--- /dev/null
+
+ TITLE STRBUILD MUDDLE STRUCTURE BUILDER
+
+.GLOBAL RCL,VECTOP,GCSTOP,GCSBOT,FRETOP,GCSNEW,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG
+.GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR,RCLV,RCLVEC
+.GLOBAL PGROW,TPGROW,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR,RBLDM,CPOPJ,CPOPJ1,STBL
+.GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,FREDIF,FREMIN,GCHAPN,INTFLG,PINIT,CKPUR,GCSET
+.GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2,MKTBS,CPOPJ1,.LIST.
+.GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS,SLEEPR,GCHK10,FPAG
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,C1CONS
+.GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,FRONT,%GCJOB,%SHWND,%INFMP,%GETIP
+.GLOBAL TD.PUT,TD.GET,TD.LNT,GLOTOP,UBIT,FLGSET,PURMNG,RPURBT,%IFMP2,CHKPGI,PURCLN
+.GLOBAL CTIME,MTYO,ILOC,NODES,GPURFL,GCDANG,GCHACK,LPUR,HITOP,BADCHN,IMPURX
+.GLOBAL NOWLVL,CURPLN,PVSTOR,SPSTOR,MPOPJ,NGCS,RNUMSP,NUMSWP,SAGC,INQAGC
+.GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC,GCRSET,ACCESS,NOSHUF,SQUPNT
+; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
+
+.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS
+.GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE
+.GLOBAL TPBINC,GBLINC,TYPINC,CONADJ,OGCSTP,ABOTN
+.GLOBAL AGC,ROOT,CIGTPR,IIGLOC
+.GLOBAL P.TOP,P.CORE,PMAPB
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM
+
+; SHARED SYMBOLS WITH GC MODULE
+
+.GLOBAL GCNO,BSTGC,BSTAT,NOWFRE,CURFRE,MAXFRE,USEFRE,NOWTP,CURTP,CTPMX,NOWLFL
+.GLOBAL CURLVL,NOWGVL,CURGVL,NOWTYP,CURTYP,NOWSTO,CURSTO,CURMAX,NOWP,CURP,CPMX
+.GLOBAL GCCAUS,GCCALL,LVLINC,GVLINC,TYPIC,STORIC,RCL,RCLV,GCDANG,GETNUM,RPTOP,CORTOP
+.GLOBAL TPGROW,PPGROW,PGROW,PMAIN,PGOOD,PMAX,TPGOOD,TPMIN,TPMAX,RFRETP,TYPTAB
+.GLOBAL NNPRI,NNSAT,TYPSAV,BUFGC,GCTIM,GPURFL,GCDFLG,DUMFLG,PMIN,PURMIN
+.GLOBAL GLBINC,GCHAIR,GCMONF,SQKIL,INBLOT
+.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
+.GLOBAL C%M20,C%M30,C%M40,C%M60
+
+NOPAGS==1 ; NUMBER OF WINDOWS
+EOFBIT==1000
+PDLBUF=100
+
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+RELOCATABLE
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+
+\f; GC-READ TAKES ONE ARGUMENT WHICH MUST BE A "READB" CHANNEL
+
+.GLOBAL CLOOKU,CINSER,MOBLIST,CATOM,EOFCND,IGLOC
+
+MFUNCTION GCREAD,SUBR,[GC-READ]
+
+ ENTRY
+
+ CAML AB,C%M2 ; CHECK # OF ARGS
+ JRST TFA
+ CAMGE AB,C%M40
+ JRST TMA
+
+ GETYP A,(AB) ; MAKE SURE ARG IS A CHANNEL
+ CAIE A,TCHAN
+ JRST WTYP2 ; IT ISN'T COMPLAIN
+ MOVE B,1(AB) ; GET PTR TO CHANNEL
+ HRRZ C,-2(B) ; LOOK AT BITS IN CHANNEL
+ TRC C,C.OPN+C.READ+C.BIN
+ TRNE C,C.OPN+C.READ+C.BIN
+ JRST BADCHN
+
+ PUSH P,1(B) ; SAVE ITS CHANNEL #
+IFN ITS,[
+ MOVE B,[-2,,C] ; SET UP AOBJN PTR TO READ IN DELIMITING
+ ; CONSTANTS
+ MOVE A,(P) ; GET CHANNEL #
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD-- IOT FAILED
+ JUMPL B,EOFGC ; IF BLOCK DIDN'T FINISH THEN EOF
+]
+IFE ITS,[
+ MOVE A,(P) ; GET CHANNEL
+ BIN
+ MOVE C,B ; TO C
+ BIN
+ MOVE D,B ; TO D
+ GTSTS ; SEE IF EOF
+ TLNE B,EOFBIT
+ JRST EOFGC
+]
+
+ PUSH P,C ; SAVE AC'S
+ PUSH P,D
+
+IFN ITS,[
+ MOVE B,[-3,,C] ; NEXT GROUP OF WORDS
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD--GC IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; GET CHANNEL
+ BIN
+ MOVE C,B
+ BIN
+ MOVE D,B
+ BIN
+ MOVE E,B
+]
+ MOVEI 0,0 ; DO PRELIMINARY TESTS
+ IOR 0,A ; IOR ALL WORDS IN
+ IOR 0,B
+ IOR 0,C
+ IOR 0,(P)
+ IOR 0,-1(P)
+ TLNE 0,-1 ; SKIP IF NO BITS IN LEFT HALF
+ JRST ERDGC
+
+ MOVEM D,NNPRI
+ MOVEM E,NNSAT
+ MOVE D,C ; GET START OF NEWTYPE TABLE
+ SUB D,-1(P) ; CREATE AOBJN POINTER
+ HRLZS D
+ ADDI D,(C)
+ MOVEM D,TYPTAB ; SAVE IT
+ MOVE A,(P) ; GET LENGTH OF WORD
+ SUBI A,CONADJ ; SUBTRACT FOR CONSTANTS
+
+ ADD A,GCSTOP
+ CAMG A,FRETOP ; SEE IF GC IS NESESSARY
+ JRST RDGC1
+ MOVE C,(P)
+ ADDM C,GETNUM ; MOVE IN REQUEST
+ MOVE C,[0,,1] ; ARGS TO GC
+ PUSHJ P,AGC ; GC
+RDGC1: MOVE C,GCSTOP ; GET CURRENT TOP OF THE WORLD
+ MOVEM C,OGCSTP ; SAVE IT
+ ADD C,(P) ; CALCULATE NEW GCSTOP
+ ADDI C,2 ; SUBTRACT FOR CONSTANTS
+ MOVEM C,GCSTOP
+ SUB C,OGCSTP
+ SUBI C,2 ; SUBSTRACT TO GET RID OF D.W'S
+ MOVNS C ; SET UP AOBJN PTR FOR READIN
+IFN ITS,[
+ HRLZS C
+ MOVE A,-2(P) ; GET CHANNEL #
+ ADD C,OGCSTP
+ DOTCAL IOT,[A,C]
+ FATAL GCREAD-- IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; CHANNEL TO A
+ MOVE B,OGCSTP ; SET UP BYTE POINTER
+ HRLI B,444400
+ SIN ; IN IT COMES
+]
+
+ MOVE C,(P) ; GET LENGHT OF OBJECT
+ ADDI A,5
+ MOVE B,1(AB) ; GET CHANNEL
+ ADDM C,ACCESS(B)
+ MOVE D,GCSTOP ; SET UP TO LOOK LIKE UVECTOR OF LOSES
+ ADDI C,2 ; ADD 2 FOR DOPE WORDS
+ HRLM C,-1(D)
+ MOVSI A,.VECT.
+ SETZM -2(D)
+ IORM A,-2(D) ; MARK VECTOR BIT
+ PUSH TP,$TRDTB ; HOLD ON IN CASE OF GC
+ MOVEI A,-2(D)
+ MOVN C,(P)
+ ADD A,C
+ HRL A,C
+ PUSH TP,A
+
+ MOVE D,-1(P) ; SET UP BOTTOM OF ATOM TABLE
+ SUBI D,1
+ MOVEM D,ABOTN
+ MOVE C,GCSTOP ; START AT TOP OF WORLD
+ SUBI C,3 ; POINT TO FIRST ATOM
+
+; LOOP TO FIX UP THE ATOMS
+
+AFXLP: HRRZ 0,1(TB)
+ ADD 0,ABOTN
+ CAMG C,0 ; SEE IF WE ARE DONE
+ JRST SWEEIN
+ HRRZ 0,1(TB)
+ SUB C,0
+ PUSHJ P,ATFXU ; FIX IT UP
+ HLRZ A,(C) ; GET LENGTH
+ TRZ A,400000 ; TURN OFF MARK BIT
+ SUBI C,(A) ; POINT TO PRECEDING ATOM
+ HRRZS C ; CLEAR OFF NEGATIVE
+ JRST AFXLP
+
+; FIXUP ROUTINE FOR ATOMS (C==> D.W.)
+
+ATFXU: PUSH P,C ; SAVE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE A,C
+ HLRZ B,(A) ; GET LENGTH AND MARKING
+ TRZE B,400000 ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED
+ JRST ATFXU1
+ MOVEI D,-3(B) ; FULL WORDS OF STRING IN PNAME
+ IMULI D,5 ; CALCULATE # OF CHARACTERS
+ MOVE 0,-2(A) ; GET LAST WORD OF STRING
+ SUBI A,-1(B) ; LET A POINT TO OBLIST SLOAT
+ MOVE B,A ; GET COPY OF A
+ MOVE A,0
+ SUBI A,1
+ ANDCM 0,A
+ JFFO 0,.+1
+ HRREI 0,-34.(A)
+ IDIVI 0,7 ; # OF CHARS IN LAST WORD
+ ADD D,0
+ ADD D,$TCHSTR ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD
+ PUSH P,D ; SAVE IT
+ MOVE C,(B) ; GET OBLIST SLOT PTR
+ATFXU9: HRRZS B ; RELATAVIZE POINTER
+ HRRZ 0,1(TB)
+ SUB B,0
+ PUSH P,B
+ JUMPE C,ATFXU6 ; NO OBLIST. CREATE ATOM
+ CAMN C,C%M1 ; SEE IF ROOT ATOM
+ JRST RTFX
+ ADD C,ABOTN ; POINT TO ATOM
+ PUSHJ P,ATFXU
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVE A,$TATOM ; SET UP TO SEE IF OBLIST EXITS
+ MOVE C,$TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,CIGTPR
+ JRST ATFXU8 ; NO OBLIST. CREATE ONE
+ SUB TP,C%22 ; GET RID OF SAVED ATOM
+RTCON: PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVE C,B ; SET UP FOR LOOKUP
+ MOVE A,-1(P) ; SET UP PTR TO PNAME
+ MOVE B,(P)
+ ADD B,[440700,,1] ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ PUSHJ P,CLOOKU
+ JRST ATFXU4 ; NOT ON IT SO INSERT
+ATFXU3: SUB P,C%22 ; DONE
+ SUB TP,C%22 ; POP OFF OBLIST
+ATFXU7: MOVE C,(P) ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVEM B,-1(C) ; MOVE IN RELATAVIZE ADDRESS
+ MOVSI D,400000
+ IORM D,(C) ; TURN OFF MARK BIT
+ MOVE 0,3(B) ; SEE IF MUST BE LOCR
+ TRNE 0,1 ; SKIP IF MUST MAKE IT IMPURE
+ PUSHJ P,IIGLOC
+ POP P,C
+ ADD C,1(TB)
+ POPJ P, ; EXIT
+ATFXU1: POP P,C ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE B,-1(C) ; GET ATOM
+ POPJ P,
+
+; ROUTINE TO INSERT AN ATOM
+
+ATFXU4: MOVE C,(TP) ; GET OBLIST PTR
+ MOVE B,(P) ; SET UP STRING PTR TO PNAME
+ ADD B,[440700,,1]
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P) ; GET TYPE WORD
+ PUSHJ P,CINSER ; INSERT IT
+ JRST ATFXU3
+
+; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST
+
+ATFXU6: MOVE B,(P) ; POINT TO PNAME
+ ADD B,[440700,,1] ; MAKE IT LOOK LIKE A BYTE POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P)
+ PUSHJ P,CATOM
+ SUB P,C%22 ; CLEAN OFF STACK
+ JRST ATFXU7
+
+; THIS ROUTINE CREATES AND OBLIST
+
+ATFXU8: MCALL 1,MOBLIST
+ PUSH TP,$TOBLS
+ PUSH TP,B ; SAVE OBLIST PTR
+ JRST ATFXU4 ; JUMP TO INSERT THE OBLIST
+
+; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST
+
+RTFX: MOVE B,ROOT+1 ; GET ROOT OBLIST
+ JRST RTCON
+
+; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS.
+
+SWEEIN:
+; ROUTINE TO FIX UP TYPE-TABLE FOR GC-READ. THIS ROUTINE FIXES UP THE TYPE TABLE SO THAT
+; THE TYPES ATOM I.D. IS REPLACED BY ITS TYPE-NUMBER IN THE NEW MUDDLE AND IF ITS A
+; TEMPLATE, THE SLOT FOR THE PRIMTYPE-ATOM IS REPLACED BY THE SAT OF THE TEMPLATE
+
+ HRRZ E,1(TB) ; SET UP TYPE TABLE
+ ADD E,TYPTAB
+ JUMPGE E,VUP ; SKIP OVER IF DONE
+TYPUP1: PUSH P,C%0 ; PUSH SLOT FOR POSSIBLE TEMPLATE ATOM
+ HLRZ A,1(E) ; GET POSSIBLE ATOM SLOT
+ JUMPE A,TYPUP2 ; JUMP IF NOT A TEMPLATE
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+ MOVE B,TYPVEC+1 ; GET TYPE VECTOR SLOT FOR LOOP TO SEE IF ITS THERE
+TYPUP3: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP4 ; FOUND ONE
+ ADD B,C%22 ; TO NEXT
+ JUMPL B,TYPUP3
+ JRST ERTYP1 ; ERROR NONE EXISTS
+TYPUP4: HRRZ C,(B) ; GET SAT SLOT
+ CAIG C,NUMSAT ; MAKE SURE TYPE IS A TEMPLATE
+ JRST ERTYP2 ; IF NOT COMPLAIN
+ HRLM C,1(E) ; SMASH IN NEW SAT
+ MOVE B,1(B) ; GET ATOM OF PRIMTYPE
+ MOVEM B,(P) ; PUSH ONTO STACK
+TYPUP2: MOVEI D,0 ; INITIALIZE TYPE COUNT FOR LOOKUP LOOP
+ MOVE B,TYPVEC+1 ; GET PTR FOR LOOP
+ HRRZ A,1(E) ; GET TYPE'S ATOM ID
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+TYPUP5: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP6 ; FOUND ONE
+ ADDI D,1 ; INCREMENT TYPE-COUNT
+ ADD B,C%22 ; POINT TO NEXT
+ JUMPL B,TYPUP5
+ HRRM D,1(E) ; CLOBBER IN TYPE-NUMBER
+ PUSH TP,$TATOM ; PUSH ARGS FOR NEWTYPE
+ PUSH TP,A
+ PUSH TP,$TATOM
+ POP P,B ; GET BACK POSSIBLE PRIMTYPE ATOM
+ JUMPE B,TYPUP7 ; JUMP IF NOT A TEMPLATE
+ PUSH TP,B ; PUSH ON PRIMTYPE
+TYPUP9: SUB E,1(TB)
+ PUSH P,E ; SAVE RELATAVIZED PTR TO TYPE-TABLE
+ MCALL 2,NEWTYPE
+ POP P,E ; RESTORE RELATAVIZED PTR
+ ADD E,1(TB) ; FIX IT UP
+TYPUP0: ADD E,C%22 ; INCREMENT E
+ JUMPL E,TYPUP1
+ JRST VUP
+TYPUP7: HRRZ B,(E) ; FIND PRIMTYPE FROM SAT
+ MOVE A,@STBL(B)
+ PUSH TP,A
+ JRST TYPUP9
+TYPUP6: HRRM D,1(E) ; CLOBBER IN TYPE #
+ JRST TYPUP0
+
+ERTYP1: ERRUUO EQUOTE CANT-FIND-TEMPLATE
+
+ERTYP2: ERRUUO EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE
+
+VUP: HRRZ E,1(TB) ; FIX UP SOME POINTERS
+ MOVEM E,OGCSTP
+ ADDM E,ABOTN
+ ADDM E,TYPTAB
+
+
+; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES.
+; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY.
+
+ HRRZ A,TYPTAB ; GET TO TOP OF WORLD
+ SUBI A,2 ; GET TO FIRST TYPE WORD OR DOPE-WORD OF FIRST OBJECT
+VUP1: CAMG A,OGCSTP ; SKIP IF NOT DONE
+ JRST VUP3
+ HLRZ B,(A) ; GET TYPE SLOT
+ TRNE B,.VECT. ; SKIP IF NOT A VECTOR
+ JRST VUP2
+ SUBI A,2 ; SKIP OVER PAIR
+ JRST VUP1
+VUP2: TRNE B,400000 ; SKIP IF UVECTOR
+ JRST VUP4
+ ANDI B,TYPMSK ; GET RID OF MONITORS
+ CAMG B,NNPRI ; SKIP IF NEWTYPE
+ JRST VUP5
+ PUSHJ P,GETNTP ; GET THE NEW TYPE #
+ PUTYP B,(A) ; SMASH IT IT
+VUP5: HLRZ B,1(A) ; SKIP OVER VECTOR
+ TRZ B,400000 ; GET RID OF POSSIBLE MARK BIT
+ SUBI A,(B)
+ JRST VUP1 ; LOOP
+VUP4: ANDI B,TYPMSK ; FLUSH MONITORS
+ CAMG B,NNSAT ; SKIP IF TEMPLATE
+ JRST VUP5
+ PUSHJ P,GETSAT ; CONVERT TO NEW SAT
+ ADDI B,.VECT. ; MAJIC TO TURN ON BIT
+ PUTYP B,(A)
+ JRST VUP5
+
+
+VUP3: PUSH P,GCSBOT ; SAVE CURRENT GCSBOT
+ MOVE A,OGCSTP ; SET UP NEW GCSBOT
+ MOVEM A,GCSBOT
+ PUSH P,GCSTOP
+ HRRZ A,TYPTAB ; SET UP NEW GCSTOP
+ MOVEM A,GCSTOP
+ SETOM GCDFLG
+ MOVE A,[PUSHJ P,RDFIX] ; INS FOR GCHACK
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ SETZM GCDFLG
+ POP P,GCSTOP ; RESTORE GCSTOP
+ MOVE A,1(TB) ; GET A POINTER TO RETURNING VALUES
+ MOVE B,A
+ HLRE C,B
+ SUB B,C
+ SETZM (B)
+ SETZM 1(B)
+ POP P,GCSBOT ; RESTORE GCSBOT
+ MOVE B,1(A) ; GET PTR TO OBJECTS
+ MOVE A,(A)
+ JRST FINIS ; EXIT
+
+; ERROR FOR INCORRECT GCREAD FILE
+
+ERDGC: ERRUUO EQUOTE BAD-GC-READ-FILE
+
+; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE
+
+RDFIX: PUSH P,C ; SAVE C
+ PUSH P,B ; SAVE PTR
+ EXCH B,C
+ TLNE C,UBIT ; SKIP IF NOT UVECTOR
+ JRST ELEFX ; DON'T HACK TYPES IN UVECTOR
+ CAIN B,TTYPEC
+ JRST TYPCFX
+ CAIN B,TTYPEW
+ JRST TYPWFX
+ CAML B,NNPRI
+ JRST TYPGFX
+ELEFX: EXCH B,A ; EXCHANGE FOR SAT
+ PUSHJ P,SAT
+ EXCH B,A ; REFIX
+ CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS
+ CAIN B,SATOM
+ JRST ATFX
+ CAIN B,SCHSTR
+ JRST STFX
+ CAIN B,S1WORD ; SEE IF PRIMTYPE WOR
+ JRST RDLSTF ; LEAVE IF IS
+STFXX: MOVE 0,GCSBOT ; ADJUSTMENT
+ SUBI 0,FPAG+5
+ SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL
+ ADDM 0,1(C) ; FIX UP
+RDLSTF: TLNN C,.LIST. ; SEE IF PAIR
+ JRST RDL1 ; EXIT
+ MOVE 0,GCSBOT ; FIX UP
+ SUBI 0,FPAG+5
+ HRRZ B,(C) ; SEE IF POINTS TO NIL
+ SKIPN B
+ JRST RDL1
+ MOVE B,C ; GET ARG FOR RLISTQ
+ PUSHJ P,RLISTQ
+ JRST RDL1
+ ADDM 0,(C)
+RDL1: POP P,B ; RESTORE B
+ POP P,C
+ POPJ P,
+
+; ROUTINE TO FIX UP PNAMES
+
+STFX: TLZN D,STATM
+ JRST STFXX
+ HLLM D,1(C) ; PUT BACK WITH BIT OFF
+ ADD D,ABOTN
+ ANDI D,-1
+ HLRE 0,-1(D) ; LENGTH OF ATOM
+ MOVNS 0
+ SUBI 0,3 ; VAL & OBLIST
+ IMULI 0,5 ; TO CHARS (SORT OF)
+ HRRZ D,-1(D)
+ ADDI D,2
+ PUSH P,A
+ PUSH P,B
+ LDB A,[360600,,1(C)] ; GET BYTE POS
+ IDIVI A,7 ; TO CHAR POS
+ SKIPE A
+ SUBI A,5
+ HRRZ B,(C) ; STRING LENGTH
+ SUB B,A ; TO WORD BOUNDARY STRING
+ SUBI 0,(B)
+ IDIVI 0,5
+ ADD D,0
+ POP P,B
+ POP P,A
+ HRRM D,1(C)
+ JRST RDLSTF
+
+; ROUTINE TO FIX UP POINTERS TO ATOMS
+
+ATFX: SKIPGE D
+ JRST RDLSTF
+ ADD D,ABOTN
+ MOVE 0,-1(D) ; GET PTR TO ATOM
+ CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR
+ JRST ATFXAT
+ MOVE B,0
+ PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSHJ P,IGLOC
+ SUB B,GLOTOP+1
+ MOVE 0,B
+ POP P,A
+ POP P,B
+ POP P,C
+ POP P,D
+ POP P,E
+ATFXAT: MOVEM 0,1(C) ; SMASH IT IN
+ JRST RDLSTF ; EXIT
+
+TYPCFX: HRRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRRM B,1(C) ; CLOBBER IT IN
+ JRST RDLSTF ; CONTINUE FIXUP
+
+TYPWFX: HLRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRLM B,1(C) ; SMASH IT IN
+ JRST ELEFX
+
+TYPGFX: PUSH P,D
+ PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE
+ POP P,D
+ PUTYP B,(C)
+ JRST ELEFX
+
+; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
+; EOF HANDLER ELSE USES CHANNELS.
+
+EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED
+ JRST MYCLOS ; USE CHANNELS
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ JRST CLOSIT
+MYCLOS: PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+CLOSIT: PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE ; CLOSE CHANNEL
+ MCALL 1,EVAL ; EVAL HIS EOF HANDLER
+ JRST FINIS
+
+; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
+
+GETNEW: CAMG B,NNPRI ;NEWTYPE
+ POPJ P,
+GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE
+GETNT1: HLRZ E,(D) ; GET TYPE #
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTTYP ; FOUND IT
+ ADD D,C%22 ; POINT TO NEXT
+ JUMPL D,GETNT1
+ SKIPA ; KEEP TYPE SAME
+GOTTYP: HRRZ B,1(D) ; GET NEW TYPE #
+ POPJ P,
+
+; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
+
+GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE
+GETSA1: HRRZ E,(D) ; GET OBJECT
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTSAT ; FOUND IT
+ ADD D,C%22
+ JUMPL D,GETSA1
+ FATAL GC-DUMP -- TYPE FIXUP FAILURE
+GOTSAT: HLRZ B,1(D) ; GET NEW SAT
+ POPJ P,
+
+
+; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
+RLISTQ: PUSH P,A
+ GETYP A,(B) ; GET TYPE
+ PUSHJ P,SAT ; GET SAT
+ CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
+ SKIPL MKTBS(A)
+ AOS -1(P) ; SKIP IF NOT DEFFERED
+ POP P,A
+ POPJ P, ; EXIT
+
+\f
+.GLOBAL FLIST
+
+MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
+
+ENTRY
+
+ JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT
+ GETYP A,(AB)
+ CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR
+ JRST WTYP1 ; IF NOT COMPLAIN
+ HLRE 0,1(AB)
+ MOVNS 0
+ CAIE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
+ JRST WTYP1
+ CAMGE AB,C%M20 ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
+ JRST TMA
+ MOVE A,(AB) ; GET THE UVECTOR
+ MOVE B,1(AB)
+ JRST SETUV ; CONTINUE
+GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR
+ PUSHJ P,IBLOCK
+SETUV: PUSH P,A ; SAVE UVECTOR
+ PUSH P,B
+ MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
+ SUB 0,RFRETP
+ ADD 0,GCSTOP
+ MOVEM 0,CURFRE
+ PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
+ HLRE 0,TP ; COMPUTE STACK SPACE USED UP
+ ADD 0,NOWTP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURTP
+ MOVE B,IMQUOTE THIS-PROCESS
+ PUSHJ P,ILOC
+ HRRZS B
+ MOVE PVP,PVSTOR+1
+ HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
+ MOVE 0,B
+ HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS
+ SUB 0,D
+ IDIVI 0,6
+ MOVEM 0,CURLVL
+ SUB B,C ; TOTAL WORDS ATOM STORAGE
+ IDIVI B,6 ; COMPUTE # OF SLOTS
+ MOVEM B,NOWLVL
+ HRRZ A,GLOBASE+1 ; COMPUTE TOTAL # OF GLOBAL SLOTS
+ HLRE 0,GLOBASE+1
+ SUB A,0 ; POINT TO DOPE WORD
+ HLRZ B,1(A)
+ ASH B,-2 ; # OF GVAL SLOTS
+ MOVEM B,NOWGVL
+ HRRZ A,GLOTOP+1 ; COMPUTE # OF GVAL SLOTS IN USE
+ HRRZ 0,GLOBSP+1
+ SUB A,0
+ ASH A,-2 ; NEGATIVE # OF SLOTS USED
+ MOVEM A,CURGVL
+ HRRZ A,TYPBOT+1 ; GET LENGTH OF TYPE VECTOR
+ HLRE 0,TYPBOT+1
+ SUB A,0
+ HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR
+ IDIVI B,2 ; CONVERT TO # OF TYPES
+ MOVEM B,NOWTYP
+ HLRE 0,TYPVEC+1 ; LENGTH OF VISABLE TYPE-VECTOR
+ MOVNS 0
+ IDIVI 0,2 ; GET # OF TYPES
+ MOVEM 0,CURTYP
+ MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE
+ MOVEM 0,NOWSTO
+ SETZB B,D ; ZERO OUT MAXIMUM
+ HRRZ C,FLIST
+LOOPC: HLRZ 0,(C) ; GET BLK LENGTH
+ ADD D,0 ; ADD # OF WORDS IN BLOCK
+ CAMGE B,0 ; SEE IF NEW MAXIMUM
+ MOVE B,0
+ HRRZ C,(C) ; POINT TO NEXT BLOCK
+ JUMPN C,LOOPC ; REPEAT
+ MOVEM D,CURSTO
+ MOVEM B,CURMAX
+ HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P
+ ADD 0,NOWP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURP
+ MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES
+ HRRZ B,(P) ; RESTORE B
+ HRR C,B
+ BLT C,(B)STATGC-1
+ HRLI C,BSTAT ; MODIFY BLT FOR STATS
+ HRRI C,STATGC(B)
+ BLT C,(B)STATGC+STATNO-1
+ MOVEI 0,TFIX+.VECT.
+ HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE
+ POP P,B
+ POP P,A ; RESTORE TYPE-WORD
+ JRST FINIS
+
+GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST
+ MOVE 0,[GCNO,,GCNO+1]
+ BLT 0,GCCALL
+ JRST GCSET
+
+
+
+\f
+.GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
+
+; USER GARBAGE COLLECTOR INTERFACE
+.GLOBAL ILVAL
+
+MFUNCTION GC,SUBR
+ ENTRY
+
+ JUMPGE AB,GC1
+ CAMGE AB,C%M60 ; [-6,,0]
+ JRST TMA
+ PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN
+ SKIPE A ; SKIP FOR 0 ARGUMENT
+ MOVEM A,FREMIN
+GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE
+ PUSH P,A
+ CAML AB,C%M40 ; [-4,,0] ; SEE IF 3RD ARG
+ JRST GC5
+ GETYP A,4(AB) ; MAKE SURE A FIX
+ CAIE A,TFIX
+ JRST WTYP ; ARG WRONG TYPE
+ MOVE A,5(AB)
+ MOVEM A,RNUMSP
+ MOVEM A,NUMSWP
+GC5: CAML AB,C%M20 ; [-2,,0] ; SEE IF SECOND ARG
+ JRST GC3
+ GETYP A,2(AB) ; SEE IF NONFALSE
+ CAIE A,TFALSE ; SKIP IF FALSE
+ JRST HAIRGC ; CAUSE A HAIRY GC
+GC3: MOVSI A,TATOM ; CHECK TO SEE IF INTERRUPT FLAG IS ON
+ MOVE B,IMQUOTE AGC-FLAG
+ PUSHJ P,ILVAL
+ CAMN A,$TUNBOUND ; SKIP IF NOT UNBOUND
+ JRST GC2
+ SKIPE GCHPN ; SKIP IF GCHAPPEN IS 0
+ JRST FALRTN ; JUMP TO RETURN FALSE
+GC2: MOVE C,[9.,,0]
+ PUSHJ P,AGC ; COLLECT THAT TRASH
+ PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?
+ POP P,B ; RETURN AMOUNT
+ SUB B,A
+ MOVSI A,TFIX
+ JRST FINIS
+HAIRGC: MOVE B,3(AB)
+ CAIN A,TFIX ; IF FIX THEN CLOBBER NGCS
+ MOVEM B,NGCS
+ MOVEI A,1 ; FORCE VALUE FLUSHING PHASE TO OCCUR
+ MOVEM A,GCHAIR
+ JRST GC2 ; HAIRY GC OCCORS NO MATTER WHAT
+FALRTN: MOVE A,$TFALSE
+ MOVEI B,0 ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR
+ JRST FINIS
+
+
+COMPRM: MOVE A,GCSTOP ; USED SPACE
+ SUB A,GCSBOT
+ POPJ P,
+
+\f
+MFUNCTION GCDMON,SUBR,[GC-MON]
+
+ ENTRY
+
+ MOVEI E,GCMONF
+
+FLGSET: MOVE C,(E) ; GET CURRENT VALUE
+ JUMPGE AB,RETFLG ; RET CURRENT
+ CAMGE AB,C%M20 ; [-3,,]
+ JRST TMA
+ GETYP 0,(AB)
+ SETZM (E)
+ CAIN 0,TFALSE
+ SETOM (E)
+ SKIPL E
+ SETCMM (E)
+
+RETFLG: SKIPL E
+ SETCMM C
+ JUMPL C,NOFLG
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+NOFLG: MOVEI B,0
+ MOVSI A,TFALSE
+ JRST FINIS
+
+.GLOBAL EVATYP,APLTYP,PRNTYP
+
+\fMFUNCTION BLOAT,SUBR
+ ENTRY
+
+ PUSHJ P,SQKIL
+ MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC
+ MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE
+
+BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?
+ PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM
+ SKIPE A
+ PUSHJ P,@BLOATER(E) ; DISPATCH
+ AOBJN E,BLOAT2 ; COUNT PARAMS SET
+
+ JUMPL AB,TMA ; ANY LEFT...ERROR
+BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED
+ MOVE C,E ; MOVE IN INDICATOR
+ HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT
+ SETOM INBLOT
+ PUSHJ P,AGC ; DO ONE
+ SKIPE A,TPBINC ; SMASH POINNTERS
+ MOVE PVP,PVSTOR+1
+ ADDM A,TPBASE+1(PVP)
+ SKIPE A,GLBINC ; GLOBAL SP
+ ADDM A,GLOBASE+1
+ SKIPE A,TYPINC
+ ADDM A,TYPBOT+1
+ SETZM TPBINC ; RESET PARAMS
+ SETZM GLBINC
+ SETZM TYPINC
+
+BLOATD: SKIPN A,GETNUM ; SKIP IF FREE STORAGE REQUEST IN EFFECT
+ JRST BLTFN
+ ADD A,FRETOP ; ADD FRETOP
+ ADDI A,1777 ; ONE BLOCK FOR MARK PDL AND ROUND
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ CAML A,PURBOT ; SKIP IF POSSIBLE TO WIN
+ JRST BLFAGC
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE ; GRET THE CORE
+ JRST BLFAGC ; LOSE LOSE LOSE
+ MOVE A,FRETOP ; CALCULATE NEW PARAMETERS
+ MOVEM A,RFRETP
+ MOVEM A,CORTOP
+ MOVE B,GCSTOP
+ SETZM 1(B)
+ HRLI B,1(B)
+ HRRI B,2(B)
+ BLT B,-1(A) ; ZERO CORE
+BLTFN: SETZM GETNUM
+ MOVE B,FRETOP
+ SUB B,GCSTOP
+ MOVSI A,TFIX ; RETURN CORE FOUND
+ JRST FINIS
+BLFAGC: MOVN A,FREMIN
+ ADDM A,GETNUM ; FIX UP SO BLOATS CORRECTLY
+ MOVE C,C%11 ; INDICATOR FOR AGC
+ PUSHJ P,AGC ; GARBAGE COLLECT
+ JRST BLTFN ; EXIT
+
+; TABLE OF BLOAT ROUTINES
+
+BLOATER:
+ MAINB
+ TPBLO
+ LOBLO
+ GLBLO
+ TYBLO
+ STBLO
+ PBLO
+ SFREM
+ SLVL
+ SGVL
+ STYP
+ SSTO
+ PUMIN
+ PMUNG
+ TPMUNG
+ NBLO==.-BLOATER
+
+; BLOAT MAIN STORAGE AREA
+
+MAINB: SETZM GETNUM
+ MOVE D,FRETOP ; COMPUTE CURRENT ROOM
+ SUB D,PARTOP
+ CAMGE A,D ; NEED MORE?
+ POPJ P, ; NO, LEAVE
+ SUB A,D
+ MOVEM A,GETNUM ; SAVE
+ POPJ P,
+
+; BLOAT TP STACK (AT TOP)
+
+TPBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ SUB A,B ; SKIP IF GROWTH NEEDED
+ JUMPLE A,CPOPJ
+ ADDI A,63.
+ ASH A,-6 ; CONVERT TO 64 WD BLOCKS
+ CAILE A,377
+ JRST OUTRNG
+ DPB A,[111100,,-1(D)] ; SMASH SPECS IN
+ AOJA C,CPOPJ
+
+; BLOAT TOP LEVEL LOCALS
+
+LOBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ CAMG A,B ; SKIP IF GROWTH NEEDED
+ IMULI A,6 ; 6 WORDS PER BINDING
+ MOVE PVP,PVSTOR+1
+ HRRZ 0,TPBASE+1(PVP)
+ HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E
+ SUB B,0
+ SUBI A,(B) ; HOW MUCH MORE?
+ JUMPLE A,CPOPJ ; NONE NEEDED
+ MOVEI B,TPBINC
+ PUSHJ P,NUMADJ
+ DPB A,[1100,,-1(D)] ; SMASH
+ AOJA C,CPOPJ
+
+; GLOBAL SLOT GROWER
+
+GLBLO: ASH A,2 ; 4 WORDS PER VAR
+ MOVE D,GLOBASE+1 ; CURRENT LIMITS
+ HRRZ B,GLOBSP+1
+ SUBI B,(D)
+ SUBI A,(B) ; NEW AMOUNT NEEDED
+ JUMPLE A,CPOPJ
+ MOVEI B,GLBINC ; WHERE TO KEEP UPDATE
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D
+ SUB D,0 ; POINT TO DOPE
+ DPB A,[1100,,(D)] ; AND SMASH
+ AOJA C,CPOPJ
+
+; HERE TO GROW TYPE VECTOR (AND FRIENDS)
+
+TYBLO: ASH A,1 ; TWO WORD PER TYPE
+ HRRZ B,TYPVEC+1 ; FIND CURRENT ROOM
+ MOVE D,TYPBOT+1
+ SUBI B,(D)
+ SUBI A,(B) ; EXTRA NEEDED TO A
+ JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE
+ MOVEI B,TYPINC ; WHERE TO STASH SPEC
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D ; POINT TO DOPE
+ SUB D,0
+ DPB A,[1100,,(D)]
+ SKIPE D,EVATYP+1 ; GROW AUX TYPE VECS IF NEEDED
+ PUSHJ P,SGROW1
+ SKIPE D,APLTYP+1
+ PUSHJ P,SGROW1
+ SKIPE D,PRNTYP+1
+ PUSHJ P,SGROW1
+ AOJA C,CPOPJ
+
+; HERE TO CREATE STORAGE SPACE
+
+STBLO: MOVE D,GCSBOT ; HOW MUCH NOW HERE
+ SUB D,CODTOP
+ SUBI A,(D) ; MORE NEEDED?
+ JUMPLE A,CPOPJ
+ MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT
+ AOJA C,CPOPJ
+
+; BLOAT P STACK
+
+PBLO: HLRE D,P
+ MOVNS B,D
+ SUBI D,5 ; FUDGE FOR THIS CALL
+ SUBI A,(D)
+ JUMPLE A,CPOPJ
+ ADDI B,1(P) ; POINT TO DOPE
+ CAME B,PGROW ; BLOWN?
+ ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.
+ ADDI A,63.
+ ASH A,-6 ; TO 64 WRD BLOCKS
+ CAILE A,377 ; IN RANGE?
+ JRST OUTRNG
+ DPB A,[111100,,-1(B)]
+ AOJA C,CPOPJ
+
+; SET FREMIN
+
+SFREM: SKIPE A ; DON'T ZERO EMPTY PARAMETER
+ MOVEM A,FREMIN
+ POPJ P,
+
+; SET LVAL INCREMENT
+
+SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B
+ MOVEI B,LVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,LVLINC
+ POPJ P,
+
+; SET GVAL INCREMENT
+
+SGVL: IMULI A,4. ; # OF SLOTS
+ MOVEI B,GVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,GVLINC
+ POPJ P,
+
+; SET TYPE INCREMENT
+
+STYP: IMULI A,2 ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
+ MOVEI B,TYPIC
+ PUSHJ P,NUMADJ
+ MOVEM A,TYPIC
+ POPJ P,
+
+; SET STORAGE INCREMENT
+
+SSTO: IDIVI A,2000 ; # OF BLOCKS
+ CAIE B,0 ; REMAINDER?
+ ADDI A,1
+ IMULI A,2000 ; CONVERT BACK TO WORDS
+ MOVEM A,STORIC
+ POPJ P,
+; HERE FOR MINIMUM PURE SPACE
+
+PUMIN: ADDI A,1777
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVEM A,PURMIN
+ POPJ P,
+
+; HERE TO ADJUST PSTACK PARAMETERS IN GC
+
+PMUNG: ADDI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ ANDCMI A,777
+ MOVEM A,PGOOD ; PGOOD
+ ASH A,2 ; PMAX IS 4*PGOOD
+ MOVEM A,PMAX
+ ASH A,-4 ; PMIN IS .25*PGOOD
+ MOVEM A,PMIN
+
+; HERE TO ADJUST GC TPSTACK PARAMS
+
+TPMUNG: ADDI A,777
+ ANDCMI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ MOVEM A,TPGOOD
+ ASH A,2 ; TPMAX= 4*TPGOOD
+ MOVEM A,TPMAX
+ ASH A,-4 ; TPMIN= .25*TPGOOD
+ MOVEM A,TPMIN
+
+
+; GET NEXT (FIX) ARG
+
+NXTFIX: PUSHJ P,GETFIX
+ ADD AB,C%22
+ POPJ P,
+
+; ROUTINE TO GET POS FIXED ARG
+
+GETFIX: GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WRONGT
+ SKIPGE A,1(AB)
+ JRST BADNUM
+ POPJ P,
+
+
+; GET NUMBERS FIXED UP FOR GROWTH FIELDS
+
+NUMADJ: ADDI A,77 ; ROUND UP
+ ANDCMI A,77 ; KILL CRAP
+ MOVE 0,A
+ MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
+ HRLI A,-1(A)
+ MOVEM A,(B) ; AND STASH IT
+ MOVE A,0
+ ASH A,-6 ; TO 64 WD BLOCKS
+ CAILE A,377 ; CHECK FIT
+ JRST OUTRNG
+ POPJ P,
+
+; DO SYMPATHETIC GROWTHS
+
+SGROW1: HLRE 0,D
+ SUB D,0
+ DPB A,[111100,,(D)]
+ POPJ P,
+
+\f;FUNCTION TO CONSTRUCT A LIST
+
+MFUNCTION CONS,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB) ;GET TYPE OF 2ND ARG
+ CAIE A,TLIST ;LIST?
+ JRST WTYP2 ;NO , COMPLAIN
+ MOVE C,(AB) ; GET THING TO CONS IN
+ MOVE D,1(AB)
+ HRRZ E,3(AB) ; AND LIST
+ PUSHJ P,ICONS ; INTERNAL CONS
+ JRST FINIS
+
+; COMPILER CALL TO CONS
+
+C1CONS: PUSHJ P,ICELL2
+ JRST ICONS2
+ICONS4: HRRI C,(E)
+ICONS3: MOVEM C,(B) ; AND STORE
+ MOVEM D,1(B)
+TLPOPJ: MOVSI A,TLIST
+ POPJ P,
+
+; INTERNAL CONS--ICONS; C,D VALUE, E CDR
+
+; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE
+; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED
+; TO: DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS.
+
+CICONS: SUBM M,(P)
+ PUSHJ P,ICONS
+ JRST MPOPJ
+
+; INTERNAL CONS TO NIL--INCONS
+
+INCONS: MOVEI E,0
+
+ICONS: GETYP A,C ; CHECK TYPE OF VAL
+ PUSHJ P,NWORDT ; # OF WORDS
+ SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED
+ PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
+ JRST ICNS2A ; NO CORE, GO GC (SPECIAL PLACE, NOTICE)
+ JRST ICONS4
+
+; HERE IF CONSING DEFERRED
+
+ICONS1: MOVEI A,4 ; NEED 4 WORDS
+ PUSHJ P,ICELL ; GO GET 'EM
+ JRST ICNS2A ; NOT THERE, GC (SAME PLACE AS FOR ICONS)
+ HRLI E,TDEFER ; CDR AND DEFER
+ MOVEM E,(B) ; STORE
+ MOVEI E,2(B) ; POINT E TO VAL CELL
+ HRRZM E,1(B)
+ MOVEM C,(E) ; STORE VALUE
+ MOVEM D,1(E)
+ JRST TLPOPJ
+
+
+
+; HERE TO GC ON A CONS
+
+; HERE FROM C1CONS
+ICONS2: SUBM M,(P)
+ PUSHJ P,ICONSG
+ SUBM M,(P)
+ JRST C1CONS
+
+; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
+ICNS2A: PUSHJ P,ICONSG
+ JRST ICONS
+
+; REALLY DO GC
+ICONSG: PUSH TP,C ; SAVE VAL
+ PUSH TP,D
+ PUSH TP,$TLIST
+ PUSH TP,E ; SAVE VITAL STUFF
+ ADDM A,GETNUM ; AMOUNT NEEDED
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC ; ATTEMPT TO WIN
+ MOVE D,-2(TP) ; RESTORE VOLATILE STUFF
+ MOVE C,-3(TP)
+ MOVE E,(TP)
+ SUB TP,C%44 ; [4,,4]
+ POPJ P, ; BACK TO DRAWING BOARD
+
+; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED
+
+CELL2: MOVEI A,2 ; USUAL CASE
+CELL: PUSHJ P,ICELL ; INTERNAL
+ JRST .+2 ; LOSER
+ POPJ P,
+
+ ADDM A,GETNUM ; AMOUNT REQUIRED
+ PUSH P,A ; PREVENT AGC DESTRUCTION
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ JRST CELL ; AND TRY AGAIN
+
+; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
+
+ICELL2: MOVEI A,2 ; MOST LIKELY CAE
+ICELL: SKIPE B,RCL
+ JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL
+ MOVE B,PARTOP ; GET TOP OF PAIRS
+ ADDI B,(A) ; BUMP
+ CAMLE B,FRETOP ; SKIP IF OK.
+ JRST VECTRY ; LOSE
+ EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER
+ ADDM A,USEFRE
+ JRST CPOPJ1 ; SKIP RETURN
+
+; TRY RECYCLING USING A VECTOR FROM RCLV
+
+VECTRY: SKIPN B,RCLV ; SKIP IF VECTOR EXISTS
+ POPJ P,
+ PUSH P,C
+ PUSH P,A
+ MOVEI C,RCLV
+VECTR1: HLRZ A,(B) ; GET LENGTH
+ SUB A,(P)
+ JUMPL A,NXTVEC ; DOESN'T SATISFY TRY AGAIN
+ CAIN A,1 ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
+ JRST NXTVEC
+ JUMPN A,SOML ; SOME ARE LEFT
+ HRRZ A,(B)
+ HRRM A,(C)
+ HLRZ A,(B)
+ SETZM (B)
+ SETZM -1(B) ; CLEAR DOPE WORDS
+ SUBI B,-1(A)
+ POP P,A ; CLEAR STACK
+ POP P,C
+ JRST CPOPJ1
+SOML: HRLM A,(B) ; SMASH AMOUNT LEFT
+ SUBI B,-1(A) ; GET TO BEGINNING
+ SUB B,(P)
+ POP P,A
+ POP P,C
+ JRST CPOPJ1
+NXTVEC: MOVEI C,(B)
+ HRRZ B,(B) ; GET NEXT
+ JUMPN B,VECTR1
+ POP P,A
+ POP P,C
+ POPJ P,
+
+ICELRC: CAIE A,2
+ JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD
+ PUSH P,A
+ MOVE A,(B)
+ HRRZM A,RCL
+ POP P,A
+ SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL
+ SETZM 1(B)
+ JRST CPOPJ1 ;THAT IT
+
+
+\f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
+
+IMFUNCTION LIST,SUBR
+ ENTRY
+
+ PUSH P,$TLIST
+LIST12: HLRE A,AB ;GET -NUM OF ARGS
+ PUSH TP,$TAB
+ PUSH TP,AB
+ MOVNS A ;MAKE IT +
+ JUMPE A,LISTN ;JUMP IF 0
+ SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME
+ JRST LST12R ;TO GET RECYCLED CELLS
+ PUSHJ P,CELL ;GET NUMBER OF CELLS
+ PUSH TP,(P) ;SAVE IT
+ PUSH TP,B
+ SUB P,C%11
+ LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS
+
+CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS
+ HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE
+ SOJG A,.-2 ;LOOP TIL ALL DONE
+ CLEARM B,-2(B) ;SET THE LAST CDR TO NIL
+
+; NOW LOBEER THE DATA IN TO THE LIST
+
+ MOVE D,AB ; COPY OF ARG POINTER
+ MOVE B,(TP) ;RESTORE LIS POINTER
+LISTLP: GETYP A,(D) ;GET TYPE
+ PUSHJ P,NWORDT ;GET NUMBER OF WORDS
+ SOJN A,LDEFER ;NEED TO DEFER POINTER
+ GETYP A,(D) ;NOW CLOBBER ELEMENTS
+ HRLM A,(B)
+ MOVE A,1(D) ;AND VALUE..
+ MOVEM A,1(B)
+LISTL2: HRRZ B,(B) ;REST B
+ ADD D,C%22 ;STEP ARGS
+ JUMPL D,LISTLP
+
+ POP TP,B
+ POP TP,A
+ SUB TP,C%22 ; CLEANUP STACK
+ JRST FINIS
+
+
+LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS
+ JUMPE A,LISTN
+ PUSH P,A ;SAVE COUNT ON STACK
+ SETZM E
+ SETZB C,D
+ PUSHJ P,ICONS
+ MOVE E,B ;LOOP AND CHAIN TOGETHER
+ SOSLE (P)
+ JRST .-4
+ PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT
+ PUSH TP,B
+ SUB P,C%22 ;CLEAN UP AFTER OURSELVES
+ JRST LISTLP-2 ;AND REJOIN MAIN STREAM
+
+
+; MAKE A DEFERRED POINTER
+
+LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER
+ PUSH TP,B
+ MOVEM D,1(TB) ; SAVE ARG HACKER
+ PUSHJ P,CELL2
+ MOVE D,1(TB)
+ GETYPF A,(D) ;GET FULL DATA
+ MOVE C,1(D)
+ MOVEM A,(B)
+ MOVEM C,1(B)
+ MOVE C,(TP) ;RESTORE LIST POINTER
+ MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE
+ MOVSI A,TDEFER
+ HLLM A,(C) ;AND STORE IT
+ MOVE B,C
+ SUB TP,C%22
+ JRST LISTL2
+
+LISTN: MOVEI B,0
+ POP P,A
+ JRST FINIS
+
+; BUILD A FORM
+
+IMFUNCTION FORM,SUBR
+
+ ENTRY
+
+ PUSH P,$TFORM
+ JRST LIST12
+
+\f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
+
+IILIST: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TLIST
+ JRST MPOPJ
+
+IIFORM: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TFORM
+ JRST MPOPJ
+
+IILST: JUMPE A,IILST0 ; NIL WHATSIT
+ PUSH P,A
+ MOVEI E,0
+IILST1: POP TP,D
+ POP TP,C
+ PUSHJ P,ICONS ; CONS 'EM UP
+ MOVEI E,(B)
+ SOSE (P) ; COUNT
+ JRST IILST1
+
+ SUB P,C%11
+ POPJ P,
+
+IILST0: MOVEI B,0
+ POPJ P,
+
+\f;FUNCTION TO BUILD AN IMPLICIT LIST
+
+MFUNCTION ILIST,SUBR
+ ENTRY
+ PUSH P,$TLIST
+ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NO MORE THAN TWO ARGS
+ JRST TMA
+ PUSHJ P,GETFIX ; GET POS FIX #
+ JUMPE A,LISTN ;EMPTY LIST ?
+ CAML AB,C%M20 ; [-2,,0] ;ONLY ONE ARG?
+ JRST LOSEL ;YES
+ PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
+ILIST0: PUSH TP,2(AB)
+ PUSH TP,(AB)3
+ MCALL 1,EVAL
+ PUSH TP,A
+ PUSH TP,B
+ SOSLE (P)
+ JRST ILIST0
+ POP P,C
+ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH
+ ACALL C,LIST
+ILIST3: POP P,A ; GET FINAL TYPE
+ JRST FINIS
+
+
+LOSEL: PUSH P,A ; SAVE COUNT
+ MOVEI E,0
+
+LOSEL1: SETZB C,D ; TLOSE,,0
+ PUSHJ P,ICONS
+ MOVEI E,(B)
+ SOSLE (P)
+ JRST LOSEL1
+
+ SUB P,C%11
+ JRST ILIST3
+
+; IMPLICIT FORM
+
+MFUNCTION IFORM,SUBR
+
+ ENTRY
+ PUSH P,$TFORM
+ JRST ILIST2
+
+\f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
+
+MFUNCTION VECTOR,SUBR,[IVECTOR]
+
+ MOVEI C,1
+ JRST VECTO3
+
+MFUNCTION UVECTOR,SUBR,[IUVECTOR]
+
+ MOVEI C,0
+VECTO3: ENTRY
+ JUMPGE AB,TFA ; AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NOT MORE THAN 2
+ JRST TMA
+ PUSHJ P,GETFIX ; GET A POS FIXED NUMBER
+ LSH A,(C) ; A-> NUMBER OF WORDS
+ PUSH P,C ; SAVE FOR LATER
+ PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)
+ POP P,C
+ HLRE A,B ; START TO
+ SUBM B,A ; FIND DOPE WORD
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(A)
+ JUMPE C,VECTO4
+ MOVSI D,400000 ; GET NOT UNIFORM BIT
+ IORM D,(A) ; INTO DOPE WORD
+ SKIPA A,$TVEC ; GET TYPE
+VECTO4: MOVSI A,TUVEC
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
+ JRST FINIS
+ JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE
+
+ PUSH TP,A ; SAVE THE VECTOR
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+
+ JUMPE C,UINIT
+ JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE
+INLP: PUSHJ P,IEVAL ; EVAL EXPR
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ ADD C,C%22 ; BUMP VECTOR
+ MOVEM C,(TP)
+ JUMPL C,INLP ; IF MORE DO IT
+
+GETVEC: MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ SUB TP,C%44 ; [4,,4]
+ JRST FINIS
+
+; HERE TO FILL UP A UVECTOR
+
+UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE
+ GETYP A,A ; GET TYPE
+ PUSH P,A ; SAVE TYPE
+ PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED
+ SOJN A,CANTUN ; COMPLAIN
+STJOIN: MOVE C,(TP) ; RESTORE POINTER
+ ADD C,1(AB) ; POINT TO DOPE WORD
+ MOVE A,(P) ; GET TYPE
+ HRLZM A,(C) ; STORE IN D.W.
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(C)
+ MOVE C,(TP) ; GET BACK VECTOR
+ SKIPE 1(AB)
+ JRST UINLP1 ; START FILLING UV
+ JRST GETVE1
+
+UINLP: MOVEM C,(TP) ; SAVE PNTR
+ PUSHJ P,IEVAL ; EVAL THE EXPR
+ GETYP A,A ; GET EVALED TYPE
+ CAIE A,@(P) ; WINNER?
+ JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE
+UINLP1: MOVEM B,(C) ; STORE
+ AOBJN C,UINLP
+GETVE1: SUB P,C%11
+ JRST GETVEC ; AND RETURN VECTOR
+
+IEVAL: PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ MCALL 1,EVAL
+ MOVE C,(TP)
+ POPJ P,
+
+; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
+
+MFUNCTION ISTORAGE,SUBR
+ ENTRY
+ JUMPGE AB,TFA
+ CAMGE AB,C%M40 ; [-4,,0] ; AT LEAST ONE ARG
+ JRST TMA
+ PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG
+ PUSHJ P,CAFRE ; GET CORE
+ MOVN B,1(AB) ; -COUNT
+ HRL A,B ; PUT IN LHW (A)
+ MOVM B,B ; +COUNT
+ HRLI B,2(B) ; LENGTH + 2
+ ADDI B,(A) ; MAKE POINTER TO DOPE WORDS
+ HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE
+ HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
+ MOVE B,A
+ MOVSI A,TSTORAGE
+ CAML AB,C%M20 ; [-2,,0] ; SECOND ARG TO EVAL?
+ JRST FINIS ; IF NOT, RETURN EMPTY
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE
+ GETYP A,A
+ PUSH P,A ; FOR COMPARISON LATER
+ PUSHJ P,SAT
+ CAIN A,S1WORD
+ JRST STJOIN ;TREAT LIKE A UVECTOR
+; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
+ PUSHJ P,FREESV ; FREE STORAGE VECTOR
+ ERRUUO EQUOTE DATA-CANT-GO-IN-STORAGE
+
+; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
+FREESV: MOVE A,1(AB) ; GET COUNT
+ ADDI A,2 ; FOR DOPE
+ HRRZ B,(TP) ; GET ADDRESS
+ PUSHJ P,CAFRET ; FREE THE CORE
+ POPJ P,
+
+\f
+; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
+
+IBLOK1: ASH A,1 ; TIMES 2
+GIBLOK: TLOA A,400000 ; FUNNY BIT
+IBLOCK: TLZ A,400000 ; NO BIT ON
+ TLO A,.VECT. ; TURN ON BIT FOR GCHACK
+ ADDI A,2 ; COMPENSATE FOR DOPE WORDS
+IBLOK2: SKIPE B,RCLV ; ANY TO RECYCLE?
+ JRST RCLVEC
+NORCL: MOVE B,GCSTOP ; POINT TO BOTTOM OF SPACE
+ PUSH P,B ; SAVE TO BUILD PTR
+ ADDI B,(A) ; ADD NEEDED AMOUNT
+ CAML B,FRETOP ; SKIP IF NO GC NEEDED
+ JRST IVECT1
+ MOVEM B,GCSTOP ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
+ ADDM A,USEFRE
+ HRRZS USEFRE
+ HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD
+ HLLZM A,-2(B) ; AND BIT
+ HRRM B,-1(B) ; SMASH IN RELOCATION
+ SOS -1(B)
+ POP P,B ; RESTORE PTR TO BOTTOM OF VECTOR
+ HRROS B ; POINT TO START OF VECTOR
+ TLC B,-3(A) ; SETUP COUNT
+ HRRI A,TVEC
+ SKIPL A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POPJ P,
+
+; HERE TO DO A GC ON A VECTOR ALLOCATION
+
+IVECT1: PUSH P,0
+ PUSH P,A ; SAVE DESIRED LENGTH
+ HRRZ 0,A
+ ADDM 0,GETNUM ; AND STORE AS DESIRED AMOUNT
+ MOVE C,[4,,1] ; GET INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ POP P,0
+ POP P,B
+ JRST IBLOK2
+
+
+; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
+; ITEMS ON TOP OF STACK
+
+IEVECT: ASH A,1 ; TO NUMBER OF WORDS
+ PUSH P,A
+ PUSHJ P,IBLOCK ; GET VECTOR
+ HLRE D,B ; FIND DW
+ SUBM B,D ; A POINTS TO DW
+ MOVSI 0,400000+.VECT.
+ MOVEM 0,(D) ; CLOBBER NON UNIF BIT
+ POP P,A ; RESTORE COUNT
+ JUMPE A,IVEC1 ; 0 LNTH, DONE
+ MOVEI C,(TP) ; BUILD BLT
+ SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK
+ MOVSI C,(C)
+ HRRI C,(B) ; B/ SOURCE,,DEST
+ BLT C,-1(D) ; XFER THE DATA
+ HRLI A,(A)
+ SUB TP,A ; FLUSH STACKAGE
+IVEC1: MOVSI A,TVEC
+ POPJ P,
+
+
+; COMPILERS CALL
+
+CIVEC: SUBM M,(P)
+ PUSHJ P,IEVECT
+ JRST MPOPJ
+
+
+\f; INTERNAL CALL TO EUVECTOR
+
+IEUVEC: PUSH P,A ; SAVE LENGTH
+ PUSHJ P,IBLOCK
+ MOVE A,(P)
+ JUMPE A,IEUVE1 ; EMPTY, LEAVE
+ ASH A,1 ; NOW FIND STACK POSITION
+ MOVEI C,(TP) ; POINT TO TOP
+ MOVE D,B ; COPY VEC POINTER
+ SUBI C,-1(A) ; POINT TO 1ST DATUM
+ GETYP A,(C) ; CHECK IT
+ PUSHJ P,NWORDT
+ SOJN A,CANTUN ; WONT FIT
+ GETYP E,(C)
+
+IEUVE2: GETYP 0,(C) ; TYPE OF EL
+ CAIE 0,(E) ; MATCH?
+ JRST WRNGUT
+ MOVE 0,1(C)
+ MOVEM 0,(D) ; CLOBBER
+ ADDI C,2
+ AOBJN D,IEUVE2 ; LOOP
+ TRO E,.VECT.
+ HRLZM E,(D) ; STORE UTYPE
+IEUVE1: POP P,A ; GET COUNY
+ ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS
+ HRLI A,(A)
+ SUB TP,A ; CLEAN UP STACK
+ MOVSI A,TUVEC
+ POPJ P,
+
+; COMPILER'S CALL
+
+CIUVEC: SUBM M,(P)
+ PUSHJ P,IEUVEC
+ JRST MPOPJ
+
+IMFUNCTION EVECTOR,SUBR,[VECTOR]
+ ENTRY
+ HLRE A,AB
+ MOVNS A
+ PUSH P,A ;SAVE NUMBER OF WORDS
+ PUSHJ P,IBLOCK ; GET WORDS
+ MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER
+ JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR
+
+ HRLI C,(AB) ;START BUILDING BLT POINTER
+ HRRI C,(B) ;TO ADDRESS
+ ADDI D,@(P) ;SET D TO FINAL ADDRESS
+ BLT C,(D)
+FINISV: MOVSI 0,400000+.VECT.
+ MOVEM 0,1(D) ; MARK AS GENERAL
+ SUB P,C%11
+ MOVSI A,TVEC
+ JRST FINIS
+
+
+
+\f;EXPLICIT VECTORS FOR THE UNIFORM CSE
+
+IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
+
+ ENTRY
+ HLRE A,AB ;-NUM OF ARGS
+ MOVNS A
+ ASH A,-1 ;NEED HALF AS MANY WORDS
+ PUSH P,A
+ JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY
+ GETYP A,(AB) ;GET FIRST ARG
+ PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS
+ SOJN A,CANTUN
+EUV1: POP P,A
+ PUSHJ P,IBLOCK ; GET VECT
+ JUMPGE B,FINISU
+
+ GETYP C,(AB) ;GET THE FIRST TYPE
+ MOVE D,AB ;COPY THE ARG POINTER
+ MOVE E,B ;COPY OF RESULT
+
+EUVLP: GETYP 0,(D) ;GET A TYPE
+ CAIE 0,(C) ;SAME?
+ JRST WRNGUT ;NO , LOSE
+ MOVE 0,1(D) ;GET GOODIE
+ MOVEM 0,(E) ;CLOBBER
+ ADD D,C%22 ;BUMP ARGS POINTER
+ AOBJN E,EUVLP
+
+ TRO C,.VECT.
+ HRLM C,(E) ;CLOBBER UNIFORM TYPE IN
+FINISU: MOVSI A,TUVEC
+ JRST FINIS
+
+WRNGSU: GETYP A,-1(TP)
+ CAIE A,TSTORAGE
+ JRST WRNGUT ;IF UVECTOR
+ PUSHJ P,FREESV ;FREE STORAGE VECTOR
+ ERRUUO EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
+
+WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+
+CANTUN: ERRUUO EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
+
+BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+\f; FUNCTION TO GROW A VECTOR
+REPEAT 0,[
+MFUNCTION GROW,SUBR
+
+ ENTRY 3
+
+ MOVEI D,0 ;STACK HACKING FLAG
+ GETYP A,(AB) ;FIRST TYPE
+ PUSHJ P,SAT ;GET STORAGE TYPE
+ GETYP B,2(AB) ;2ND ARG
+ CAIE A,STPSTK ;IS IT ASTACK
+ CAIN A,SPSTK
+ AOJA D,GRSTCK ;YES, WIN
+ CAIE A,SNWORD ;UNIFORM VECTOR
+ CAIN A,S2NWORD ;OR GENERAL
+GRSTCK: CAIE B,TFIX ;IS 2ND FIXED
+ JRST WTYP2 ;COMPLAIN
+ GETYP B,4(AB)
+ CAIE B,TFIX ;3RD ARG
+ JRST WTYP3 ;LOSE
+
+ MOVEI E,1 ;UNIFORM/GENERAL FLAG
+ CAIE A,SNWORD ;SKIP IF UNIFORM
+ CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL
+ MOVEI E,0
+
+ HRRZ B,1(AB) ;POINT TO START
+ HLRE A,1(AB) ;GET -LENGTH
+ SUB B,A ;POINT TO DOPE WORD
+ SKIPE D ;SKIP IF NOT STACK
+ ADDI B,PDLBUF ;FUDGE FOR PDL
+ HLLZS (B) ;ZERO OUT GROWTH SPECS
+ SKIPN A,3(AB) ;ANY TOP GROWTH?
+ JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH
+ ASH A,(E) ;MULT BY 2 IF GENERAL
+ ADDI A,77 ;ROUND TO NEAREST BLOCK
+ ANDCMI A,77 ;CLEAR LOW ORDER BITS
+ ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION
+ TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS A
+ TLNE A,-1 ;SKIP IF NOT TOO BIG
+ JRST GTOBIG ;ERROR
+GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH
+ JRST GROW4 ;NONE, SKIP
+ ASH C,(E) ;GENRAL FUDGE
+ ADDI C,77 ;ROUND
+ ANDCMI C,77 ;FUDGE FOR VALUE RETURN
+ PUSH P,C ;AND SAVE
+ ASH C,-6 ;DIVIDE BY 100
+ TRZE C,400 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS C
+ TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW
+ JRST GTOBIG
+GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR
+ MOVNI E,-1(E)
+ HRLI E,(E) ;TO BOTH HALVES
+ ADDI E,1(B) ;POINTS TO TOP
+ SKIPE D ;STACK?
+ ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH
+ SKIPL D,(P) ;SHRINKAGE?
+ JRST GROW3 ;NO, CONTINUE
+ MOVNS D ;PLUSIFY
+ HRLI D,(D) ;TO BOTH HALVES
+ ADD E,D ;POINT TO NEW LOW ADDR
+GROW3: IORI A,(C) ;OR TOGETHER
+ HRRM A,(B) ;DEPOSIT INTO DOPEWORD
+ PUSH TP,(AB) ;PUSH TYPE
+ PUSH TP,E ;AND VALUE
+ SKIPE A ;DON'T GC FOR NOTHING
+ MOVE C,[2,,0] ; GET INDICATOR FOR AGC
+ PUSHJ P,AGC
+ JUMPL A,GROFUL
+ POP P,C ;RESTORE GROWTH
+ HRLI C,(C)
+ POP TP,B ;GET VECTOR POINTER
+ SUB B,C ;POINT TO NEW TOP
+ POP TP,A
+ JRST FINIS
+
+GROFUL: SUB P,C%11 ; CLEAN UP STACK
+ SUB TP,C%22
+ PUSHJ P,FULLOS
+ JRST GROW
+
+GTOBIG: ERRUUO EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
+GROW4: PUSH P,[0] ;0 BOTTOM GROWTH
+ JRST GROW2
+]
+FULLOS: ERRUUO EQUOTE NO-STORAGE
+
+
+\f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
+
+MFUNCTION BYTES,SUBR
+
+ ENTRY
+ MOVEI D,1
+ JUMPGE AB,TFA
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP1
+ MOVE E,1(AB)
+ ADD AB,C%22
+ JRST STRNG1
+
+IMFUNCTION STRING,SUBR
+
+ ENTRY
+
+ MOVEI D,0
+ MOVEI E,7
+STRNG1: MOVE B,AB ;COPY ARG POINTER
+ MOVEI C,0 ;INITIALIZE COUNTER
+ PUSH TP,$TAB ;SAVE A COPY
+ PUSH TP,B
+ HLRE A,B ; GET # OF ARGS
+ MOVNS A
+ ASH A,-1 ; 1/2 FOR # OF ARGS
+ PUSHJ P,IISTRN
+ JRST FINIS
+
+IISTRN: PUSH P,E
+ JUMPL E,OUTRNG
+ CAILE E,36.
+ JRST OUTRNG
+ SKIPN E,A ; SKIP IF ARGS EXIST
+ JRST MAKSTR ; ALL DONE
+
+STRIN2: GETYP 0,(B) ;GET TYPE CODE
+ CAMN 0,SING(D) ; SINGLE CHARACTER OR FIX?
+ AOJA C,STRIN1
+ CAME 0,MULTI(D) ; OR STRING OR BYTE-STRING
+ JRST WRONGT ;NEITHER
+ HRRZ 0,(B) ; GET CHAR COUNT
+ ADD C,0 ; AND BUMP
+
+STRIN1: ADD B,C%22
+ SOJG A,STRIN2
+
+; NOW GET THE NECESSARY VECTOR
+
+MAKSTR: HRL C,MULTI(D) ; FINAL TYPE,, CHAR COUNT
+ PUSH P,C ; SAVE CHAR COUNT
+ PUSH P,E ; SAVE ARG COUNT
+ MOVEI D,36.
+ IDIV D,-2(P) ; A==> BYTES PER WORD
+ MOVEI A,(C) ; LNTH+4 TO A
+ ADDI A,-1(D)
+ IDIVI A,(D)
+ LSH E,12.
+ MOVE D,-2(P)
+ DPB D,[060600,,E]
+ HRLM E,-2(P) ; SAVE REMAINDER
+ PUSHJ P,IBLOCK
+
+ POP P,A
+ JUMPGE B,DONEC ; 0 LENGTH, NO STRING
+ HRLI B,440000 ;CONVERT B TO A BYTE POINTER
+ HRRZ 0,-1(P) ; BYTE SIZE
+ DPB 0,[300600,,B]
+ MOVE C,(TP) ; POINT TO ARGS AGAIN
+
+NXTRG1: GETYP D,(C) ;GET AN ARG
+ CAIN D,TFIX
+ JRST .+3
+ CAIE D,TCHRS
+ JRST TRYSTR
+ MOVE D,1(C) ; GET IT
+ IDPB D,B ;AND DEPOSIT IT
+ JRST NXTARG
+
+TRYSTR: MOVE E,1(C) ;GET BYTER
+ HRRZ 0,(C) ;AND COUNT
+NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG
+ ILDB D,E ;AND GET NEXT
+ IDPB D,B ; AND DEPOSIT SAME
+ JRST NXTCHR
+
+NXTARG: ADD C,C%22 ;BUMP ARG POINTER
+ SOJG A,NXTRG1
+ ADDI B,1
+
+DONEC: MOVSI C,TCHRS+.VECT.
+ TLO B,400000
+ HLLM C,(B) ;AND CLOBBER AWAY
+ HLRZ C,1(B) ;GET LENGTH BACK
+ POP P,A
+ SUBI B,-1(C)
+ HLL B,(P) ;MAKE A BYTE POINTER
+ SUB P,C%11
+ POPJ P,
+
+SING: TCHRS
+ TFIX
+
+MULTI: TCHSTR
+ TBYTE
+
+
+; COMPILER'S CALL TO MAKE A STRING
+
+CISTNG: TDZA D,D
+
+; COMPILERS CALL TO MAKE A BYTE STRING
+
+CBYTES: MOVEI D,1
+ SUBM M,(P)
+ MOVEI C,0 ; INIT CHAR COUNTER
+ MOVEI B,(A) ; SET UP STACK POINTER
+ ASH B,1 ; * 2 FOR NO. OF SLOTS
+ HRLI B,(B)
+ SUBM TP,B ; B POINTS TO ARGS
+ PUSH P,D
+ MOVEI E,7
+ JUMPE D,CBYST
+ GETYP 0,1(B) ; CHECK BYTE SIZE
+ CAIE 0,TFIX
+ JRST WRONGT
+ MOVE E,2(B)
+ ADD B,C%22
+ SUBI A,1
+CBYST: ADD B,C%11
+ PUSH TP,$TTP
+ PUSH TP,B
+ PUSHJ P,IISTRN ; MAKE IT HAPPEN
+ MOVE TP,(TP) ; FLUSH ARGS
+ SUB TP,C%11
+ POP P,D
+ JUMPE D,MPOPJ
+ SUB TP,C%22
+ JRST MPOPJ
+
+\f;BUILD IMPLICT STRING
+
+MFUNCTION IBYTES,SUBR
+
+ ENTRY
+
+ CAML AB,C%M20 ; [-3,,] ; AT LEAST 2
+ JRST TFA
+ CAMGE AB,C%M60 ; [-7,,] ; NO MORE THAN 3
+ JRST TMA
+ PUSHJ P,GETFIX ; GET BYTE SIZE
+ JUMPL A,OUTRNG
+ CAILE A,36.
+ JRST OUTRNG
+ PUSH P,[TFIX]
+ PUSH P,A
+ PUSH P,$TBYTE
+ ADD AB,C%22
+ MOVEM AB,ABSAV(TB)
+ JRST ISTR1
+
+MFUNCTION ISTRING,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA ; TOO FEW ARGS
+ CAMGE AB,C%M40 ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
+ JRST TMA
+ PUSH P,[TCHRS]
+ PUSH P,[7]
+ PUSH P,$TCHSTR
+ISTR1: PUSHJ P,GETFIX
+ MOVEI C,36.
+ IDIV C,-1(P)
+ ADDI A,-1(C)
+ IDIVI A,(C) ; # OF WORDS NEEDED TO A
+ ASH D,12.
+ MOVE C,-1(P) ; GET BYTE SIZE
+ DPB C,[060600,,D]
+ PUSH P,D
+ PUSHJ P,IBLOCK
+ HLRE C,B ; -LENGTH TO C
+ SUBM B,C ; LOCN OF DOPE WORD TO C
+ HRLI D,TCHRS+.VECT. ; CLOBBER ITS TYPE
+ HLLM D,(C)
+ MOVE A,-1(P)
+ HRR A,1(AB) ; SETUP TYPE'S RH
+ SUBI B,1
+ HRL B,(P) ; AND BYTE POINTER
+ SUB P,C%33
+ SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
+ JRST FINIS
+ PUSH TP,A ;SAVE OUR STRING
+ PUSH TP,B
+ PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER
+ PUSH TP,B
+ PUSH P,(AB)1 ;SAVE COUNT
+ PUSH TP,(AB)+2
+ PUSH TP,(AB)+3
+CLOBST: PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,EVAL
+ GETYP C,A ; CHECK IT
+ CAME C,-1(P) ; MUST BE A CHARACTER
+ JRST WTYP2
+ IDPB B,-2(TP) ;CLOBBER
+ SOSLE (P) ;FINISHED?
+ JRST CLOBST ;NO
+ SUB P,C%22
+ SUB TP,C%66
+ MOVE A,(TP)+1
+ MOVE B,(TP)+2
+ JRST FINIS
+
+\f
+; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
+; PUNT SOME IF THERE ARE.
+
+INQAGC: PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSH P,E
+ PUSHJ P,SQKIL
+ JSP E,CKPUR ; CHECK FOR PURE RSUBR
+ POP P,E
+ MOVE A,PURTOP
+ SUB A,CURPLN
+ MOVE B,RFRETP ; GET REAL FRETOP
+ CAIL B,(A)
+ MOVE B,A ; TOP OF WORLD
+ MOVE A,GCSTOP
+ ADD A,GETNUM
+ ADDI A,1777 ; PAGE BOUNDARY
+ ANDCMI A,1777
+ CAIL A,(B) ; SEE WHETHER THERE IS ROOM
+ JRST GOTOGC
+ PUSHJ P,CLEANT
+ POP P,A
+ POP P,B
+ POP P,C
+ POPJ P,
+GOTOGC: POP P,A
+ POP P,B
+ POP P,C ; RESTORE CAUSE INDICATOR
+ MOVE A,P.TOP
+ PUSHJ P,CLEANT ; CLEAN UP
+ SKIPL PLODR ; IF IN PLOAD DON'T INTERRUPT
+ JRST INTAGC ; GO CAUSE GARBAGE COLLECT
+ JRST SAGC
+
+CLEANT: PUSH P,C
+ PUSH P,A
+ SUB A,P.TOP
+ ASH A,-PGSZ
+ JUMPE A,CLNT1
+ PUSHJ P,GETPAG ; GET THOSE PAGES
+ FATAL CAN'T GET PAGES NEEDED
+ MOVE A,(P)
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE
+ PUSHJ P,SLEEPR
+CLNT1: PUSHJ P,RBLDM
+ POP P,A
+ POP P,C
+ POPJ P,
+
+\f; RCLVEC DISTASTEFUL VECTOR RECYCLER
+
+; Arrive here with B pointing to first recycler, A desired length
+
+RCLVEC: PUSH P,D ; Save registers
+ PUSH P,C
+ PUSH P,E
+ MOVEI D,RCLV ; Point to previous recycle for splice
+RCLV1: HLRZ C,(B) ; Get size of this block
+ CAIL C,(A) ; Skip if too small
+ JRST FOUND1
+
+RCLV2: MOVEI D,(B) ; Save previous pointer
+ HRRZ B,(B) ; Point to next block
+ JUMPN B,RCLV1 ; Jump if more blocks
+
+ POP P,E
+ POP P,C
+ POP P,D
+ JRST NORCL ; Go to normal allocator
+
+
+FOUND1: CAIN C,1(A) ; Exactly 1 greater?
+ JRST RCLV2 ; Cant use this guy
+
+ HRLM A,(B) ; Smash in new count
+ TLO A,.VECT. ; make vector bit be on
+ HLLM A,-1(B)
+ CAIE C,(A) ; Exactly right length?
+ JRST FOUND2 ; No, do hair
+
+ HRRZ C,(B) ; Point to next block
+ HRRM C,(D) ; Smash previous pointer
+ HRRM B,(B)
+ SUBI B,-1(A) ; Point to top of block
+ JRST FOUND3
+
+FOUND2: SUBI C,(A) ; Amount of left over to C
+ HRRZ E,(B) ; Point to next block
+ HRRM B,(B)
+ SUBI B,(A) ; Point to dope words of guy to put back
+ MOVSM C,(B) ; Smash in count
+ MOVSI C,.VECT. ; Get vector bit
+ MOVEM C,-1(B) ; Make sure it is a vector
+ HRRM B,(D) ; Splice him in
+ HRRM E,(B) ; And the next guy also
+ ADDI B,1 ; Point to start of vector
+
+FOUND3: HRROI B,(B) ; Make an AOBJN pointer
+ TLC B,-3(A)
+ HRRI A,TVEC
+ SKIPGE A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POP P,E
+ POP P,C
+ POP P,D
+ POPJ P,
+
+END
+\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff