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