<mdl.int>/stbuil.mid.20

   1
   2  TITLE STRBUILD MUDDLE STRUCTURE BUILDER
   3
   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
  17
  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
  25
  26 ; SHARED SYMBOLS WITH GC MODULE
  27
  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
  36
  37 NOPAGS==1       ; NUMBER OF WINDOWS
  38 EOFBIT==1000
  39 PDLBUF=100
  40
  41 .ATOM.==200000  ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
  42
  43 GCHN==0         ; CHANNEL FOR FUNNNY INFERIOR
  44 STATNO==19.     ; # OF STATISTICS FOR BLOAT-STAT
  45 STATGC==8.      ; # OF GC-STATISTICS FOR BLOAT-STAT
  46
  47
  48 RELOCATABLE
  49 .INSRT MUDDLE >
  50 SYSQ
  51 IFE ITS,[
  52 .INSRT STENEX >
  53 ]
  54 IFN ITS,        PGSZ==10.
  55 IFE ITS,        PGSZ==9.
  56
  57
  58 \f; GC-READ TAKES ONE ARGUMENT WHICH MUST BE A "READB" CHANNEL
  59
  60 .GLOBAL CLOOKU,CINSER,MOBLIST,CATOM,EOFCND,IGLOC
  61
  62 MFUNCTION GCREAD,SUBR,[GC-READ]
  63
  64         ENTRY
  65
  66         CAML    AB,C%M2         ; CHECK # OF ARGS
  67         JRST    TFA
  68         CAMGE   AB,C%M40
  69         JRST    TMA
  70
  71         GETYP   A,(AB)          ; MAKE SURE ARG IS A CHANNEL
  72         CAIE    A,TCHAN
  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
  78         JRST    BADCHN
  79
  80         PUSH    P,1(B)          ; SAVE ITS CHANNEL #
  81 IFN ITS,[
  82         MOVE    B,[-2,,C]       ; SET UP AOBJN PTR TO READ IN DELIMITING
  83                                 ;       CONSTANTS
  84         MOVE    A,(P)           ; GET CHANNEL #
  85         DOTCAL  IOT,[A,B]
  86         FATAL GCREAD-- IOT FAILED
  87         JUMPL   B,EOFGC         ; IF BLOCK DIDN'T FINISH THEN EOF
  88 ]
  89 IFE ITS,[
  90         MOVE    A,(P)           ; GET CHANNEL
  91         BIN
  92         MOVE    C,B             ; TO C
  93         BIN
  94         MOVE    D,B             ; TO D
  95         GTSTS                   ; SEE IF EOF
  96         TLNE    B,EOFBIT
  97         JRST    EOFGC
  98 ]
  99
 100         PUSH    P,C             ; SAVE AC'S
 101         PUSH    P,D
 102
 103 IFN ITS,[
 104         MOVE    B,[-3,,C]       ; NEXT GROUP OF WORDS
 105         DOTCAL  IOT,[A,B]
 106         FATAL   GCREAD--GC IOT FAILED
 107 ]
 108 IFE ITS,[
 109         MOVE    A,-2(P)         ; GET CHANNEL
 110         BIN
 111         MOVE    C,B
 112         BIN
 113         MOVE    D,B
 114         BIN
 115         MOVE    E,B
 116 ]
 117         MOVEI   0,0             ; DO PRELIMINARY TESTS
 118         IOR     0,A             ; IOR ALL WORDS IN
 119         IOR     0,B
 120         IOR     0,C
 121         IOR     0,(P)
 122         IOR     0,-1(P)
 123         TLNE    0,-1            ; SKIP IF NO BITS IN LEFT HALF
 124          JRST   ERDGC
 125
 126         MOVEM   D,NNPRI
 127         MOVEM   E,NNSAT
 128         MOVE    D,C             ; GET START OF NEWTYPE TABLE
 129         SUB     D,-1(P)         ; CREATE AOBJN POINTER
 130         HRLZS   D
 131         ADDI    D,(C)
 132         MOVEM   D,TYPTAB        ; SAVE IT
 133         MOVE    A,(P)           ; GET LENGTH OF WORD
 134         SUBI    A,CONADJ        ; SUBTRACT FOR CONSTANTS
 135
 136         ADD     A,GCSTOP
 137         CAMG    A,FRETOP        ; SEE IF GC IS NESESSARY
 138         JRST    RDGC1
 139         MOVE    C,(P)
 140         ADDM    C,GETNUM        ; MOVE IN REQUEST
 141         MOVE    C,[0,,1]        ; ARGS TO GC
 142         PUSHJ   P,AGC           ; 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
 147         MOVEM   C,GCSTOP
 148         SUB     C,OGCSTP
 149         SUBI    C,2             ; SUBSTRACT TO GET RID OF D.W'S
 150         MOVNS   C               ; SET UP AOBJN PTR FOR READIN
 151 IFN ITS,[
 152         HRLZS   C
 153         MOVE    A,-2(P)         ; GET CHANNEL #
 154         ADD     C,OGCSTP
 155         DOTCAL  IOT,[A,C]
 156         FATAL GCREAD-- IOT FAILED
 157 ]
 158 IFE ITS,[
 159         MOVE    A,-2(P)         ; CHANNEL TO A
 160         MOVE    B,OGCSTP        ; SET UP BYTE POINTER
 161         HRLI    B,444400
 162         SIN                     ; IN IT COMES
 163 ]
 164
 165         MOVE    C,(P)           ; GET LENGHT OF OBJECT
 166         ADDI    A,5
 167         MOVE    B,1(AB)         ; GET CHANNEL
 168         ADDM    C,ACCESS(B)
 169         MOVE    D,GCSTOP        ; SET UP TO LOOK LIKE UVECTOR OF LOSES
 170         ADDI    C,2             ; ADD 2 FOR DOPE WORDS
 171         HRLM    C,-1(D)
 172         MOVSI   A,.VECT.
 173         SETZM   -2(D)
 174         IORM    A,-2(D)         ; MARK VECTOR BIT
 175         PUSH    TP,$TRDTB       ; HOLD ON IN CASE OF GC
 176         MOVEI   A,-2(D)
 177         MOVN    C,(P)
 178         ADD     A,C
 179         HRL     A,C
 180         PUSH    TP,A
 181
 182         MOVE    D,-1(P)         ; SET UP BOTTOM OF ATOM TABLE
 183         SUBI    D,1
 184         MOVEM   D,ABOTN
 185         MOVE    C,GCSTOP        ; START AT TOP OF WORLD
 186         SUBI    C,3             ; POINT TO FIRST ATOM
 187
 188 ; LOOP TO FIX UP THE ATOMS
 189
 190 AFXLP:  HRRZ    0,1(TB)
 191         ADD     0,ABOTN
 192         CAMG    C,0             ; SEE IF WE ARE DONE
 193         JRST    SWEEIN
 194         HRRZ    0,1(TB)
 195         SUB     C,0
 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
 201         JRST    AFXLP
 202
 203 ; FIXUP ROUTINE FOR ATOMS (C==> D.W.)
 204
 205 ATFXU:  PUSH    P,C             ; SAVE PTR TO D.W.
 206         ADD     C,1(TB)
 207         MOVE    A,C
 208         HLRZ    B,(A)           ; GET LENGTH AND MARKING
 209         TRZE    B,400000        ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED
 210         JRST    ATFXU1
 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
 216         MOVE    A,0
 217         SUBI    A,1
 218         ANDCM   0,A
 219         JFFO    0,.+1
 220         HRREI   0,-34.(A)
 221         IDIVI   0,7             ; # OF CHARS IN LAST WORD
 222         ADD     D,0
 223         ADD     D,$TCHSTR       ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD
 224         PUSH    P,D             ; SAVE IT
 225         MOVE    C,(B)           ; GET OBLIST SLOT PTR
 226 ATFXU9: HRRZS   B               ; RELATAVIZE POINTER
 227         HRRZ    0,1(TB)
 228         SUB     B,0
 229         PUSH    P,B
 230         JUMPE   C,ATFXU6        ; NO OBLIST.  CREATE ATOM
 231         CAMN    C,C%M1          ; SEE IF ROOT ATOM
 232         JRST    RTFX
 233         ADD     C,ABOTN         ; POINT TO ATOM
 234         PUSHJ   P,ATFXU
 235         PUSH    TP,$TATOM
 236         PUSH    TP,B
 237         MOVE    A,$TATOM        ; SET UP TO SEE IF OBLIST EXITS
 238         MOVE    C,$TATOM
 239         MOVE    D,IMQUOTE OBLIST
 240         PUSHJ   P,CIGTPR
 241         JRST    ATFXU8          ; NO OBLIST. CREATE ONE
 242         SUB     TP,C%22         ; GET RID OF SAVED ATOM
 243 RTCON:  PUSH    TP,$TOBLS
 244         PUSH    TP,B
 245         MOVE    C,B             ; SET UP FOR LOOKUP
 246         MOVE    A,-1(P)         ; SET UP PTR TO PNAME
 247         MOVE    B,(P)
 248         ADD     B,[440700,,1]   ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER
 249         HRRZ    0,1(TB)
 250         ADD     B,0
 251         PUSHJ   P,CLOOKU
 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.
 256         ADD     C,1(TB)
 257         MOVEM   B,-1(C)         ; MOVE IN RELATAVIZE ADDRESS
 258         MOVSI   D,400000
 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
 262          PUSHJ  P,IIGLOC
 263         POP     P,C
 264         ADD     C,1(TB)
 265         POPJ    P,              ; EXIT
 266 ATFXU1: POP     P,C             ; RESTORE PTR TO D.W.
 267         ADD     C,1(TB)
 268         MOVE    B,-1(C)         ; GET ATOM
 269         POPJ    P,
 270
 271 ; ROUTINE TO INSERT AN ATOM
 272
 273 ATFXU4: MOVE    C,(TP)          ; GET OBLIST PTR
 274         MOVE    B,(P)           ; SET UP STRING PTR TO PNAME
 275         ADD     B,[440700,,1]
 276         HRRZ    0,1(TB)
 277         ADD     B,0
 278         MOVE    A,-1(P)         ; GET TYPE WORD
 279         PUSHJ   P,CINSER        ; INSERT IT
 280         JRST    ATFXU3
 281
 282 ; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST
 283
 284 ATFXU6: MOVE    B,(P)           ; POINT TO PNAME
 285         ADD     B,[440700,,1]   ; MAKE IT LOOK LIKE A BYTE POINTER
 286         HRRZ    0,1(TB)
 287         ADD     B,0
 288         MOVE    A,-1(P)
 289         PUSHJ   P,CATOM
 290         SUB     P,C%22          ; CLEAN OFF STACK
 291         JRST    ATFXU7
 292
 293 ; THIS ROUTINE CREATES AND OBLIST
 294
 295 ATFXU8: MCALL   1,MOBLIST
 296         PUSH    TP,$TOBLS
 297         PUSH    TP,B            ; SAVE OBLIST PTR
 298         JRST    ATFXU4          ; JUMP TO INSERT THE OBLIST
 299
 300 ; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST
 301
 302 RTFX:   MOVE    B,ROOT+1                ; GET ROOT OBLIST
 303         JRST    RTCON
 304
 305 ; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS.
 306
 307 SWEEIN:
 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
 311
 312         HRRZ    E,1(TB)         ; SET UP TYPE TABLE
 313         ADD     E,TYPTAB
 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
 319         ADD     A,1(TB)
 320         MOVE    A,-1(A)
 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
 324         ADD     B,C%22          ; TO NEXT
 325         JUMPL   B,TYPUP3
 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
 337         ADD     A,1(TB)
 338         MOVE    A,-1(A)
 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
 343         JUMPL   B,TYPUP5
 344         HRRM    D,1(E)          ; CLOBBER IN TYPE-NUMBER
 345         PUSH    TP,$TATOM       ; PUSH ARGS FOR NEWTYPE
 346         PUSH    TP,A
 347         PUSH    TP,$TATOM
 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
 351 TYPUP9: SUB     E,1(TB)
 352         PUSH    P,E             ; SAVE RELATAVIZED PTR TO TYPE-TABLE
 353         MCALL   2,NEWTYPE
 354         POP     P,E             ; RESTORE RELATAVIZED PTR
 355         ADD     E,1(TB)         ; FIX IT UP
 356 TYPUP0: ADD     E,C%22          ; INCREMENT E
 357         JUMPL   E,TYPUP1
 358         JRST    VUP
 359 TYPUP7: HRRZ    B,(E)           ; FIND PRIMTYPE FROM SAT
 360         MOVE    A,@STBL(B)
 361         PUSH    TP,A
 362         JRST    TYPUP9
 363 TYPUP6: HRRM    D,1(E)          ; CLOBBER IN TYPE #
 364         JRST    TYPUP0
 365
 366 ERTYP1: ERRUUO  EQUOTE CANT-FIND-TEMPLATE
 367
 368 ERTYP2: ERRUUO  EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE
 369
 370 VUP:    HRRZ    E,1(TB)         ; FIX UP SOME POINTERS
 371         MOVEM   E,OGCSTP
 372         ADDM    E,ABOTN
 373         ADDM    E,TYPTAB
 374
 375
 376 ; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES.
 377 ; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY.
 378
 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
 382         JRST    VUP3
 383         HLRZ    B,(A)           ; GET TYPE SLOT
 384         TRNE    B,.VECT.        ; SKIP IF NOT A VECTOR
 385         JRST    VUP2
 386         SUBI    A,2             ; SKIP OVER PAIR
 387         JRST    VUP1
 388 VUP2:   TRNE    B,400000        ; SKIP IF UVECTOR
 389         JRST    VUP4
 390         ANDI    B,TYPMSK        ; GET RID OF MONITORS
 391         CAMG    B,NNPRI         ; SKIP IF NEWTYPE
 392         JRST    VUP5
 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
 397         SUBI    A,(B)
 398         JRST    VUP1            ; LOOP
 399 VUP4:   ANDI    B,TYPMSK        ; FLUSH MONITORS
 400         CAMG    B,NNSAT         ; SKIP IF TEMPLATE
 401         JRST    VUP5
 402         PUSHJ   P,GETSAT        ; CONVERT TO NEW SAT
 403         ADDI    B,.VECT.        ; MAJIC TO TURN ON BIT
 404         PUTYP   B,(A)
 405         JRST    VUP5
 406
 407
 408 VUP3:   PUSH    P,GCSBOT        ; SAVE CURRENT GCSBOT
 409         MOVE    A,OGCSTP        ; SET UP NEW GCSBOT
 410         MOVEM   A,GCSBOT
 411         PUSH    P,GCSTOP
 412         HRRZ    A,TYPTAB                ; SET UP NEW GCSTOP
 413         MOVEM   A,GCSTOP
 414         SETOM   GCDFLG
 415         MOVE    A,[PUSHJ P,RDFIX]       ; INS FOR GCHACK
 416         MOVEI   PVP,0           ; SAY MIGHT BE NON-ATOMS
 417         PUSHJ   P,GCHK10
 418         SETZM   GCDFLG
 419         POP     P,GCSTOP        ; RESTORE GCSTOP
 420         MOVE    A,1(TB)         ; GET A POINTER TO RETURNING VALUES
 421         MOVE    B,A
 422         HLRE    C,B
 423         SUB     B,C
 424         SETZM   (B)
 425         SETZM   1(B)
 426         POP     P,GCSBOT        ; RESTORE GCSBOT
 427         MOVE    B,1(A)          ; GET PTR TO OBJECTS
 428         MOVE    A,(A)
 429         JRST    FINIS           ; EXIT
 430
 431 ; ERROR FOR INCORRECT GCREAD FILE
 432
 433 ERDGC:  ERRUUO  EQUOTE BAD-GC-READ-FILE
 434
 435 ; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE
 436
 437 RDFIX:  PUSH    P,C             ; SAVE C
 438         PUSH    P,B             ; SAVE PTR
 439         EXCH    B,C
 440         TLNE    C,UBIT          ; SKIP IF NOT UVECTOR
 441         JRST    ELEFX           ; DON'T HACK TYPES IN UVECTOR
 442         CAIN    B,TTYPEC
 443         JRST    TYPCFX
 444         CAIN    B,TTYPEW
 445         JRST    TYPWFX
 446         CAMLE   B,NNPRI
 447          JRST   TYPGFX
 448 ELEFX:  EXCH    B,A             ; EXCHANGE FOR SAT
 449         PUSHJ   P,SAT
 450         EXCH    B,A             ; REFIX
 451         CAIE    B,SOFFS
 452          JRST   OFSFIX
 453         CAIE    B,SLOCR         ; REL GLOC'S ARE STORED AS ATOMS
 454         CAIN    B,SATOM
 455         JRST    ATFX
 456         CAIN    B,SCHSTR
 457          JRST   STFX
 458         CAIN    B,S1WORD                ; SEE IF PRIMTYPE WOR
 459         JRST    RDLSTF          ; LEAVE IF IS
 460 STFXX:  MOVE    0,GCSBOT        ; ADJUSTMENT
 461         SUBI    0,FPAG+5
 462         SKIPE   1(C)            ; DON'T CHANGE A PTR TO NIL
 463         ADDM    0,1(C)          ; FIX UP
 464 RDLSTF: TLNN    C,.LIST.        ; SEE IF PAIR
 465         JRST    RDL1            ; EXIT
 466         MOVE    0,GCSBOT        ; FIX UP
 467         SUBI    0,FPAG+5
 468         HRRZ    B,(C)           ; SEE IF POINTS TO NIL
 469         SKIPN   B
 470         JRST    RDL1
 471         MOVE    B,C             ; GET ARG FOR RLISTQ
 472         PUSHJ   P,RLISTQ
 473         JRST    RDL1
 474         ADDM    0,(C)
 475 RDL1:   POP     P,B             ; RESTORE B
 476         POP     P,C
 477         POPJ    P,
 478
 479 ; FIXUP OFSSETS
 480
 481 OFSFIX: HLRZ    B,1(C)          ; SEE IF PNTR TO FIXUP
 482         JUMPE   B,RDL1
 483         MOVE    0,GCSBOT        ; GET UPDATE AMOUNT
 484         SUBI    0,FPAG+5
 485         HRLZS   0
 486         ADDM    0,1(C)          ; FIX POINTER
 487         JRST    RDL1
 488
 489 ; ROUTINE TO FIX UP PNAMES
 490
 491 STFX:   TLZN    D,STATM
 492          JRST   STFXX
 493         HLLM    D,1(C)          ; PUT BACK WITH BIT OFF
 494         ADD     D,ABOTN
 495         ANDI    D,-1
 496         HLRE    0,-1(D)         ; LENGTH OF ATOM
 497         MOVNS   0
 498         SUBI    0,3             ; VAL & OBLIST
 499         IMULI   0,5             ; TO CHARS (SORT OF)
 500         HRRZ    D,-1(D)
 501         ADDI    D,2
 502         PUSH    P,A
 503         PUSH    P,B
 504         LDB     A,[360600,,1(C)]        ; GET BYTE POS
 505         IDIVI   A,7             ; TO CHAR POS
 506         SKIPE   A
 507          SUBI   A,5
 508         HRRZ    B,(C)           ; STRING LENGTH
 509         SUB     B,A             ; TO WORD BOUNDARY STRING
 510         SUBI    0,(B)
 511         IDIVI   0,5
 512         ADD     D,0
 513         POP     P,B
 514         POP     P,A
 515         HRRM    D,1(C)
 516         JRST    RDLSTF
 517
 518 ; ROUTINE TO FIX UP POINTERS TO ATOMS
 519
 520 ATFX:   SKIPGE  D
 521         JRST    RDLSTF
 522         ADD     D,ABOTN
 523         MOVE    0,-1(D)         ; GET PTR TO ATOM
 524         CAIE    B,SLOCR         ; IF REL LOCATIVE, MORE HAIR
 525          JRST   ATFXAT
 526         MOVE    B,0
 527         PUSH    P,E
 528         PUSH    P,D
 529         PUSH    P,C
 530         PUSH    P,B
 531         PUSH    P,A
 532         PUSHJ   P,IGLOC
 533         SUB     B,GLOTOP+1
 534         MOVE    0,B
 535         POP     P,A
 536         POP     P,B
 537         POP     P,C
 538         POP     P,D
 539         POP     P,E
 540 ATFXAT: MOVEM   0,1(C)          ; SMASH IT IN
 541         JRST    RDLSTF          ; EXIT
 542
 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
 547
 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
 551         JRST    ELEFX
 552
 553 TYPGFX: PUSH    P,D
 554         PUSHJ   P,GETNTP                ; GET TYPE IN THIS CORE IMAGE
 555         POP     P,D
 556         PUTYP   B,(C)
 557         JRST    ELEFX
 558
 559 ; HERE TO HANDLE AN EOF IN GC-READ.  IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
 560 ; EOF HANDLER ELSE USES CHANNELS.
 561
 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
 565         PUSH    TP,2(AB)
 566         PUSH    TP,3(AB)
 567         JRST    CLOSIT
 568 MYCLOS: PUSH    TP,EOFCND-1(B)
 569         PUSH    TP,EOFCND(B)
 570 CLOSIT: PUSH    TP,$TCHAN
 571         PUSH    TP,B
 572         MCALL   1,FCLOSE                ; CLOSE CHANNEL
 573         MCALL   1,EVAL                  ; EVAL HIS EOF HANDLER
 574         JRST    FINIS
 575
 576 ; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
 577
 578 GETNEW: CAMG    B,NNPRI         ;NEWTYPE
 579         POPJ    P,
 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
 585         JUMPL   D,GETNT1
 586         SKIPA                   ; KEEP TYPE SAME
 587 GOTTYP: HRRZ    B,1(D)          ; GET NEW TYPE #
 588         POPJ    P,
 589
 590 ; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
 591
 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
 596         ADD     D,C%22
 597         JUMPL   D,GETSA1
 598         FATAL GC-DUMP -- TYPE FIXUP FAILURE
 599 GOTSAT: HLRZ    B,1(D)          ; GET NEW SAT
 600         POPJ    P,
 601
 602
 603 ; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
 604 RLISTQ: PUSH    P,A
 605         GETYP   A,(B)           ; GET TYPE
 606         PUSHJ   P,SAT           ; GET SAT
 607         CAIG    A,NUMSAT        ; NOT DEFERRED IF TEMPLATE
 608         SKIPL   MKTBS(A)
 609         AOS     -1(P)           ; SKIP IF NOT DEFFERED
 610         POP     P,A
 611         POPJ    P,              ; EXIT
 612
 613 \f
 614 .GLOBAL FLIST
 615
 616 MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
 617
 618 ENTRY
 619
 620         JUMPGE  AB,GETUVC       ; SEE IF THERE IS AN ARGUMENT
 621         GETYP   A,(AB)
 622         CAIE    A,TUVEC         ; SEE IF THE ARGUMENT IS A UVECTOR
 623         JRST    WTYP1           ; IF NOT COMPLAIN
 624         HLRE    0,1(AB)
 625         MOVNS   0
 626         CAIE    0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
 627         JRST    WTYP1
 628         CAMGE   AB,C%M20        ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
 629         JRST    TMA
 630         MOVE    A,(AB)          ; GET THE UVECTOR
 631         MOVE    B,1(AB)
 632         JRST    SETUV           ; CONTINUE
 633 GETUVC: MOVEI   A,STATNO+STATGC ; CREATE A UVECTOR
 634         PUSHJ   P,IBLOCK
 635 SETUV:  PUSH    P,A             ; SAVE UVECTOR
 636         PUSH    P,B
 637         MOVE    0,NOWFRE        ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
 638         SUB     0,RFRETP
 639         ADD     0,GCSTOP
 640         MOVEM   0,CURFRE
 641         PUSHJ   P,GCSET         ; FIX UP BLOAT-STAT PARAMETERS
 642         HLRE    0,TP            ; COMPUTE STACK SPACE USED UP
 643         ADD     0,NOWTP
 644         SUBI    0,PDLBUF
 645         MOVEM   0,CURTP
 646         MOVE    B,IMQUOTE THIS-PROCESS
 647         PUSHJ   P,ILOC
 648         HRRZS   B
 649         MOVE    PVP,PVSTOR+1
 650         HRRZ    C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
 651         MOVE    0,B
 652         HRRZ    D,SPBASE+1(PVP)         ; COMPUTE CURRENT # OF BINDINGS
 653         SUB     0,D
 654         IDIVI   0,6
 655         MOVEM   0,CURLVL
 656         SUB     B,C             ; TOTAL WORDS ATOM STORAGE
 657         IDIVI   B,6             ; COMPUTE # OF SLOTS
 658         MOVEM   B,NOWLVL
 659         HRRZ    A,GLOBASE+1     ; COMPUTE TOTAL # OF GLOBAL SLOTS
 660         HLRE    0,GLOBASE+1
 661         SUB     A,0             ; POINT TO DOPE WORD
 662         HLRZ    B,1(A)
 663         ASH     B,-2            ; # OF GVAL SLOTS
 664         MOVEM   B,NOWGVL
 665         HRRZ    A,GLOTOP+1      ; COMPUTE # OF GVAL SLOTS IN USE
 666         HRRZ    0,GLOBSP+1
 667         SUB     A,0
 668         ASH     A,-2            ; NEGATIVE # OF SLOTS USED
 669         MOVEM   A,CURGVL
 670         HRRZ    A,TYPBOT+1      ; GET LENGTH OF TYPE VECTOR
 671         HLRE    0,TYPBOT+1
 672         SUB     A,0
 673         HLRZ    B,1(A)          ; # OF WORDS IN TYPE-VECTOR
 674         IDIVI   B,2             ; CONVERT TO # OF TYPES
 675         MOVEM   B,NOWTYP
 676         HLRE    0,TYPVEC+1      ; LENGTH OF VISABLE TYPE-VECTOR
 677         MOVNS   0
 678         IDIVI   0,2             ; GET # OF TYPES
 679         MOVEM   0,CURTYP
 680         MOVE    0,CODTOP        ; GET LENGTH OF STATIONARY IMPURE STORAGE
 681         MOVEM   0,NOWSTO
 682         SETZB   B,D             ; ZERO OUT MAXIMUM
 683         HRRZ    C,FLIST
 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
 687         MOVE    B,0
 688         HRRZ    C,(C)           ; POINT TO NEXT BLOCK
 689         JUMPN   C,LOOPC         ; REPEAT
 690         MOVEM   D,CURSTO
 691         MOVEM   B,CURMAX
 692         HLRE    0,P             ; GET AMOUNT OF ROOM LEFT ON P
 693         ADD     0,NOWP
 694         SUBI    0,PDLBUF
 695         MOVEM   0,CURP
 696         MOVSI   C,BSTGC         ; SET UP BLT FOR GC FIGURES
 697         HRRZ    B,(P)           ; RESTORE B
 698         HRR     C,B
 699         BLT     C,(B)STATGC-1
 700         HRLI    C,BSTAT         ; MODIFY BLT FOR STATS
 701         HRRI    C,STATGC(B)
 702         BLT     C,(B)STATGC+STATNO-1
 703         MOVEI   0,TFIX+.VECT.
 704         HRLM    0,(B)STATNO+STATGC      ; MOVE IN UTYPE
 705         POP     P,B
 706         POP     P,A             ; RESTORE TYPE-WORD
 707         JRST    FINIS
 708
 709 GCRSET: SETZM   GCNO            ; CALL FROM INIT, ZAP ALL 1ST
 710         MOVE    0,[GCNO,,GCNO+1]
 711         BLT     0,GCCALL
 712         JRST    GCSET
 713
 714
 715
 716 \f
 717 .GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
 718
 719 ; USER GARBAGE COLLECTOR INTERFACE
 720 .GLOBAL ILVAL
 721
 722 MFUNCTION GC,SUBR
 723         ENTRY
 724
 725         JUMPGE  AB,GC1
 726         CAMGE   AB,C%M60        ; [-6,,0]
 727         JRST    TMA
 728         PUSHJ   P,GETFIX        ; GET FREEE MIN IF GIVEN
 729         SKIPE   A               ; SKIP FOR 0 ARGUMENT
 730         MOVEM   A,FREMIN
 731 GC1:    PUSHJ   P,COMPRM        ; GET CURRENT USED CORE
 732         PUSH    P,A
 733         CAML    AB,C%M40        ; [-4,,0] ; SEE IF 3RD ARG
 734         JRST    GC5
 735         GETYP   A,4(AB)         ; MAKE SURE A FIX
 736         CAIE    A,TFIX
 737         JRST    WTYP            ; ARG WRONG TYPE
 738         MOVE    A,5(AB)
 739         MOVEM   A,RNUMSP
 740         MOVEM   A,NUMSWP
 741 GC5:    CAML    AB,C%M20        ; [-2,,0] ; SEE IF SECOND ARG
 742         JRST    GC3
 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
 748         PUSHJ   P,ILVAL
 749         CAMN    A,$TUNBOUND     ; SKIP IF NOT UNBOUND
 750         JRST    GC2
 751         SKIPE   GCHPN           ; SKIP IF GCHAPPEN IS 0
 752         JRST    FALRTN          ; JUMP TO RETURN FALSE
 753 GC2:    MOVE    C,[9.,,0]
 754         PUSHJ   P,AGC           ; COLLECT THAT TRASH
 755         PUSHJ   P,COMPRM        ; HOW MUCH ROOM NOW?
 756         POP     P,B             ; RETURN AMOUNT
 757         SUB     B,A
 758         MOVSI   A,TFIX
 759         JRST    FINIS
 760 HAIRGC: MOVE    B,3(AB)
 761         CAIN    A,TFIX          ; IF FIX THEN CLOBBER NGCS
 762         MOVEM   B,NGCS
 763         MOVEI   A,1             ; FORCE VALUE FLUSHING PHASE TO OCCUR
 764         MOVEM   A,GCHAIR
 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
 768         JRST    FINIS
 769
 770
 771 COMPRM: MOVE    A,GCSTOP        ; USED SPACE
 772         SUB     A,GCSBOT
 773         POPJ    P,
 774
 775 \f
 776 MFUNCTION GCDMON,SUBR,[GC-MON]
 777
 778         ENTRY
 779
 780         MOVEI   E,GCMONF
 781
 782 FLGSET: MOVE    C,(E)           ; GET CURRENT VALUE
 783         JUMPGE  AB,RETFLG       ; RET CURRENT
 784         CAMGE   AB,C%M20        ; [-3,,]
 785          JRST   TMA
 786         GETYP   0,(AB)
 787         SETZM   (E)
 788         CAIN    0,TFALSE
 789         SETOM   (E)
 790         SKIPL   E
 791         SETCMM  (E)
 792
 793 RETFLG: SKIPL   E
 794         SETCMM  C
 795         JUMPL   C,NOFLG
 796         MOVSI   A,TATOM
 797         MOVE    B,IMQUOTE T
 798         JRST    FINIS
 799
 800 NOFLG:  MOVEI   B,0
 801         MOVSI   A,TFALSE
 802         JRST    FINIS
 803
 804 .GLOBAL EVATYP,APLTYP,PRNTYP
 805
 806 \fMFUNCTION BLOAT,SUBR
 807         ENTRY
 808
 809         PUSHJ   P,SQKIL
 810         MOVEI   C,0             ; FLAG TO SAY WHETHER NEED A GC
 811         MOVSI   E,-NBLO         ; AOBJN TO BLOATER TABLE
 812
 813 BLOAT2: JUMPGE  AB,BLOAT1       ; ALL DONE?
 814         PUSHJ   P,NXTFIX        ; GET NEXT BLOAT PARAM
 815         SKIPE   A
 816         PUSHJ   P,@BLOATER(E)   ; DISPATCH
 817         AOBJN   E,BLOAT2        ; COUNT PARAMS SET
 818
 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
 823         SETOM   INBLOT
 824         PUSHJ   P,AGC           ; DO ONE
 825         SKIPE   A,TPBINC        ; SMASH POINNTERS
 826         MOVE    PVP,PVSTOR+1
 827         ADDM    A,TPBASE+1(PVP)
 828         SKIPE   A,GLBINC        ; GLOBAL SP
 829         ADDM    A,GLOBASE+1
 830         SKIPE   A,TYPINC
 831         ADDM    A,TYPBOT+1
 832         SETZM   TPBINC          ; RESET PARAMS
 833         SETZM   GLBINC
 834         SETZM   TYPINC
 835
 836 BLOATD: SKIPN   A,GETNUM        ; SKIP IF FREE STORAGE REQUEST IN EFFECT
 837         JRST    BLTFN
 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
 842         JRST    BLFAGC
 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
 847         MOVEM   A,RFRETP
 848         MOVEM   A,CORTOP
 849         MOVE    B,GCSTOP
 850         SETZM   1(B)
 851         HRLI    B,1(B)
 852         HRRI    B,2(B)
 853         BLT     B,-1(A) ; ZERO CORE
 854 BLTFN:  SETZM   GETNUM
 855         MOVE    B,FRETOP
 856         SUB     B,GCSTOP
 857         MOVSI   A,TFIX          ; RETURN CORE FOUND
 858         JRST    FINIS
 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
 863         JRST    BLTFN           ; EXIT
 864
 865 ; TABLE OF BLOAT ROUTINES
 866
 867 BLOATER:
 868         MAINB
 869         TPBLO
 870         LOBLO
 871         GLBLO
 872         TYBLO
 873         STBLO
 874         PBLO
 875         SFREM
 876         SLVL
 877         SGVL
 878         STYP
 879         SSTO
 880         PUMIN
 881         PMUNG
 882         TPMUNG
 883         NBLO==.-BLOATER
 884
 885 ; BLOAT MAIN STORAGE AREA
 886
 887 MAINB:  SETZM   GETNUM
 888         MOVE    D,FRETOP        ; COMPUTE CURRENT ROOM
 889         SUB     D,PARTOP
 890         CAMGE   A,D             ; NEED MORE?
 891         POPJ    P,              ; NO, LEAVE
 892         SUB     A,D
 893         MOVEM   A,GETNUM                ; SAVE
 894         POPJ    P,
 895
 896 ; BLOAT TP STACK (AT TOP)
 897
 898 TPBLO:  HLRE    D,TP            ; GET -SIZE
 899         MOVNS   B,D
 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
 904         JUMPLE  A,CPOPJ
 905         ADDI    A,63.
 906         ASH     A,-6            ; CONVERT TO 64 WD BLOCKS
 907         CAILE   A,377
 908         JRST    OUTRNG
 909         DPB     A,[111100,,-1(D)]       ; SMASH SPECS IN
 910         AOJA    C,CPOPJ
 911
 912 ; BLOAT TOP LEVEL LOCALS
 913
 914 LOBLO:  HLRE    D,TP            ; GET -SIZE
 915         MOVNS   B,D
 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
 921         MOVE    PVP,PVSTOR+1
 922         HRRZ    0,TPBASE+1(PVP)
 923         HRRZ    B,SPBASE+1(PVP) ; ROOM AVAIL TO E
 924         SUB     B,0
 925         SUBI    A,(B)           ; HOW MUCH MORE?
 926         JUMPLE  A,CPOPJ         ; NONE NEEDED
 927         MOVEI   B,TPBINC
 928         PUSHJ   P,NUMADJ
 929         DPB     A,[1100,,-1(D)] ; SMASH
 930         AOJA    C,CPOPJ
 931
 932 ; GLOBAL SLOT GROWER
 933
 934 GLBLO:  ASH     A,2             ; 4 WORDS PER VAR
 935         MOVE    D,GLOBASE+1     ; CURRENT LIMITS
 936         HRRZ    B,GLOBSP+1
 937         SUBI    B,(D)
 938         SUBI    A,(B)           ; NEW AMOUNT NEEDED
 939         JUMPLE  A,CPOPJ
 940         MOVEI   B,GLBINC        ; WHERE TO KEEP UPDATE
 941         PUSHJ   P,NUMADJ        ; FIX NUMBER
 942         HLRE    0,D
 943         SUB     D,0             ; POINT TO DOPE
 944         DPB     A,[1100,,(D)]   ; AND SMASH
 945         AOJA    C,CPOPJ
 946
 947 ; HERE TO GROW TYPE VECTOR (AND FRIENDS)
 948
 949 TYBLO:  ASH     A,1             ; TWO WORD PER TYPE
 950         HRRZ    B,TYPVEC+1      ; FIND CURRENT ROOM
 951         MOVE    D,TYPBOT+1
 952         SUBI    B,(D)
 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
 958         SUB     D,0
 959         DPB     A,[1100,,(D)]
 960         SKIPE   D,EVATYP+1      ; GROW AUX TYPE VECS IF NEEDED
 961         PUSHJ   P,SGROW1
 962         SKIPE   D,APLTYP+1
 963         PUSHJ   P,SGROW1
 964         SKIPE   D,PRNTYP+1
 965         PUSHJ   P,SGROW1
 966         AOJA    C,CPOPJ
 967
 968 ; HERE TO CREATE STORAGE SPACE
 969
 970 STBLO:  MOVE    D,GCSBOT        ; HOW MUCH NOW HERE
 971         SUB     D,CODTOP
 972         SUBI    A,(D)           ; MORE NEEDED?
 973         JUMPLE  A,CPOPJ
 974         MOVEM   A,PARNEW        ; FORCE PAIR SPACE TO MOVE ON OUT
 975         AOJA    C,CPOPJ
 976
 977 ; BLOAT P STACK
 978
 979 PBLO:   HLRE    D,P
 980         MOVNS   B,D
 981         SUBI    D,5             ; FUDGE FOR THIS CALL
 982         SUBI    A,(D)
 983         JUMPLE  A,CPOPJ
 984         ADDI    B,1(P)          ; POINT TO DOPE
 985         CAME    B,PGROW         ; BLOWN?
 986         ADDI    B,PDLBUF        ; NOPE, POIN TO REAL D.W.
 987         ADDI    A,63.
 988         ASH     A,-6            ; TO 64 WRD BLOCKS
 989         CAILE   A,377           ; IN RANGE?
 990         JRST    OUTRNG
 991         DPB     A,[111100,,-1(B)]
 992         AOJA    C,CPOPJ
 993
 994 ; SET FREMIN
 995
 996 SFREM:  SKIPE   A               ; DON'T ZERO EMPTY PARAMETER
 997         MOVEM   A,FREMIN
 998         POPJ    P,
 999
1000 ; SET LVAL INCREMENT
1001
1002 SLVL:   IMULI   A,6             ; CALCULATE AMOUNT TO GROW B
1003         MOVEI   B,LVLINC
1004         PUSHJ   P,NUMADJ
1005         MOVEM   A,LVLINC
1006         POPJ P,
1007
1008 ; SET GVAL INCREMENT
1009
1010 SGVL:   IMULI   A,4.            ; # OF SLOTS
1011         MOVEI   B,GVLINC
1012         PUSHJ   P,NUMADJ
1013         MOVEM   A,GVLINC
1014         POPJ    P,
1015
1016 ; SET TYPE INCREMENT
1017
1018 STYP:   IMULI   A,2             ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
1019         MOVEI   B,TYPIC
1020         PUSHJ   P,NUMADJ
1021         MOVEM   A,TYPIC
1022         POPJ    P,
1023
1024 ; SET STORAGE INCREMENT
1025
1026 SSTO:   IDIVI   A,2000          ; # OF BLOCKS
1027         CAIE    B,0             ; REMAINDER?
1028         ADDI    A,1
1029         IMULI   A,2000          ; CONVERT BACK TO WORDS
1030         MOVEM   A,STORIC
1031         POPJ    P,
1032 ; HERE FOR MINIMUM PURE SPACE
1033
1034 PUMIN:  ADDI    A,1777
1035         ANDCMI  A,1777          ; TO PAGE BOUNDRY
1036         MOVEM   A,PURMIN
1037         POPJ    P,
1038
1039 ; HERE TO ADJUST PSTACK PARAMETERS IN GC
1040
1041 PMUNG:  ADDI    A,777           ; TO NEAREST 1000 WORD BOUNDRY
1042         ANDCMI  A,777
1043         MOVEM   A,PGOOD         ; PGOOD
1044         ASH     A,2             ; PMAX IS 4*PGOOD
1045         MOVEM   A,PMAX
1046         ASH     A,-4            ; PMIN IS .25*PGOOD
1047         MOVEM   A,PMIN
1048
1049 ; HERE TO ADJUST GC TPSTACK PARAMS
1050
1051 TPMUNG: ADDI    A,777
1052         ANDCMI  A,777           ; TO NEAREST 1000 WORD BOUNDRY
1053         MOVEM   A,TPGOOD
1054         ASH     A,2             ; TPMAX= 4*TPGOOD
1055         MOVEM   A,TPMAX
1056         ASH     A,-4            ; TPMIN= .25*TPGOOD
1057         MOVEM   A,TPMIN
1058
1059
1060 ; GET NEXT (FIX) ARG
1061
1062 NXTFIX: PUSHJ   P,GETFIX
1063         ADD     AB,C%22
1064         POPJ    P,
1065
1066 ; ROUTINE TO GET POS FIXED ARG
1067
1068 GETFIX: GETYP   A,(AB)
1069         CAIE    A,TFIX
1070         JRST    WRONGT
1071         SKIPGE  A,1(AB)
1072         JRST    BADNUM
1073         POPJ    P,
1074
1075
1076 ; GET NUMBERS FIXED UP FOR GROWTH FIELDS
1077
1078 NUMADJ: ADDI    A,77            ; ROUND UP
1079         ANDCMI  A,77            ; KILL CRAP
1080         MOVE    0,A
1081         MOVNS   A               ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
1082         HRLI    A,-1(A)
1083         MOVEM   A,(B)           ; AND STASH IT
1084         MOVE    A,0
1085         ASH     A,-6            ; TO 64 WD BLOCKS
1086         CAILE   A,377           ; CHECK FIT
1087         JRST    OUTRNG
1088         POPJ    P,
1089
1090 ; DO SYMPATHETIC GROWTHS
1091
1092 SGROW1: HLRE    0,D
1093         SUB     D,0
1094         DPB     A,[111100,,(D)]
1095         POPJ    P,
1096
1097 \f;FUNCTION TO CONSTRUCT A LIST
1098
1099 MFUNCTION CONS,SUBR
1100
1101         ENTRY   2
1102         GETYP   A,2(AB)         ;GET TYPE OF 2ND ARG
1103         CAIE    A,TLIST         ;LIST?
1104         JRST    WTYP2           ;NO , COMPLAIN
1105         MOVE    C,(AB)          ; GET THING TO CONS IN
1106         MOVE    D,1(AB)
1107         HRRZ    E,3(AB)         ; AND LIST
1108         PUSHJ   P,ICONS         ; INTERNAL CONS
1109         JRST    FINIS
1110
1111 ; COMPILER CALL TO CONS
1112
1113 C1CONS: PUSHJ   P,ICELL2
1114         JRST    ICONS2
1115 ICONS4: HRRI    C,(E)
1116 ICONS3: MOVEM   C,(B)           ; AND STORE
1117         MOVEM   D,1(B)
1118 TLPOPJ: MOVSI   A,TLIST
1119         POPJ    P,
1120
1121 ; INTERNAL CONS--ICONS;  C,D VALUE, E CDR
1122
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.
1126
1127 CICONS: SUBM    M,(P)
1128         PUSHJ   P,ICONS
1129         JRST    MPOPJ
1130
1131 ; INTERNAL CONS TO NIL--INCONS
1132
1133 INCONS: MOVEI   E,0
1134
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)
1140         JRST    ICONS4
1141
1142 ; HERE IF CONSING DEFERRED
1143
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
1148         MOVEM   E,(B)           ; STORE
1149         MOVEI   E,2(B)          ; POINT E TO VAL CELL
1150         HRRZM   E,1(B)
1151         MOVEM   C,(E)           ; STORE VALUE
1152         MOVEM   D,1(E)
1153         JRST    TLPOPJ
1154
1155
1156
1157 ; HERE TO GC ON A CONS
1158
1159 ; HERE FROM C1CONS
1160 ICONS2: SUBM    M,(P)
1161         PUSHJ   P,ICONSG
1162         SUBM    M,(P)
1163         JRST    C1CONS
1164
1165 ; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
1166 ICNS2A: PUSHJ   P,ICONSG
1167         JRST    ICONS
1168
1169 ; REALLY DO GC
1170 ICONSG: PUSH    TP,C            ; SAVE VAL
1171         PUSH    TP,D
1172         PUSH    TP,$TLIST
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
1178         MOVE    C,-3(TP)
1179         MOVE    E,(TP)
1180         SUB     TP,C%44         ; [4,,4]
1181         POPJ    P,              ; BACK TO DRAWING BOARD
1182
1183 ; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE.  CALLS AGC IF NEEDED
1184
1185 CELL2:  MOVEI   A,2             ; USUAL CASE
1186 CELL:   PUSHJ   P,ICELL         ; INTERNAL
1187         JRST    .+2             ; LOSER
1188         POPJ    P,
1189
1190         ADDM    A,GETNUM        ; AMOUNT REQUIRED
1191         PUSH    P,A             ; PREVENT AGC DESTRUCTION
1192         MOVE    C,[3,,1]        ; INDICATOR FOR AGC
1193         PUSHJ   P,INQAGC
1194         POP     P,A
1195         JRST    CELL            ; AND TRY AGAIN
1196
1197 ; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
1198
1199 ICELL2: MOVEI   A,2             ; MOST LIKELY CAE
1200 ICELL:  SKIPE   B,RCL
1201         JRST    ICELRC          ;SEE IF WE CAN RE-USE A RECYCLE CELL
1202         MOVE    B,PARTOP        ; GET TOP OF PAIRS
1203         ADDI    B,(A)           ; BUMP
1204         CAMLE   B,FRETOP        ; SKIP IF OK.
1205         JRST    VECTRY          ; LOSE
1206         EXCH    B,PARTOP        ; SETUP NEW PARTOP AND RETURN POINTER
1207         ADDM    A,USEFRE
1208         JRST    CPOPJ1          ; SKIP RETURN
1209
1210 ; TRY RECYCLING USING A VECTOR FROM RCLV
1211
1212 VECTRY: SKIPN   B,RCLV          ; SKIP IF VECTOR EXISTS
1213         POPJ    P,
1214         PUSH    P,C
1215         PUSH    P,A
1216         MOVEI   C,RCLV
1217 VECTR1: HLRZ    A,(B)           ; GET LENGTH
1218         SUB     A,(P)
1219         JUMPL   A,NXTVEC        ; DOESN'T SATISFY TRY AGAIN
1220         CAIN    A,1             ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
1221         JRST    NXTVEC
1222         JUMPN   A,SOML          ; SOME ARE LEFT
1223         HRRZ    A,(B)
1224         HRRM    A,(C)
1225         HLRZ    A,(B)
1226         SETZM   (B)
1227         SETZM   -1(B)           ; CLEAR DOPE WORDS
1228         SUBI    B,-1(A)
1229         POP     P,A             ; CLEAR STACK
1230         POP     P,C
1231         JRST    CPOPJ1
1232 SOML:   HRLM    A,(B)           ; SMASH AMOUNT LEFT
1233         SUBI    B,-1(A)         ; GET TO BEGINNING
1234         SUB     B,(P)
1235         POP     P,A
1236         POP     P,C
1237         JRST    CPOPJ1
1238 NXTVEC: MOVEI   C,(B)
1239         HRRZ    B,(B)           ; GET NEXT
1240         JUMPN   B,VECTR1
1241         POP     P,A
1242         POP     P,C
1243         POPJ    P,
1244
1245 ICELRC: CAIE    A,2
1246         JRST    ICELL+2         ;IF HE DOESNT WANT TWO, USE OLD METHOD
1247         PUSH    P,A
1248         MOVE    A,(B)
1249         HRRZM   A,RCL
1250         POP     P,A
1251         SETZM   (B)             ;GIVE HIM A CLEAN RECYCLED CELL
1252         SETZM   1(B)
1253         JRST    CPOPJ1          ;THAT IT
1254
1255
1256 \f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
1257
1258 IMFUNCTION LIST,SUBR
1259         ENTRY
1260
1261         PUSH    P,$TLIST
1262 LIST12: HLRE    A,AB            ;GET -NUM OF ARGS
1263         PUSH    TP,$TAB
1264         PUSH    TP,AB
1265         MOVNS   A               ;MAKE IT +
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
1271         PUSH    TP,B
1272         SUB     P,C%11
1273         LSH     A,-1            ;NUMBER OF REAL LIST ELEMENTS
1274
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
1279
1280 ; NOW LOBEER THE DATA IN TO THE LIST
1281
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
1288         HRLM    A,(B)
1289         MOVE    A,1(D)          ;AND VALUE..
1290         MOVEM   A,1(B)
1291 LISTL2: HRRZ    B,(B)           ;REST B
1292         ADD     D,C%22          ;STEP ARGS
1293         JUMPL   D,LISTLP
1294
1295         POP     TP,B
1296         POP     TP,A
1297         SUB     TP,C%22         ; CLEANUP STACK
1298         JRST    FINIS
1299
1300
1301 LST12R: ASH     A,-1            ;ONE AT A TIME TO GET RECYCLED CELLS
1302         JUMPE   A,LISTN
1303         PUSH    P,A             ;SAVE COUNT ON STACK
1304         SETZM   E
1305         SETZB   C,D
1306         PUSHJ   P,ICONS
1307         MOVE    E,B             ;LOOP AND CHAIN TOGETHER
1308         SOSLE   (P)
1309         JRST    .-4
1310         PUSH    TP,-1(P)        ;PUSH ON THE TYPE WE WANT
1311         PUSH    TP,B
1312         SUB     P,C%22          ;CLEAN UP AFTER OURSELVES
1313         JRST    LISTLP-2        ;AND REJOIN MAIN STREAM
1314
1315
1316 ; MAKE A DEFERRED POINTER
1317
1318 LDEFER: PUSH    TP,$TLIST       ;SAVE CURRENT POINTER
1319         PUSH    TP,B
1320         MOVEM   D,1(TB)         ; SAVE ARG HACKER
1321         PUSHJ   P,CELL2
1322         MOVE    D,1(TB)
1323         GETYPF  A,(D)           ;GET FULL DATA
1324         MOVE    C,1(D)
1325         MOVEM   A,(B)
1326         MOVEM   C,1(B)
1327         MOVE    C,(TP)          ;RESTORE LIST POINTER
1328         MOVEM   B,1(C)          ;AND MAKE THIS BE THE VALUE
1329         MOVSI   A,TDEFER
1330         HLLM    A,(C)           ;AND STORE IT
1331         MOVE    B,C
1332         SUB     TP,C%22
1333         JRST    LISTL2
1334
1335 LISTN:  MOVEI   B,0
1336         POP     P,A
1337         JRST    FINIS
1338
1339 ; BUILD A FORM
1340
1341 IMFUNCTION FORM,SUBR
1342
1343         ENTRY
1344
1345         PUSH    P,$TFORM
1346         JRST    LIST12
1347
1348 \f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
1349
1350 IILIST: SUBM    M,(P)
1351         PUSHJ   P,IILST
1352         MOVSI   A,TLIST
1353         JRST    MPOPJ
1354
1355 IIFORM: SUBM    M,(P)
1356         PUSHJ   P,IILST
1357         MOVSI   A,TFORM
1358         JRST    MPOPJ
1359
1360 IILST:  JUMPE   A,IILST0        ; NIL WHATSIT
1361         PUSH    P,A
1362         MOVEI   E,0
1363 IILST1: POP     TP,D
1364         POP     TP,C
1365         PUSHJ   P,ICONS         ; CONS 'EM UP
1366         MOVEI   E,(B)
1367         SOSE    (P)             ; COUNT
1368         JRST    IILST1
1369
1370         SUB     P,C%11
1371         POPJ    P,
1372
1373 IILST0: MOVEI   B,0
1374         POPJ    P,
1375
1376 \f;FUNCTION TO BUILD AN IMPLICIT LIST
1377
1378 MFUNCTION ILIST,SUBR
1379         ENTRY
1380         PUSH    P,$TLIST
1381 ILIST2: JUMPGE  AB,TFA          ;NEED AT LEAST ONE ARG
1382         CAMGE   AB,C%M40        ; [-4,,0] ; NO MORE THAN TWO ARGS
1383         JRST    TMA
1384         PUSHJ   P,GETFIX        ; GET POS FIX #
1385         JUMPE   A,LISTN         ;EMPTY LIST ?
1386         CAML    AB,C%M20        ; [-2,,0] ;ONLY ONE ARG?
1387         JRST    LOSEL           ;YES
1388         PUSH    P,A             ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
1389 ILIST0: PUSH    TP,2(AB)
1390         PUSH    TP,(AB)3
1391         MCALL   1,EVAL
1392         PUSH    TP,A
1393         PUSH    TP,B
1394         SOSLE   (P)
1395         JRST    ILIST0
1396         POP     P,C
1397 ILIST1: MOVE    C,(AB)+1        ;REGOBBLE LENGTH
1398         ACALL   C,LIST
1399 ILIST3: POP     P,A             ; GET FINAL TYPE
1400         JRST    FINIS
1401
1402
1403 LOSEL:  PUSH    P,A             ; SAVE COUNT
1404         MOVEI   E,0
1405
1406 LOSEL1: SETZB   C,D             ; TLOSE,,0
1407         PUSHJ   P,ICONS
1408         MOVEI   E,(B)
1409         SOSLE   (P)
1410         JRST    LOSEL1
1411
1412         SUB     P,C%11
1413         JRST    ILIST3
1414
1415 ; IMPLICIT FORM
1416
1417 MFUNCTION IFORM,SUBR
1418
1419         ENTRY
1420         PUSH    P,$TFORM
1421         JRST    ILIST2
1422
1423 \f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
1424
1425 MFUNCTION VECTOR,SUBR,[IVECTOR]
1426
1427         MOVEI   C,1
1428         JRST    VECTO3
1429
1430 MFUNCTION UVECTOR,SUBR,[IUVECTOR]
1431
1432         MOVEI   C,0
1433 VECTO3: ENTRY
1434         JUMPGE  AB,TFA          ; AT LEAST ONE ARG
1435         CAMGE   AB,C%M40        ; [-4,,0] ; NOT MORE THAN 2
1436         JRST    TMA
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)
1441         POP     P,C
1442         HLRE    A,B             ; START TO
1443         SUBM    B,A             ; FIND DOPE WORD
1444         MOVSI   D,.VECT.                ; FOR GCHACK
1445         IORM    D,(A)
1446         JUMPE   C,VECTO4
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
1452         JRST    FINIS
1453         JUMPGE  B,FINIS         ; DON'T EVAL FOR EMPTY CASE
1454
1455         PUSH    TP,A            ; SAVE THE VECTOR
1456         PUSH    TP,B
1457         PUSH    TP,A
1458         PUSH    TP,B
1459
1460         JUMPE   C,UINIT
1461         JUMPGE  B,FINIS         ; EMPTY VECTOR, LEAVE
1462 INLP:   PUSHJ   P,IEVAL         ; EVAL EXPR
1463         MOVEM   A,(C)
1464         MOVEM   B,1(C)
1465         ADD     C,C%22          ; BUMP VECTOR
1466         MOVEM   C,(TP)
1467         JUMPL   C,INLP          ; IF MORE DO IT
1468
1469 GETVEC: MOVE    A,-3(TP)
1470         MOVE    B,-2(TP)
1471         SUB     TP,C%44         ; [4,,4]
1472         JRST    FINIS
1473
1474 ; HERE TO FILL UP A UVECTOR
1475
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
1486         IORM    D,(C)
1487         MOVE    C,(TP)          ; GET BACK VECTOR
1488         SKIPE   1(AB)
1489         JRST    UINLP1          ; START FILLING UV
1490         JRST    GETVE1
1491
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
1498         AOBJN   C,UINLP
1499 GETVE1: SUB     P,C%11
1500         JRST    GETVEC          ; AND RETURN VECTOR
1501
1502 IEVAL:  PUSH    TP,2(AB)
1503         PUSH    TP,3(AB)
1504         MCALL   1,EVAL
1505         MOVE    C,(TP)
1506         POPJ    P,
1507
1508 ; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
1509
1510 MFUNCTION ISTORAGE,SUBR
1511         ENTRY
1512         JUMPGE  AB,TFA
1513         CAMGE   AB,C%M40        ; [-4,,0] ; AT LEAST ONE ARG
1514         JRST    TMA
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)
1519         MOVM    B,B             ; +COUNT
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).
1524         MOVE    B,A
1525         MOVSI   A,TSTORAGE
1526         CAML    AB,C%M20        ; [-2,,0] ; SECOND ARG TO EVAL?
1527         JRST     FINIS          ; IF NOT, RETURN EMPTY
1528         PUSH    TP,A
1529         PUSH    TP,B
1530         PUSH    TP,A
1531         PUSH    TP,B
1532         PUSHJ   P,IEVAL         ; EVALUATE FOR FIRST VALUE
1533         GETYP   A,A
1534         PUSH    P,A             ; FOR COMPARISON LATER
1535         PUSHJ   P,SAT
1536         CAIN    A,S1WORD
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
1541
1542 ; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
1543 FREESV: MOVE    A,1(AB)         ; GET COUNT
1544         ADDI    A,2             ; FOR DOPE
1545         HRRZ    B,(TP)          ; GET ADDRESS
1546         PUSHJ   P,CAFRET        ; FREE THE CORE
1547         POPJ    P,
1548
1549 \f
1550 ; INTERNAL VECTOR ALLOCATOR.  A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
1551
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?
1558         JRST    RCLVEC
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
1563         JRST    IVECT1
1564         MOVEM   B,GCSTOP        ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
1565         ADDM    A,USEFRE
1566         HRRZS   USEFRE
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
1570         SOS     -1(B)
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
1574         HRRI    A,TVEC
1575         SKIPL   A
1576         HRRI    A,TUVEC
1577         MOVSI   A,(A)
1578         POPJ    P,
1579
1580 ; HERE TO DO A GC ON A VECTOR ALLOCATION
1581
1582 IVECT1: PUSH    P,0
1583         PUSH    P,A             ; SAVE DESIRED LENGTH
1584         HRRZ    0,A
1585         ADDM    0,GETNUM        ; AND STORE AS DESIRED AMOUNT
1586         MOVE    C,[4,,1]        ; GET INDICATOR FOR AGC
1587         PUSHJ   P,INQAGC
1588         POP     P,A
1589         POP     P,0
1590         POP     P,B
1591         JRST    IBLOK2
1592
1593
1594 ; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
1595 ; ITEMS ON TOP OF STACK
1596
1597 IEVECT: ASH     A,1             ; TO NUMBER OF WORDS
1598         PUSH    P,A
1599         PUSHJ   P,IBLOCK        ; GET VECTOR
1600         HLRE    D,B             ; FIND DW
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
1608         MOVSI   C,(C)
1609         HRRI    C,(B)           ; B/ SOURCE,,DEST
1610         BLT     C,-1(D)         ; XFER THE DATA
1611         HRLI    A,(A)
1612         SUB     TP,A            ; FLUSH STACKAGE
1613 IVEC1:  MOVSI   A,TVEC
1614         POPJ    P,
1615
1616
1617 ; COMPILERS CALL
1618
1619 CIVEC:  SUBM    M,(P)
1620         PUSHJ   P,IEVECT
1621         JRST    MPOPJ
1622
1623
1624 \f; INTERNAL CALL TO EUVECTOR
1625
1626 IEUVEC: PUSH    P,A             ; SAVE LENGTH
1627         PUSHJ   P,IBLOCK
1628         MOVE    A,(P)
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
1635         PUSHJ   P,NWORDT
1636         SOJN    A,CANTUN        ; WONT FIT
1637         GETYP   E,(C)
1638
1639 IEUVE2: GETYP   0,(C)           ; TYPE OF EL
1640         CAIE    0,(E)           ; MATCH?
1641         JRST    WRNGUT
1642         MOVE    0,1(C)
1643         MOVEM   0,(D)           ; CLOBBER
1644         ADDI    C,2
1645         AOBJN   D,IEUVE2        ; LOOP
1646         TRO     E,.VECT.
1647         HRLZM   E,(D)           ; STORE UTYPE
1648 IEUVE1: POP     P,A             ; GET COUNY
1649         ASH     A,1             ; MUST FLUSH 2 TIMES # OF ELEMENTS
1650         HRLI    A,(A)
1651         SUB     TP,A            ; CLEAN UP STACK
1652         MOVSI   A,TUVEC
1653         POPJ    P,
1654
1655 ; COMPILER'S CALL
1656
1657 CIUVEC: SUBM    M,(P)
1658         PUSHJ   P,IEUVEC
1659         JRST    MPOPJ
1660
1661 IMFUNCTION EVECTOR,SUBR,[VECTOR]
1662         ENTRY
1663         HLRE    A,AB
1664         MOVNS   A
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
1669
1670         HRLI    C,(AB)          ;START BUILDING BLT POINTER
1671         HRRI    C,(B)           ;TO ADDRESS
1672         ADDI    D,@(P)          ;SET D TO FINAL ADDRESS
1673         BLT     C,(D)
1674 FINISV: MOVSI   0,400000+.VECT.
1675         MOVEM   0,1(D)          ; MARK AS GENERAL
1676         SUB     P,C%11
1677         MOVSI   A,TVEC
1678         JRST    FINIS
1679
1680
1681
1682 \f;EXPLICIT VECTORS FOR THE UNIFORM CSE
1683
1684 IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
1685
1686         ENTRY
1687         HLRE    A,AB            ;-NUM OF ARGS
1688         MOVNS   A
1689         ASH     A,-1            ;NEED HALF AS MANY WORDS
1690         PUSH    P,A
1691         JUMPGE  AB,EUV1         ; DONT CHECK FOR EMPTY
1692         GETYP   A,(AB)          ;GET FIRST ARG
1693         PUSHJ   P,NWORDT                ;SEE IF NEEDS EXTRA WORDS
1694         SOJN    A,CANTUN
1695 EUV1:   POP     P,A
1696         PUSHJ   P,IBLOCK        ; GET VECT
1697         JUMPGE  B,FINISU
1698
1699         GETYP   C,(AB)          ;GET THE FIRST TYPE
1700         MOVE    D,AB            ;COPY THE ARG POINTER
1701         MOVE    E,B             ;COPY OF RESULT
1702
1703 EUVLP:  GETYP   0,(D)           ;GET A TYPE
1704         CAIE    0,(C)           ;SAME?
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
1709         AOBJN   E,EUVLP
1710
1711         TRO     C,.VECT.
1712         HRLM    C,(E)           ;CLOBBER UNIFORM TYPE IN
1713 FINISU: MOVSI   A,TUVEC
1714         JRST    FINIS
1715
1716 WRNGSU: GETYP   A,-1(TP)
1717         CAIE    A,TSTORAGE
1718         JRST    WRNGUT          ;IF UVECTOR
1719         PUSHJ   P,FREESV        ;FREE STORAGE VECTOR
1720         ERRUUO  EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
1721
1722 WRNGUT: ERRUUO  EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
1723
1724 CANTUN: ERRUUO  EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
1725
1726 BADNUM: ERRUUO  EQUOTE NEGATIVE-ARGUMENT
1727 \f; FUNCTION TO GROW A VECTOR
1728 REPEAT 0,[
1729 MFUNCTION GROW,SUBR
1730
1731         ENTRY   3
1732
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
1738         CAIN    A,SPSTK
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
1744         GETYP   B,4(AB)
1745         CAIE    B,TFIX          ;3RD ARG
1746         JRST    WTYP3           ;LOSE
1747
1748         MOVEI   E,1             ;UNIFORM/GENERAL FLAG
1749         CAIE    A,SNWORD        ;SKIP IF UNIFORM
1750         CAIN    A,SPSTK         ;DONT SKIP IF UNIFORM PDL
1751         MOVEI   E,0
1752
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
1766         MOVNS   A
1767         TLNE    A,-1            ;SKIP IF NOT TOO BIG
1768         JRST    GTOBIG          ;ERROR
1769 GROW1:  SKIPN   C,5(AB)         ;CHECK LOW GROWTH
1770         JRST    GROW4           ;NONE, SKIP
1771         ASH     C,(E)           ;GENRAL FUDGE
1772         ADDI    C,77            ;ROUND
1773         ANDCMI  C,77            ;FUDGE FOR VALUE RETURN
1774         PUSH    P,C             ;AND SAVE
1775         ASH     C,-6            ;DIVIDE BY 100
1776         TRZE    C,400           ;CONVERT TO SIGN MAGNITUDE
1777         MOVNS   C
1778         TDNE    C,[-1,,777000]  ;CHECK FOR OVERFLOW
1779         JRST    GTOBIG
1780 GROW2:  HLRZ    E,1(B)          ;GET TOTAL LENGTH OF VECTOR
1781         MOVNI   E,-1(E)
1782         HRLI    E,(E)           ;TO BOTH HALVES
1783         ADDI    E,1(B)          ;POINTS TO TOP
1784         SKIPE   D               ;STACK?
1785         ADD     E,[PDLBUF,,0]   ;YES, FUDGE LENGTH
1786         SKIPL   D,(P)           ;SHRINKAGE?
1787         JRST    GROW3           ;NO, CONTINUE
1788         MOVNS   D               ;PLUSIFY
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
1797         PUSHJ   P,AGC
1798         JUMPL   A,GROFUL
1799         POP     P,C             ;RESTORE GROWTH
1800         HRLI    C,(C)
1801         POP     TP,B            ;GET VECTOR POINTER
1802         SUB     B,C             ;POINT TO NEW TOP
1803         POP     TP,A
1804         JRST    FINIS
1805
1806 GROFUL: SUB     P,C%11          ; CLEAN UP STACK
1807         SUB     TP,C%22
1808         PUSHJ   P,FULLOS
1809         JRST    GROW
1810
1811 GTOBIG: ERRUUO  EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
1812 GROW4:  PUSH    P,[0]           ;0 BOTTOM GROWTH
1813         JRST    GROW2
1814 ]
1815 FULLOS: ERRUUO  EQUOTE NO-STORAGE
1816
1817
1818 \f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
1819
1820 MFUNCTION BYTES,SUBR
1821
1822         ENTRY
1823         MOVEI   D,1
1824         JUMPGE  AB,TFA
1825         GETYP   0,(AB)
1826         CAIE    0,TFIX
1827         JRST    WTYP1
1828         MOVE    E,1(AB)
1829         ADD     AB,C%22
1830         JRST    STRNG1
1831
1832 IMFUNCTION STRING,SUBR
1833
1834         ENTRY
1835
1836         MOVEI   D,0
1837         MOVEI   E,7
1838 STRNG1: MOVE    B,AB            ;COPY ARG POINTER
1839         MOVEI   C,0             ;INITIALIZE COUNTER
1840         PUSH    TP,$TAB         ;SAVE A COPY
1841         PUSH    TP,B
1842         HLRE    A,B             ; GET # OF ARGS
1843         MOVNS   A
1844         ASH     A,-1            ; 1/2 FOR # OF ARGS
1845         PUSHJ   P,IISTRN
1846         JRST    FINIS
1847
1848 IISTRN: PUSH    P,E
1849         JUMPL   E,OUTRNG
1850         CAILE   E,36.
1851         JRST    OUTRNG
1852         SKIPN   E,A             ; SKIP IF ARGS EXIST
1853         JRST    MAKSTR          ; ALL DONE
1854
1855 STRIN2: GETYP   0,(B)           ;GET TYPE CODE
1856         CAMN    0,SING(D)       ; SINGLE CHARACTER OR FIX?
1857         AOJA    C,STRIN1
1858         CAME    0,MULTI(D)      ; OR STRING OR BYTE-STRING
1859         JRST    WRONGT          ;NEITHER
1860         HRRZ    0,(B)           ; GET CHAR COUNT
1861         ADD     C,0             ; AND BUMP
1862
1863 STRIN1: ADD     B,C%22
1864         SOJG    A,STRIN2
1865
1866 ; NOW GET THE NECESSARY VECTOR
1867
1868 MAKSTR: HRL     C,MULTI(D)              ; FINAL TYPE,, CHAR COUNT
1869         PUSH    P,C             ; SAVE CHAR COUNT
1870         PUSH    P,E             ; SAVE ARG COUNT
1871         MOVEI   D,36.
1872         IDIV    D,-2(P)         ; A==> BYTES PER WORD
1873         MOVEI   A,(C)           ; LNTH+4 TO A
1874         ADDI    A,-1(D)
1875         IDIVI   A,(D)
1876         LSH     E,12.
1877         MOVE    D,-2(P)
1878         DPB     D,[060600,,E]
1879         HRLM    E,-2(P)         ; SAVE REMAINDER
1880         PUSHJ   P,IBLOCK
1881
1882         POP     P,A
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
1886         DPB     0,[300600,,B]
1887         MOVE    C,(TP)          ; POINT TO ARGS AGAIN
1888
1889 NXTRG1: GETYP   D,(C)           ;GET AN ARG
1890         CAIN    D,TFIX
1891          JRST   .+3
1892         CAIE    D,TCHRS
1893          JRST   TRYSTR
1894         MOVE    D,1(C)                  ; GET IT
1895         IDPB    D,B             ;AND DEPOSIT IT
1896         JRST    NXTARG
1897
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
1903         JRST    NXTCHR
1904
1905 NXTARG: ADD     C,C%22          ;BUMP ARG POINTER
1906         SOJG    A,NXTRG1
1907         ADDI    B,1
1908
1909 DONEC:  MOVSI   C,TCHRS+.VECT.
1910         TLO     B,400000
1911         HLLM    C,(B)           ;AND CLOBBER AWAY
1912         HLRZ    C,1(B)          ;GET LENGTH BACK
1913         POP     P,A
1914         SUBI    B,-1(C)
1915         HLL     B,(P)           ;MAKE A BYTE POINTER
1916         SUB     P,C%11
1917         POPJ    P,
1918
1919 SING:   TCHRS
1920         TFIX
1921
1922 MULTI:  TCHSTR
1923         TBYTE
1924
1925
1926 ; COMPILER'S CALL TO MAKE A STRING
1927
1928 CISTNG: TDZA    D,D
1929
1930 ; COMPILERS CALL TO MAKE A BYTE STRING
1931
1932 CBYTES: MOVEI   D,1
1933         SUBM    M,(P)
1934         MOVEI   C,0             ; INIT CHAR COUNTER
1935         MOVEI   B,(A)           ; SET UP STACK POINTER
1936         ASH     B,1             ; * 2 FOR NO. OF SLOTS
1937         HRLI    B,(B)
1938         SUBM    TP,B            ; B POINTS TO ARGS
1939         PUSH    P,D
1940         MOVEI   E,7
1941         JUMPE   D,CBYST
1942         GETYP   0,1(B)          ; CHECK BYTE SIZE
1943         CAIE    0,TFIX
1944         JRST    WRONGT
1945         MOVE    E,2(B)
1946         ADD     B,C%22
1947         SUBI    A,1
1948 CBYST:  ADD     B,C%11
1949         PUSH    TP,$TTP
1950         PUSH    TP,B
1951         PUSHJ   P,IISTRN        ; MAKE IT HAPPEN
1952         MOVE    TP,(TP)         ; FLUSH ARGS
1953         SUB     TP,C%11
1954         POP     P,D
1955         JUMPE   D,MPOPJ
1956         SUB     TP,C%22
1957         JRST    MPOPJ
1958
1959 \f;BUILD IMPLICT STRING
1960
1961 MFUNCTION IBYTES,SUBR
1962
1963         ENTRY
1964
1965         CAML    AB,C%M20                ; [-3,,] ; AT LEAST 2
1966          JRST   TFA
1967         CAMGE   AB,C%M60                ; [-7,,] ; NO MORE THAN 3
1968          JRST   TMA
1969         PUSHJ   P,GETFIX        ; GET BYTE SIZE
1970         JUMPL   A,OUTRNG
1971         CAILE   A,36.
1972          JRST   OUTRNG
1973         PUSH    P,[TFIX]
1974         PUSH    P,A
1975         PUSH    P,$TBYTE
1976         ADD     AB,C%22
1977         MOVEM   AB,ABSAV(TB)
1978         JRST    ISTR1
1979
1980 MFUNCTION ISTRING,SUBR
1981
1982         ENTRY
1983         JUMPGE  AB,TFA          ; TOO FEW ARGS
1984         CAMGE   AB,C%M40        ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
1985          JRST   TMA
1986         PUSH    P,[TCHRS]
1987         PUSH    P,[7]
1988         PUSH    P,$TCHSTR
1989 ISTR1:  PUSHJ   P,GETFIX
1990         MOVEI   C,36.
1991         IDIV    C,-1(P)
1992         ADDI    A,-1(C)
1993         IDIVI   A,(C)           ; # OF WORDS NEEDED TO A
1994         ASH     D,12.
1995         MOVE    C,-1(P)         ; GET BYTE SIZE
1996         DPB     C,[060600,,D]
1997         PUSH    P,D
1998         PUSHJ   P,IBLOCK
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
2002         HLLM    D,(C)
2003         MOVE    A,-1(P)
2004         HRR     A,1(AB)         ; SETUP TYPE'S RH
2005         SUBI    B,1
2006         HRL     B,(P)           ; AND BYTE POINTER
2007         SUB     P,C%33
2008         SKIPE   (AB)+1          ; SKIP IF NO CHARACTERS TO DEPOSIT
2009         CAML    AB,C%M20        ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
2010          JRST   FINIS
2011         PUSH    TP,A            ;SAVE OUR STRING
2012         PUSH    TP,B
2013         PUSH    TP,A            ;SAVE A TEMPORARY CLOBBER POINTER
2014         PUSH    TP,B
2015         PUSH    P,(AB)1         ;SAVE COUNT
2016         PUSH    TP,(AB)+2
2017         PUSH    TP,(AB)+3
2018 CLOBST: PUSH    TP,-1(TP)
2019         PUSH    TP,-1(TP)
2020         MCALL   1,EVAL
2021         GETYP   C,A             ; CHECK IT
2022         CAME    C,-1(P)         ; MUST BE A CHARACTER
2023          JRST   WTYP2
2024         IDPB    B,-2(TP)        ;CLOBBER
2025         SOSLE   (P)             ;FINISHED?
2026          JRST   CLOBST          ;NO
2027         SUB     P,C%22
2028         SUB     TP,C%66
2029         MOVE    A,(TP)+1
2030         MOVE    B,(TP)+2
2031         JRST    FINIS
2032
2033 \f
2034 ; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
2035 ;       PUNT SOME IF THERE ARE.
2036
2037 INQAGC: PUSH    P,C
2038         PUSH    P,B
2039         PUSH    P,A
2040         PUSH    P,E
2041         PUSHJ   P,SQKIL
2042         JSP     E,CKPUR         ; CHECK FOR PURE RSUBR
2043         POP     P,E
2044         MOVE    A,PURTOP
2045         SUB     A,CURPLN
2046         MOVE    B,RFRETP        ; GET REAL FRETOP
2047         CAIL    B,(A)
2048         MOVE    B,A             ; TOP OF WORLD
2049         MOVE    A,GCSTOP
2050         ADD     A,GETNUM
2051         ADDI    A,1777          ; PAGE BOUNDARY
2052         ANDCMI  A,1777
2053         CAIL    A,(B)           ; SEE WHETHER THERE IS ROOM
2054         JRST    GOTOGC
2055         PUSHJ   P,CLEANT
2056         POP     P,A
2057         POP     P,B
2058         POP     P,C
2059         POPJ    P,
2060 GOTOGC: POP     P,A
2061         POP     P,B
2062         POP     P,C             ; RESTORE CAUSE INDICATOR
2063         MOVE    A,P.TOP
2064         PUSHJ   P,CLEANT        ; CLEAN UP
2065         SKIPL   PLODR           ; IF IN PLOAD DON'T INTERRUPT
2066          JRST   INTAGC          ; GO CAUSE GARBAGE COLLECT
2067         JRST    SAGC
2068
2069 CLEANT: PUSH    P,C
2070         PUSH    P,A
2071         SUB     A,P.TOP
2072         ASH     A,-PGSZ
2073         JUMPE   A,CLNT1
2074         PUSHJ   P,GETPAG                ; GET THOSE PAGES
2075         FATAL CAN'T GET PAGES NEEDED
2076         MOVE    A,(P)
2077         ASH     A,-10.                  ; TO PAGES
2078         PUSHJ   P,P.CORE
2079         PUSHJ   P,SLEEPR
2080 CLNT1:  PUSHJ   P,RBLDM
2081         POP     P,A
2082         POP     P,C
2083         POPJ    P,
2084
2085 \f; RCLVEC DISTASTEFUL VECTOR RECYCLER
2086
2087 ; Arrive here with B pointing to first recycler, A desired length
2088
2089 RCLVEC: PUSH    P,D             ; Save registers
2090         PUSH    P,C
2091         PUSH    P,E
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
2095         JRST    FOUND1
2096
2097 RCLV2:  MOVEI   D,(B)           ; Save previous pointer
2098         HRRZ    B,(B)           ; Point to next block
2099         JUMPN   B,RCLV1         ; Jump if more blocks
2100
2101         POP     P,E
2102         POP     P,C
2103         POP     P,D
2104         JRST    NORCL           ; Go to normal allocator
2105
2106
2107 FOUND1: CAIN    C,1(A)          ; Exactly 1 greater?
2108         JRST    RCLV2           ; Cant use this guy
2109
2110         HRLM    A,(B)           ; Smash in new count
2111         TLO     A,.VECT.        ; make vector bit be on
2112         HLLM    A,-1(B)
2113         CAIE    C,(A)           ; Exactly right length?
2114         JRST    FOUND2          ; No, do hair
2115
2116         HRRZ    C,(B)           ; Point to next block
2117         HRRM    C,(D)           ; Smash previous pointer
2118         HRRM    B,(B)
2119         SUBI    B,-1(A)         ; Point to top of block
2120         JRST    FOUND3
2121
2122 FOUND2: SUBI    C,(A)           ; Amount of left over to C
2123         HRRZ    E,(B)           ; Point to next block
2124         HRRM    B,(B)
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
2132
2133 FOUND3: HRROI   B,(B)           ; Make an AOBJN pointer
2134         TLC     B,-3(A)
2135         HRRI    A,TVEC
2136         SKIPGE  A
2137         HRRI    A,TUVEC
2138         MOVSI   A,(A)
2139         POP     P,E
2140         POP     P,C
2141         POP     P,D
2142         POPJ    P,
2143
2144 END
2145 \f