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
451 CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS
456 CAIN B,S1WORD ; SEE IF PRIMTYPE WOR
457 JRST RDLSTF ; LEAVE IF IS
458 STFXX: MOVE 0,GCSBOT ; ADJUSTMENT
460 SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL
462 RDLSTF: TLNN C,.LIST. ; SEE IF PAIR
464 MOVE 0,GCSBOT ; FIX UP
466 HRRZ B,(C) ; SEE IF POINTS TO NIL
469 MOVE B,C ; GET ARG FOR RLISTQ
473 RDL1: POP P,B ; RESTORE B
477 ; ROUTINE TO FIX UP PNAMES
481 HLLM D,1(C) ; PUT BACK WITH BIT OFF
484 HLRE 0,-1(D) ; LENGTH OF ATOM
486 SUBI 0,3 ; VAL & OBLIST
487 IMULI 0,5 ; TO CHARS (SORT OF)
492 LDB A,[360600,,1(C)] ; GET BYTE POS
493 IDIVI A,7 ; TO CHAR POS
496 HRRZ B,(C) ; STRING LENGTH
497 SUB B,A ; TO WORD BOUNDARY STRING
506 ; ROUTINE TO FIX UP POINTERS TO ATOMS
511 MOVE 0,-1(D) ; GET PTR TO ATOM
512 CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR
528 ATFXAT: MOVEM 0,1(C) ; SMASH IT IN
531 TYPCFX: HRRZ B,1(C) ; GET TYPE
532 PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
533 HRRM B,1(C) ; CLOBBER IT IN
534 JRST RDLSTF ; CONTINUE FIXUP
536 TYPWFX: HLRZ B,1(C) ; GET TYPE
537 PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
538 HRLM B,1(C) ; SMASH IT IN
542 PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE
547 ; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
548 ; EOF HANDLER ELSE USES CHANNELS.
550 EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B
551 CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED
552 JRST MYCLOS ; USE CHANNELS
556 MYCLOS: PUSH TP,EOFCND-1(B)
558 CLOSIT: PUSH TP,$TCHAN
560 MCALL 1,FCLOSE ; CLOSE CHANNEL
561 MCALL 1,EVAL ; EVAL HIS EOF HANDLER
564 ; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
566 GETNEW: CAMG B,NNPRI ;NEWTYPE
568 GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE
569 GETNT1: HLRZ E,(D) ; GET TYPE #
570 CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
571 JRST GOTTYP ; FOUND IT
572 ADD D,C%22 ; POINT TO NEXT
574 SKIPA ; KEEP TYPE SAME
575 GOTTYP: HRRZ B,1(D) ; GET NEW TYPE #
578 ; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
580 GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE
581 GETSA1: HRRZ E,(D) ; GET OBJECT
582 CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
583 JRST GOTSAT ; FOUND IT
586 FATAL GC-DUMP -- TYPE FIXUP FAILURE
587 GOTSAT: HLRZ B,1(D) ; GET NEW SAT
591 ; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
593 GETYP A,(B) ; GET TYPE
594 PUSHJ P,SAT ; GET SAT
595 CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
597 AOS -1(P) ; SKIP IF NOT DEFFERED
604 MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
608 JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT
610 CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR
611 JRST WTYP1 ; IF NOT COMPLAIN
614 CAIE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
616 CAMGE AB,C%M20 ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
618 MOVE A,(AB) ; GET THE UVECTOR
620 JRST SETUV ; CONTINUE
621 GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR
623 SETUV: PUSH P,A ; SAVE UVECTOR
625 MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
629 PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
630 HLRE 0,TP ; COMPUTE STACK SPACE USED UP
634 MOVE B,IMQUOTE THIS-PROCESS
638 HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
640 HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS
644 SUB B,C ; TOTAL WORDS ATOM STORAGE
645 IDIVI B,6 ; COMPUTE # OF SLOTS
647 HRRZ A,GLOBASE+1 ; COMPUTE TOTAL # OF GLOBAL SLOTS
649 SUB A,0 ; POINT TO DOPE WORD
651 ASH B,-2 ; # OF GVAL SLOTS
653 HRRZ A,GLOTOP+1 ; COMPUTE # OF GVAL SLOTS IN USE
656 ASH A,-2 ; NEGATIVE # OF SLOTS USED
658 HRRZ A,TYPBOT+1 ; GET LENGTH OF TYPE VECTOR
661 HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR
662 IDIVI B,2 ; CONVERT TO # OF TYPES
664 HLRE 0,TYPVEC+1 ; LENGTH OF VISABLE TYPE-VECTOR
666 IDIVI 0,2 ; GET # OF TYPES
668 MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE
670 SETZB B,D ; ZERO OUT MAXIMUM
672 LOOPC: HLRZ 0,(C) ; GET BLK LENGTH
673 ADD D,0 ; ADD # OF WORDS IN BLOCK
674 CAMGE B,0 ; SEE IF NEW MAXIMUM
676 HRRZ C,(C) ; POINT TO NEXT BLOCK
677 JUMPN C,LOOPC ; REPEAT
680 HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P
684 MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES
685 HRRZ B,(P) ; RESTORE B
688 HRLI C,BSTAT ; MODIFY BLT FOR STATS
690 BLT C,(B)STATGC+STATNO-1
692 HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE
694 POP P,A ; RESTORE TYPE-WORD
697 GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST
698 MOVE 0,[GCNO,,GCNO+1]
705 .GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
707 ; USER GARBAGE COLLECTOR INTERFACE
714 CAMGE AB,C%M60 ; [-6,,0]
716 PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN
717 SKIPE A ; SKIP FOR 0 ARGUMENT
719 GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE
721 CAML AB,C%M40 ; [-4,,0] ; SEE IF 3RD ARG
723 GETYP A,4(AB) ; MAKE SURE A FIX
725 JRST WTYP ; ARG WRONG TYPE
729 GC5: CAML AB,C%M20 ; [-2,,0] ; SEE IF SECOND ARG
731 GETYP A,2(AB) ; SEE IF NONFALSE
732 CAIE A,TFALSE ; SKIP IF FALSE
733 JRST HAIRGC ; CAUSE A HAIRY GC
734 GC3: MOVSI A,TATOM ; CHECK TO SEE IF INTERRUPT FLAG IS ON
735 MOVE B,IMQUOTE AGC-FLAG
737 CAMN A,$TUNBOUND ; SKIP IF NOT UNBOUND
739 SKIPE GCHPN ; SKIP IF GCHAPPEN IS 0
740 JRST FALRTN ; JUMP TO RETURN FALSE
742 PUSHJ P,AGC ; COLLECT THAT TRASH
743 PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?
744 POP P,B ; RETURN AMOUNT
749 CAIN A,TFIX ; IF FIX THEN CLOBBER NGCS
751 MOVEI A,1 ; FORCE VALUE FLUSHING PHASE TO OCCUR
753 JRST GC2 ; HAIRY GC OCCORS NO MATTER WHAT
754 FALRTN: MOVE A,$TFALSE
755 MOVEI B,0 ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR
759 COMPRM: MOVE A,GCSTOP ; USED SPACE
764 MFUNCTION GCDMON,SUBR,[GC-MON]
770 FLGSET: MOVE C,(E) ; GET CURRENT VALUE
771 JUMPGE AB,RETFLG ; RET CURRENT
772 CAMGE AB,C%M20 ; [-3,,]
792 .GLOBAL EVATYP,APLTYP,PRNTYP
794 \fMFUNCTION BLOAT,SUBR
798 MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC
799 MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE
801 BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?
802 PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM
804 PUSHJ P,@BLOATER(E) ; DISPATCH
805 AOBJN E,BLOAT2 ; COUNT PARAMS SET
807 JUMPL AB,TMA ; ANY LEFT...ERROR
808 BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED
809 MOVE C,E ; MOVE IN INDICATOR
810 HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT
813 SKIPE A,TPBINC ; SMASH POINNTERS
816 SKIPE A,GLBINC ; GLOBAL SP
820 SETZM TPBINC ; RESET PARAMS
824 BLOATD: SKIPN A,GETNUM ; SKIP IF FREE STORAGE REQUEST IN EFFECT
826 ADD A,FRETOP ; ADD FRETOP
827 ADDI A,1777 ; ONE BLOCK FOR MARK PDL AND ROUND
828 ANDCMI A,1777 ; TO PAGE BOUNDRY
829 CAML A,PURBOT ; SKIP IF POSSIBLE TO WIN
831 ASH A,-10. ; TO PAGES
832 PUSHJ P,P.CORE ; GRET THE CORE
833 JRST BLFAGC ; LOSE LOSE LOSE
834 MOVE A,FRETOP ; CALCULATE NEW PARAMETERS
841 BLT B,-1(A) ; ZERO CORE
845 MOVSI A,TFIX ; RETURN CORE FOUND
847 BLFAGC: MOVN A,FREMIN
848 ADDM A,GETNUM ; FIX UP SO BLOATS CORRECTLY
849 MOVE C,C%11 ; INDICATOR FOR AGC
850 PUSHJ P,AGC ; GARBAGE COLLECT
853 ; TABLE OF BLOAT ROUTINES
873 ; BLOAT MAIN STORAGE AREA
876 MOVE D,FRETOP ; COMPUTE CURRENT ROOM
878 CAMGE A,D ; NEED MORE?
881 MOVEM A,GETNUM ; SAVE
884 ; BLOAT TP STACK (AT TOP)
886 TPBLO: HLRE D,TP ; GET -SIZE
888 ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
889 CAME D,TPGROW ; BLOWN?
890 ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
891 SUB A,B ; SKIP IF GROWTH NEEDED
894 ASH A,-6 ; CONVERT TO 64 WD BLOCKS
897 DPB A,[111100,,-1(D)] ; SMASH SPECS IN
900 ; BLOAT TOP LEVEL LOCALS
902 LOBLO: HLRE D,TP ; GET -SIZE
904 ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
905 CAME D,TPGROW ; BLOWN?
906 ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
907 CAMG A,B ; SKIP IF GROWTH NEEDED
908 IMULI A,6 ; 6 WORDS PER BINDING
911 HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E
913 SUBI A,(B) ; HOW MUCH MORE?
914 JUMPLE A,CPOPJ ; NONE NEEDED
917 DPB A,[1100,,-1(D)] ; SMASH
922 GLBLO: ASH A,2 ; 4 WORDS PER VAR
923 MOVE D,GLOBASE+1 ; CURRENT LIMITS
926 SUBI A,(B) ; NEW AMOUNT NEEDED
928 MOVEI B,GLBINC ; WHERE TO KEEP UPDATE
929 PUSHJ P,NUMADJ ; FIX NUMBER
931 SUB D,0 ; POINT TO DOPE
932 DPB A,[1100,,(D)] ; AND SMASH
935 ; HERE TO GROW TYPE VECTOR (AND FRIENDS)
937 TYBLO: ASH A,1 ; TWO WORD PER TYPE
938 HRRZ B,TYPVEC+1 ; FIND CURRENT ROOM
941 SUBI A,(B) ; EXTRA NEEDED TO A
942 JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE
943 MOVEI B,TYPINC ; WHERE TO STASH SPEC
944 PUSHJ P,NUMADJ ; FIX NUMBER
945 HLRE 0,D ; POINT TO DOPE
948 SKIPE D,EVATYP+1 ; GROW AUX TYPE VECS IF NEEDED
956 ; HERE TO CREATE STORAGE SPACE
958 STBLO: MOVE D,GCSBOT ; HOW MUCH NOW HERE
960 SUBI A,(D) ; MORE NEEDED?
962 MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT
969 SUBI D,5 ; FUDGE FOR THIS CALL
972 ADDI B,1(P) ; POINT TO DOPE
973 CAME B,PGROW ; BLOWN?
974 ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.
976 ASH A,-6 ; TO 64 WRD BLOCKS
977 CAILE A,377 ; IN RANGE?
979 DPB A,[111100,,-1(B)]
984 SFREM: SKIPE A ; DON'T ZERO EMPTY PARAMETER
990 SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B
998 SGVL: IMULI A,4. ; # OF SLOTS
1004 ; SET TYPE INCREMENT
1006 STYP: IMULI A,2 ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
1012 ; SET STORAGE INCREMENT
1014 SSTO: IDIVI A,2000 ; # OF BLOCKS
1015 CAIE B,0 ; REMAINDER?
1017 IMULI A,2000 ; CONVERT BACK TO WORDS
1020 ; HERE FOR MINIMUM PURE SPACE
1023 ANDCMI A,1777 ; TO PAGE BOUNDRY
1027 ; HERE TO ADJUST PSTACK PARAMETERS IN GC
1029 PMUNG: ADDI A,777 ; TO NEAREST 1000 WORD BOUNDRY
1031 MOVEM A,PGOOD ; PGOOD
1032 ASH A,2 ; PMAX IS 4*PGOOD
1034 ASH A,-4 ; PMIN IS .25*PGOOD
1037 ; HERE TO ADJUST GC TPSTACK PARAMS
1040 ANDCMI A,777 ; TO NEAREST 1000 WORD BOUNDRY
1042 ASH A,2 ; TPMAX= 4*TPGOOD
1044 ASH A,-4 ; TPMIN= .25*TPGOOD
1048 ; GET NEXT (FIX) ARG
1050 NXTFIX: PUSHJ P,GETFIX
1054 ; ROUTINE TO GET POS FIXED ARG
1056 GETFIX: GETYP A,(AB)
1064 ; GET NUMBERS FIXED UP FOR GROWTH FIELDS
1066 NUMADJ: ADDI A,77 ; ROUND UP
1067 ANDCMI A,77 ; KILL CRAP
1069 MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
1071 MOVEM A,(B) ; AND STASH IT
1073 ASH A,-6 ; TO 64 WD BLOCKS
1074 CAILE A,377 ; CHECK FIT
1078 ; DO SYMPATHETIC GROWTHS
1085 \f;FUNCTION TO CONSTRUCT A LIST
1090 GETYP A,2(AB) ;GET TYPE OF 2ND ARG
1092 JRST WTYP2 ;NO , COMPLAIN
1093 MOVE C,(AB) ; GET THING TO CONS IN
1095 HRRZ E,3(AB) ; AND LIST
1096 PUSHJ P,ICONS ; INTERNAL CONS
1099 ; COMPILER CALL TO CONS
1101 C1CONS: PUSHJ P,ICELL2
1104 ICONS3: MOVEM C,(B) ; AND STORE
1106 TLPOPJ: MOVSI A,TLIST
1109 ; INTERNAL CONS--ICONS; C,D VALUE, E CDR
1111 ; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE
1112 ; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED
1113 ; TO: DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS.
1119 ; INTERNAL CONS TO NIL--INCONS
1123 ICONS: GETYP A,C ; CHECK TYPE OF VAL
1124 PUSHJ P,NWORDT ; # OF WORDS
1125 SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED
1126 PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
1127 JRST ICNS2A ; NO CORE, GO GC (SPECIAL PLACE, NOTICE)
1130 ; HERE IF CONSING DEFERRED
1132 ICONS1: MOVEI A,4 ; NEED 4 WORDS
1133 PUSHJ P,ICELL ; GO GET 'EM
1134 JRST ICNS2A ; NOT THERE, GC (SAME PLACE AS FOR ICONS)
1135 HRLI E,TDEFER ; CDR AND DEFER
1137 MOVEI E,2(B) ; POINT E TO VAL CELL
1139 MOVEM C,(E) ; STORE VALUE
1145 ; HERE TO GC ON A CONS
1153 ; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
1154 ICNS2A: PUSHJ P,ICONSG
1158 ICONSG: PUSH TP,C ; SAVE VAL
1161 PUSH TP,E ; SAVE VITAL STUFF
1162 ADDM A,GETNUM ; AMOUNT NEEDED
1163 MOVE C,[3,,1] ; INDICATOR FOR AGC
1164 PUSHJ P,INQAGC ; ATTEMPT TO WIN
1165 MOVE D,-2(TP) ; RESTORE VOLATILE STUFF
1168 SUB TP,C%44 ; [4,,4]
1169 POPJ P, ; BACK TO DRAWING BOARD
1171 ; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED
1173 CELL2: MOVEI A,2 ; USUAL CASE
1174 CELL: PUSHJ P,ICELL ; INTERNAL
1178 ADDM A,GETNUM ; AMOUNT REQUIRED
1179 PUSH P,A ; PREVENT AGC DESTRUCTION
1180 MOVE C,[3,,1] ; INDICATOR FOR AGC
1183 JRST CELL ; AND TRY AGAIN
1185 ; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
1187 ICELL2: MOVEI A,2 ; MOST LIKELY CAE
1189 JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL
1190 MOVE B,PARTOP ; GET TOP OF PAIRS
1192 CAMLE B,FRETOP ; SKIP IF OK.
1194 EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER
1196 JRST CPOPJ1 ; SKIP RETURN
1198 ; TRY RECYCLING USING A VECTOR FROM RCLV
1200 VECTRY: SKIPN B,RCLV ; SKIP IF VECTOR EXISTS
1205 VECTR1: HLRZ A,(B) ; GET LENGTH
1207 JUMPL A,NXTVEC ; DOESN'T SATISFY TRY AGAIN
1208 CAIN A,1 ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
1210 JUMPN A,SOML ; SOME ARE LEFT
1215 SETZM -1(B) ; CLEAR DOPE WORDS
1217 POP P,A ; CLEAR STACK
1220 SOML: HRLM A,(B) ; SMASH AMOUNT LEFT
1221 SUBI B,-1(A) ; GET TO BEGINNING
1227 HRRZ B,(B) ; GET NEXT
1234 JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD
1239 SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL
1241 JRST CPOPJ1 ;THAT IT
1244 \f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
1246 IMFUNCTION LIST,SUBR
1250 LIST12: HLRE A,AB ;GET -NUM OF ARGS
1254 JUMPE A,LISTN ;JUMP IF 0
1255 SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME
1256 JRST LST12R ;TO GET RECYCLED CELLS
1257 PUSHJ P,CELL ;GET NUMBER OF CELLS
1258 PUSH TP,(P) ;SAVE IT
1261 LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS
1263 CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS
1264 HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE
1265 SOJG A,.-2 ;LOOP TIL ALL DONE
1266 CLEARM B,-2(B) ;SET THE LAST CDR TO NIL
1268 ; NOW LOBEER THE DATA IN TO THE LIST
1270 MOVE D,AB ; COPY OF ARG POINTER
1271 MOVE B,(TP) ;RESTORE LIS POINTER
1272 LISTLP: GETYP A,(D) ;GET TYPE
1273 PUSHJ P,NWORDT ;GET NUMBER OF WORDS
1274 SOJN A,LDEFER ;NEED TO DEFER POINTER
1275 GETYP A,(D) ;NOW CLOBBER ELEMENTS
1277 MOVE A,1(D) ;AND VALUE..
1279 LISTL2: HRRZ B,(B) ;REST B
1280 ADD D,C%22 ;STEP ARGS
1285 SUB TP,C%22 ; CLEANUP STACK
1289 LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS
1291 PUSH P,A ;SAVE COUNT ON STACK
1295 MOVE E,B ;LOOP AND CHAIN TOGETHER
1298 PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT
1300 SUB P,C%22 ;CLEAN UP AFTER OURSELVES
1301 JRST LISTLP-2 ;AND REJOIN MAIN STREAM
1304 ; MAKE A DEFERRED POINTER
1306 LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER
1308 MOVEM D,1(TB) ; SAVE ARG HACKER
1311 GETYPF A,(D) ;GET FULL DATA
1315 MOVE C,(TP) ;RESTORE LIST POINTER
1316 MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE
1318 HLLM A,(C) ;AND STORE IT
1329 IMFUNCTION FORM,SUBR
1336 \f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
1348 IILST: JUMPE A,IILST0 ; NIL WHATSIT
1353 PUSHJ P,ICONS ; CONS 'EM UP
1364 \f;FUNCTION TO BUILD AN IMPLICIT LIST
1366 MFUNCTION ILIST,SUBR
1369 ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG
1370 CAMGE AB,C%M40 ; [-4,,0] ; NO MORE THAN TWO ARGS
1372 PUSHJ P,GETFIX ; GET POS FIX #
1373 JUMPE A,LISTN ;EMPTY LIST ?
1374 CAML AB,C%M20 ; [-2,,0] ;ONLY ONE ARG?
1376 PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
1377 ILIST0: PUSH TP,2(AB)
1385 ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH
1387 ILIST3: POP P,A ; GET FINAL TYPE
1391 LOSEL: PUSH P,A ; SAVE COUNT
1394 LOSEL1: SETZB C,D ; TLOSE,,0
1405 MFUNCTION IFORM,SUBR
1411 \f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
1413 MFUNCTION VECTOR,SUBR,[IVECTOR]
1418 MFUNCTION UVECTOR,SUBR,[IUVECTOR]
1422 JUMPGE AB,TFA ; AT LEAST ONE ARG
1423 CAMGE AB,C%M40 ; [-4,,0] ; NOT MORE THAN 2
1425 PUSHJ P,GETFIX ; GET A POS FIXED NUMBER
1426 LSH A,(C) ; A-> NUMBER OF WORDS
1427 PUSH P,C ; SAVE FOR LATER
1428 PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)
1431 SUBM B,A ; FIND DOPE WORD
1432 MOVSI D,.VECT. ; FOR GCHACK
1435 MOVSI D,400000 ; GET NOT UNIFORM BIT
1436 IORM D,(A) ; INTO DOPE WORD
1437 SKIPA A,$TVEC ; GET TYPE
1438 VECTO4: MOVSI A,TUVEC
1439 CAML AB,C%M20 ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
1441 JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE
1443 PUSH TP,A ; SAVE THE VECTOR
1449 JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE
1450 INLP: PUSHJ P,IEVAL ; EVAL EXPR
1453 ADD C,C%22 ; BUMP VECTOR
1455 JUMPL C,INLP ; IF MORE DO IT
1457 GETVEC: MOVE A,-3(TP)
1459 SUB TP,C%44 ; [4,,4]
1462 ; HERE TO FILL UP A UVECTOR
1464 UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE
1465 GETYP A,A ; GET TYPE
1466 PUSH P,A ; SAVE TYPE
1467 PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED
1468 SOJN A,CANTUN ; COMPLAIN
1469 STJOIN: MOVE C,(TP) ; RESTORE POINTER
1470 ADD C,1(AB) ; POINT TO DOPE WORD
1471 MOVE A,(P) ; GET TYPE
1472 HRLZM A,(C) ; STORE IN D.W.
1473 MOVSI D,.VECT. ; FOR GCHACK
1475 MOVE C,(TP) ; GET BACK VECTOR
1477 JRST UINLP1 ; START FILLING UV
1480 UINLP: MOVEM C,(TP) ; SAVE PNTR
1481 PUSHJ P,IEVAL ; EVAL THE EXPR
1482 GETYP A,A ; GET EVALED TYPE
1483 CAIE A,@(P) ; WINNER?
1484 JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE
1485 UINLP1: MOVEM B,(C) ; STORE
1488 JRST GETVEC ; AND RETURN VECTOR
1490 IEVAL: PUSH TP,2(AB)
1496 ; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
1498 MFUNCTION ISTORAGE,SUBR
1501 CAMGE AB,C%M40 ; [-4,,0] ; AT LEAST ONE ARG
1503 PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG
1504 PUSHJ P,CAFRE ; GET CORE
1505 MOVN B,1(AB) ; -COUNT
1506 HRL A,B ; PUT IN LHW (A)
1508 HRLI B,2(B) ; LENGTH + 2
1509 ADDI B,(A) ; MAKE POINTER TO DOPE WORDS
1510 HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE
1511 HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
1514 CAML AB,C%M20 ; [-2,,0] ; SECOND ARG TO EVAL?
1515 JRST FINIS ; IF NOT, RETURN EMPTY
1520 PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE
1522 PUSH P,A ; FOR COMPARISON LATER
1525 JRST STJOIN ;TREAT LIKE A UVECTOR
1526 ; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
1527 PUSHJ P,FREESV ; FREE STORAGE VECTOR
1528 ERRUUO EQUOTE DATA-CANT-GO-IN-STORAGE
1530 ; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
1531 FREESV: MOVE A,1(AB) ; GET COUNT
1533 HRRZ B,(TP) ; GET ADDRESS
1534 PUSHJ P,CAFRET ; FREE THE CORE
1538 ; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
1540 IBLOK1: ASH A,1 ; TIMES 2
1541 GIBLOK: TLOA A,400000 ; FUNNY BIT
1542 IBLOCK: TLZ A,400000 ; NO BIT ON
1543 TLO A,.VECT. ; TURN ON BIT FOR GCHACK
1544 ADDI A,2 ; COMPENSATE FOR DOPE WORDS
1545 IBLOK2: SKIPE B,RCLV ; ANY TO RECYCLE?
1547 NORCL: MOVE B,GCSTOP ; POINT TO BOTTOM OF SPACE
1548 PUSH P,B ; SAVE TO BUILD PTR
1549 ADDI B,(A) ; ADD NEEDED AMOUNT
1550 CAML B,FRETOP ; SKIP IF NO GC NEEDED
1552 MOVEM B,GCSTOP ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
1555 HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD
1556 HLLZM A,-2(B) ; AND BIT
1557 HRRM B,-1(B) ; SMASH IN RELOCATION
1559 POP P,B ; RESTORE PTR TO BOTTOM OF VECTOR
1560 HRROS B ; POINT TO START OF VECTOR
1561 TLC B,-3(A) ; SETUP COUNT
1568 ; HERE TO DO A GC ON A VECTOR ALLOCATION
1571 PUSH P,A ; SAVE DESIRED LENGTH
1573 ADDM 0,GETNUM ; AND STORE AS DESIRED AMOUNT
1574 MOVE C,[4,,1] ; GET INDICATOR FOR AGC
1582 ; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
1583 ; ITEMS ON TOP OF STACK
1585 IEVECT: ASH A,1 ; TO NUMBER OF WORDS
1587 PUSHJ P,IBLOCK ; GET VECTOR
1589 SUBM B,D ; A POINTS TO DW
1590 MOVSI 0,400000+.VECT.
1591 MOVEM 0,(D) ; CLOBBER NON UNIF BIT
1592 POP P,A ; RESTORE COUNT
1593 JUMPE A,IVEC1 ; 0 LNTH, DONE
1594 MOVEI C,(TP) ; BUILD BLT
1595 SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK
1597 HRRI C,(B) ; B/ SOURCE,,DEST
1598 BLT C,-1(D) ; XFER THE DATA
1600 SUB TP,A ; FLUSH STACKAGE
1612 \f; INTERNAL CALL TO EUVECTOR
1614 IEUVEC: PUSH P,A ; SAVE LENGTH
1617 JUMPE A,IEUVE1 ; EMPTY, LEAVE
1618 ASH A,1 ; NOW FIND STACK POSITION
1619 MOVEI C,(TP) ; POINT TO TOP
1620 MOVE D,B ; COPY VEC POINTER
1621 SUBI C,-1(A) ; POINT TO 1ST DATUM
1622 GETYP A,(C) ; CHECK IT
1624 SOJN A,CANTUN ; WONT FIT
1627 IEUVE2: GETYP 0,(C) ; TYPE OF EL
1631 MOVEM 0,(D) ; CLOBBER
1633 AOBJN D,IEUVE2 ; LOOP
1635 HRLZM E,(D) ; STORE UTYPE
1636 IEUVE1: POP P,A ; GET COUNY
1637 ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS
1639 SUB TP,A ; CLEAN UP STACK
1649 IMFUNCTION EVECTOR,SUBR,[VECTOR]
1653 PUSH P,A ;SAVE NUMBER OF WORDS
1654 PUSHJ P,IBLOCK ; GET WORDS
1655 MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER
1656 JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR
1658 HRLI C,(AB) ;START BUILDING BLT POINTER
1659 HRRI C,(B) ;TO ADDRESS
1660 ADDI D,@(P) ;SET D TO FINAL ADDRESS
1662 FINISV: MOVSI 0,400000+.VECT.
1663 MOVEM 0,1(D) ; MARK AS GENERAL
1670 \f;EXPLICIT VECTORS FOR THE UNIFORM CSE
1672 IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
1675 HLRE A,AB ;-NUM OF ARGS
1677 ASH A,-1 ;NEED HALF AS MANY WORDS
1679 JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY
1680 GETYP A,(AB) ;GET FIRST ARG
1681 PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS
1684 PUSHJ P,IBLOCK ; GET VECT
1687 GETYP C,(AB) ;GET THE FIRST TYPE
1688 MOVE D,AB ;COPY THE ARG POINTER
1689 MOVE E,B ;COPY OF RESULT
1691 EUVLP: GETYP 0,(D) ;GET A TYPE
1693 JRST WRNGUT ;NO , LOSE
1694 MOVE 0,1(D) ;GET GOODIE
1695 MOVEM 0,(E) ;CLOBBER
1696 ADD D,C%22 ;BUMP ARGS POINTER
1700 HRLM C,(E) ;CLOBBER UNIFORM TYPE IN
1701 FINISU: MOVSI A,TUVEC
1704 WRNGSU: GETYP A,-1(TP)
1706 JRST WRNGUT ;IF UVECTOR
1707 PUSHJ P,FREESV ;FREE STORAGE VECTOR
1708 ERRUUO EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
1710 WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
1712 CANTUN: ERRUUO EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
1714 BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
1715 \f; FUNCTION TO GROW A VECTOR
1721 MOVEI D,0 ;STACK HACKING FLAG
1722 GETYP A,(AB) ;FIRST TYPE
1723 PUSHJ P,SAT ;GET STORAGE TYPE
1724 GETYP B,2(AB) ;2ND ARG
1725 CAIE A,STPSTK ;IS IT ASTACK
1727 AOJA D,GRSTCK ;YES, WIN
1728 CAIE A,SNWORD ;UNIFORM VECTOR
1729 CAIN A,S2NWORD ;OR GENERAL
1730 GRSTCK: CAIE B,TFIX ;IS 2ND FIXED
1731 JRST WTYP2 ;COMPLAIN
1733 CAIE B,TFIX ;3RD ARG
1736 MOVEI E,1 ;UNIFORM/GENERAL FLAG
1737 CAIE A,SNWORD ;SKIP IF UNIFORM
1738 CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL
1741 HRRZ B,1(AB) ;POINT TO START
1742 HLRE A,1(AB) ;GET -LENGTH
1743 SUB B,A ;POINT TO DOPE WORD
1744 SKIPE D ;SKIP IF NOT STACK
1745 ADDI B,PDLBUF ;FUDGE FOR PDL
1746 HLLZS (B) ;ZERO OUT GROWTH SPECS
1747 SKIPN A,3(AB) ;ANY TOP GROWTH?
1748 JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH
1749 ASH A,(E) ;MULT BY 2 IF GENERAL
1750 ADDI A,77 ;ROUND TO NEAREST BLOCK
1751 ANDCMI A,77 ;CLEAR LOW ORDER BITS
1752 ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION
1753 TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE
1755 TLNE A,-1 ;SKIP IF NOT TOO BIG
1757 GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH
1758 JRST GROW4 ;NONE, SKIP
1759 ASH C,(E) ;GENRAL FUDGE
1761 ANDCMI C,77 ;FUDGE FOR VALUE RETURN
1763 ASH C,-6 ;DIVIDE BY 100
1764 TRZE C,400 ;CONVERT TO SIGN MAGNITUDE
1766 TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW
1768 GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR
1770 HRLI E,(E) ;TO BOTH HALVES
1771 ADDI E,1(B) ;POINTS TO TOP
1773 ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH
1774 SKIPL D,(P) ;SHRINKAGE?
1775 JRST GROW3 ;NO, CONTINUE
1777 HRLI D,(D) ;TO BOTH HALVES
1778 ADD E,D ;POINT TO NEW LOW ADDR
1779 GROW3: IORI A,(C) ;OR TOGETHER
1780 HRRM A,(B) ;DEPOSIT INTO DOPEWORD
1781 PUSH TP,(AB) ;PUSH TYPE
1782 PUSH TP,E ;AND VALUE
1783 SKIPE A ;DON'T GC FOR NOTHING
1784 MOVE C,[2,,0] ; GET INDICATOR FOR AGC
1787 POP P,C ;RESTORE GROWTH
1789 POP TP,B ;GET VECTOR POINTER
1790 SUB B,C ;POINT TO NEW TOP
1794 GROFUL: SUB P,C%11 ; CLEAN UP STACK
1799 GTOBIG: ERRUUO EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
1800 GROW4: PUSH P,[0] ;0 BOTTOM GROWTH
1803 FULLOS: ERRUUO EQUOTE NO-STORAGE
1806 \f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
1808 MFUNCTION BYTES,SUBR
1820 IMFUNCTION STRING,SUBR
1826 STRNG1: MOVE B,AB ;COPY ARG POINTER
1827 MOVEI C,0 ;INITIALIZE COUNTER
1828 PUSH TP,$TAB ;SAVE A COPY
1830 HLRE A,B ; GET # OF ARGS
1832 ASH A,-1 ; 1/2 FOR # OF ARGS
1840 SKIPN E,A ; SKIP IF ARGS EXIST
1841 JRST MAKSTR ; ALL DONE
1843 STRIN2: GETYP 0,(B) ;GET TYPE CODE
1844 CAMN 0,SING(D) ; SINGLE CHARACTER OR FIX?
1846 CAME 0,MULTI(D) ; OR STRING OR BYTE-STRING
1847 JRST WRONGT ;NEITHER
1848 HRRZ 0,(B) ; GET CHAR COUNT
1854 ; NOW GET THE NECESSARY VECTOR
1856 MAKSTR: HRL C,MULTI(D) ; FINAL TYPE,, CHAR COUNT
1857 PUSH P,C ; SAVE CHAR COUNT
1858 PUSH P,E ; SAVE ARG COUNT
1860 IDIV D,-2(P) ; A==> BYTES PER WORD
1861 MOVEI A,(C) ; LNTH+4 TO A
1867 HRLM E,-2(P) ; SAVE REMAINDER
1871 JUMPGE B,DONEC ; 0 LENGTH, NO STRING
1872 HRLI B,440000 ;CONVERT B TO A BYTE POINTER
1873 HRRZ 0,-1(P) ; BYTE SIZE
1875 MOVE C,(TP) ; POINT TO ARGS AGAIN
1877 NXTRG1: GETYP D,(C) ;GET AN ARG
1882 MOVE D,1(C) ; GET IT
1883 IDPB D,B ;AND DEPOSIT IT
1886 TRYSTR: MOVE E,1(C) ;GET BYTER
1887 HRRZ 0,(C) ;AND COUNT
1888 NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG
1889 ILDB D,E ;AND GET NEXT
1890 IDPB D,B ; AND DEPOSIT SAME
1893 NXTARG: ADD C,C%22 ;BUMP ARG POINTER
1897 DONEC: MOVSI C,TCHRS+.VECT.
1899 HLLM C,(B) ;AND CLOBBER AWAY
1900 HLRZ C,1(B) ;GET LENGTH BACK
1903 HLL B,(P) ;MAKE A BYTE POINTER
1914 ; COMPILER'S CALL TO MAKE A STRING
1918 ; COMPILERS CALL TO MAKE A BYTE STRING
1922 MOVEI C,0 ; INIT CHAR COUNTER
1923 MOVEI B,(A) ; SET UP STACK POINTER
1924 ASH B,1 ; * 2 FOR NO. OF SLOTS
1926 SUBM TP,B ; B POINTS TO ARGS
1930 GETYP 0,1(B) ; CHECK BYTE SIZE
1939 PUSHJ P,IISTRN ; MAKE IT HAPPEN
1940 MOVE TP,(TP) ; FLUSH ARGS
1947 \f;BUILD IMPLICT STRING
1949 MFUNCTION IBYTES,SUBR
1953 CAML AB,C%M20 ; [-3,,] ; AT LEAST 2
1955 CAMGE AB,C%M60 ; [-7,,] ; NO MORE THAN 3
1957 PUSHJ P,GETFIX ; GET BYTE SIZE
1968 MFUNCTION ISTRING,SUBR
1971 JUMPGE AB,TFA ; TOO FEW ARGS
1972 CAMGE AB,C%M40 ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
1977 ISTR1: PUSHJ P,GETFIX
1981 IDIVI A,(C) ; # OF WORDS NEEDED TO A
1983 MOVE C,-1(P) ; GET BYTE SIZE
1987 HLRE C,B ; -LENGTH TO C
1988 SUBM B,C ; LOCN OF DOPE WORD TO C
1989 HRLI D,TCHRS+.VECT. ; CLOBBER ITS TYPE
1992 HRR A,1(AB) ; SETUP TYPE'S RH
1994 HRL B,(P) ; AND BYTE POINTER
1996 SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT
1997 CAML AB,C%M20 ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
1999 PUSH TP,A ;SAVE OUR STRING
2001 PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER
2003 PUSH P,(AB)1 ;SAVE COUNT
2006 CLOBST: PUSH TP,-1(TP)
2009 GETYP C,A ; CHECK IT
2010 CAME C,-1(P) ; MUST BE A CHARACTER
2012 IDPB B,-2(TP) ;CLOBBER
2013 SOSLE (P) ;FINISHED?
2022 ; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
2023 ; PUNT SOME IF THERE ARE.
2030 JSP E,CKPUR ; CHECK FOR PURE RSUBR
2034 MOVE B,RFRETP ; GET REAL FRETOP
2036 MOVE B,A ; TOP OF WORLD
2039 ADDI A,1777 ; PAGE BOUNDARY
2041 CAIL A,(B) ; SEE WHETHER THERE IS ROOM
2050 POP P,C ; RESTORE CAUSE INDICATOR
2052 PUSHJ P,CLEANT ; CLEAN UP
2053 SKIPL PLODR ; IF IN PLOAD DON'T INTERRUPT
2054 JRST INTAGC ; GO CAUSE GARBAGE COLLECT
2062 PUSHJ P,GETPAG ; GET THOSE PAGES
2063 FATAL CAN'T GET PAGES NEEDED
2065 ASH A,-10. ; TO PAGES
2068 CLNT1: PUSHJ P,RBLDM
2073 \f; RCLVEC DISTASTEFUL VECTOR RECYCLER
2075 ; Arrive here with B pointing to first recycler, A desired length
2077 RCLVEC: PUSH P,D ; Save registers
2080 MOVEI D,RCLV ; Point to previous recycle for splice
2081 RCLV1: HLRZ C,(B) ; Get size of this block
2082 CAIL C,(A) ; Skip if too small
2085 RCLV2: MOVEI D,(B) ; Save previous pointer
2086 HRRZ B,(B) ; Point to next block
2087 JUMPN B,RCLV1 ; Jump if more blocks
2092 JRST NORCL ; Go to normal allocator
2095 FOUND1: CAIN C,1(A) ; Exactly 1 greater?
2096 JRST RCLV2 ; Cant use this guy
2098 HRLM A,(B) ; Smash in new count
2099 TLO A,.VECT. ; make vector bit be on
2101 CAIE C,(A) ; Exactly right length?
2102 JRST FOUND2 ; No, do hair
2104 HRRZ C,(B) ; Point to next block
2105 HRRM C,(D) ; Smash previous pointer
2107 SUBI B,-1(A) ; Point to top of block
2110 FOUND2: SUBI C,(A) ; Amount of left over to C
2111 HRRZ E,(B) ; Point to next block
2113 SUBI B,(A) ; Point to dope words of guy to put back
2114 MOVSM C,(B) ; Smash in count
2115 MOVSI C,.VECT. ; Get vector bit
2116 MOVEM C,-1(B) ; Make sure it is a vector
2117 HRRM B,(D) ; Splice him in
2118 HRRM E,(B) ; And the next guy also
2119 ADDI B,1 ; Point to start of vector
2121 FOUND3: HRROI B,(B) ; Make an AOBJN pointer