TITLE ARITHMETIC PRIMITIVES FOR MUDDLE .GLOBAL HI,RLOW,CPLUS,CMINUS,CTIMES,CDIVID,CFIX,CFLOAT .GLOBAL CLQ,CGQ,CLEQ,CGEQ,C1Q,C0Q,CMAX,CMIN,CABS,CMOD,CCOS,CSIN,CATAN,CLOG .GLOBAL CEXP,CSQRT,CTIME,CORB,CXORB,CANDB,CEQVB,CRAND,CLSH,CROT, .GLOBAL SAT,BFLOAT,FLGSET ;BKD ;DEFINES MUDDLE PRIMITIVES: FIX,FLOAT,ATAN,IEXP,LOG, ; G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM, ; TIME,SORT. RELOCATABLE .INSRT MUDDLE > O=0 DEFINE TYP1 (AB) TERMIN DEFINE VAL1 (AB)+1 TERMIN DEFINE TYP2 (AB)+2 TERMIN DEFINE VAL2 (AB)+3 TERMIN DEFINE TYP3 (AB)+4 TERMIN DEFINE VAL3 (AB)+5 TERMIN DEFINE TYPN (D) TERMIN DEFINE VALN (D)+1 TERMIN YES: MOVSI A,TATOM ;RETURN PATH FOR 'TRUE' MOVE B,IMQUOTE T AOS (P) POPJ P, NO: MOVSI A,TFALSE ;RETURN PATH FOR 'FALSE' MOVEI B,NIL POPJ P, ;ERROR RETURNS AND OTHER UTILITY ROUTINES OVRFLW==10 OVRFLD: ERRUUO EQUOTE OVERFLOW CARGCH: GETYP 0,A ; GET TYPE CAIN 0,TFLOAT POPJ P, JSP A,BFLOAT POPJ P, ARGCHK: ;CHECK FOR SINGLE FIXED OR FLOATING ;ARGUMENT IF FIXED CONVERT TO FLOATING ;RETURN FLOATING ARGRUMENT IN B ALWAYS ENTRY 1 GETYP C,TYP1 MOVE B,VAL1 CAIN C,TFLOAT ;FLOATING? POPJ P, ;YES, RETURN CAIE C,TFIX ;FIXED? JRST WTYP1 ;NO, ERROR JSP A,BFLOAT ;YES, CONVERT TO FLOATING AND RETURN POPJ P, OUTRNG: ERRUUO EQUOTE ARGUMENT-OUT-OF-RANGE NSQRT: ERRUUO EQUOTE NEGATIVE-ARGUMENT DEFINE MFLOAT AC IDIVI AC,400000 FSC AC+1,233 FSC AC,254 FADR AC,AC+1 TERMIN BFLOAT: MFLOAT B JRST (A) OFLOAT: MFLOAT O JRST (C) BFIX: MULI B,400 TSC B,B ASH C,(B)-243 MOVE B,C JRST (A) ;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES TABLE2: SETZ NO ;TABLE2 (0) TABLE3: SETZ YES ;TABLE2 (1) & TABLE3 (0) SETZ NO ;TABLE2 (2) SETZ YES SETZ NO TABLE4: SETZ NO SETZ NO SETZ YES SETZ YES FUNC: JSP A,BFIX JSP A,BFLOAT SUB B,VALN IDIV B,VALN ADD B,VALN IMUL B,VALN JSP C,SWITCH JSP C,SWITCH FLFUNC==.-2 FSBR B,O FDVR B,O FADR B,O FMPR B,O JSP C,FLSWCH JSP C,FLSWCH DEFVAL==.-2 0 1 0 1 377777,,-1 400000,,1 DEFTYP==.-2 TFIX,, TFIX,, TFIX,, TFIX,, TFLOAT,, TFLOAT,, ;PRIMITIVES FLOAT AND FIX IMFUNCTION FIX,SUBR ENTRY 1 JSP C,FXFL MOVE B,1(AB) CAIE A,TFIX JSP A,BFIX MOVSI A,TFIX JRST FINIS IMFUNCTION FLOAT,SUBR ENTRY 1 JSP C,FXFL MOVE B,1(AB) CAIE A,TFLOAT JSP A,BFLOAT MOVSI A,TFLOAT JRST FINIS CFIX: GETYP 0,A CAIN 0,TFIX POPJ P, JSP A,BFIX MOVSI A,TFIX POPJ P, CFLOAT: GETYP 0,A CAIN 0,TFLOAT POPJ P, JSP A,BFLOAT MOVSI A,TFLOAT POPJ P, FXFL: GETYP A,(AB) CAIE A,TFIX CAIN A,TFLOAT JRST (C) JRST WTYP1 MFUNCTION ABS,SUBR ENTRY 1 GETYP A,TYP1 CAIE A,TFIX CAIN A,TFLOAT JRST MOVIT JRST WTYP1 MOVIT: MOVM B,VAL1 ;GET ABSOLUTE VALUE OF ARGUMENT AFINIS: HRLZS A ;MOVE TYPE CODE INTO LEFT HALF JRST FINIS MFUNCTION MOD,SUBR ENTRY 2 GETYP A,TYP1 CAIE A,TFIX ;FIRST ARG FIXED ? JRST WTYP1 GETYP A,TYP2 CAIE A,TFIX ;SECOND ARG FIXED ? JRST WTYP2 MOVE A,VAL1 IDIV A,VAL2 ;FORM QUOTIENT & REMAINDER JUMPGE B,.+2 ;Only return positive remainders ADD B,VAL2 MOVSI A,TFIX JRST FINIS ;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX MFUNCTION MIN,SUBR ENTRY MOVEI E,6 JRST GOPT IMFUNCTION MAX,SUBR ENTRY MOVEI E,7 JRST GOPT MFUNCTION DIVIDE,SUBR,[/] ENTRY MOVEI E,3 JRST GOPT MFUNCTION DIFFERENCE,SUBR,[-] ENTRY MOVEI E,2 JRST GOPT IMFUNCTION TIMES,SUBR,[*] ENTRY MOVEI E,5 JRST GOPT MFUNCTION PLUS,SUBR,[+] ENTRY MOVEI E,4 GOPT: MOVE D,AB ;ARGUMENT POINTER HLRE A,AB MOVMS A ASH A,-1 PUSHJ P,CARITH JRST FINIS ; BUILD COMPILER ENTRIES TO THESE ROUTINES IRP NAME,,[CMINUS,CDIVID,CPLUS,CTIMES,CMIN,CMAX]CODE,,[2,3,4,5,6,7] NAME: MOVEI E,CODE JRST CARIT1 TERMIN CARIT1: MOVEI D,(A) ASH D,1 ; TIMES 2 HRLI D,(D) SUBM TP,D ; POINT TO ARGS PUSH TP,$TTP AOBJN D,.+1 PUSH TP,D PUSHJ P,CARITH MOVE TP,(TP) SUB TP,[1,,1] POPJ P, CARITH: MOVE B,DEFVAL(E) ; GET VAL JFCL OVRFLW,.+1 MOVEI 0,TFIX ; FIX UNTIL CHANGE JUMPN A,ARITH0 ; AT LEAST ONE ARG MOVE A,DEFTYP(E) POPJ P, ARITH0: SOJE A,ARITH1 ; FALL IN WITH ONE ARG MOVE B,1(D) GETYP C,(D) ; TYPE OF 1ST ARG ADD D,[2,,2] ; GO TO NEXT CAIN C,TFLOAT JRST ARITH3 CAIN C,TFIX JRST ARITH1 JRST WRONGT ARITH1: GETYP C,0(D) ; GET NEXT TYPE CAIE C,TFIX JRST ARITH2 ; TO FLOAT LOOP XCT FUNC(E) ; DO IT ADD D,[2,,2] SOJG A,ARITH1 ; KEEP ADDING OR WHATEVER SKIPE OVFLG JFCL OVRFLW,OVRFLD MOVSI A,TFIX POPJ P, ARITH3: GETYP C,0(D) MOVE 0,1(D) ; GET ARG CAIE C,TFIX JRST ARITH4 PUSH P,A JSP C,OFLOAT ; FLOAT IT POP P,A JRST ARITH5 ARITH4: CAIE C,TFLOAT JRST WRONGT JRST ARITH5 ARITH2: CAIE C,TFLOAT ; FLOATER? JRST WRONGT PUSH P,A JSP A,BFLOAT POP P,A MOVE 0,1(D) ARITH5: XCT FLFUNC(E) ADD D,[2,,2] SOJG A,ARITH3 SKIPE OVFLG JFCL OVRFLW,OVRFLD MOVSI A,TFLOAT POPJ P, SWITCH: XCT COMPAR(E) ;FOR MAX & MIN TESTING MOVE B,VALN JRST (C) COMPAR==.-6 CAMLE B,VALN CAMGE B,VALN FLSWCH: XCT FLCMPR(E) MOVE B,O JRST (C) FLCMPR==.-6 CAMLE B,O CAMGE B,O ;PRIMITIVES ONEP AND ZEROP MFUNCTION ONEP,SUBR,[1?] MOVEI E,1 JRST JOIN MFUNCTION ZEROP,SUBR,[0?] MOVEI E, JOIN: ENTRY 1 GETYP A,TYP1 CAIN A,TFIX ;fixed ? JRST TESTFX CAIE A,TFLOAT ;floating ? JRST WTYP1 MOVE B,VAL1 CAMN B,NUMBR(E) ;equal to correct value ? JRST YES1 JRST NO1 TESTFX: CAMN E,VAL1 ;equal to correct value ? JRST YES1 NO1: MOVSI A,TFALSE MOVEI B,0 JRST FINIS YES1: MOVSI A,TATOM MOVE B,IMQUOTE T JRST FINIS NUMBR: 0 ;FLOATING PT ZERO 201400,,0 ;FLOATING PT ONE ;PRIMITIVES LESSP AND GREATERP MFUNCTION LEQP,SUBR,[L=?] MOVEI E,3 JRST ARGS MFUNCTION GEQP,SUBR,[G=?] MOVEI E,2 JRST ARGS MFUNCTION LESSP,SUBR,[L?] MOVEI E,1 JRST ARGS MFUNCTION GREATERP,SUBR,[G?] MOVEI E,0 ARGS: ENTRY 2 MOVE B,VAL1 MOVE A,TYP1 GETYP 0,A PUSHJ P,CMPTYP JRST WTYP1 MOVE D,VAL2 MOVE C,TYP2 GETYP 0,C PUSHJ P,CMPTYP JRST WTYP2 PUSHJ P,ACOMPS JFCL JRST FINIS ; COMPILERS ENTRIES TO THESE GUYS IRP NAME,,[CGQ,CLQ,CGEQ,CLEQ]COD,,[0,1,2,3] NAME: MOVEI E,COD JRST ACOMPS TERMIN ACOMPS: GETYP A,A GETYP 0,C CAIE 0,(A) JRST COMPD ; COMPARING FIX AND FLOAT TEST: CAMN B,D JRST @TABLE4(E) CAMG B,D JRST @TABLE2(E) JRST @TABLE3(E) CMPTYP: CAIE 0,TFIX CAIN 0,TFLOAT AOS (P) POPJ P, COMPD: EXCH B,D CAIN A,TFLOAT JSP A,BFLOAT EXCH B,D CAIN 0,TFLOAT JSP A,BFLOAT COMPF: JRST TEST MFUNCTION RANDOM,SUBR ENTRY HLRE A,AB CAMGE A,[-4] ;At most two arguments to random to set seeds JRST TMA JRST RANDGO(A) MOVE B,VAL2 ;Set second seed MOVEM B,RLOW MOVE A,VAL1 ;Set first seed MOVEM A,RHI RANDGO: PUSHJ P,CRAND JRST FINIS CRAND: MOVE A,RHI MOVE B,RLOW MOVEM A,RLOW ;Update Low seed LSHC A,-1 ;Shift both right one bit XORB B,RHI ;Generate output and update High seed MOVSI A,TFIX POPJ P, MFUNCTION SQRT,SUBR PUSHJ P,ARGCHK JUMPL B,NSQRT PUSHJ P,ISQRT JRST FINIS ISQRT: MOVE A,B ASH B,-1 FSC B,100 SQ2: MOVE C,B ;NEWTON'S METHOD, SPECINER'S HACK. FDVRM A,B FADRM C,B FSC B,-1 CAME C,B JRST SQ2 MOVSI A,TFLOAT POPJ P, MFUNCTION COS,SUBR PUSHJ P,ARGCHK FADR B,[1.570796326] ;COS(X)=SIN (X+PI/2) PUSHJ P,.SIN MOVSI A,TFLOAT JRST FINIS MFUNCTION SIN,SUBR PUSHJ P,ARGCHK PUSHJ P,.SIN MOVSI A,TFLOAT JRST FINIS .SIN: MOVM A,B CAMG A,[.0001] POPJ P, ;GOSPER'S RECURSIVE SIN. FDVR B,[-3.0] ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3) PUSHJ P,.SIN FSC A,1 FMPR A,A FADR A,[-3.0] FMPRB A,B POPJ P, CSQRT: PUSHJ P,CARGCH JUMPL B,NSQRT JRST ISQRT CSIN: PUSHJ P,CARGCH CSIN1: PUSHJ P,.SIN MOVSI A,TFLOAT POPJ P, CCOS: PUSHJ P,CARGCH FADR B,[1.570796326] JRST CSIN1 MFUNCTION LOG,SUBR PUSHJ P,ARGCHK ;LEAVES ARGUMENT IN B PUSHJ P,ILOG JRST FINIS CLOG: PUSHJ P,CARGCH ILOG: JUMPLE B,OUTRNG LDB D,[331100,,B] ;GRAB EXPONENT SUBI D,201 ;REMOVE BIAS TLZ B,777000 ;SET EXPONENT TLO B,201000 ; TO 1 MOVE A,B FSBR A,RT2 FADR B,RT2 FDVB A,B FMPR B,B MOVE C,[0.434259751] FMPR C,B FADR C,[0.576584342] FMPR C,B FADR C,[0.961800762] FMPR C,B FADR C,[2.88539007] FMPR C,A FADR C,[0.5] MOVE B,D FSC B,233 FADR B,C FMPR B,[0.693147180] ;LOG E OF 2 MOVSI A,TFLOAT POPJ P, RT2: 1.41421356 MFUNCTION ATAN,SUBR PUSHJ P,ARGCHK PUSHJ P,IATAN JRST FINIS CATAN: PUSHJ P,CARGCH IATAN: PUSH P,B MOVM D,B CAMG D,[0.4^-8] ;SMALL ENOUGH SO ATAN(X)=X? JRST ATAN3 ;YES CAML D,[7.0^7] ;LARGE ENOUGH SO THAT ATAN(X)=PI/2? JRST ATAN1 ;YES MOVN C,[1.0] CAMLE D,[1.0] ;IS ABS(X)<1.0? FDVM C,D ;NO,SCALE IT DOWN MOVE B,D FMPR B,B MOVE C,[1.44863154] FADR C,B MOVE A,[-0.264768620] FDVM A,C FADR C,B FADR C,[3.31633543] MOVE A,[-7.10676005] FDVM A,C FADR C,B FADR C,[6.76213924] MOVE B,[3.70925626] FDVR B,C FADR B,[0.174655439] FMPR B,D JUMPG D,ATAN2 ;WAS ARG SCALED? FADR B,PI2 ;YES, ATAN(X)=PI/2-ATAN(1/X) JRST ATAN2 ATAN1: MOVE B,PI2 ATAN2: SKIPGE (P) ;WAS INPUT NEGATIVE? MOVNS B ;YES,COMPLEMENT ATAN3: MOVSI A,TFLOAT SUB P,[1,,1] POPJ P, PI2: 1.57079632 MFUNCTION IEXP,SUBR,[EXP] PUSHJ P,ARGCHK ;LEAVE FLOATING POINT ARG IN B PUSHJ P,IIEXP JRST FINIS CEXP: PUSHJ P,CARGCH IIEXP: PUSH P,B MOVM A,B SETZM B FMPR A,[0.434294481] ;LOG BASE 10 OF E MOVE D,[1.0] CAMG A,D JRST RATEX MULI A,400 ASHC B,-243(A) CAILE B,43 JRST OUTRNG CAILE B,7 JRST EXPR2 EXPR1: FMPR D,FLOAP1(B) LDB A,[103300,,C] SKIPE A TLO A,177000 FADR A,A RATEX: MOVEI B,7 SETZM C RATEY: FADR C,COEF2-1(B) FMPR C,A SOJN B,RATEY FADR C,[1.0] FMPR C,C FMPR D,C MOVE B,[1.0] SKIPL (P) ;SKIP IF INPUT NEGATIVE SKIPN B,D FDVR B,D MOVSI A,TFLOAT SUB P,[1,,1] POPJ P, EXPR2: LDB E,[030300,,B] ANDI B,7 MOVE D,FLOAP1(E) FMPR D,D ;TO THE 8TH POWER FMPR D,D FMPR D,D JRST EXPR1 COEF2: 1.15129278 0.662730884 0.254393575 0.0729517367 0.0174211199 2.55491796^-3 9.3264267^-4 FLOAP1: 1.0 10.0 100.0 1000.0 10000.0 100000.0 1000000.0 10000000.0 ;LSH AND ROT (ERB WOULD BE PLEASED) PDL 2/22/79 MFUNCTION %LSH,SUBR,LSH ENTRY 2 MOVE C,[LSH B,(A)] JRST LSHROT MFUNCTION %ROT,SUBR,ROT ENTRY 2 MOVE C,[ROT B,(A)] LSHROT: GETYP A,(AB) PUSHJ P,SAT CAIE A,S1WORD JRST WRONGT GETYP A,2(AB) CAIE A,TFIX JRST WTYP2 MOVE A,3(AB) MOVE B,1(AB) XCT C MOVE A,$TWORD JRST FINIS ;BITWISE BOOLEAN FUNCTIONS MFUNCTION %ANDB,SUBR,ANDB ENTRY HRREI B,-1 ;START ANDING WITH ALL ONES MOVE D,[AND B,A] ;LOGICAL INSTRUCTION JRST LOGFUN ;DO THE OPERATION MFUNCTION %ORB,SUBR,ORB ENTRY MOVEI B,0 MOVE D,[IOR B,A] JRST LOGFUN MFUNCTION %XORB,SUBR,XORB ENTRY MOVEI B,0 MOVE D,[XOR B,A] JRST LOGFUN MFUNCTION %EQVB,SUBR,EQVB ENTRY HRREI B,-1 MOVE D,[EQV B,A] LOGFUN: JUMPGE AB,ZROARG LOGTYP: GETYP A,(AB) ;GRAB THE TYPE PUSHJ P,SAT ;STORAGE ALLOCATION TYPE CAIE A,S1WORD JRST WRONGT ;WRONG TYPE...LOSE MOVE A,1(AB) ;LOAD ARG INTO A XCT D ;DO THE LOGICAL OPERATION AOBJP AB,.+2 ;ADD ONE TO BOTH HALVES AOBJN AB,LOGTYP ;ADD AGAIN AND LOOP IF NEEDED ZROARG: MOVE A,$TWORD JRST FINIS REPEAT 0,[ ;routine to sort lists or vectors of either fixed point or floating numbers ;the components are interchanged repeatedly to acheive the sort ;first arg: the structure to be sorted ;if no second arg sort in descending order ;second arg: if false then sort in ascending order ; else sort in descending order MFUNCTION SORT,SUBR ENTRY HLRZ A,AB CAIGE A,-4 ;Only two arguments allowed JRST TMA MOVE O,DESCEND ;Set up "O" to test for descending order as default condition CAIE A,-4 ;Optional second argument? JRST .+4 GETYP B,TYP2 ;See if it is other than false CAIN B,TFALSE MOVE O,ASCEND ;Set up "O" to test for ascending order GETYP A,TYP1 ;CHECK TYPE OF FIRST ARGUMENT CAIN A,TLIST JRST LSORT CAIN A,TVEC JRST VSORT JRST WTYP1 GOBACK: MOVE A,TYP1 ;RETURN THE SORTED ARGUMENT AS VALUE MOVE B,VAL1 JRST FINIS DESCEND: CAMG C,(A)+1 ASCEND: CAML C,(A)+1 ;ROUTINE TO SORT LISTS IN NUMERICAL ORDER LSORT: MOVE A,VAL1 JUMPE A,GOBACK ;EMPTY LIST? HLRZ B,(A) ;TYPE OF FIRST COMPONENT CAIE B,TFIX CAIN B,TFLOAT SKIPA JRST WRONGT MOVEI E,0 ;FOR COUNT OF LENGTH OF LIST LCOUNT: JUMPE A,LLSORT ;REACHED END OF LIST? MOVE A,(A) ;NEXT COMPONENT TLZ A,(B) ;SAME TYPE AS FIRST COMPONENT? TLNE A,-1 JRST WRONGT AOJA E,LCOUNT ;INCREMENT COUNT AND CONTINUE LLSORT: SOJE E,GOBACK ;FINISHED WITH SORTING? HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING MOVEM E,(P)+1 ;Save the iteration depth CLSORT: HRRZ B,(A) ;NEXT COMPONENT MOVE C,(B)+1 ;ITS VALUE XCT O ;ARE THESE TWO COMPONENTS IN ORDER? JRST .+4 MOVE D,(A)+1 ;INTERCHANGE THEM MOVEM D,(B)+1 MOVEM C,(A)+1 MOVE A,B ;MAKE THE COMPONENT IN "B" THE CURRENT ONE SOJG E,CLSORT MOVE E,(P)+1 ;Restore the iteration depth JRST LLSORT ;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER VSORT: HLRE D,VAL1 ;GET COUNT FIELD OF VECTOR IDIV D,[-2] ;LENGTH JUMPE D,GOBACK ;EMPTY VECTOR? MOVE E,D ;SAVE LENGTH IN "E" HRRZ A,VAL1 ;POINTER TO VECTOR MOVE B,(A) ;TYPE OF FIRST COMPONENT CAME B,$TFIX CAMN B,$TFLOAT SKIPA JRST WRONGT SOJLE D,GOBACK ;IF ONLY ONE COMPONENT THEN FINISHED VCOUNT: ADDI A,2 ;CHECK NEXT COMPONENT CAME B,(A) ;SAME TYPE AS FIRST COMPONENT? JRST WRONGT SOJG D,VCOUNT ;CONTINUE WITH NEXT COMPONENT VVSORT: SOJE E,GOBACK ;FINISHED SORTING? HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING MOVEM E,(P)+1 ;Save the iteration depth CVSORT: MOVE C,(A)+3 ;VALUE OF NEXT COMPONENT XCT O ;ARE THESE TWO COMPONENTS IN ORDER? JRST .+4 MOVE D,(A)+1 ;INTERCHANGE THEM MOVEM D,(A)+3 MOVEM C,(A)+1 ADDI A,2 ;UPDATE THE CURRENT COMPONENT SOJG E,CVSORT MOVE E,(P)+1 ;Restore the iteration depth JRST VVSORT ] MFUNCTION OVERFLOW,SUBR ENTRY MOVEI E,OVFLG JRST FLGSET MFUNCTION TIME,SUBR ENTRY PUSHJ P,CTIME JRST FINIS IMPURE RHI: 267762113337 RLOW: 155256071112 OVFLG: -1 PURE END