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