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