<mdl.int>/stbuil.mid.17

   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,INQAGC                ; 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         CAML    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,SLOCR         ; REL GLOC'S ARE STORED AS ATOMS
 452         CAIN    B,SATOM
 453         JRST    ATFX
 454         CAIN    B,SCHSTR
 455          JRST   STFX
 456         CAIN    B,S1WORD                ; SEE IF PRIMTYPE WOR
 457         JRST    RDLSTF          ; LEAVE IF IS
 458 STFXX:  MOVE    0,GCSBOT        ; ADJUSTMENT
 459         SUBI    0,FPAG+5
 460         SKIPE   1(C)            ; DON'T CHANGE A PTR TO NIL
 461         ADDM    0,1(C)          ; FIX UP
 462 RDLSTF: TLNN    C,.LIST.        ; SEE IF PAIR
 463         JRST    RDL1            ; EXIT
 464         MOVE    0,GCSBOT        ; FIX UP
 465         SUBI    0,FPAG+5
 466         HRRZ    B,(C)           ; SEE IF POINTS TO NIL
 467         SKIPN   B
 468         JRST    RDL1
 469         MOVE    B,C             ; GET ARG FOR RLISTQ
 470         PUSHJ   P,RLISTQ
 471         JRST    RDL1
 472         ADDM    0,(C)
 473 RDL1:   POP     P,B             ; RESTORE B
 474         POP     P,C
 475         POPJ    P,
 476
 477 ; ROUTINE TO FIX UP PNAMES
 478
 479 STFX:   TLZN    D,STATM
 480          JRST   STFXX
 481         HLLM    D,1(C)          ; PUT BACK WITH BIT OFF
 482         ADD     D,ABOTN
 483         ANDI    D,-1
 484         HLRE    0,-1(D)         ; LENGTH OF ATOM
 485         MOVNS   0
 486         SUBI    0,3             ; VAL & OBLIST
 487         IMULI   0,5             ; TO CHARS (SORT OF)
 488         HRRZ    D,-1(D)
 489         ADDI    D,2
 490         PUSH    P,A
 491         PUSH    P,B
 492         LDB     A,[360600,,1(C)]        ; GET BYTE POS
 493         IDIVI   A,7             ; TO CHAR POS
 494         SKIPE   A
 495          SUBI   A,5
 496         HRRZ    B,(C)           ; STRING LENGTH
 497         SUB     B,A             ; TO WORD BOUNDARY STRING
 498         SUBI    0,(B)
 499         IDIVI   0,5
 500         ADD     D,0
 501         POP     P,B
 502         POP     P,A
 503         HRRM    D,1(C)
 504         JRST    RDLSTF
 505
 506 ; ROUTINE TO FIX UP POINTERS TO ATOMS
 507
 508 ATFX:   SKIPGE  D
 509         JRST    RDLSTF
 510         ADD     D,ABOTN
 511         MOVE    0,-1(D)         ; GET PTR TO ATOM
 512         CAIE    B,SLOCR         ; IF REL LOCATIVE, MORE HAIR
 513          JRST   ATFXAT
 514         MOVE    B,0
 515         PUSH    P,E
 516         PUSH    P,D
 517         PUSH    P,C
 518         PUSH    P,B
 519         PUSH    P,A
 520         PUSHJ   P,IGLOC
 521         SUB     B,GLOTOP+1
 522         MOVE    0,B
 523         POP     P,A
 524         POP     P,B
 525         POP     P,C
 526         POP     P,D
 527         POP     P,E
 528 ATFXAT: MOVEM   0,1(C)          ; SMASH IT IN
 529         JRST    RDLSTF          ; EXIT
 530
 531 TYPCFX: HRRZ    B,1(C)          ; GET TYPE
 532         PUSHJ   P,GETNEW                ; GET TYPE IN THIS CORE IMAGE
 533         HRRM    B,1(C)          ; CLOBBER IT IN
 534         JRST    RDLSTF          ; CONTINUE FIXUP
 535
 536 TYPWFX: HLRZ    B,1(C)          ; GET TYPE
 537         PUSHJ   P,GETNEW        ; GET TYPE IN THIS CORE IMAGE
 538         HRLM    B,1(C)          ; SMASH IT IN
 539         JRST    ELEFX
 540
 541 TYPGFX: PUSH    P,D
 542         PUSHJ   P,GETNTP                ; GET TYPE IN THIS CORE IMAGE
 543         POP     P,D
 544         PUTYP   B,(C)
 545         JRST    ELEFX
 546
 547 ; HERE TO HANDLE AN EOF IN GC-READ.  IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
 548 ; EOF HANDLER ELSE USES CHANNELS.
 549
 550 EOFGC:  MOVE    B,1(AB)         ; GET CHANNEL INTO B
 551         CAML    AB,C%M20        ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED
 552         JRST    MYCLOS          ; USE CHANNELS
 553         PUSH    TP,2(AB)
 554         PUSH    TP,3(AB)
 555         JRST    CLOSIT
 556 MYCLOS: PUSH    TP,EOFCND-1(B)
 557         PUSH    TP,EOFCND(B)
 558 CLOSIT: PUSH    TP,$TCHAN
 559         PUSH    TP,B
 560         MCALL   1,FCLOSE                ; CLOSE CHANNEL
 561         MCALL   1,EVAL                  ; EVAL HIS EOF HANDLER
 562         JRST    FINIS
 563
 564 ; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
 565
 566 GETNEW: CAMG    B,NNPRI         ;NEWTYPE
 567         POPJ    P,
 568 GETNTP: MOVE    D,TYPTAB        ; GET AOBJN POINTER TO TYPE-TABLE
 569 GETNT1: HLRZ    E,(D)           ; GET TYPE #
 570         CAIN    E,(B)           ; SKIP IF NOT EQUAL TO GOAL
 571         JRST    GOTTYP          ; FOUND IT
 572         ADD     D,C%22          ; POINT TO NEXT
 573         JUMPL   D,GETNT1
 574         SKIPA                   ; KEEP TYPE SAME
 575 GOTTYP: HRRZ    B,1(D)          ; GET NEW TYPE #
 576         POPJ    P,
 577
 578 ; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
 579
 580 GETSAT: MOVE    D,TYPTAB        ; GET AOBJN PTR TO TYPE TABLE
 581 GETSA1: HRRZ    E,(D)           ; GET OBJECT
 582         CAIN    E,(B)           ; SKIP IF NOT EQUAL TO GOAL
 583         JRST    GOTSAT          ; FOUND IT
 584         ADD     D,C%22
 585         JUMPL   D,GETSA1
 586         FATAL GC-DUMP -- TYPE FIXUP FAILURE
 587 GOTSAT: HLRZ    B,1(D)          ; GET NEW SAT
 588         POPJ    P,
 589
 590
 591 ; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
 592 RLISTQ: PUSH    P,A
 593         GETYP   A,(B)           ; GET TYPE
 594         PUSHJ   P,SAT           ; GET SAT
 595         CAIG    A,NUMSAT        ; NOT DEFERRED IF TEMPLATE
 596         SKIPL   MKTBS(A)
 597         AOS     -1(P)           ; SKIP IF NOT DEFFERED
 598         POP     P,A
 599         POPJ    P,              ; EXIT
 600
 601 \f
 602 .GLOBAL FLIST
 603
 604 MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
 605
 606 ENTRY
 607
 608         JUMPGE  AB,GETUVC       ; SEE IF THERE IS AN ARGUMENT
 609         GETYP   A,(AB)
 610         CAIE    A,TUVEC         ; SEE IF THE ARGUMENT IS A UVECTOR
 611         JRST    WTYP1           ; IF NOT COMPLAIN
 612         HLRE    0,1(AB)
 613         MOVNS   0
 614         CAIE    0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
 615         JRST    WTYP1
 616         CAMGE   AB,C%M20        ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
 617         JRST    TMA
 618         MOVE    A,(AB)          ; GET THE UVECTOR
 619         MOVE    B,1(AB)
 620         JRST    SETUV           ; CONTINUE
 621 GETUVC: MOVEI   A,STATNO+STATGC ; CREATE A UVECTOR
 622         PUSHJ   P,IBLOCK
 623 SETUV:  PUSH    P,A             ; SAVE UVECTOR
 624         PUSH    P,B
 625         MOVE    0,NOWFRE        ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
 626         SUB     0,RFRETP
 627         ADD     0,GCSTOP
 628         MOVEM   0,CURFRE
 629         PUSHJ   P,GCSET         ; FIX UP BLOAT-STAT PARAMETERS
 630         HLRE    0,TP            ; COMPUTE STACK SPACE USED UP
 631         ADD     0,NOWTP
 632         SUBI    0,PDLBUF
 633         MOVEM   0,CURTP
 634         MOVE    B,IMQUOTE THIS-PROCESS
 635         PUSHJ   P,ILOC
 636         HRRZS   B
 637         MOVE    PVP,PVSTOR+1
 638         HRRZ    C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
 639         MOVE    0,B
 640         HRRZ    D,SPBASE+1(PVP)         ; COMPUTE CURRENT # OF BINDINGS
 641         SUB     0,D
 642         IDIVI   0,6
 643         MOVEM   0,CURLVL
 644         SUB     B,C             ; TOTAL WORDS ATOM STORAGE
 645         IDIVI   B,6             ; COMPUTE # OF SLOTS
 646         MOVEM   B,NOWLVL
 647         HRRZ    A,GLOBASE+1     ; COMPUTE TOTAL # OF GLOBAL SLOTS
 648         HLRE    0,GLOBASE+1
 649         SUB     A,0             ; POINT TO DOPE WORD
 650         HLRZ    B,1(A)
 651         ASH     B,-2            ; # OF GVAL SLOTS
 652         MOVEM   B,NOWGVL
 653         HRRZ    A,GLOTOP+1      ; COMPUTE # OF GVAL SLOTS IN USE
 654         HRRZ    0,GLOBSP+1
 655         SUB     A,0
 656         ASH     A,-2            ; NEGATIVE # OF SLOTS USED
 657         MOVEM   A,CURGVL
 658         HRRZ    A,TYPBOT+1      ; GET LENGTH OF TYPE VECTOR
 659         HLRE    0,TYPBOT+1
 660         SUB     A,0
 661         HLRZ    B,1(A)          ; # OF WORDS IN TYPE-VECTOR
 662         IDIVI   B,2             ; CONVERT TO # OF TYPES
 663         MOVEM   B,NOWTYP
 664         HLRE    0,TYPVEC+1      ; LENGTH OF VISABLE TYPE-VECTOR
 665         MOVNS   0
 666         IDIVI   0,2             ; GET # OF TYPES
 667         MOVEM   0,CURTYP
 668         MOVE    0,CODTOP        ; GET LENGTH OF STATIONARY IMPURE STORAGE
 669         MOVEM   0,NOWSTO
 670         SETZB   B,D             ; ZERO OUT MAXIMUM
 671         HRRZ    C,FLIST
 672 LOOPC:  HLRZ    0,(C)           ; GET BLK LENGTH
 673         ADD     D,0             ; ADD # OF WORDS IN BLOCK
 674         CAMGE   B,0             ; SEE IF NEW MAXIMUM
 675         MOVE    B,0
 676         HRRZ    C,(C)           ; POINT TO NEXT BLOCK
 677         JUMPN   C,LOOPC         ; REPEAT
 678         MOVEM   D,CURSTO
 679         MOVEM   B,CURMAX
 680         HLRE    0,P             ; GET AMOUNT OF ROOM LEFT ON P
 681         ADD     0,NOWP
 682         SUBI    0,PDLBUF
 683         MOVEM   0,CURP
 684         MOVSI   C,BSTGC         ; SET UP BLT FOR GC FIGURES
 685         HRRZ    B,(P)           ; RESTORE B
 686         HRR     C,B
 687         BLT     C,(B)STATGC-1
 688         HRLI    C,BSTAT         ; MODIFY BLT FOR STATS
 689         HRRI    C,STATGC(B)
 690         BLT     C,(B)STATGC+STATNO-1
 691         MOVEI   0,TFIX+.VECT.
 692         HRLM    0,(B)STATNO+STATGC      ; MOVE IN UTYPE
 693         POP     P,B
 694         POP     P,A             ; RESTORE TYPE-WORD
 695         JRST    FINIS
 696
 697 GCRSET: SETZM   GCNO            ; CALL FROM INIT, ZAP ALL 1ST
 698         MOVE    0,[GCNO,,GCNO+1]
 699         BLT     0,GCCALL
 700         JRST    GCSET
 701
 702
 703
 704 \f
 705 .GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
 706
 707 ; USER GARBAGE COLLECTOR INTERFACE
 708 .GLOBAL ILVAL
 709
 710 MFUNCTION GC,SUBR
 711         ENTRY
 712
 713         JUMPGE  AB,GC1
 714         CAMGE   AB,C%M60        ; [-6,,0]
 715         JRST    TMA
 716         PUSHJ   P,GETFIX        ; GET FREEE MIN IF GIVEN
 717         SKIPE   A               ; SKIP FOR 0 ARGUMENT
 718         MOVEM   A,FREMIN
 719 GC1:    PUSHJ   P,COMPRM        ; GET CURRENT USED CORE
 720         PUSH    P,A
 721         CAML    AB,C%M40        ; [-4,,0] ; SEE IF 3RD ARG
 722         JRST    GC5
 723         GETYP   A,4(AB)         ; MAKE SURE A FIX
 724         CAIE    A,TFIX
 725         JRST    WTYP            ; ARG WRONG TYPE
 726         MOVE    A,5(AB)
 727         MOVEM   A,RNUMSP
 728         MOVEM   A,NUMSWP
 729 GC5:    CAML    AB,C%M20        ; [-2,,0] ; SEE IF SECOND ARG
 730         JRST    GC3
 731         GETYP   A,2(AB)         ; SEE IF NONFALSE
 732         CAIE    A,TFALSE        ; SKIP IF FALSE
 733         JRST    HAIRGC          ; CAUSE A HAIRY GC
 734 GC3:    MOVSI   A,TATOM         ; CHECK TO SEE IF INTERRUPT FLAG IS ON
 735         MOVE    B,IMQUOTE AGC-FLAG
 736         PUSHJ   P,ILVAL
 737         CAMN    A,$TUNBOUND     ; SKIP IF NOT UNBOUND
 738         JRST    GC2
 739         SKIPE   GCHPN           ; SKIP IF GCHAPPEN IS 0
 740         JRST    FALRTN          ; JUMP TO RETURN FALSE
 741 GC2:    MOVE    C,[9.,,0]
 742         PUSHJ   P,AGC           ; COLLECT THAT TRASH
 743         PUSHJ   P,COMPRM        ; HOW MUCH ROOM NOW?
 744         POP     P,B             ; RETURN AMOUNT
 745         SUB     B,A
 746         MOVSI   A,TFIX
 747         JRST    FINIS
 748 HAIRGC: MOVE    B,3(AB)
 749         CAIN    A,TFIX          ; IF FIX THEN CLOBBER NGCS
 750         MOVEM   B,NGCS
 751         MOVEI   A,1             ; FORCE VALUE FLUSHING PHASE TO OCCUR
 752         MOVEM   A,GCHAIR
 753         JRST    GC2             ; HAIRY GC OCCORS NO MATTER WHAT
 754 FALRTN: MOVE    A,$TFALSE
 755         MOVEI   B,0             ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR
 756         JRST    FINIS
 757
 758
 759 COMPRM: MOVE    A,GCSTOP        ; USED SPACE
 760         SUB     A,GCSBOT
 761         POPJ    P,
 762
 763 \f
 764 MFUNCTION GCDMON,SUBR,[GC-MON]
 765
 766         ENTRY
 767
 768         MOVEI   E,GCMONF
 769
 770 FLGSET: MOVE    C,(E)           ; GET CURRENT VALUE
 771         JUMPGE  AB,RETFLG       ; RET CURRENT
 772         CAMGE   AB,C%M20        ; [-3,,]
 773          JRST   TMA
 774         GETYP   0,(AB)
 775         SETZM   (E)
 776         CAIN    0,TFALSE
 777         SETOM   (E)
 778         SKIPL   E
 779         SETCMM  (E)
 780
 781 RETFLG: SKIPL   E
 782         SETCMM  C
 783         JUMPL   C,NOFLG
 784         MOVSI   A,TATOM
 785         MOVE    B,IMQUOTE T
 786         JRST    FINIS
 787
 788 NOFLG:  MOVEI   B,0
 789         MOVSI   A,TFALSE
 790         JRST    FINIS
 791
 792 .GLOBAL EVATYP,APLTYP,PRNTYP
 793
 794 \fMFUNCTION BLOAT,SUBR
 795         ENTRY
 796
 797         PUSHJ   P,SQKIL
 798         MOVEI   C,0             ; FLAG TO SAY WHETHER NEED A GC
 799         MOVSI   E,-NBLO         ; AOBJN TO BLOATER TABLE
 800
 801 BLOAT2: JUMPGE  AB,BLOAT1       ; ALL DONE?
 802         PUSHJ   P,NXTFIX        ; GET NEXT BLOAT PARAM
 803         SKIPE   A
 804         PUSHJ   P,@BLOATER(E)   ; DISPATCH
 805         AOBJN   E,BLOAT2        ; COUNT PARAMS SET
 806
 807         JUMPL   AB,TMA          ; ANY LEFT...ERROR
 808 BLOAT1: JUMPE   C,BLOATD        ; DONE, NO GC NEEDED
 809         MOVE    C,E             ; MOVE IN INDICATOR
 810         HRLI    C,1             ; INDICATE THAT IT COMES FROM BLOAT
 811         SETOM   INBLOT
 812         PUSHJ   P,AGC           ; DO ONE
 813         SKIPE   A,TPBINC        ; SMASH POINNTERS
 814         MOVE    PVP,PVSTOR+1
 815         ADDM    A,TPBASE+1(PVP)
 816         SKIPE   A,GLBINC        ; GLOBAL SP
 817         ADDM    A,GLOBASE+1
 818         SKIPE   A,TYPINC
 819         ADDM    A,TYPBOT+1
 820         SETZM   TPBINC          ; RESET PARAMS
 821         SETZM   GLBINC
 822         SETZM   TYPINC
 823
 824 BLOATD: SKIPN   A,GETNUM        ; SKIP IF FREE STORAGE REQUEST IN EFFECT
 825         JRST    BLTFN
 826         ADD     A,FRETOP        ; ADD FRETOP
 827         ADDI    A,1777          ; ONE BLOCK FOR MARK PDL AND ROUND
 828         ANDCMI  A,1777          ; TO PAGE BOUNDRY
 829         CAML    A,PURBOT        ; SKIP IF POSSIBLE TO WIN
 830         JRST    BLFAGC
 831         ASH     A,-10.          ; TO PAGES
 832         PUSHJ   P,P.CORE        ; GRET THE CORE
 833         JRST    BLFAGC          ; LOSE LOSE LOSE
 834         MOVE    A,FRETOP        ; CALCULATE NEW PARAMETERS
 835         MOVEM   A,RFRETP
 836         MOVEM   A,CORTOP
 837         MOVE    B,GCSTOP
 838         SETZM   1(B)
 839         HRLI    B,1(B)
 840         HRRI    B,2(B)
 841         BLT     B,-1(A) ; ZERO CORE
 842 BLTFN:  SETZM   GETNUM
 843         MOVE    B,FRETOP
 844         SUB     B,GCSTOP
 845         MOVSI   A,TFIX          ; RETURN CORE FOUND
 846         JRST    FINIS
 847 BLFAGC: MOVN    A,FREMIN
 848         ADDM    A,GETNUM                ; FIX UP SO BLOATS CORRECTLY
 849         MOVE    C,C%11          ; INDICATOR FOR AGC
 850         PUSHJ   P,AGC           ; GARBAGE COLLECT
 851         JRST    BLTFN           ; EXIT
 852
 853 ; TABLE OF BLOAT ROUTINES
 854
 855 BLOATER:
 856         MAINB
 857         TPBLO
 858         LOBLO
 859         GLBLO
 860         TYBLO
 861         STBLO
 862         PBLO
 863         SFREM
 864         SLVL
 865         SGVL
 866         STYP
 867         SSTO
 868         PUMIN
 869         PMUNG
 870         TPMUNG
 871         NBLO==.-BLOATER
 872
 873 ; BLOAT MAIN STORAGE AREA
 874
 875 MAINB:  SETZM   GETNUM
 876         MOVE    D,FRETOP        ; COMPUTE CURRENT ROOM
 877         SUB     D,PARTOP
 878         CAMGE   A,D             ; NEED MORE?
 879         POPJ    P,              ; NO, LEAVE
 880         SUB     A,D
 881         MOVEM   A,GETNUM                ; SAVE
 882         POPJ    P,
 883
 884 ; BLOAT TP STACK (AT TOP)
 885
 886 TPBLO:  HLRE    D,TP            ; GET -SIZE
 887         MOVNS   B,D
 888         ADDI    D,1(TP)         ; POINT TO DOPE (ALMOST)
 889         CAME    D,TPGROW        ; BLOWN?
 890         ADDI    D,PDLBUF        ; POINT TO REAL DOPE WORD
 891         SUB     A,B             ; SKIP IF GROWTH NEEDED
 892         JUMPLE  A,CPOPJ
 893         ADDI    A,63.
 894         ASH     A,-6            ; CONVERT TO 64 WD BLOCKS
 895         CAILE   A,377
 896         JRST    OUTRNG
 897         DPB     A,[111100,,-1(D)]       ; SMASH SPECS IN
 898         AOJA    C,CPOPJ
 899
 900 ; BLOAT TOP LEVEL LOCALS
 901
 902 LOBLO:  HLRE    D,TP            ; GET -SIZE
 903         MOVNS   B,D
 904         ADDI    D,1(TP)         ; POINT TO DOPE (ALMOST)
 905         CAME    D,TPGROW        ; BLOWN?
 906         ADDI    D,PDLBUF        ; POINT TO REAL DOPE WORD
 907         CAMG    A,B             ; SKIP IF GROWTH NEEDED
 908         IMULI   A,6             ; 6 WORDS PER BINDING
 909         MOVE    PVP,PVSTOR+1
 910         HRRZ    0,TPBASE+1(PVP)
 911         HRRZ    B,SPBASE+1(PVP) ; ROOM AVAIL TO E
 912         SUB     B,0
 913         SUBI    A,(B)           ; HOW MUCH MORE?
 914         JUMPLE  A,CPOPJ         ; NONE NEEDED
 915         MOVEI   B,TPBINC
 916         PUSHJ   P,NUMADJ
 917         DPB     A,[1100,,-1(D)] ; SMASH
 918         AOJA    C,CPOPJ
 919
 920 ; GLOBAL SLOT GROWER
 921
 922 GLBLO:  ASH     A,2             ; 4 WORDS PER VAR
 923         MOVE    D,GLOBASE+1     ; CURRENT LIMITS
 924         HRRZ    B,GLOBSP+1
 925         SUBI    B,(D)
 926         SUBI    A,(B)           ; NEW AMOUNT NEEDED
 927         JUMPLE  A,CPOPJ
 928         MOVEI   B,GLBINC        ; WHERE TO KEEP UPDATE
 929         PUSHJ   P,NUMADJ        ; FIX NUMBER
 930         HLRE    0,D
 931         SUB     D,0             ; POINT TO DOPE
 932         DPB     A,[1100,,(D)]   ; AND SMASH
 933         AOJA    C,CPOPJ
 934
 935 ; HERE TO GROW TYPE VECTOR (AND FRIENDS)
 936
 937 TYBLO:  ASH     A,1             ; TWO WORD PER TYPE
 938         HRRZ    B,TYPVEC+1      ; FIND CURRENT ROOM
 939         MOVE    D,TYPBOT+1
 940         SUBI    B,(D)
 941         SUBI    A,(B)           ; EXTRA NEEDED TO A
 942         JUMPLE  A,CPOPJ         ; NONE NEEDED, LEAVE
 943         MOVEI   B,TYPINC        ; WHERE TO STASH SPEC
 944         PUSHJ   P,NUMADJ        ; FIX NUMBER
 945         HLRE    0,D             ; POINT TO DOPE
 946         SUB     D,0
 947         DPB     A,[1100,,(D)]
 948         SKIPE   D,EVATYP+1      ; GROW AUX TYPE VECS IF NEEDED
 949         PUSHJ   P,SGROW1
 950         SKIPE   D,APLTYP+1
 951         PUSHJ   P,SGROW1
 952         SKIPE   D,PRNTYP+1
 953         PUSHJ   P,SGROW1
 954         AOJA    C,CPOPJ
 955
 956 ; HERE TO CREATE STORAGE SPACE
 957
 958 STBLO:  MOVE    D,GCSBOT        ; HOW MUCH NOW HERE
 959         SUB     D,CODTOP
 960         SUBI    A,(D)           ; MORE NEEDED?
 961         JUMPLE  A,CPOPJ
 962         MOVEM   A,PARNEW        ; FORCE PAIR SPACE TO MOVE ON OUT
 963         AOJA    C,CPOPJ
 964
 965 ; BLOAT P STACK
 966
 967 PBLO:   HLRE    D,P
 968         MOVNS   B,D
 969         SUBI    D,5             ; FUDGE FOR THIS CALL
 970         SUBI    A,(D)
 971         JUMPLE  A,CPOPJ
 972         ADDI    B,1(P)          ; POINT TO DOPE
 973         CAME    B,PGROW         ; BLOWN?
 974         ADDI    B,PDLBUF        ; NOPE, POIN TO REAL D.W.
 975         ADDI    A,63.
 976         ASH     A,-6            ; TO 64 WRD BLOCKS
 977         CAILE   A,377           ; IN RANGE?
 978         JRST    OUTRNG
 979         DPB     A,[111100,,-1(B)]
 980         AOJA    C,CPOPJ
 981
 982 ; SET FREMIN
 983
 984 SFREM:  SKIPE   A               ; DON'T ZERO EMPTY PARAMETER
 985         MOVEM   A,FREMIN
 986         POPJ    P,
 987
 988 ; SET LVAL INCREMENT
 989
 990 SLVL:   IMULI   A,6             ; CALCULATE AMOUNT TO GROW B
 991         MOVEI   B,LVLINC
 992         PUSHJ   P,NUMADJ
 993         MOVEM   A,LVLINC
 994         POPJ P,
 995
 996 ; SET GVAL INCREMENT
 997
 998 SGVL:   IMULI   A,4.            ; # OF SLOTS
 999         MOVEI   B,GVLINC
1000         PUSHJ   P,NUMADJ
1001         MOVEM   A,GVLINC
1002         POPJ    P,
1003
1004 ; SET TYPE INCREMENT
1005
1006 STYP:   IMULI   A,2             ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
1007         MOVEI   B,TYPIC
1008         PUSHJ   P,NUMADJ
1009         MOVEM   A,TYPIC
1010         POPJ    P,
1011
1012 ; SET STORAGE INCREMENT
1013
1014 SSTO:   IDIVI   A,2000          ; # OF BLOCKS
1015         CAIE    B,0             ; REMAINDER?
1016         ADDI    A,1
1017         IMULI   A,2000          ; CONVERT BACK TO WORDS
1018         MOVEM   A,STORIC
1019         POPJ    P,
1020 ; HERE FOR MINIMUM PURE SPACE
1021
1022 PUMIN:  ADDI    A,1777
1023         ANDCMI  A,1777          ; TO PAGE BOUNDRY
1024         MOVEM   A,PURMIN
1025         POPJ    P,
1026
1027 ; HERE TO ADJUST PSTACK PARAMETERS IN GC
1028
1029 PMUNG:  ADDI    A,777           ; TO NEAREST 1000 WORD BOUNDRY
1030         ANDCMI  A,777
1031         MOVEM   A,PGOOD         ; PGOOD
1032         ASH     A,2             ; PMAX IS 4*PGOOD
1033         MOVEM   A,PMAX
1034         ASH     A,-4            ; PMIN IS .25*PGOOD
1035         MOVEM   A,PMIN
1036
1037 ; HERE TO ADJUST GC TPSTACK PARAMS
1038
1039 TPMUNG: ADDI    A,777
1040         ANDCMI  A,777           ; TO NEAREST 1000 WORD BOUNDRY
1041         MOVEM   A,TPGOOD
1042         ASH     A,2             ; TPMAX= 4*TPGOOD
1043         MOVEM   A,TPMAX
1044         ASH     A,-4            ; TPMIN= .25*TPGOOD
1045         MOVEM   A,TPMIN
1046
1047
1048 ; GET NEXT (FIX) ARG
1049
1050 NXTFIX: PUSHJ   P,GETFIX
1051         ADD     AB,C%22
1052         POPJ    P,
1053
1054 ; ROUTINE TO GET POS FIXED ARG
1055
1056 GETFIX: GETYP   A,(AB)
1057         CAIE    A,TFIX
1058         JRST    WRONGT
1059         SKIPGE  A,1(AB)
1060         JRST    BADNUM
1061         POPJ    P,
1062
1063
1064 ; GET NUMBERS FIXED UP FOR GROWTH FIELDS
1065
1066 NUMADJ: ADDI    A,77            ; ROUND UP
1067         ANDCMI  A,77            ; KILL CRAP
1068         MOVE    0,A
1069         MOVNS   A               ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
1070         HRLI    A,-1(A)
1071         MOVEM   A,(B)           ; AND STASH IT
1072         MOVE    A,0
1073         ASH     A,-6            ; TO 64 WD BLOCKS
1074         CAILE   A,377           ; CHECK FIT
1075         JRST    OUTRNG
1076         POPJ    P,
1077
1078 ; DO SYMPATHETIC GROWTHS
1079
1080 SGROW1: HLRE    0,D
1081         SUB     D,0
1082         DPB     A,[111100,,(D)]
1083         POPJ    P,
1084
1085 \f;FUNCTION TO CONSTRUCT A LIST
1086
1087 MFUNCTION CONS,SUBR
1088
1089         ENTRY   2
1090         GETYP   A,2(AB)         ;GET TYPE OF 2ND ARG
1091         CAIE    A,TLIST         ;LIST?
1092         JRST    WTYP2           ;NO , COMPLAIN
1093         MOVE    C,(AB)          ; GET THING TO CONS IN
1094         MOVE    D,1(AB)
1095         HRRZ    E,3(AB)         ; AND LIST
1096         PUSHJ   P,ICONS         ; INTERNAL CONS
1097         JRST    FINIS
1098
1099 ; COMPILER CALL TO CONS
1100
1101 C1CONS: PUSHJ   P,ICELL2
1102         JRST    ICONS2
1103 ICONS4: HRRI    C,(E)
1104 ICONS3: MOVEM   C,(B)           ; AND STORE
1105         MOVEM   D,1(B)
1106 TLPOPJ: MOVSI   A,TLIST
1107         POPJ    P,
1108
1109 ; INTERNAL CONS--ICONS;  C,D VALUE, E CDR
1110
1111 ; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE
1112 ; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED
1113 ; TO:  DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS.
1114
1115 CICONS: SUBM    M,(P)
1116         PUSHJ   P,ICONS
1117         JRST    MPOPJ
1118
1119 ; INTERNAL CONS TO NIL--INCONS
1120
1121 INCONS: MOVEI   E,0
1122
1123 ICONS:  GETYP   A,C             ; CHECK TYPE OF VAL
1124         PUSHJ   P,NWORDT        ; # OF WORDS
1125         SOJN    A,ICONS1        ; JUMP IF DEFERMENT NEEDED
1126         PUSHJ   P,ICELL2        ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
1127         JRST    ICNS2A          ; NO CORE, GO GC (SPECIAL PLACE, NOTICE)
1128         JRST    ICONS4
1129
1130 ; HERE IF CONSING DEFERRED
1131
1132 ICONS1: MOVEI   A,4             ; NEED 4 WORDS
1133         PUSHJ   P,ICELL         ; GO GET 'EM
1134         JRST    ICNS2A          ; NOT THERE, GC (SAME PLACE AS FOR ICONS)
1135         HRLI    E,TDEFER        ; CDR AND DEFER
1136         MOVEM   E,(B)           ; STORE
1137         MOVEI   E,2(B)          ; POINT E TO VAL CELL
1138         HRRZM   E,1(B)
1139         MOVEM   C,(E)           ; STORE VALUE
1140         MOVEM   D,1(E)
1141         JRST    TLPOPJ
1142
1143
1144
1145 ; HERE TO GC ON A CONS
1146
1147 ; HERE FROM C1CONS
1148 ICONS2: SUBM    M,(P)
1149         PUSHJ   P,ICONSG
1150         SUBM    M,(P)
1151         JRST    C1CONS
1152
1153 ; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
1154 ICNS2A: PUSHJ   P,ICONSG
1155         JRST    ICONS
1156
1157 ; REALLY DO GC
1158 ICONSG: PUSH    TP,C            ; SAVE VAL
1159         PUSH    TP,D
1160         PUSH    TP,$TLIST
1161         PUSH    TP,E            ; SAVE VITAL STUFF
1162         ADDM    A,GETNUM        ; AMOUNT NEEDED
1163         MOVE    C,[3,,1]        ; INDICATOR FOR AGC
1164         PUSHJ   P,INQAGC                ; ATTEMPT TO WIN
1165         MOVE    D,-2(TP)        ; RESTORE VOLATILE STUFF
1166         MOVE    C,-3(TP)
1167         MOVE    E,(TP)
1168         SUB     TP,C%44         ; [4,,4]
1169         POPJ    P,              ; BACK TO DRAWING BOARD
1170
1171 ; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE.  CALLS AGC IF NEEDED
1172
1173 CELL2:  MOVEI   A,2             ; USUAL CASE
1174 CELL:   PUSHJ   P,ICELL         ; INTERNAL
1175         JRST    .+2             ; LOSER
1176         POPJ    P,
1177
1178         ADDM    A,GETNUM        ; AMOUNT REQUIRED
1179         PUSH    P,A             ; PREVENT AGC DESTRUCTION
1180         MOVE    C,[3,,1]        ; INDICATOR FOR AGC
1181         PUSHJ   P,INQAGC
1182         POP     P,A
1183         JRST    CELL            ; AND TRY AGAIN
1184
1185 ; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
1186
1187 ICELL2: MOVEI   A,2             ; MOST LIKELY CAE
1188 ICELL:  SKIPE   B,RCL
1189         JRST    ICELRC          ;SEE IF WE CAN RE-USE A RECYCLE CELL
1190         MOVE    B,PARTOP        ; GET TOP OF PAIRS
1191         ADDI    B,(A)           ; BUMP
1192         CAMLE   B,FRETOP        ; SKIP IF OK.
1193         JRST    VECTRY          ; LOSE
1194         EXCH    B,PARTOP        ; SETUP NEW PARTOP AND RETURN POINTER
1195         ADDM    A,USEFRE
1196         JRST    CPOPJ1          ; SKIP RETURN
1197
1198 ; TRY RECYCLING USING A VECTOR FROM RCLV
1199
1200 VECTRY: SKIPN   B,RCLV          ; SKIP IF VECTOR EXISTS
1201         POPJ    P,
1202         PUSH    P,C
1203         PUSH    P,A
1204         MOVEI   C,RCLV
1205 VECTR1: HLRZ    A,(B)           ; GET LENGTH
1206         SUB     A,(P)
1207         JUMPL   A,NXTVEC        ; DOESN'T SATISFY TRY AGAIN
1208         CAIN    A,1             ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
1209         JRST    NXTVEC
1210         JUMPN   A,SOML          ; SOME ARE LEFT
1211         HRRZ    A,(B)
1212         HRRM    A,(C)
1213         HLRZ    A,(B)
1214         SETZM   (B)
1215         SETZM   -1(B)           ; CLEAR DOPE WORDS
1216         SUBI    B,-1(A)
1217         POP     P,A             ; CLEAR STACK
1218         POP     P,C
1219         JRST    CPOPJ1
1220 SOML:   HRLM    A,(B)           ; SMASH AMOUNT LEFT
1221         SUBI    B,-1(A)         ; GET TO BEGINNING
1222         SUB     B,(P)
1223         POP     P,A
1224         POP     P,C
1225         JRST    CPOPJ1
1226 NXTVEC: MOVEI   C,(B)
1227         HRRZ    B,(B)           ; GET NEXT
1228         JUMPN   B,VECTR1
1229         POP     P,A
1230         POP     P,C
1231         POPJ    P,
1232
1233 ICELRC: CAIE    A,2
1234         JRST    ICELL+2         ;IF HE DOESNT WANT TWO, USE OLD METHOD
1235         PUSH    P,A
1236         MOVE    A,(B)
1237         HRRZM   A,RCL
1238         POP     P,A
1239         SETZM   (B)             ;GIVE HIM A CLEAN RECYCLED CELL
1240         SETZM   1(B)
1241         JRST    CPOPJ1          ;THAT IT
1242
1243
1244 \f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
1245
1246 IMFUNCTION LIST,SUBR
1247         ENTRY
1248
1249         PUSH    P,$TLIST
1250 LIST12: HLRE    A,AB            ;GET -NUM OF ARGS
1251         PUSH    TP,$TAB
1252         PUSH    TP,AB
1253         MOVNS   A               ;MAKE IT +
1254         JUMPE   A,LISTN         ;JUMP IF 0
1255         SKIPE   RCL             ;SEE IF WE WANT TO DO ONE AT A TIME
1256         JRST    LST12R          ;TO GET RECYCLED CELLS
1257         PUSHJ   P,CELL          ;GET NUMBER OF CELLS
1258         PUSH    TP,(P)  ;SAVE IT
1259         PUSH    TP,B
1260         SUB     P,C%11
1261         LSH     A,-1            ;NUMBER OF REAL LIST ELEMENTS
1262
1263 CHAINL: ADDI    B,2             ;LOOP TO CHAIN ELEMENTS
1264         HRRZM   B,-2(B)         ;CHAIN LAST ONE TO NEXT ONE
1265         SOJG    A,.-2           ;LOOP TIL ALL DONE
1266         CLEARM  B,-2(B)         ;SET THE  LAST CDR TO NIL
1267
1268 ; NOW LOBEER THE DATA IN TO THE LIST
1269
1270         MOVE    D,AB            ; COPY OF ARG POINTER
1271         MOVE    B,(TP)          ;RESTORE LIS POINTER
1272 LISTLP: GETYP   A,(D)           ;GET TYPE
1273         PUSHJ   P,NWORDT        ;GET NUMBER OF WORDS
1274         SOJN    A,LDEFER        ;NEED TO DEFER POINTER
1275         GETYP   A,(D)           ;NOW CLOBBER ELEMENTS
1276         HRLM    A,(B)
1277         MOVE    A,1(D)          ;AND VALUE..
1278         MOVEM   A,1(B)
1279 LISTL2: HRRZ    B,(B)           ;REST B
1280         ADD     D,C%22          ;STEP ARGS
1281         JUMPL   D,LISTLP
1282
1283         POP     TP,B
1284         POP     TP,A
1285         SUB     TP,C%22         ; CLEANUP STACK
1286         JRST    FINIS
1287
1288
1289 LST12R: ASH     A,-1            ;ONE AT A TIME TO GET RECYCLED CELLS
1290         JUMPE   A,LISTN
1291         PUSH    P,A             ;SAVE COUNT ON STACK
1292         SETZM   E
1293         SETZB   C,D
1294         PUSHJ   P,ICONS
1295         MOVE    E,B             ;LOOP AND CHAIN TOGETHER
1296         SOSLE   (P)
1297         JRST    .-4
1298         PUSH    TP,-1(P)        ;PUSH ON THE TYPE WE WANT
1299         PUSH    TP,B
1300         SUB     P,C%22          ;CLEAN UP AFTER OURSELVES
1301         JRST    LISTLP-2        ;AND REJOIN MAIN STREAM
1302
1303
1304 ; MAKE A DEFERRED POINTER
1305
1306 LDEFER: PUSH    TP,$TLIST       ;SAVE CURRENT POINTER
1307         PUSH    TP,B
1308         MOVEM   D,1(TB)         ; SAVE ARG HACKER
1309         PUSHJ   P,CELL2
1310         MOVE    D,1(TB)
1311         GETYPF  A,(D)           ;GET FULL DATA
1312         MOVE    C,1(D)
1313         MOVEM   A,(B)
1314         MOVEM   C,1(B)
1315         MOVE    C,(TP)          ;RESTORE LIST POINTER
1316         MOVEM   B,1(C)          ;AND MAKE THIS BE THE VALUE
1317         MOVSI   A,TDEFER
1318         HLLM    A,(C)           ;AND STORE IT
1319         MOVE    B,C
1320         SUB     TP,C%22
1321         JRST    LISTL2
1322
1323 LISTN:  MOVEI   B,0
1324         POP     P,A
1325         JRST    FINIS
1326
1327 ; BUILD A FORM
1328
1329 IMFUNCTION FORM,SUBR
1330
1331         ENTRY
1332
1333         PUSH    P,$TFORM
1334         JRST    LIST12
1335
1336 \f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
1337
1338 IILIST: SUBM    M,(P)
1339         PUSHJ   P,IILST
1340         MOVSI   A,TLIST
1341         JRST    MPOPJ
1342
1343 IIFORM: SUBM    M,(P)
1344         PUSHJ   P,IILST
1345         MOVSI   A,TFORM
1346         JRST    MPOPJ
1347
1348 IILST:  JUMPE   A,IILST0        ; NIL WHATSIT
1349         PUSH    P,A
1350         MOVEI   E,0
1351 IILST1: POP     TP,D
1352         POP     TP,C
1353         PUSHJ   P,ICONS         ; CONS 'EM UP
1354         MOVEI   E,(B)
1355         SOSE    (P)             ; COUNT
1356         JRST    IILST1
1357
1358         SUB     P,C%11
1359         POPJ    P,
1360
1361 IILST0: MOVEI   B,0
1362         POPJ    P,
1363
1364 \f;FUNCTION TO BUILD AN IMPLICIT LIST
1365
1366 MFUNCTION ILIST,SUBR
1367         ENTRY
1368         PUSH    P,$TLIST
1369 ILIST2: JUMPGE  AB,TFA          ;NEED AT LEAST ONE ARG
1370         CAMGE   AB,C%M40        ; [-4,,0] ; NO MORE THAN TWO ARGS
1371         JRST    TMA
1372         PUSHJ   P,GETFIX        ; GET POS FIX #
1373         JUMPE   A,LISTN         ;EMPTY LIST ?
1374         CAML    AB,C%M20        ; [-2,,0] ;ONLY ONE ARG?
1375         JRST    LOSEL           ;YES
1376         PUSH    P,A             ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
1377 ILIST0: PUSH    TP,2(AB)
1378         PUSH    TP,(AB)3
1379         MCALL   1,EVAL
1380         PUSH    TP,A
1381         PUSH    TP,B
1382         SOSLE   (P)
1383         JRST    ILIST0
1384         POP     P,C
1385 ILIST1: MOVE    C,(AB)+1        ;REGOBBLE LENGTH
1386         ACALL   C,LIST
1387 ILIST3: POP     P,A             ; GET FINAL TYPE
1388         JRST    FINIS
1389
1390
1391 LOSEL:  PUSH    P,A             ; SAVE COUNT
1392         MOVEI   E,0
1393
1394 LOSEL1: SETZB   C,D             ; TLOSE,,0
1395         PUSHJ   P,ICONS
1396         MOVEI   E,(B)
1397         SOSLE   (P)
1398         JRST    LOSEL1
1399
1400         SUB     P,C%11
1401         JRST    ILIST3
1402
1403 ; IMPLICIT FORM
1404
1405 MFUNCTION IFORM,SUBR
1406
1407         ENTRY
1408         PUSH    P,$TFORM
1409         JRST    ILIST2
1410
1411 \f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
1412
1413 MFUNCTION VECTOR,SUBR,[IVECTOR]
1414
1415         MOVEI   C,1
1416         JRST    VECTO3
1417
1418 MFUNCTION UVECTOR,SUBR,[IUVECTOR]
1419
1420         MOVEI   C,0
1421 VECTO3: ENTRY
1422         JUMPGE  AB,TFA          ; AT LEAST ONE ARG
1423         CAMGE   AB,C%M40        ; [-4,,0] ; NOT MORE THAN 2
1424         JRST    TMA
1425         PUSHJ   P,GETFIX        ; GET A POS FIXED NUMBER
1426         LSH     A,(C)           ; A-> NUMBER OF WORDS
1427         PUSH    P,C             ; SAVE FOR LATER
1428         PUSHJ   P,IBLOCK        ; GET BLOCK (TURN ON BIT APPROPRIATELY)
1429         POP     P,C
1430         HLRE    A,B             ; START TO
1431         SUBM    B,A             ; FIND DOPE WORD
1432         MOVSI   D,.VECT.                ; FOR GCHACK
1433         IORM    D,(A)
1434         JUMPE   C,VECTO4
1435         MOVSI   D,400000        ; GET NOT UNIFORM BIT
1436         IORM    D,(A)           ; INTO DOPE WORD
1437         SKIPA   A,$TVEC         ; GET TYPE
1438 VECTO4: MOVSI   A,TUVEC
1439         CAML    AB,C%M20        ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
1440         JRST    FINIS
1441         JUMPGE  B,FINIS         ; DON'T EVAL FOR EMPTY CASE
1442
1443         PUSH    TP,A            ; SAVE THE VECTOR
1444         PUSH    TP,B
1445         PUSH    TP,A
1446         PUSH    TP,B
1447
1448         JUMPE   C,UINIT
1449         JUMPGE  B,FINIS         ; EMPTY VECTOR, LEAVE
1450 INLP:   PUSHJ   P,IEVAL         ; EVAL EXPR
1451         MOVEM   A,(C)
1452         MOVEM   B,1(C)
1453         ADD     C,C%22          ; BUMP VECTOR
1454         MOVEM   C,(TP)
1455         JUMPL   C,INLP          ; IF MORE DO IT
1456
1457 GETVEC: MOVE    A,-3(TP)
1458         MOVE    B,-2(TP)
1459         SUB     TP,C%44         ; [4,,4]
1460         JRST    FINIS
1461
1462 ; HERE TO FILL UP A UVECTOR
1463
1464 UINIT:  PUSHJ   P,IEVAL         ; HACK THE 1ST VALUE
1465         GETYP   A,A             ; GET TYPE
1466         PUSH    P,A             ; SAVE TYPE
1467         PUSHJ   P,NWORDT        ; SEE IF IT CAN BE UNIFORMED
1468         SOJN    A,CANTUN        ; COMPLAIN
1469 STJOIN: MOVE    C,(TP)          ; RESTORE POINTER
1470         ADD     C,1(AB)         ; POINT TO DOPE WORD
1471         MOVE    A,(P)           ; GET TYPE
1472         HRLZM   A,(C)           ; STORE IN D.W.
1473         MOVSI   D,.VECT.        ; FOR GCHACK
1474         IORM    D,(C)
1475         MOVE    C,(TP)          ; GET BACK VECTOR
1476         SKIPE   1(AB)
1477         JRST    UINLP1          ; START FILLING UV
1478         JRST    GETVE1
1479
1480 UINLP:  MOVEM   C,(TP)          ; SAVE PNTR
1481         PUSHJ   P,IEVAL         ; EVAL THE EXPR
1482         GETYP   A,A             ; GET EVALED TYPE
1483         CAIE    A,@(P)          ; WINNER?
1484         JRST    WRNGSU          ; SERVICE ERROR FOR UVECTOR,STORAGE
1485 UINLP1: MOVEM   B,(C)           ; STORE
1486         AOBJN   C,UINLP
1487 GETVE1: SUB     P,C%11
1488         JRST    GETVEC          ; AND RETURN VECTOR
1489
1490 IEVAL:  PUSH    TP,2(AB)
1491         PUSH    TP,3(AB)
1492         MCALL   1,EVAL
1493         MOVE    C,(TP)
1494         POPJ    P,
1495
1496 ; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
1497
1498 MFUNCTION ISTORAGE,SUBR
1499         ENTRY
1500         JUMPGE  AB,TFA
1501         CAMGE   AB,C%M40        ; [-4,,0] ; AT LEAST ONE ARG
1502         JRST    TMA
1503         PUSHJ   P,GETFIX        ; POSITIVE COUNT FIRST ARG
1504         PUSHJ   P,CAFRE         ; GET CORE
1505         MOVN    B,1(AB)         ; -COUNT
1506         HRL     A,B             ; PUT IN LHW (A)
1507         MOVM    B,B             ; +COUNT
1508         HRLI    B,2(B)          ; LENGTH + 2
1509         ADDI    B,(A)           ; MAKE POINTER TO DOPE WORDS
1510         HLLZM   B,1(B)          ; PUT TOTAL LENGTH IN 2ND DOPE
1511         HRRM    A,1(B)          ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
1512         MOVE    B,A
1513         MOVSI   A,TSTORAGE
1514         CAML    AB,C%M20        ; [-2,,0] ; SECOND ARG TO EVAL?
1515         JRST     FINIS          ; IF NOT, RETURN EMPTY
1516         PUSH    TP,A
1517         PUSH    TP,B
1518         PUSH    TP,A
1519         PUSH    TP,B
1520         PUSHJ   P,IEVAL         ; EVALUATE FOR FIRST VALUE
1521         GETYP   A,A
1522         PUSH    P,A             ; FOR COMPARISON LATER
1523         PUSHJ   P,SAT
1524         CAIN    A,S1WORD
1525         JRST    STJOIN          ;TREAT LIKE A UVECTOR
1526 ; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
1527         PUSHJ   P,FREESV        ; FREE STORAGE VECTOR
1528         ERRUUO  EQUOTE DATA-CANT-GO-IN-STORAGE
1529
1530 ; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
1531 FREESV: MOVE    A,1(AB)         ; GET COUNT
1532         ADDI    A,2             ; FOR DOPE
1533         HRRZ    B,(TP)          ; GET ADDRESS
1534         PUSHJ   P,CAFRET        ; FREE THE CORE
1535         POPJ    P,
1536
1537 \f
1538 ; INTERNAL VECTOR ALLOCATOR.  A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
1539
1540 IBLOK1: ASH     A,1             ; TIMES 2
1541 GIBLOK: TLOA    A,400000        ; FUNNY BIT
1542 IBLOCK: TLZ     A,400000        ; NO BIT ON
1543         TLO     A,.VECT.        ; TURN ON BIT FOR GCHACK
1544         ADDI    A,2             ; COMPENSATE FOR DOPE WORDS
1545 IBLOK2: SKIPE   B,RCLV          ; ANY TO RECYCLE?
1546         JRST    RCLVEC
1547 NORCL:  MOVE    B,GCSTOP        ; POINT TO BOTTOM OF SPACE
1548         PUSH    P,B             ; SAVE TO BUILD PTR
1549         ADDI    B,(A)           ; ADD NEEDED AMOUNT
1550         CAML    B,FRETOP        ; SKIP IF NO GC NEEDED
1551         JRST    IVECT1
1552         MOVEM   B,GCSTOP        ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
1553         ADDM    A,USEFRE
1554         HRRZS   USEFRE
1555         HRLZM   A,-1(B)         ; STORE LENGTH IN DOPE WORD
1556         HLLZM   A,-2(B)         ; AND BIT
1557         HRRM    B,-1(B)         ; SMASH IN RELOCATION
1558         SOS     -1(B)
1559         POP     P,B             ; RESTORE PTR TO BOTTOM OF VECTOR
1560         HRROS   B               ; POINT TO START OF VECTOR
1561         TLC     B,-3(A)         ; SETUP COUNT
1562         HRRI    A,TVEC
1563         SKIPL   A
1564         HRRI    A,TUVEC
1565         MOVSI   A,(A)
1566         POPJ    P,
1567
1568 ; HERE TO DO A GC ON A VECTOR ALLOCATION
1569
1570 IVECT1: PUSH    P,0
1571         PUSH    P,A             ; SAVE DESIRED LENGTH
1572         HRRZ    0,A
1573         ADDM    0,GETNUM        ; AND STORE AS DESIRED AMOUNT
1574         MOVE    C,[4,,1]        ; GET INDICATOR FOR AGC
1575         PUSHJ   P,INQAGC
1576         POP     P,A
1577         POP     P,0
1578         POP     P,B
1579         JRST    IBLOK2
1580
1581
1582 ; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
1583 ; ITEMS ON TOP OF STACK
1584
1585 IEVECT: ASH     A,1             ; TO NUMBER OF WORDS
1586         PUSH    P,A
1587         PUSHJ   P,IBLOCK        ; GET VECTOR
1588         HLRE    D,B             ; FIND DW
1589         SUBM    B,D             ; A POINTS TO DW
1590         MOVSI   0,400000+.VECT.
1591         MOVEM   0,(D)           ; CLOBBER NON UNIF BIT
1592         POP     P,A             ; RESTORE COUNT
1593         JUMPE   A,IVEC1         ; 0 LNTH, DONE
1594         MOVEI   C,(TP)          ; BUILD BLT
1595         SUBI    C,(A)-1         ; C POINTS TO 1ST ITEM ON STACK
1596         MOVSI   C,(C)
1597         HRRI    C,(B)           ; B/ SOURCE,,DEST
1598         BLT     C,-1(D)         ; XFER THE DATA
1599         HRLI    A,(A)
1600         SUB     TP,A            ; FLUSH STACKAGE
1601 IVEC1:  MOVSI   A,TVEC
1602         POPJ    P,
1603
1604
1605 ; COMPILERS CALL
1606
1607 CIVEC:  SUBM    M,(P)
1608         PUSHJ   P,IEVECT
1609         JRST    MPOPJ
1610
1611
1612 \f; INTERNAL CALL TO EUVECTOR
1613
1614 IEUVEC: PUSH    P,A             ; SAVE LENGTH
1615         PUSHJ   P,IBLOCK
1616         MOVE    A,(P)
1617         JUMPE   A,IEUVE1        ; EMPTY, LEAVE
1618         ASH     A,1             ; NOW FIND STACK POSITION
1619         MOVEI   C,(TP)          ; POINT TO TOP
1620         MOVE    D,B             ; COPY VEC POINTER
1621         SUBI    C,-1(A)         ; POINT TO 1ST DATUM
1622         GETYP   A,(C)           ; CHECK IT
1623         PUSHJ   P,NWORDT
1624         SOJN    A,CANTUN        ; WONT FIT
1625         GETYP   E,(C)
1626
1627 IEUVE2: GETYP   0,(C)           ; TYPE OF EL
1628         CAIE    0,(E)           ; MATCH?
1629         JRST    WRNGUT
1630         MOVE    0,1(C)
1631         MOVEM   0,(D)           ; CLOBBER
1632         ADDI    C,2
1633         AOBJN   D,IEUVE2        ; LOOP
1634         TRO     E,.VECT.
1635         HRLZM   E,(D)           ; STORE UTYPE
1636 IEUVE1: POP     P,A             ; GET COUNY
1637         ASH     A,1             ; MUST FLUSH 2 TIMES # OF ELEMENTS
1638         HRLI    A,(A)
1639         SUB     TP,A            ; CLEAN UP STACK
1640         MOVSI   A,TUVEC
1641         POPJ    P,
1642
1643 ; COMPILER'S CALL
1644
1645 CIUVEC: SUBM    M,(P)
1646         PUSHJ   P,IEUVEC
1647         JRST    MPOPJ
1648
1649 IMFUNCTION EVECTOR,SUBR,[VECTOR]
1650         ENTRY
1651         HLRE    A,AB
1652         MOVNS   A
1653         PUSH    P,A             ;SAVE NUMBER OF WORDS
1654         PUSHJ   P,IBLOCK        ; GET WORDS
1655         MOVEI   D,-1(B)         ; SETUP FOR BLT AND DOPE CLOBBER
1656         JUMPGE  B,FINISV                ;DONT COPY A ZERO LENGTH VECTOR
1657
1658         HRLI    C,(AB)          ;START BUILDING BLT POINTER
1659         HRRI    C,(B)           ;TO ADDRESS
1660         ADDI    D,@(P)          ;SET D TO FINAL ADDRESS
1661         BLT     C,(D)
1662 FINISV: MOVSI   0,400000+.VECT.
1663         MOVEM   0,1(D)          ; MARK AS GENERAL
1664         SUB     P,C%11
1665         MOVSI   A,TVEC
1666         JRST    FINIS
1667
1668
1669
1670 \f;EXPLICIT VECTORS FOR THE UNIFORM CSE
1671
1672 IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
1673
1674         ENTRY
1675         HLRE    A,AB            ;-NUM OF ARGS
1676         MOVNS   A
1677         ASH     A,-1            ;NEED HALF AS MANY WORDS
1678         PUSH    P,A
1679         JUMPGE  AB,EUV1         ; DONT CHECK FOR EMPTY
1680         GETYP   A,(AB)          ;GET FIRST ARG
1681         PUSHJ   P,NWORDT                ;SEE IF NEEDS EXTRA WORDS
1682         SOJN    A,CANTUN
1683 EUV1:   POP     P,A
1684         PUSHJ   P,IBLOCK        ; GET VECT
1685         JUMPGE  B,FINISU
1686
1687         GETYP   C,(AB)          ;GET THE FIRST TYPE
1688         MOVE    D,AB            ;COPY THE ARG POINTER
1689         MOVE    E,B             ;COPY OF RESULT
1690
1691 EUVLP:  GETYP   0,(D)           ;GET A TYPE
1692         CAIE    0,(C)           ;SAME?
1693         JRST    WRNGUT          ;NO , LOSE
1694         MOVE    0,1(D)          ;GET GOODIE
1695         MOVEM   0,(E)           ;CLOBBER
1696         ADD     D,C%22          ;BUMP ARGS POINTER
1697         AOBJN   E,EUVLP
1698
1699         TRO     C,.VECT.
1700         HRLM    C,(E)           ;CLOBBER UNIFORM TYPE IN
1701 FINISU: MOVSI   A,TUVEC
1702         JRST    FINIS
1703
1704 WRNGSU: GETYP   A,-1(TP)
1705         CAIE    A,TSTORAGE
1706         JRST    WRNGUT          ;IF UVECTOR
1707         PUSHJ   P,FREESV        ;FREE STORAGE VECTOR
1708         ERRUUO  EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
1709
1710 WRNGUT: ERRUUO  EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
1711
1712 CANTUN: ERRUUO  EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
1713
1714 BADNUM: ERRUUO  EQUOTE NEGATIVE-ARGUMENT
1715 \f; FUNCTION TO GROW A VECTOR
1716 REPEAT 0,[
1717 MFUNCTION GROW,SUBR
1718
1719         ENTRY   3
1720
1721         MOVEI   D,0             ;STACK HACKING FLAG
1722         GETYP   A,(AB)          ;FIRST TYPE
1723         PUSHJ   P,SAT           ;GET STORAGE TYPE
1724         GETYP   B,2(AB)         ;2ND ARG
1725         CAIE    A,STPSTK        ;IS IT ASTACK
1726         CAIN    A,SPSTK
1727         AOJA    D,GRSTCK        ;YES, WIN
1728         CAIE    A,SNWORD        ;UNIFORM VECTOR
1729         CAIN    A,S2NWORD       ;OR GENERAL
1730 GRSTCK: CAIE    B,TFIX          ;IS 2ND FIXED
1731         JRST    WTYP2           ;COMPLAIN
1732         GETYP   B,4(AB)
1733         CAIE    B,TFIX          ;3RD ARG
1734         JRST    WTYP3           ;LOSE
1735
1736         MOVEI   E,1             ;UNIFORM/GENERAL FLAG
1737         CAIE    A,SNWORD        ;SKIP IF UNIFORM
1738         CAIN    A,SPSTK         ;DONT SKIP IF UNIFORM PDL
1739         MOVEI   E,0
1740
1741         HRRZ    B,1(AB)         ;POINT TO START
1742         HLRE    A,1(AB)         ;GET -LENGTH
1743         SUB     B,A             ;POINT TO DOPE WORD
1744         SKIPE   D               ;SKIP IF NOT STACK
1745         ADDI    B,PDLBUF        ;FUDGE FOR PDL
1746         HLLZS   (B)             ;ZERO OUT GROWTH SPECS
1747         SKIPN   A,3(AB)         ;ANY TOP GROWTH?
1748         JRST    GROW1           ;NO, LOOK FOR BOTTOM GROWTH
1749         ASH     A,(E)           ;MULT BY 2 IF GENERAL
1750         ADDI    A,77            ;ROUND TO NEAREST BLOCK
1751         ANDCMI  A,77            ;CLEAR LOW ORDER BITS
1752         ASH     A,9-6           ;DIVIDE BY 100 AND SHIFT TO POSTION
1753         TRZE    A,400000        ;CONVERT TO SIGN MAGNITUDE
1754         MOVNS   A
1755         TLNE    A,-1            ;SKIP IF NOT TOO BIG
1756         JRST    GTOBIG          ;ERROR
1757 GROW1:  SKIPN   C,5(AB)         ;CHECK LOW GROWTH
1758         JRST    GROW4           ;NONE, SKIP
1759         ASH     C,(E)           ;GENRAL FUDGE
1760         ADDI    C,77            ;ROUND
1761         ANDCMI  C,77            ;FUDGE FOR VALUE RETURN
1762         PUSH    P,C             ;AND SAVE
1763         ASH     C,-6            ;DIVIDE BY 100
1764         TRZE    C,400           ;CONVERT TO SIGN MAGNITUDE
1765         MOVNS   C
1766         TDNE    C,[-1,,777000]  ;CHECK FOR OVERFLOW
1767         JRST    GTOBIG
1768 GROW2:  HLRZ    E,1(B)          ;GET TOTAL LENGTH OF VECTOR
1769         MOVNI   E,-1(E)
1770         HRLI    E,(E)           ;TO BOTH HALVES
1771         ADDI    E,1(B)          ;POINTS TO TOP
1772         SKIPE   D               ;STACK?
1773         ADD     E,[PDLBUF,,0]   ;YES, FUDGE LENGTH
1774         SKIPL   D,(P)           ;SHRINKAGE?
1775         JRST    GROW3           ;NO, CONTINUE
1776         MOVNS   D               ;PLUSIFY
1777         HRLI    D,(D)           ;TO BOTH HALVES
1778         ADD     E,D             ;POINT TO NEW LOW ADDR
1779 GROW3:  IORI    A,(C)           ;OR TOGETHER
1780         HRRM    A,(B)           ;DEPOSIT INTO DOPEWORD
1781         PUSH    TP,(AB)         ;PUSH TYPE
1782         PUSH    TP,E            ;AND VALUE
1783         SKIPE   A               ;DON'T GC FOR NOTHING
1784         MOVE    C,[2,,0]        ; GET INDICATOR FOR AGC
1785         PUSHJ   P,AGC
1786         JUMPL   A,GROFUL
1787         POP     P,C             ;RESTORE GROWTH
1788         HRLI    C,(C)
1789         POP     TP,B            ;GET VECTOR POINTER
1790         SUB     B,C             ;POINT TO NEW TOP
1791         POP     TP,A
1792         JRST    FINIS
1793
1794 GROFUL: SUB     P,C%11          ; CLEAN UP STACK
1795         SUB     TP,C%22
1796         PUSHJ   P,FULLOS
1797         JRST    GROW
1798
1799 GTOBIG: ERRUUO  EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
1800 GROW4:  PUSH    P,[0]           ;0 BOTTOM GROWTH
1801         JRST    GROW2
1802 ]
1803 FULLOS: ERRUUO  EQUOTE NO-STORAGE
1804
1805
1806 \f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
1807
1808 MFUNCTION BYTES,SUBR
1809
1810         ENTRY
1811         MOVEI   D,1
1812         JUMPGE  AB,TFA
1813         GETYP   0,(AB)
1814         CAIE    0,TFIX
1815         JRST    WTYP1
1816         MOVE    E,1(AB)
1817         ADD     AB,C%22
1818         JRST    STRNG1
1819
1820 IMFUNCTION STRING,SUBR
1821
1822         ENTRY
1823
1824         MOVEI   D,0
1825         MOVEI   E,7
1826 STRNG1: MOVE    B,AB            ;COPY ARG POINTER
1827         MOVEI   C,0             ;INITIALIZE COUNTER
1828         PUSH    TP,$TAB         ;SAVE A COPY
1829         PUSH    TP,B
1830         HLRE    A,B             ; GET # OF ARGS
1831         MOVNS   A
1832         ASH     A,-1            ; 1/2 FOR # OF ARGS
1833         PUSHJ   P,IISTRN
1834         JRST    FINIS
1835
1836 IISTRN: PUSH    P,E
1837         JUMPL   E,OUTRNG
1838         CAILE   E,36.
1839         JRST    OUTRNG
1840         SKIPN   E,A             ; SKIP IF ARGS EXIST
1841         JRST    MAKSTR          ; ALL DONE
1842
1843 STRIN2: GETYP   0,(B)           ;GET TYPE CODE
1844         CAMN    0,SING(D)       ; SINGLE CHARACTER OR FIX?
1845         AOJA    C,STRIN1
1846         CAME    0,MULTI(D)      ; OR STRING OR BYTE-STRING
1847         JRST    WRONGT          ;NEITHER
1848         HRRZ    0,(B)           ; GET CHAR COUNT
1849         ADD     C,0             ; AND BUMP
1850
1851 STRIN1: ADD     B,C%22
1852         SOJG    A,STRIN2
1853
1854 ; NOW GET THE NECESSARY VECTOR
1855
1856 MAKSTR: HRL     C,MULTI(D)              ; FINAL TYPE,, CHAR COUNT
1857         PUSH    P,C             ; SAVE CHAR COUNT
1858         PUSH    P,E             ; SAVE ARG COUNT
1859         MOVEI   D,36.
1860         IDIV    D,-2(P)         ; A==> BYTES PER WORD
1861         MOVEI   A,(C)           ; LNTH+4 TO A
1862         ADDI    A,-1(D)
1863         IDIVI   A,(D)
1864         LSH     E,12.
1865         MOVE    D,-2(P)
1866         DPB     D,[060600,,E]
1867         HRLM    E,-2(P)         ; SAVE REMAINDER
1868         PUSHJ   P,IBLOCK
1869
1870         POP     P,A
1871         JUMPGE  B,DONEC         ; 0 LENGTH, NO STRING
1872         HRLI    B,440000        ;CONVERT B TO A BYTE POINTER
1873         HRRZ    0,-1(P)         ; BYTE SIZE
1874         DPB     0,[300600,,B]
1875         MOVE    C,(TP)          ; POINT TO ARGS AGAIN
1876
1877 NXTRG1: GETYP   D,(C)           ;GET AN ARG
1878         CAIN    D,TFIX
1879          JRST   .+3
1880         CAIE    D,TCHRS
1881          JRST   TRYSTR
1882         MOVE    D,1(C)                  ; GET IT
1883         IDPB    D,B             ;AND DEPOSIT IT
1884         JRST    NXTARG
1885
1886 TRYSTR: MOVE    E,1(C)          ;GET BYTER
1887         HRRZ    0,(C)           ;AND COUNT
1888 NXTCHR: SOJL    0,NXTARG        ; IF RUNOUT, GET NEXT ARG
1889         ILDB    D,E             ;AND GET NEXT
1890         IDPB    D,B             ; AND DEPOSIT SAME
1891         JRST    NXTCHR
1892
1893 NXTARG: ADD     C,C%22          ;BUMP ARG POINTER
1894         SOJG    A,NXTRG1
1895         ADDI    B,1
1896
1897 DONEC:  MOVSI   C,TCHRS+.VECT.
1898         TLO     B,400000
1899         HLLM    C,(B)           ;AND CLOBBER AWAY
1900         HLRZ    C,1(B)          ;GET LENGTH BACK
1901         POP     P,A
1902         SUBI    B,-1(C)
1903         HLL     B,(P)           ;MAKE A BYTE POINTER
1904         SUB     P,C%11
1905         POPJ    P,
1906
1907 SING:   TCHRS
1908         TFIX
1909
1910 MULTI:  TCHSTR
1911         TBYTE
1912
1913
1914 ; COMPILER'S CALL TO MAKE A STRING
1915
1916 CISTNG: TDZA    D,D
1917
1918 ; COMPILERS CALL TO MAKE A BYTE STRING
1919
1920 CBYTES: MOVEI   D,1
1921         SUBM    M,(P)
1922         MOVEI   C,0             ; INIT CHAR COUNTER
1923         MOVEI   B,(A)           ; SET UP STACK POINTER
1924         ASH     B,1             ; * 2 FOR NO. OF SLOTS
1925         HRLI    B,(B)
1926         SUBM    TP,B            ; B POINTS TO ARGS
1927         PUSH    P,D
1928         MOVEI   E,7
1929         JUMPE   D,CBYST
1930         GETYP   0,1(B)          ; CHECK BYTE SIZE
1931         CAIE    0,TFIX
1932         JRST    WRONGT
1933         MOVE    E,2(B)
1934         ADD     B,C%22
1935         SUBI    A,1
1936 CBYST:  ADD     B,C%11
1937         PUSH    TP,$TTP
1938         PUSH    TP,B
1939         PUSHJ   P,IISTRN        ; MAKE IT HAPPEN
1940         MOVE    TP,(TP)         ; FLUSH ARGS
1941         SUB     TP,C%11
1942         POP     P,D
1943         JUMPE   D,MPOPJ
1944         SUB     TP,C%22
1945         JRST    MPOPJ
1946
1947 \f;BUILD IMPLICT STRING
1948
1949 MFUNCTION IBYTES,SUBR
1950
1951         ENTRY
1952
1953         CAML    AB,C%M20                ; [-3,,] ; AT LEAST 2
1954          JRST   TFA
1955         CAMGE   AB,C%M60                ; [-7,,] ; NO MORE THAN 3
1956          JRST   TMA
1957         PUSHJ   P,GETFIX        ; GET BYTE SIZE
1958         JUMPL   A,OUTRNG
1959         CAILE   A,36.
1960          JRST   OUTRNG
1961         PUSH    P,[TFIX]
1962         PUSH    P,A
1963         PUSH    P,$TBYTE
1964         ADD     AB,C%22
1965         MOVEM   AB,ABSAV(TB)
1966         JRST    ISTR1
1967
1968 MFUNCTION ISTRING,SUBR
1969
1970         ENTRY
1971         JUMPGE  AB,TFA          ; TOO FEW ARGS
1972         CAMGE   AB,C%M40        ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
1973          JRST   TMA
1974         PUSH    P,[TCHRS]
1975         PUSH    P,[7]
1976         PUSH    P,$TCHSTR
1977 ISTR1:  PUSHJ   P,GETFIX
1978         MOVEI   C,36.
1979         IDIV    C,-1(P)
1980         ADDI    A,-1(C)
1981         IDIVI   A,(C)           ; # OF WORDS NEEDED TO A
1982         ASH     D,12.
1983         MOVE    C,-1(P)         ; GET BYTE SIZE
1984         DPB     C,[060600,,D]
1985         PUSH    P,D
1986         PUSHJ   P,IBLOCK
1987         HLRE    C,B             ; -LENGTH TO C
1988         SUBM    B,C             ; LOCN OF DOPE WORD TO C
1989         HRLI    D,TCHRS+.VECT.  ; CLOBBER ITS TYPE
1990         HLLM    D,(C)
1991         MOVE    A,-1(P)
1992         HRR     A,1(AB)         ; SETUP TYPE'S RH
1993         SUBI    B,1
1994         HRL     B,(P)           ; AND BYTE POINTER
1995         SUB     P,C%33
1996         SKIPE   (AB)+1          ; SKIP IF NO CHARACTERS TO DEPOSIT
1997         CAML    AB,C%M20        ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
1998          JRST   FINIS
1999         PUSH    TP,A            ;SAVE OUR STRING
2000         PUSH    TP,B
2001         PUSH    TP,A            ;SAVE A TEMPORARY CLOBBER POINTER
2002         PUSH    TP,B
2003         PUSH    P,(AB)1         ;SAVE COUNT
2004         PUSH    TP,(AB)+2
2005         PUSH    TP,(AB)+3
2006 CLOBST: PUSH    TP,-1(TP)
2007         PUSH    TP,-1(TP)
2008         MCALL   1,EVAL
2009         GETYP   C,A             ; CHECK IT
2010         CAME    C,-1(P)         ; MUST BE A CHARACTER
2011          JRST   WTYP2
2012         IDPB    B,-2(TP)        ;CLOBBER
2013         SOSLE   (P)             ;FINISHED?
2014          JRST   CLOBST          ;NO
2015         SUB     P,C%22
2016         SUB     TP,C%66
2017         MOVE    A,(TP)+1
2018         MOVE    B,(TP)+2
2019         JRST    FINIS
2020
2021 \f
2022 ; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
2023 ;       PUNT SOME IF THERE ARE.
2024
2025 INQAGC: PUSH    P,C
2026         PUSH    P,B
2027         PUSH    P,A
2028         PUSH    P,E
2029         PUSHJ   P,SQKIL
2030         JSP     E,CKPUR         ; CHECK FOR PURE RSUBR
2031         POP     P,E
2032         MOVE    A,PURTOP
2033         SUB     A,CURPLN
2034         MOVE    B,RFRETP        ; GET REAL FRETOP
2035         CAIL    B,(A)
2036         MOVE    B,A             ; TOP OF WORLD
2037         MOVE    A,GCSTOP
2038         ADD     A,GETNUM
2039         ADDI    A,1777          ; PAGE BOUNDARY
2040         ANDCMI  A,1777
2041         CAIL    A,(B)           ; SEE WHETHER THERE IS ROOM
2042         JRST    GOTOGC
2043         PUSHJ   P,CLEANT
2044         POP     P,A
2045         POP     P,B
2046         POP     P,C
2047         POPJ    P,
2048 GOTOGC: POP     P,A
2049         POP     P,B
2050         POP     P,C             ; RESTORE CAUSE INDICATOR
2051         MOVE    A,P.TOP
2052         PUSHJ   P,CLEANT        ; CLEAN UP
2053         SKIPL   PLODR           ; IF IN PLOAD DON'T INTERRUPT
2054          JRST   INTAGC          ; GO CAUSE GARBAGE COLLECT
2055         JRST    SAGC
2056
2057 CLEANT: PUSH    P,C
2058         PUSH    P,A
2059         SUB     A,P.TOP
2060         ASH     A,-PGSZ
2061         JUMPE   A,CLNT1
2062         PUSHJ   P,GETPAG                ; GET THOSE PAGES
2063         FATAL CAN'T GET PAGES NEEDED
2064         MOVE    A,(P)
2065         ASH     A,-10.                  ; TO PAGES
2066         PUSHJ   P,P.CORE
2067         PUSHJ   P,SLEEPR
2068 CLNT1:  PUSHJ   P,RBLDM
2069         POP     P,A
2070         POP     P,C
2071         POPJ    P,
2072
2073 \f; RCLVEC DISTASTEFUL VECTOR RECYCLER
2074
2075 ; Arrive here with B pointing to first recycler, A desired length
2076
2077 RCLVEC: PUSH    P,D             ; Save registers
2078         PUSH    P,C
2079         PUSH    P,E
2080         MOVEI   D,RCLV          ; Point to previous recycle for splice
2081 RCLV1:  HLRZ    C,(B)           ; Get size of this block
2082         CAIL    C,(A)           ; Skip if too small
2083         JRST    FOUND1
2084
2085 RCLV2:  MOVEI   D,(B)           ; Save previous pointer
2086         HRRZ    B,(B)           ; Point to next block
2087         JUMPN   B,RCLV1         ; Jump if more blocks
2088
2089         POP     P,E
2090         POP     P,C
2091         POP     P,D
2092         JRST    NORCL           ; Go to normal allocator
2093
2094
2095 FOUND1: CAIN    C,1(A)          ; Exactly 1 greater?
2096         JRST    RCLV2           ; Cant use this guy
2097
2098         HRLM    A,(B)           ; Smash in new count
2099         TLO     A,.VECT.        ; make vector bit be on
2100         HLLM    A,-1(B)
2101         CAIE    C,(A)           ; Exactly right length?
2102         JRST    FOUND2          ; No, do hair
2103
2104         HRRZ    C,(B)           ; Point to next block
2105         HRRM    C,(D)           ; Smash previous pointer
2106         HRRM    B,(B)
2107         SUBI    B,-1(A)         ; Point to top of block
2108         JRST    FOUND3
2109
2110 FOUND2: SUBI    C,(A)           ; Amount of left over to C
2111         HRRZ    E,(B)           ; Point to next block
2112         HRRM    B,(B)
2113         SUBI    B,(A)           ; Point to dope words of guy to put back
2114         MOVSM   C,(B)           ; Smash in count
2115         MOVSI   C,.VECT.        ; Get vector bit
2116         MOVEM   C,-1(B)         ; Make sure it is a vector
2117         HRRM    B,(D)           ; Splice him in
2118         HRRM    E,(B)           ; And the next guy also
2119         ADDI    B,1             ; Point to start of vector
2120
2121 FOUND3: HRROI   B,(B)           ; Make an AOBJN pointer
2122         TLC     B,-3(A)
2123         HRRI    A,TVEC
2124         SKIPGE  A
2125         HRRI    A,TUVEC
2126         MOVSI   A,(A)
2127         POP     P,E
2128         POP     P,C
2129         POP     P,D
2130         POPJ    P,
2131
2132 END
2133 \f