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 DEFSTU: PUSH TP,$TLIST
1790 PUSHJ P,CELL2 ; GET WORDS
1796 HLLZ 0,(E) ; GET OLD MONITORS
1797 TLZ 0,TYPMSK ; KILL TYPES
1798 TLO 0,TDEFER ; MAKE DEFERRED
1802 ; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK
1807 VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR
1808 POP TP,D ; GET GOODIE BACK
1811 ; AVSTUF -- CLOBBER ARGS AND VECTORS
1814 VSTUF: PUSHJ P,MONCH0
1822 ; UPUT -- CLOBBER A UVECTOR
1824 UPUT: PUSHJ P,UAT ; GET IT RESTED
1828 ; USTUF -- HERE TO CLOBBER A UVECTOR
1831 SUBM B,E ; C POINTS TO DOPE
1832 GETYP A,(E) ; GET UTYPE
1834 CAIE 0,(A) ; CHECK SAMENESS
1836 HLLZ 0,(E) ; MONITOR BITS IN DOPE WORD
1837 MOVSI A,TLOCU ; CHOMP, CHOMP (WAS TUVEC) -- MARC 5/2/78
1842 ; BPUT -- HERE TO PUT A BYTE-STRING
1850 ; SPUT -- HERE TO PUT A STRING
1852 SPUT: PUSHJ P,STAT ; REST IT
1856 ; SSTUF -- STUFF A STRING
1858 SSTUF: MOVEI E,TCHRS
1859 SSTUF1: GETYP 0,C ; BETTER BE CHAR
1865 MOVEI C,-1(TP) ; FIND D.W.
1867 SKIPGE (A)-1 ; SKIP IF NOT REALLY ATOM
1869 HLLZ 0,(A)-1 ; GET MONITORS
1880 PUSH TP,EQUOTE ATTEMPT-TO-MUNG-ATOMS-PNAME
1887 ; TSTUF -- SETLOC A TEMPLATE
1893 ; PUTTMP -- TEMPLATE PUTTER
1896 PUSHJ P,TM.TOE ; GET E POINTING TO SLOT #
1897 ADD A,TD.PUT+1 ; POINT TO INS
1898 MOVE A,(A) ; GET VECTOR OF INS
1900 POP TP,B ; NEW VAL TO A AND B
1907 TM.LN1: SUBI 0,NUMSAT+1
1908 HRRZ A,0 ; RET FIXED OFFSET
1910 ADD 0,TD.LNT+1 ; USE LENGTHERS FOR TEST
1914 HRRZS 0 ; POINT TO TABLE ENTRY
1921 TM.TBL: MOVEI E,(D) ; TENTATIVE WINNER IN E
1922 TLNN B,-1 ; SKIP IF REST HAIR EXISTS
1925 PUSH P,A ; SAVE OFFSET
1926 HRLS A ; A IS REL OFFSET TO INS TABLE
1927 ADD A,TD.GET+1 ; GET ONEOF THE TABLES
1928 MOVE A,(A) ; TABLE POINTER TO A
1929 MOVSI 0,-1(D) ; START SEEING IF PAST TEMP SPEC
1931 JUMPL 0,CPOPJA ; JUMP IF E STILL VALID
1932 HLRZ E,B ; BASIC LENGTH TO E
1933 HLRE 0,A ; LENGTH OF TEMPLATE TO 0
1934 ADDI 0,(E) ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE
1936 SUBM D,E ; E ==> # PAST BASIC WANTED
1938 IDIVI 0,(E) ; A ==> REL REST GUY WANTED
1944 ; TM.TOE -- GET RIGHT TEMPLATE # IN E
1945 ; C/ OBJECT #, B/ OBJECT POINTER
1947 TM.TOE: GETYP 0,(B) ; GET REAL SAT
1948 MOVEI D,(C) ; OBJ # TO D
1949 HLRZ C,B ; REST COUNT
1950 ADDI D,(C) ; FUDGE FOR REST COUNTER
1951 MOVE C,B ; POINTER TO C
1952 PUSHJ P,TM.LN1 ; GET LENGTH IN B (WATCH LH!)
1953 CAILE D,(B) ; CHECK RANGE
1954 JRST OUTRNG ; LOSER, QUIT
1955 JRST TM.TBL ; GO COMPUTE TABLE OFFSET
1957 \f; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B
1968 ; COMPILER CALLS TO MANY OF THESE GUYS
1970 CIREST: PUSHJ P,CPTYEE ; TYPE OF DISP TO E
1971 HRRES C ; CLEAR LH, IN CASE IT'S AN OFFSET
1978 CIRST1: PUSHJ P,STORST
1981 CINTH: PUSHJ P,CPTYEE
1983 SOJL C,OUTRNG ; CHECK BOUNDS
1987 CIAT: PUSHJ P,CPTYEE
1992 CSETLO: PUSHJ P,CTYLOC
1993 MOVSS E ; REAL DISPATCH
1994 GETYP 0,A ; INCASE LOCAS OR LOCD
2003 MOVSS E ; REAL DISPATCH
2015 ; COMPILER'S PUT,GET AND GETL
2025 JUMPE E,CIGET1 ; REAL GET, NOT NTH
2026 GETYP 0,C ; INDIC FIX?
2032 AOS (P) ; ALWAYS SKIP
2033 MOVE C,D ; # TO AN AC
2038 CIGET1: POP P,E ; GET FLAG
2039 JRST @GETTR(E) ; DO A REAL GET
2049 PUSH TP,-1(TP) ; PAIN AND SUFFERING
2055 CAIE 0,TFIX ; YES DO STRUCT
2061 SOJL C,OUTRNG ; CHECK BOUNDS
2067 CIPUT1: PUSHJ P,IPUT
2070 ; SMON -- SET MONITOR BITS
2071 ; B/ <POINTER TO LOCATIVE>
2072 ; D/ <IORM> OR <ANDCAM>
2076 PUSHJ P,PTYPE ; TO PRIM TYPE
2078 SKIPE A,SMONTB(A) ; DISPATCH?
2081 ; COULD STILL BE LOCN OR LOCD
2083 GETYP A,(B) ; TYPE BACK
2085 JRST SMON2 ; COULD BE LOCD
2087 HRRI D,VAL(C) ; MAKE INST POINT
2094 ; SET LIST/TUPLE/ID LOCATIVE
2096 SMON4: HRR D,1(B) ; POINT TO TYPE WORD
2102 SMON5: HRRZ C,1(B) ; POINT TO TOP OF UV
2104 SUB C,0 ; POINT TO DOPE
2105 HRRI D,(C) ; POINT IN INST
2110 SMON6: MOVEI C,(B) ; FOR BYTDOP
2111 PUSHJ P,BYTDOP ; POINT TO DOPE
2115 PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4]
2116 [PNWORD,SMON5],[PCHSTR,SMON6],[PBYTE,SMON6]]
2131 ; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE
2133 MFUNCTION MONAD,SUBR,MONAD?
2137 MOVE B,AB ; CHECK PRIM TYPE
2139 JUMPE A,ITRUTH ;RETURN ARGUMENT
2141 JRST @MONTBL(A) ;DISPATCH ON PTYPE
2144 PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1]
2145 [PCHSTR,CHMON],[PTMPLT,TMPMON],[PBYTE,CHMON]]
2147 MON1: JUMPGE B,ITRUTH ;EMPTY VECTOR
2154 TMPMON: PUSHJ P,LNTMPL
2158 CISTRU: GETYP A,A ; COMPILER CALL
2163 ISTRUC: PUSHJ P,SAT ; STORAGE TYPE
2165 AOS (P) ; SKIP IF WINS
2168 ; SUBR TO CHECK FOR LOCATIVE
2170 MFUNCTION %LOCA,SUBR,[LOCATIVE?]
2178 ; SKIPS IF TYPE IN A IS A LOCATIVE
2180 LOCQ: GETYP A,(B) ; GET TYPE
2181 LOCQQ: PUSH P,A ; SAVE FOR LOCN/LOCD
2190 LOCQ1: POP P,A ; RESTORE TYPE
2197 ; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS
2199 MFUNCTION MEMBER,SUBR
2201 MOVE E,[PUSHJ P,EQLTST] ;TEST ROUTINE IN E
2206 MOVE E,[PUSHJ P,EQTST] ;EQ TESTER
2209 MOVE B,AB ;POINT TO FIRST ARG
2210 PUSHJ P,PTYPE ;CHECK PRIM TYPE
2211 ADD B,[2,,2] ;POINT TO 2ND ARG
2213 JUMPE A,WTYP2 ;2ND WRONG TYPE
2216 MOVE C,2(AB) ; FOR TUPLE CASE
2217 SKIPE B,3(AB) ;GOBBLE LIST VECTOR ETC. POINTER
2218 PUSHJ P,@MEMTBL(A) ;DISPATCH
2219 JRST IFALSE ;OR REPORT LOSSAGE
2222 PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC]
2223 [PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP],[PBYTE,MEMBYT]]
2227 MEMLST: MOVSI 0,TLIST ;SET B'S TYPE TO LIST
2230 JUMPE B,MEMLS6 ; EMPTY LIST LOSE IMMEDIATE
2232 MEMLS1: INTGO ;CHECK INTERRUPTS
2233 MOVEI C,(B) ;COPY POINTER
2234 GETYP D,(C) ;GET TYPE
2236 CAIE D,TDEFER ;DEFERRED?
2238 MOVE C,1(C) ;GET DEFERRED DATUM
2239 GETYPF A,(C) ;GET FULL TYPE WORD
2240 MEMLS2: MOVE C,1(C) ;GET DATUM
2241 XCT E ;DO THE COMPARISON
2242 JRST MEMLS3 ;NO MATCH
2245 MEMLS6: MOVE PVP,PVSTOR+1
2246 SETZM BSTO(PVP) ;RESET B'S TYPE
2249 MEMLS3: HRRZ B,(B) ;STEP THROGH
2250 JUMPN B,MEMLS1 ;STILL MORE TO DO
2251 MEMLS4: MOVSI A,TFALSE ;RETURN FALSE
2252 JRST MEMLS6 ;RETURN 0
2256 MEMVEC: MOVSI A,TVEC ;CLOBBER B'S TYPE TO VECTOR
2257 JUMPGE B,MEMLS4 ;EMPTY VECTOR
2261 MEMV1: INTGO ;CHECK FOR INTS
2262 GETYPF A,(B) ;GET FULL TYPE
2263 MOVE C,1(B) ;AND DATA
2264 XCT E ;DO COMPARISON INS
2265 JRST MEMV2 ;NOT EQUAL
2268 JRST MEMLS5 ;RETURN WITH POINTER
2270 MEMV2: ADD B,[2,,2] ;INCREMENT AND GO
2271 JUMPL B,MEMV1 ;STILL WINNING
2273 JRST MEMLS4 ;AND RETURN FALSE
2275 MUVEC: JUMPGE B,MEMLS4
2276 GETYP A,-1(TP) ;GET TYPE OF GODIE
2277 HLRE C,B ;LOOK FOR UNIFORM TYPE
2278 SUBM B,C ;DOPE POINTER TO C
2279 GETYP C,(C) ;GET THE TYPE
2280 CAIE A,(C) ;ARE THEY THE SAME?
2281 JRST MEMLS4 ;NO, LOSE
2288 MOVSI A,(C) ;TYPE TO LH
2289 PUSH P,A ; SAVE FOR EACH TEST
2291 MUVEC1: INTGO ;CHECK OUT INTS
2292 MOVE C,(B) ;GET DATUM
2293 MOVE A,(P) ; GET TYPE
2295 AOBJN B,MUVEC1 ;LOOP TO WINNAGE
2298 JUMPGE B,MEMV3 ;LOSE RETURN
2303 MEMBYT: MOVEI 0,TFIX
2307 MEMCH: MOVEI 0,TCHRS
2309 MEMBY1: GETYP A,-1(TP) ;IS ARG A SINGLE CHAR
2310 CAIE 0,(A) ;SKIP IF POSSIBLE WINNER
2313 MOVE D,(TP) ; AND CHAR
2315 MEMCH1: SOJL 0,MEMV3
2318 CAIE A,(D) ;CHECK IT
2326 CAME E,[PUSHJ P,EQLTST]
2328 LDB A,[300600,,(TP)]
2332 MOVEI 0,(C) ; GET # OF CHAR INTO 0
2334 PUSH P,D ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK
2336 MEMST1: SOJL 0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR
2340 SOJA C,MEMST1 ; MATCH FAILS TRY NEXT
2346 MOVE E,(TP) ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP
2347 HRRZ C,-1(TP) ; LENGTH OF 1ARG
2348 MEMST2: SOJE C,MEMWN ; WON -RAN OUT OF 1ARG FIRST-
2349 SOJL MEMLSR ; LOST -RAN OUT OF 2ARG-
2352 CAIN A,(D) ; SKP IF POSSIBLY LOST -BACK TO MEMST1-
2361 MEMWN: MOVE B,-2(P) ; SETS UP ARGS LIKE MEMCH2 - HAVE WON
2366 MEMLSR: SUB P,[5,,5]
2372 ; MEMBERSHIP FOR TEMPLATE HACKER
2374 MEMTMP: GETYP 0,(B) ; GET REAL SAT
2378 PUSH TP,B ; SAVE GOOEIE
2379 PUSHJ P,TM.LN1 ; GET LENGTH
2381 HLRZ A,(TP) ; FUDGE FOR REST
2383 PUSH P,B ; SAVE LENGTH
2390 MEMTM1: MOVE PVP,PVSTOR+1
2396 PUSHJ P,TMPLNT ; GET ITEM
2397 EXCH C,B ; VALUE TO C, POINTER BACK TO B
2409 MEMTM3: MOVE PVP,PVSTOR+1
2411 HRL B,(P) ; DO APPROPRIATE REST
2413 MEMTM2: SUB P,[4,,4]
2421 CAMN C,(TP) ;CHECK VALUE
2422 CAIE 0,(A) ;AND TYPE
2426 EQLTST: MOVE PVP,PVSTOR+1
2433 MOVEI C,-5(TP) ;SET UP CALL TO IEQUAL
2435 AOS -1(P) ;ASSUME SKIP
2436 PUSHJ P,IEQUAL ;GO INO EQUAL
2437 SOS -1(P) ;UNDO SKIP
2438 SUB TP,[2,,2] ;AND POOP OF CRAP
2445 ; COMPILER MEMQ AND MEMBER
2447 CIMEMB: SKIPA E,[PUSHJ P,EQLTST]
2449 CIMEMQ: MOVE E,[PUSHJ P,EQTST]
2456 MOVE B,D ; STRUCT TO B
2458 TDZA 0,0 ; FLAG NO SKIP
2459 MOVEI 0,1 ; FLAG SKIP
2462 SOS (P) ; SKIP RETURN
2466 ; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR
2472 MOVE B,AB ;CHECK ARG
2477 PUSHJ P,@TOPTBL(E) ;DISPATCH
2480 PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP]
2481 [PTMPLT,BCKTOP],[PBYTE,BTOP]]
2483 BCKTOP: MOVEI B,(B) ; FIX UP POINTER
2487 UVTOP: SKIPA A,$TUVEC
2492 HLRE C,B ;AND -LENGTH
2494 SUB B,C ;POINT TO DOPE WORD
2495 HLRZ D,1(B) ;TOTAL LENGTH
2496 SUBI B,-2(D) ;POINT TO TOP
2497 MOVNI D,-2(D) ;-LENGTH
2498 HRLI B,(D) ;B NOW POINTS TO TOP
2501 BTOP: SKIPA E,$TBYTE
2502 CHTOP: MOVSI E,TCHSTR
2507 LDB 0,[360600,,(TP)] ; POSITION FIELD
2508 LDB E,[300600,,(TP)] ; AND SIZE FILED
2509 IDIVI 0,(E) ; 0/ BYTES IN 1ST WORD
2510 MOVEI C,36. ; BITS PER WORD
2511 IDIVI C,(E) ; BYTES PER WORD
2513 SUBM C,0 ; UNUSED BYTES I 1ST WORD
2514 ADD 0,-1(TP) ; LENGTH OF WORD BOUNDARIED STRING
2515 MOVEI C,-1(TP) ; GET DOPE WORD
2517 HLRZ C,(A) ; GET LENGTH
2518 SKIPGE -1(A) ; SKIP IF NOT REALLY ATOM
2519 SUBI C,3 ; IF IT IS, 3 LESS WORDS
2520 SUBI A,-1(C) ; START +1
2521 MOVEI B,-1(A) ; SETUP BYTER
2522 SUB A,(TP) ; WORDS DIFFERENT
2523 IMUL A,(P) ; CHARS EXTRA
2524 SUBM 0,A ; FINAL TOTAL TO A
2529 IMULI E,(C) ; BITS USED IN FULL WORD
2531 SUBI C,(E) ; WHERE TO POINT IN EMPTY? CASE
2540 GETATO: HLRE C,B ;GET -LENGTH
2543 GETYP 0,(B) ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY)
2544 CAIN 0,TENTRY ;IF ENTRY
2545 JRST EASYTP ;WANT UNEVALUATED ARGS
2546 HRRE C,(B) ;ELSE-- GET NO. OF ARGS (*-2)
2547 SUBI B,(C) ;GO TO TOP
2548 TLCA B,-1(C) ;STORE NUMBER IN TOP POINTER
2549 EASYTP: MOVE B,FRAMLN+ABSAV(B) ;GET ARG POINTER
2553 ; COMPILERS ENTRY TO TOP
2555 CITOP: PUSHJ P,CPTYEE
2556 CAIN E,P2WORD ; LIST?
2561 ; FUNCTION TO CLOBBER THE CDR OF A LIST
2563 MFUNCTION PUTREST,SUBR,[PUTREST]
2566 MOVE B,AB ;COPY ARG POINTER
2567 PUSHJ P,PTYPE ;CHECK IT
2568 CAIE A,P2WORD ;LIST?
2569 JRST WTYP1 ;NO, LOSE
2570 ADD B,[2,,2] ;AND NEXT ONE
2573 JRST WTYP2 ;NOT LIST, LOSE
2574 HRRZ B,1(AB) ;GET FIRST
2576 MOVE D,3(AB) ;AND 2D LIST
2580 MOVE A,(AB) ;RETURN CALLED TYPE
2585 ; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING
2591 MOVEI C,1 ;ASSUME BACKING UP ONE
2592 JUMPGE AB,TFA ;NO ARGS IS TOO FEW
2593 CAML AB,[-2,,0] ;SKIP IF MORE THAN 2 ARGS
2594 JRST BACK1 ;ONLY ONE ARG
2595 GETYP A,2(AB) ;GET TYPE
2596 CAIE A,TFIX ;MUST BE FIXED
2598 SKIPGE C,3(AB) ;GET NUMBER
2600 CAMGE AB,[-4,,0] ;SKIP IF WINNING NUMBER OF ARGS
2602 BACK1: MOVE B,AB ;SET UP TO FIND TYPE
2603 PUSHJ P,PTYPE ;GET PRIM TYPE
2606 SKIPN B,1(AB) ;GET DATUM
2611 PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA]
2612 [PTMPLT,BCKTMP],[PBYTE,BACKB]]
2614 BACKV: LSH C,1 ;GENERAL, DOUBLE AMOUNT
2616 BACKU: MOVSI A,TUVEC
2619 HRLI C,(C) ;TO BOTH HALVES
2620 SUB B,C ;BACK UP VECTOR POINTER
2621 HLRE C,B ;FIND OUT IF OVERFLOW
2622 SUBM B,C ;DOPE POINTER TO C
2623 HLRZ D,1(C) ;GET LENGTH
2624 SUBI C,-2(D) ;POINT TO TOP
2626 CAILE C,(B) ;SKIP IF A WINNER
2627 JRST OUTRNG ;COMPLAIN
2631 SUB B,C ; FIX UP POINTER
2636 BACKB: SKIPA E,[TBYTE]
2637 BACKC: MOVEI E,TCHSTR
2640 ADDI A,(C) ; NEW LENGTH
2642 PUSH P,A ; SAVE COUNT
2643 LDB E,[300600,,B] ;BYTE SIZE
2644 MOVEI 0,36. ;BITS PER WORD
2645 IDIVI 0,(E) ;DIVIDE TO FIND BYTES/WORD
2646 IDIV C,0 ;C/ WORDS BACK, D/BYTES BACK
2647 SUBI B,(C) ;BACK WORDS UP
2648 JUMPE D,CHBOUN ;CHECK BOUNDS
2650 IMULI 0,(E) ;0/ BITS OCCUPIED BY FULL WORD
2651 LDB A,[360600,,B] ;GET POSITION FILED
2652 BACKC2: ADDI A,(E) ;BUMP
2656 SUBI B,1 ;DECREMENT POINTER PART
2657 BACKC1: SOJG D,BACKC2 ;DO FOR ALL BYTES
2661 DPB A,[360600,,B] ;FIX UP POINT BYTER
2662 CHBOUN: MOVEI C,-1(TP)
2663 PUSHJ P,BYTDOP ; FIND DOPE WORD
2665 SKIPGE -1(A) ; SKIP IF NOT REALLY AN ATOM
2666 SUBI C,3 ; ELSE FUDGE FOR VALUE CELL AND OBLIST SLOT
2667 SUBI A,-1(C) ; POINT TO TOP
2668 MOVE C,B ; COPY BYTER
2670 CAILE A,(C) ; SKIP IF OK
2672 POP P,A ; RESTORE COUNT
2677 BACKA: LSH C,1 ;NUMBER TIMES 2
2678 HRLI C,(C) ;TO BOTH HALVES
2679 SUB B,C ;FIX POINTER
2681 PUSHJ P,GETATO ;LOOK A T TOP
2689 CIBACK: PUSHJ P,CPTYEE
2696 MFUNCTION STRCOMP,SUBR
2709 JRST ATMCMP ; MAYBE ATOMS
2715 MOVEI A,(A) ; ISOLATR LENGHTS
2718 STRCO2: SOJL A,CHOTHE ; ONE STRING EXHAUSTED, CHECK OTHER
2719 SOJL C,1BIG ; 1ST IS BIGGER
2722 CAIN 0,(E) ; SKIP IF DIFFERENT
2724 CAIL 0,(E) ; SKIP IF 2D BIGGER THAN 1ST
2729 CHOTHE: JUMPN C,2BIG ; 2 IS BIGGER
2730 SM.CMP: TDZA B,B ; RETURN 0
2732 RETFIX: MOVSI A,TFIX
2735 ATMCMP: CAIE 0,TATOM ; COULD BE ATOM
2736 JRST WTYP1 ; NO, QUIT
2741 CAMN B,D ; SAME ATOM?
2743 ADD B,[3,,3] ; SKIP VAL CELL ETC.
2746 ATMCM1: MOVE 0,(B) ; GET A WORD OF CHARS
2748 JRST ATMCM3 ; NO, GET DIF
2750 AOBJN D,ATMCM1 ; MORE TO COMPARE
2751 JRST 1BIG ; 1ST IS BIGGER
2754 ATMCM2: AOBJP D,SM.CMP ; EQUAL
2757 ATMCM3: LSH 0,-1 ; AVOID SIGN LOSSAGE
2764 \f;ERROR COMMENTS FOR SOME PRIMITIVES
2766 OUTRNG: ERRUUO EQUOTE OUT-OF-BOUNDS
2768 WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
2770 IIGETP: JRST IGETP ;FUDGE FOR MIDAS/STINK LOSSAGE
2773 \f;SUPER USEFUL ERROR MESSAGES (USED BY WHOLE WORLD)
2775 WNA: ERRUUO EQUOTE WRONG-NUMBER-OF-ARGUMENTS
2777 TFA: ERRUUO EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
2779 TMA: ERRUUO EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
2782 WTYP: ERRUUO EQUOTE ARG-WRONG-TYPE
2785 WTYP1: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
2788 WTYP2: ERRUUO EQUOTE SECOND-ARG-WRONG-TYPE
2790 BADTPL: ERRUUO EQUOTE BAD-TEMPLATE-DATA
2792 BADPUT: ERRUUO EQUOTE TEMPLATE-TYPE-VIOLATION
2794 WTYP3: ERRUUO EQUOTE THIRD-ARG-WRONG-TYPE
2796 WTYPL: ERRUUO EQUOTE INTERNAL-BACK-OR-TOP-OF-A-LIST
2798 WTYPUN: ERRUUO EQUOTE NON-STRUCTURED-ARG-TO-INTERNAL-PUT-REST-NTH-TOP-OR-BACK
2801 CALER: HRRZ C,FSAV(TB)
2804 SKIPA C,@-1(C) ; SUBRS AND FSUBRS
2805 MOVE C,3(C) ; FOR RSUBRS
2812 GETWNA: HLRZ B,(E)-2 ;GET LOSING COMPARE INSTRUCTION
2813 CAIE B,(CAIE A,) ;AS EXPECTED ?
2815 HRRE B,(E)-2 ;GET DESIRED NUMBER OF ARGS
2816 HLRE A,AB ;GET ACTUAL NUMBER OF ARGS