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
140 ADDM C,GETNUM ; MOVE IN REQUEST
141 MOVE C,[0,,1] ; ARGS TO GC
143 RDGC1: MOVE C,GCSTOP ; GET CURRENT TOP OF THE WORLD
144 MOVEM C,OGCSTP ; SAVE IT
145 ADD C,(P) ; CALCULATE NEW GCSTOP
146 ADDI C,2 ; SUBTRACT FOR CONSTANTS
149 SUBI C,2 ; SUBSTRACT TO GET RID OF D.W'S
150 MOVNS C ; SET UP AOBJN PTR FOR READIN
153 MOVE A,-2(P) ; GET CHANNEL #
156 FATAL GCREAD-- IOT FAILED
159 MOVE A,-2(P) ; CHANNEL TO A
160 MOVE B,OGCSTP ; SET UP BYTE POINTER
165 MOVE C,(P) ; GET LENGHT OF OBJECT
167 MOVE B,1(AB) ; GET CHANNEL
169 MOVE D,GCSTOP ; SET UP TO LOOK LIKE UVECTOR OF LOSES
170 ADDI C,2 ; ADD 2 FOR DOPE WORDS
174 IORM A,-2(D) ; MARK VECTOR BIT
175 PUSH TP,$TRDTB ; HOLD ON IN CASE OF GC
182 MOVE D,-1(P) ; SET UP BOTTOM OF ATOM TABLE
185 MOVE C,GCSTOP ; START AT TOP OF WORLD
186 SUBI C,3 ; POINT TO FIRST ATOM
188 ; LOOP TO FIX UP THE ATOMS
192 CAMG C,0 ; SEE IF WE ARE DONE
196 PUSHJ P,ATFXU ; FIX IT UP
197 HLRZ A,(C) ; GET LENGTH
198 TRZ A,400000 ; TURN OFF MARK BIT
199 SUBI C,(A) ; POINT TO PRECEDING ATOM
200 HRRZS C ; CLEAR OFF NEGATIVE
203 ; FIXUP ROUTINE FOR ATOMS (C==> D.W.)
205 ATFXU: PUSH P,C ; SAVE PTR TO D.W.
208 HLRZ B,(A) ; GET LENGTH AND MARKING
209 TRZE B,400000 ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED
211 MOVEI D,-3(B) ; FULL WORDS OF STRING IN PNAME
212 IMULI D,5 ; CALCULATE # OF CHARACTERS
213 MOVE 0,-2(A) ; GET LAST WORD OF STRING
214 SUBI A,-1(B) ; LET A POINT TO OBLIST SLOAT
215 MOVE B,A ; GET COPY OF A
221 IDIVI 0,7 ; # OF CHARS IN LAST WORD
223 ADD D,$TCHSTR ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD
225 MOVE C,(B) ; GET OBLIST SLOT PTR
226 ATFXU9: HRRZS B ; RELATAVIZE POINTER
230 JUMPE C,ATFXU6 ; NO OBLIST. CREATE ATOM
231 CAMN C,C%M1 ; SEE IF ROOT ATOM
233 ADD C,ABOTN ; POINT TO ATOM
237 MOVE A,$TATOM ; SET UP TO SEE IF OBLIST EXITS
239 MOVE D,IMQUOTE OBLIST
241 JRST ATFXU8 ; NO OBLIST. CREATE ONE
242 SUB TP,C%22 ; GET RID OF SAVED ATOM
243 RTCON: PUSH TP,$TOBLS
245 MOVE C,B ; SET UP FOR LOOKUP
246 MOVE A,-1(P) ; SET UP PTR TO PNAME
248 ADD B,[440700,,1] ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER
252 JRST ATFXU4 ; NOT ON IT SO INSERT
253 ATFXU3: SUB P,C%22 ; DONE
254 SUB TP,C%22 ; POP OFF OBLIST
255 ATFXU7: MOVE C,(P) ; RESTORE PTR TO D.W.
257 MOVEM B,-1(C) ; MOVE IN RELATAVIZE ADDRESS
259 IORM D,(C) ; TURN OFF MARK BIT
260 MOVE 0,3(B) ; SEE IF MUST BE LOCR
261 TRNE 0,1 ; SKIP IF MUST MAKE IT IMPURE
266 ATFXU1: POP P,C ; RESTORE PTR TO D.W.
268 MOVE B,-1(C) ; GET ATOM
271 ; ROUTINE TO INSERT AN ATOM
273 ATFXU4: MOVE C,(TP) ; GET OBLIST PTR
274 MOVE B,(P) ; SET UP STRING PTR TO PNAME
278 MOVE A,-1(P) ; GET TYPE WORD
279 PUSHJ P,CINSER ; INSERT IT
282 ; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST
284 ATFXU6: MOVE B,(P) ; POINT TO PNAME
285 ADD B,[440700,,1] ; MAKE IT LOOK LIKE A BYTE POINTER
290 SUB P,C%22 ; CLEAN OFF STACK
293 ; THIS ROUTINE CREATES AND OBLIST
295 ATFXU8: MCALL 1,MOBLIST
297 PUSH TP,B ; SAVE OBLIST PTR
298 JRST ATFXU4 ; JUMP TO INSERT THE OBLIST
300 ; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST
302 RTFX: MOVE B,ROOT+1 ; GET ROOT OBLIST
305 ; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS.
308 ; ROUTINE TO FIX UP TYPE-TABLE FOR GC-READ. THIS ROUTINE FIXES UP THE TYPE TABLE SO THAT
309 ; THE TYPES ATOM I.D. IS REPLACED BY ITS TYPE-NUMBER IN THE NEW MUDDLE AND IF ITS A
310 ; TEMPLATE, THE SLOT FOR THE PRIMTYPE-ATOM IS REPLACED BY THE SAT OF THE TEMPLATE
312 HRRZ E,1(TB) ; SET UP TYPE TABLE
314 JUMPGE E,VUP ; SKIP OVER IF DONE
315 TYPUP1: PUSH P,C%0 ; PUSH SLOT FOR POSSIBLE TEMPLATE ATOM
316 HLRZ A,1(E) ; GET POSSIBLE ATOM SLOT
317 JUMPE A,TYPUP2 ; JUMP IF NOT A TEMPLATE
318 ADD A,ABOTN ; GET ATOM
321 MOVE B,TYPVEC+1 ; GET TYPE VECTOR SLOT FOR LOOP TO SEE IF ITS THERE
322 TYPUP3: CAMN A,1(B) ; SKIP IF NOT EQUAL
323 JRST TYPUP4 ; FOUND ONE
326 JRST ERTYP1 ; ERROR NONE EXISTS
327 TYPUP4: HRRZ C,(B) ; GET SAT SLOT
328 CAIG C,NUMSAT ; MAKE SURE TYPE IS A TEMPLATE
329 JRST ERTYP2 ; IF NOT COMPLAIN
330 HRLM C,1(E) ; SMASH IN NEW SAT
331 MOVE B,1(B) ; GET ATOM OF PRIMTYPE
332 MOVEM B,(P) ; PUSH ONTO STACK
333 TYPUP2: MOVEI D,0 ; INITIALIZE TYPE COUNT FOR LOOKUP LOOP
334 MOVE B,TYPVEC+1 ; GET PTR FOR LOOP
335 HRRZ A,1(E) ; GET TYPE'S ATOM ID
336 ADD A,ABOTN ; GET ATOM
339 TYPUP5: CAMN A,1(B) ; SKIP IF NOT EQUAL
340 JRST TYPUP6 ; FOUND ONE
341 ADDI D,1 ; INCREMENT TYPE-COUNT
342 ADD B,C%22 ; POINT TO NEXT
344 HRRM D,1(E) ; CLOBBER IN TYPE-NUMBER
345 PUSH TP,$TATOM ; PUSH ARGS FOR NEWTYPE
348 POP P,B ; GET BACK POSSIBLE PRIMTYPE ATOM
349 JUMPE B,TYPUP7 ; JUMP IF NOT A TEMPLATE
350 PUSH TP,B ; PUSH ON PRIMTYPE
352 PUSH P,E ; SAVE RELATAVIZED PTR TO TYPE-TABLE
354 POP P,E ; RESTORE RELATAVIZED PTR
355 ADD E,1(TB) ; FIX IT UP
356 TYPUP0: ADD E,C%22 ; INCREMENT E
359 TYPUP7: HRRZ B,(E) ; FIND PRIMTYPE FROM SAT
363 TYPUP6: HRRM D,1(E) ; CLOBBER IN TYPE #
366 ERTYP1: ERRUUO EQUOTE CANT-FIND-TEMPLATE
368 ERTYP2: ERRUUO EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE
370 VUP: HRRZ E,1(TB) ; FIX UP SOME POINTERS
376 ; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES.
377 ; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY.
379 HRRZ A,TYPTAB ; GET TO TOP OF WORLD
380 SUBI A,2 ; GET TO FIRST TYPE WORD OR DOPE-WORD OF FIRST OBJECT
381 VUP1: CAMG A,OGCSTP ; SKIP IF NOT DONE
383 HLRZ B,(A) ; GET TYPE SLOT
384 TRNE B,.VECT. ; SKIP IF NOT A VECTOR
386 SUBI A,2 ; SKIP OVER PAIR
388 VUP2: TRNE B,400000 ; SKIP IF UVECTOR
390 ANDI B,TYPMSK ; GET RID OF MONITORS
391 CAMG B,NNPRI ; SKIP IF NEWTYPE
393 PUSHJ P,GETNTP ; GET THE NEW TYPE #
394 PUTYP B,(A) ; SMASH IT IT
395 VUP5: HLRZ B,1(A) ; SKIP OVER VECTOR
396 TRZ B,400000 ; GET RID OF POSSIBLE MARK BIT
399 VUP4: ANDI B,TYPMSK ; FLUSH MONITORS
400 CAMG B,NNSAT ; SKIP IF TEMPLATE
402 PUSHJ P,GETSAT ; CONVERT TO NEW SAT
403 ADDI B,.VECT. ; MAJIC TO TURN ON BIT
408 VUP3: PUSH P,GCSBOT ; SAVE CURRENT GCSBOT
409 MOVE A,OGCSTP ; SET UP NEW GCSBOT
412 HRRZ A,TYPTAB ; SET UP NEW GCSTOP
415 MOVE A,[PUSHJ P,RDFIX] ; INS FOR GCHACK
416 MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
419 POP P,GCSTOP ; RESTORE GCSTOP
420 MOVE A,1(TB) ; GET A POINTER TO RETURNING VALUES
426 POP P,GCSBOT ; RESTORE GCSBOT
427 MOVE B,1(A) ; GET PTR TO OBJECTS
431 ; ERROR FOR INCORRECT GCREAD FILE
433 ERDGC: ERRUUO EQUOTE BAD-GC-READ-FILE
435 ; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE
437 RDFIX: PUSH P,C ; SAVE C
440 TLNE C,UBIT ; SKIP IF NOT UVECTOR
441 JRST ELEFX ; DON'T HACK TYPES IN UVECTOR
448 ELEFX: EXCH B,A ; EXCHANGE FOR SAT
453 CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS
458 CAIN B,S1WORD ; SEE IF PRIMTYPE WOR
459 JRST RDLSTF ; LEAVE IF IS
460 STFXX: MOVE 0,GCSBOT ; ADJUSTMENT
462 SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL
464 RDLSTF: TLNN C,.LIST. ; SEE IF PAIR
466 MOVE 0,GCSBOT ; FIX UP
468 HRRZ B,(C) ; SEE IF POINTS TO NIL
471 MOVE B,C ; GET ARG FOR RLISTQ
475 RDL1: POP P,B ; RESTORE B
481 OFSFIX: HLRZ B,1(A) ; SEE IF PNTR TO FIXUP
483 MOVE 0,GCSBOT ; GET UPDATE AMOUNT
486 ADDM 0,1(A) ; FIX POINTER
489 ; ROUTINE TO FIX UP PNAMES
493 HLLM D,1(C) ; PUT BACK WITH BIT OFF
496 HLRE 0,-1(D) ; LENGTH OF ATOM
498 SUBI 0,3 ; VAL & OBLIST
499 IMULI 0,5 ; TO CHARS (SORT OF)
504 LDB A,[360600,,1(C)] ; GET BYTE POS
505 IDIVI A,7 ; TO CHAR POS
508 HRRZ B,(C) ; STRING LENGTH
509 SUB B,A ; TO WORD BOUNDARY STRING
518 ; ROUTINE TO FIX UP POINTERS TO ATOMS
523 MOVE 0,-1(D) ; GET PTR TO ATOM
524 CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR
540 ATFXAT: MOVEM 0,1(C) ; SMASH IT IN
543 TYPCFX: HRRZ B,1(C) ; GET TYPE
544 PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
545 HRRM B,1(C) ; CLOBBER IT IN
546 JRST RDLSTF ; CONTINUE FIXUP
548 TYPWFX: HLRZ B,1(C) ; GET TYPE
549 PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
550 HRLM B,1(C) ; SMASH IT IN
554 PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE
559 ; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
560 ; EOF HANDLER ELSE USES CHANNELS.
562 EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B
563 CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED
564 JRST MYCLOS ; USE CHANNELS
568 MYCLOS: PUSH TP,EOFCND-1(B)
570 CLOSIT: PUSH TP,$TCHAN
572 MCALL 1,FCLOSE ; CLOSE CHANNEL
573 MCALL 1,EVAL ; EVAL HIS EOF HANDLER
576 ; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
578 GETNEW: CAMG B,NNPRI ;NEWTYPE
580 GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE
581 GETNT1: HLRZ E,(D) ; GET TYPE #
582 CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
583 JRST GOTTYP ; FOUND IT
584 ADD D,C%22 ; POINT TO NEXT
586 SKIPA ; KEEP TYPE SAME
587 GOTTYP: HRRZ B,1(D) ; GET NEW TYPE #
590 ; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
592 GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE
593 GETSA1: HRRZ E,(D) ; GET OBJECT
594 CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
595 JRST GOTSAT ; FOUND IT
598 FATAL GC-DUMP -- TYPE FIXUP FAILURE
599 GOTSAT: HLRZ B,1(D) ; GET NEW SAT
603 ; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
605 GETYP A,(B) ; GET TYPE
606 PUSHJ P,SAT ; GET SAT
607 CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
609 AOS -1(P) ; SKIP IF NOT DEFFERED
616 MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
620 JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT
622 CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR
623 JRST WTYP1 ; IF NOT COMPLAIN
626 CAIE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
628 CAMGE AB,C%M20 ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
630 MOVE A,(AB) ; GET THE UVECTOR
632 JRST SETUV ; CONTINUE
633 GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR
635 SETUV: PUSH P,A ; SAVE UVECTOR
637 MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
641 PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
642 HLRE 0,TP ; COMPUTE STACK SPACE USED UP
646 MOVE B,IMQUOTE THIS-PROCESS
650 HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
652 HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS
656 SUB B,C ; TOTAL WORDS ATOM STORAGE
657 IDIVI B,6 ; COMPUTE # OF SLOTS
659 HRRZ A,GLOBASE+1 ; COMPUTE TOTAL # OF GLOBAL SLOTS
661 SUB A,0 ; POINT TO DOPE WORD
663 ASH B,-2 ; # OF GVAL SLOTS
665 HRRZ A,GLOTOP+1 ; COMPUTE # OF GVAL SLOTS IN USE
668 ASH A,-2 ; NEGATIVE # OF SLOTS USED
670 HRRZ A,TYPBOT+1 ; GET LENGTH OF TYPE VECTOR
673 HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR
674 IDIVI B,2 ; CONVERT TO # OF TYPES
676 HLRE 0,TYPVEC+1 ; LENGTH OF VISABLE TYPE-VECTOR
678 IDIVI 0,2 ; GET # OF TYPES
680 MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE
682 SETZB B,D ; ZERO OUT MAXIMUM
684 LOOPC: HLRZ 0,(C) ; GET BLK LENGTH
685 ADD D,0 ; ADD # OF WORDS IN BLOCK
686 CAMGE B,0 ; SEE IF NEW MAXIMUM
688 HRRZ C,(C) ; POINT TO NEXT BLOCK
689 JUMPN C,LOOPC ; REPEAT
692 HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P
696 MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES
697 HRRZ B,(P) ; RESTORE B
700 HRLI C,BSTAT ; MODIFY BLT FOR STATS
702 BLT C,(B)STATGC+STATNO-1
704 HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE
706 POP P,A ; RESTORE TYPE-WORD
709 GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST
710 MOVE 0,[GCNO,,GCNO+1]
717 .GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
719 ; USER GARBAGE COLLECTOR INTERFACE
726 CAMGE AB,C%M60 ; [-6,,0]
728 PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN
729 SKIPE A ; SKIP FOR 0 ARGUMENT
731 GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE
733 CAML AB,C%M40 ; [-4,,0] ; SEE IF 3RD ARG
735 GETYP A,4(AB) ; MAKE SURE A FIX
737 JRST WTYP ; ARG WRONG TYPE
741 GC5: CAML AB,C%M20 ; [-2,,0] ; SEE IF SECOND ARG
743 GETYP A,2(AB) ; SEE IF NONFALSE
744 CAIE A,TFALSE ; SKIP IF FALSE
745 JRST HAIRGC ; CAUSE A HAIRY GC
746 GC3: MOVSI A,TATOM ; CHECK TO SEE IF INTERRUPT FLAG IS ON
747 MOVE B,IMQUOTE AGC-FLAG
749 CAMN A,$TUNBOUND ; SKIP IF NOT UNBOUND
751 SKIPE GCHPN ; SKIP IF GCHAPPEN IS 0
752 JRST FALRTN ; JUMP TO RETURN FALSE
754 PUSHJ P,AGC ; COLLECT THAT TRASH
755 PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?
756 POP P,B ; RETURN AMOUNT
761 CAIN A,TFIX ; IF FIX THEN CLOBBER NGCS
763 MOVEI A,1 ; FORCE VALUE FLUSHING PHASE TO OCCUR
765 JRST GC2 ; HAIRY GC OCCORS NO MATTER WHAT
766 FALRTN: MOVE A,$TFALSE
767 MOVEI B,0 ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR
771 COMPRM: MOVE A,GCSTOP ; USED SPACE
776 MFUNCTION GCDMON,SUBR,[GC-MON]
782 FLGSET: MOVE C,(E) ; GET CURRENT VALUE
783 JUMPGE AB,RETFLG ; RET CURRENT
784 CAMGE AB,C%M20 ; [-3,,]
804 .GLOBAL EVATYP,APLTYP,PRNTYP
806 \fMFUNCTION BLOAT,SUBR
810 MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC
811 MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE
813 BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?
814 PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM
816 PUSHJ P,@BLOATER(E) ; DISPATCH
817 AOBJN E,BLOAT2 ; COUNT PARAMS SET
819 JUMPL AB,TMA ; ANY LEFT...ERROR
820 BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED
821 MOVE C,E ; MOVE IN INDICATOR
822 HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT
825 SKIPE A,TPBINC ; SMASH POINNTERS
828 SKIPE A,GLBINC ; GLOBAL SP
832 SETZM TPBINC ; RESET PARAMS
836 BLOATD: SKIPN A,GETNUM ; SKIP IF FREE STORAGE REQUEST IN EFFECT
838 ADD A,FRETOP ; ADD FRETOP
839 ADDI A,1777 ; ONE BLOCK FOR MARK PDL AND ROUND
840 ANDCMI A,1777 ; TO PAGE BOUNDRY
841 CAML A,PURBOT ; SKIP IF POSSIBLE TO WIN
843 ASH A,-10. ; TO PAGES
844 PUSHJ P,P.CORE ; GRET THE CORE
845 JRST BLFAGC ; LOSE LOSE LOSE
846 MOVE A,FRETOP ; CALCULATE NEW PARAMETERS
853 BLT B,-1(A) ; ZERO CORE
857 MOVSI A,TFIX ; RETURN CORE FOUND
859 BLFAGC: MOVN A,FREMIN
860 ADDM A,GETNUM ; FIX UP SO BLOATS CORRECTLY
861 MOVE C,C%11 ; INDICATOR FOR AGC
862 PUSHJ P,AGC ; GARBAGE COLLECT
865 ; TABLE OF BLOAT ROUTINES
885 ; BLOAT MAIN STORAGE AREA
888 MOVE D,FRETOP ; COMPUTE CURRENT ROOM
890 CAMGE A,D ; NEED MORE?
893 MOVEM A,GETNUM ; SAVE
896 ; BLOAT TP STACK (AT TOP)
898 TPBLO: HLRE D,TP ; GET -SIZE
900 ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
901 CAME D,TPGROW ; BLOWN?
902 ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
903 SUB A,B ; SKIP IF GROWTH NEEDED
906 ASH A,-6 ; CONVERT TO 64 WD BLOCKS
909 DPB A,[111100,,-1(D)] ; SMASH SPECS IN
912 ; BLOAT TOP LEVEL LOCALS
914 LOBLO: HLRE D,TP ; GET -SIZE
916 ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
917 CAME D,TPGROW ; BLOWN?
918 ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
919 CAMG A,B ; SKIP IF GROWTH NEEDED
920 IMULI A,6 ; 6 WORDS PER BINDING
923 HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E
925 SUBI A,(B) ; HOW MUCH MORE?
926 JUMPLE A,CPOPJ ; NONE NEEDED
929 DPB A,[1100,,-1(D)] ; SMASH
934 GLBLO: ASH A,2 ; 4 WORDS PER VAR
935 MOVE D,GLOBASE+1 ; CURRENT LIMITS
938 SUBI A,(B) ; NEW AMOUNT NEEDED
940 MOVEI B,GLBINC ; WHERE TO KEEP UPDATE
941 PUSHJ P,NUMADJ ; FIX NUMBER
943 SUB D,0 ; POINT TO DOPE
944 DPB A,[1100,,(D)] ; AND SMASH
947 ; HERE TO GROW TYPE VECTOR (AND FRIENDS)
949 TYBLO: ASH A,1 ; TWO WORD PER TYPE
950 HRRZ B,TYPVEC+1 ; FIND CURRENT ROOM
953 SUBI A,(B) ; EXTRA NEEDED TO A
954 JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE
955 MOVEI B,TYPINC ; WHERE TO STASH SPEC
956 PUSHJ P,NUMADJ ; FIX NUMBER
957 HLRE 0,D ; POINT TO DOPE
960 SKIPE D,EVATYP+1 ; GROW AUX TYPE VECS IF NEEDED
968 ; HERE TO CREATE STORAGE SPACE
970 STBLO: MOVE D,GCSBOT ; HOW MUCH NOW HERE
972 SUBI A,(D) ; MORE NEEDED?
974 MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT
981 SUBI D,5 ; FUDGE FOR THIS CALL
984 ADDI B,1(P) ; POINT TO DOPE
985 CAME B,PGROW ; BLOWN?
986 ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.
988 ASH A,-6 ; TO 64 WRD BLOCKS
989 CAILE A,377 ; IN RANGE?
991 DPB A,[111100,,-1(B)]
996 SFREM: SKIPE A ; DON'T ZERO EMPTY PARAMETER
1000 ; SET LVAL INCREMENT
1002 SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B
1008 ; SET GVAL INCREMENT
1010 SGVL: IMULI A,4. ; # OF SLOTS
1016 ; SET TYPE INCREMENT
1018 STYP: IMULI A,2 ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
1024 ; SET STORAGE INCREMENT
1026 SSTO: IDIVI A,2000 ; # OF BLOCKS
1027 CAIE B,0 ; REMAINDER?
1029 IMULI A,2000 ; CONVERT BACK TO WORDS
1032 ; HERE FOR MINIMUM PURE SPACE
1035 ANDCMI A,1777 ; TO PAGE BOUNDRY
1039 ; HERE TO ADJUST PSTACK PARAMETERS IN GC
1041 PMUNG: ADDI A,777 ; TO NEAREST 1000 WORD BOUNDRY
1043 MOVEM A,PGOOD ; PGOOD
1044 ASH A,2 ; PMAX IS 4*PGOOD
1046 ASH A,-4 ; PMIN IS .25*PGOOD
1049 ; HERE TO ADJUST GC TPSTACK PARAMS
1052 ANDCMI A,777 ; TO NEAREST 1000 WORD BOUNDRY
1054 ASH A,2 ; TPMAX= 4*TPGOOD
1056 ASH A,-4 ; TPMIN= .25*TPGOOD
1060 ; GET NEXT (FIX) ARG
1062 NXTFIX: PUSHJ P,GETFIX
1066 ; ROUTINE TO GET POS FIXED ARG
1068 GETFIX: GETYP A,(AB)
1076 ; GET NUMBERS FIXED UP FOR GROWTH FIELDS
1078 NUMADJ: ADDI A,77 ; ROUND UP
1079 ANDCMI A,77 ; KILL CRAP
1081 MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
1083 MOVEM A,(B) ; AND STASH IT
1085 ASH A,-6 ; TO 64 WD BLOCKS
1086 CAILE A,377 ; CHECK FIT
1090 ; DO SYMPATHETIC GROWTHS
1097 \f;FUNCTION TO CONSTRUCT A LIST
1102 GETYP A,2(AB) ;GET TYPE OF 2ND ARG
1104 JRST WTYP2 ;NO , COMPLAIN
1105 MOVE C,(AB) ; GET THING TO CONS IN
1107 HRRZ E,3(AB) ; AND LIST
1108 PUSHJ P,ICONS ; INTERNAL CONS
1111 ; COMPILER CALL TO CONS
1113 C1CONS: PUSHJ P,ICELL2
1116 ICONS3: MOVEM C,(B) ; AND STORE
1118 TLPOPJ: MOVSI A,TLIST
1121 ; INTERNAL CONS--ICONS; C,D VALUE, E CDR
1123 ; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE
1124 ; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED
1125 ; TO: DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS.
1131 ; INTERNAL CONS TO NIL--INCONS
1135 ICONS: GETYP A,C ; CHECK TYPE OF VAL
1136 PUSHJ P,NWORDT ; # OF WORDS
1137 SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED
1138 PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
1139 JRST ICNS2A ; NO CORE, GO GC (SPECIAL PLACE, NOTICE)
1142 ; HERE IF CONSING DEFERRED
1144 ICONS1: MOVEI A,4 ; NEED 4 WORDS
1145 PUSHJ P,ICELL ; GO GET 'EM
1146 JRST ICNS2A ; NOT THERE, GC (SAME PLACE AS FOR ICONS)
1147 HRLI E,TDEFER ; CDR AND DEFER
1149 MOVEI E,2(B) ; POINT E TO VAL CELL
1151 MOVEM C,(E) ; STORE VALUE
1157 ; HERE TO GC ON A CONS
1165 ; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
1166 ICNS2A: PUSHJ P,ICONSG
1170 ICONSG: PUSH TP,C ; SAVE VAL
1173 PUSH TP,E ; SAVE VITAL STUFF
1174 ADDM A,GETNUM ; AMOUNT NEEDED
1175 MOVE C,[3,,1] ; INDICATOR FOR AGC
1176 PUSHJ P,INQAGC ; ATTEMPT TO WIN
1177 MOVE D,-2(TP) ; RESTORE VOLATILE STUFF
1180 SUB TP,C%44 ; [4,,4]
1181 POPJ P, ; BACK TO DRAWING BOARD
1183 ; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED
1185 CELL2: MOVEI A,2 ; USUAL CASE
1186 CELL: PUSHJ P,ICELL ; INTERNAL
1190 ADDM A,GETNUM ; AMOUNT REQUIRED
1191 PUSH P,A ; PREVENT AGC DESTRUCTION
1192 MOVE C,[3,,1] ; INDICATOR FOR AGC
1195 JRST CELL ; AND TRY AGAIN
1197 ; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
1199 ICELL2: MOVEI A,2 ; MOST LIKELY CAE
1201 JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL
1202 MOVE B,PARTOP ; GET TOP OF PAIRS
1204 CAMLE B,FRETOP ; SKIP IF OK.
1206 EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER
1208 JRST CPOPJ1 ; SKIP RETURN
1210 ; TRY RECYCLING USING A VECTOR FROM RCLV
1212 VECTRY: SKIPN B,RCLV ; SKIP IF VECTOR EXISTS
1217 VECTR1: HLRZ A,(B) ; GET LENGTH
1219 JUMPL A,NXTVEC ; DOESN'T SATISFY TRY AGAIN
1220 CAIN A,1 ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
1222 JUMPN A,SOML ; SOME ARE LEFT
1227 SETZM -1(B) ; CLEAR DOPE WORDS
1229 POP P,A ; CLEAR STACK
1232 SOML: HRLM A,(B) ; SMASH AMOUNT LEFT
1233 SUBI B,-1(A) ; GET TO BEGINNING
1239 HRRZ B,(B) ; GET NEXT
1246 JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD
1251 SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL
1253 JRST CPOPJ1 ;THAT IT
1256 \f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
1258 IMFUNCTION LIST,SUBR
1262 LIST12: HLRE A,AB ;GET -NUM OF ARGS
1266 JUMPE A,LISTN ;JUMP IF 0
1267 SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME
1268 JRST LST12R ;TO GET RECYCLED CELLS
1269 PUSHJ P,CELL ;GET NUMBER OF CELLS
1270 PUSH TP,(P) ;SAVE IT
1273 LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS
1275 CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS
1276 HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE
1277 SOJG A,.-2 ;LOOP TIL ALL DONE
1278 CLEARM B,-2(B) ;SET THE LAST CDR TO NIL
1280 ; NOW LOBEER THE DATA IN TO THE LIST
1282 MOVE D,AB ; COPY OF ARG POINTER
1283 MOVE B,(TP) ;RESTORE LIS POINTER
1284 LISTLP: GETYP A,(D) ;GET TYPE
1285 PUSHJ P,NWORDT ;GET NUMBER OF WORDS
1286 SOJN A,LDEFER ;NEED TO DEFER POINTER
1287 GETYP A,(D) ;NOW CLOBBER ELEMENTS
1289 MOVE A,1(D) ;AND VALUE..
1291 LISTL2: HRRZ B,(B) ;REST B
1292 ADD D,C%22 ;STEP ARGS
1297 SUB TP,C%22 ; CLEANUP STACK
1301 LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS
1303 PUSH P,A ;SAVE COUNT ON STACK
1307 MOVE E,B ;LOOP AND CHAIN TOGETHER
1310 PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT
1312 SUB P,C%22 ;CLEAN UP AFTER OURSELVES
1313 JRST LISTLP-2 ;AND REJOIN MAIN STREAM
1316 ; MAKE A DEFERRED POINTER
1318 LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER
1320 MOVEM D,1(TB) ; SAVE ARG HACKER
1323 GETYPF A,(D) ;GET FULL DATA
1327 MOVE C,(TP) ;RESTORE LIST POINTER
1328 MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE
1330 HLLM A,(C) ;AND STORE IT
1341 IMFUNCTION FORM,SUBR
1348 \f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
1360 IILST: JUMPE A,IILST0 ; NIL WHATSIT
1365 PUSHJ P,ICONS ; CONS 'EM UP
1376 \f;FUNCTION TO BUILD AN IMPLICIT LIST
1378 MFUNCTION ILIST,SUBR
1381 ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG
1382 CAMGE AB,C%M40 ; [-4,,0] ; NO MORE THAN TWO ARGS
1384 PUSHJ P,GETFIX ; GET POS FIX #
1385 JUMPE A,LISTN ;EMPTY LIST ?
1386 CAML AB,C%M20 ; [-2,,0] ;ONLY ONE ARG?
1388 PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
1389 ILIST0: PUSH TP,2(AB)
1397 ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH
1399 ILIST3: POP P,A ; GET FINAL TYPE
1403 LOSEL: PUSH P,A ; SAVE COUNT
1406 LOSEL1: SETZB C,D ; TLOSE,,0
1417 MFUNCTION IFORM,SUBR
1423 \f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
1425 MFUNCTION VECTOR,SUBR,[IVECTOR]
1430 MFUNCTION UVECTOR,SUBR,[IUVECTOR]
1434 JUMPGE AB,TFA ; AT LEAST ONE ARG
1435 CAMGE AB,C%M40 ; [-4,,0] ; NOT MORE THAN 2
1437 PUSHJ P,GETFIX ; GET A POS FIXED NUMBER
1438 LSH A,(C) ; A-> NUMBER OF WORDS
1439 PUSH P,C ; SAVE FOR LATER
1440 PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)
1443 SUBM B,A ; FIND DOPE WORD
1444 MOVSI D,.VECT. ; FOR GCHACK
1447 MOVSI D,400000 ; GET NOT UNIFORM BIT
1448 IORM D,(A) ; INTO DOPE WORD
1449 SKIPA A,$TVEC ; GET TYPE
1450 VECTO4: MOVSI A,TUVEC
1451 CAML AB,C%M20 ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
1453 JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE
1455 PUSH TP,A ; SAVE THE VECTOR
1461 JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE
1462 INLP: PUSHJ P,IEVAL ; EVAL EXPR
1465 ADD C,C%22 ; BUMP VECTOR
1467 JUMPL C,INLP ; IF MORE DO IT
1469 GETVEC: MOVE A,-3(TP)
1471 SUB TP,C%44 ; [4,,4]
1474 ; HERE TO FILL UP A UVECTOR
1476 UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE
1477 GETYP A,A ; GET TYPE
1478 PUSH P,A ; SAVE TYPE
1479 PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED
1480 SOJN A,CANTUN ; COMPLAIN
1481 STJOIN: MOVE C,(TP) ; RESTORE POINTER
1482 ADD C,1(AB) ; POINT TO DOPE WORD
1483 MOVE A,(P) ; GET TYPE
1484 HRLZM A,(C) ; STORE IN D.W.
1485 MOVSI D,.VECT. ; FOR GCHACK
1487 MOVE C,(TP) ; GET BACK VECTOR
1489 JRST UINLP1 ; START FILLING UV
1492 UINLP: MOVEM C,(TP) ; SAVE PNTR
1493 PUSHJ P,IEVAL ; EVAL THE EXPR
1494 GETYP A,A ; GET EVALED TYPE
1495 CAIE A,@(P) ; WINNER?
1496 JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE
1497 UINLP1: MOVEM B,(C) ; STORE
1500 JRST GETVEC ; AND RETURN VECTOR
1502 IEVAL: PUSH TP,2(AB)
1508 ; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
1510 MFUNCTION ISTORAGE,SUBR
1513 CAMGE AB,C%M40 ; [-4,,0] ; AT LEAST ONE ARG
1515 PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG
1516 PUSHJ P,CAFRE ; GET CORE
1517 MOVN B,1(AB) ; -COUNT
1518 HRL A,B ; PUT IN LHW (A)
1520 HRLI B,2(B) ; LENGTH + 2
1521 ADDI B,(A) ; MAKE POINTER TO DOPE WORDS
1522 HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE
1523 HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
1526 CAML AB,C%M20 ; [-2,,0] ; SECOND ARG TO EVAL?
1527 JRST FINIS ; IF NOT, RETURN EMPTY
1532 PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE
1534 PUSH P,A ; FOR COMPARISON LATER
1537 JRST STJOIN ;TREAT LIKE A UVECTOR
1538 ; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
1539 PUSHJ P,FREESV ; FREE STORAGE VECTOR
1540 ERRUUO EQUOTE DATA-CANT-GO-IN-STORAGE
1542 ; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
1543 FREESV: MOVE A,1(AB) ; GET COUNT
1545 HRRZ B,(TP) ; GET ADDRESS
1546 PUSHJ P,CAFRET ; FREE THE CORE
1550 ; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
1552 IBLOK1: ASH A,1 ; TIMES 2
1553 GIBLOK: TLOA A,400000 ; FUNNY BIT
1554 IBLOCK: TLZ A,400000 ; NO BIT ON
1555 TLO A,.VECT. ; TURN ON BIT FOR GCHACK
1556 ADDI A,2 ; COMPENSATE FOR DOPE WORDS
1557 IBLOK2: SKIPE B,RCLV ; ANY TO RECYCLE?
1559 NORCL: MOVE B,GCSTOP ; POINT TO BOTTOM OF SPACE
1560 PUSH P,B ; SAVE TO BUILD PTR
1561 ADDI B,(A) ; ADD NEEDED AMOUNT
1562 CAML B,FRETOP ; SKIP IF NO GC NEEDED
1564 MOVEM B,GCSTOP ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
1567 HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD
1568 HLLZM A,-2(B) ; AND BIT
1569 HRRM B,-1(B) ; SMASH IN RELOCATION
1571 POP P,B ; RESTORE PTR TO BOTTOM OF VECTOR
1572 HRROS B ; POINT TO START OF VECTOR
1573 TLC B,-3(A) ; SETUP COUNT
1580 ; HERE TO DO A GC ON A VECTOR ALLOCATION
1583 PUSH P,A ; SAVE DESIRED LENGTH
1585 ADDM 0,GETNUM ; AND STORE AS DESIRED AMOUNT
1586 MOVE C,[4,,1] ; GET INDICATOR FOR AGC
1594 ; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
1595 ; ITEMS ON TOP OF STACK
1597 IEVECT: ASH A,1 ; TO NUMBER OF WORDS
1599 PUSHJ P,IBLOCK ; GET VECTOR
1601 SUBM B,D ; A POINTS TO DW
1602 MOVSI 0,400000+.VECT.
1603 MOVEM 0,(D) ; CLOBBER NON UNIF BIT
1604 POP P,A ; RESTORE COUNT
1605 JUMPE A,IVEC1 ; 0 LNTH, DONE
1606 MOVEI C,(TP) ; BUILD BLT
1607 SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK
1609 HRRI C,(B) ; B/ SOURCE,,DEST
1610 BLT C,-1(D) ; XFER THE DATA
1612 SUB TP,A ; FLUSH STACKAGE
1624 \f; INTERNAL CALL TO EUVECTOR
1626 IEUVEC: PUSH P,A ; SAVE LENGTH
1629 JUMPE A,IEUVE1 ; EMPTY, LEAVE
1630 ASH A,1 ; NOW FIND STACK POSITION
1631 MOVEI C,(TP) ; POINT TO TOP
1632 MOVE D,B ; COPY VEC POINTER
1633 SUBI C,-1(A) ; POINT TO 1ST DATUM
1634 GETYP A,(C) ; CHECK IT
1636 SOJN A,CANTUN ; WONT FIT
1639 IEUVE2: GETYP 0,(C) ; TYPE OF EL
1643 MOVEM 0,(D) ; CLOBBER
1645 AOBJN D,IEUVE2 ; LOOP
1647 HRLZM E,(D) ; STORE UTYPE
1648 IEUVE1: POP P,A ; GET COUNY
1649 ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS
1651 SUB TP,A ; CLEAN UP STACK
1661 IMFUNCTION EVECTOR,SUBR,[VECTOR]
1665 PUSH P,A ;SAVE NUMBER OF WORDS
1666 PUSHJ P,IBLOCK ; GET WORDS
1667 MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER
1668 JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR
1670 HRLI C,(AB) ;START BUILDING BLT POINTER
1671 HRRI C,(B) ;TO ADDRESS
1672 ADDI D,@(P) ;SET D TO FINAL ADDRESS
1674 FINISV: MOVSI 0,400000+.VECT.
1675 MOVEM 0,1(D) ; MARK AS GENERAL
1682 \f;EXPLICIT VECTORS FOR THE UNIFORM CSE
1684 IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
1687 HLRE A,AB ;-NUM OF ARGS
1689 ASH A,-1 ;NEED HALF AS MANY WORDS
1691 JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY
1692 GETYP A,(AB) ;GET FIRST ARG
1693 PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS
1696 PUSHJ P,IBLOCK ; GET VECT
1699 GETYP C,(AB) ;GET THE FIRST TYPE
1700 MOVE D,AB ;COPY THE ARG POINTER
1701 MOVE E,B ;COPY OF RESULT
1703 EUVLP: GETYP 0,(D) ;GET A TYPE
1705 JRST WRNGUT ;NO , LOSE
1706 MOVE 0,1(D) ;GET GOODIE
1707 MOVEM 0,(E) ;CLOBBER
1708 ADD D,C%22 ;BUMP ARGS POINTER
1712 HRLM C,(E) ;CLOBBER UNIFORM TYPE IN
1713 FINISU: MOVSI A,TUVEC
1716 WRNGSU: GETYP A,-1(TP)
1718 JRST WRNGUT ;IF UVECTOR
1719 PUSHJ P,FREESV ;FREE STORAGE VECTOR
1720 ERRUUO EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
1722 WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
1724 CANTUN: ERRUUO EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
1726 BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
1727 \f; FUNCTION TO GROW A VECTOR
1733 MOVEI D,0 ;STACK HACKING FLAG
1734 GETYP A,(AB) ;FIRST TYPE
1735 PUSHJ P,SAT ;GET STORAGE TYPE
1736 GETYP B,2(AB) ;2ND ARG
1737 CAIE A,STPSTK ;IS IT ASTACK
1739 AOJA D,GRSTCK ;YES, WIN
1740 CAIE A,SNWORD ;UNIFORM VECTOR
1741 CAIN A,S2NWORD ;OR GENERAL
1742 GRSTCK: CAIE B,TFIX ;IS 2ND FIXED
1743 JRST WTYP2 ;COMPLAIN
1745 CAIE B,TFIX ;3RD ARG
1748 MOVEI E,1 ;UNIFORM/GENERAL FLAG
1749 CAIE A,SNWORD ;SKIP IF UNIFORM
1750 CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL
1753 HRRZ B,1(AB) ;POINT TO START
1754 HLRE A,1(AB) ;GET -LENGTH
1755 SUB B,A ;POINT TO DOPE WORD
1756 SKIPE D ;SKIP IF NOT STACK
1757 ADDI B,PDLBUF ;FUDGE FOR PDL
1758 HLLZS (B) ;ZERO OUT GROWTH SPECS
1759 SKIPN A,3(AB) ;ANY TOP GROWTH?
1760 JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH
1761 ASH A,(E) ;MULT BY 2 IF GENERAL
1762 ADDI A,77 ;ROUND TO NEAREST BLOCK
1763 ANDCMI A,77 ;CLEAR LOW ORDER BITS
1764 ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION
1765 TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE
1767 TLNE A,-1 ;SKIP IF NOT TOO BIG
1769 GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH
1770 JRST GROW4 ;NONE, SKIP
1771 ASH C,(E) ;GENRAL FUDGE
1773 ANDCMI C,77 ;FUDGE FOR VALUE RETURN
1775 ASH C,-6 ;DIVIDE BY 100
1776 TRZE C,400 ;CONVERT TO SIGN MAGNITUDE
1778 TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW
1780 GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR
1782 HRLI E,(E) ;TO BOTH HALVES
1783 ADDI E,1(B) ;POINTS TO TOP
1785 ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH
1786 SKIPL D,(P) ;SHRINKAGE?
1787 JRST GROW3 ;NO, CONTINUE
1789 HRLI D,(D) ;TO BOTH HALVES
1790 ADD E,D ;POINT TO NEW LOW ADDR
1791 GROW3: IORI A,(C) ;OR TOGETHER
1792 HRRM A,(B) ;DEPOSIT INTO DOPEWORD
1793 PUSH TP,(AB) ;PUSH TYPE
1794 PUSH TP,E ;AND VALUE
1795 SKIPE A ;DON'T GC FOR NOTHING
1796 MOVE C,[2,,0] ; GET INDICATOR FOR AGC
1799 POP P,C ;RESTORE GROWTH
1801 POP TP,B ;GET VECTOR POINTER
1802 SUB B,C ;POINT TO NEW TOP
1806 GROFUL: SUB P,C%11 ; CLEAN UP STACK
1811 GTOBIG: ERRUUO EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
1812 GROW4: PUSH P,[0] ;0 BOTTOM GROWTH
1815 FULLOS: ERRUUO EQUOTE NO-STORAGE
1818 \f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
1820 MFUNCTION BYTES,SUBR
1832 IMFUNCTION STRING,SUBR
1838 STRNG1: MOVE B,AB ;COPY ARG POINTER
1839 MOVEI C,0 ;INITIALIZE COUNTER
1840 PUSH TP,$TAB ;SAVE A COPY
1842 HLRE A,B ; GET # OF ARGS
1844 ASH A,-1 ; 1/2 FOR # OF ARGS
1852 SKIPN E,A ; SKIP IF ARGS EXIST
1853 JRST MAKSTR ; ALL DONE
1855 STRIN2: GETYP 0,(B) ;GET TYPE CODE
1856 CAMN 0,SING(D) ; SINGLE CHARACTER OR FIX?
1858 CAME 0,MULTI(D) ; OR STRING OR BYTE-STRING
1859 JRST WRONGT ;NEITHER
1860 HRRZ 0,(B) ; GET CHAR COUNT
1866 ; NOW GET THE NECESSARY VECTOR
1868 MAKSTR: HRL C,MULTI(D) ; FINAL TYPE,, CHAR COUNT
1869 PUSH P,C ; SAVE CHAR COUNT
1870 PUSH P,E ; SAVE ARG COUNT
1872 IDIV D,-2(P) ; A==> BYTES PER WORD
1873 MOVEI A,(C) ; LNTH+4 TO A
1879 HRLM E,-2(P) ; SAVE REMAINDER
1883 JUMPGE B,DONEC ; 0 LENGTH, NO STRING
1884 HRLI B,440000 ;CONVERT B TO A BYTE POINTER
1885 HRRZ 0,-1(P) ; BYTE SIZE
1887 MOVE C,(TP) ; POINT TO ARGS AGAIN
1889 NXTRG1: GETYP D,(C) ;GET AN ARG
1894 MOVE D,1(C) ; GET IT
1895 IDPB D,B ;AND DEPOSIT IT
1898 TRYSTR: MOVE E,1(C) ;GET BYTER
1899 HRRZ 0,(C) ;AND COUNT
1900 NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG
1901 ILDB D,E ;AND GET NEXT
1902 IDPB D,B ; AND DEPOSIT SAME
1905 NXTARG: ADD C,C%22 ;BUMP ARG POINTER
1909 DONEC: MOVSI C,TCHRS+.VECT.
1911 HLLM C,(B) ;AND CLOBBER AWAY
1912 HLRZ C,1(B) ;GET LENGTH BACK
1915 HLL B,(P) ;MAKE A BYTE POINTER
1926 ; COMPILER'S CALL TO MAKE A STRING
1930 ; COMPILERS CALL TO MAKE A BYTE STRING
1934 MOVEI C,0 ; INIT CHAR COUNTER
1935 MOVEI B,(A) ; SET UP STACK POINTER
1936 ASH B,1 ; * 2 FOR NO. OF SLOTS
1938 SUBM TP,B ; B POINTS TO ARGS
1942 GETYP 0,1(B) ; CHECK BYTE SIZE
1951 PUSHJ P,IISTRN ; MAKE IT HAPPEN
1952 MOVE TP,(TP) ; FLUSH ARGS
1959 \f;BUILD IMPLICT STRING
1961 MFUNCTION IBYTES,SUBR
1965 CAML AB,C%M20 ; [-3,,] ; AT LEAST 2
1967 CAMGE AB,C%M60 ; [-7,,] ; NO MORE THAN 3
1969 PUSHJ P,GETFIX ; GET BYTE SIZE
1980 MFUNCTION ISTRING,SUBR
1983 JUMPGE AB,TFA ; TOO FEW ARGS
1984 CAMGE AB,C%M40 ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
1989 ISTR1: PUSHJ P,GETFIX
1993 IDIVI A,(C) ; # OF WORDS NEEDED TO A
1995 MOVE C,-1(P) ; GET BYTE SIZE
1999 HLRE C,B ; -LENGTH TO C
2000 SUBM B,C ; LOCN OF DOPE WORD TO C
2001 HRLI D,TCHRS+.VECT. ; CLOBBER ITS TYPE
2004 HRR A,1(AB) ; SETUP TYPE'S RH
2006 HRL B,(P) ; AND BYTE POINTER
2008 SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT
2009 CAML AB,C%M20 ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
2011 PUSH TP,A ;SAVE OUR STRING
2013 PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER
2015 PUSH P,(AB)1 ;SAVE COUNT
2018 CLOBST: PUSH TP,-1(TP)
2021 GETYP C,A ; CHECK IT
2022 CAME C,-1(P) ; MUST BE A CHARACTER
2024 IDPB B,-2(TP) ;CLOBBER
2025 SOSLE (P) ;FINISHED?
2034 ; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
2035 ; PUNT SOME IF THERE ARE.
2042 JSP E,CKPUR ; CHECK FOR PURE RSUBR
2046 MOVE B,RFRETP ; GET REAL FRETOP
2048 MOVE B,A ; TOP OF WORLD
2051 ADDI A,1777 ; PAGE BOUNDARY
2053 CAIL A,(B) ; SEE WHETHER THERE IS ROOM
2062 POP P,C ; RESTORE CAUSE INDICATOR
2064 PUSHJ P,CLEANT ; CLEAN UP
2065 SKIPL PLODR ; IF IN PLOAD DON'T INTERRUPT
2066 JRST INTAGC ; GO CAUSE GARBAGE COLLECT
2074 PUSHJ P,GETPAG ; GET THOSE PAGES
2075 FATAL CAN'T GET PAGES NEEDED
2077 ASH A,-10. ; TO PAGES
2080 CLNT1: PUSHJ P,RBLDM
2085 \f; RCLVEC DISTASTEFUL VECTOR RECYCLER
2087 ; Arrive here with B pointing to first recycler, A desired length
2089 RCLVEC: PUSH P,D ; Save registers
2092 MOVEI D,RCLV ; Point to previous recycle for splice
2093 RCLV1: HLRZ C,(B) ; Get size of this block
2094 CAIL C,(A) ; Skip if too small
2097 RCLV2: MOVEI D,(B) ; Save previous pointer
2098 HRRZ B,(B) ; Point to next block
2099 JUMPN B,RCLV1 ; Jump if more blocks
2104 JRST NORCL ; Go to normal allocator
2107 FOUND1: CAIN C,1(A) ; Exactly 1 greater?
2108 JRST RCLV2 ; Cant use this guy
2110 HRLM A,(B) ; Smash in new count
2111 TLO A,.VECT. ; make vector bit be on
2113 CAIE C,(A) ; Exactly right length?
2114 JRST FOUND2 ; No, do hair
2116 HRRZ C,(B) ; Point to next block
2117 HRRM C,(D) ; Smash previous pointer
2119 SUBI B,-1(A) ; Point to top of block
2122 FOUND2: SUBI C,(A) ; Amount of left over to C
2123 HRRZ E,(B) ; Point to next block
2125 SUBI B,(A) ; Point to dope words of guy to put back
2126 MOVSM C,(B) ; Smash in count
2127 MOVSI C,.VECT. ; Get vector bit
2128 MOVEM C,-1(B) ; Make sure it is a vector
2129 HRRM B,(D) ; Splice him in
2130 HRRM E,(B) ; And the next guy also
2131 ADDI B,1 ; Point to start of vector
2133 FOUND3: HRROI B,(B) ; Make an AOBJN pointer