--- /dev/null
+TITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP,LSTUF,PVSTOR,SPSTOR
+.GLOBAL NWORDT,CHARGS,CHFRM,CHLOCI,IFALSE,IPUTP,IGETP,BYTDOP
+.GLOBAL OUTRNG,IGETLO,CHFRAM,ISTRUC,TYPVEC,SAT,CHKAB,VAL,CELL2,MONCH,MONCH0
+.GLOBAL RMONCH,RMONC0,LOCQ,LOCQQ,SMON,PURERR,APLQ,NAPT,TYPSEG,NXTLM
+.GLOBAL MAKACT,ILLCHO,COMPER,CEMPTY,CIAT,CIEQUA,CILEGQ,CILNQ,CILNT,CIN,CINTH,CIREST
+.GLOBAL CISTRU,CSETLO,CIPUT,CIGET,CIGETL,CIMEMQ,CIMEMB,CIMON,CITOP,CIBACK
+.GLOBAL IGET,IGETL,IPUT,CIGETP,CIGTPR,CINEQU,IEQUAL,TD.LNT,TD.GET,TD.PUT,TD.PTY
+.GLOBAL TMPLNT,BADTPL,ISTRCM,PTYPE,CIGVAL,MAKTUP,CSBSTR,TMATCH
+
+; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE
+F==PVP
+
+PRMTYP:
+
+REPEAT NUMSAT+1,[0] ;INITIALIZE TABLE TO ZEROES
+
+IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE]
+
+LOC PRMTYP+S!A
+P!A==.IRPCN+1
+P!A
+
+TERMIN
+
+PTMPLT==PBYTE+1
+
+; FUDGE FOR STRUCTURE LOCATIVES
+
+IRP A,,[[LOCL,2WORD],[LOCV,2NWORD],[LOCU,NWORD],[LOCS,CHSTR],[LOCA,ARGS]
+[LOCT,TMPLT],[LOCB,BYTE]]
+ IRP B,C,[A]
+ LOC PRMTYP+S!B
+ P!B==P!C,,0
+ P!B
+ .ISTOP
+ TERMIN
+TERMIN
+
+LOC PRMTYP+SSTORE ;SPECIAL HACK FOR AFREE STORAGE
+PNWORD
+
+LOC PRMTYP+NUMSAT+1
+
+PNUM==PTMPLT+1
+
+; MACRO TO BUILD PRIMITIVE DISPATCH TABLES
+
+DEFINE PRDISP NAME,DEFAULT,LIST
+ TBLDIS NAME,DEFAULT,[LIST]PNUM,400000
+ TERMIN
+
+
+; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL
+
+PTYPE: GETYP A,(B) ;CALLE D WITH B POINTING TO PAIR
+ CAIN A,TILLEG ;LOSE IF ILLEGAL
+ JRST ILLCHOS
+
+ PUSHJ P,SAT ;GET STORAGE ALLOC TYPE
+ CAIE A,SLOCA
+ CAIN A,SARGS ;SPECIAL HAIR FOR ARGS
+ PUSHJ P,CHARGS
+ CAIN A,SFRAME
+ PUSHJ P,CHFRM
+ CAIN A,SLOCID
+ PUSHJ P,CHLOCI
+PTYP1: MOVEI 0,(A) ; ALSO RETURN PRIMTYPE
+ CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
+ SKIPA A,[PTMPLT]
+ MOVE A,PRMTYP(A) ;GET PRIM TYPE,
+ POPJ P,
+
+; COMPILERS CALL TO ABOVE (LESS CHECKING)
+
+CPTYPE: PUSHJ P,SAT
+ MOVEI 0,(A)
+ CAILE A,NUMSAT
+ SKIPA A,[PTMPLT]
+ MOVE A,PRMTYP(A)
+ POPJ P,
+
+
+MFUNCTION SORT,SUBR
+
+ ENTRY
+
+; HACK TO DYNAMICALLY LOAD SORT
+ MOVE B,MQUOTE SORTX
+ PUSHJ P,CIGVAL
+ PUSH TP,A
+ PUSH TP,B ; PUSH ON FUNCTION FOR APPLY
+ MOVE A,AB ; PUSH ARGS TO SORT ONTO STACK
+ JUMPE A,DONPSH
+ PUSH TP,(A)
+ AOBJN A,.-1
+DONPSH: HLRE A,AB ; GET COUNT
+ MOVNS A
+ ADDI A,2
+ ASH A,-1 ; # OF ARGS
+ ACALL A,APPLY
+ JRST FINIS
+
+\f
+MFUNCTION SUBSTRUC,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA ;need at least one arg
+ CAMGE AB,[-10,,0] ;NO MORE THEN 4
+ JRST TMA
+ HLRE A,AB ; GET NEGATIVE LENGTH IN A
+ MOVNS A ; SET UP LENGTH ARG TO SUBSTRUC
+ ASH A,-1
+ MOVE B,AB ; AOBJN POINTER FOR LOOP
+ PUSH TP,(B) ; PUSH ON ARGS
+ AOBJN B,.-1
+ PUSHJ P,CSBSTR ; GO TO INTERNAL ROUTINE
+ JRST FINIS
+
+; VARIOUS OFFSETS INTO PSTACK
+
+PRTYP==0
+LNT==0
+NOARGS==-1
+
+; VARIOUS OFFSETS INTO TP STACK
+
+OBJ==-7
+RSTR==-5
+LNT==-3
+NOBJ==-1
+
+; THIS STARTS THE MAIN ROUTINE
+
+CSBSTR: SUBM M,(P) ; FOR RSUBRS
+ JSP E,@PTBL(A)
+ MOVEI B,OBJ(TP)
+ PUSH P,A
+ PUSHJ P,PTYPE ; get primtype in A
+ PUSH P,A
+ JRST @TYTBL(A)
+
+PTBL: SETZ WNA
+ SETZ PUSH6
+ SETZ PUSH4
+ SETZ PUSH2
+ SETZ PUSH0
+
+PUSH6: PUSH TP,[0]
+ PUSH TP,[0]
+PUSH4: PUSH TP,[0]
+ PUSH TP,[0]
+PUSH2: PUSH TP,[0]
+ PUSH TP,[0]
+PUSH0: JRST (E)
+
+
+RESSUB: MOVE D,NOARGS(P) ; GET NUMBER OF ARGS
+ CAIN D,1 ; IF 1 THEN JUST COPY
+ JRST @COPYTB(A)
+ GETYP B,RSTR(TP) ; GET TYPE OF REST ARGUMENT
+ CAIE B,TFIX ;IF FIX OK
+ JRST WRONGT
+ MOVEI E,(A)
+ MOVE A,OBJ(TP)
+ MOVE B,OBJ+1(TP) ; GET OBJECT
+ SKIPGE C,RSTR+1(TP) ; GET REST ARGUMENT
+ JRST OUTRNG
+ PUSHJ P,@MRSTBL(E)
+ PUSH TP,A ; type
+ PUSH TP,B ; put rested sturc on stack
+ JRST ALOCOK
+
+PRDISP TYTBL,IWTYP1,[[PARGS,RESSUB],[P2WORD,RESSUB],[P2NWORD,RESSUB]
+[PNWORD,RESSUB],[PCHSTR,RESSUB],[PBYTE,RESSUB]]
+
+PRDISP MRSTBL,IWTYP1,[[PARGS,AREST],[P2WORD,LREST],[P2NWORD,VREST]
+[PNWORD,UREST],[PCHSTR,SREST],[PBYTE,BREST]]
+
+PRDISP COPYTB,IWTYP1,[[PARGS,CPYVEC],[P2WORD,CPYLST],[P2NWORD,CPYVEC]
+[PNWORD,CPYUVC],[PCHSTR,CPYSTR],[PBYTE,CPYBYT]]
+
+PRDISP ALOCTB,IWTYP1,[[PARGS,ALVEC],[P2WORD,ALLIST],[P2NWORD,ALVEC]
+[PNWORD,ALUVEC],[PCHSTR,ALSTR],[PBYTE,ALBYT]]
+
+; HERE WE HAVE RESTED STRUCTURE ON TOP OF STACK
+
+ALOCFX: MOVE B,(TP) ; missing 3rd arg aloc for "rest" of struc
+ MOVE C,-1(TP)
+ MOVE A,(P)
+ PUSH P,[377777,,-1]
+ PUSHJ P,@LENTBL(A) ; get length of rested struc
+ SUB P,[1,,1]
+ POP P,C
+ MOVE A,B ; # of elements needed
+ JRST @ALOCTB(C)
+
+
+; HERE WE HAVE RESTED STRUCTURE ON THE TOP OF THE STACK
+
+ALOCOK: MOVE D,NOARGS(P) ; GET NUMBER OF ARGS
+ CAIG D,2 ; SKIP IF NOT EXACTLY 3 ARGS
+ JRST ALOCFX
+ GETYP C,LNT-2(TP) ; GET THE LENGTH ARGUMENT
+ CAIE C,TFIX ; OK IF TYPE FIX
+ JRST WRONGT
+ POP P,C
+ SKIPL A,LNT-1(TP) ; GET LENGTH
+ JRST @ALOCTB(C) ; DO ALLOCATION
+ JRST OUTRNG
+
+
+CPYVEC: HLRE A,OBJ+1(TP) ; USE WHEN ONLY ONE ARG
+ MOVNS A ; LENGTH ARG IS LENGTH OF STRUCTURE
+ ASH A,-1 ; # OF ELEMENTS FOR ALLOCATION
+ PUSH TP,OBJ(TP)
+ SUB P,[1,,1]
+ PUSH TP,OBJ(TP) ; REPUSH ARGS
+
+ALVEC: PUSH P,A ; SAVE LENGTH
+ ASH A,1
+ HRLI A,(A)
+ ADD A,(TP)
+ CAIL A,-1 ; CHK FOR OUT OF RANGE
+ JRST OUTRNG
+ MOVE D,NOARGS(P)
+ CAILE D,3 ; SKIP IF WE GET VECTOR
+ JRST ALVEC2 ; USER SUPPLIED VECTOR
+ MOVE A,(P)
+ PUSHJ P,IBLOK1
+ALVEC1: MOVE A,(P) ; # OF WORDS TO ALLOCATE
+ MOVE C,B ; SAVE VECTOR POINTER
+ JUMPE A,ALEVC4
+ ASH A,1 ; TIMES 2
+ HRLI A,(A)
+ ADD A,B ; PTING TO FIRST DOPE WORD -ALLOCATED
+ CAIL A,-1
+ JRST OUTRNG
+ SUBI A,1 ; ptr to last element of the block
+ MOVE D,NOARGS(P)
+ CAILE D,3
+ CAMGE B,(TP) ; SKIP IF BACKWARDS BLT IS NEEDED
+ JRST ALEVC3
+ HRRZ 0,(TP)
+ ADD 0,-4(TP)
+ ADD 0,-4(TP) ; FIND END OF DEST
+ CAIGE 0,(B) ; SEE IF BBLT IS NEEDED
+ JRST ALEVC3
+ PUSHJ P,BBLT ; BLT IT
+ JRST ALEVC4
+ALEVC3: HRL B,(TP) ;bleft-ptr to source , b right -ptr to allocated space
+ BLT B,(A)
+ MOVE B,C
+ALEVC4: MOVE D,NOARGS(P)
+ CAIE D,4
+ JRST ALEVC5
+ MOVE A,NOBJ-2(TP)
+ JRST EXSUB
+ALEVC5: MOVSI A,TVEC
+ JRST EXSUB
+
+; RESTED OBJECT ON TOP OF STACK
+
+ALVEC2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
+ CAIE 0,TARGS
+ CAIN 0,TVEC
+ SKIPA
+ JRST WTYP
+ HLRE A,NOBJ-1(TP) ; CHECK SIZE
+ MOVNS A
+ ASH A,-1 ; # OF ELEMENTS
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH
+ JRST OUTRNG
+ MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
+ JRST ALVEC1
+
+CPYUVC: HLRE A,OBJ+1(TP) ;# OF ELEMENTS FOR ALLOCATION
+ MOVNS A
+ PUSH TP,(B)
+ PUSH TP,1(B)
+ SUB P,[1,,1]
+
+
+ALUVEC: PUSH P,A
+ HRLI A,(A)
+ ADD A,(TP) ; PTING TO DOPE WORD OF ORIG VEC
+ CAIL A,-1
+ JRST OUTRNG
+ MOVE D,NOARGS(P)
+ CAILE D,3
+ JRST ALUVE2
+ MOVE A,(P)
+ PUSHJ P,IBLOCK
+ALUVE1: MOVE A,(P) ; # of owrds to allocate
+ JUMPE A,ALUEV4
+ HRLI A,(A)
+ ADD A,B ; LOCATION O FIRST ALLOCATED DOPE WORD
+ HLR E,OBJ-1(TP) ; # OF ELEMENTS IN UVECTOR
+ MOVNS E
+ ADD E,OBJ-1(TP) ; LOCATION OF FIRST DOPE WORD FOR SOURCE
+ GETYP E,(E) ; GET UTYPE
+ MOVE D,NOARGS(P)
+ CAIE D,4
+ PUTYP E,(A) ; DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC
+ CAILE D,3
+ CAIN 0,(E) ; 0 HAS USER UVEC UTYPE
+ JRST .+2
+ JRST WRNGUT
+ CAIL A,-1
+ JRST OUTRNG
+ MOVE D,NOARGS(P)
+ CAILE D,3
+ CAMGE B,(TP) ; SKIP IF NEEDS BACKWARDS BLT
+ JRST ALUEV3
+ HRRZ 0,(TP)
+ ADD 0,-4(TP)
+ CAIGE 0,(B)
+ JRST ALUEV3
+ SUBI A,1
+ PUSHJ P,BBLT
+ JRST ALUEV4
+ALUEV3: MOVE C,B ; SAVE POINTER TO FINAL GUY
+ HRL C,(TP) ; BUILD BLT POINTER
+ BLT C,-1(A)
+ALUEV4: MOVSI A,TUVEC
+ JRST EXSUB
+
+; BACKWARDS BLTTER
+; A==LAST WORD DEST (TP)==FIRST WORD DEST B==FIRST WORD SOURCE
+
+BBLT: SUBI A,-1(B)
+ MOVE E,A ; SAVE ADDITION
+ HRLZS A ; SWAP AND ZERO
+ HRR A,(TP)
+ ADDI A,-1(E)
+ MOVEI C,(B) ; SET UP DEST WORD
+ SUBI C,(A) ; CALC DIFF
+ ADDI C,-1(E) ; ADD TO GET TO END
+ HRLI C,A ; SET UP INDIRECT
+ POP A,@C ; BLT
+ TLNE A,-1 ; SKIP IF DONE
+ JRST .-2
+ POPJ P, ; EXIT
+
+ALUVE2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
+ CAIE 0,TUVEC
+ JRST WTYP
+ HLRE A,NOBJ-1(TP) ; CHECK SIZE
+ MOVNS A
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH
+ JRST OUTRNG
+ MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
+ HLRE A,B
+ SUBM B,A
+ GETYP 0,(A) ; GET UTYPE OF USER UVECTOR
+ JRST ALUVE1
+
+ALBYT: MOVSI C,TBYTE
+ JRST ALSTRX
+
+CPYBYT: SKIPA C,$TBYTE
+CPYSTR: MOVSI C,TCHSTR
+ HRR A,OBJ(TP)
+ PUSH TP,(B) ; ALSTR EXPECTS STRING IN TP
+ PUSH TP,1(B)
+ SUB P,[1,,1]
+ JRST .+2
+
+ALSTR: MOVSI C,TCHSTR
+ALSTRX: PUSH P,C ; SAVE FINAL TYPE
+ PUSH P,A ; LENGTH
+ HRRZ 0,-1(TP) ;0 IS LENGTH OFF VECTOR
+ CAIGE 0,(A)
+ JRST OUTRNG
+ CAILE D,3
+ JRST ALSTR2
+ LDB C,[300600,,(TP)]
+ MOVEI B,36.
+ IDIVI B,(C) ; B BYT PER WD, C XTRA BITS
+ ADDI A,-1(B)
+ IDIVI A,(B)
+ PUSH P,C
+ PUSHJ P,IBLOCK ;ALLOCATE SPACE
+ HLL B,(TP)
+ POP P,C
+ DPB C,[360600,,B]
+ SUBI B,1
+ MOVEM B,-2(TP)
+ MOVE A,(P) ; # OF CHARS TO A
+ HLL A,-1(P)
+ MOVEM A,-3(TP)
+ JUMPN A,SSTR1
+ALSTR9: SUB TP,[4,,4]
+ JRST ALSTR8
+ALSTR1: HLL A,-2(P) ; GET TYPE
+ HRRZ C,B ; SEE IF WE WILL OVERLAP
+ HRRZ D,(TP) ; GET RESTED STRING
+ CAIGE C,(D) ; IF C > B THE A CHANCE
+ JRST SSTR
+ MOVEI C,-1(TP) ; GO TO BYTDOP
+ PUSHJ P,BYTDOP
+ HRRZ B,-2(TP) ; IF B < A THEN OVERLAP
+ CAILE B,(A)
+ JRST SSTR
+ HRRZ A,-4(TP) ; GET LENGTH IN A
+ MOVEI B,0 ; START LENGTH COUNT
+
+; ORIGINAL STRING IS ON THE TOP OF THE STACK
+
+CLOOP1: INTGO
+ PUSH P,[0] ; STORE CHARS ON STACK
+ MOVSI E,(<440000,,(P)>) ; SETUP BYTE POINTER
+ LDB 0,[300600,,(TP)]
+ DPB 0,[300600,,E]
+CLOOP: IBP E ; BUMP IT
+ TRNE E,-1 ; WORD FULL
+ AOJA B,CLOOP1 ; PUSH NEW ONE
+ ILDB 0,(TP) ; GET A CHARACTER
+ SOS -1(TP) ; DECREMENT CHARACTER COUNT
+ DPB 0,E
+ SOJN A,CLOOP ; ANY MORE?
+ SUB TP,[2,,2]
+ MOVEI C,(P)
+ PUSH P,B ; SAVE B
+ SUBI C,(B)
+ MOVE A,-2(TP) ; GET COUNT
+ MOVE B,(TP)
+ HRLI C,440000 ; MAKE IT LOOK LIKE A BYTE PTR
+ LDB 0,[300600,,(TP)]
+ DPB 0,[300600,,C]
+CLOOP3: ILDB D,C ; GET NEW CHARACTER
+ IDPB D,B ; DEPOSIT CHARACTER
+ SOJG A,CLOOP3
+ POP P,A
+ SUBI P,(A)
+ HRLZS A
+ SUB P,A ; CLEAN OFF STACK
+ POP TP,B ;BYTE PTR TO COPY
+ SUB P,[1,,1]
+ALST10: SUB TP,[1,,1] ; CLEAN OFF STACK
+ALSTR8: POP P,A ;# FO ELEMENTS
+ HLL A,(P)
+ SUB TP,[6,,6]
+ JRST EXSUB1
+
+
+; ROUTINE TO DO FAST TRANSFER FOR NON SHARING STRINGS
+
+SSTR: MOVE A,-4(TP) ; GET # OF ELEMENTS INTO A
+ MOVE B,-2(TP)
+SSTR1: POP TP,C
+ SUB TP,[1,,1]
+ HRRZS A
+SSTR2: ILDB D,C
+ IDPB D,B
+ SOJG A,SSTR2
+ POP TP,B
+ JRST ALST10
+
+ALSTR2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
+ MOVSS 0
+ CAME 0,-1(P)
+ JRST WTYP
+ HRRZ A,NOBJ-2(TP)
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH
+ JRST OUTRNG
+ EXCH A,(P)
+ MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
+ JUMPE A,ALSTR9
+ JRST ALSTR1
+
+; HERE TO COPY A LIST
+
+CPYLST: SKIPN OBJ+1(TP)
+ JRST ZEROLT
+ PUSHJ P,CELL2
+ POP P,C
+ HRLI C,TLIST ; TP JUNK FOR GAR. COLLECTOR
+ PUSH TP,C ; TYPE
+ PUSH TP,B ; VALUE -PTR TO NEW LIST
+ PUSH TP,C ; TYPE
+ MOVE C,OBJ-2(TP) ; PTR TO FIRST ELEMENT OF ORIG. LIST
+REPLST: MOVE D,(C)
+ MOVE E,1(C) ; GET LIST ELEMENT INTO ALOC SPACE
+ HLLM D,(B)
+ MOVEM E,1(B) ; PUT INTO ALLOCATED SPACE
+ HRRZ C,(C) ; UPDATE PTR
+ JUMPE C,CLOSWL ; END OF LIST?
+ PUSH TP,B
+ PUSHJ P,CELL2
+ POP TP,D
+ HRRM B,(D) ; LINK ALLOCATED LIST CELLS
+ JRST REPLST
+
+CLOSWL: MOVE A,-2(TP) ; GET LIST
+ MOVE B,-1(TP)
+ SUB TP,[11.,,11.]
+LEXIT: SUB P,[1,,1]
+ JRST MPOPJ
+
+
+
+ALLIST: PUSH P,A
+ MOVE D,NOARGS(P)
+ CAILE D,3 ; SKIP IF WE BUILD LIST
+ JRST CPYLS2
+ JUMPE A,ZEROL1
+ ASH A,1 ; TIMES 2
+ PUSHJ P,CELL
+ POP P,A ; # OF ELEMENTS
+ PUSH P,B ; ptr to allocated list
+ POP TP,C ; ptr to orig list
+ JRST ENTCOP
+
+COPYL: ADDI B,2
+ HRRM B,-2(B) ; LINK ALOCATED LIST CELLS
+ENTCOP: JUMPE C,OUTRNG
+ MOVE D,(C)
+ MOVE E,1(C) ; get list element into D+E
+ HLLM D,(B)
+ MOVEM E,1(B) ; put into allocated space
+ HRRZ C,(C) ; update ptrs
+ SOJG A,COPYL ; finish transfer?
+
+CLOSEL: POP P,B
+ MOVE A,(TP)
+ SUB TP,[9.,,9.]
+ JRST LEXIT
+
+
+ZEROL1: SUB TP,[2,,2]
+ZEROLT: MOVSI A,TLIST
+ MOVEI B,0
+ SUB TP,[8,,8]
+ JRST EXSUB1
+
+CPYLS2: GETYP 0,NOBJ-2(TP)
+ CAIE 0,TLIST
+ JRST WTYP
+ MOVE B,NOBJ-1(TP) ; GET DEST LIST
+ MOVE C,(TP)
+
+ JUMPE A,CPYLS3
+CPYLS4: JUMPE B,OUTRNG
+ JUMPE C,OUTRNG
+ MOVE D,1(C)
+ MOVEM D,1(B)
+ GETYP 0,(C)
+ HRLM 0,(B)
+ HRRZ B,(B)
+ HRRZ C,(C)
+ SOJG A,CPYLS4
+
+CPYLS3: MOVE D,-2(TP)
+ MOVE B,NOBJ-1(TP)
+ MOVSI A,TLIST
+
+; HERE TO EXIT
+
+EXSUB: SUB TP,[10.,,10.]
+EXSUB1: SUB P,[2,,2]
+ JRST MPOPJ
+
+
+\f
+; PROCESS TYPE ILLEGAL
+
+ILLCHO: HRRZ B,1(B) ;GET CLOBBERED TYPE
+ CAIN B,TARGS ;WAS IT ARGS?
+ JRST ILLAR1
+ CAIN B,TFRAME ;A FRAME?
+ JRST ILFRAM
+ CAIN B,TLOCD ;A LOCATIVE TO AN ID
+ JRST ILLOC1
+
+ LSH B,1 ;NONE OF ABOVE LOOK IN TABLE
+ ADDI B,TYPVEC+1
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ILLEGAL
+ PUSH TP,$TATOM
+ PUSH TP,(B) ;PUSH ATOMIC NAME
+ MOVEI A,2
+ JRST CALER ;GO TO ERROR REPORTER
+
+; CHECK AN ARGS POINTER
+
+CHARGS: PUSHJ P,ICHARG ; INTERNAL CHECK
+ JUMPN B,CPOPJ
+
+ILLAR1: ERRUUO EQUOTE ILLEGAL-ARGUMENT-BLOCK
+
+ICHARG: PUSH P,A ;SAVE SOME ACS
+ PUSH P,B
+ PUSH P,C
+ SKIPN C,1(B) ;GET POINTER
+ JRST ILLARG ; ZERO POINTER IS ILLEGAL
+ HLRE A,C ;FIND ASSOCIATED FRAME
+ SUBI C,(A) ;C POINTS TO FRAME OR FRAME POINTER
+ GETYP A,(C) ;GET TYPE OF NEXT GOODIE
+ CAIN A,TCBLK
+ JRST CHARG1
+ CAIE A,TENTRY ;MUST BE EITHER ENTRY OR TINFO
+ CAIN A,TINFO
+ JRST CHARG1 ;WINNER
+ JRST ILLARG
+
+CHARG1: CAIN A,TINFO ;POINTER TO FRAME?
+ ADD C,1(C) ;YES, GET IT
+ CAIE A,TINFO ;POINTS TO ENTRT?
+ MOVEI C,FRAMLN(C) ;YES POINT TO END OF FRAME
+ HLRZ C,OTBSAV(C) ;GET TIME FROM FRAME
+ HRRZ B,(B) ;AND ARGS TIME
+ CAIE B,(C) ;SAME?
+ILLARG: SETZM -1(P) ; RETURN ZEROED B
+POPBCJ: POP P,C
+ POP P,B
+ POP P,A
+ POPJ P, ;GO GET PRIM TYPE
+\f
+
+
+; CHECK A FRAME POINTER
+
+CHFRM: PUSHJ P,CHFRAM
+ JUMPN B,CPOPJ
+
+ILFRAM: ERRUUO EQUOTE ILLEGAL-FRAME
+
+CHFRAM: PUSH P,A ;SAVE SOME REGISTERS
+ PUSH P,B
+ PUSH P,C
+ HRRZ A,(B) ; GE PVP POINTER
+ HLRZ C,(A) ; GET LNTH
+ SUBI A,-1(C) ; POINT TO TOP
+ MOVE PVP,PVSTOR+1
+ CAIN A,(PVP) ; SKIP IF NOT THIS PROCESS
+ MOVEM TP,TPSTO+1(A) ; MAKE CURRENT BE STORED
+ HRRZ A,TPSTO+1(A) ; GET TP FOR THIS PROC
+ HRRZ C,1(B) ;GET POINTER PART
+ CAILE C,1(A) ;STILL WITHIN STACK
+ JRST BDFR
+ HLRZ A,FSAV(C) ;CHECK STILL AN ENTRY BLOCK
+ CAIN A,TCBLK
+ JRST .+3
+ CAIE A,TENTRY
+ JRST BDFR
+ HLRZ A,1(B) ;GET TIME FROM POINTER
+ HLRZ C,OTBSAV(C) ;AND FROM FRAME
+ CAIE A,(C) ;SAME?
+BDFR: SETZM -1(P) ; RETURN 0 IN B
+ JRST POPBCJ ;YES, WIN
+
+; CHECK A LOCATIVE TO AN IDENTIFIER
+
+CHLOCI: PUSHJ P,ICHLOC
+ JUMPN B,CPOPJ
+
+ILLOC1: ERRUUO EQUOTE ILLEGAL-LOCATIVE
+
+ICHLOC: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+
+ HRRZ A,(B) ;GET TIME FROM POINTER
+ JUMPE A,POPBCJ ;ZERO, GLOBAL VARIABLE NO TIME
+ HRRZ C,1(B) ;POINT TO STACK
+ CAMLE C,VECTOP
+ JRST ILLOC ;NO
+ HRRZ C,2(C) ; SHOULD BE DECL,,TIME
+ CAIE A,(C)
+ILLOC: SETZM -1(P) ; RET 0 IN B
+ JRST POPBCJ
+
+
+
+\f
+; PREDICATE TO SEE IF AN OBJECT IS STRUCTURED
+
+MFUNCTION %STRUC,SUBR,[STRUCTURED?]
+
+ ENTRY 1
+
+ GETYP A,(AB) ; GET TYPE
+ PUSHJ P,ISTRUC ; INTERNAL
+ JRST IFALSE
+ JRST ITRUTH
+
+
+; PREDICATE TO CHECK THE LEGALITY OF A FRAME/ARGS TUPLE/IDENTIFIER LOCATIVE
+
+MFUNCTION %LEGAL,SUBR,[LEGAL?]
+
+ ENTRY 1
+
+ MOVEI B,(AB) ; POINT TO ARG
+ PUSHJ P,ILEGQ
+ JRST IFALSE
+ JRST ITRUTH
+
+ILEGQ: GETYP A,(B)
+ CAIN A,TILLEG
+ POPJ P,
+ PUSHJ P,SAT ; GET STORG TYPE
+ CAIN A,SFRAME ; FRAME?
+ PUSHJ P,CHFRAM
+ CAIE A,SLOCA
+ CAIN A,SARGS ; ARG TUPLE
+ PUSHJ P,ICHARG
+ CAIN A,SLOCID ; ID LOCATIVE
+ PUSHJ P,ICHLOC
+ JUMPE B,CPOPJ
+ JRST CPOPJ1
+
+
+; COMPILERS CALL
+
+CILEGQ: PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,ILEGQ
+ TDZA 0,0
+ MOVEI 0,1
+ SUB TP,[2,,2]
+ JUMPE 0,NO
+
+YES: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST CPOPJ1
+
+NOM: SUBM M,(P)
+NO: MOVSI A,TFALSE
+ MOVEI B,0
+ POPJ P,
+
+YESM: SUBM M,(P)
+ JRST YES
+\f;SUBRS TO DEFINE, GET, AND PUT BIT FIELDS
+
+MFUNCTION BITS,SUBR
+ ENTRY
+ JUMPGE AB,TFA ;AT LEAST ONE ARG ?
+ GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WTYP1
+ SKIPLE C,(AB)+1 ;GET FIRST AND CHECK TO SEE IF POSITIVE
+ CAILE C,44 ;CHECK IF FIELD NOT GREATER THAN WORD SIZE
+ JRST OUTRNG
+ MOVEI B,0
+ CAML AB,[-2,,0] ;ONLY ONE ARG ?
+ JRST ONEF ;YES
+ CAMGE AB,[-4,,0] ;MORE THAN TWO ARGS ?
+ JRST TMA ;YES, LOSE
+ GETYP A,(AB)+2
+ CAIE A,TFIX
+ JRST WTYP2
+ SKIPGE B,(AB)+3 ;GET SECOND ARG AND CHECK TO SEE IF NON-NEGATIVE
+ JRST OUTRNG
+ ADD C,(AB)+3 ;CALCULATE LEFTMOST EXTENT OF THE FIELD
+ CAILE C,44 ;SHOULD BE LESS THAN WORD SIZE
+ JRST OUTRNG
+ LSH B,6
+ONEF: ADD B,(AB)+1
+ LSH B,30 ;FORM BYTE POINTER'S LEFT HALF
+ MOVSI A,TBITS
+ JRST FINIS
+
+
+
+MFUNCTION GETBITS,SUBR
+ ENTRY 2
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIN A,SSTORE
+ JRST .+3
+ CAIE A,S1WORD
+ JRST WTYP1
+ GETYP A,(AB)+2
+ CAIE A,TBITS
+ JRST WTYP2
+ MOVEI A,(AB)+1 ;GET ADDRESS OF THE WORD
+ HLL A,(AB)+3 ;GET LEFT HALF OF BYTE POINTER
+ LDB B,A
+ MOVSI A,TWORD ; ALWAYS RETURN WORD\b\b\b\b____
+ JRST FINIS
+
+
+MFUNCTION PUTBITS,SUBR
+ ENTRY
+ CAML AB,[-2,,0] ;AT LEAST TWO ARGS ?
+ JRST TFA ;NO, LOSE
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIE A,S1WORD
+ JRST WTYP1
+ GETYP A,(AB)+2
+ CAIE A,TBITS
+ JRST WTYP2
+ MOVEI B,0 ;EMPTY THIRD ARG DEFAULT
+ CAML AB,[-4,,0] ;ONLY TWO ARGS ?
+ JRST TWOF
+ CAMGE AB,[-6,,0] ;MORE THAN THREE ARGS ?
+ JRST TMA ;YES, LOSE
+ GETYP A,(AB)+4
+ PUSHJ P,SAT
+ CAIE A,S1WORD
+ JRST WTYP3
+ MOVE B,(AB)+5
+TWOF: MOVEI A,(AB)+1 ;ADDRESS OF THE TARGET WORD
+ HLL A,(AB)+3 ;GET THE LEFT HALF OF THE BYTE POINTER
+ DPB B,A
+ MOVE B,(AB)+1
+ MOVE A,(AB) ;SAME TYPE AS FIRST ARG'S
+ JRST FINIS
+\f
+
+; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS
+
+MFUNCTION LNTHQ,SUBR,[LENGTH?]
+
+ ENTRY 2
+ GETYP A,(AB)2
+ CAIE A,TFIX
+ JRST WTYP2
+ PUSH P,(AB)3
+ JRST LNTHER
+
+
+MFUNCTION LENGTH,SUBR
+
+ ENTRY 1
+ PUSH P,[377777777777]
+LNTHER: MOVE B,AB ;POINT TO ARGS
+ PUSHJ P,PTYPE ;GET ITS PRIM TYPE
+ MOVE B,1(AB)
+ MOVE C,(AB)
+ PUSHJ P,@LENTBL(A) ; CALL RIGTH ONE
+ JRST LFINIS ;OTHERWISE USE 0
+
+PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC]
+[PARGS,LNVEC],[PCHSTR,LNCHAR],[PTMPLT,LNTMPL],[PBYTE,LNCHAR]]
+
+LNLST: SKIPN C,B ; EMPTY?
+ JRST LNLST2 ; YUP, LEAVE
+ MOVEI B,1 ; INIT COUNTER
+ MOVSI A,TLIST ;WILL BECOME INTERRUPTABLE
+ MOVE PVP,PVSTOR+1
+ HLLM A,CSTO(PVP) ;AND C WILL BE A LIST POINTER
+LNLST1: INTGO ;IN CASE CIRCULAR LIST
+ CAMLE B,(P)-1
+ JRST LNLST2
+ HRRZ C,(C) ;STEP
+ JUMPE C,.+2 ;DONE, RETRUN LENGTH
+ AOJA B,LNLST1 ;COUNT AND GO
+LNLST2: MOVE PVP,PVSTOR+1
+ SETZM CSTO(PVP)
+ POPJ P,
+
+LFINIS: POP P,C
+ CAMLE B,C
+ JRST IFALSE
+ MOVSI A,TFIX ;LENGTH IS AN INTEGER
+ JRST FINIS
+
+LNVEC: ASH B,-1 ;GENERAL VECTOR DIVIDE BY 2
+LNUVEC: HLRES B ;GET LENGTH
+ MOVMS B ;MAKE POS
+ POPJ P,
+
+LNCHAR: HRRZ B,C ; GET COUNT
+ POPJ P,
+
+LNTMPL: GETYP A,(B) ; GET REAL SAT
+ SUBI A,NUMSAT+1
+ HRLS A ; READY TO HIT TABLE
+ ADD A,TD.LNT+1
+ JUMPGE A,BADTPL
+ MOVE C,B ; DATUM TO C
+ XCT (A) ; GET LENGTH
+ HLRZS C ; REST COUNTER
+ SUBI B,(C) ; FLUSH IT OFF
+ MOVEI B,(B) ; IN CASE FUNNY STUFF
+ MOVSI A,TFIX
+ POPJ P,
+
+; COMPILERS ENTRIES
+
+CILNT: SUBM M,(P)
+ PUSH P,[377777,,-1]
+ MOVE C,A
+ GETYP A,A
+ PUSHJ P,CPTYPE ; GET PRIMTYPE
+ JUMPE A,CILN1
+ PUSHJ P,@LENTBL(A) ; DISPATCH
+ MOVSI A,TFIX
+CILN2: SUB P,[1,,1]
+MPOPJ: SUBM M,(P)
+ POPJ P,
+
+CILN1: PUSH TP,C
+ PUSH TP,B
+ MCALL 1,LENGTH
+ JRST CILN2
+
+CILNQ: SUBM M,(P)
+ PUSH P,C
+ MOVE C,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ JUMPE A,CILNQ1
+ PUSHJ P,@LENTBL(A)
+ POP P,C
+ SUBM M,(P)
+ MOVSI A,TFIX
+ CAMG B,C
+ JRST CPOPJ1
+ MOVSI A,TFALSE
+ MOVEI B,0
+ POPJ P,
+
+CILNQ1: PUSH TP,C
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,(P)
+ MCALL 2,LENGTH?
+ SUBM M,(P)
+ GETYP 0,A
+ CAIE 0,TFALSE
+ AOS (P)
+ POPJ P,
+\f
+
+MFUNCTION BYTSIZ,SUBR,[BYTE-SIZE]
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIE A,SBYTE
+ JRST WTYP1
+ LDB B,[300600,,1(AB)]
+ MOVSI A,TFIX
+ JRST FINIS
+\f
+
+
+IDNT1: MOVE A,(AB) ;RETURN THE FIRST ARG
+ MOVE B,1(AB)
+ JRST FINIS
+
+IMFUNCTION QUOTE,FSUBR
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TLIST ;ARG MUST BE A LIST
+ JRST WTYP1
+ SKIPN B,1(AB) ;SHOULD HAVE A BODY
+ JRST TFA
+
+ HLLZ A,(B) ; GET IT
+ MOVE B,1(B)
+ JSP E,CHKAB
+ JRST FINIS
+
+MFUNCTION NEQ,SUBR,[N==?]
+
+ MOVEI D,1
+ JRST EQR
+
+MFUNCTION EQ,SUBR,[==?]
+
+ MOVEI D,0
+EQR: ENTRY 2
+
+ GETYP A,(AB) ;GET 1ST TYPE
+ GETYP C,2(AB) ;AND 2D TYPE
+ MOVE B,1(AB)
+ CAIN A,(C) ;CHECK IT
+ CAME B,3(AB)
+ JRST @TABLE2(D)
+ JRST @TABLE1(D)
+
+ITRUTH: MOVSI A,TATOM ;RETURN TRUTH
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+IFALSE: MOVSI A,TFALSE ;RETURN FALSE
+ MOVEI B,0
+ JRST FINIS
+
+TABLE1: ITRUTH
+TABLE2: IFALSE
+ ITRUTH
+
+\f
+
+
+MFUNCTION EMPTY,SUBR,EMPTY?
+
+ ENTRY 1
+
+ MOVE B,AB
+ PUSHJ P,PTYPE ;GET PRIMITIVE TYPE
+
+ MOVEI A,(A)
+ JUMPE A,WTYP1
+ SKIPN B,1(AB) ;GET THE ARG
+ JRST ITRUTH
+
+ CAIN A,PTMPLT ; TEMPLATE?
+ JRST EMPTPL
+ CAIE A,P2WORD ;A LIST?
+ JRST EMPT1 ;NO VECTOR OR CHSTR
+ JUMPE B,ITRUTH ;0 POINTER MEANS EMPTY LIST
+ JRST IFALSE
+
+
+EMPT1: CAIN A,PBYTE
+ JRST .+3
+ CAIE A,PCHSTR ;CHAR STRING?
+ JRST EMPT2 ;NO, VECTOR
+ HRRZ B,(AB) ; GET COUNT
+ JUMPE B,ITRUTH ;0 STRING WINS
+ JRST IFALSE
+
+EMPT2: JUMPGE B,ITRUTH
+ JRST IFALSE
+
+EMPTPL: PUSHJ P,LNTMPL ; GET LENGTH
+ JUMPE B,ITRUTH
+ JRST IFALSE
+
+; COMPILER'S ENTRY TO EMPTY
+
+CEMPTY: PUSH P,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ POP P,0
+ JUMPE A,CEMPT2
+ JUMPE B,YES ; ALWAYS EMPTY
+ CAIN A,PTMPLT
+ JRST CEMPTP
+ CAIN A,P2WORD
+ JRST NO
+ CAIN A,PCHSTR
+ JRST .+3
+ JUMPGE B,YES
+ JRST NO
+ TRNE 0,-1 ; STRING, SKIP ON ZERO LENGTH FIELD
+ JRST NO
+ JRST YES
+
+CEMPTP: PUSHJ P,LNTMPL
+ JUMPE B,YES
+ JRST NO
+
+CEMPT2: PUSH TP,0
+ PUSH TP,B
+ MCALL 1,EMPTY?
+ JUMPE B,NO
+ JRST YES
+
+MFUNCTION NEQUAL,SUBR,[N=?]
+ PUSH P,[1]
+ JRST EQUALR
+
+MFUNCTION EQUAL,SUBR,[=?]
+ PUSH P,[0]
+EQUALR: ENTRY 2
+
+ MOVE C,AB ;SET UP TO CALL INTERNAL
+ MOVE D,AB
+ ADD D,[2,,2] ;C POINTS TO FIRS, D TO SECOND
+ PUSHJ P,IEQUAL ;CALL INTERNAL
+ JRST EQFALS ;NO SKIP MEANS LOSE
+ JRST EQTRUE
+EQFALS: POP P,C
+ JRST @TABLE2(C)
+EQTRUE: POP P,C
+ JRST @TABLE1(C)
+
+\f
+; COMPILER'S ENTRY TO =? AND N=?
+
+CINEQU: PUSH P,[0]
+ JRST .+2
+
+CIEQUA: PUSH P,[1]
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ MOVEI C,-3(TP)
+ MOVEI D,-1(TP)
+ SUBM M,-1(P) ; MAY BECOME INTERRUPTABLE
+ PUSHJ P,IEQUAL
+ JRST NOE
+ POP P,C
+ SUB TP,[4,,4] ; FLUSH TEMPS
+ JRST @CTAB1(C)
+
+NOE: POP P,C
+ SUB TP,[4,,4]
+ JRST @CTAB2(C)
+
+CTAB1: SETZ NOM
+CTAB2: SETZ YESM
+ SETZ NOM
+
+; INTERNAL EQUAL SUBROUTINE
+
+IEQUAL: MOVE B,C ;NOW CHECK THE ARGS
+ PUSHJ P,PTYPE
+ MOVE B,D
+ PUSHJ P,PTYPE
+ MOVE F,0 ; SAVE SAT FOR OFFSET HACK
+ GETYP 0,(C) ;NOW CHECK FOR EQ
+ GETYP B,(D)
+ MOVE E,1(C)
+ CAIN 0,(B) ;DONT SKIP IF POSSIBLE WINNER
+ CAME E,1(D) ;DEFINITE WINNER, SKIP
+ JRST IEQ1
+CPOPJ1: AOS (P) ;EQ, SKIP RETURN
+ POPJ P,
+
+
+IEQ1: CAIE 0,(B) ;SKIP IF POSSIBLE MATCH
+CPOPJ: POPJ P, ;NOT POSSIBLE WINNERS
+ CAIN F,SOFFS
+ JRST EQOFFS
+ JRST @EQTBL(A) ;DISPATCH
+
+PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC]
+[PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL],[PBYTE,EQCHST]]
+
+EQLIST: PUSHJ P,PUSHCD ;PUT ARGS ON STACK
+
+EQLST1: INTGO ;IN CASE OF CIRCULAR
+ HRRZ C,-2(TP) ;GET FIRST
+ HRRZ D,(TP) ;AND 2D
+ CAIN C,(D) ;EQUAL?
+ JRST EQLST2 ;YES, LEAVE
+ JUMPE C,EQLST3 ;NIL LOSES
+ JUMPE D,EQLST3
+ GETYP 0,(C) ;CHECK DEFERMENT
+ CAIN 0,TDEFER
+ HRRZ C,1(C) ;PICK UP POINTED TO CROCK
+ GETYP 0,(D)
+ CAIN 0,TDEFER
+ HRRZ D,1(D) ;POINT TO REAL GOODIE
+ PUSHJ P,IEQUAL ;CHECK THE CARS
+ JRST EQLST3 ;LOSE
+ HRRZ C,@-2(TP) ;CDR THE LISTS
+ HRRZ D,@(TP)
+ HRRZM C,-2(TP) ;AND STORE
+ HRRZM D,(TP)
+ JRST EQLST1
+
+EQLST2: AOS (P) ;SKIP RETRUN
+EQLST3: SUB TP,[4,,4] ;REMOVE CRUFT
+ POPJ P,
+\f
+; HERE FOR HACKING OFFSETS
+EQOFFS: HRRZ A,1(C)
+ HRRZ B,1(D) ; GET NUMBERS
+ CAIE A,(B) ; POSSIBLE WINNER IF SKIP
+ POPJ P,
+ PUSH TP,$TLIST
+ HLRZ A,1(C)
+ PUSH TP,A
+ PUSH TP,$TLIST
+ HLRZ A,1(D)
+ PUSH TP,A
+ JRST EQLST1 ; SEE IF THE TWO LISTS ARE EQUAL
+
+; HERE FOR HACKING TEMPLATE STRUCTURES
+
+EQTMPL: PUSHJ P,PUSHCD ; SAVE GOODIES
+ PUSHJ P,PUSHCD
+ MOVE C,1(C) ; CHECK REAL SATS
+ GETYP C,(C)
+ MOVE D,1(D)
+ GETYP 0,(D)
+ CAIE 0,(C) ; SKIP IF WINNERS
+ JRST EQTMP4
+ PUSH P,0 ; SAVE MAGIC OFFSET
+ MOVE B,-2(TP)
+ PUSHJ P,TM.LN1 ; RET LENGTH IN B
+ MOVEI B,(B) ; FLUSH FUNNY
+ HLRZ C,-2(TP)
+ SUBI B,(C)
+ PUSH P,B
+ MOVE C,(TP) ; POINTER TO OTHER GUY
+ ADD A,TD.LNT+1
+ XCT (A) ; OTHER LENGTH TO B
+ HLRZ 0,-2(TP) ; REST OFFSETTER
+ SUBI 0,1
+ PUSH P,0
+ MOVEI B,(B)
+ HLRZ C,(TP)
+ SUBI B,(C)
+ HRRZS -4(TP) ; UNDO RESTING (ACCOUNTED FOR BY STARTING
+ ; AT LATER ELEMENT)
+ HRRZS -6(TP)
+ CAME B,-1(P)
+ JRST EQTMP1
+
+EQTMP2: AOS C,(P)
+ SOSGE -1(P)
+ JRST EQTMP3 ; WIN!!
+
+ MOVE B,-6(TP) ; POINTER
+ MOVE 0,-2(P) ; GET MAGIC OFFSET
+ PUSHJ P,TMPLNT ; GET AN ELEMENT
+ MOVEM A,-3(TP)
+ MOVEM B,-2(TP)
+ MOVE C,(P)
+ MOVE B,-4(TP) ; OTHER GUY
+ MOVE 0,-2(P)
+ PUSHJ P,TMPLNT
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+ MOVEI C,-3(TP)
+ MOVEI D,-1(TP)
+ PUSHJ P,IEQUAL ; RECURSE
+ JRST EQTMP1 ; LOSER
+ JRST EQTMP2 ; WINNER
+
+EQTMP3: AOS -3(P) ; WIN RETURN
+EQTMP1: SUB P,[3,,3] ; FLUSH JUNK
+EQTMP4: SUB TP,[10,,10]
+ POPJ P,
+
+
+
+EQVEC: HLRE A,1(C) ;GET LENGTHS
+ HLRZ B,1(D)
+ CAIE B,(A) ;SKIP IF EQUAL LENGTHS
+ POPJ P, ;LOSE
+ JUMPGE A,CPOPJ1 ;SKIP RETRUN WIN
+ PUSHJ P,PUSHCD ;SAVE ARGS
+
+EQVEC1: INTGO ;IN CASE LONG VECTOR
+ MOVE C,(TP)
+ MOVE D,-2(TP) ;ARGS TO C AND D
+ PUSHJ P,IEQUAL
+ JRST EQLST3
+ MOVE C,[2,,2] ;GET BUMPER
+ ADDM C,(TP)
+ ADDB C,-2(TP) ;BUMP BOTH POINTERS
+ JUMPL C,EQVEC1
+ JRST EQLST2
+
+EQUVEC: HLRE A,1(C) ;GET LENGTHS
+ HLRZ B,1(D)
+ CAIE B,(A) ;SKIP IF EQUAL
+ POPJ P,
+
+ HRRZ B,1(C) ;START COMPUTING DOPE WORD LOCN
+ SUB B,A ;B POINTS TO DOPE WORD
+ GETYP 0,(B) ;GET UNIFORM TYPE
+ HRRZ B,1(D) ;NOW FIND OTHER DOPE WORD
+ SUB B,A
+ GETYP B,(B) ;OTHER UNIFORM TYPE
+ CAIE 0,(B) ;TYPES THE SAME?
+ POPJ P, ;NO, LOSE
+
+ JUMPGE A,CPOPJ1 ;IF ZERO LENGTH ALREADY WON
+
+ HRLZI B,(B) ;TYPE TO LH
+ PUSH P,B ;AND SAVED
+ PUSHJ P,PUSHCD ;SAVE ARGS
+
+EQUV1: MOVEI C,1(TP) ;POINT TO WHERE WILL GO
+ PUSH TP,(P)
+ MOVE A,-3(TP) ;PUSH ONE OF THE VECTORS
+ PUSH TP,(A) ; PUSH ELEMENT
+ MOVEI D,1(TP) ;POINT TO 2D ARG
+ PUSH TP,(P)
+ MOVE A,-3(TP) ;AND PUSH ITS POINTER
+ PUSH TP,(A)
+ PUSHJ P,IEQUAL
+ JRST UNEQUV
+
+ SUB TP,[4,,4] ;POP TP
+ MOVE A,[1,,1]
+ ADDM A,(TP) ;BUMP POINTERS
+ ADDB A,-2(TP)
+ JUMPL A,EQUV1 ;JUMP IF STILL MORE STUFF
+ SUB P,[1,,1] ;POP OFF TYPE
+ JRST EQLST2
+
+UNEQUV: SUB P,[1,,1]
+ SUB TP,[10,,10]
+ POPJ P,
+\f
+
+
+EQCHST: HRRZ B,(C) ; GET LENGTHS
+ HRRZ A,(D)
+ CAIE A,(B) ;SAME
+ JRST EQCHS3 ;NO, LOSE
+ LDB 0,[300600,,1(C)]
+ LDB E,[300600,,1(D)]
+ CAIE 0,(E)
+ JRST EQCHS3
+ MOVE C,1(C)
+ MOVE D,1(D)
+ JUMPE A,EQCHS4 ;BOTH 0 LENGTH, WINS
+
+EQCHS2:
+ ILDB 0,C ;GET NEXT CHARS
+ ILDB E,D
+ CAME 0,E ; SKIP IF STILL WINNING
+ JRST EQCHS3 ; NOT =
+ SOJG A,EQCHS2
+
+EQCHS4: AOS (P)
+EQCHS3: POPJ P,
+
+PUSHCD: PUSH TP,(C)
+ PUSH TP,1(C)
+ PUSH TP,(D)
+ PUSH TP,1(D)
+ POPJ P,
+
+\f
+; REST/NTH/AT/PUT/GET
+
+; ARG CHECKER
+
+ARGS1: MOVE E,[JRST WTYP2] ; ERROR CONDITION FOR 2D ARG NOT FIXED
+ARGS2: HLRE 0,AB ; CHECK NO. OF ARGS
+ ASH 0,-1 ; TO - NO. OF ARGS
+ AOJG 0,TFA ; 0--TOO FEW
+ AOJL 0,TMA ; MORE THAT 2-- TOO MANY
+ MOVEI C,1 ; DEFAULT ARG2
+ JUMPN 0,ARGS4 ; GET STRUCTURED ARG
+ARGS3: GETYP A,2(AB)
+ CAIN A,TOFFS ; OFFSET?
+ JRST ARGOFF ; GO DO DECL-CHECK AND SUCH
+ CAIE A,TFIX ; SHOULD BE FIXED NUMBER
+ XCT E ; DO ERROR THING
+ SKIPGE C,3(AB) ; BETTER BE NON-NEGATIVE
+ JRST OUTRNG
+ARGS4: MOVEI B,(AB) ; POINT TO STRUCTURED POINTER
+ PUSHJ P,PTYPE ; GET PRIM TYPE
+ MOVEI E,(A) ; DISPATCH CODE TO E
+ MOVE A,(AB) ; GET ARG 1
+ MOVE B,1(AB)
+ POPJ P,
+ARGOFF: HLRZ B,3(AB) ; PICK UP DECL POINTER FOR OFFSET
+ JUMPE B,ARGOF1
+ MOVE A,(B) ; TYPE WORD
+ MOVE B,1(B) ; VALUE
+ MOVE C,(AB)
+ MOVE D,1(AB)
+ PUSHJ P,TMATCH ; CHECK THE DECL
+ JRST WTYP1 ; FIRST ARG WRONG TYPE
+ARGOF1: HRRE C,3(AB) ; GET THE FIX
+ JUMPL C,OUTRNG
+ JRST ARGS4 ; FINISH
+
+; REST
+
+IMFUNCTION REST,SUBR
+
+ ENTRY
+ PUSHJ P,ARGS1 ; GET AND CHECK ARGS
+ PUSHJ P,@RESTBL(E) ; DO IT BASED ON TYPE
+ MOVE C,A ; THE FOLLOWING IS TO MAKE STORAGE WORK
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIN A,SSTORE ; SKIP IF NOT STORAGE
+ MOVSI C,TSTORA ; USE ITS PRIMTYPE
+ MOVE A,C
+ JRST FINIS
+
+PRDISP RESTBL,IWTYP1,[[P2WORD,LREST],[PNWORD,UREST],[P2NWOR,VREST],[PARGS,AREST]
+[PCHSTR,SREST],[PTMPLT,TMPRST],[PBYTE,BREST]]
+
+; AT
+
+MFUNCTION AT,SUBR
+
+ ENTRY
+ PUSHJ P,ARGS1
+ SOJL C,OUTRNG
+ PUSHJ P,@ATTBL(E)
+ JRST FINIS
+
+PRDISP ATTBL,IWTYP1,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
+[PCHSTR,STAT],[PTMPLT,TAT],[PBYTE,BTAT]]
+
+\f
+; NTH
+
+MFUNCTION NTH,SUBR
+
+ ENTRY
+
+ PUSHJ P,ARGS1
+ SOJL C,OUTRNG
+ PUSHJ P,@NTHTBL(E)
+ JRST FINIS
+
+PRDISP NTHTBL,IWTYP1,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWOR,VNTH],[PARGS,ANTH]
+[PCHSTR,SNTH],[PTMPLT,TMPLNT],[PBYTE,BNTH]]
+
+; GET
+
+MFUNCTION GET,SUBR
+
+ ENTRY
+ MOVE E,IIGETP ; MAKE ARG CHECKER FAIL INTO GETPROP
+ PUSHJ P,ARGS5 ; CHECK ARGS
+ SOJL C,OUTRNG
+ SKIPN E,IGETBL(E) ; GET DISPATCH ADR
+ JRST IGETP ; REALLY PUTPROP
+ JUMPE 0,TMA
+ PUSHJ P,(E) ; DISPATCH
+ JRST FINIS
+
+PRDISP IGETBL,0,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWORD,VNTH],[PARGS,ANTH]
+[PCHSTR,SNTH],[PTMPLT,TMPLNT],[PBYTE,BNTH]]
+
+; GETL
+
+MFUNCTION GETL,SUBR
+
+ ENTRY
+ MOVE E,IIGETL ; ERROR HACK
+ PUSHJ P,ARGS5
+ SOJL C,OUTRNG ; LOSER
+ SKIPN E,IGTLTB(E)
+ JRST IGETLO ; REALLY GETPL
+ JUMPE 0,TMA
+ PUSHJ P,(E) ; DISPATCH
+ JRST FINIS
+
+IIGETL: JRST IGETLO
+
+PRDISP IGTLTB,0,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
+[PCHSTR,STAT],[PBYTE,BTAT]]
+
+
+; ARG CHECKER FOR PUT/GET/GETL
+
+ARGS5: HLRE 0,AB ; -# OF ARGS
+ ASH 0,-1
+ ADDI 0,2 ; 0 OR -1 WIN
+ JUMPG 0,TFA
+ AOJL 0,TMA ; MORE THAN 3
+ JRST ARGS3 ; GET ARGS
+\f
+; PUT
+
+MFUNCTION PUT,SUBR
+
+ ENTRY
+ MOVE E,IIPUTP
+ PUSHJ P,ARGS5 ; GET ARGS
+ SKIPN E,IPUTBL(E)
+ JRST IPUTP
+ CAML AB,[-5,,] ; SKIP IF GOOD ARRGS
+ JRST TFA
+ SOJL C,OUTRNG
+ PUSH TP,4(AB)
+ PUSH TP,5(AB)
+ PUSHJ P,(E)
+ MOVE A,(AB) ; RET STRUCTURE
+ MOVE B,1(AB)
+ JRST FINIS
+
+PRDISP IPUTBL,0,[[P2WORD,LPUT],[PNWORD,UPUT],[P2NWORD,VPUT],[PARGS,APUT]
+[PCHSTR,SPUT],[PTMPLT,TMPPUT],[PBYTE,BPUT]]
+
+; IN
+
+MFUNCTION IN,SUBR
+
+ ENTRY 1
+
+ MOVEI B,(AB) ; POINT TO ARG
+ PUSHJ P,PTYPE
+ MOVS E,A ; REAL DISPATCH TO E
+ MOVE B,1(AB)
+ MOVE A,(AB)
+ GETYP C,A ; IN CASE NEEDED
+ PUSHJ P,@INTBL(E)
+ JRST FINIS
+
+PRDISP INTBL,OTHIN,[[P2WORD,LNTH1],[PNWORD,UIN],[P2NWORD,VIN],[PARGS,AIN]
+[PCHSTR,SIN],[PTMPLT,TIN],[PBYTE,BINN]]
+
+OTHIN: CAIE C,TLOCN ; ASSOCIATION LOCATIVE
+ JRST OTHIN1 ; MAYBE LOCD
+ HLLZ 0,VAL(B)
+ PUSHJ P,RMONCH
+ MOVE A,VAL(B)
+ MOVE B,VAL+1(B)
+ POPJ P,
+
+OTHIN1: CAIN C,TLOCD
+ JRST VIN
+ JRST WTYP1
+
+\f
+; SETLOC
+
+MFUNCTION SETLOC,SUBR
+
+ ENTRY 2
+
+ MOVEI B,(AB) ; POINT TO ARG
+ PUSHJ P,PTYPE ; DO TYPE
+ MOVS E,A ; REAL TYPE
+ MOVE B,1(AB)
+ MOVE C,2(AB) ; PASS ARG
+ MOVE D,3(AB)
+ MOVE A,(AB) ; IN CASE
+ GETYP 0,A
+ PUSHJ P,@SETTBL(E)
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ JRST FINIS
+
+PRDISP SETTBL,OTHSET,[[P2WORD,LSTUF],[PNWORD,USTUF],[P2NWORD,VSTUF],[PARGS,ASTUF]
+[PCHSTR,SSTUF],[PTMPLT,TSTUF],[PBYTE,BSTUF]]
+
+OTHSET: CAIE 0,TLOCN ; ASSOC?
+ JRST OTHSE1
+ HLLZ 0,VAL(B) ; GET MONITORS
+ PUSHJ P,MONCH
+ MOVEM C,VAL(B)
+ MOVEM D,VAL+1(B)
+ POPJ P,
+
+OTHSE1: CAIE 0,TLOCD
+ JRST WTYP1
+ JRST VSTUF
+
+; LREST -- REST A LIST IN B BY AMOUNT IN C
+
+LREST: MOVSI A,TLIST
+ JUMPE C,CPOPJ
+ MOVE PVP,PVSTOR+1
+ MOVEM A,BSTO(PVP)
+
+LREST2: INTGO ;CHECK INTERRUPTS
+ JUMPE B,OUTRNG ; CANT CDR NIL
+ HRRZ B,(B) ;CDR THE LIST
+ SOJG C,LREST2 ;COUNT DOWN
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP) ;RESET BSTO
+ POPJ P,
+
+\f
+; VREST -- REST A VECTOR, AREST -- REST AN ARG BLOCK
+
+VREST: SKIPA A,$TVEC ; FINAL TYPE
+AREST: HRLI A,TARGS
+ ASH C,1 ; TIMES 2
+ JRST UREST1
+
+; UREST -- REST A UVECTOR
+
+STORST: SKIPA A,$TSTORA
+UREST: MOVSI A,TUVEC
+UREST1: JUMPE C,CPOPJ
+ HRLI C,(C)
+ JUMPL C,OUTRNG
+ ADD B,C ; REST IT
+ CAILE B,-1 ; OUT OF RANGE ?
+ JRST OUTRNG
+ POPJ P,
+
+
+; SREST -- REST A STRING
+
+BREST: SKIPA D,[TBYTE]
+
+SREST: MOVEI D,TCHSTR
+ PUSH P,D
+ JUMPE C,SREST1
+ PUSH P,A ; SAVE TYPE WORD
+ PUSH P,C ; SAVE AMOUNT
+ MOVEI D,(A) ; GET LENGTH
+ CAILE C,(D) ; SKIP IF OK
+ JRST OUTRNG
+ LDB D,[366000,,B] ;POSITION FIELD OF BYTE POINTER
+ LDB A,[300600,,B] ;SIZE FIELD
+ PUSH P,A ;SAVE SIZE
+ IDIVI D,(A) ;COMPUT BYTES IN 1ST WORD
+ MOVEI 0,36. ;NOW COMPUTE BYTES PER WORD
+ IDIVI 0,(A) ;BYTES PER WORD IN 0
+ MOVE E,0 ;COPY OF BYTES PER WORD TO E
+ SUBI 0,(D) ;0 # OF UNSUED BYTES IN 1ST WORD
+ ADDB C,0 ;C AND 0 NO.OF CHARS FROM WORD BOUNDARY
+ IDIVI C,(E) ;C/ REL WORD D/ CHAR IN LAST
+ ADDI C,(B) ;POINTO WORD WITH C
+ POP P,A ;RESTORE BITS PER BYTE
+ JUMPN D,.+3 ; JUMP IF NOT WD BOUNDARY
+ MOVEI D,(E) ; USE FULL AMOUNT
+ SUBI C,1 ; POINT TO PREV WORD
+ IMULI A,(D) ;A/ BITS USED IN LAST WORD
+ MOVEI 0,36.
+ SUBI 0,(A) ;0 HAS NEW POSITION FIELD
+ DPB 0,[360600,,B] ;INTO BYTE POINTER
+ HRRI B,(C) ;POINT TO RIGHT WORD
+ POP P,C ; RESTORE AMOUNT
+ POP P,A
+ SUBI A,(C) ; NEW LENGTH
+SREST1: POP P,0
+ HRL A,0
+ POPJ P,
+
+; TMPRST -- REST A TEMPLATE DATA STRUCTURE
+
+TMPRST: PUSHJ P,TM.TOE ; CHECK ALL BOUNDS ETC.
+ MOVSI D,(D)
+ HLL C,D
+ MOVE B,C ; RET IN B
+ MOVSI A,TTMPLT
+ POPJ P,
+
+; LAT -- GET A LOCATIVE TO A LIST
+
+LAT: PUSHJ P,LREST ; GET POINTER
+ JUMPE B,OUTRNG ; YOU LOSE!
+ MOVSI A,TLOCL ; NEW TYPE
+ POPJ P,
+
+\f
+; UAT -- GET A LOCATIVE TO A UVECTOR
+
+UAT: PUSHJ P,UREST
+ MOVSI A,TLOCU
+ JRST POPJL
+
+; VAT -- GET A LOCATIVE TO A VECTOR
+
+VAT: PUSHJ P,VREST ; REST IT AND TYPE IT
+ MOVSI A,TLOCV
+ JRST POPJL
+
+; AAT -- GET A LOCATIVE TO AN ARGS BLOCK
+
+AAT: PUSHJ P,AREST
+ HRLI A,TLOCA
+POPJL: JUMPGE B,OUTRNG ; LOST
+ POPJ P,
+
+; STAT -- LOCATIVE TO A STRING
+
+STAT: PUSHJ P,SREST
+ TRNN A,-1 ; SKIP IF ANY LEFT
+ JRST OUTRNG
+ HRLI A,TLOCS ; LOCATIVE
+ POPJ P,
+
+; BTAT -- LOCATIVE TO A BYTE-STRING
+
+BTAT: PUSHJ P,BREST
+ TRNN A,-1 ; SKIP IF ANY LEFT
+ JRST OUTRNG
+ HRLI A,TLOCB ; LOCATIVE
+ POPJ P,
+
+; TAT -- LOCATIVE TO A TEMPLATE
+
+TAT: PUSHJ P,TMPRST
+ PUSH TP,A
+ PUSH TP,B
+ GETYP A,(B) ; GET REAL SAT
+ SUBI A,NUMSAT+1
+ HRLS A ; READY TO HIT TABLE
+ ADD A,TD.LNT+1
+ JUMPGE A,BADTPL
+ MOVE C,B ; DATUM TO C
+ XCT (A) ; GET LENGTH
+ HLRZS C ; REST COUNTER
+ SUBI B,(C) ; FLUSH IT OFF
+ JUMPE B,OUTRNG
+ MOVE B,(TP)
+ SUB TP,[2,,2]
+ MOVSI A,TLOCT
+ POPJ P,
+
+
+; LNTH -- NTH OF LIST
+
+LNTH: PUSHJ P,LAT
+LNTH1: PUSHJ P,RMONC0 ; CHECK READ MONITORS
+ HLLZ A,(B) ; GET GOODIE
+ MOVE B,1(B)
+ JSP E,CHKAB ; HACK DEFER
+ POPJ P,
+
+; VNTH -- NTH A VECTOR, ANTH -- NTH AN ARGS BLOCK
+
+ANTH: PUSHJ P,AAT
+ JRST .+2
+
+VNTH: PUSHJ P,VAT
+AIN:
+VIN: PUSHJ P,RMONC0
+ MOVE A,(B)
+ MOVE B,1(B)
+ POPJ P,
+
+; UNTH -- NTH OF UVECTOR
+
+UNTH: PUSHJ P,UAT
+UIN: HLRE C,B ; FIND DW
+ SUBM B,C
+ HLLZ 0,(C) ; GET MONITORS
+ MOVE D,0
+ TLZ D,TYPMSK#<-1>
+ PUSH P,D
+ PUSHJ P,RMONCH ; CHECK EM
+ POP P,A
+ MOVE B,(B) ; AND VALUE
+ POPJ P,
+
+\f
+; BNTH -- NTH A BYTE STRING
+
+BNTH: PUSHJ P,BTAT
+BINN: PUSH P,$TFIX
+ JRST SIN1
+
+; SNTH -- NTH A STRING
+
+SNTH: PUSHJ P,STAT
+SIN: PUSH P,$TCHRS
+SIN1: PUSH TP,A
+ PUSH TP,B ; SAVE POINT BYTER
+ MOVEI C,-1(TP) ; FIND DOPE WORD
+ PUSHJ P,BYTDOP
+ HLLZ 0,-1(A) ; GET
+ POP TP,B
+ POP TP,A
+ PUSHJ P,RMONCH
+ ILDB B,B ; GET CHAR
+ POP P,A
+ POPJ P,
+
+; TIN -- IN OF A TEMPLATE
+
+TIN: MOVEI C,0
+
+; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE
+
+TMPLNT: ADDI C,1
+ PUSHJ P,TM.TOE ; GET POINTER TO INS IN E
+ ADD A,TD.GET+1 ; POINT TO GETTER
+ MOVE A,(A) ; GET VECTOR OF INS
+ ADDI E,-1(A) ; POINT TO INS
+ SUBI D,1
+ XCT (E) ; DO IT
+ JFCL ; SKIP IF AN ANY CASE
+ POPJ P, ; RETURN
+
+; LPUT -- PUT ON A LIST
+
+LPUT: PUSHJ P,LAT ; POSITION
+ POP TP,D
+ POP TP,C
+
+; LSTUF -- HERE TO STUFF A LIST ELEMENT
+
+LSTUF: PUSHJ P,MONCH0 ; CHECK OUT MONITOR BITS
+ GETYP A,C ; ISOLATE TYPE
+ PUSHJ P,NWORDT ; NEED TO DEFER?
+ SOJN A,DEFSTU
+ HLLM C,(B)
+ MOVEM D,1(B) ; AND VAL
+ POPJ P,
+
+DEFSTU: PUSH TP,$TLIST
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,CELL2 ; GET WORDS
+ POP TP,1(B)
+ POP TP,(B)
+ MOVE E,(TP)
+ SUB TP,[2,,2]
+ MOVEM B,1(E)
+ HLLZ 0,(E) ; GET OLD MONITORS
+ TLZ 0,TYPMSK ; KILL TYPES
+ TLO 0,TDEFER ; MAKE DEFERRED
+ HLLM 0,(E)
+ POPJ P,
+
+; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK
+
+APUT: PUSHJ P,AAT
+ JRST .+2
+
+VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR
+ POP TP,D ; GET GOODIE BACK
+ POP TP,C
+
+; AVSTUF -- CLOBBER ARGS AND VECTORS
+
+ASTUF:
+VSTUF: PUSHJ P,MONCH0
+ MOVEM C,(B)
+ MOVEM D,1(B)
+ POPJ P,
+
+\f
+
+
+; UPUT -- CLOBBER A UVECTOR
+
+UPUT: PUSHJ P,UAT ; GET IT RESTED
+ POP TP,D
+ POP TP,C
+
+; USTUF -- HERE TO CLOBBER A UVECTOR
+
+USTUF: HLRE E,B
+ SUBM B,E ; C POINTS TO DOPE
+ GETYP A,(E) ; GET UTYPE
+ GETYP 0,C
+ CAIE 0,(A) ; CHECK SAMENESS
+ JRST WRNGUT
+ HLLZ 0,(E) ; MONITOR BITS IN DOPE WORD
+ MOVSI A,TLOCU ; CHOMP, CHOMP (WAS TUVEC) -- MARC 5/2/78
+ PUSHJ P,MONCH
+ MOVEM D,(B) ; SMASH
+ POPJ P,
+
+; BPUT -- HERE TO PUT A BYTE-STRING
+
+BPUT: PUSHJ P,BTAT
+ POP TP,D
+ POP TP,C
+BSTUF: MOVEI E,TFIX
+ JRST SSTUF1
+
+; SPUT -- HERE TO PUT A STRING
+
+SPUT: PUSHJ P,STAT ; REST IT
+ POP TP,D
+ POP TP,C
+
+; SSTUF -- STUFF A STRING
+
+SSTUF: MOVEI E,TCHRS
+SSTUF1: GETYP 0,C ; BETTER BE CHAR
+ CAIE 0,(E)
+ JRST WTYP3
+ PUSH P,C
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI C,-1(TP) ; FIND D.W.
+ PUSHJ P,BYTDOP
+ SKIPGE (A)-1 ; SKIP IF NOT REALLY ATOM
+ JRST PNMNG
+ HLLZ 0,(A)-1 ; GET MONITORS
+ POP TP,B
+ POP TP,A
+ POP P,C
+ PUSHJ P,MONCH
+ IDPB D,B ; STASH
+ POPJ P,
+
+PNMNG: POP TP,B
+ POP TP,A
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ATTEMPT-TO-MUNG-ATOMS-PNAME
+ HRLI A,TCHSTR
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI A,2
+ JRST CALER
+
+; TSTUF -- SETLOC A TEMPLATE
+
+TSTUF: PUSH TP,C
+ PUSH TP,D
+ MOVEI C,0
+
+; PUTTMP -- TEMPLATE PUTTER
+
+TMPPUT: ADDI C,1
+ PUSHJ P,TM.TOE ; GET E POINTING TO SLOT #
+ ADD A,TD.PUT+1 ; POINT TO INS
+ MOVE A,(A) ; GET VECTOR OF INS
+ ADDI E,-1(A)
+ POP TP,B ; NEW VAL TO A AND B
+ POP TP,A
+ SUBI D,1
+ XCT (E) ; DO IT
+ JRST BADPUT
+ POPJ P,
+
+TM.LN1: SUBI 0,NUMSAT+1
+ HRRZ A,0 ; RET FIXED OFFSET
+ HRLS 0
+ ADD 0,TD.LNT+1 ; USE LENGTHERS FOR TEST
+ JUMPGE 0,BADTPL
+ PUSH P,C
+ MOVE C,B
+ HRRZS 0 ; POINT TO TABLE ENTRY
+ PUSH P,A
+ XCT @0 ; DO IT
+ POP P,A
+ POP P,C
+ POPJ P,
+
+TM.TBL: MOVEI E,(D) ; TENTATIVE WINNER IN E
+ TLNN B,-1 ; SKIP IF REST HAIR EXISTS
+ POPJ P, ; NO, WIN
+
+ PUSH P,A ; SAVE OFFSET
+ HRLS A ; A IS REL OFFSET TO INS TABLE
+ ADD A,TD.GET+1 ; GET ONEOF THE TABLES
+ MOVE A,(A) ; TABLE POINTER TO A
+ MOVSI 0,-1(D) ; START SEEING IF PAST TEMP SPEC
+ ADD 0,A
+ JUMPL 0,CPOPJA ; JUMP IF E STILL VALID
+ HLRZ E,B ; BASIC LENGTH TO E
+ HLRE 0,A ; LENGTH OF TEMPLATE TO 0
+ ADDI 0,(E) ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE
+ MOVNS 0
+ SUBM D,E ; E ==> # PAST BASIC WANTED
+ EXCH 0,E
+ IDIVI 0,(E) ; A ==> REL REST GUY WANTED
+ HLRZ E,B
+ ADDI E,1(A)
+CPOPJA: POP P,A
+ POPJ P,
+
+; TM.TOE -- GET RIGHT TEMPLATE # IN E
+; C/ OBJECT #, B/ OBJECT POINTER
+
+TM.TOE: GETYP 0,(B) ; GET REAL SAT
+ MOVEI D,(C) ; OBJ # TO D
+ HLRZ C,B ; REST COUNT
+ ADDI D,(C) ; FUDGE FOR REST COUNTER
+ MOVE C,B ; POINTER TO C
+ PUSHJ P,TM.LN1 ; GET LENGTH IN B (WATCH LH!)
+ CAILE D,(B) ; CHECK RANGE
+ JRST OUTRNG ; LOSER, QUIT
+ JRST TM.TBL ; GO COMPUTE TABLE OFFSET
+
+\f; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B
+; FIXES (P)
+
+CPTYEE: MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ JUMPE A,WTYPUN
+ SUBM M,-1(P)
+ EXCH E,A
+ POPJ P,
+
+; COMPILER CALLS TO MANY OF THESE GUYS
+
+CIREST: PUSHJ P,CPTYEE ; TYPE OF DISP TO E
+ HRRES C ; CLEAR LH, IN CASE IT'S AN OFFSET
+ JUMPL C,OUTRNG
+ CAIN 0,SSTORE
+ JRST CIRST1
+ PUSHJ P,@RESTBL(E)
+ JRST MPOPJ
+
+CIRST1: PUSHJ P,STORST
+ JRST MPOPJ
+
+CINTH: PUSHJ P,CPTYEE
+ HRRES C ; CLEAR LH
+ SOJL C,OUTRNG ; CHECK BOUNDS
+ PUSHJ P,@NTHTBL(E)
+ JRST MPOPJ
+
+CIAT: PUSHJ P,CPTYEE
+ SOJL C,OUTRNG
+ PUSHJ P,@ATTBL(E)
+ JRST MPOPJ
+
+CSETLO: PUSHJ P,CTYLOC
+ MOVSS E ; REAL DISPATCH
+ GETYP 0,A ; INCASE LOCAS OR LOCD
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,@SETTBL(E)
+ POP TP,B
+ POP TP,A
+ JRST MPOPJ
+
+CIN: PUSHJ P,CTYLOC
+ MOVSS E ; REAL DISPATCH
+ GETYP C,A
+ PUSHJ P,@INTBL(E)
+ JRST MPOPJ
+
+CTYLOC: MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ SUBM M,-1(P)
+ EXCH A,E
+ POPJ P,
+
+; COMPILER'S PUT,GET AND GETL
+
+CIGET: PUSH P,[0]
+ JRST .+2
+
+CIGETL: PUSH P,[1]
+ MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ EXCH A,E
+ JUMPE E,CIGET1 ; REAL GET, NOT NTH
+ GETYP 0,C ; INDIC FIX?
+ CAIE 0,TFIX
+ CAIN 0,TOFFS
+ JRST .+2
+ JRST CIGET1
+ POP P,E ; GET FLAG
+ AOS (P) ; ALWAYS SKIP
+ MOVE C,D ; # TO AN AC
+ JRST @.+1(E)
+ SETZ CINTH
+ SETZ CIAT
+
+CIGET1: POP P,E ; GET FLAG
+ JRST @GETTR(E) ; DO A REAL GET
+
+GETTR: SETZ CIGTPR
+ SETZ CIGETP
+
+CIPUT: SUBM M,(P)
+ MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ EXCH A,E
+ PUSH TP,-1(TP) ; PAIN AND SUFFERING
+ PUSH TP,-1(TP)
+ MOVEM A,-3(TP)
+ MOVEM B,-2(TP)
+ JUMPE E,CIPUT1
+ GETYP 0,C
+ CAIE 0,TFIX ; YES DO STRUCT
+ CAIN 0,TOFFS
+ JRST .+2
+ JRST CIPUT1
+ MOVE C,D
+ HRRES C
+ SOJL C,OUTRNG ; CHECK BOUNDS
+ PUSHJ P,@IPUTBL(E)
+PMPOPJ: POP TP,B
+ POP TP,A
+ JRST MPOPJ
+
+CIPUT1: PUSHJ P,IPUT
+ JRST PMPOPJ
+\f
+; SMON -- SET MONITOR BITS
+; B/ <POINTER TO LOCATIVE>
+; D/ <IORM> OR <ANDCAM>
+; E/ BITS
+
+SMON: GETYP A,(B)
+ PUSHJ P,PTYPE ; TO PRIM TYPE
+ HLRZS A
+ SKIPE A,SMONTB(A) ; DISPATCH?
+ JRST (A)
+
+; COULD STILL BE LOCN OR LOCD
+
+ GETYP A,(B) ; TYPE BACK
+ CAIE A,TLOCN
+ JRST SMON2 ; COULD BE LOCD
+ MOVE C,1(B) ; POINT
+ HRRI D,VAL(C) ; MAKE INST POINT
+ JRST SMON3
+
+SMON2: CAIE A,TLOCD
+ JRST WRONGT
+
+
+; SET LIST/TUPLE/ID LOCATIVE
+
+SMON4: HRR D,1(B) ; POINT TO TYPE WORD
+SMON3: XCT D
+ POPJ P,
+
+; SET UVEC LOC
+
+SMON5: HRRZ C,1(B) ; POINT TO TOP OF UV
+ HLRE 0,1(B)
+ SUB C,0 ; POINT TO DOPE
+ HRRI D,(C) ; POINT IN INST
+ JRST SMON3
+
+; SET CHSTR LOC
+
+SMON6: MOVEI C,(B) ; FOR BYTDOP
+ PUSHJ P,BYTDOP ; POINT TO DOPE
+ HRRI D,(A)-1
+ JRST SMON3
+
+PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4]
+[PNWORD,SMON5],[PCHSTR,SMON6],[PBYTE,SMON6]]
+
+\f
+; COMPILER'S MONAD?
+
+CIMON: PUSH P,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ JUMPE A,CIMON1
+ POP P,A
+ JRST CEMPTY
+
+CIMON1: POP P,A
+ JRST YES
+
+; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE
+
+MFUNCTION MONAD,SUBR,MONAD?
+
+ ENTRY 1
+
+ MOVE B,AB ; CHECK PRIM TYPE
+ PUSHJ P,PTYPE
+ JUMPE A,ITRUTH ;RETURN ARGUMENT
+ SKIPE B,1(AB)
+ JRST @MONTBL(A) ;DISPATCH ON PTYPE
+ JRST ITRUTH
+
+PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1]
+[PCHSTR,CHMON],[PTMPLT,TMPMON],[PBYTE,CHMON]]
+
+MON1: JUMPGE B,ITRUTH ;EMPTY VECTOR
+ JRST IFALSE
+
+CHMON: HRRZ B,(AB)
+ JUMPE B,ITRUTH
+ JRST IFALSE
+
+TMPMON: PUSHJ P,LNTMPL
+ JUMPE B,ITRUTH
+ JRST IFALSE
+
+CISTRU: GETYP A,A ; COMPILER CALL
+ PUSHJ P,ISTRUC
+ JRST NO
+ JRST YES
+
+ISTRUC: PUSHJ P,SAT ; STORAGE TYPE
+ SKIPE A,PRMTYP(A)
+ AOS (P) ; SKIP IF WINS
+ POPJ P,
+
+; SUBR TO CHECK FOR LOCATIVE
+
+MFUNCTION %LOCA,SUBR,[LOCATIVE?]
+
+ ENTRY 1
+ GETYP A,(AB)
+ PUSHJ P,LOCQQ
+ JRST IFALSE
+ JRST ITRUTH
+
+; SKIPS IF TYPE IN A IS A LOCATIVE
+
+LOCQ: GETYP A,(B) ; GET TYPE
+LOCQQ: PUSH P,A ; SAVE FOR LOCN/LOCD
+ PUSHJ P,SAT
+ MOVE A,PRMTYP(A)
+ JUMPE A,LOCQ1
+ SUB P,[1,,1]
+ TRNN A,-1
+LOCQ2: AOS (P)
+ POPJ P,
+
+LOCQ1: POP P,A ; RESTORE TYPE
+ CAIE A,TLOCN
+ CAIN A,TLOCD
+ JRST LOCQ2
+ POPJ P,
+
+\f
+; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS
+
+MFUNCTION MEMBER,SUBR
+
+ MOVE E,[PUSHJ P,EQLTST] ;TEST ROUTINE IN E
+ JRST MEMB
+
+MFUNCTION MEMQ,SUBR
+
+ MOVE E,[PUSHJ P,EQTST] ;EQ TESTER
+
+MEMB: ENTRY 2
+ MOVE B,AB ;POINT TO FIRST ARG
+ PUSHJ P,PTYPE ;CHECK PRIM TYPE
+ ADD B,[2,,2] ;POINT TO 2ND ARG
+ PUSHJ P,PTYPE
+ JUMPE A,WTYP2 ;2ND WRONG TYPE
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MOVE C,2(AB) ; FOR TUPLE CASE
+ SKIPE B,3(AB) ;GOBBLE LIST VECTOR ETC. POINTER
+ PUSHJ P,@MEMTBL(A) ;DISPATCH
+ JRST IFALSE ;OR REPORT LOSSAGE
+ JRST FINIS
+
+PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC]
+[PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP],[PBYTE,MEMBYT]]
+
+
+
+MEMLST: MOVSI 0,TLIST ;SET B'S TYPE TO LIST
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,BSTO(PVP)
+ JUMPE B,MEMLS6 ; EMPTY LIST LOSE IMMEDIATE
+
+MEMLS1: INTGO ;CHECK INTERRUPTS
+ MOVEI C,(B) ;COPY POINTER
+ GETYP D,(C) ;GET TYPE
+ MOVSI A,(D) ;COPY
+ CAIE D,TDEFER ;DEFERRED?
+ JRST MEMLS2
+ MOVE C,1(C) ;GET DEFERRED DATUM
+ GETYPF A,(C) ;GET FULL TYPE WORD
+MEMLS2: MOVE C,1(C) ;GET DATUM
+ XCT E ;DO THE COMPARISON
+ JRST MEMLS3 ;NO MATCH
+ MOVSI A,TLIST
+MEMLS5: AOS (P)
+MEMLS6: MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP) ;RESET B'S TYPE
+ POPJ P,
+
+MEMLS3: HRRZ B,(B) ;STEP THROGH
+ JUMPN B,MEMLS1 ;STILL MORE TO DO
+MEMLS4: MOVSI A,TFALSE ;RETURN FALSE
+ JRST MEMLS6 ;RETURN 0
+
+MEMTUP: HRRZ A,C
+ TLOA A,TARGS
+MEMVEC: MOVSI A,TVEC ;CLOBBER B'S TYPE TO VECTOR
+ JUMPGE B,MEMLS4 ;EMPTY VECTOR
+ MOVE PVP,PVSTOR+1
+ MOVEM A,BSTO(PVP)
+
+MEMV1: INTGO ;CHECK FOR INTS
+ GETYPF A,(B) ;GET FULL TYPE
+ MOVE C,1(B) ;AND DATA
+ XCT E ;DO COMPARISON INS
+ JRST MEMV2 ;NOT EQUAL
+ MOVE PVP,PVSTOR+1
+ MOVE A,BSTO(PVP)
+ JRST MEMLS5 ;RETURN WITH POINTER
+\f
+MEMV2: ADD B,[2,,2] ;INCREMENT AND GO
+ JUMPL B,MEMV1 ;STILL WINNING
+MEMV3: MOVEI B,0
+ JRST MEMLS4 ;AND RETURN FALSE
+
+MUVEC: JUMPGE B,MEMLS4
+ GETYP A,-1(TP) ;GET TYPE OF GODIE
+ HLRE C,B ;LOOK FOR UNIFORM TYPE
+ SUBM B,C ;DOPE POINTER TO C
+ GETYP C,(C) ;GET THE TYPE
+ CAIE A,(C) ;ARE THEY THE SAME?
+ JRST MEMLS4 ;NO, LOSE
+ MOVSI A,TUVEC
+ CAIN 0,SSTORE
+ MOVSI A,TSTORA
+ PUSH P,A
+ MOVE PVP,PVSTOR+1
+ MOVEM A,BSTO(PVP)
+ MOVSI A,(C) ;TYPE TO LH
+ PUSH P,A ; SAVE FOR EACH TEST
+
+MUVEC1: INTGO ;CHECK OUT INTS
+ MOVE C,(B) ;GET DATUM
+ MOVE A,(P) ; GET TYPE
+ XCT E ;COMPARE
+ AOBJN B,MUVEC1 ;LOOP TO WINNAGE
+ SUB P,[1,,1]
+ POP P,A
+ JUMPGE B,MEMV3 ;LOSE RETURN
+
+MUVEC2: JRST MEMLS5
+
+
+MEMBYT: MOVEI 0,TFIX
+ MOVEI D,TBYTE
+ JRST MEMBY1
+
+MEMCH: MOVEI 0,TCHRS
+ MOVEI D,TCHSTR
+MEMBY1: GETYP A,-1(TP) ;IS ARG A SINGLE CHAR
+ CAIE 0,(A) ;SKIP IF POSSIBLE WINNER
+ JRST MEMSTR
+ MOVEI 0,(C)
+ MOVE D,(TP) ; AND CHAR
+
+MEMCH1: SOJL 0,MEMV3
+ MOVE E,B
+ ILDB A,B
+ CAIE A,(D) ;CHECK IT
+ SOJA C,MEMCH1
+
+MEMCH2: MOVE B,E
+ MOVE A,C
+ JRST MEMLS5
+
+MEMSTR: CAIN A,(D)
+ CAME E,[PUSHJ P,EQLTST]
+ JRST MEMV3
+ LDB A,[300600,,(TP)]
+ LDB 0,[300600,,B]
+ CAIE 0,(A)
+ JRST MEMV3
+ MOVEI 0,(C) ; GET # OF CHAR INTO 0
+ ILDB D,(TP)
+ PUSH P,D ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK
+
+MEMST1: SOJL 0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR
+ MOVE E,B
+ ILDB A,B
+ CAME A,(P)
+ SOJA C,MEMST1 ; MATCH FAILS TRY NEXT
+
+ PUSH P,B
+ PUSH P,E
+ PUSH P,C
+ PUSH P,0
+ MOVE E,(TP) ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP
+ HRRZ C,-1(TP) ; LENGTH OF 1ARG
+MEMST2: SOJE C,MEMWN ; WON -RAN OUT OF 1ARG FIRST-
+ SOJL MEMLSR ; LOST -RAN OUT OF 2ARG-
+ ILDB A,B
+ ILDB D,E
+ CAIN A,(D) ; SKP IF POSSIBLY LOST -BACK TO MEMST1-
+ JRST MEMST2
+
+ POP P,0
+ POP P,C
+ POP P,E
+ POP P,B
+ SOJA C,MEMST1
+
+MEMWN: MOVE B,-2(P) ; SETS UP ARGS LIKE MEMCH2 - HAVE WON
+ MOVE A,-1(P)
+ SUB P,[5,,5]
+ JRST MEMLS5
+
+MEMLSR: SUB P,[5,,5]
+ JRST MEMV3
+
+MEMLS: SUB P,[1,,1]
+ JRST MEMV3
+
+; MEMBERSHIP FOR TEMPLATE HACKER
+
+MEMTMP: GETYP 0,(B) ; GET REAL SAT
+ PUSH P,E
+ PUSH P,0
+ PUSH TP,A
+ PUSH TP,B ; SAVE GOOEIE
+ PUSHJ P,TM.LN1 ; GET LENGTH
+ MOVEI B,(B)
+ HLRZ A,(TP) ; FUDGE FOR REST
+ SUBI B,(A)
+ PUSH P,B ; SAVE LENGTH
+ PUSH P,[-1]
+ POP TP,B
+ POP TP,A
+ MOVE PVP,PVSTOR+1
+ MOVEM B,BSTO+1(PVP)
+
+MEMTM1: MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ AOS C,(P)
+ SOSGE -1(P)
+ JRST MEMTM2
+ MOVE 0,-2(P)
+ PUSHJ P,TMPLNT ; GET ITEM
+ EXCH C,B ; VALUE TO C, POINTER BACK TO B
+ MOVE E,-3(P)
+ MOVSI 0,TTMPLT
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,BSTO(PVP)
+ XCT E
+ SKIPA
+ JRST MEMTM3
+ MOVE PVP,PVSTOR+1
+ MOVE B,BSTO+1(PVP)
+ JRST MEMTM1
+
+MEMTM3: MOVE PVP,PVSTOR+1
+ MOVE B,BSTO+1(PVP)
+ HRL B,(P) ; DO APPROPRIATE REST
+ AOS -4(P)
+MEMTM2: SUB P,[4,,4]
+ MOVSI A,TTMPLT
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ POPJ P,
+
+EQTST: GETYP A,A
+ GETYP 0,-1(TP)
+ CAMN C,(TP) ;CHECK VALUE
+ CAIE 0,(A) ;AND TYPE
+ POPJ P,
+ JRST CPOPJ1
+
+EQLTST: MOVE PVP,PVSTOR+1
+ PUSH TP,BSTO(PVP)
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,C
+ SETZM BSTO(PVP)
+ PUSH P,E ;SAVE INS
+ MOVEI C,-5(TP) ;SET UP CALL TO IEQUAL
+ MOVEI D,-1(TP)
+ AOS -1(P) ;ASSUME SKIP
+ PUSHJ P,IEQUAL ;GO INO EQUAL
+ SOS -1(P) ;UNDO SKIP
+ SUB TP,[2,,2] ;AND POOP OF CRAP
+ POP TP,B
+ MOVE PVP,PVSTOR+1
+ POP TP,BSTO(PVP)
+ POP P,E
+ POPJ P,
+
+; COMPILER MEMQ AND MEMBER
+
+CIMEMB: SKIPA E,[PUSHJ P,EQLTST]
+
+CIMEMQ: MOVE E,[PUSHJ P,EQTST]
+ SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ GETYP A,C
+ PUSHJ P,CPTYPE
+ JUMPE A,WTYPUN
+ MOVE B,D ; STRUCT TO B
+ PUSHJ P,@MEMTBL(A)
+ TDZA 0,0 ; FLAG NO SKIP
+ MOVEI 0,1 ; FLAG SKIP
+ SUB TP,[2,,2]
+ JUMPE 0,NOM
+ SOS (P) ; SKIP RETURN
+ JRST MPOPJ
+\f
+
+; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR
+
+MFUNCTION TOP,SUBR
+
+ ENTRY 1
+
+ MOVE B,AB ;CHECK ARG
+ PUSHJ P,PTYPE
+ MOVEI E,(A)
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,@TOPTBL(E) ;DISPATCH
+ JRST FINIS
+
+PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP]
+[PTMPLT,BCKTOP],[PBYTE,BTOP]]
+
+BCKTOP: MOVEI B,(B) ; FIX UP POINTER
+ MOVSI A,TTMPLT
+ POPJ P,
+
+UVTOP: SKIPA A,$TUVEC
+VTOP: MOVSI A,TVEC
+ CAIN 0,SSTORE
+ MOVSI A,TSTORA
+ JUMPE B,CPOPJ
+ HLRE C,B ;AND -LENGTH
+ HRRZS B
+ SUB B,C ;POINT TO DOPE WORD
+ HLRZ D,1(B) ;TOTAL LENGTH
+ SUBI B,-2(D) ;POINT TO TOP
+ MOVNI D,-2(D) ;-LENGTH
+ HRLI B,(D) ;B NOW POINTS TO TOP
+ POPJ P,
+
+BTOP: SKIPA E,$TBYTE
+CHTOP: MOVSI E,TCHSTR
+ JUMPE B,CPOPJ
+ PUSH P,E
+ PUSH TP,A
+ PUSH TP,B
+ LDB 0,[360600,,(TP)] ; POSITION FIELD
+ LDB E,[300600,,(TP)] ; AND SIZE FILED
+ IDIVI 0,(E) ; 0/ BYTES IN 1ST WORD
+ MOVEI C,36. ; BITS PER WORD
+ IDIVI C,(E) ; BYTES PER WORD
+ PUSH P,C
+ SUBM C,0 ; UNUSED BYTES I 1ST WORD
+ ADD 0,-1(TP) ; LENGTH OF WORD BOUNDARIED STRING
+ MOVEI C,-1(TP) ; GET DOPE WORD
+ PUSHJ P,BYTDOP
+ HLRZ C,(A) ; GET LENGTH
+ SKIPGE -1(A) ; SKIP IF NOT REALLY ATOM
+ SUBI C,3 ; IF IT IS, 3 LESS WORDS
+ SUBI A,-1(C) ; START +1
+ MOVEI B,-1(A) ; SETUP BYTER
+ SUB A,(TP) ; WORDS DIFFERENT
+ IMUL A,(P) ; CHARS EXTRA
+ SUBM 0,A ; FINAL TOTAL TO A
+ HLL A,-1(P)
+ MOVE C,(P)
+ SUB P,[2,,2]
+ DPB E,[300600,,B]
+ IMULI E,(C) ; BITS USED IN FULL WORD
+ MOVEI C,36.
+ SUBI C,(E) ; WHERE TO POINT IN EMPTY? CASE
+ DPB C,[360600,,B]
+ SUB TP,[2,,2]
+ POPJ P,
+\f
+
+
+ATOP:
+
+GETATO: HLRE C,B ;GET -LENGTH
+ HRROS B
+ SUB B,C ;POINT PAST
+ GETYP 0,(B) ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY)
+ CAIN 0,TENTRY ;IF ENTRY
+ JRST EASYTP ;WANT UNEVALUATED ARGS
+ HRRE C,(B) ;ELSE-- GET NO. OF ARGS (*-2)
+ SUBI B,(C) ;GO TO TOP
+ TLCA B,-1(C) ;STORE NUMBER IN TOP POINTER
+EASYTP: MOVE B,FRAMLN+ABSAV(B) ;GET ARG POINTER
+ HRLI A,TARGS
+ POPJ P,
+
+; COMPILERS ENTRY TO TOP
+
+CITOP: PUSHJ P,CPTYEE
+ CAIN E,P2WORD ; LIST?
+ JRST WTYPL
+ PUSHJ P,@TOPTBL(E)
+ JRST MPOPJ
+
+; FUNCTION TO CLOBBER THE CDR OF A LIST
+
+MFUNCTION PUTREST,SUBR,[PUTREST]
+ ENTRY 2
+
+ MOVE B,AB ;COPY ARG POINTER
+ PUSHJ P,PTYPE ;CHECK IT
+ CAIE A,P2WORD ;LIST?
+ JRST WTYP1 ;NO, LOSE
+ ADD B,[2,,2] ;AND NEXT ONE
+ PUSHJ P,PTYPE
+ CAIE A,P2WORD
+ JRST WTYP2 ;NOT LIST, LOSE
+ HRRZ B,1(AB) ;GET FIRST
+ JUMPE B,OUTRNG
+ MOVE D,3(AB) ;AND 2D LIST
+ CAIL B,HIBOT
+ JRST PURERR
+ HRRM D,(B) ;CLOBBER
+ MOVE A,(AB) ;RETURN CALLED TYPE
+ JRST FINIS
+
+\f
+
+; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING
+
+MFUNCTION BACK,SUBR
+
+ ENTRY
+
+ MOVEI C,1 ;ASSUME BACKING UP ONE
+ JUMPGE AB,TFA ;NO ARGS IS TOO FEW
+ CAML AB,[-2,,0] ;SKIP IF MORE THAN 2 ARGS
+ JRST BACK1 ;ONLY ONE ARG
+ GETYP A,2(AB) ;GET TYPE
+ CAIE A,TFIX ;MUST BE FIXED
+ JRST WTYP2
+ SKIPGE C,3(AB) ;GET NUMBER
+ JRST OUTRNG
+ CAMGE AB,[-4,,0] ;SKIP IF WINNING NUMBER OF ARGS
+ JRST TMA
+BACK1: MOVE B,AB ;SET UP TO FIND TYPE
+ PUSHJ P,PTYPE ;GET PRIM TYPE
+ MOVEI E,(A)
+ MOVE A,(AB)
+ SKIPN B,1(AB) ;GET DATUM
+ JRST OUTRNG
+ PUSHJ P,@BCKTBL(E)
+ JRST FINIS
+
+PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA]
+[PTMPLT,BCKTMP],[PBYTE,BACKB]]
+
+BACKV: LSH C,1 ;GENERAL, DOUBLE AMOUNT
+ SKIPA A,$TVEC
+BACKU: MOVSI A,TUVEC
+ CAIN 0,SSTORE
+ MOVSI A,TSTORA
+ HRLI C,(C) ;TO BOTH HALVES
+ SUB B,C ;BACK UP VECTOR POINTER
+ HLRE C,B ;FIND OUT IF OVERFLOW
+ SUBM B,C ;DOPE POINTER TO C
+ HLRZ D,1(C) ;GET LENGTH
+ SUBI C,-2(D) ;POINT TO TOP
+ ANDI C,-1
+ CAILE C,(B) ;SKIP IF A WINNER
+ JRST OUTRNG ;COMPLAIN
+BACKUV: POPJ P,
+
+BCKTMP: MOVSI C,(C)
+ SUB B,C ; FIX UP POINTER
+ JUMPL B,OUTRNG
+ MOVSI A,TTMPLT
+ POPJ P,
+
+BACKB: SKIPA E,[TBYTE]
+BACKC: MOVEI E,TCHSTR
+ PUSH TP,A
+ PUSH TP,B
+ ADDI A,(C) ; NEW LENGTH
+ HRLI A,(E)
+ PUSH P,A ; SAVE COUNT
+ LDB E,[300600,,B] ;BYTE SIZE
+ MOVEI 0,36. ;BITS PER WORD
+ IDIVI 0,(E) ;DIVIDE TO FIND BYTES/WORD
+ IDIV C,0 ;C/ WORDS BACK, D/BYTES BACK
+ SUBI B,(C) ;BACK WORDS UP
+ JUMPE D,CHBOUN ;CHECK BOUNDS
+
+ IMULI 0,(E) ;0/ BITS OCCUPIED BY FULL WORD
+ LDB A,[360600,,B] ;GET POSITION FILED
+BACKC2: ADDI A,(E) ;BUMP
+ CAIGE A,36.
+ JRST BACKC1 ;O.K.
+ SUB A,0
+ SUBI B,1 ;DECREMENT POINTER PART
+BACKC1: SOJG D,BACKC2 ;DO FOR ALL BYTES
+\f
+
+
+ DPB A,[360600,,B] ;FIX UP POINT BYTER
+CHBOUN: MOVEI C,-1(TP)
+ PUSHJ P,BYTDOP ; FIND DOPE WORD
+ HLRZ C,(A)
+ SKIPGE -1(A) ; SKIP IF NOT REALLY AN ATOM
+ SUBI C,3 ; ELSE FUDGE FOR VALUE CELL AND OBLIST SLOT
+ SUBI A,-1(C) ; POINT TO TOP
+ MOVE C,B ; COPY BYTER
+ IBP C
+ CAILE A,(C) ; SKIP IF OK
+ JRST OUTRNG
+ POP P,A ; RESTORE COUNT
+ SUB TP,[2,,2]
+ POPJ P,
+
+
+BACKA: LSH C,1 ;NUMBER TIMES 2
+ HRLI C,(C) ;TO BOTH HALVES
+ SUB B,C ;FIX POINTER
+ MOVE E,B ;AND SAVE
+ PUSHJ P,GETATO ;LOOK A T TOP
+ CAMLE B,E ;COMPARE
+ JRST OUTRNG
+ MOVE B,E
+ POPJ P,
+
+; COMPILER'S BACK
+
+CIBACK: PUSHJ P,CPTYEE
+ JUMPL C,OUTRNG
+ CAIN E,P2WORD
+ JRST WTYPL
+ PUSHJ P,@BCKTBL(E)
+ JRST MPOPJ
+\f
+MFUNCTION STRCOMP,SUBR
+
+ ENTRY 2
+
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVE C,2(AB)
+ MOVE D,3(AB)
+ PUSHJ P,ISTRCM
+ JRST FINIS
+
+ISTRCM: GETYP 0,A
+ CAIE 0,TCHSTR
+ JRST ATMCMP ; MAYBE ATOMS
+
+ GETYP 0,C
+ CAIE 0,TCHSTR
+ JRST WTYP2
+
+ MOVEI A,(A) ; ISOLATR LENGHTS
+ MOVEI C,(C)
+
+STRCO2: SOJL A,CHOTHE ; ONE STRING EXHAUSTED, CHECK OTHER
+ SOJL C,1BIG ; 1ST IS BIGGER
+ ILDB 0,B
+ ILDB E,D
+ CAIN 0,(E) ; SKIP IF DIFFERENT
+ JRST STRCO2
+ CAIL 0,(E) ; SKIP IF 2D BIGGER THAN 1ST
+ JRST 1BIG
+2BIG: MOVNI B,1
+ JRST RETFIX
+
+CHOTHE: JUMPN C,2BIG ; 2 IS BIGGER
+SM.CMP: TDZA B,B ; RETURN 0
+1BIG: MOVEI B,1
+RETFIX: MOVSI A,TFIX
+ POPJ P,
+
+ATMCMP: CAIE 0,TATOM ; COULD BE ATOM
+ JRST WTYP1 ; NO, QUIT
+ GETYP 0,C
+ CAIE 0,TATOM
+ JRST WTYP2
+
+ CAMN B,D ; SAME ATOM?
+ JRST SM.CMP
+ ADD B,[3,,3] ; SKIP VAL CELL ETC.
+ ADD D,[3,,3]
+
+ATMCM1: MOVE 0,(B) ; GET A WORD OF CHARS
+ CAME 0,(D) ; SAME?
+ JRST ATMCM3 ; NO, GET DIF
+ AOBJP B,ATMCM2
+ AOBJN D,ATMCM1 ; MORE TO COMPARE
+ JRST 1BIG ; 1ST IS BIGGER
+
+
+ATMCM2: AOBJP D,SM.CMP ; EQUAL
+ JRST 2BIG
+
+ATMCM3: LSH 0,-1 ; AVOID SIGN LOSSAGE
+ MOVE C,(D)
+ LSH C,-1
+ CAMG 0,C
+ JRST 2BIG
+ JRST 1BIG
+
+\f;ERROR COMMENTS FOR SOME PRIMITIVES
+
+OUTRNG: ERRUUO EQUOTE OUT-OF-BOUNDS
+
+WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+
+IIGETP: JRST IGETP ;FUDGE FOR MIDAS/STINK LOSSAGE
+IIPUTP: JRST IPUTP
+
+\f;SUPER USEFUL ERROR MESSAGES (USED BY WHOLE WORLD)
+
+WNA: ERRUUO EQUOTE WRONG-NUMBER-OF-ARGUMENTS
+
+TFA: ERRUUO EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
+
+TMA: ERRUUO EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
+
+WRONGT:
+WTYP: ERRUUO EQUOTE ARG-WRONG-TYPE
+
+IWTYP1:
+WTYP1: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
+
+IWTYP2:
+WTYP2: ERRUUO EQUOTE SECOND-ARG-WRONG-TYPE
+
+BADTPL: ERRUUO EQUOTE BAD-TEMPLATE-DATA
+
+BADPUT: ERRUUO EQUOTE TEMPLATE-TYPE-VIOLATION
+
+WTYP3: ERRUUO EQUOTE THIRD-ARG-WRONG-TYPE
+
+WTYPL: ERRUUO EQUOTE INTERNAL-BACK-OR-TOP-OF-A-LIST
+
+WTYPUN: ERRUUO EQUOTE NON-STRUCTURED-ARG-TO-INTERNAL-PUT-REST-NTH-TOP-OR-BACK
+
+CALER1: MOVEI A,1
+CALER: HRRZ C,FSAV(TB)
+ PUSH TP,$TATOM
+ CAIL C,HIBOT
+ SKIPA C,@-1(C) ; SUBRS AND FSUBRS
+ MOVE C,3(C) ; FOR RSUBRS
+ PUSH TP,C
+ ADDI A,1
+ ACALL A,ERROR
+ JRST FINIS
+
+
+GETWNA: HLRZ B,(E)-2 ;GET LOSING COMPARE INSTRUCTION
+ CAIE B,(CAIE A,) ;AS EXPECTED ?
+ JRST WNA ;NO,
+ HRRE B,(E)-2 ;GET DESIRED NUMBER OF ARGS
+ HLRE A,AB ;GET ACTUAL NUMBER OF ARGS
+ CAMG B,A
+ JRST TFA
+ JRST TMA
+
+END
+\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff