1 TITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM
7 .GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP,LSTUF,PVSTOR,SPSTOR
8 .GLOBAL NWORDT,CHARGS,CHFRM,CHLOCI,IFALSE,IPUTP,IGETP,BYTDOP
9 .GLOBAL OUTRNG,IGETLO,CHFRAM,ISTRUC,TYPVEC,SAT,CHKAB,VAL,CELL2,MONCH,MONCH0
10 .GLOBAL RMONCH,RMONC0,LOCQ,LOCQQ,SMON,PURERR,APLQ,NAPT,TYPSEG,NXTLM
11 .GLOBAL MAKACT,ILLCHO,COMPER,CEMPTY,CIAT,CIEQUA,CILEGQ,CILNQ,CILNT,CIN,CINTH,CIREST
12 .GLOBAL CISTRU,CSETLO,CIPUT,CIGET,CIGETL,CIMEMQ,CIMEMB,CIMON,CITOP,CIBACK
13 .GLOBAL IGET,IGETL,IPUT,CIGETP,CIGTPR,CINEQU,IEQUAL,TD.LNT,TD.GET,TD.PUT,TD.PTY
14 .GLOBAL TMPLNT,BADTPL,ISTRCM,PTYPE,CIGVAL,MAKTUP,CSBSTR,TMATCH
16 ; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE
21 REPEAT NUMSAT+1,[0] ;INITIALIZE TABLE TO ZEROES
23 IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE]
33 ; FUDGE FOR STRUCTURE LOCATIVES
35 IRP A,,[[LOCL,2WORD],[LOCV,2NWORD],[LOCU,NWORD],[LOCS,CHSTR],[LOCA,ARGS]
36 [LOCT,TMPLT],[LOCB,BYTE]]
45 LOC PRMTYP+SSTORE ;SPECIAL HACK FOR AFREE STORAGE
52 ; MACRO TO BUILD PRIMITIVE DISPATCH TABLES
54 DEFINE PRDISP NAME,DEFAULT,LIST
55 TBLDIS NAME,DEFAULT,[LIST]PNUM,400000
59 ; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL
61 PTYPE: GETYP A,(B) ;CALLE D WITH B POINTING TO PAIR
62 CAIN A,TILLEG ;LOSE IF ILLEGAL
65 PUSHJ P,SAT ;GET STORAGE ALLOC TYPE
67 CAIN A,SARGS ;SPECIAL HAIR FOR ARGS
73 PTYP1: MOVEI 0,(A) ; ALSO RETURN PRIMTYPE
74 CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
76 MOVE A,PRMTYP(A) ;GET PRIM TYPE,
79 ; COMPILERS CALL TO ABOVE (LESS CHECKING)
93 ; HACK TO DYNAMICALLY LOAD SORT
97 PUSH TP,B ; PUSH ON FUNCTION FOR APPLY
98 MOVE A,AB ; PUSH ARGS TO SORT ONTO STACK
102 DONPSH: HLRE A,AB ; GET COUNT
110 MFUNCTION SUBSTRUC,SUBR
113 JUMPGE AB,TFA ;need at least one arg
114 CAMGE AB,[-10,,0] ;NO MORE THEN 4
116 HLRE A,AB ; GET NEGATIVE LENGTH IN A
117 MOVNS A ; SET UP LENGTH ARG TO SUBSTRUC
119 MOVE B,AB ; AOBJN POINTER FOR LOOP
120 PUSH TP,(B) ; PUSH ON ARGS
122 PUSHJ P,CSBSTR ; GO TO INTERNAL ROUTINE
125 ; VARIOUS OFFSETS INTO PSTACK
131 ; VARIOUS OFFSETS INTO TP STACK
138 ; THIS STARTS THE MAIN ROUTINE
140 CSBSTR: SUBM M,(P) ; FOR RSUBRS
144 PUSHJ P,PTYPE ; get primtype in A
163 RESSUB: MOVE D,NOARGS(P) ; GET NUMBER OF ARGS
164 CAIN D,1 ; IF 1 THEN JUST COPY
166 GETYP B,RSTR(TP) ; GET TYPE OF REST ARGUMENT
167 CAIE B,TFIX ;IF FIX OK
171 MOVE B,OBJ+1(TP) ; GET OBJECT
172 SKIPGE C,RSTR+1(TP) ; GET REST ARGUMENT
176 PUSH TP,B ; put rested sturc on stack
179 PRDISP TYTBL,IWTYP1,[[PARGS,RESSUB],[P2WORD,RESSUB],[P2NWORD,RESSUB]
180 [PNWORD,RESSUB],[PCHSTR,RESSUB],[PBYTE,RESSUB]]
182 PRDISP MRSTBL,IWTYP1,[[PARGS,AREST],[P2WORD,LREST],[P2NWORD,VREST]
183 [PNWORD,UREST],[PCHSTR,SREST],[PBYTE,BREST]]
185 PRDISP COPYTB,IWTYP1,[[PARGS,CPYVEC],[P2WORD,CPYLST],[P2NWORD,CPYVEC]
186 [PNWORD,CPYUVC],[PCHSTR,CPYSTR],[PBYTE,CPYBYT]]
188 PRDISP ALOCTB,IWTYP1,[[PARGS,ALVEC],[P2WORD,ALLIST],[P2NWORD,ALVEC]
189 [PNWORD,ALUVEC],[PCHSTR,ALSTR],[PBYTE,ALBYT]]
191 ; HERE WE HAVE RESTED STRUCTURE ON TOP OF STACK
193 ALOCFX: MOVE B,(TP) ; missing 3rd arg aloc for "rest" of struc
197 PUSHJ P,@LENTBL(A) ; get length of rested struc
200 MOVE A,B ; # of elements needed
204 ; HERE WE HAVE RESTED STRUCTURE ON THE TOP OF THE STACK
206 ALOCOK: MOVE D,NOARGS(P) ; GET NUMBER OF ARGS
207 CAIG D,2 ; SKIP IF NOT EXACTLY 3 ARGS
209 GETYP C,LNT-2(TP) ; GET THE LENGTH ARGUMENT
210 CAIE C,TFIX ; OK IF TYPE FIX
213 SKIPL A,LNT-1(TP) ; GET LENGTH
214 JRST @ALOCTB(C) ; DO ALLOCATION
218 CPYVEC: HLRE A,OBJ+1(TP) ; USE WHEN ONLY ONE ARG
219 MOVNS A ; LENGTH ARG IS LENGTH OF STRUCTURE
220 ASH A,-1 ; # OF ELEMENTS FOR ALLOCATION
223 PUSH TP,OBJ(TP) ; REPUSH ARGS
225 ALVEC: PUSH P,A ; SAVE LENGTH
229 CAIL A,-1 ; CHK FOR OUT OF RANGE
232 CAILE D,3 ; SKIP IF WE GET VECTOR
233 JRST ALVEC2 ; USER SUPPLIED VECTOR
236 ALVEC1: MOVE A,(P) ; # OF WORDS TO ALLOCATE
237 MOVE C,B ; SAVE VECTOR POINTER
241 ADD A,B ; PTING TO FIRST DOPE WORD -ALLOCATED
244 SUBI A,1 ; ptr to last element of the block
247 CAMGE B,(TP) ; SKIP IF BACKWARDS BLT IS NEEDED
251 ADD 0,-4(TP) ; FIND END OF DEST
252 CAIGE 0,(B) ; SEE IF BBLT IS NEEDED
254 PUSHJ P,BBLT ; BLT IT
256 ALEVC3: HRL B,(TP) ;bleft-ptr to source , b right -ptr to allocated space
259 ALEVC4: MOVE D,NOARGS(P)
267 ; RESTED OBJECT ON TOP OF STACK
269 ALVEC2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
274 HLRE A,NOBJ-1(TP) ; CHECK SIZE
276 ASH A,-1 ; # OF ELEMENTS
277 CAMGE A,(P) ; SKIP IF BIG ENOUGH
279 MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
282 CPYUVC: HLRE A,OBJ+1(TP) ;# OF ELEMENTS FOR ALLOCATION
291 ADD A,(TP) ; PTING TO DOPE WORD OF ORIG VEC
299 ALUVE1: MOVE A,(P) ; # of owrds to allocate
302 ADD A,B ; LOCATION O FIRST ALLOCATED DOPE WORD
303 HLR E,OBJ-1(TP) ; # OF ELEMENTS IN UVECTOR
305 ADD E,OBJ-1(TP) ; LOCATION OF FIRST DOPE WORD FOR SOURCE
306 GETYP E,(E) ; GET UTYPE
309 PUTYP E,(A) ; DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC
311 CAIN 0,(E) ; 0 HAS USER UVEC UTYPE
318 CAMGE B,(TP) ; SKIP IF NEEDS BACKWARDS BLT
327 ALUEV3: MOVE C,B ; SAVE POINTER TO FINAL GUY
328 HRL C,(TP) ; BUILD BLT POINTER
330 ALUEV4: MOVSI A,TUVEC
334 ; A==LAST WORD DEST (TP)==FIRST WORD DEST B==FIRST WORD SOURCE
337 MOVE E,A ; SAVE ADDITION
338 HRLZS A ; SWAP AND ZERO
341 MOVEI C,(B) ; SET UP DEST WORD
342 SUBI C,(A) ; CALC DIFF
343 ADDI C,-1(E) ; ADD TO GET TO END
344 HRLI C,A ; SET UP INDIRECT
346 TLNE A,-1 ; SKIP IF DONE
350 ALUVE2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
353 HLRE A,NOBJ-1(TP) ; CHECK SIZE
355 CAMGE A,(P) ; SKIP IF BIG ENOUGH
357 MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
360 GETYP 0,(A) ; GET UTYPE OF USER UVECTOR
366 CPYBYT: SKIPA C,$TBYTE
367 CPYSTR: MOVSI C,TCHSTR
369 PUSH TP,(B) ; ALSTR EXPECTS STRING IN TP
374 ALSTR: MOVSI C,TCHSTR
375 ALSTRX: PUSH P,C ; SAVE FINAL TYPE
377 HRRZ 0,-1(TP) ;0 IS LENGTH OFF VECTOR
384 IDIVI B,(C) ; B BYT PER WD, C XTRA BITS
388 PUSHJ P,IBLOCK ;ALLOCATE SPACE
394 MOVE A,(P) ; # OF CHARS TO A
398 ALSTR9: SUB TP,[4,,4]
400 ALSTR1: HLL A,-2(P) ; GET TYPE
401 HRRZ C,B ; SEE IF WE WILL OVERLAP
402 HRRZ D,(TP) ; GET RESTED STRING
403 CAIGE C,(D) ; IF C > B THE A CHANCE
405 MOVEI C,-1(TP) ; GO TO BYTDOP
407 HRRZ B,-2(TP) ; IF B < A THEN OVERLAP
410 HRRZ A,-4(TP) ; GET LENGTH IN A
411 MOVEI B,0 ; START LENGTH COUNT
413 ; ORIGINAL STRING IS ON THE TOP OF THE STACK
416 PUSH P,[0] ; STORE CHARS ON STACK
417 MOVSI E,(<440000,,(P)>) ; SETUP BYTE POINTER
420 CLOOP: IBP E ; BUMP IT
421 TRNE E,-1 ; WORD FULL
422 AOJA B,CLOOP1 ; PUSH NEW ONE
423 ILDB 0,(TP) ; GET A CHARACTER
424 SOS -1(TP) ; DECREMENT CHARACTER COUNT
426 SOJN A,CLOOP ; ANY MORE?
431 MOVE A,-2(TP) ; GET COUNT
433 HRLI C,440000 ; MAKE IT LOOK LIKE A BYTE PTR
436 CLOOP3: ILDB D,C ; GET NEW CHARACTER
437 IDPB D,B ; DEPOSIT CHARACTER
442 SUB P,A ; CLEAN OFF STACK
443 POP TP,B ;BYTE PTR TO COPY
445 ALST10: SUB TP,[1,,1] ; CLEAN OFF STACK
446 ALSTR8: POP P,A ;# FO ELEMENTS
452 ; ROUTINE TO DO FAST TRANSFER FOR NON SHARING STRINGS
454 SSTR: MOVE A,-4(TP) ; GET # OF ELEMENTS INTO A
465 ALSTR2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
470 CAMGE A,(P) ; SKIP IF BIG ENOUGH
473 MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
477 ; HERE TO COPY A LIST
479 CPYLST: SKIPN OBJ+1(TP)
483 HRLI C,TLIST ; TP JUNK FOR GAR. COLLECTOR
485 PUSH TP,B ; VALUE -PTR TO NEW LIST
487 MOVE C,OBJ-2(TP) ; PTR TO FIRST ELEMENT OF ORIG. LIST
489 MOVE E,1(C) ; GET LIST ELEMENT INTO ALOC SPACE
491 MOVEM E,1(B) ; PUT INTO ALLOCATED SPACE
492 HRRZ C,(C) ; UPDATE PTR
493 JUMPE C,CLOSWL ; END OF LIST?
497 HRRM B,(D) ; LINK ALLOCATED LIST CELLS
500 CLOSWL: MOVE A,-2(TP) ; GET LIST
510 CAILE D,3 ; SKIP IF WE BUILD LIST
515 POP P,A ; # OF ELEMENTS
516 PUSH P,B ; ptr to allocated list
517 POP TP,C ; ptr to orig list
521 HRRM B,-2(B) ; LINK ALOCATED LIST CELLS
522 ENTCOP: JUMPE C,OUTRNG
524 MOVE E,1(C) ; get list element into D+E
526 MOVEM E,1(B) ; put into allocated space
527 HRRZ C,(C) ; update ptrs
528 SOJG A,COPYL ; finish transfer?
536 ZEROL1: SUB TP,[2,,2]
537 ZEROLT: MOVSI A,TLIST
542 CPYLS2: GETYP 0,NOBJ-2(TP)
545 MOVE B,NOBJ-1(TP) ; GET DEST LIST
549 CPYLS4: JUMPE B,OUTRNG
559 CPYLS3: MOVE D,-2(TP)
565 EXSUB: SUB TP,[10.,,10.]
571 ; PROCESS TYPE ILLEGAL
573 ILLCHO: HRRZ B,1(B) ;GET CLOBBERED TYPE
574 CAIN B,TARGS ;WAS IT ARGS?
576 CAIN B,TFRAME ;A FRAME?
578 CAIN B,TLOCD ;A LOCATIVE TO AN ID
581 LSH B,1 ;NONE OF ABOVE LOOK IN TABLE
584 PUSH TP,EQUOTE ILLEGAL
586 PUSH TP,(B) ;PUSH ATOMIC NAME
588 JRST CALER ;GO TO ERROR REPORTER
590 ; CHECK AN ARGS POINTER
592 CHARGS: PUSHJ P,ICHARG ; INTERNAL CHECK
595 ILLAR1: ERRUUO EQUOTE ILLEGAL-ARGUMENT-BLOCK
597 ICHARG: PUSH P,A ;SAVE SOME ACS
600 SKIPN C,1(B) ;GET POINTER
601 JRST ILLARG ; ZERO POINTER IS ILLEGAL
602 HLRE A,C ;FIND ASSOCIATED FRAME
603 SUBI C,(A) ;C POINTS TO FRAME OR FRAME POINTER
604 GETYP A,(C) ;GET TYPE OF NEXT GOODIE
607 CAIE A,TENTRY ;MUST BE EITHER ENTRY OR TINFO
612 CHARG1: CAIN A,TINFO ;POINTER TO FRAME?
613 ADD C,1(C) ;YES, GET IT
614 CAIE A,TINFO ;POINTS TO ENTRT?
615 MOVEI C,FRAMLN(C) ;YES POINT TO END OF FRAME
616 HLRZ C,OTBSAV(C) ;GET TIME FROM FRAME
617 HRRZ B,(B) ;AND ARGS TIME
619 ILLARG: SETZM -1(P) ; RETURN ZEROED B
623 POPJ P, ;GO GET PRIM TYPE
627 ; CHECK A FRAME POINTER
629 CHFRM: PUSHJ P,CHFRAM
632 ILFRAM: ERRUUO EQUOTE ILLEGAL-FRAME
634 CHFRAM: PUSH P,A ;SAVE SOME REGISTERS
637 HRRZ A,(B) ; GE PVP POINTER
638 HLRZ C,(A) ; GET LNTH
639 SUBI A,-1(C) ; POINT TO TOP
641 CAIN A,(PVP) ; SKIP IF NOT THIS PROCESS
642 MOVEM TP,TPSTO+1(A) ; MAKE CURRENT BE STORED
643 HRRZ A,TPSTO+1(A) ; GET TP FOR THIS PROC
644 HRRZ C,1(B) ;GET POINTER PART
645 CAILE C,1(A) ;STILL WITHIN STACK
647 HLRZ A,FSAV(C) ;CHECK STILL AN ENTRY BLOCK
652 HLRZ A,1(B) ;GET TIME FROM POINTER
653 HLRZ C,OTBSAV(C) ;AND FROM FRAME
655 BDFR: SETZM -1(P) ; RETURN 0 IN B
656 JRST POPBCJ ;YES, WIN
658 ; CHECK A LOCATIVE TO AN IDENTIFIER
660 CHLOCI: PUSHJ P,ICHLOC
663 ILLOC1: ERRUUO EQUOTE ILLEGAL-LOCATIVE
669 HRRZ A,(B) ;GET TIME FROM POINTER
670 JUMPE A,POPBCJ ;ZERO, GLOBAL VARIABLE NO TIME
671 HRRZ C,1(B) ;POINT TO STACK
674 HRRZ C,2(C) ; SHOULD BE DECL,,TIME
676 ILLOC: SETZM -1(P) ; RET 0 IN B
682 ; PREDICATE TO SEE IF AN OBJECT IS STRUCTURED
684 MFUNCTION %STRUC,SUBR,[STRUCTURED?]
688 GETYP A,(AB) ; GET TYPE
689 PUSHJ P,ISTRUC ; INTERNAL
694 ; PREDICATE TO CHECK THE LEGALITY OF A FRAME/ARGS TUPLE/IDENTIFIER LOCATIVE
696 MFUNCTION %LEGAL,SUBR,[LEGAL?]
700 MOVEI B,(AB) ; POINT TO ARG
708 PUSHJ P,SAT ; GET STORG TYPE
709 CAIN A,SFRAME ; FRAME?
712 CAIN A,SARGS ; ARG TUPLE
714 CAIN A,SLOCID ; ID LOCATIVE
742 \f;SUBRS TO DEFINE, GET, AND PUT BIT FIELDS
746 JUMPGE AB,TFA ;AT LEAST ONE ARG ?
750 SKIPLE C,(AB)+1 ;GET FIRST AND CHECK TO SEE IF POSITIVE
751 CAILE C,44 ;CHECK IF FIELD NOT GREATER THAN WORD SIZE
754 CAML AB,[-2,,0] ;ONLY ONE ARG ?
756 CAMGE AB,[-4,,0] ;MORE THAN TWO ARGS ?
761 SKIPGE B,(AB)+3 ;GET SECOND ARG AND CHECK TO SEE IF NON-NEGATIVE
763 ADD C,(AB)+3 ;CALCULATE LEFTMOST EXTENT OF THE FIELD
764 CAILE C,44 ;SHOULD BE LESS THAN WORD SIZE
768 LSH B,30 ;FORM BYTE POINTER'S LEFT HALF
774 MFUNCTION GETBITS,SUBR
785 MOVEI A,(AB)+1 ;GET ADDRESS OF THE WORD
786 HLL A,(AB)+3 ;GET LEFT HALF OF BYTE POINTER
788 MOVSI A,TWORD ; ALWAYS RETURN WORD
\b\b\b\b____
792 MFUNCTION PUTBITS,SUBR
794 CAML AB,[-2,,0] ;AT LEAST TWO ARGS ?
803 MOVEI B,0 ;EMPTY THIRD ARG DEFAULT
804 CAML AB,[-4,,0] ;ONLY TWO ARGS ?
806 CAMGE AB,[-6,,0] ;MORE THAN THREE ARGS ?
813 TWOF: MOVEI A,(AB)+1 ;ADDRESS OF THE TARGET WORD
814 HLL A,(AB)+3 ;GET THE LEFT HALF OF THE BYTE POINTER
817 MOVE A,(AB) ;SAME TYPE AS FIRST ARG'S
821 ; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS
823 MFUNCTION LNTHQ,SUBR,[LENGTH?]
833 MFUNCTION LENGTH,SUBR
836 PUSH P,[377777777777]
837 LNTHER: MOVE B,AB ;POINT TO ARGS
838 PUSHJ P,PTYPE ;GET ITS PRIM TYPE
841 PUSHJ P,@LENTBL(A) ; CALL RIGTH ONE
842 JRST LFINIS ;OTHERWISE USE 0
844 PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC]
845 [PARGS,LNVEC],[PCHSTR,LNCHAR],[PTMPLT,LNTMPL],[PBYTE,LNCHAR]]
847 LNLST: SKIPN C,B ; EMPTY?
848 JRST LNLST2 ; YUP, LEAVE
849 MOVEI B,1 ; INIT COUNTER
850 MOVSI A,TLIST ;WILL BECOME INTERRUPTABLE
852 HLLM A,CSTO(PVP) ;AND C WILL BE A LIST POINTER
853 LNLST1: INTGO ;IN CASE CIRCULAR LIST
857 JUMPE C,.+2 ;DONE, RETRUN LENGTH
858 AOJA B,LNLST1 ;COUNT AND GO
859 LNLST2: MOVE PVP,PVSTOR+1
866 MOVSI A,TFIX ;LENGTH IS AN INTEGER
869 LNVEC: ASH B,-1 ;GENERAL VECTOR DIVIDE BY 2
870 LNUVEC: HLRES B ;GET LENGTH
874 LNCHAR: HRRZ B,C ; GET COUNT
877 LNTMPL: GETYP A,(B) ; GET REAL SAT
879 HRLS A ; READY TO HIT TABLE
882 MOVE C,B ; DATUM TO C
884 HLRZS C ; REST COUNTER
885 SUBI B,(C) ; FLUSH IT OFF
886 MOVEI B,(B) ; IN CASE FUNNY STUFF
896 PUSHJ P,CPTYPE ; GET PRIMTYPE
898 PUSHJ P,@LENTBL(A) ; DISPATCH
937 MFUNCTION BYTSIZ,SUBR,[BYTE-SIZE]
945 LDB B,[300600,,1(AB)]
951 IDNT1: MOVE A,(AB) ;RETURN THE FIRST ARG
955 IMFUNCTION QUOTE,FSUBR
960 CAIE A,TLIST ;ARG MUST BE A LIST
962 SKIPN B,1(AB) ;SHOULD HAVE A BODY
970 MFUNCTION NEQ,SUBR,[N==?]
975 MFUNCTION EQ,SUBR,[==?]
980 GETYP A,(AB) ;GET 1ST TYPE
981 GETYP C,2(AB) ;AND 2D TYPE
988 ITRUTH: MOVSI A,TATOM ;RETURN TRUTH
992 IFALSE: MOVSI A,TFALSE ;RETURN FALSE
1003 MFUNCTION EMPTY,SUBR,EMPTY?
1008 PUSHJ P,PTYPE ;GET PRIMITIVE TYPE
1012 SKIPN B,1(AB) ;GET THE ARG
1015 CAIN A,PTMPLT ; TEMPLATE?
1017 CAIE A,P2WORD ;A LIST?
1018 JRST EMPT1 ;NO VECTOR OR CHSTR
1019 JUMPE B,ITRUTH ;0 POINTER MEANS EMPTY LIST
1025 CAIE A,PCHSTR ;CHAR STRING?
1026 JRST EMPT2 ;NO, VECTOR
1027 HRRZ B,(AB) ; GET COUNT
1028 JUMPE B,ITRUTH ;0 STRING WINS
1031 EMPT2: JUMPGE B,ITRUTH
1034 EMPTPL: PUSHJ P,LNTMPL ; GET LENGTH
1038 ; COMPILER'S ENTRY TO EMPTY
1045 JUMPE B,YES ; ALWAYS EMPTY
1054 TRNE 0,-1 ; STRING, SKIP ON ZERO LENGTH FIELD
1058 CEMPTP: PUSHJ P,LNTMPL
1068 MFUNCTION NEQUAL,SUBR,[N=?]
1072 MFUNCTION EQUAL,SUBR,[=?]
1076 MOVE C,AB ;SET UP TO CALL INTERNAL
1078 ADD D,[2,,2] ;C POINTS TO FIRS, D TO SECOND
1079 PUSHJ P,IEQUAL ;CALL INTERNAL
1080 JRST EQFALS ;NO SKIP MEANS LOSE
1088 ; COMPILER'S ENTRY TO =? AND N=?
1100 SUBM M,-1(P) ; MAY BECOME INTERRUPTABLE
1104 SUB TP,[4,,4] ; FLUSH TEMPS
1115 ; INTERNAL EQUAL SUBROUTINE
1117 IEQUAL: MOVE B,C ;NOW CHECK THE ARGS
1121 MOVE F,0 ; SAVE SAT FOR OFFSET HACK
1122 GETYP 0,(C) ;NOW CHECK FOR EQ
1125 CAIN 0,(B) ;DONT SKIP IF POSSIBLE WINNER
1126 CAME E,1(D) ;DEFINITE WINNER, SKIP
1128 CPOPJ1: AOS (P) ;EQ, SKIP RETURN
1132 IEQ1: CAIE 0,(B) ;SKIP IF POSSIBLE MATCH
1133 CPOPJ: POPJ P, ;NOT POSSIBLE WINNERS
1136 JRST @EQTBL(A) ;DISPATCH
1138 PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC]
1139 [PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL],[PBYTE,EQCHST]]
1141 EQLIST: PUSHJ P,PUSHCD ;PUT ARGS ON STACK
1143 EQLST1: INTGO ;IN CASE OF CIRCULAR
1144 HRRZ C,-2(TP) ;GET FIRST
1147 JRST EQLST2 ;YES, LEAVE
1148 JUMPE C,EQLST3 ;NIL LOSES
1150 GETYP 0,(C) ;CHECK DEFERMENT
1152 HRRZ C,1(C) ;PICK UP POINTED TO CROCK
1155 HRRZ D,1(D) ;POINT TO REAL GOODIE
1156 PUSHJ P,IEQUAL ;CHECK THE CARS
1158 HRRZ C,@-2(TP) ;CDR THE LISTS
1160 HRRZM C,-2(TP) ;AND STORE
1164 EQLST2: AOS (P) ;SKIP RETRUN
1165 EQLST3: SUB TP,[4,,4] ;REMOVE CRUFT
1168 ; HERE FOR HACKING OFFSETS
1170 HRRZ B,1(D) ; GET NUMBERS
1171 CAIE A,(B) ; POSSIBLE WINNER IF SKIP
1179 JRST EQLST1 ; SEE IF THE TWO LISTS ARE EQUAL
1181 ; HERE FOR HACKING TEMPLATE STRUCTURES
1183 EQTMPL: PUSHJ P,PUSHCD ; SAVE GOODIES
1185 MOVE C,1(C) ; CHECK REAL SATS
1189 CAIE 0,(C) ; SKIP IF WINNERS
1191 PUSH P,0 ; SAVE MAGIC OFFSET
1193 PUSHJ P,TM.LN1 ; RET LENGTH IN B
1194 MOVEI B,(B) ; FLUSH FUNNY
1198 MOVE C,(TP) ; POINTER TO OTHER GUY
1200 XCT (A) ; OTHER LENGTH TO B
1201 HLRZ 0,-2(TP) ; REST OFFSETTER
1207 HRRZS -4(TP) ; UNDO RESTING (ACCOUNTED FOR BY STARTING
1217 MOVE B,-6(TP) ; POINTER
1218 MOVE 0,-2(P) ; GET MAGIC OFFSET
1219 PUSHJ P,TMPLNT ; GET AN ELEMENT
1223 MOVE B,-4(TP) ; OTHER GUY
1230 PUSHJ P,IEQUAL ; RECURSE
1232 JRST EQTMP2 ; WINNER
1234 EQTMP3: AOS -3(P) ; WIN RETURN
1235 EQTMP1: SUB P,[3,,3] ; FLUSH JUNK
1236 EQTMP4: SUB TP,[10,,10]
1241 EQVEC: HLRE A,1(C) ;GET LENGTHS
1243 CAIE B,(A) ;SKIP IF EQUAL LENGTHS
1245 JUMPGE A,CPOPJ1 ;SKIP RETRUN WIN
1246 PUSHJ P,PUSHCD ;SAVE ARGS
1248 EQVEC1: INTGO ;IN CASE LONG VECTOR
1250 MOVE D,-2(TP) ;ARGS TO C AND D
1253 MOVE C,[2,,2] ;GET BUMPER
1255 ADDB C,-2(TP) ;BUMP BOTH POINTERS
1259 EQUVEC: HLRE A,1(C) ;GET LENGTHS
1261 CAIE B,(A) ;SKIP IF EQUAL
1264 HRRZ B,1(C) ;START COMPUTING DOPE WORD LOCN
1265 SUB B,A ;B POINTS TO DOPE WORD
1266 GETYP 0,(B) ;GET UNIFORM TYPE
1267 HRRZ B,1(D) ;NOW FIND OTHER DOPE WORD
1269 GETYP B,(B) ;OTHER UNIFORM TYPE
1270 CAIE 0,(B) ;TYPES THE SAME?
1273 JUMPGE A,CPOPJ1 ;IF ZERO LENGTH ALREADY WON
1275 HRLZI B,(B) ;TYPE TO LH
1277 PUSHJ P,PUSHCD ;SAVE ARGS
1279 EQUV1: MOVEI C,1(TP) ;POINT TO WHERE WILL GO
1281 MOVE A,-3(TP) ;PUSH ONE OF THE VECTORS
1282 PUSH TP,(A) ; PUSH ELEMENT
1283 MOVEI D,1(TP) ;POINT TO 2D ARG
1285 MOVE A,-3(TP) ;AND PUSH ITS POINTER
1290 SUB TP,[4,,4] ;POP TP
1292 ADDM A,(TP) ;BUMP POINTERS
1294 JUMPL A,EQUV1 ;JUMP IF STILL MORE STUFF
1295 SUB P,[1,,1] ;POP OFF TYPE
1298 UNEQUV: SUB P,[1,,1]
1304 EQCHST: HRRZ B,(C) ; GET LENGTHS
1307 JRST EQCHS3 ;NO, LOSE
1308 LDB 0,[300600,,1(C)]
1309 LDB E,[300600,,1(D)]
1314 JUMPE A,EQCHS4 ;BOTH 0 LENGTH, WINS
1317 ILDB 0,C ;GET NEXT CHARS
1319 CAME 0,E ; SKIP IF STILL WINNING
1333 ; REST/NTH/AT/PUT/GET
1337 ARGS1: MOVE E,[JRST WTYP2] ; ERROR CONDITION FOR 2D ARG NOT FIXED
1338 ARGS2: HLRE 0,AB ; CHECK NO. OF ARGS
1339 ASH 0,-1 ; TO - NO. OF ARGS
1340 AOJG 0,TFA ; 0--TOO FEW
1341 AOJL 0,TMA ; MORE THAT 2-- TOO MANY
1342 MOVEI C,1 ; DEFAULT ARG2
1343 JUMPN 0,ARGS4 ; GET STRUCTURED ARG
1344 ARGS3: GETYP A,2(AB)
1345 CAIN A,TOFFS ; OFFSET?
1346 JRST ARGOFF ; GO DO DECL-CHECK AND SUCH
1347 CAIE A,TFIX ; SHOULD BE FIXED NUMBER
1348 XCT E ; DO ERROR THING
1349 SKIPGE C,3(AB) ; BETTER BE NON-NEGATIVE
1351 ARGS4: MOVEI B,(AB) ; POINT TO STRUCTURED POINTER
1352 PUSHJ P,PTYPE ; GET PRIM TYPE
1353 MOVEI E,(A) ; DISPATCH CODE TO E
1354 MOVE A,(AB) ; GET ARG 1
1357 ARGOFF: HLRZ B,3(AB) ; PICK UP DECL POINTER FOR OFFSET
1359 MOVE A,(B) ; TYPE WORD
1363 PUSHJ P,TMATCH ; CHECK THE DECL
1364 JRST WTYP1 ; FIRST ARG WRONG TYPE
1365 ARGOF1: HRRE C,3(AB) ; GET THE FIX
1371 IMFUNCTION REST,SUBR
1374 PUSHJ P,ARGS1 ; GET AND CHECK ARGS
1375 PUSHJ P,@RESTBL(E) ; DO IT BASED ON TYPE
1376 MOVE C,A ; THE FOLLOWING IS TO MAKE STORAGE WORK
1379 CAIN A,SSTORE ; SKIP IF NOT STORAGE
1380 MOVSI C,TSTORA ; USE ITS PRIMTYPE
1384 PRDISP RESTBL,IWTYP1,[[P2WORD,LREST],[PNWORD,UREST],[P2NWOR,VREST],[PARGS,AREST]
1385 [PCHSTR,SREST],[PTMPLT,TMPRST],[PBYTE,BREST]]
1397 PRDISP ATTBL,IWTYP1,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
1398 [PCHSTR,STAT],[PTMPLT,TAT],[PBYTE,BTAT]]
1412 PRDISP NTHTBL,IWTYP1,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWOR,VNTH],[PARGS,ANTH]
1413 [PCHSTR,SNTH],[PTMPLT,TMPLNT],[PBYTE,BNTH]]
1420 MOVE E,IIGETP ; MAKE ARG CHECKER FAIL INTO GETPROP
1421 PUSHJ P,ARGS5 ; CHECK ARGS
1423 SKIPN E,IGETBL(E) ; GET DISPATCH ADR
1424 JRST IGETP ; REALLY PUTPROP
1426 PUSHJ P,(E) ; DISPATCH
1429 PRDISP IGETBL,0,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWORD,VNTH],[PARGS,ANTH]
1430 [PCHSTR,SNTH],[PTMPLT,TMPLNT],[PBYTE,BNTH]]
1437 MOVE E,IIGETL ; ERROR HACK
1439 SOJL C,OUTRNG ; LOSER
1441 JRST IGETLO ; REALLY GETPL
1443 PUSHJ P,(E) ; DISPATCH
1448 PRDISP IGTLTB,0,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
1449 [PCHSTR,STAT],[PBYTE,BTAT]]
1452 ; ARG CHECKER FOR PUT/GET/GETL
1454 ARGS5: HLRE 0,AB ; -# OF ARGS
1456 ADDI 0,2 ; 0 OR -1 WIN
1458 AOJL 0,TMA ; MORE THAN 3
1459 JRST ARGS3 ; GET ARGS
1467 PUSHJ P,ARGS5 ; GET ARGS
1470 CAML AB,[-5,,] ; SKIP IF GOOD ARRGS
1476 MOVE A,(AB) ; RET STRUCTURE
1480 PRDISP IPUTBL,0,[[P2WORD,LPUT],[PNWORD,UPUT],[P2NWORD,VPUT],[PARGS,APUT]
1481 [PCHSTR,SPUT],[PTMPLT,TMPPUT],[PBYTE,BPUT]]
1489 MOVEI B,(AB) ; POINT TO ARG
1491 MOVS E,A ; REAL DISPATCH TO E
1494 GETYP C,A ; IN CASE NEEDED
1498 PRDISP INTBL,OTHIN,[[P2WORD,LNTH1],[PNWORD,UIN],[P2NWORD,VIN],[PARGS,AIN]
1499 [PCHSTR,SIN],[PTMPLT,TIN],[PBYTE,BINN]]
1501 OTHIN: CAIE C,TLOCN ; ASSOCIATION LOCATIVE
1502 JRST OTHIN1 ; MAYBE LOCD
1509 OTHIN1: CAIN C,TLOCD
1516 MFUNCTION SETLOC,SUBR
1520 MOVEI B,(AB) ; POINT TO ARG
1521 PUSHJ P,PTYPE ; DO TYPE
1522 MOVS E,A ; REAL TYPE
1524 MOVE C,2(AB) ; PASS ARG
1526 MOVE A,(AB) ; IN CASE
1533 PRDISP SETTBL,OTHSET,[[P2WORD,LSTUF],[PNWORD,USTUF],[P2NWORD,VSTUF],[PARGS,ASTUF]
1534 [PCHSTR,SSTUF],[PTMPLT,TSTUF],[PBYTE,BSTUF]]
1536 OTHSET: CAIE 0,TLOCN ; ASSOC?
1538 HLLZ 0,VAL(B) ; GET MONITORS
1544 OTHSE1: CAIE 0,TLOCD
1548 ; LREST -- REST A LIST IN B BY AMOUNT IN C
1550 LREST: MOVSI A,TLIST
1555 LREST2: INTGO ;CHECK INTERRUPTS
1556 JUMPE B,OUTRNG ; CANT CDR NIL
1557 HRRZ B,(B) ;CDR THE LIST
1558 SOJG C,LREST2 ;COUNT DOWN
1560 SETZM BSTO(PVP) ;RESET BSTO
1564 ; VREST -- REST A VECTOR, AREST -- REST AN ARG BLOCK
1566 VREST: SKIPA A,$TVEC ; FINAL TYPE
1571 ; UREST -- REST A UVECTOR
1573 STORST: SKIPA A,$TSTORA
1574 UREST: MOVSI A,TUVEC
1575 UREST1: JUMPE C,CPOPJ
1579 CAILE B,-1 ; OUT OF RANGE ?
1584 ; SREST -- REST A STRING
1586 BREST: SKIPA D,[TBYTE]
1588 SREST: MOVEI D,TCHSTR
1591 PUSH P,A ; SAVE TYPE WORD
1592 PUSH P,C ; SAVE AMOUNT
1593 MOVEI D,(A) ; GET LENGTH
1594 CAILE C,(D) ; SKIP IF OK
1596 LDB D,[366000,,B] ;POSITION FIELD OF BYTE POINTER
1597 LDB A,[300600,,B] ;SIZE FIELD
1599 IDIVI D,(A) ;COMPUT BYTES IN 1ST WORD
1600 MOVEI 0,36. ;NOW COMPUTE BYTES PER WORD
1601 IDIVI 0,(A) ;BYTES PER WORD IN 0
1602 MOVE E,0 ;COPY OF BYTES PER WORD TO E
1603 SUBI 0,(D) ;0 # OF UNSUED BYTES IN 1ST WORD
1604 ADDB C,0 ;C AND 0 NO.OF CHARS FROM WORD BOUNDARY
1605 IDIVI C,(E) ;C/ REL WORD D/ CHAR IN LAST
1606 ADDI C,(B) ;POINTO WORD WITH C
1607 POP P,A ;RESTORE BITS PER BYTE
1608 JUMPN D,.+3 ; JUMP IF NOT WD BOUNDARY
1609 MOVEI D,(E) ; USE FULL AMOUNT
1610 SUBI C,1 ; POINT TO PREV WORD
1611 IMULI A,(D) ;A/ BITS USED IN LAST WORD
1613 SUBI 0,(A) ;0 HAS NEW POSITION FIELD
1614 DPB 0,[360600,,B] ;INTO BYTE POINTER
1615 HRRI B,(C) ;POINT TO RIGHT WORD
1616 POP P,C ; RESTORE AMOUNT
1618 SUBI A,(C) ; NEW LENGTH
1623 ; TMPRST -- REST A TEMPLATE DATA STRUCTURE
1625 TMPRST: PUSHJ P,TM.TOE ; CHECK ALL BOUNDS ETC.
1632 ; LAT -- GET A LOCATIVE TO A LIST
1634 LAT: PUSHJ P,LREST ; GET POINTER
1635 JUMPE B,OUTRNG ; YOU LOSE!
1636 MOVSI A,TLOCL ; NEW TYPE
1640 ; UAT -- GET A LOCATIVE TO A UVECTOR
1646 ; VAT -- GET A LOCATIVE TO A VECTOR
1648 VAT: PUSHJ P,VREST ; REST IT AND TYPE IT
1652 ; AAT -- GET A LOCATIVE TO AN ARGS BLOCK
1656 POPJL: JUMPGE B,OUTRNG ; LOST
1659 ; STAT -- LOCATIVE TO A STRING
1662 TRNN A,-1 ; SKIP IF ANY LEFT
1664 HRLI A,TLOCS ; LOCATIVE
1667 ; BTAT -- LOCATIVE TO A BYTE-STRING
1670 TRNN A,-1 ; SKIP IF ANY LEFT
1672 HRLI A,TLOCB ; LOCATIVE
1675 ; TAT -- LOCATIVE TO A TEMPLATE
1680 GETYP A,(B) ; GET REAL SAT
1682 HRLS A ; READY TO HIT TABLE
1685 MOVE C,B ; DATUM TO C
1686 XCT (A) ; GET LENGTH
1687 HLRZS C ; REST COUNTER
1688 SUBI B,(C) ; FLUSH IT OFF
1696 ; LNTH -- NTH OF LIST
1699 LNTH1: PUSHJ P,RMONC0 ; CHECK READ MONITORS
1700 HLLZ A,(B) ; GET GOODIE
1702 JSP E,CHKAB ; HACK DEFER
1705 ; VNTH -- NTH A VECTOR, ANTH -- NTH AN ARGS BLOCK
1717 ; UNTH -- NTH OF UVECTOR
1720 UIN: HLRE C,B ; FIND DW
1722 HLLZ 0,(C) ; GET MONITORS
1726 PUSHJ P,RMONCH ; CHECK EM
1728 MOVE B,(B) ; AND VALUE
1732 ; BNTH -- NTH A BYTE STRING
1738 ; SNTH -- NTH A STRING
1743 PUSH TP,B ; SAVE POINT BYTER
1744 MOVEI C,-1(TP) ; FIND DOPE WORD
1754 ; TIN -- IN OF A TEMPLATE
1758 ; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE
1761 PUSHJ P,TM.TOE ; GET POINTER TO INS IN E
1762 ADD A,TD.GET+1 ; POINT TO GETTER
1763 MOVE A,(A) ; GET VECTOR OF INS
1764 ADDI E,-1(A) ; POINT TO INS
1767 JFCL ; SKIP IF AN ANY CASE
1770 ; LPUT -- PUT ON A LIST
1772 LPUT: PUSHJ P,LAT ; POSITION
1776 ; LSTUF -- HERE TO STUFF A LIST ELEMENT
1778 LSTUF: PUSHJ P,MONCH0 ; CHECK OUT MONITOR BITS
1779 GETYP A,C ; ISOLATE TYPE
1780 PUSHJ P,NWORDT ; NEED TO DEFER?
1783 MOVEM D,1(B) ; AND VAL
1786 DEFRCY: MOVE E,1(B) ; RECYCLE THIS HANDY DEFER
1798 PUSHJ P,CELL2 ; GET WORDS
1804 HLLZ 0,(E) ; GET OLD MONITORS
1805 TLZ 0,TYPMSK ; KILL TYPES
1806 TLO 0,TDEFER ; MAKE DEFERRED
1810 ; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK
1815 VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR
1816 POP TP,D ; GET GOODIE BACK
1819 ; AVSTUF -- CLOBBER ARGS AND VECTORS
1822 VSTUF: PUSHJ P,MONCH0
1830 ; UPUT -- CLOBBER A UVECTOR
1832 UPUT: PUSHJ P,UAT ; GET IT RESTED
1836 ; USTUF -- HERE TO CLOBBER A UVECTOR
1839 SUBM B,E ; C POINTS TO DOPE
1840 GETYP A,(E) ; GET UTYPE
1842 CAIE 0,(A) ; CHECK SAMENESS
1844 HLLZ 0,(E) ; MONITOR BITS IN DOPE WORD
1845 MOVSI A,TLOCU ; CHOMP, CHOMP (WAS TUVEC) -- MARC 5/2/78
1850 ; BPUT -- HERE TO PUT A BYTE-STRING
1858 ; SPUT -- HERE TO PUT A STRING
1860 SPUT: PUSHJ P,STAT ; REST IT
1864 ; SSTUF -- STUFF A STRING
1866 SSTUF: MOVEI E,TCHRS
1867 SSTUF1: GETYP 0,C ; BETTER BE CHAR
1873 MOVEI C,-1(TP) ; FIND D.W.
1875 SKIPGE (A)-1 ; SKIP IF NOT REALLY ATOM
1877 HLLZ 0,(A)-1 ; GET MONITORS
1888 PUSH TP,EQUOTE ATTEMPT-TO-MUNG-ATOMS-PNAME
1895 ; TSTUF -- SETLOC A TEMPLATE
1901 ; PUTTMP -- TEMPLATE PUTTER
1904 PUSHJ P,TM.TOE ; GET E POINTING TO SLOT #
1905 ADD A,TD.PUT+1 ; POINT TO INS
1906 MOVE A,(A) ; GET VECTOR OF INS
1908 POP TP,B ; NEW VAL TO A AND B
1915 TM.LN1: SUBI 0,NUMSAT+1
1916 HRRZ A,0 ; RET FIXED OFFSET
1918 ADD 0,TD.LNT+1 ; USE LENGTHERS FOR TEST
1922 HRRZS 0 ; POINT TO TABLE ENTRY
1929 TM.TBL: MOVEI E,(D) ; TENTATIVE WINNER IN E
1930 TLNN B,-1 ; SKIP IF REST HAIR EXISTS
1933 PUSH P,A ; SAVE OFFSET
1934 HRLS A ; A IS REL OFFSET TO INS TABLE
1935 ADD A,TD.GET+1 ; GET ONEOF THE TABLES
1936 MOVE A,(A) ; TABLE POINTER TO A
1937 MOVSI 0,-1(D) ; START SEEING IF PAST TEMP SPEC
1939 JUMPL 0,CPOPJA ; JUMP IF E STILL VALID
1940 HLRZ E,B ; BASIC LENGTH TO E
1941 HLRE 0,A ; LENGTH OF TEMPLATE TO 0
1942 ADDI 0,(E) ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE
1944 SUBM D,E ; E ==> # PAST BASIC WANTED
1946 IDIVI 0,(E) ; A ==> REL REST GUY WANTED
1952 ; TM.TOE -- GET RIGHT TEMPLATE # IN E
1953 ; C/ OBJECT #, B/ OBJECT POINTER
1955 TM.TOE: GETYP 0,(B) ; GET REAL SAT
1956 MOVEI D,(C) ; OBJ # TO D
1957 HLRZ C,B ; REST COUNT
1958 ADDI D,(C) ; FUDGE FOR REST COUNTER
1959 MOVE C,B ; POINTER TO C
1960 PUSHJ P,TM.LN1 ; GET LENGTH IN B (WATCH LH!)
1961 CAILE D,(B) ; CHECK RANGE
1962 JRST OUTRNG ; LOSER, QUIT
1963 JRST TM.TBL ; GO COMPUTE TABLE OFFSET
1965 \f; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B
1976 ; COMPILER CALLS TO MANY OF THESE GUYS
1978 CIREST: PUSHJ P,CPTYEE ; TYPE OF DISP TO E
1979 HRRES C ; CLEAR LH, IN CASE IT'S AN OFFSET
1986 CIRST1: PUSHJ P,STORST
1989 CINTH: PUSHJ P,CPTYEE
1991 SOJL C,OUTRNG ; CHECK BOUNDS
1995 CIAT: PUSHJ P,CPTYEE
2000 CSETLO: PUSHJ P,CTYLOC
2001 MOVSS E ; REAL DISPATCH
2002 GETYP 0,A ; INCASE LOCAS OR LOCD
2011 MOVSS E ; REAL DISPATCH
2023 ; COMPILER'S PUT,GET AND GETL
2033 JUMPE E,CIGET1 ; REAL GET, NOT NTH
2034 GETYP 0,C ; INDIC FIX?
2040 AOS (P) ; ALWAYS SKIP
2041 MOVE C,D ; # TO AN AC
2046 CIGET1: POP P,E ; GET FLAG
2047 JRST @GETTR(E) ; DO A REAL GET
2057 PUSH TP,-1(TP) ; PAIN AND SUFFERING
2063 CAIE 0,TFIX ; YES DO STRUCT
2069 SOJL C,OUTRNG ; CHECK BOUNDS
2075 CIPUT1: PUSHJ P,IPUT
2078 ; SMON -- SET MONITOR BITS
2079 ; B/ <POINTER TO LOCATIVE>
2080 ; D/ <IORM> OR <ANDCAM>
2084 PUSHJ P,PTYPE ; TO PRIM TYPE
2086 SKIPE A,SMONTB(A) ; DISPATCH?
2089 ; COULD STILL BE LOCN OR LOCD
2091 GETYP A,(B) ; TYPE BACK
2093 JRST SMON2 ; COULD BE LOCD
2095 HRRI D,VAL(C) ; MAKE INST POINT
2102 ; SET LIST/TUPLE/ID LOCATIVE
2104 SMON4: HRR D,1(B) ; POINT TO TYPE WORD
2110 SMON5: HRRZ C,1(B) ; POINT TO TOP OF UV
2112 SUB C,0 ; POINT TO DOPE
2113 HRRI D,(C) ; POINT IN INST
2118 SMON6: MOVEI C,(B) ; FOR BYTDOP
2119 PUSHJ P,BYTDOP ; POINT TO DOPE
2123 PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4]
2124 [PNWORD,SMON5],[PCHSTR,SMON6],[PBYTE,SMON6]]
2139 ; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE
2141 MFUNCTION MONAD,SUBR,MONAD?
2145 MOVE B,AB ; CHECK PRIM TYPE
2147 JUMPE A,ITRUTH ;RETURN ARGUMENT
2149 JRST @MONTBL(A) ;DISPATCH ON PTYPE
2152 PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1]
2153 [PCHSTR,CHMON],[PTMPLT,TMPMON],[PBYTE,CHMON]]
2155 MON1: JUMPGE B,ITRUTH ;EMPTY VECTOR
2162 TMPMON: PUSHJ P,LNTMPL
2166 CISTRU: GETYP A,A ; COMPILER CALL
2171 ISTRUC: PUSHJ P,SAT ; STORAGE TYPE
2173 AOS (P) ; SKIP IF WINS
2176 ; SUBR TO CHECK FOR LOCATIVE
2178 MFUNCTION %LOCA,SUBR,[LOCATIVE?]
2186 ; SKIPS IF TYPE IN A IS A LOCATIVE
2188 LOCQ: GETYP A,(B) ; GET TYPE
2189 LOCQQ: PUSH P,A ; SAVE FOR LOCN/LOCD
2198 LOCQ1: POP P,A ; RESTORE TYPE
2205 ; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS
2207 MFUNCTION MEMBER,SUBR
2209 MOVE E,[PUSHJ P,EQLTST] ;TEST ROUTINE IN E
2214 MOVE E,[PUSHJ P,EQTST] ;EQ TESTER
2217 MOVE B,AB ;POINT TO FIRST ARG
2218 PUSHJ P,PTYPE ;CHECK PRIM TYPE
2219 ADD B,[2,,2] ;POINT TO 2ND ARG
2221 JUMPE A,WTYP2 ;2ND WRONG TYPE
2224 MOVE C,2(AB) ; FOR TUPLE CASE
2225 SKIPE B,3(AB) ;GOBBLE LIST VECTOR ETC. POINTER
2226 PUSHJ P,@MEMTBL(A) ;DISPATCH
2227 JRST IFALSE ;OR REPORT LOSSAGE
2230 PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC]
2231 [PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP],[PBYTE,MEMBYT]]
2235 MEMLST: MOVSI 0,TLIST ;SET B'S TYPE TO LIST
2238 JUMPE B,MEMLS6 ; EMPTY LIST LOSE IMMEDIATE
2240 MEMLS1: INTGO ;CHECK INTERRUPTS
2241 MOVEI C,(B) ;COPY POINTER
2242 GETYP D,(C) ;GET TYPE
2244 CAIE D,TDEFER ;DEFERRED?
2246 MOVE C,1(C) ;GET DEFERRED DATUM
2247 GETYPF A,(C) ;GET FULL TYPE WORD
2248 MEMLS2: MOVE C,1(C) ;GET DATUM
2249 XCT E ;DO THE COMPARISON
2250 JRST MEMLS3 ;NO MATCH
2253 MEMLS6: MOVE PVP,PVSTOR+1
2254 SETZM BSTO(PVP) ;RESET B'S TYPE
2257 MEMLS3: HRRZ B,(B) ;STEP THROGH
2258 JUMPN B,MEMLS1 ;STILL MORE TO DO
2259 MEMLS4: MOVSI A,TFALSE ;RETURN FALSE
2260 JRST MEMLS6 ;RETURN 0
2264 MEMVEC: MOVSI A,TVEC ;CLOBBER B'S TYPE TO VECTOR
2265 JUMPGE B,MEMLS4 ;EMPTY VECTOR
2269 MEMV1: INTGO ;CHECK FOR INTS
2270 GETYPF A,(B) ;GET FULL TYPE
2271 MOVE C,1(B) ;AND DATA
2272 XCT E ;DO COMPARISON INS
2273 JRST MEMV2 ;NOT EQUAL
2276 JRST MEMLS5 ;RETURN WITH POINTER
2278 MEMV2: ADD B,[2,,2] ;INCREMENT AND GO
2279 JUMPL B,MEMV1 ;STILL WINNING
2281 JRST MEMLS4 ;AND RETURN FALSE
2283 MUVEC: JUMPGE B,MEMLS4
2284 GETYP A,-1(TP) ;GET TYPE OF GODIE
2285 HLRE C,B ;LOOK FOR UNIFORM TYPE
2286 SUBM B,C ;DOPE POINTER TO C
2287 GETYP C,(C) ;GET THE TYPE
2288 CAIE A,(C) ;ARE THEY THE SAME?
2289 JRST MEMLS4 ;NO, LOSE
2296 MOVSI A,(C) ;TYPE TO LH
2297 PUSH P,A ; SAVE FOR EACH TEST
2299 MUVEC1: INTGO ;CHECK OUT INTS
2300 MOVE C,(B) ;GET DATUM
2301 MOVE A,(P) ; GET TYPE
2303 AOBJN B,MUVEC1 ;LOOP TO WINNAGE
2306 JUMPGE B,MEMV3 ;LOSE RETURN
2311 MEMBYT: MOVEI 0,TFIX
2315 MEMCH: MOVEI 0,TCHRS
2317 MEMBY1: GETYP A,-1(TP) ;IS ARG A SINGLE CHAR
2318 CAIE 0,(A) ;SKIP IF POSSIBLE WINNER
2321 MOVE D,(TP) ; AND CHAR
2323 MEMCH1: SOJL 0,MEMV3
2326 CAIE A,(D) ;CHECK IT
2334 CAME E,[PUSHJ P,EQLTST]
2336 LDB A,[300600,,(TP)]
2340 MOVEI 0,(C) ; GET # OF CHAR INTO 0
2342 PUSH P,D ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK
2344 MEMST1: SOJL 0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR
2348 SOJA C,MEMST1 ; MATCH FAILS TRY NEXT
2354 MOVE E,(TP) ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP
2355 HRRZ C,-1(TP) ; LENGTH OF 1ARG
2356 MEMST2: SOJE C,MEMWN ; WON -RAN OUT OF 1ARG FIRST-
2357 SOJL MEMLSR ; LOST -RAN OUT OF 2ARG-
2360 CAIN A,(D) ; SKP IF POSSIBLY LOST -BACK TO MEMST1-
2369 MEMWN: MOVE B,-2(P) ; SETS UP ARGS LIKE MEMCH2 - HAVE WON
2374 MEMLSR: SUB P,[5,,5]
2380 ; MEMBERSHIP FOR TEMPLATE HACKER
2382 MEMTMP: GETYP 0,(B) ; GET REAL SAT
2386 PUSH TP,B ; SAVE GOOEIE
2387 PUSHJ P,TM.LN1 ; GET LENGTH
2389 HLRZ A,(TP) ; FUDGE FOR REST
2391 PUSH P,B ; SAVE LENGTH
2398 MEMTM1: MOVE PVP,PVSTOR+1
2404 PUSHJ P,TMPLNT ; GET ITEM
2405 EXCH C,B ; VALUE TO C, POINTER BACK TO B
2417 MEMTM3: MOVE PVP,PVSTOR+1
2419 HRL B,(P) ; DO APPROPRIATE REST
2421 MEMTM2: SUB P,[4,,4]
2429 CAMN C,(TP) ;CHECK VALUE
2430 CAIE 0,(A) ;AND TYPE
2434 EQLTST: MOVE PVP,PVSTOR+1
2441 MOVEI C,-5(TP) ;SET UP CALL TO IEQUAL
2443 AOS -1(P) ;ASSUME SKIP
2444 PUSHJ P,IEQUAL ;GO INO EQUAL
2445 SOS -1(P) ;UNDO SKIP
2446 SUB TP,[2,,2] ;AND POOP OF CRAP
2453 ; COMPILER MEMQ AND MEMBER
2455 CIMEMB: SKIPA E,[PUSHJ P,EQLTST]
2457 CIMEMQ: MOVE E,[PUSHJ P,EQTST]
2464 MOVE B,D ; STRUCT TO B
2466 TDZA 0,0 ; FLAG NO SKIP
2467 MOVEI 0,1 ; FLAG SKIP
2470 SOS (P) ; SKIP RETURN
2474 ; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR
2480 MOVE B,AB ;CHECK ARG
2485 PUSHJ P,@TOPTBL(E) ;DISPATCH
2488 PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP]
2489 [PTMPLT,BCKTOP],[PBYTE,BTOP]]
2491 BCKTOP: MOVEI B,(B) ; FIX UP POINTER
2495 UVTOP: SKIPA A,$TUVEC
2500 HLRE C,B ;AND -LENGTH
2502 SUB B,C ;POINT TO DOPE WORD
2503 HLRZ D,1(B) ;TOTAL LENGTH
2504 SUBI B,-2(D) ;POINT TO TOP
2505 MOVNI D,-2(D) ;-LENGTH
2506 HRLI B,(D) ;B NOW POINTS TO TOP
2509 BTOP: SKIPA E,$TBYTE
2510 CHTOP: MOVSI E,TCHSTR
2515 LDB 0,[360600,,(TP)] ; POSITION FIELD
2516 LDB E,[300600,,(TP)] ; AND SIZE FILED
2517 IDIVI 0,(E) ; 0/ BYTES IN 1ST WORD
2518 MOVEI C,36. ; BITS PER WORD
2519 IDIVI C,(E) ; BYTES PER WORD
2521 SUBM C,0 ; UNUSED BYTES I 1ST WORD
2522 ADD 0,-1(TP) ; LENGTH OF WORD BOUNDARIED STRING
2523 MOVEI C,-1(TP) ; GET DOPE WORD
2525 HLRZ C,(A) ; GET LENGTH
2526 SKIPGE -1(A) ; SKIP IF NOT REALLY ATOM
2527 SUBI C,3 ; IF IT IS, 3 LESS WORDS
2528 SUBI A,-1(C) ; START +1
2529 MOVEI B,-1(A) ; SETUP BYTER
2530 SUB A,(TP) ; WORDS DIFFERENT
2531 IMUL A,(P) ; CHARS EXTRA
2532 SUBM 0,A ; FINAL TOTAL TO A
2537 IMULI E,(C) ; BITS USED IN FULL WORD
2539 SUBI C,(E) ; WHERE TO POINT IN EMPTY? CASE
2548 GETATO: HLRE C,B ;GET -LENGTH
2551 GETYP 0,(B) ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY)
2552 CAIN 0,TENTRY ;IF ENTRY
2553 JRST EASYTP ;WANT UNEVALUATED ARGS
2554 HRRE C,(B) ;ELSE-- GET NO. OF ARGS (*-2)
2555 SUBI B,(C) ;GO TO TOP
2556 TLCA B,-1(C) ;STORE NUMBER IN TOP POINTER
2557 EASYTP: MOVE B,FRAMLN+ABSAV(B) ;GET ARG POINTER
2561 ; COMPILERS ENTRY TO TOP
2563 CITOP: PUSHJ P,CPTYEE
2564 CAIN E,P2WORD ; LIST?
2569 ; FUNCTION TO CLOBBER THE CDR OF A LIST
2571 MFUNCTION PUTREST,SUBR,[PUTREST]
2574 MOVE B,AB ;COPY ARG POINTER
2575 PUSHJ P,PTYPE ;CHECK IT
2576 CAIE A,P2WORD ;LIST?
2577 JRST WTYP1 ;NO, LOSE
2578 ADD B,[2,,2] ;AND NEXT ONE
2581 JRST WTYP2 ;NOT LIST, LOSE
2582 HRRZ B,1(AB) ;GET FIRST
2584 MOVE D,3(AB) ;AND 2D LIST
2588 MOVE A,(AB) ;RETURN CALLED TYPE
2593 ; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING
2599 MOVEI C,1 ;ASSUME BACKING UP ONE
2600 JUMPGE AB,TFA ;NO ARGS IS TOO FEW
2601 CAML AB,[-2,,0] ;SKIP IF MORE THAN 2 ARGS
2602 JRST BACK1 ;ONLY ONE ARG
2603 GETYP A,2(AB) ;GET TYPE
2604 CAIE A,TFIX ;MUST BE FIXED
2606 SKIPGE C,3(AB) ;GET NUMBER
2608 CAMGE AB,[-4,,0] ;SKIP IF WINNING NUMBER OF ARGS
2610 BACK1: MOVE B,AB ;SET UP TO FIND TYPE
2611 PUSHJ P,PTYPE ;GET PRIM TYPE
2614 SKIPN B,1(AB) ;GET DATUM
2619 PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA]
2620 [PTMPLT,BCKTMP],[PBYTE,BACKB]]
2622 BACKV: LSH C,1 ;GENERAL, DOUBLE AMOUNT
2624 BACKU: MOVSI A,TUVEC
2627 HRLI C,(C) ;TO BOTH HALVES
2628 SUB B,C ;BACK UP VECTOR POINTER
2629 HLRE C,B ;FIND OUT IF OVERFLOW
2630 SUBM B,C ;DOPE POINTER TO C
2631 HLRZ D,1(C) ;GET LENGTH
2632 SUBI C,-2(D) ;POINT TO TOP
2634 CAILE C,(B) ;SKIP IF A WINNER
2635 JRST OUTRNG ;COMPLAIN
2639 SUB B,C ; FIX UP POINTER
2644 BACKB: SKIPA E,[TBYTE]
2645 BACKC: MOVEI E,TCHSTR
2648 ADDI A,(C) ; NEW LENGTH
2650 PUSH P,A ; SAVE COUNT
2651 LDB E,[300600,,B] ;BYTE SIZE
2652 MOVEI 0,36. ;BITS PER WORD
2653 IDIVI 0,(E) ;DIVIDE TO FIND BYTES/WORD
2654 IDIV C,0 ;C/ WORDS BACK, D/BYTES BACK
2655 SUBI B,(C) ;BACK WORDS UP
2656 JUMPE D,CHBOUN ;CHECK BOUNDS
2658 IMULI 0,(E) ;0/ BITS OCCUPIED BY FULL WORD
2659 LDB A,[360600,,B] ;GET POSITION FILED
2660 BACKC2: ADDI A,(E) ;BUMP
2664 SUBI B,1 ;DECREMENT POINTER PART
2665 BACKC1: SOJG D,BACKC2 ;DO FOR ALL BYTES
2669 DPB A,[360600,,B] ;FIX UP POINT BYTER
2670 CHBOUN: MOVEI C,-1(TP)
2671 PUSHJ P,BYTDOP ; FIND DOPE WORD
2673 SKIPGE -1(A) ; SKIP IF NOT REALLY AN ATOM
2674 SUBI C,3 ; ELSE FUDGE FOR VALUE CELL AND OBLIST SLOT
2675 SUBI A,-1(C) ; POINT TO TOP
2676 MOVE C,B ; COPY BYTER
2678 CAILE A,(C) ; SKIP IF OK
2680 POP P,A ; RESTORE COUNT
2685 BACKA: LSH C,1 ;NUMBER TIMES 2
2686 HRLI C,(C) ;TO BOTH HALVES
2687 SUB B,C ;FIX POINTER
2689 PUSHJ P,GETATO ;LOOK A T TOP
2697 CIBACK: PUSHJ P,CPTYEE
2704 MFUNCTION STRCOMP,SUBR
2717 JRST ATMCMP ; MAYBE ATOMS
2723 MOVEI A,(A) ; ISOLATR LENGHTS
2726 STRCO2: SOJL A,CHOTHE ; ONE STRING EXHAUSTED, CHECK OTHER
2727 SOJL C,1BIG ; 1ST IS BIGGER
2730 CAIN 0,(E) ; SKIP IF DIFFERENT
2732 CAIL 0,(E) ; SKIP IF 2D BIGGER THAN 1ST
2737 CHOTHE: JUMPN C,2BIG ; 2 IS BIGGER
2738 SM.CMP: TDZA B,B ; RETURN 0
2740 RETFIX: MOVSI A,TFIX
2743 ATMCMP: CAIE 0,TATOM ; COULD BE ATOM
2744 JRST WTYP1 ; NO, QUIT
2749 CAMN B,D ; SAME ATOM?
2751 ADD B,[3,,3] ; SKIP VAL CELL ETC.
2754 ATMCM1: MOVE 0,(B) ; GET A WORD OF CHARS
2756 JRST ATMCM3 ; NO, GET DIF
2758 AOBJN D,ATMCM1 ; MORE TO COMPARE
2759 JRST 1BIG ; 1ST IS BIGGER
2762 ATMCM2: AOBJP D,SM.CMP ; EQUAL
2765 ATMCM3: LSH 0,-1 ; AVOID SIGN LOSSAGE
2772 \f;ERROR COMMENTS FOR SOME PRIMITIVES
2774 OUTRNG: ERRUUO EQUOTE OUT-OF-BOUNDS
2776 WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
2778 IIGETP: JRST IGETP ;FUDGE FOR MIDAS/STINK LOSSAGE
2781 \f;SUPER USEFUL ERROR MESSAGES (USED BY WHOLE WORLD)
2783 WNA: ERRUUO EQUOTE WRONG-NUMBER-OF-ARGUMENTS
2785 TFA: ERRUUO EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
2787 TMA: ERRUUO EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
2790 WTYP: ERRUUO EQUOTE ARG-WRONG-TYPE
2793 WTYP1: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
2796 WTYP2: ERRUUO EQUOTE SECOND-ARG-WRONG-TYPE
2798 BADTPL: ERRUUO EQUOTE BAD-TEMPLATE-DATA
2800 BADPUT: ERRUUO EQUOTE TEMPLATE-TYPE-VIOLATION
2802 WTYP3: ERRUUO EQUOTE THIRD-ARG-WRONG-TYPE
2804 WTYPL: ERRUUO EQUOTE INTERNAL-BACK-OR-TOP-OF-A-LIST
2806 WTYPUN: ERRUUO EQUOTE NON-STRUCTURED-ARG-TO-INTERNAL-PUT-REST-NTH-TOP-OR-BACK
2809 CALER: HRRZ C,FSAV(TB)
2812 SKIPA C,@-1(C) ; SUBRS AND FSUBRS
2813 MOVE C,3(C) ; FOR RSUBRS
2820 GETWNA: HLRZ B,(E)-2 ;GET LOSING COMPARE INSTRUCTION
2821 CAIE B,(CAIE A,) ;AS EXPECTED ?
2823 HRRE B,(E)-2 ;GET DESIRED NUMBER OF ARGS
2824 HLRE A,AB ;GET ACTUAL NUMBER OF ARGS