<mdl.int>/stbuil.mid.16

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