--- /dev/null
+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,
+
+\f;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)
+
+\f;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,,
+\f;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
+\f;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
+\f
+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
+\f;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
+\f;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,
+
+
+\fMFUNCTION 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
+\fMFUNCTION 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
+\fMFUNCTION 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
+\fMFUNCTION 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
+\f
+;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
+\fREPEAT 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
+\f;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
+\f;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
+\f\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff