2 TITLE STRBUILD MUDDLE STRUCTURE BUILDER
4 .GLOBAL RCL,VECTOP,GCSTOP,GCSBOT,FRETOP,GCSNEW,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG
5 .GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR,RCLV,RCLVEC
6 .GLOBAL PGROW,TPGROW,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR,RBLDM,CPOPJ,CPOPJ1,STBL
7 .GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,FREDIF,FREMIN,GCHAPN,INTFLG,PINIT,CKPUR,GCSET
8 .GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2,MKTBS,CPOPJ1,.LIST.
9 .GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS,SLEEPR,GCHK10,FPAG
10 .GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,C1CONS
11 .GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,FRONT,%GCJOB,%SHWND,%INFMP,%GETIP
12 .GLOBAL TD.PUT,TD.GET,TD.LNT,GLOTOP,UBIT,FLGSET,PURMNG,RPURBT,%IFMP2,CHKPGI,PURCLN
13 .GLOBAL CTIME,MTYO,ILOC,NODES,GPURFL,GCDANG,GCHACK,LPUR,HITOP,BADCHN,IMPURX
14 .GLOBAL NOWLVL,CURPLN,PVSTOR,SPSTOR,MPOPJ,NGCS,RNUMSP,NUMSWP,SAGC,INQAGC
15 .GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC,GCRSET,ACCESS,NOSHUF,SQUPNT
16 ; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
18 .GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS
19 .GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE
20 .GLOBAL TPBINC,GBLINC,TYPINC,CONADJ,OGCSTP,ABOTN
21 .GLOBAL AGC,ROOT,CIGTPR,IIGLOC
22 .GLOBAL P.TOP,P.CORE,PMAPB
23 .GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1
24 .GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM
26 ; SHARED SYMBOLS WITH GC MODULE
28 .GLOBAL GCNO,BSTGC,BSTAT,NOWFRE,CURFRE,MAXFRE,USEFRE,NOWTP,CURTP,CTPMX,NOWLFL
29 .GLOBAL CURLVL,NOWGVL,CURGVL,NOWTYP,CURTYP,NOWSTO,CURSTO,CURMAX,NOWP,CURP,CPMX
30 .GLOBAL GCCAUS,GCCALL,LVLINC,GVLINC,TYPIC,STORIC,RCL,RCLV,GCDANG,GETNUM,RPTOP,CORTOP
31 .GLOBAL TPGROW,PPGROW,PGROW,PMAIN,PGOOD,PMAX,TPGOOD,TPMIN,TPMAX,RFRETP,TYPTAB
32 .GLOBAL NNPRI,NNSAT,TYPSAV,BUFGC,GCTIM,GPURFL,GCDFLG,DUMFLG,PMIN,PURMIN
33 .GLOBAL GLBINC,GCHAIR,GCMONF,SQKIL,INBLOT
34 .GLOBAL C%11,C%22,C%33,C%44,C%55,C%66,C%0,C%1,C%2,C%3,C%M1,C%M2,C%M10
35 .GLOBAL C%M20,C%M30,C%M40,C%M60
37 NOPAGS==1 ; NUMBER OF WINDOWS
41 .ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
43 GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
44 STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
45 STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
58 \f; GC-READ TAKES ONE ARGUMENT WHICH MUST BE A "READB" CHANNEL
60 .GLOBAL CLOOKU,CINSER,MOBLIST,CATOM,EOFCND,IGLOC
62 MFUNCTION GCREAD,SUBR,[GC-READ]
66 CAML AB,C%M2 ; CHECK # OF ARGS
71 GETYP A,(AB) ; MAKE SURE ARG IS A CHANNEL
73 JRST WTYP2 ; IT ISN'T COMPLAIN
74 MOVE B,1(AB) ; GET PTR TO CHANNEL
75 HRRZ C,-2(B) ; LOOK AT BITS IN CHANNEL
76 TRC C,C.OPN+C.READ+C.BIN
77 TRNE C,C.OPN+C.READ+C.BIN
80 PUSH P,1(B) ; SAVE ITS CHANNEL #
82 MOVE B,[-2,,C] ; SET UP AOBJN PTR TO READ IN DELIMITING
84 MOVE A,(P) ; GET CHANNEL #
86 FATAL GCREAD-- IOT FAILED
87 JUMPL B,EOFGC ; IF BLOCK DIDN'T FINISH THEN EOF
90 MOVE A,(P) ; GET CHANNEL
104 MOVE B,[-3,,C] ; NEXT GROUP OF WORDS
106 FATAL GCREAD--GC IOT FAILED
109 MOVE A,-2(P) ; GET CHANNEL
117 MOVEI 0,0 ; DO PRELIMINARY TESTS
118 IOR 0,A ; IOR ALL WORDS IN
123 TLNE 0,-1 ; SKIP IF NO BITS IN LEFT HALF
128 MOVE D,C ; GET START OF NEWTYPE TABLE
129 SUB D,-1(P) ; CREATE AOBJN POINTER
132 MOVEM D,TYPTAB ; SAVE IT
133 MOVE A,(P) ; GET LENGTH OF WORD
134 SUBI A,CONADJ ; SUBTRACT FOR CONSTANTS
137 CAMG A,FRETOP ; SEE IF GC IS NESESSARY
139 ADDM C,GETNUM ; MOVE IN REQUEST
140 MOVE C,[0,,1] ; ARGS TO GC
142 RDGC1: MOVE C,GCSTOP ; GET CURRENT TOP OF THE WORLD
143 MOVEM C,OGCSTP ; SAVE IT
144 ADD C,(P) ; CALCULATE NEW GCSTOP
145 ADDI C,2 ; SUBTRACT FOR CONSTANTS
148 SUBI C,2 ; SUBSTRACT TO GET RID OF D.W'S
149 MOVNS C ; SET UP AOBJN PTR FOR READIN
152 MOVE A,-2(P) ; GET CHANNEL #
155 FATAL GCREAD-- IOT FAILED
158 MOVE A,-2(P) ; CHANNEL TO A
159 MOVE B,OGCSTP ; SET UP BYTE POINTER
164 MOVE C,(P) ; GET LENGHT OF OBJECT
166 MOVE B,1(AB) ; GET CHANNEL
168 MOVE D,GCSTOP ; SET UP TO LOOK LIKE UVECTOR OF LOSES
169 ADDI C,2 ; ADD 2 FOR DOPE WORDS
173 IORM A,-2(D) ; MARK VECTOR BIT
174 PUSH TP,$TRDTB ; HOLD ON IN CASE OF GC
181 MOVE D,-1(P) ; SET UP BOTTOM OF ATOM TABLE
184 MOVE C,GCSTOP ; START AT TOP OF WORLD
185 SUBI C,3 ; POINT TO FIRST ATOM
187 ; LOOP TO FIX UP THE ATOMS
191 CAMG C,0 ; SEE IF WE ARE DONE
195 PUSHJ P,ATFXU ; FIX IT UP
196 HLRZ A,(C) ; GET LENGTH
197 TRZ A,400000 ; TURN OFF MARK BIT
198 SUBI C,(A) ; POINT TO PRECEDING ATOM
199 HRRZS C ; CLEAR OFF NEGATIVE
202 ; FIXUP ROUTINE FOR ATOMS (C==> D.W.)
204 ATFXU: PUSH P,C ; SAVE PTR TO D.W.
207 HLRZ B,(A) ; GET LENGTH AND MARKING
208 TRZE B,400000 ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED
210 MOVEI D,-3(B) ; FULL WORDS OF STRING IN PNAME
211 IMULI D,5 ; CALCULATE # OF CHARACTERS
212 MOVE 0,-2(A) ; GET LAST WORD OF STRING
213 SUBI A,-1(B) ; LET A POINT TO OBLIST SLOAT
214 MOVE B,A ; GET COPY OF A
220 IDIVI 0,7 ; # OF CHARS IN LAST WORD
222 ADD D,$TCHSTR ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD
224 MOVE C,(B) ; GET OBLIST SLOT PTR
225 ATFXU9: HRRZS B ; RELATAVIZE POINTER
229 JUMPE C,ATFXU6 ; NO OBLIST. CREATE ATOM
230 CAMN C,C%M1 ; SEE IF ROOT ATOM
232 ADD C,ABOTN ; POINT TO ATOM
236 MOVE A,$TATOM ; SET UP TO SEE IF OBLIST EXITS
238 MOVE D,IMQUOTE OBLIST
240 JRST ATFXU8 ; NO OBLIST. CREATE ONE
241 SUB TP,C%22 ; GET RID OF SAVED ATOM
242 RTCON: PUSH TP,$TOBLS
244 MOVE C,B ; SET UP FOR LOOKUP
245 MOVE A,-1(P) ; SET UP PTR TO PNAME
247 ADD B,[440700,,1] ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER
251 JRST ATFXU4 ; NOT ON IT SO INSERT
252 ATFXU3: SUB P,C%22 ; DONE
253 SUB TP,C%22 ; POP OFF OBLIST
254 ATFXU7: MOVE C,(P) ; RESTORE PTR TO D.W.
256 MOVEM B,-1(C) ; MOVE IN RELATAVIZE ADDRESS
258 IORM D,(C) ; TURN OFF MARK BIT
259 MOVE 0,3(B) ; SEE IF MUST BE LOCR
260 TRNE 0,1 ; SKIP IF MUST MAKE IT IMPURE
265 ATFXU1: POP P,C ; RESTORE PTR TO D.W.
267 MOVE B,-1(C) ; GET ATOM
270 ; ROUTINE TO INSERT AN ATOM
272 ATFXU4: MOVE C,(TP) ; GET OBLIST PTR
273 MOVE B,(P) ; SET UP STRING PTR TO PNAME
277 MOVE A,-1(P) ; GET TYPE WORD
278 PUSHJ P,CINSER ; INSERT IT
281 ; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST
283 ATFXU6: MOVE B,(P) ; POINT TO PNAME
284 ADD B,[440700,,1] ; MAKE IT LOOK LIKE A BYTE POINTER
289 SUB P,C%22 ; CLEAN OFF STACK
292 ; THIS ROUTINE CREATES AND OBLIST
294 ATFXU8: MCALL 1,MOBLIST
296 PUSH TP,B ; SAVE OBLIST PTR
297 JRST ATFXU4 ; JUMP TO INSERT THE OBLIST
299 ; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST
301 RTFX: MOVE B,ROOT+1 ; GET ROOT OBLIST
304 ; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS.
307 ; ROUTINE TO FIX UP TYPE-TABLE FOR GC-READ. THIS ROUTINE FIXES UP THE TYPE TABLE SO THAT
308 ; THE TYPES ATOM I.D. IS REPLACED BY ITS TYPE-NUMBER IN THE NEW MUDDLE AND IF ITS A
309 ; TEMPLATE, THE SLOT FOR THE PRIMTYPE-ATOM IS REPLACED BY THE SAT OF THE TEMPLATE
311 HRRZ E,1(TB) ; SET UP TYPE TABLE
313 JUMPGE E,VUP ; SKIP OVER IF DONE
314 TYPUP1: PUSH P,C%0 ; PUSH SLOT FOR POSSIBLE TEMPLATE ATOM
315 HLRZ A,1(E) ; GET POSSIBLE ATOM SLOT
316 JUMPE A,TYPUP2 ; JUMP IF NOT A TEMPLATE
317 ADD A,ABOTN ; GET ATOM
320 MOVE B,TYPVEC+1 ; GET TYPE VECTOR SLOT FOR LOOP TO SEE IF ITS THERE
321 TYPUP3: CAMN A,1(B) ; SKIP IF NOT EQUAL
322 JRST TYPUP4 ; FOUND ONE
325 JRST ERTYP1 ; ERROR NONE EXISTS
326 TYPUP4: HRRZ C,(B) ; GET SAT SLOT
327 CAIG C,NUMSAT ; MAKE SURE TYPE IS A TEMPLATE
328 JRST ERTYP2 ; IF NOT COMPLAIN
329 HRLM C,1(E) ; SMASH IN NEW SAT
330 MOVE B,1(B) ; GET ATOM OF PRIMTYPE
331 MOVEM B,(P) ; PUSH ONTO STACK
332 TYPUP2: MOVEI D,0 ; INITIALIZE TYPE COUNT FOR LOOKUP LOOP
333 MOVE B,TYPVEC+1 ; GET PTR FOR LOOP
334 HRRZ A,1(E) ; GET TYPE'S ATOM ID
335 ADD A,ABOTN ; GET ATOM
338 TYPUP5: CAMN A,1(B) ; SKIP IF NOT EQUAL
339 JRST TYPUP6 ; FOUND ONE
340 ADDI D,1 ; INCREMENT TYPE-COUNT
341 ADD B,C%22 ; POINT TO NEXT
343 HRRM D,1(E) ; CLOBBER IN TYPE-NUMBER
344 PUSH TP,$TATOM ; PUSH ARGS FOR NEWTYPE
347 POP P,B ; GET BACK POSSIBLE PRIMTYPE ATOM
348 JUMPE B,TYPUP7 ; JUMP IF NOT A TEMPLATE
349 PUSH TP,B ; PUSH ON PRIMTYPE
351 PUSH P,E ; SAVE RELATAVIZED PTR TO TYPE-TABLE
353 POP P,E ; RESTORE RELATAVIZED PTR
354 ADD E,1(TB) ; FIX IT UP
355 TYPUP0: ADD E,C%22 ; INCREMENT E
358 TYPUP7: HRRZ B,(E) ; FIND PRIMTYPE FROM SAT
362 TYPUP6: HRRM D,1(E) ; CLOBBER IN TYPE #
365 ERTYP1: ERRUUO EQUOTE CANT-FIND-TEMPLATE
367 ERTYP2: ERRUUO EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE
369 VUP: HRRZ E,1(TB) ; FIX UP SOME POINTERS
375 ; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES.
376 ; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY.
378 HRRZ A,TYPTAB ; GET TO TOP OF WORLD
379 SUBI A,2 ; GET TO FIRST TYPE WORD OR DOPE-WORD OF FIRST OBJECT
380 VUP1: CAMG A,OGCSTP ; SKIP IF NOT DONE
382 HLRZ B,(A) ; GET TYPE SLOT
383 TRNE B,.VECT. ; SKIP IF NOT A VECTOR
385 SUBI A,2 ; SKIP OVER PAIR
387 VUP2: TRNE B,400000 ; SKIP IF UVECTOR
389 ANDI B,TYPMSK ; GET RID OF MONITORS
390 CAMG B,NNPRI ; SKIP IF NEWTYPE
392 PUSHJ P,GETNTP ; GET THE NEW TYPE #
393 PUTYP B,(A) ; SMASH IT IT
394 VUP5: HLRZ B,1(A) ; SKIP OVER VECTOR
395 TRZ B,400000 ; GET RID OF POSSIBLE MARK BIT
398 VUP4: ANDI B,TYPMSK ; FLUSH MONITORS
399 CAMG B,NNSAT ; SKIP IF TEMPLATE
401 PUSHJ P,GETSAT ; CONVERT TO NEW SAT
402 ADDI B,.VECT. ; MAJIC TO TURN ON BIT
407 VUP3: PUSH P,GCSBOT ; SAVE CURRENT GCSBOT
408 MOVE A,OGCSTP ; SET UP NEW GCSBOT
411 HRRZ A,TYPTAB ; SET UP NEW GCSTOP
414 MOVE A,[PUSHJ P,RDFIX] ; INS FOR GCHACK
415 MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
418 POP P,GCSTOP ; RESTORE GCSTOP
419 MOVE A,1(TB) ; GET A POINTER TO RETURNING VALUES
425 POP P,GCSBOT ; RESTORE GCSBOT
426 MOVE B,1(A) ; GET PTR TO OBJECTS
430 ; ERROR FOR INCORRECT GCREAD FILE
432 ERDGC: ERRUUO EQUOTE BAD-GC-READ-FILE
434 ; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE
436 RDFIX: PUSH P,C ; SAVE C
439 TLNE C,UBIT ; SKIP IF NOT UVECTOR
440 JRST ELEFX ; DON'T HACK TYPES IN UVECTOR
447 ELEFX: EXCH B,A ; EXCHANGE FOR SAT
450 CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS
455 CAIN B,S1WORD ; SEE IF PRIMTYPE WOR
456 JRST RDLSTF ; LEAVE IF IS
457 STFXX: MOVE 0,GCSBOT ; ADJUSTMENT
459 SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL
461 RDLSTF: TLNN C,.LIST. ; SEE IF PAIR
463 MOVE 0,GCSBOT ; FIX UP
465 HRRZ B,(C) ; SEE IF POINTS TO NIL
468 MOVE B,C ; GET ARG FOR RLISTQ
472 RDL1: POP P,B ; RESTORE B
476 ; ROUTINE TO FIX UP PNAMES
480 HLLM D,1(C) ; PUT BACK WITH BIT OFF
483 HLRE 0,-1(D) ; LENGTH OF ATOM
485 SUBI 0,3 ; VAL & OBLIST
486 IMULI 0,5 ; TO CHARS (SORT OF)
491 LDB A,[360600,,1(C)] ; GET BYTE POS
492 IDIVI A,7 ; TO CHAR POS
495 HRRZ B,(C) ; STRING LENGTH
496 SUB B,A ; TO WORD BOUNDARY STRING
505 ; ROUTINE TO FIX UP POINTERS TO ATOMS
510 MOVE 0,-1(D) ; GET PTR TO ATOM
511 CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR
527 ATFXAT: MOVEM 0,1(C) ; SMASH IT IN
530 TYPCFX: HRRZ B,1(C) ; GET TYPE
531 PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
532 HRRM B,1(C) ; CLOBBER IT IN
533 JRST RDLSTF ; CONTINUE FIXUP
535 TYPWFX: HLRZ B,1(C) ; GET TYPE
536 PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
537 HRLM B,1(C) ; SMASH IT IN
541 PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE
546 ; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
547 ; EOF HANDLER ELSE USES CHANNELS.
549 EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B
550 CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED
551 JRST MYCLOS ; USE CHANNELS
555 MYCLOS: PUSH TP,EOFCND-1(B)
557 CLOSIT: PUSH TP,$TCHAN
559 MCALL 1,FCLOSE ; CLOSE CHANNEL
560 MCALL 1,EVAL ; EVAL HIS EOF HANDLER
563 ; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
565 GETNEW: CAMG B,NNPRI ;NEWTYPE
567 GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE
568 GETNT1: HLRZ E,(D) ; GET TYPE #
569 CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
570 JRST GOTTYP ; FOUND IT
571 ADD D,C%22 ; POINT TO NEXT
573 SKIPA ; KEEP TYPE SAME
574 GOTTYP: HRRZ B,1(D) ; GET NEW TYPE #
577 ; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
579 GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE
580 GETSA1: HRRZ E,(D) ; GET OBJECT
581 CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
582 JRST GOTSAT ; FOUND IT
585 FATAL GC-DUMP -- TYPE FIXUP FAILURE
586 GOTSAT: HLRZ B,1(D) ; GET NEW SAT
590 ; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
592 GETYP A,(B) ; GET TYPE
593 PUSHJ P,SAT ; GET SAT
594 CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
596 AOS -1(P) ; SKIP IF NOT DEFFERED
603 MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
607 JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT
609 CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR
610 JRST WTYP1 ; IF NOT COMPLAIN
613 CAIE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
615 CAMGE AB,C%M20 ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
617 MOVE A,(AB) ; GET THE UVECTOR
619 JRST SETUV ; CONTINUE
620 GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR
622 SETUV: PUSH P,A ; SAVE UVECTOR
624 MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
628 PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
629 HLRE 0,TP ; COMPUTE STACK SPACE USED UP
633 MOVE B,IMQUOTE THIS-PROCESS
637 HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
639 HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS
643 SUB B,C ; TOTAL WORDS ATOM STORAGE
644 IDIVI B,6 ; COMPUTE # OF SLOTS
646 HRRZ A,GLOBASE+1 ; COMPUTE TOTAL # OF GLOBAL SLOTS
648 SUB A,0 ; POINT TO DOPE WORD
650 ASH B,-2 ; # OF GVAL SLOTS
652 HRRZ A,GLOTOP+1 ; COMPUTE # OF GVAL SLOTS IN USE
655 ASH A,-2 ; NEGATIVE # OF SLOTS USED
657 HRRZ A,TYPBOT+1 ; GET LENGTH OF TYPE VECTOR
660 HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR
661 IDIVI B,2 ; CONVERT TO # OF TYPES
663 HLRE 0,TYPVEC+1 ; LENGTH OF VISABLE TYPE-VECTOR
665 IDIVI 0,2 ; GET # OF TYPES
667 MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE
669 SETZB B,D ; ZERO OUT MAXIMUM
671 LOOPC: HLRZ 0,(C) ; GET BLK LENGTH
672 ADD D,0 ; ADD # OF WORDS IN BLOCK
673 CAMGE B,0 ; SEE IF NEW MAXIMUM
675 HRRZ C,(C) ; POINT TO NEXT BLOCK
676 JUMPN C,LOOPC ; REPEAT
679 HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P
683 MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES
684 HRRZ B,(P) ; RESTORE B
687 HRLI C,BSTAT ; MODIFY BLT FOR STATS
689 BLT C,(B)STATGC+STATNO-1
691 HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE
693 POP P,A ; RESTORE TYPE-WORD
696 GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST
697 MOVE 0,[GCNO,,GCNO+1]
704 .GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
706 ; USER GARBAGE COLLECTOR INTERFACE
713 CAMGE AB,C%M60 ; [-6,,0]
715 PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN
716 SKIPE A ; SKIP FOR 0 ARGUMENT
718 GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE
720 CAML AB,C%M40 ; [-4,,0] ; SEE IF 3RD ARG
722 GETYP A,4(AB) ; MAKE SURE A FIX
724 JRST WTYP ; ARG WRONG TYPE
728 GC5: CAML AB,C%M20 ; [-2,,0] ; SEE IF SECOND ARG
730 GETYP A,2(AB) ; SEE IF NONFALSE
731 CAIE A,TFALSE ; SKIP IF FALSE
732 JRST HAIRGC ; CAUSE A HAIRY GC
733 GC3: MOVSI A,TATOM ; CHECK TO SEE IF INTERRUPT FLAG IS ON
734 MOVE B,IMQUOTE AGC-FLAG
736 CAMN A,$TUNBOUND ; SKIP IF NOT UNBOUND
738 SKIPE GCHPN ; SKIP IF GCHAPPEN IS 0
739 JRST FALRTN ; JUMP TO RETURN FALSE
741 PUSHJ P,AGC ; COLLECT THAT TRASH
742 PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?
743 POP P,B ; RETURN AMOUNT
748 CAIN A,TFIX ; IF FIX THEN CLOBBER NGCS
750 MOVEI A,1 ; FORCE VALUE FLUSHING PHASE TO OCCUR
752 JRST GC2 ; HAIRY GC OCCORS NO MATTER WHAT
753 FALRTN: MOVE A,$TFALSE
754 MOVEI B,0 ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR
758 COMPRM: MOVE A,GCSTOP ; USED SPACE
763 MFUNCTION GCDMON,SUBR,[GC-MON]
769 FLGSET: MOVE C,(E) ; GET CURRENT VALUE
770 JUMPGE AB,RETFLG ; RET CURRENT
771 CAMGE AB,C%M20 ; [-3,,]
791 .GLOBAL EVATYP,APLTYP,PRNTYP
793 \fMFUNCTION BLOAT,SUBR
797 MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC
798 MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE
800 BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?
801 PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM
803 PUSHJ P,@BLOATER(E) ; DISPATCH
804 AOBJN E,BLOAT2 ; COUNT PARAMS SET
806 JUMPL AB,TMA ; ANY LEFT...ERROR
807 BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED
808 MOVE C,E ; MOVE IN INDICATOR
809 HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT
812 SKIPE A,TPBINC ; SMASH POINNTERS
815 SKIPE A,GLBINC ; GLOBAL SP
819 SETZM TPBINC ; RESET PARAMS
823 BLOATD: SKIPN A,GETNUM ; SKIP IF FREE STORAGE REQUEST IN EFFECT
825 ADD A,FRETOP ; ADD FRETOP
826 ADDI A,1777 ; ONE BLOCK FOR MARK PDL AND ROUND
827 ANDCMI A,1777 ; TO PAGE BOUNDRY
828 CAML A,PURBOT ; SKIP IF POSSIBLE TO WIN
830 ASH A,-10. ; TO PAGES
831 PUSHJ P,P.CORE ; GRET THE CORE
832 JRST BLFAGC ; LOSE LOSE LOSE
833 MOVE A,FRETOP ; CALCULATE NEW PARAMETERS
840 BLT B,-1(A) ; ZERO CORE
844 MOVSI A,TFIX ; RETURN CORE FOUND
846 BLFAGC: MOVN A,FREMIN
847 ADDM A,GETNUM ; FIX UP SO BLOATS CORRECTLY
848 MOVE C,C%11 ; INDICATOR FOR AGC
849 PUSHJ P,AGC ; GARBAGE COLLECT
852 ; TABLE OF BLOAT ROUTINES
872 ; BLOAT MAIN STORAGE AREA
875 MOVE D,FRETOP ; COMPUTE CURRENT ROOM
877 CAMGE A,D ; NEED MORE?
880 MOVEM A,GETNUM ; SAVE
883 ; BLOAT TP STACK (AT TOP)
885 TPBLO: HLRE D,TP ; GET -SIZE
887 ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
888 CAME D,TPGROW ; BLOWN?
889 ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
890 SUB A,B ; SKIP IF GROWTH NEEDED
893 ASH A,-6 ; CONVERT TO 64 WD BLOCKS
896 DPB A,[111100,,-1(D)] ; SMASH SPECS IN
899 ; BLOAT TOP LEVEL LOCALS
901 LOBLO: HLRE D,TP ; GET -SIZE
903 ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
904 CAME D,TPGROW ; BLOWN?
905 ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
906 CAMG A,B ; SKIP IF GROWTH NEEDED
907 IMULI A,6 ; 6 WORDS PER BINDING
910 HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E
912 SUBI A,(B) ; HOW MUCH MORE?
913 JUMPLE A,CPOPJ ; NONE NEEDED
916 DPB A,[1100,,-1(D)] ; SMASH
921 GLBLO: ASH A,2 ; 4 WORDS PER VAR
922 MOVE D,GLOBASE+1 ; CURRENT LIMITS
925 SUBI A,(B) ; NEW AMOUNT NEEDED
927 MOVEI B,GLBINC ; WHERE TO KEEP UPDATE
928 PUSHJ P,NUMADJ ; FIX NUMBER
930 SUB D,0 ; POINT TO DOPE
931 DPB A,[1100,,(D)] ; AND SMASH
934 ; HERE TO GROW TYPE VECTOR (AND FRIENDS)
936 TYBLO: ASH A,1 ; TWO WORD PER TYPE
937 HRRZ B,TYPVEC+1 ; FIND CURRENT ROOM
940 SUBI A,(B) ; EXTRA NEEDED TO A
941 JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE
942 MOVEI B,TYPINC ; WHERE TO STASH SPEC
943 PUSHJ P,NUMADJ ; FIX NUMBER
944 HLRE 0,D ; POINT TO DOPE
947 SKIPE D,EVATYP+1 ; GROW AUX TYPE VECS IF NEEDED
955 ; HERE TO CREATE STORAGE SPACE
957 STBLO: MOVE D,GCSBOT ; HOW MUCH NOW HERE
959 SUBI A,(D) ; MORE NEEDED?
961 MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT
968 SUBI D,5 ; FUDGE FOR THIS CALL
971 ADDI B,1(P) ; POINT TO DOPE
972 CAME B,PGROW ; BLOWN?
973 ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.
975 ASH A,-6 ; TO 64 WRD BLOCKS
976 CAILE A,377 ; IN RANGE?
978 DPB A,[111100,,-1(B)]
983 SFREM: SKIPE A ; DON'T ZERO EMPTY PARAMETER
989 SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B
997 SGVL: IMULI A,4. ; # OF SLOTS
1003 ; SET TYPE INCREMENT
1005 STYP: IMULI A,2 ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
1011 ; SET STORAGE INCREMENT
1013 SSTO: IDIVI A,2000 ; # OF BLOCKS
1014 CAIE B,0 ; REMAINDER?
1016 IMULI A,2000 ; CONVERT BACK TO WORDS
1019 ; HERE FOR MINIMUM PURE SPACE
1022 ANDCMI A,1777 ; TO PAGE BOUNDRY
1026 ; HERE TO ADJUST PSTACK PARAMETERS IN GC
1028 PMUNG: ADDI A,777 ; TO NEAREST 1000 WORD BOUNDRY
1030 MOVEM A,PGOOD ; PGOOD
1031 ASH A,2 ; PMAX IS 4*PGOOD
1033 ASH A,-4 ; PMIN IS .25*PGOOD
1036 ; HERE TO ADJUST GC TPSTACK PARAMS
1039 ANDCMI A,777 ; TO NEAREST 1000 WORD BOUNDRY
1041 ASH A,2 ; TPMAX= 4*TPGOOD
1043 ASH A,-4 ; TPMIN= .25*TPGOOD
1047 ; GET NEXT (FIX) ARG
1049 NXTFIX: PUSHJ P,GETFIX
1053 ; ROUTINE TO GET POS FIXED ARG
1055 GETFIX: GETYP A,(AB)
1063 ; GET NUMBERS FIXED UP FOR GROWTH FIELDS
1065 NUMADJ: ADDI A,77 ; ROUND UP
1066 ANDCMI A,77 ; KILL CRAP
1068 MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
1070 MOVEM A,(B) ; AND STASH IT
1072 ASH A,-6 ; TO 64 WD BLOCKS
1073 CAILE A,377 ; CHECK FIT
1077 ; DO SYMPATHETIC GROWTHS
1084 \f;FUNCTION TO CONSTRUCT A LIST
1089 GETYP A,2(AB) ;GET TYPE OF 2ND ARG
1091 JRST WTYP2 ;NO , COMPLAIN
1092 MOVE C,(AB) ; GET THING TO CONS IN
1094 HRRZ E,3(AB) ; AND LIST
1095 PUSHJ P,ICONS ; INTERNAL CONS
1098 ; COMPILER CALL TO CONS
1100 C1CONS: PUSHJ P,ICELL2
1103 ICONS3: MOVEM C,(B) ; AND STORE
1105 TLPOPJ: MOVSI A,TLIST
1108 ; INTERNAL CONS--ICONS; C,D VALUE, E CDR
1110 ; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE
1111 ; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED
1112 ; TO: DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS.
1118 ; INTERNAL CONS TO NIL--INCONS
1122 ICONS: GETYP A,C ; CHECK TYPE OF VAL
1123 PUSHJ P,NWORDT ; # OF WORDS
1124 SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED
1125 PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
1126 JRST ICNS2A ; NO CORE, GO GC (SPECIAL PLACE, NOTICE)
1129 ; HERE IF CONSING DEFERRED
1131 ICONS1: MOVEI A,4 ; NEED 4 WORDS
1132 PUSHJ P,ICELL ; GO GET 'EM
1133 JRST ICNS2A ; NOT THERE, GC (SAME PLACE AS FOR ICONS)
1134 HRLI E,TDEFER ; CDR AND DEFER
1136 MOVEI E,2(B) ; POINT E TO VAL CELL
1138 MOVEM C,(E) ; STORE VALUE
1144 ; HERE TO GC ON A CONS
1152 ; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
1153 ICNS2A: PUSHJ P,ICONSG
1157 ICONSG: PUSH TP,C ; SAVE VAL
1160 PUSH TP,E ; SAVE VITAL STUFF
1161 ADDM A,GETNUM ; AMOUNT NEEDED
1162 MOVE C,[3,,1] ; INDICATOR FOR AGC
1163 PUSHJ P,INQAGC ; ATTEMPT TO WIN
1164 MOVE D,-2(TP) ; RESTORE VOLATILE STUFF
1167 SUB TP,C%44 ; [4,,4]
1168 POPJ P, ; BACK TO DRAWING BOARD
1170 ; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED
1172 CELL2: MOVEI A,2 ; USUAL CASE
1173 CELL: PUSHJ P,ICELL ; INTERNAL
1177 ADDM A,GETNUM ; AMOUNT REQUIRED
1178 PUSH P,A ; PREVENT AGC DESTRUCTION
1179 MOVE C,[3,,1] ; INDICATOR FOR AGC
1182 JRST CELL ; AND TRY AGAIN
1184 ; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
1186 ICELL2: MOVEI A,2 ; MOST LIKELY CAE
1188 JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL
1189 MOVE B,PARTOP ; GET TOP OF PAIRS
1191 CAMLE B,FRETOP ; SKIP IF OK.
1193 EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER
1195 JRST CPOPJ1 ; SKIP RETURN
1197 ; TRY RECYCLING USING A VECTOR FROM RCLV
1199 VECTRY: SKIPN B,RCLV ; SKIP IF VECTOR EXISTS
1204 VECTR1: HLRZ A,(B) ; GET LENGTH
1206 JUMPL A,NXTVEC ; DOESN'T SATISFY TRY AGAIN
1207 CAIN A,1 ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
1209 JUMPN A,SOML ; SOME ARE LEFT
1214 SETZM -1(B) ; CLEAR DOPE WORDS
1216 POP P,A ; CLEAR STACK
1219 SOML: HRLM A,(B) ; SMASH AMOUNT LEFT
1220 SUBI B,-1(A) ; GET TO BEGINNING
1226 HRRZ B,(B) ; GET NEXT
1233 JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD
1238 SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL
1240 JRST CPOPJ1 ;THAT IT
1243 \f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
1245 IMFUNCTION LIST,SUBR
1249 LIST12: HLRE A,AB ;GET -NUM OF ARGS
1253 JUMPE A,LISTN ;JUMP IF 0
1254 SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME
1255 JRST LST12R ;TO GET RECYCLED CELLS
1256 PUSHJ P,CELL ;GET NUMBER OF CELLS
1257 PUSH TP,(P) ;SAVE IT
1260 LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS
1262 CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS
1263 HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE
1264 SOJG A,.-2 ;LOOP TIL ALL DONE
1265 CLEARM B,-2(B) ;SET THE LAST CDR TO NIL
1267 ; NOW LOBEER THE DATA IN TO THE LIST
1269 MOVE D,AB ; COPY OF ARG POINTER
1270 MOVE B,(TP) ;RESTORE LIS POINTER
1271 LISTLP: GETYP A,(D) ;GET TYPE
1272 PUSHJ P,NWORDT ;GET NUMBER OF WORDS
1273 SOJN A,LDEFER ;NEED TO DEFER POINTER
1274 GETYP A,(D) ;NOW CLOBBER ELEMENTS
1276 MOVE A,1(D) ;AND VALUE..
1278 LISTL2: HRRZ B,(B) ;REST B
1279 ADD D,C%22 ;STEP ARGS
1284 SUB TP,C%22 ; CLEANUP STACK
1288 LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS
1290 PUSH P,A ;SAVE COUNT ON STACK
1294 MOVE E,B ;LOOP AND CHAIN TOGETHER
1297 PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT
1299 SUB P,C%22 ;CLEAN UP AFTER OURSELVES
1300 JRST LISTLP-2 ;AND REJOIN MAIN STREAM
1303 ; MAKE A DEFERRED POINTER
1305 LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER
1307 MOVEM D,1(TB) ; SAVE ARG HACKER
1310 GETYPF A,(D) ;GET FULL DATA
1314 MOVE C,(TP) ;RESTORE LIST POINTER
1315 MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE
1317 HLLM A,(C) ;AND STORE IT
1328 IMFUNCTION FORM,SUBR
1335 \f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
1347 IILST: JUMPE A,IILST0 ; NIL WHATSIT
1352 PUSHJ P,ICONS ; CONS 'EM UP
1363 \f;FUNCTION TO BUILD AN IMPLICIT LIST
1365 MFUNCTION ILIST,SUBR
1368 ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG
1369 CAMGE AB,C%M40 ; [-4,,0] ; NO MORE THAN TWO ARGS
1371 PUSHJ P,GETFIX ; GET POS FIX #
1372 JUMPE A,LISTN ;EMPTY LIST ?
1373 CAML AB,C%M20 ; [-2,,0] ;ONLY ONE ARG?
1375 PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
1376 ILIST0: PUSH TP,2(AB)
1384 ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH
1386 ILIST3: POP P,A ; GET FINAL TYPE
1390 LOSEL: PUSH P,A ; SAVE COUNT
1393 LOSEL1: SETZB C,D ; TLOSE,,0
1404 MFUNCTION IFORM,SUBR
1410 \f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
1412 MFUNCTION VECTOR,SUBR,[IVECTOR]
1417 MFUNCTION UVECTOR,SUBR,[IUVECTOR]
1421 JUMPGE AB,TFA ; AT LEAST ONE ARG
1422 CAMGE AB,C%M40 ; [-4,,0] ; NOT MORE THAN 2
1424 PUSHJ P,GETFIX ; GET A POS FIXED NUMBER
1425 LSH A,(C) ; A-> NUMBER OF WORDS
1426 PUSH P,C ; SAVE FOR LATER
1427 PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)
1430 SUBM B,A ; FIND DOPE WORD
1431 MOVSI D,.VECT. ; FOR GCHACK
1434 MOVSI D,400000 ; GET NOT UNIFORM BIT
1435 IORM D,(A) ; INTO DOPE WORD
1436 SKIPA A,$TVEC ; GET TYPE
1437 VECTO4: MOVSI A,TUVEC
1438 CAML AB,C%M20 ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
1440 JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE
1442 PUSH TP,A ; SAVE THE VECTOR
1448 JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE
1449 INLP: PUSHJ P,IEVAL ; EVAL EXPR
1452 ADD C,C%22 ; BUMP VECTOR
1454 JUMPL C,INLP ; IF MORE DO IT
1456 GETVEC: MOVE A,-3(TP)
1458 SUB TP,C%44 ; [4,,4]
1461 ; HERE TO FILL UP A UVECTOR
1463 UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE
1464 GETYP A,A ; GET TYPE
1465 PUSH P,A ; SAVE TYPE
1466 PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED
1467 SOJN A,CANTUN ; COMPLAIN
1468 STJOIN: MOVE C,(TP) ; RESTORE POINTER
1469 ADD C,1(AB) ; POINT TO DOPE WORD
1470 MOVE A,(P) ; GET TYPE
1471 HRLZM A,(C) ; STORE IN D.W.
1472 MOVSI D,.VECT. ; FOR GCHACK
1474 MOVE C,(TP) ; GET BACK VECTOR
1476 JRST UINLP1 ; START FILLING UV
1479 UINLP: MOVEM C,(TP) ; SAVE PNTR
1480 PUSHJ P,IEVAL ; EVAL THE EXPR
1481 GETYP A,A ; GET EVALED TYPE
1482 CAIE A,@(P) ; WINNER?
1483 JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE
1484 UINLP1: MOVEM B,(C) ; STORE
1487 JRST GETVEC ; AND RETURN VECTOR
1489 IEVAL: PUSH TP,2(AB)
1495 ; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
1497 MFUNCTION ISTORAGE,SUBR
1500 CAMGE AB,C%M40 ; [-4,,0] ; AT LEAST ONE ARG
1502 PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG
1503 PUSHJ P,CAFRE ; GET CORE
1504 MOVN B,1(AB) ; -COUNT
1505 HRL A,B ; PUT IN LHW (A)
1507 HRLI B,2(B) ; LENGTH + 2
1508 ADDI B,(A) ; MAKE POINTER TO DOPE WORDS
1509 HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE
1510 HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
1513 CAML AB,C%M20 ; [-2,,0] ; SECOND ARG TO EVAL?
1514 JRST FINIS ; IF NOT, RETURN EMPTY
1519 PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE
1521 PUSH P,A ; FOR COMPARISON LATER
1524 JRST STJOIN ;TREAT LIKE A UVECTOR
1525 ; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
1526 PUSHJ P,FREESV ; FREE STORAGE VECTOR
1527 ERRUUO EQUOTE DATA-CANT-GO-IN-STORAGE
1529 ; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
1530 FREESV: MOVE A,1(AB) ; GET COUNT
1532 HRRZ B,(TP) ; GET ADDRESS
1533 PUSHJ P,CAFRET ; FREE THE CORE
1537 ; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
1539 IBLOK1: ASH A,1 ; TIMES 2
1540 GIBLOK: TLOA A,400000 ; FUNNY BIT
1541 IBLOCK: TLZ A,400000 ; NO BIT ON
1542 TLO A,.VECT. ; TURN ON BIT FOR GCHACK
1543 ADDI A,2 ; COMPENSATE FOR DOPE WORDS
1544 IBLOK2: SKIPE B,RCLV ; ANY TO RECYCLE?
1546 NORCL: MOVE B,GCSTOP ; POINT TO BOTTOM OF SPACE
1547 PUSH P,B ; SAVE TO BUILD PTR
1548 ADDI B,(A) ; ADD NEEDED AMOUNT
1549 CAML B,FRETOP ; SKIP IF NO GC NEEDED
1551 MOVEM B,GCSTOP ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
1554 HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD
1555 HLLZM A,-2(B) ; AND BIT
1556 HRLI A,-1(B) ; SMASH IN RELOCATION
1558 POP P,B ; RESTORE PTR TO BOTTOM OF VECTOR
1559 HRROS B ; POINT TO START OF VECTOR
1560 TLC B,-3(A) ; SETUP COUNT
1567 ; HERE TO DO A GC ON A VECTOR ALLOCATION
1570 PUSH P,A ; SAVE DESIRED LENGTH
1572 ADDM 0,GETNUM ; AND STORE AS DESIRED AMOUNT
1573 MOVE C,[4,,1] ; GET INDICATOR FOR AGC
1581 ; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
1582 ; ITEMS ON TOP OF STACK
1584 IEVECT: ASH A,1 ; TO NUMBER OF WORDS
1586 PUSHJ P,IBLOCK ; GET VECTOR
1588 SUBM B,D ; A POINTS TO DW
1589 MOVSI 0,400000+.VECT.
1590 MOVEM 0,(D) ; CLOBBER NON UNIF BIT
1591 POP P,A ; RESTORE COUNT
1592 JUMPE A,IVEC1 ; 0 LNTH, DONE
1593 MOVEI C,(TP) ; BUILD BLT
1594 SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK
1596 HRRI C,(B) ; B/ SOURCE,,DEST
1597 BLT C,-1(D) ; XFER THE DATA
1599 SUB TP,A ; FLUSH STACKAGE
1611 \f; INTERNAL CALL TO EUVECTOR
1613 IEUVEC: PUSH P,A ; SAVE LENGTH
1616 JUMPE A,IEUVE1 ; EMPTY, LEAVE
1617 ASH A,1 ; NOW FIND STACK POSITION
1618 MOVEI C,(TP) ; POINT TO TOP
1619 MOVE D,B ; COPY VEC POINTER
1620 SUBI C,-1(A) ; POINT TO 1ST DATUM
1621 GETYP A,(C) ; CHECK IT
1623 SOJN A,CANTUN ; WONT FIT
1626 IEUVE2: GETYP 0,(C) ; TYPE OF EL
1630 MOVEM 0,(D) ; CLOBBER
1632 AOBJN D,IEUVE2 ; LOOP
1634 HRLZM E,(D) ; STORE UTYPE
1635 IEUVE1: POP P,A ; GET COUNY
1636 ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS
1638 SUB TP,A ; CLEAN UP STACK
1648 IMFUNCTION EVECTOR,SUBR,[VECTOR]
1652 PUSH P,A ;SAVE NUMBER OF WORDS
1653 PUSHJ P,IBLOCK ; GET WORDS
1654 MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER
1655 JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR
1657 HRLI C,(AB) ;START BUILDING BLT POINTER
1658 HRRI C,(B) ;TO ADDRESS
1659 ADDI D,@(P) ;SET D TO FINAL ADDRESS
1661 FINISV: MOVSI 0,400000+.VECT.
1662 MOVEM 0,1(D) ; MARK AS GENERAL
1669 \f;EXPLICIT VECTORS FOR THE UNIFORM CSE
1671 IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
1674 HLRE A,AB ;-NUM OF ARGS
1676 ASH A,-1 ;NEED HALF AS MANY WORDS
1678 JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY
1679 GETYP A,(AB) ;GET FIRST ARG
1680 PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS
1683 PUSHJ P,IBLOCK ; GET VECT
1686 GETYP C,(AB) ;GET THE FIRST TYPE
1687 MOVE D,AB ;COPY THE ARG POINTER
1688 MOVE E,B ;COPY OF RESULT
1690 EUVLP: GETYP 0,(D) ;GET A TYPE
1692 JRST WRNGUT ;NO , LOSE
1693 MOVE 0,1(D) ;GET GOODIE
1694 MOVEM 0,(E) ;CLOBBER
1695 ADD D,C%22 ;BUMP ARGS POINTER
1699 HRLM C,(E) ;CLOBBER UNIFORM TYPE IN
1700 FINISU: MOVSI A,TUVEC
1703 WRNGSU: GETYP A,-1(TP)
1705 JRST WRNGUT ;IF UVECTOR
1706 PUSHJ P,FREESV ;FREE STORAGE VECTOR
1707 ERRUUO EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
1709 WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
1711 CANTUN: ERRUUO EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
1713 BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
1714 \f; FUNCTION TO GROW A VECTOR
1720 MOVEI D,0 ;STACK HACKING FLAG
1721 GETYP A,(AB) ;FIRST TYPE
1722 PUSHJ P,SAT ;GET STORAGE TYPE
1723 GETYP B,2(AB) ;2ND ARG
1724 CAIE A,STPSTK ;IS IT ASTACK
1726 AOJA D,GRSTCK ;YES, WIN
1727 CAIE A,SNWORD ;UNIFORM VECTOR
1728 CAIN A,S2NWORD ;OR GENERAL
1729 GRSTCK: CAIE B,TFIX ;IS 2ND FIXED
1730 JRST WTYP2 ;COMPLAIN
1732 CAIE B,TFIX ;3RD ARG
1735 MOVEI E,1 ;UNIFORM/GENERAL FLAG
1736 CAIE A,SNWORD ;SKIP IF UNIFORM
1737 CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL
1740 HRRZ B,1(AB) ;POINT TO START
1741 HLRE A,1(AB) ;GET -LENGTH
1742 SUB B,A ;POINT TO DOPE WORD
1743 SKIPE D ;SKIP IF NOT STACK
1744 ADDI B,PDLBUF ;FUDGE FOR PDL
1745 HLLZS (B) ;ZERO OUT GROWTH SPECS
1746 SKIPN A,3(AB) ;ANY TOP GROWTH?
1747 JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH
1748 ASH A,(E) ;MULT BY 2 IF GENERAL
1749 ADDI A,77 ;ROUND TO NEAREST BLOCK
1750 ANDCMI A,77 ;CLEAR LOW ORDER BITS
1751 ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION
1752 TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE
1754 TLNE A,-1 ;SKIP IF NOT TOO BIG
1756 GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH
1757 JRST GROW4 ;NONE, SKIP
1758 ASH C,(E) ;GENRAL FUDGE
1760 ANDCMI C,77 ;FUDGE FOR VALUE RETURN
1762 ASH C,-6 ;DIVIDE BY 100
1763 TRZE C,400 ;CONVERT TO SIGN MAGNITUDE
1765 TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW
1767 GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR
1769 HRLI E,(E) ;TO BOTH HALVES
1770 ADDI E,1(B) ;POINTS TO TOP
1772 ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH
1773 SKIPL D,(P) ;SHRINKAGE?
1774 JRST GROW3 ;NO, CONTINUE
1776 HRLI D,(D) ;TO BOTH HALVES
1777 ADD E,D ;POINT TO NEW LOW ADDR
1778 GROW3: IORI A,(C) ;OR TOGETHER
1779 HRRM A,(B) ;DEPOSIT INTO DOPEWORD
1780 PUSH TP,(AB) ;PUSH TYPE
1781 PUSH TP,E ;AND VALUE
1782 SKIPE A ;DON'T GC FOR NOTHING
1783 MOVE C,[2,,0] ; GET INDICATOR FOR AGC
1786 POP P,C ;RESTORE GROWTH
1788 POP TP,B ;GET VECTOR POINTER
1789 SUB B,C ;POINT TO NEW TOP
1793 GROFUL: SUB P,C%11 ; CLEAN UP STACK
1798 GTOBIG: ERRUUO EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
1799 GROW4: PUSH P,[0] ;0 BOTTOM GROWTH
1802 FULLOS: ERRUUO EQUOTE NO-STORAGE
1805 \f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
1807 MFUNCTION BYTES,SUBR
1819 IMFUNCTION STRING,SUBR
1825 STRNG1: MOVE B,AB ;COPY ARG POINTER
1826 MOVEI C,0 ;INITIALIZE COUNTER
1827 PUSH TP,$TAB ;SAVE A COPY
1829 HLRE A,B ; GET # OF ARGS
1831 ASH A,-1 ; 1/2 FOR # OF ARGS
1839 SKIPN E,A ; SKIP IF ARGS EXIST
1840 JRST MAKSTR ; ALL DONE
1842 STRIN2: GETYP 0,(B) ;GET TYPE CODE
1843 CAMN 0,SING(D) ; SINGLE CHARACTER OR FIX?
1845 CAME 0,MULTI(D) ; OR STRING OR BYTE-STRING
1846 JRST WRONGT ;NEITHER
1847 HRRZ 0,(B) ; GET CHAR COUNT
1853 ; NOW GET THE NECESSARY VECTOR
1855 MAKSTR: HRL C,MULTI(D) ; FINAL TYPE,, CHAR COUNT
1856 PUSH P,C ; SAVE CHAR COUNT
1857 PUSH P,E ; SAVE ARG COUNT
1859 IDIV D,-2(P) ; A==> BYTES PER WORD
1860 MOVEI A,(C) ; LNTH+4 TO A
1866 HRLM E,-2(P) ; SAVE REMAINDER
1870 JUMPGE B,DONEC ; 0 LENGTH, NO STRING
1871 HRLI B,440000 ;CONVERT B TO A BYTE POINTER
1872 HRRZ 0,-1(P) ; BYTE SIZE
1874 MOVE C,(TP) ; POINT TO ARGS AGAIN
1876 NXTRG1: GETYP D,(C) ;GET AN ARG
1881 MOVE D,1(C) ; GET IT
1882 IDPB D,B ;AND DEPOSIT IT
1885 TRYSTR: MOVE E,1(C) ;GET BYTER
1886 HRRZ 0,(C) ;AND COUNT
1887 NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG
1888 ILDB D,E ;AND GET NEXT
1889 IDPB D,B ; AND DEPOSIT SAME
1892 NXTARG: ADD C,C%22 ;BUMP ARG POINTER
1896 DONEC: MOVSI C,TCHRS+.VECT.
1898 HLLM C,(B) ;AND CLOBBER AWAY
1899 HLRZ C,1(B) ;GET LENGTH BACK
1902 HLL B,(P) ;MAKE A BYTE POINTER
1913 ; COMPILER'S CALL TO MAKE A STRING
1917 ; COMPILERS CALL TO MAKE A BYTE STRING
1921 MOVEI C,0 ; INIT CHAR COUNTER
1922 MOVEI B,(A) ; SET UP STACK POINTER
1923 ASH B,1 ; * 2 FOR NO. OF SLOTS
1925 SUBM TP,B ; B POINTS TO ARGS
1929 GETYP 0,1(B) ; CHECK BYTE SIZE
1938 PUSHJ P,IISTRN ; MAKE IT HAPPEN
1939 MOVE TP,(TP) ; FLUSH ARGS
1946 \f;BUILD IMPLICT STRING
1948 MFUNCTION IBYTES,SUBR
1952 CAML AB,C%M20 ; [-3,,] ; AT LEAST 2
1954 CAMGE AB,C%M60 ; [-7,,] ; NO MORE THAN 3
1956 PUSHJ P,GETFIX ; GET BYTE SIZE
1967 MFUNCTION ISTRING,SUBR
1970 JUMPGE AB,TFA ; TOO FEW ARGS
1971 CAMGE AB,C%M40 ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
1976 ISTR1: PUSHJ P,GETFIX
1980 IDIVI A,(C) ; # OF WORDS NEEDED TO A
1982 MOVE C,-1(P) ; GET BYTE SIZE
1986 HLRE C,B ; -LENGTH TO C
1987 SUBM B,C ; LOCN OF DOPE WORD TO C
1988 HRLI D,TCHRS+.VECT. ; CLOBBER ITS TYPE
1991 HRR A,1(AB) ; SETUP TYPE'S RH
1993 HRL B,(P) ; AND BYTE POINTER
1995 SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT
1996 CAML AB,C%M20 ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
1998 PUSH TP,A ;SAVE OUR STRING
2000 PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER
2002 PUSH P,(AB)1 ;SAVE COUNT
2005 CLOBST: PUSH TP,-1(TP)
2008 GETYP C,A ; CHECK IT
2009 CAME C,-1(P) ; MUST BE A CHARACTER
2011 IDPB B,-2(TP) ;CLOBBER
2012 SOSLE (P) ;FINISHED?
2021 ; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
2022 ; PUNT SOME IF THERE ARE.
2029 JSP E,CKPUR ; CHECK FOR PURE RSUBR
2033 MOVE B,RFRETP ; GET REAL FRETOP
2035 MOVE B,A ; TOP OF WORLD
2038 ADDI A,1777 ; PAGE BOUNDARY
2040 CAIL A,(B) ; SEE WHETHER THERE IS ROOM
2049 POP P,C ; RESTORE CAUSE INDICATOR
2051 PUSHJ P,CLEANT ; CLEAN UP
2052 SKIPL PLODR ; IF IN PLOAD DON'T INTERRUPT
2053 JRST INTAGC ; GO CAUSE GARBAGE COLLECT
2061 PUSHJ P,GETPAG ; GET THOSE PAGES
2062 FATAL CAN'T GET PAGES NEEDED
2064 ASH A,-10. ; TO PAGES
2067 CLNT1: PUSHJ P,RBLDM
2072 \f; RCLVEC DISTASTEFUL VECTOR RECYCLER
2074 ; Arrive here with B pointing to first recycler, A desired length
2076 RCLVEC: PUSH P,D ; Save registers
2079 MOVEI D,RCLV ; Point to previous recycle for splice
2080 RCLV1: HLRZ C,(B) ; Get size of this block
2081 CAIL C,(A) ; Skip if too small
2084 RCLV2: MOVEI D,(B) ; Save previous pointer
2085 HRRZ B,(B) ; Point to next block
2086 JUMPN B,RCLV1 ; Jump if more blocks
2091 JRST NORCL ; Go to normal allocator
2094 FOUND1: CAIN C,1(A) ; Exactly 1 greater?
2095 JRST RCLV2 ; Cant use this guy
2097 HRLM A,(B) ; Smash in new count
2098 TLO A,.VECT. ; make vector bit be on
2100 CAIE C,(A) ; Exactly right length?
2101 JRST FOUND2 ; No, do hair
2103 HRRZ C,(B) ; Point to next block
2104 HRRM C,(D) ; Smash previous pointer
2106 SUBI B,-1(A) ; Point to top of block
2109 FOUND2: SUBI C,(A) ; Amount of left over to C
2110 HRRZ E,(B) ; Point to next block
2112 SUBI B,(A) ; Point to dope words of guy to put back
2113 MOVSM C,(B) ; Smash in count
2114 MOVSI C,.VECT. ; Get vector bit
2115 MOVEM C,-1(B) ; Make sure it is a vector
2116 HRRM B,(D) ; Splice him in
2117 HRRM E,(B) ; And the next guy also
2118 ADDI B,1 ; Point to start of vector
2120 FOUND3: HRROI B,(B) ; Make an AOBJN pointer