TITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM RELOCATABLE .INSRT MUDDLE > .GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP .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,ISTRCM ; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE PRMTYP: REPEAT NUMSAT,[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]] 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 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 SUBSTRUC,SUBR ENTRY JUMPGE AB,TFA ;need at least one arg CAMGE AB,[-10,,0] ;NO MORE THEN 4 JRST TMA MOVE B,AB PUSHJ P,PTYPE ;get primtype in A PUSH P,A JRST @TYTBL(A) RESSUB: CAMLE AB,[-2,,0] ;if only one arg skip rest JRST @COPYTB(A) HLRZ B,(AB)2 ;GET TYPE CAIE B,TFIX ;IF FIX OK JRST WRONGT MOVE B,(AB)1 ;ptr to object of resting MOVE C,(AB)3 ;# of times to rest MOVEI E,(A) MOVE A,(AB) PUSHJ P,@MRSTBL(E) PUSH TP,A ;type PUSH TP,B ;put rested sturc on stack JRST ALOCOK PRDISP TYTBL,IWTYP1,[[P2WORD,RESSUB],[P2NWORD,RESSUB] [PNWORD,RESSUB],[PCHSTR,RESSUB]] PRDISP MRSTBL,IWTYP1,[[P2WORD,LREST],[P2NWORD,VREST] [PNWORD,UREST],[PCHSTR,SREST]] PRDISP COPYTB,IWTYP1,[[P2WORD,CPYLST],[P2NWORD,CPYVEC] [PNWORD,CPYUVC],[PCHSTR,CPYSTR]] PRDISP ALOCTB,IWTYP1,[[P2WORD,ALLIST],[P2NWORD,ALVEC] [PNWORD,ALUVEC],[PCHSTR,ALSTR]] 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) ALOCOK: CAML AB,[-4,,0] ;exactly 3 args JRST ALOCFX HLRZ C,(AB)4 CAIE C,TFIX ;OK IF TYPE FIX JRST WRONGT POP P,C ;C HAS PRIMTYYPE MOVE A,(AB)5 ;# of elements needed JRST @ALOCTB(C) ;DO ALLOCATION CPYVEC: HLRE A,(AB)1 ;USE WHEN ONLY ONE ARG MOVNS A ASH A,-1 ;# OF ELEMENTS FOR ALLOCATION PUSH TP,(AB) PUSH TP,(AB)1 ALVEC: PUSH P,A ASH A,1 HRLI A,(A) ADD A,(TP) CAIL A,-1 ;CHK FOR OUT OF RANGE JRST OUTRNG CAMGE AB,[-6,,] ; 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 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 HRL B,(TP) ;bleft-ptr to source , b right -ptr to allocated space BLT B,(A) MOVE B,C POP P,A SUB TP,[2,,2] MOVSI A,TVEC JRST FINIS ALVEC2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR CAIE 0,TVEC JRST WTYP HLRE A,7(AB) ; CHECK SIZE MOVNS A ASH A,-1 ; # OF ELEMENTS CAMGE A,(P) ; SKIP IF BIG ENOUGH JRST OUTRNG MOVE B,7(AB) ; WINNER, JOIN COMMON CODE JRST ALVEC1 CPYUVC: HLRE A,(AB)1 ;# OF ELEMENTS FOR ALLOCATION MOVNS A PUSH TP,(AB) PUSH TP,1(AB) ALUVEC: PUSH P,A HRLI A,(A) ADD A,(TP) ;PTING TO DOPE WORD OF ORIG VEC CAIL A,-1 JRST OUTRNG CAMGE AB,[-6,,] ; SKIP IF WE SUPPLY UVECTOR JRST ALUVE2 MOVE A,(P) PUSHJ P,IBLOCK ALUVE1: MOVE A,(P) ;# of owrds to allocate HRLI A,(A) ADD A,B ;LOCATION O FIRST ALLOCATED DOPE WORD HLR D,(AB)1 ;# OF ELEMENTS IN UVECTOR MOVNS D ADD D,(AB)1 ;LOCATION OF FIRST DOPE WORD FOR SOURCE GETYP E,(D) ;GET UTYPE CAML AB,[-6,,] ; SKIP IF USER SUPPLIED OUTPUT UVECTOR HRLM E,(A) ;DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC CAMGE AB,[-6,,] CAIN 0,(E) ; 0 HAS USER UVEC UTYPE JRST .+2 JRST WRNGUT CAIL A,-1 JRST OUTRNG MOVE C,B ; SAVE POINTER TO FINAL GUY HRL C,(TP) ;Bleft- ptr to source, Bright-ptr to allocated space BLT C,-1(A) POP P,A MOVSI A,TUVEC JRST FINIS ALUVE2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR CAIE 0,TUVEC JRST WTYP HLRE A,7(AB) ; CHECK SIZE MOVNS A CAMGE A,(P) ; SKIP IF BIG ENOUGH JRST OUTRNG MOVE B,7(AB) ; WINNER, JOIN COMMON CODE HLRE A,B SUBM B,A GETYP 0,(A) ; GET UTYPE OF USER UVECTOR JRST ALUVE1 CPYSTR: HRR A,(AB) ;#OF CHAR TO COPY PUSH TP,(AB) ;ALSTR EXPECTS STRING IN TP PUSH TP,1(AB) ALSTR: PUSH P,A HRRZ 0,-1(TP) ;0 IS LENGTH OFF VECTOR CAIGE 0,(A) JRST OUTRNG CAMGE AB,[-6,,] ; SKIP IF WE SUPPLY STRING JRST ALSTR2 ADDI A,4 IDIVI A,5 PUSHJ P,IBLOCK ;ALLOCATE SPACE HRLI B,440700 MOVE A,(P) ; # OF CHARS TO A ALSTR1: PUSH P,B ;BYTE PTR TO ALOC SPACE POP TP,C ;PTR TO ORIGINAL STR POP TP,D ;USELESS COPYST: ILDB D,C ;GET NEW CHAR IDPB D,B ;DEPOSIT CHAR SOJG A,COPYST ;FINISH TRANSFER? CLOSTR: POP P,B ;BYTE PTR TO COPY POP P,A ;# FO ELEMENTS HRLI A,TCHSTR JRST FINIS ALSTR2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR CAIE 0,TCHSTR JRST WTYP HRRZ A,6(AB) CAMGE A,(P) ; SKIP IF BIG ENOUGH JRST OUTRNG EXCH A,(P) MOVE B,7(AB) ; WINNER, JOIN COMMON CODE JRST ALSTR1 CPYLST: SKIPN 1(AB) 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,1(AB) ;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: POP TP,B ;USELESS POP TP,B ;PTR TO NEW LIST POP TP,A ;TYPE JRST FINIS ALLIST: CAMGE AB,[-6,,] ; SKIP IF WE BUILD THE LIST JRST CPYLS2 JUMPE A,ZEROLT PUSH P,A 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 ;PTR TO NEW LIST POP TP,A ;type JRST FINIS ZEROLT: SUB TP,[1,,1] ;IF RESTED ALL OF LIST SUB TP,[1,,1] MOVSI A,TLIST MOVEI B,0 JRST FINIS CPYLS2: GETYP 0,6(AB) CAIE 0,TLIST JRST WTYP MOVE B,7(AB) ; 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 B,7(AB) MOVSI A,TLIST JRST FINIS ; 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(TVP) 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: PUSH TP,$TATOM PUSH TP,EQUOTE ILLEGAL-ARGUMENT-BLOCK JRST CALER1 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: PUSH TP,$TATOM PUSH TP,EQUOTE ILLEGAL-FRAME JRST CALER1 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 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: PUSH TP,$TATOM PUSH TP,EQUOTE ILLEGAL-LOCATIVE JRST CALER1 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 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,MQUOTE 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]] LNLST: SKIPN C,B ; EMPTY? JRST LNLST2 ; YUP, LEAVE MOVEI B,1 ; INIT COUNTER MOVSI A,TLIST ;WILL BECOME INTERRUPTABLE 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: 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(TVP) 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,COMPERR PUSHJ P,@LENTBL(A) ; DISPATCH MOVSI A,TFIX SUB P,[1,,1] MPOPJ: SUBM M,(P) POPJ P, CILNQ: SUBM M,(P) PUSH P,C MOVE C,A GETYP A,A PUSHJ P,CPTYPE JUMPE A,COMPERR 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, IDNT1: MOVE A,(AB) ;RETURN THE FIRST ARG MOVE B,1(AB) JRST FINIS MFUNCTION 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,MQUOTE 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: 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,COMPERR 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 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: NOM CTAB2: YESM NOM ; INTERNAL EQUAL SUBROUTINE IEQUAL: MOVE B,C ;NOW CHECK THE ARGS PUSHJ P,PTYPE MOVE B,D PUSHJ P,PTYPE 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 JRST @EQTBL(A) ;DISPATCH PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC] [PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL]] 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 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,-1(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(TVP) XCT (A) ; OTHER LENGTH TO B HLRZ 0,B ; REST OFFSETTER PUSH P,0 MOVEI B,-1(B) HLRZ C,(TP) SUBI B,(C) 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,TM.TOE ; GET OFFSET TO TEMPLATE ADD A,TD.GET+1(TVP) MOVE A,(A) ADDI E,(A) XCT (E) ; VAL TO A AND B MOVEM A,-3(TP) MOVEM B,-2(TP) MOVE C,(P) MOVE B,-4(TP) ; OTHER GUY MOVE 0,-2(P) PUSHJ P,TM.TOE ADD A,TD.GET+1(TVP) MOVE A,(A) ADDI E,(A) XCT (E) ; GET OTHER VALUE 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 HLRZ 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 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 CAIE 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) 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, ; REST MFUNCTION 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]] ; 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]] ; 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]] ; 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]] ; 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]] ; 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]] ; 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]] 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: CAIE C,TLOCD JRST WTYP1 JRST VIN ; 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]] 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 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 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 SREST: 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 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: HRLI A,TCHSTR 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, ; 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(TVP) 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, ; SNTH -- NTH A STRING SNTH: PUSHJ P,STAT SIN: 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 MOVSI A,TCHRS 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(TVP) ; POINT TO GETTER MOVE A,(A) ; GET VECTOR OF INS ADDI E,-1(A) ; POINT TO INS SUBI D,1 XCT (E) ; DO IT POPJ P, ; RETURN ; LPUT -- PUT ON A LIST LPUT: PUSHJ P,LAT ; POSITION POP TP,D POP TP,C ; LSTUF -- HERE TO STUFF A LIST ELEMENT LSTUF: PUSHJ P,MONCH0 ; CHECK OUT MONITOR BITS GETYP A,C ; ISOLATE TYPE PUSHJ P,NWORDT ; NEED TO DEFER? SOJN A,DEFSTU HLLM C,(B) MOVEM D,1(B) ; AND VAL POPJ P, DEFSTU: PUSH TP,$TLIST PUSH TP,B PUSH TP,C PUSH TP,D PUSHJ P,CELL2 ; GET WORDS POP TP,1(B) POP TP,(B) MOVE E,(TP) SUB TP,[2,,2] MOVEM B,1(E) HLLZ 0,(E) ; GET OLD MONITORS TLZ 0,TYPMSK ; KILL TYPES TLO 0,TDEFER ; MAKE DEFERRED HLLM 0,(E) POPJ P, ; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK APUT: PUSHJ P,AAT JRST .+2 VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR POP TP,D ; GET GOODIE BACK POP TP,C ; AVSTUF -- CLOBBER ARGS AND VECTORS ASTUF: VSTUF: PUSHJ P,MONCH0 MOVEM C,(B) MOVEM D,1(B) POPJ P, ; 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,TUVEC PUSHJ P,MONCH MOVEM D,(B) ; SMASH POPJ P, ; SPUT -- HERE TO PUT A STRING SPUT: PUSHJ P,STAT ; REST IT POP TP,D POP TP,C ; SSTUF -- STUFF A STRING SSTUF: GETYP 0,C ; BETTER BE CHAR CAIE 0,TCHRS JRST WTYP3 PUSH TP,A PUSH TP,B MOVEI C,-1(TP) ; FIND D.W. PUSHJ P,BYTDOP HLLZ 0,(A)-1 ; GET MONITORS POP TP,B POP TP,A MOVSI C,TCHRS PUSHJ P,MONCH IDPB D,B ; STASH POPJ P, ; 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(TVP) ; 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(TVP) ; 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(TVP) ; 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,COMPERR 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 JUMPL C,OUTRNG CAIN 0,SSTORE JRST CIRST1 PUSHJ P,@RESTBL(E) JRST MPOPJ CIRST1: PUSHJ P,STORST JRST MPOPJ CINTH: PUSHJ P,CPTYEE 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 JRST CIGET1 POP P,E ; GET FLAG AOS (P) ; ALWAYS SKIP MOVE C,D ; # TO AN AC JRST @.+1(E) CINTH CIAT CIGET1: POP P,E ; GET FLAG JRST @GETTR(E) ; DO A REAL GET GETTR: CIGTPR 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 JRST CIPUT1 MOVE C,D 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]] ; 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]] 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, ; MUDDLE SORT ROUTINE ; P-STACK OFFSETS MUDDLE SORT ROUTINE ; P-STACK OFFSETS FOR THIS PROGRAM XCHNG==0 ; FLAG SAYING AN EXCHANGE HAS HAPPENED PLACE==-1 ; WHERE WE ARE NOW UTYP==-2 ; TYPE OF UNIFORM VECTOR DELT==-3 ; DIST BETWEEN COMPARERS MFUNCTION SORT,SUBR ENTRY HLRZ 0,AB ; CHECK FOR ENOUGH ARGS CAILE 0,-4 JRST TFA GETYP A,(AB) ; 1ST MUST EITHER BE FALSE OR APPLICABLE CAIN A,TFALSE JRST SORT1 ; FALSE, OK PUSHJ P,APLQ ; IS IT APPLICABLE JRST NAPT ; NO, LOSER SORT1: MOVE B,AB ADD B,[2,,2] ; BUMP TO POINT TO MAIN ARRAY SETZB D,E ; 0 # OF STUCS AND LNTH SORT2: GETYP A,(B) ; GET ITS TYPE PUSHJ P,PTYPE ; IS IT STRUCTURED? MOVEI C,1 ; CHECK TYPE OF STRUC CAIN A,PNWORD ; UVEC? MOVEI C,0 ; YUP CAIE A,PARGS CAIN A,P2NWORD ; VECTOR MOVNI C,1 JUMPG C,WTYP PUSH TP,(B) ; PUSH IT PUSH TP,1(B) ADD B,[2,,2] ; GO ON MOVEI A,1 ; DEFAULT REC SIZE PUSHJ P,NXFIX ; SIZE OF RECORD? HLRZ 0,-2(TP) ; -LNTH OF STUC HRRZ A,(TP) ; LENGTH OF REC IDIVI 0,(A) ; DIV TO GET - # OF RECS SKIPN D ; PREV LENGTH EXIST? MOVE D,0 ; NO USE THIS CAME 0,D JRST SLOSE0 MOVEI A,0 ; DEF REC SIZE PUSHJ P,NXFIX ; AND OFFSET OF KEY SUBI E,1 JUMPL B,SORT2 ; GO ON HRRM E,4(TB) ; SAVE THAT IN APPROPRIATE PLACE MOVE 0,3(TB) CAMG 0,5(TB) ; CHECK FOR BAD OFFSET JRST SLOSE3 ; NOW CHECK WHATEVER STUCTURE THIS IS IS UNIFORM AND HAS GOOD ELEMENTS HLRE B,1(TB) ; COMP LENGTH MOVNS B HRRZ C,2(TB) ; GET VEC/UVEC FLAG MOVEI D,(B) ASH B,(C) ; FUDGE JUMPE C,.+3 ; SKIP FOR UVEC MOVE 0,[1,,1] ; ELSE FUDGE KEY OFFSET ADDM 0,5(TB) HRRZ 0,3(TB) ; GET REC LENGTH IDIV D,0 ; # OF RECS JUMPN E,SLOSE4 CAIG D,1 ; MORE THAN 1? JRST SORTD ; NO, DONE ALREADY GETYP 0,(AB) ; TYPE OF COMPARER CAIE 0,TFALSE ; IF FALSE, STRUCT MUST CONTAIN FIX,FLOAT,ATOM OR STRING JRST SORT3 ; USER SUPPLIED COMPARER, LET HIM WORRY ; NOW CHECK OUT ELEMENT TYPES JUMPN C,SORT5 ; JUMP IF GENERAL MOVEI D,1(B) ; FIND END OF VECTOR ADD D,1(TB) ; D POINTS TO END PUSHJ P,TYPCH1 ; GET TYPE AND CHECK IT JRST SORT6 SORT5: MOVE D,1(TB) ; POINT TO VEC ADD D,5(TB) ; INTO REC TO KEY PUSHJ P,TYPCH1 SAMELP: GETYP C,-1(D) ; GET TYPE CAIE 0,(C) ; COMPARE TYPE JRST SLOSE2 ADD D,3(TB) ; TO NEXT RECORD JUMPL D,SAMELP SORT6: CAIE A,S1WORD ; 1 WORDS? JRST SORT7 MOVEI E,INTSRT MOVSI A,400000 ; SET UP MASK SORT9: PUSHJ P,ISORT MOVE A,2(AB) MOVE B,3(AB) JRST FINIS SORT7: CAIE A,SATOM ; ATOMS? JRST SORT8 MOVE E,[-3,,ATMSRT] ; SET UP FOR ATOMS MOVE A,[430140,,3(D)] ; BIT POINTER FOR ATOMS JRST SORT9 SORT8: MOVE E,[1,,STRSRT] ; MUST BE STRING SORT MOVE A,[430140,,(D)] ; BYTE POINTER FOR STRINGER JRST SORT9 ; TABLES FOR RADIX SORT CHECKERS INTSRT==0 ATMSRT==1 STRSRT==2 TST1: PUSHJ P,I.TST1 PUSHJ P,A.TST1 PUSHJ P,S.TST1 TST2: PUSHJ P,I.TST2 PUSHJ P,A.TST2 PUSHJ P,S.TST2 NXBIT: ROT A,-1 PUSHJ P,A.NXBI PUSHJ P,S.NXBI PREBIT: ROT A,1 PUSHJ P,A.PREB PUSHJ P,S.PREB ENDTST: SKIPGE A TLOE A,40 TLOE A,40 ; INTEGER SORT SPECIFIC ROUTINES I.TST1: JUMPL A,I.TST3 I.TST4: TDNE A,(D) AOS (P) POPJ P, I.TST2: JUMPL A,I.TST4 I.TST3: TDNN A,(D) AOS (P) POPJ P, ; ATOM SORT SPECIFIC ROUTINES A.TST1: MOVE D,(D) ; GET AN ATOM CAMG E,D ; SKIP IF NOT EXHAUSTED POPJ P, TLZ A,40 ; TELL A BIT HAS HAPPENED LDB D,A ; GET THE BIT SKIPE D AOS (P) ; SKIP IF ON POPJ P, A.TST2: PUSHJ P,A.TST1 ; USE OTHER ROUTINE AOS (P) POPJ P, A.NXBI: TLNN A,770000 ; CHECK FOR WORD CHANGE SUB E,[1,,0] ; FIX WORD CHECKER IBP A POPJ P, A.PREB: ADD A,[10000,,] ; AH FOR A DECR BYTE POINTER SKIPG A CAMG A,[437777,,-1] ; SKIP IF BACKED OVER WORD POPJ P, TLZ A,770000 ; CLOBBER POSIT FIELD SUBI A,1 ; DECR WORD POS FIELD ADD E,[1,,0] ; AND FIX WORD HACKER POPJ P, ; STRING SPECIFIC SORT ROUTINES S.TST1: HRLZ 0,-1(D) ; LENGTH OF STRING IMULI 0,7 ; IN BITS HRRI 0,-1 ; MAKE SURE BIGGER RH CAMG 0,E ; SKIP IF MORE BITS LEFT POPJ P, ; DON TSKIP TLZ A,40 ; BIT FOUND HLRZ 0,(D) ; CHECK FOR SIMPLE CASE HRRZ D,(D) ; POINT TO STRING CAIN 0,440700 ; SKIP IF HAIRY JRST S.TST3 PUSH P,A ; SAVE BYTER MOVEI A,440700 ; COMPUTE BITS NOT USED 1ST WORD SUBI A,@0 HLRZ 0,(P) ; GET BIT POINTER SUBI 0,(A) ; UPDATE POS FIELD JUMPGE 0,.+2 ; NO NEED FOR NEXT WORD ADD 0,[1,,440000] MOVSS 0 HRRZ A,(P) ; REBUILD BYTE POINTER ADDI 0,(A) LDB 0,0 ; GET THE DAMN BYTE POP P,A JRST .+2 S.TST3: LDB 0,A ; GET BYTE FOR EASY CASE SKIPE 0 AOS (P) POPJ P, S.TST2: PUSHJ P,S.TST1 AOS (P) POPJ P, S.NXBI: IBP A ; BUMP BYTER TLNN A,770000 ; SKIP IF NOT END BIT IBP A ; SKIP END BIT (NOT USED IN ASCII STRINGS) ADD E,[1,,0] ; COUNT BIT POPJ P, S.PREB: SUB E,[1,,0] ; DECR CHAR COUNT ADD A,[10000,,0] ; PLEASE GIVE ME A DECRBYTEPNTR SKIPG A CAMG A,[437777,,-1] POPJ P, TLC A,450000 ; POINT TO LAST USED BIT IN WORD SUBI A,1 POPJ P, ; SIMPLE RADIX EXCHANGE ISORT: MOVE B,1(TB) ; START OF VECTOR HLRE D,B ; COMPUTE POINTER TO END OF IT SUBM B,D ; FIND END MOVEI C,(D) ISORT1: PUSH TP,(TB) PUSH TP,C MOVE 0,C ; SEE IF HAVE MET AT MIDDLE SUB 0,3(TB) ANDI 0,-1 CAIGE 0,(B) JRST ISORT7 ; HAVE MET, LEAVE PUSH TP,(TB) ; SAVE OTHER POINTER PUSH TP,B INTGO MOVE B,(TP) ; IN CASE MOVED MOVE C,-2(TP) ISORT3: HRRZ D,5(TB) ; OFFSET TO KEY ADDI D,(B) ; POINT TO KEY XCT TST1(E) ; CHECK FOR LOSER JRST ISORT4 SUB C,3(TB) ; IS THERE ONE TO EXCHANGE WITH HRRZ D,5(TB) ADDI D,(C) XCT TST2(E) ; SKIP IF A POSSIBLE EXCHANGE JRST ISORT2 ; NO EXCH, KEEP LOOKING PUSHJ P,EXCHM ; DO THE EXCHANGE ISORT4: ADD B,3(TB) ; HAVE EXCHANGED, MOVE ON ISORT2: CAME B,C ; MET? JRST ISORT3 ; MORE TO CHECK XCT NXBIT(E) ; NEXT BIT MOVE B,(TP) ; RESTORE TOP POINTER SUB TP,[2,,2] ; FLUSH IT XCT ENDTST(E) JRST ISORT6 PUSHJ P,ISORT1 ; SORT SUB AREA MOVE C,(TP) ; AND OTHER SUB AREA PUSHJ P,ISORT1 ISORT6: XCT PREBIT(E) ISORT7: MOVE B,(TP) SUB TP,[2,,2] POPJ P, ; SCHELL SORT FOR USER SUPPLIED COMPARER SORT3: ADDI D,1 ASH D,-1 ; COMPUTE INITIAL D PUSH P,D ; AND SAVE IT PUSH P,[0] ; MAY HOLD UTYPE OF VECTOR HRRZ 0,(TB) ; 0 NON ZERO MEANS GEN VECT JUMPN 0,SSORT1 ; DONT COMPUTE UTYPE HLRE C,1(TB) HRRZ D,1(TB) ; FIND TYPE SUBI D,(C) GETYP D,(D) MOVSM D,(P) ; AND SAVE SSORT1: PUSH P,[0] ; CURRENT PLACE IN VECTOR PUSH P,[0] ; EXCHANGE FLAG PUSH TP,[0] PUSH TP,[0] ; OUTER LOOP STARTS HERE OUTRLP: SETZM XCHNG(P) ; NO EXHCANGE YET SETZM PLACE(P) INRLP: PUSH TP,(AB) ; PUSH USER COMPARE FCN PUSH TP,1(AB) MOVE C,PLACE(P) ; GET CURRENT PLACE ADD C,1(TB) ; ADD POINTER TO VEC IN ADD C,5(TB) ; OFFSET TO KEY PUSHJ P,GETELM MOVE D,3(TB) IMUL D,DELT(P) ; TIMES WORDS PER REC ADD C,D PUSHJ P,GETELM MCALL 3,APPLY ; APPLY IT GETYP 0,A ; TYPE OF RETURN CAIN 0,TFALSE ; SKIP IF MUST CHANGE JRST INRLP1 MOVE C,1(TB) ; POINT TO START ADD C,PLACE(P) MOVE B,3(TB) IMUL B,DELT(P) ADD B,C PUSHJ P,EXCHM ; EXCHANGE THEM SETOM XCHNG(P) ; SAY AN EXCHANGE TOOK PLACE INRLP1: MOVE C,3(TB) ; GET OFFSET ADDB C,PLACE(P) MOVE D,3(TB) IMUL D,DELT(P) ADD C,D ; CHECK FOR OVERFLOW ADD C,1(TB) JUMPL C,INRLP SKIPE XCHNG(P) ; ANY EXCHANGES? JRST OUTRLP ; YES, RESET PLACE AND GO SOSG D,DELT(P) ; SKIP IF DIST WAS 1 JRST SORTD ADDI D,2 ; COMPUTE NEW DIST ASH D,-1 MOVEM D,DELT(P) JRST OUTRLP SORTD: MOVE A,2(AB) ; DONE, RET 1ST STRUC MOVE B,3(AB) JRST FINIS ; ROUTINE TO GET NEXT ARG IF ITS FIX NXFIX: JUMPGE B,NXFIX1 ; NONE LEFT, USE DEFAULT GETYP 0,(B) ; TYPE CAIE 0,TFIX ; FIXED? JRST NXFIX1 ; NO, USE DEFAULT MOVE A,1(B) ; GET THE NUMBER ADD B,[2,,2] ; BUMP TO NEXT ARG NXFIX1: HRLI C,TFIX TRNE C,-1 ; SKIP IF UV ASH A,1 ; FUDGE FOR VEC/UVEC HRLI A,(A) PUSH TP,C PUSH TP,A POPJ P, GETELM: SKIPN A,UTYP-1(P) ; SKIP IF UVECT MOVE A,-1(C) ; GGET GEN TYPE PUSH TP,A PUSH TP,(C) POPJ P, TYPCH1: GETYP A,-1(D) ; GET TYPE MOVEI 0,(A) ; SAVE IN 0 PUSHJ P,SAT ; AND SAT CAIE A,SCHSTR ; STRING CAIN A,SATOM POPJ P, CAIN A,S1WORD ; 1-WORD GOODIE POPJ P, JRST SLOSE1 ; HERE TO DO EXCHANGE EXCHM: PUSH P,E PUSH P,A ; SAVE VITAL ACS PUSH P,B PUSH P,C SUB B,1(TB) ; COMPUTE RECORD # HLRZS B ; TO RH HRRZ 0,3(TB) ; GET REC LENGTH IDIV B,0 ; DIV BY REC LENGTH MOVE C,(P) SUB C,1(TB) ; SAME FOR C HLRZS C IDIV C,0 ; NOW HAVE OTHER RECORD HRRE D,4(TB) ; - # OF STUCS MOVSI D,(D) ; MAKE AN AOBJN POINTER HRRI D,(TB) ; TO TEMPPS RECLP: HRRZ 0,3(D) ; GET REC LENGTH MOVN E,3(D) ; NOW AOBJN TO REC MOVSI E,(E) HRR E,1(D) MOVEI A,(C) ; COMP START OF REC IMUL A,0 ; TIMES REC LENGTH ADDI E,(A) MOVEI A,(B) IMUL A,0 ADD A,1(D) ; POINT TO OTHER RECORD EXCHLP: EXCH 0,(A) EXCH 0,(E) EXCH 0,(A) ADDI A,1 AOBJN E,EXCHLP ADD D,[1,,6] ; TO NEXT STRUC JUMPL D,RECLP ; IF MORE POP P,C POP P,B POP P,A POP P,E 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]] MEMLST: MOVSI 0,TLIST ;SET B'S TYPE TO LIST 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: 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 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 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 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 MEMCH: GETYP A,-1(TP) ;IS ARG A SINGLE CHAR CAIE A,TCHRS ;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: CAME E,[PUSHJ P,EQLTST] JRST MEMV3 HLRZ A,C CAIE A, TCHSTR ; A SHOULD HAVE TCHSTR IN RIGHT HALF 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 MOVEM A,BSTO+1(PVP) MEMTM1: 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 MOVEM 0,BSTO(PVP) XCT E JRST MEMTM1 HRL B,(P) ; DO APPROPRIATE REST AOS -4(P) MEMTM2: SUB P,[4,,4] MOVSI A,TTMPLT 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: 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 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,COMPERR 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]] 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 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, CHTOP: 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 SUBI A,-1(C) ; START +1 MOVEI B,(A) ; SETUP BYTER HRLI B,440000 SUB A,(TP) ; WORDS DIFFERENT IMUL A,(P) ; CHARS EXTRA SUBM 0,A ; FINAL TOTAL TO A HRLI A,TCHSTR POP P,C DPB E,[300600,,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 COMPERR 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 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) MOVE B,1(AB) ;GET DATUM PUSHJ P,@BCKTBL(E) JRST FINIS PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA] [PTMPLT,BCKTMP]] 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, BACKC: PUSH TP,A PUSH TP,B ADDI A,(C) ; NEW LENGTH HRLI A,TCHSTR 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) 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 COMPERR 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: PUSH TP,$TATOM PUSH TP,EQUOTE OUT-OF-BOUNDS JRST CALER1 WRNGUT: PUSH TP,$TATOM PUSH TP,EQUOTE UNIFORM-VECTORS-TYPE-DIFFERS JRST CALER1 SLOSE0: PUSH TP,$TATOM PUSH TP,EQUOTE VECTOR-LENGTHS-DIFFER JRST CALER1 SLOSE1: PUSH TP,$TATOM PUSH TP,EQUOTE KEYS-WRONG-TYPE JRST CALER1 SLOSE2: PUSH TP,$TATOM PUSH TP,EQUOTE KEY-TYPES-DIFFER JRST CALER1 SLOSE3: PUSH TP,$TATOM PUSH TP,EQUOTE KEY-OFFSET-OUTSIDE-RECORD JRST CALER1 SLOSE4: PUSH TP,$TATOM PUSH TP,EQUOTE NON-INTEGER-NO.-OF-RECORDS JRST CALER1 IIGETP: JRST IGETP ;FUDGE FOR MIDAS/STINK LOSSAGE IIPUTP: JRST IPUTP ;SUPER USEFUL ERROR MESSAGES (USED BY WHOLE WORLD) WNA: PUSH TP,$TATOM PUSH TP,EQUOTE WRONG-NUMBER-OF-ARGUMENTS JRST CALER1 TFA: PUSH TP,$TATOM PUSH TP,EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED JRST CALER1 TMA: PUSH TP,$TATOM PUSH TP,EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED JRST CALER1 WRONGT: WTYP: PUSH TP,$TATOM PUSH TP,EQUOTE ARG-WRONG-TYPE JRST CALER1 IWTYP1: WTYP1: PUSH TP,$TATOM PUSH TP,EQUOTE FIRST-ARG-WRONG-TYPE JRST CALER1 IWTYP2: WTYP2: PUSH TP,$TATOM PUSH TP,EQUOTE SECOND-ARG-WRONG-TYPE JRST CALER1 BADTPL: PUSH TP,$TATOM PUSH TP,EQUOTE BAD-TEMPLATE-DATA JRST CALER1 BADPUT: PUSH TP,$TATOM PUSH TP,EQUOTE TEMPLATE-TYPE-VIOLATION JRST CALER1 WTYP3: PUSH TP,$TATOM PUSH TP,EQUOTE THIRD-ARG-WRONG-TYPE JRST CALER1 CALER1: MOVEI A,1 CALER: HRRZ C,FSAV(TB) PUSH TP,$TATOM CAMGE C,VECTOP CAMGE C,VECBOT 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