1 TITLE ARITHMETIC PRIMITIVES FOR MUDDLE
5 ;DEFINES MUDDLE PRIMITIVES: FIX,FLOAT,ATAN,IEXP,LOG,
6 ; G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM,
37 YES: MOVSI A,TATOM ;RETURN PATH FOR 'TRUE'
41 NO: MOVSI A,TFALSE ;RETURN PATH FOR 'FALSE'
45 \f;ERROR RETURNS AND OTHER UTILITY ROUTINES
48 OVRFLD: PUSH TP,$TATOM
49 PUSH TP,MQUOTE OVERFLOW
52 ARGCHK: ;CHECK FOR SINGLE FIXED OR FLOATING
53 ;ARGUMENT IF FIXED CONVERT TO FLOATING
54 ;RETURN FLOATING ARGRUMENT IN B ALWAYS
58 CAIN C,TFLOAT ;FLOATING?
62 JSP A,BFLOAT ;YES, CONVERT TO FLOATING AND RETURN
65 OUTRNG: PUSH TP,$TATOM
66 PUSH TP,MQUOTE ARGUMENT-OUT-OF-RANGE
70 PUSH TP,MQUOTE NEGATIVE-ARGUMENT
74 PUSH TP,MQUOTE WRONG-TYPE
96 \f;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES
98 TABLE2: NO ;TABLE2 (0)
99 TABLE3: YES ;TABLE2 (1) & TABLE3 (0)
119 \f;PRIMITIVES FLOAT AND FIX
131 CAMN A,TYPS(E)+1 ;SAME TYPE ARGUMENT?
133 CAME A,TYPS(E) ;correct type argument ?
135 XCT FUNC(E) ;perform appropriate operation
136 MOVE A,TYPS(E)+1 ;save this new type
150 MOVIT: MOVM B,VAL1 ;GET ABSOLUTE VALUE OF ARGUMENT
156 CAME A,TYP1 ;FIRST ARG FIXED ?
158 CAME A,TYP2 ;SECOND ARG FIXED ?
161 IDIV B,VAL2 ;FORM QUOTIENT & REMAINDER
162 JUMPGE C,.+2 ;Only return positive remainders
164 MOVE B,C ;RETURN REMAINDER
166 \f;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX
175 MOVE D,AB ;ARGUMENT POINTER
176 JUMPL D,MINMAX ;ANY ARGUMENTS AT ALL ?
177 MOVSI A,TFLOAT ;DEFAULT TYPE
178 MOVE B,INFIN(E) ;DEFAULT VALUE + OR - "LARGE NUMBER"
184 MFUNCTION DIVIDE,SUBR,[/]
188 MFUNCTION DIFFERENCE,SUBR,[-]
192 MFUNCTION TIMES,SUBR,[*]
196 MFUNCTION PLUS,SUBR,[+]
200 MOVE D,AB ;argument pointer
201 CAMGE D,[-2,,0] ;LESS THAN TWO ARGUMENTS ?
203 MOVSI A,TFIX ;initial type of result
204 MOVE B,E ;initial accumulator contents for zero & one argument
208 MOVE B,VAL1 ;initial value of accumulator for more than one argument is first value
209 ADD D,[2,,2] ;UPDATE ARGUMENT POINTER
210 JUMPGE D,FINIS ;ANY MORE ARGUMENTS ?
212 CAME A,$TFIX ;WAS THE FIRST ARGUMENT FIXED ?
214 ARITH1: CAME A,TYPN ;next argument fixed ?
216 XCT FUNC(E) ;PERFORM APPROPRIATE OPERATION
217 ADD D,[2,,2] ;UPDATE ARGUMENT POINTER
218 JUMPL D,ARITH1 ;repeat for next argument if any
221 \f;CONTINUATION OF PLUS,TIMES, ETC.
223 ARITH3: CAME A,$TFLOAT ;was the first argument floating ?
227 ARITH2: JSP A,BFLOAT ;float accumulator contents
228 MOVE C,TYPN ;get next argument's type
229 MOVE O,VALN ;get next argument's value
230 CAMN C,$TFLOAT ;floating ?
232 CAME C,$TFIX ;fixed ?
234 JSP C,OFLOAT ;go float this fixed argument
235 OPERATE: XCT FLFUNC(E) ;perform appropriate operation
236 ADD D,[2,,2] ;UPDATE ARGUMENT POINTER
237 JUMPL D,ARITH2+1 ;repeat for next argument if any
242 SWITCH: XCT COMPAR(E) ;FOR MAX & MIN TESTING
249 FLSWCH: XCT FLCMPR(E)
255 \f;PRIMITIVES ONEP AND ZEROP
257 MFUNCTION ONEP,SUBR,[1?]
261 MFUNCTION ZEROP,SUBR,[0?]
266 CAMN A,$TFIX ;fixed ?
268 CAME A,$TFLOAT ;floating ?
271 CAMN B,NUMBR(E) ;equal to correct value ?
275 TESTFX: CAMN E,VAL1 ;equal to correct value ?
279 NUMBR: 0 ;FLOATING PT ZERO
280 201400,,0 ;FLOATING PT ONE
281 \f;PRIMITIVES LESSP AND GREATERP
284 MFUNCTION LESSP,SUBR,[L?]
288 MFUNCTION GREATERP,SUBR,[G?]
295 SETO D, ;used for flow of control in this routine
302 AOJE D,FIXFIX ;are both arguments fixed
305 JUMPE D,FLTFLT ;are both arguments floating ?
306 JSP C,OFLOAT ;go float the first argument
307 FLTFLT: FSBR O,B ;both arguments are floating here
308 TEST: JUMPL O,@TABLE2(E)
312 FLTFIX: JUMPLE D,WTYP
313 JSP A,BFLOAT ;go float the second argument
316 FIXFIX: SUB O,B ;both arguments are fixed here
319 MFUNCTION RANDOM,SUBR
322 CAMGE A,[-4] ;At most two arguments to random to set seeds
325 MOVE B,VAL2 ;Set second seed
327 MOVE A,VAL1 ;Set first seed
329 RANDGO: MOVE B,RLOW ;FREDKIN'S RANDOM NUMBER GENERATOR.
338 \fMFUNCTION SQRT,SUBR
352 SQ2: MOVE C,B ;NEWTON'S METHOD, SPECINER'S HACK.
371 COS1: FADR B,[1.570796326] ;COS(X)=SIN (X+PI/2)
391 POPJ P, ;GOSPER'S RECURSIVE SIN.
392 FDVR B,[-3.0] ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3)
400 PUSHJ P,ARGCHK ;LEAVES ARGUMENT IN B
402 LDB D,[331100,,B] ;GRAB EXPONENT
403 SUBI D,201 ;REMOVE BIAS
404 TLZ B,777000 ;SET EXPONENT
424 FMPR B,[0.693147180] ;LOG E OF 2
428 \fMFUNCTION ATAN,SUBR
431 CAMG D,[0.4^-8] ;SMALL ENOUGH SO ATAN(X)=X?
433 CAML D,[7.0^7] ;LARGE ENOUGH SO THAT ATAN(X)=PI/2?
436 CAMLE D,[1.0] ;IS ABS(X)<1.0?
437 FDVM C,D ;NO,SCALE IT DOWN
442 MOVE A,[-0.264768620]
454 JUMPG D,ATAN2 ;WAS ARG SCALED?
455 FADR B,PI2 ;YES, ATAN(X)=PI/2-ATAN(1/X)
458 ATAN2: SKIPGE 1(AB) ;WAS INPUT NEGATIVE?
459 MOVNS B ;YES,COMPLEMENT
460 ATAN3: MOVSI A,TFLOAT
463 \fMFUNCTION IEXP,SUBR,[EXP]
464 PUSHJ P,ARGCHK ;LEAVE FLOATING POINT ARG IN B
467 FMPR A,[0.434294481] ;LOG BASE 10 OF E
477 EXPR1: FMPR D,FLOAP1(B)
484 RATEY: FADR C,COEF2-1(B)
491 SKIPL 1(AB) ;SKIP IF INPUT NEGATIVE
496 EXPR2: LDB E,[030300,,B]
499 FMPR D,D ;TO THE 8TH POWER
520 \f;routine to sort lists or vectors of either fixed point or floating numbers
521 ;the components are interchanged repeatedly to acheive the sort
522 ;first arg: the structure to be sorted
523 ;if no second arg sort in descending order
524 ;second arg: if false then sort in ascending order
525 ; else sort in descending order
530 CAIGE A,-4 ;Only two arguments allowed
532 MOVE O,DESCEND ;Set up "O" to test for descending order as default condition
533 CAIE A,-4 ;Optional second argument?
535 HLRZ B,TYP2 ;See if it is other than false
537 MOVE O,ASCEND ;Set up "O" to test for ascending order
538 HLRZ A,TYP1 ;CHECK TYPE OF FIRST ARGUMENT
548 GOBACK: MOVE A,TYP1 ;RETURN THE SORTED ARGUMENT AS VALUE
552 DESCEND: CAMG C,(A)+1
554 \f;ROUTINE TO SORT LISTS IN NUMERICAL ORDER
557 JUMPE A,GOBACK ;EMPTY LIST?
558 HLRZ B,(A) ;TYPE OF FIRST COMPONENT
563 MOVEI E,0 ;FOR COUNT OF LENGTH OF LIST
564 LCOUNT: JUMPE A,LLSORT ;REACHED END OF LIST?
565 MOVE A,(A) ;NEXT COMPONENT
566 TLZ A,(B) ;SAME TYPE AS FIRST COMPONENT?
569 AOJA E,LCOUNT ;INCREMENT COUNT AND CONTINUE
571 LLSORT: SOJE E,GOBACK ;FINISHED WITH SORTING?
572 HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING
573 MOVEM E,(P)+1 ;Save the iteration depth
574 CLSORT: HRRZ B,(A) ;NEXT COMPONENT
575 MOVE C,(B)+1 ;ITS VALUE
576 XCT O ;ARE THESE TWO COMPONENTS IN ORDER?
578 MOVE D,(A)+1 ;INTERCHANGE THEM
581 MOVE A,B ;MAKE THE COMPONENT IN "B" THE CURRENT ONE
583 MOVE E,(P)+1 ;Restore the iteration depth
585 \f;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER
587 VSORT: HLRE D,VAL1 ;GET COUNT FIELD OF VECTOR
589 JUMPE D,GOBACK ;EMPTY VECTOR?
590 MOVE E,D ;SAVE LENGTH IN "E"
591 HRRZ A,VAL1 ;POINTER TO VECTOR
592 MOVE B,(A) ;TYPE OF FIRST COMPONENT
597 SOJLE D,GOBACK ;IF ONLY ONE COMPONENT THEN FINISHED
598 VCOUNT: ADDI A,2 ;CHECK NEXT COMPONENT
599 CAME B,(A) ;SAME TYPE AS FIRST COMPONENT?
601 SOJG D,VCOUNT ;CONTINUE WITH NEXT COMPONENT
603 VVSORT: SOJE E,GOBACK ;FINISHED SORTING?
604 HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING
605 MOVEM E,(P)+1 ;Save the iteration depth
606 CVSORT: MOVE C,(A)+3 ;VALUE OF NEXT COMPONENT
607 XCT O ;ARE THESE TWO COMPONENTS IN ORDER?
609 MOVE D,(A)+1 ;INTERCHANGE THEM
612 ADDI A,2 ;UPDATE THE CURRENT COMPONENT
614 MOVE E,(P)+1 ;Restore the iteration depth
620 .RDTIME B, ;Get time since SYSTEM up