1 TITLE ARITHMETIC PRIMITIVES FOR MUDDLE
3 .GLOBAL HI,RLOW,CPLUS,CMINUS,CTIMES,CDIVID,CFIX,CFLOAT
4 .GLOBAL CLQ,CGQ,CLEQ,CGEQ,C1Q,C0Q,CMAX,CMIN,CABS,CMOD,CCOS,CSIN,CATAN,CLOG
5 .GLOBAL CEXP,CSQRT,CTIME,CORB,CXORB,CANDB,CEQVB,CRAND,CLSH,CROT,
6 .GLOBAL SAT,BFLOAT,FLGSET
10 ;DEFINES MUDDLE PRIMITIVES: FIX,FLOAT,ATAN,IEXP,LOG,
11 ; G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM,
42 YES: MOVSI A,TATOM ;RETURN PATH FOR 'TRUE'
47 NO: MOVSI A,TFALSE ;RETURN PATH FOR 'FALSE'
51 \f;ERROR RETURNS AND OTHER UTILITY ROUTINES
54 OVRFLD: ERRUUO EQUOTE OVERFLOW
56 CARGCH: GETYP 0,A ; GET TYPE
62 ARGCHK: ;CHECK FOR SINGLE FIXED OR FLOATING
63 ;ARGUMENT IF FIXED CONVERT TO FLOATING
64 ;RETURN FLOATING ARGRUMENT IN B ALWAYS
68 CAIN C,TFLOAT ;FLOATING?
72 JSP A,BFLOAT ;YES, CONVERT TO FLOATING AND RETURN
75 OUTRNG: ERRUUO EQUOTE ARGUMENT-OUT-OF-RANGE
77 NSQRT: ERRUUO EQUOTE NEGATIVE-ARGUMENT
98 \f;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES
100 TABLE2: SETZ NO ;TABLE2 (0)
101 TABLE3: SETZ YES ;TABLE2 (1) & TABLE3 (0)
147 \f;PRIMITIVES FLOAT AND FIX
160 IMFUNCTION FLOAT,SUBR
199 MOVIT: MOVM B,VAL1 ;GET ABSOLUTE VALUE OF ARGUMENT
200 AFINIS: HRLZS A ;MOVE TYPE CODE INTO LEFT HALF
208 CAIE A,TFIX ;FIRST ARG FIXED ?
211 CAIE A,TFIX ;SECOND ARG FIXED ?
214 IDIV A,VAL2 ;FORM QUOTIENT & REMAINDER
215 JUMPGE B,.+2 ;Only return positive remainders
219 \f;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX
235 MFUNCTION DIVIDE,SUBR,[/]
242 MFUNCTION DIFFERENCE,SUBR,[-]
249 IMFUNCTION TIMES,SUBR,[*]
256 MFUNCTION PLUS,SUBR,[+]
262 GOPT: MOVE D,AB ;ARGUMENT POINTER
269 ; BUILD COMPILER ENTRIES TO THESE ROUTINES
271 IRP NAME,,[CMINUS,CDIVID,CPLUS,CTIMES,CMIN,CMAX]CODE,,[2,3,4,5,6,7]
280 SUBM TP,D ; POINT TO ARGS
289 CARITH: MOVE B,DEFVAL(E) ; GET VAL
291 MOVEI 0,TFIX ; FIX UNTIL CHANGE
292 JUMPN A,ARITH0 ; AT LEAST ONE ARG
296 ARITH0: SOJE A,ARITH1 ; FALL IN WITH ONE ARG
298 GETYP C,(D) ; TYPE OF 1ST ARG
299 ADD D,[2,,2] ; GO TO NEXT
306 ARITH1: GETYP C,0(D) ; GET NEXT TYPE
308 JRST ARITH2 ; TO FLOAT LOOP
311 SOJG A,ARITH1 ; KEEP ADDING OR WHATEVER
318 MOVE 0,1(D) ; GET ARG
322 JSP C,OFLOAT ; FLOAT IT
325 ARITH4: CAIE C,TFLOAT
329 ARITH2: CAIE C,TFLOAT ; FLOATER?
336 ARITH5: XCT FLFUNC(E)
345 SWITCH: XCT COMPAR(E) ;FOR MAX & MIN TESTING
354 FLSWCH: XCT FLCMPR(E)
360 \f;PRIMITIVES ONEP AND ZEROP
362 MFUNCTION ONEP,SUBR,[1?]
366 MFUNCTION ZEROP,SUBR,[0?]
373 CAIE A,TFLOAT ;floating ?
376 CAMN B,NUMBR(E) ;equal to correct value ?
380 TESTFX: CAMN E,VAL1 ;equal to correct value ?
391 NUMBR: 0 ;FLOATING PT ZERO
392 201400,,0 ;FLOATING PT ONE
393 \f;PRIMITIVES LESSP AND GREATERP
395 MFUNCTION LEQP,SUBR,[L=?]
399 MFUNCTION GEQP,SUBR,[G=?]
404 MFUNCTION LESSP,SUBR,[L?]
408 MFUNCTION GREATERP,SUBR,[G?]
426 ; COMPILERS ENTRIES TO THESE GUYS
428 IRP NAME,,[CGQ,CLQ,CGEQ,CLEQ]COD,,[0,1,2,3]
437 JRST COMPD ; COMPARING FIX AND FLOAT
456 MFUNCTION RANDOM,SUBR
459 CAMGE A,[-4] ;At most two arguments to random to set seeds
462 MOVE B,VAL2 ;Set second seed
464 MOVE A,VAL1 ;Set first seed
466 RANDGO: PUSHJ P,CRAND
471 MOVEM A,RLOW ;Update Low seed
472 LSHC A,-1 ;Shift both right one bit
473 XORB B,RHI ;Generate output and update High seed
478 \fMFUNCTION SQRT,SUBR
487 SQ2: MOVE C,B ;NEWTON'S METHOD, SPECINER'S HACK.
498 FADR B,[1.570796326] ;COS(X)=SIN (X+PI/2)
511 POPJ P, ;GOSPER'S RECURSIVE SIN.
512 FDVR B,[-3.0] ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3)
520 CSQRT: PUSHJ P,CARGCH
533 PUSHJ P,ARGCHK ;LEAVES ARGUMENT IN B
539 ILOG: JUMPLE B,OUTRNG
540 LDB D,[331100,,B] ;GRAB EXPONENT
541 SUBI D,201 ;REMOVE BIAS
542 TLZ B,777000 ;SET EXPONENT
561 FMPR B,[0.693147180] ;LOG E OF 2
566 \fMFUNCTION ATAN,SUBR
571 CATAN: PUSHJ P,CARGCH
575 CAMG D,[0.4^-8] ;SMALL ENOUGH SO ATAN(X)=X?
577 CAML D,[7.0^7] ;LARGE ENOUGH SO THAT ATAN(X)=PI/2?
580 CAMLE D,[1.0] ;IS ABS(X)<1.0?
581 FDVM C,D ;NO,SCALE IT DOWN
586 MOVE A,[-0.264768620]
598 JUMPG D,ATAN2 ;WAS ARG SCALED?
599 FADR B,PI2 ;YES, ATAN(X)=PI/2-ATAN(1/X)
602 ATAN2: SKIPGE (P) ;WAS INPUT NEGATIVE?
603 MOVNS B ;YES,COMPLEMENT
604 ATAN3: MOVSI A,TFLOAT
609 \fMFUNCTION IEXP,SUBR,[EXP]
610 PUSHJ P,ARGCHK ;LEAVE FLOATING POINT ARG IN B
619 FMPR A,[0.434294481] ;LOG BASE 10 OF E
629 EXPR1: FMPR D,FLOAP1(B)
636 RATEY: FADR C,COEF2-1(B)
643 SKIPL (P) ;SKIP IF INPUT NEGATIVE
650 EXPR2: LDB E,[030300,,B]
653 FMPR D,D ;TO THE 8TH POWER
675 ;LSH AND ROT (ERB WOULD BE PLEASED) PDL 2/22/79
677 MFUNCTION %LSH,SUBR,LSH
682 MFUNCTION %ROT,SUBR,ROT
698 ;BITWISE BOOLEAN FUNCTIONS
700 MFUNCTION %ANDB,SUBR,ANDB
702 HRREI B,-1 ;START ANDING WITH ALL ONES
703 MOVE D,[AND B,A] ;LOGICAL INSTRUCTION
704 JRST LOGFUN ;DO THE OPERATION
706 MFUNCTION %ORB,SUBR,ORB
712 MFUNCTION %XORB,SUBR,XORB
718 MFUNCTION %EQVB,SUBR,EQVB
723 LOGFUN: JUMPGE AB,ZROARG
724 LOGTYP: GETYP A,(AB) ;GRAB THE TYPE
725 PUSHJ P,SAT ;STORAGE ALLOCATION TYPE
727 JRST WRONGT ;WRONG TYPE...LOSE
728 MOVE A,1(AB) ;LOAD ARG INTO A
729 XCT D ;DO THE LOGICAL OPERATION
730 AOBJP AB,.+2 ;ADD ONE TO BOTH HALVES
731 AOBJN AB,LOGTYP ;ADD AGAIN AND LOOP IF NEEDED
733 ZROARG: MOVE A,$TWORD
736 ;routine to sort lists or vectors of either fixed point or floating numbers
737 ;the components are interchanged repeatedly to acheive the sort
738 ;first arg: the structure to be sorted
739 ;if no second arg sort in descending order
740 ;second arg: if false then sort in ascending order
741 ; else sort in descending order
746 CAIGE A,-4 ;Only two arguments allowed
748 MOVE O,DESCEND ;Set up "O" to test for descending order as default condition
749 CAIE A,-4 ;Optional second argument?
751 GETYP B,TYP2 ;See if it is other than false
753 MOVE O,ASCEND ;Set up "O" to test for ascending order
754 GETYP A,TYP1 ;CHECK TYPE OF FIRST ARGUMENT
764 GOBACK: MOVE A,TYP1 ;RETURN THE SORTED ARGUMENT AS VALUE
768 DESCEND: CAMG C,(A)+1
770 \f;ROUTINE TO SORT LISTS IN NUMERICAL ORDER
773 JUMPE A,GOBACK ;EMPTY LIST?
774 HLRZ B,(A) ;TYPE OF FIRST COMPONENT
779 MOVEI E,0 ;FOR COUNT OF LENGTH OF LIST
780 LCOUNT: JUMPE A,LLSORT ;REACHED END OF LIST?
781 MOVE A,(A) ;NEXT COMPONENT
782 TLZ A,(B) ;SAME TYPE AS FIRST COMPONENT?
785 AOJA E,LCOUNT ;INCREMENT COUNT AND CONTINUE
787 LLSORT: SOJE E,GOBACK ;FINISHED WITH SORTING?
788 HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING
789 MOVEM E,(P)+1 ;Save the iteration depth
790 CLSORT: HRRZ B,(A) ;NEXT COMPONENT
791 MOVE C,(B)+1 ;ITS VALUE
792 XCT O ;ARE THESE TWO COMPONENTS IN ORDER?
794 MOVE D,(A)+1 ;INTERCHANGE THEM
797 MOVE A,B ;MAKE THE COMPONENT IN "B" THE CURRENT ONE
799 MOVE E,(P)+1 ;Restore the iteration depth
801 \f;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER
803 VSORT: HLRE D,VAL1 ;GET COUNT FIELD OF VECTOR
805 JUMPE D,GOBACK ;EMPTY VECTOR?
806 MOVE E,D ;SAVE LENGTH IN "E"
807 HRRZ A,VAL1 ;POINTER TO VECTOR
808 MOVE B,(A) ;TYPE OF FIRST COMPONENT
813 SOJLE D,GOBACK ;IF ONLY ONE COMPONENT THEN FINISHED
814 VCOUNT: ADDI A,2 ;CHECK NEXT COMPONENT
815 CAME B,(A) ;SAME TYPE AS FIRST COMPONENT?
817 SOJG D,VCOUNT ;CONTINUE WITH NEXT COMPONENT
819 VVSORT: SOJE E,GOBACK ;FINISHED SORTING?
820 HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING
821 MOVEM E,(P)+1 ;Save the iteration depth
822 CVSORT: MOVE C,(A)+3 ;VALUE OF NEXT COMPONENT
823 XCT O ;ARE THESE TWO COMPONENTS IN ORDER?
825 MOVE D,(A)+1 ;INTERCHANGE THEM
828 ADDI A,2 ;UPDATE THE CURRENT COMPONENT
830 MOVE E,(P)+1 ;Restore the iteration depth
834 MFUNCTION OVERFLOW,SUBR