X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=blobdiff_plain;f=%3Cmdl.int%3E%2Fprimit.mid.316;fp=%3Cmdl.int%3E%2Fprimit.mid.316;h=4147a23d9815439c32d8bc3d0590a6dea86af4dc;hp=0000000000000000000000000000000000000000;hb=bab072f950a643ac109660a223b57e635492ac25;hpb=233a3c5245f8274882cc9d27a3c20e9b3678000c diff --git a//primit.mid.316 b//primit.mid.316 new file mode 100644 index 0000000..4147a23 --- /dev/null +++ b//primit.mid.316 @@ -0,0 +1,2830 @@ +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 + + +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 + + + +; 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 + + + +; 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 + + + + +; 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 + ;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____ + 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 + + +; 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, + + +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 + + + +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 + + + + +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) + + +; 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, + +; 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, + + + +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, + + +; 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]] + + +; 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 + +; 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 + + +; 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, + + +; 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, + + +; 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, + + +; 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, + +DEFRCY: MOVE E,1(B) ; RECYCLE THIS HANDY DEFER + MOVEM C,(E) + MOVEM D,1(E) + POPJ P, + +DEFSTU: GETYP A,(B) + CAIN A,TDEFER + JRST DEFRCY + 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, + + + + +; 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 + + ; 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 + +; SMON -- SET MONITOR BITS +; B/ +; D/ OR +; 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]] + + +; 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, + + +; 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 + +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 + + +; 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, + + + +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 + + + +; 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 + + + + 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 + +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 + + ;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 + + ;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 + \ No newline at end of file