<mdl.int>/atomhk.mid.149

   1
   2 TITLE ATOMHACKER FOR MUDDLE
   3
   4 RELOCATABLE
   5
   6 .INSRT MUDDLE >
   7 .GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE,PVSTOR,SPSTOR
   8 .GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP,HASHTB
   9 .GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY,BSETG,TYPVEC,IGET,IPUT
  10 .GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG,CSPNAM,GPURFL,IMPURX
  11
  12 LPVP==SP
  13 TYPNT==AB
  14 LNKBIT==200000
  15
  16 ; FUNCTION TO GENERATE AN EMPTY OBLIST
  17
  18 MFUNCTION MOBLIST,SUBR
  19
  20         ENTRY
  21         CAMGE   AB,[-5,,0]      ;CHECK NUMBER OF ARGS
  22         JRST    TMA
  23         JUMPGE  AB,MOBL2                ; NO ARGS
  24         MOVE    A,(AB)
  25         MOVE    B,1(AB)
  26         MOVSI   C,TATOM
  27         MOVE    D,IMQUOTE OBLIST
  28         PUSHJ   P,IGET          ; CHECK IF IT EXISTS ALREADY
  29         CAMN    A,$TOBLS
  30         JRST    FINIS
  31 MOBL2:
  32         MOVEI   A,1
  33         PUSHJ   P,IBLOCK        ;GET A UNIFORM VECTOR
  34         MOVSI   C,TLIST+.VECT.  ;IT IS OF TYPE LIST
  35         HLRE    D,B             ;-LENGTH TO D
  36         SUBM    B,D             ;D POINTS TO DOPE WORD
  37         MOVEM   C,(D)           ;CLOBBER TYPE IN
  38         MOVSI   A,TOBLS
  39         JUMPGE  AB,FINIS        ; IF NO ARGS, DONE
  40         GETYP   A,(AB)
  41         CAIE    A,TATOM
  42         JRST    WTYP1
  43         MOVSI   A,TOBLS
  44         PUSH    TP,$TOBLS
  45         PUSH    TP,B
  46         MOVSI   C,TATOM
  47         MOVE    D,IMQUOTE OBLIST
  48         PUSH    TP,(AB)
  49         PUSH    TP,1(AB)
  50         PUSHJ   P,IPUT  ; PUT THE NAME ON THE OBLIST
  51         MOVE    A,(AB)
  52         MOVE    B,1(AB)
  53         MOVSI   C,TATOM
  54         MOVE    D,IMQUOTE OBLIST
  55         PUSH    TP,(TB)
  56         PUSH    TP,1(TB)
  57         PUSHJ   P,IPUT  ; PUT THE OBLIST ON THE NAME
  58
  59         POP     TP,B
  60         POP     TP,A
  61         JRST    FINIS
  62
  63 MFUNCTION GROOT,SUBR,ROOT
  64         ENTRY 0
  65         MOVE    A,ROOT
  66         MOVE    B,ROOT+1
  67         JRST    FINIS
  68
  69 MFUNCTION GINTS,SUBR,INTERRUPTS
  70         ENTRY 0
  71         MOVE    A,INTOBL
  72         MOVE    B,INTOBL+1
  73         JRST FINIS
  74
  75 MFUNCTION GERRS,SUBR,ERRORS
  76         ENTRY 0
  77         MOVE    A,ERROBL
  78         MOVE    B,ERROBL+1
  79         JRST    FINIS
  80
  81
  82 COBLQ:  SKIPN   B,2(B)          ; SKIP IF EXISTS
  83         JRST    IFLS
  84         MOVSI   A,TOBLS
  85
  86         ANDI    B,-1
  87         CAMG    B,VECBOT        ; TVP IS IN FROZEN SPACE, NEVER OBLISTS
  88         MOVE    B,(B)
  89         HRLI    B,-1
  90
  91 CPOPJ1: AOS     (P)
  92         POPJ    P,
  93
  94 IFLS:   MOVEI   B,0
  95         MOVSI   A,TFALSE
  96         POPJ    P,
  97
  98 MFUNCTION OBLQ,SUBR,[OBLIST?]
  99
 100         ENTRY   1
 101         GETYP   A,(AB)
 102         CAIE    A,TATOM
 103         JRST    WTYP1
 104         MOVE    B,1(AB)         ; GET ATOM
 105         PUSHJ   P,COBLQ
 106         JFCL
 107         JRST    FINIS
 108
 109 \f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
 110
 111 MFUNCTION LOOKUP,SUBR
 112
 113         ENTRY   2
 114         PUSHJ   P,ILOOKU        ;CALL INTERNAL ROUTINE
 115         JRST    FINIS
 116
 117 CLOOKU: SUBM    M,(P)
 118         PUSH    TP,A
 119         PUSH    TP,B
 120         MOVEI   B,-1(TP)
 121         PUSH    TP,$TOBLS
 122         PUSH    TP,C
 123         GETYP   A,A
 124         PUSHJ   P,CSTAK
 125         MOVE    B,(TP)
 126         MOVSI   A,TOBLS         ; THIS IS AN OBLIST
 127         PUSHJ   P,ILOOK
 128         POP     P,D
 129         HRLI    D,(D)
 130         SUB     P,D
 131         SKIPE   B
 132         SOS     (P)
 133         SUB     TP,[4,,4]
 134         JRST    MPOPJ
 135
 136 ILOOKU: PUSHJ   P,ARGCHK        ;CHECK ARGS
 137         PUSHJ   P,CSTACK        ;PUT CHARACTERS ON THE STACK
 138
 139 CALLIT: MOVE    B,3(AB)         ;GET OBLIST
 140         MOVSI   A,TOBLS
 141 ILOOKC: PUSHJ   P,ILOOK         ;LOOK IT UP
 142         POP     P,D             ;RESTORE COUNT
 143         HRLI    D,(D)           ;TO BOTH SIDES
 144         SUB     P,D
 145         POPJ    P,
 146
 147 ;THIS ROUTINE CHECKS ARG TYPES
 148
 149 ARGCHK: GETYP   A,(AB)          ;GET TYPES
 150         GETYP   C,2(AB)
 151         CAIE    A,TCHRS         ;IS IT EITHER CHAR STRING
 152         CAIN    A,TCHSTR
 153         CAIE    C,TOBLS         ;IS 2ND AN OBLIST
 154         JRST    WRONGT          ;TYPES ARE WRONG
 155         POPJ    P,
 156
 157 ;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
 158
 159
 160 CSTACK: MOVEI   B,(AB)
 161 CSTAK:  POP     P,D             ;RETURN ADDRESS TO D
 162         CAIE    A,TCHRS         ;IMMEDIATE?
 163         JRST    NOTIMM          ;NO, HAIR
 164         MOVE    A,1(B)          ; GET CHAR
 165         LSH     A,29.           ; POSITION
 166         PUSH    P,A             ;ONTO P
 167         PUSH    P,[1]           ;WITH NUMBER
 168         JRST    (D)             ;GO CALL SEARCHER
 169
 170 NOTIMM: MOVEI   A,1             ; CLEAR CHAR COUNT
 171         MOVE    C,(B)           ; GET COUNT OF CHARS
 172         TRNN    C,-1
 173         JRST    NULST           ; FLUSH NULL STRING
 174         MOVE    PVP,PVSTOR+1
 175         MOVEM   C,BSTO(PVP)
 176         ANDI    C,-1
 177         MOVE    B,1(B)          ;GET BYTE POINTER
 178
 179 CLOOP1: PUSH    P,[0]           ; STORE CHARS ON STACK
 180         MOVSI   E,(<440700,,(P)>)       ; SETUP BYTE POINTER
 181 CLOOP:  SKIPL   INTFLG          ; SO CAN WIN WITH INTERRUPTS
 182          JRST   CLOOP2
 183         MOVE    PVP,PVSTOR+1
 184         HRRM    C,BSTO(PVP)     ;SAVE STRING LENGTH
 185         JSR     LCKINT
 186 CLOOP2: ILDB    0,B             ;GET A CHARACTER
 187         IDPB    0,E             ;STORE IT
 188         SOJE    C,CDONE         ; ANY MORE?
 189         TLNE    E,760000        ; WORD FULL
 190         JRST    CLOOP           ;NO CONTINUE
 191         AOJA    A,CLOOP1        ;AND CONTINUE
 192
 193 CDONE:
 194 CDONE1: MOVE    PVP,PVSTOR+1
 195         SETZM   BSTO(PVP)
 196         PUSH    P,A             ;AND NUMBER OF WORDS
 197         JRST    (D)             ;RETURN
 198
 199
 200 NULST:  ERRUUO  EQUOTE NULL-STRING
 201 \f; THIS FUNCTION LOOKS FOR ATOMS.  CALLED BY PUSHJ P,ILOOK
 202 ;       A,B/    OBLIST POINTER (CAN BE LIST OF SAME)
 203 ;       -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
 204 ;       CHAR STRING IS ON THE STACK
 205 ;       IF ATOM EXISTS RETURNS:
 206 ;               B/      THE ATOM
 207 ;               C/      THE BUCKET
 208 ;               0/      THE PREVIOUS BUCKET
 209 ;
 210 ;       IF NOT
 211 ;               B/ 0
 212 ;               0/ PREV IF ONE WITH SAME PNAME, ELSE 0
 213 ;               C/ BUCKET
 214
 215 ILOOK:  PUSH    TP,A
 216         PUSH    TP,B
 217
 218         MOVN    A,-1(P)         ;GET -LENGTH
 219         HRLI    A,-1(A)         ;<-LENGTH-1>,,-LENGTH
 220         PUSH    TP,$TFIX        ;SAVE
 221         PUSH    TP,A
 222         ADDI    A,-1(P)         ;HAVE AOBJN POINTER TO CHARS
 223         MOVE    0,[202622077324]                ;HASH WORD
 224         ROT     0,1
 225         TSC     0,(A)
 226         AOBJN   A,.-2           ;XOR THEM ALL TOGETHER
 227         HLRE    A,HASHTB+1
 228         MOVNS   A
 229         MOVMS   0               ; MAKE SURE + HASH CODE
 230         IDIVI   0,(A)           ;DIVIDE
 231         HRLI    A,(A)           ;TO BOTH HALVES
 232         ADD     A,HASHTB+1
 233
 234         MOVE    C,A
 235         HRRZ    A,(A)           ; POINT TO FIRST ATOM
 236         SETZB   E,0             ; INDICATE NO ATOM
 237
 238         JUMPE   A,NOTFND
 239 LOOK2:  HLRZ    E,1(A)          ; PREPARE TO BUILD AOBJN
 240         ANDI    E,377777        ; SIGN MIGHT BE ON IF IN PURIFY ETC.
 241         SUBI    E,2
 242         HRLS    E
 243         SUBB    A,E
 244
 245         ADD     A,[3,,3]        ;POINT TO ATOMS PNAME
 246         MOVE    D,(TP)          ;GET PSEUDO AOBJN POINTER TO CHARS
 247         ADDI    D,-1(P)         ;NOW ITS A REAL AOBJN POINTER
 248         JUMPE   D,CHECK0        ;ONE IS EMPTY
 249 LOOK1:
 250         MOVE    SP,(D)
 251         CAME    SP,(A)
 252
 253         JRST    NEXT1           ;THIS ONE DOESN'T MATCH
 254         AOBJP   D,CHECK         ;ONE RAN OUT
 255         AOBJN   A,LOOK1         ;JUMP IF STILL MIGHT WIN
 256
 257 NEXT1:  HRRZ    A,-1(TP)        ; SEE IF WE'VE ALREADY SEEN THIS NAME
 258         GETYP   D,-3(TP)        ; SEE IF LIST OF OBLISTS
 259         CAIN    D,TLIST
 260         JUMPN   A,CHECK3        ; DON'T LOOK FURTHER
 261         JUMPN   A,NOTFND
 262 NEXT:
 263         MOVE    0,E
 264         HLRZ    A,2(E)          ; NEXT ATOM
 265         JUMPN   A,LOOK2
 266         HRRZ    A,-1(TP)
 267         JUMPN   A,NEXT1
 268
 269         SETZB   E,0
 270
 271 NOTFND:
 272         MOVEI   B,0
 273         MOVSI   A,TFALSE
 274 CPOPJT:
 275
 276         SUB     TP,[4,,4]
 277         POPJ    P,
 278
 279 CHECK0: JUMPN   A,NEXT1         ;JUMP IF NOT ALSO EMPTY
 280         SKIPA
 281 CHECK:  AOBJN   A,NEXT1         ;JUMP IF NO MATCH
 282
 283 CHECK5: HRRZ    A,-1(TP)        ; SEE IF FIRST SHOT AT THIS GUY?
 284         SKIPN   A
 285         MOVE    B,0             ; REMEMBER ATOM FOR FALL BACK
 286         HLLOS   -1(TP)          ; INDICATE NAME MATCH HAS OCCURRED
 287         HRRZ    A,2(E)          ; COMPUTE OBLIST POINTER
 288         CAMGE   A,VECBOT
 289         MOVE    A,(A)
 290         HRROS   A
 291         GETYP   D,-3(TP)        ; SEE IF LIST OF OBLISTS OR
 292         CAIE    D,TOBLS
 293         JRST    CHECK1
 294         CAME    A,-2(TP)        ; DO OBLISTS MATCH?
 295         JRST    NEXT
 296
 297 CHECK2: MOVE    B,E             ; RETURN ATOM
 298         MOVSI   A,TATOM
 299         JRST    CPOPJT
 300
 301 CHECK1: MOVE    D,-2(TP)        ; ANY LEFT?
 302         CAMN    A,1(D)          ; MATCH
 303         JRST    CHECK2
 304         JRST    NEXT
 305
 306 CHECK3: MOVE    D,-2(TP)
 307         HRRZ    D,(D)
 308         MOVEM   D,-2(TP)
 309         JUMPE   D,NOTFND
 310         JUMPE   B,CHECK6
 311         HLRZ    E,2(B)
 312 CHECK7: HLRZ    A,1(E)
 313         ANDI    A,377777        ; SIGN MIGHT BE ON IF IN PURIFY ETC.
 314         SUBI    A,2
 315         HRLS    A
 316         SUBB    E,A
 317         JRST    CHECK5
 318
 319 CHECK6: HRRZ    E,(C)
 320         JRST    CHECK7
 321
 322 \f; FUNCTION TO INSERT AN ATOM ON AN OBLIST
 323
 324 MFUNCTION INSERT,SUBR
 325
 326         ENTRY   2
 327         GETYP   A,2(AB)
 328         CAIE    A,TOBLS
 329         JRST    WTYP2
 330         MOVE    A,(AB)
 331         MOVE    B,1(AB)
 332         MOVE    C,3(AB)
 333         PUSHJ   P,IINSRT
 334         JRST    FINIS
 335
 336 CINSER: SUBM    M,(P)
 337         PUSHJ   P,IINSRT
 338         JRST    MPOPJ
 339
 340 IINSRT: PUSH    TP,A
 341         PUSH    TP,B
 342         PUSH    TP,$TOBLS
 343         PUSH    TP,C
 344         GETYP   A,A
 345         CAIN    A,TATOM
 346         JRST    INSRT0
 347
 348 ;INSERT WITH A GIVEN PNAME
 349
 350         CAIE    A,TCHRS
 351         CAIN    A,TCHSTR
 352         JRST    .+2
 353         JRST    WTYP1
 354
 355         PUSH    TP,$TFIX        ;FLAG CALL
 356         PUSH    TP,[0]
 357         MOVEI   B,-5(TP)
 358         PUSHJ   P,CSTAK         ;COPY ONTO STACK
 359         MOVE    B,-2(TP)
 360         MOVSI   A,TOBLS
 361         PUSHJ   P,ILOOK         ;LOOK IT UP (BUCKET RETURNS IN C)
 362         SETZM   -4(TP)
 363         SETZM   -5(TP)          ; KILL STRING POINTER TO KEEP FROM CONFUSING GC
 364         JUMPN   B,ALRDY         ;EXISTS, LOSE
 365         MOVE    D,-2(TP)        ; GET OBLIST BACK
 366 INSRT1: PUSH    TP,$TATOM
 367         PUSH    TP,0            ; PREV ATOM
 368         PUSH    TP,$TUVEC       ;SAVE BUCKET POINTER
 369         PUSH    TP,C
 370         PUSH    TP,$TOBLS
 371         PUSH    TP,D            ; SAVE OBLIST
 372 INSRT3: PUSHJ   P,IATOM         ; MAKE AN ATOM
 373         HLRE    A,B             ; FIND DOPE WORD
 374         SUBM    B,A
 375         ANDI    A,-1
 376         SKIPN   E,-4(TP)        ; AFTER AN ATOM?
 377          JRST   INSRT7          ; NO, FIRST IN BUCKET
 378         MOVEI   0,(E)           ; CHECK IF PURE
 379         CAIG    0,HIBOT
 380          JRST   INSRNP
 381         PUSH    TP,$TATOM       ; SAVE NEW ATOM
 382         PUSH    TP,B
 383         MOVE    B,E
 384         PUSHJ   P,IMPURIF
 385         MOVE    B,(TP)
 386         MOVE    E,-6(TP)
 387         SUB     TP,[2,,2]
 388         HLRE    A,B             ; FIND DOPE WORD
 389         SUBM    B,A
 390         ANDI    A,-1
 391
 392 INSRNP: HLRZ    0,2(E)          ; NEXT
 393         HRLM    A,2(E)          ; SPLICE
 394         HRLM    0,2(B)
 395         JRST    INSRT8
 396
 397 INSRT7: MOVE    E,-2(TP)
 398         EXCH    A,(E)
 399         HRLM    A,2(B)          ; IN CASE OLD ONE
 400
 401 INSRT8: MOVE    E,(TP)          ; GET OBLIST
 402         HRRM    E,2(B)          ; STORE OBLIST
 403         MOVE    E,(E)           ; POINT TO LIST OF ATOMS
 404         PUSHJ   P,LINKCK
 405         PUSHJ   P,ICONS
 406         MOVE    E,(TP)
 407         HRRM    B,(E)           ;INTO NEW BUCKET
 408         MOVSI   A,TATOM
 409         MOVE    B,1(B)          ;GET ATOM BACK
 410         MOVE    C,-6(TP)        ;GET FLAG
 411         SUB     TP,[8,,8]       ;POP STACK
 412         JUMPN   C,(C)
 413         SUB     TP,[4,,4]
 414         POPJ    P,
 415
 416 ;INSERT WITH GIVEN ATOM
 417 INSRT0: MOVE    A,-2(TP)        ;GOBBLE PNAME
 418         SKIPE   2(A)            ; SKIP IF NOT ON AN OBLIST
 419         JRST    ONOBL
 420         ADD     A,[3,,3]
 421         HLRE    C,A
 422         MOVNS   C
 423         PUSH    P,(A)           ;FLUSH PNAME ONTO P STACK
 424         AOBJN   A,.-1
 425         PUSH    P,C
 426         MOVE    B,(TP)          ; GET OBLIST FOR LOOKUP
 427         MOVSI   A,TOBLS
 428         PUSHJ   P,ILOOK         ;ALREADY THERE?
 429         JUMPN   B,ALRDY
 430         MOVE    D,-2(TP)
 431
 432         HLRE    A,-2(TP)        ; FIND DOPE WORD
 433         SUBM    D,A             ; TO A
 434         JUMPE   0,INSRT9        ; NO CURRENT ATOM
 435         MOVE    E,0
 436         MOVEI   0,(E)
 437         CAIGE   0,HIBOT         ; PURE?
 438          JRST   INSRPN
 439         PUSH    TP,$TATOM
 440         PUSH    TP,E
 441         PUSH    TP,$TATOM
 442         PUSH    TP,D
 443         MOVE    B,E
 444         PUSHJ   P,IMPURIF
 445         MOVE    D,(TP)
 446         MOVE    E,-2(TP)
 447         SUB     TP,[4,,4]
 448         HLRE    A,D
 449         SUBM    D,A
 450
 451
 452 INSRPN: HLRZ    0,2(E)          ; POINT TO NEXT
 453         HRLM    A,2(E)          ; CLOBBER NEW GUY IN
 454         HRLM    0,2(D)          ; FINISH SLPICE
 455         JRST    INSRT6
 456
 457 INSRT9: ANDI    A,-1
 458         EXCH    A,(C)           ; INTO BUCKET
 459         HRLM    A,2(D)
 460
 461 INSRT6: HRRZ    E,(TP)
 462         HRRZ    E,(E)
 463         MOVE    B,D
 464         PUSHJ   P,LINKCK
 465         PUSHJ   P,ICONS
 466         MOVE    C,(TP)          ;RESTORE OBLIST
 467         HRRZM   B,(C)
 468         MOVE    B,-2(TP)        ; GET BACK ATOM
 469         HRRM    C,2(B)          ; CLOBBER OBLIST IN
 470         MOVSI   A,TATOM
 471         SUB     TP,[4,,4]
 472         POP     P,C
 473         HRLI    C,(C)
 474         SUB     P,C
 475         POPJ    P,
 476
 477 LINKCK: HRRZ    C,FSAV(TB)      ;CALLER'S NAME
 478         MOVE    D,B
 479         CAIE    C,LINK
 480         SKIPA   C,$TATOM        ;LET US INSERT A LINK INSTEAD OF AN ATOM
 481         SKIPA   C,$TLINK        ;GET REAL ATOM FOR CALL TO ICONS
 482         POPJ    P,
 483         HLRE    A,D
 484         SUBM    D,A
 485         MOVEI   B,LNKBIT
 486         IORM    B,(A)
 487         POPJ    P,
 488
 489
 490 ALRDY:  ERRUUO  EQUOTE ATOM-ALREADY-THERE
 491
 492 ONOBL:  ERRUUO  EQUOTE ON-AN-OBLIST-ALREADY
 493
 494 ; INTERNAL INSERT CALL
 495
 496 INSRTX: POP     P,0             ; GET RET ADDR
 497         PUSH    TP,$TFIX
 498         PUSH    TP,0
 499         PUSH    TP,$TATOM
 500         PUSH    TP,[0]
 501         PUSH    TP,$TUVEC
 502         PUSH    TP,[0]
 503         PUSH    TP,$TOBLS
 504         PUSH    TP,B
 505         MOVSI   A,TOBLS
 506         PUSHJ   P,ILOOK
 507         JUMPN   B,INSRXT
 508         MOVEM   0,-4(TP)
 509         MOVEM   C,-2(TP)
 510         JRST    INSRT3          ; INTO INSERT CODE
 511
 512 INSRXT: PUSH    P,-4(TP)
 513         SUB     TP,[6,,6]
 514         POPJ    P,
 515         JRST    IATM1
 516 \f
 517 ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
 518
 519 MFUNCTION REMOVE,SUBR
 520
 521         ENTRY
 522
 523         JUMPGE  AB,TFA
 524         CAMGE   AB,[-5,,]
 525         JRST    TMA
 526         MOVEI   C,0
 527         CAML    AB,[-3,,]       ; SKIP IF OBLIST GIVEN
 528         JRST    .+5
 529         GETYP   0,2(AB)
 530         CAIE    0,TOBLS
 531         JRST    WTYP2
 532         MOVE    C,3(AB)
 533         MOVE    A,(AB)
 534         MOVE    B,1(AB)
 535         PUSHJ   P,IRMV
 536         JRST    FINIS
 537
 538 CIRMV:  SUBM    M,(P)
 539         PUSHJ   P,IRMV
 540         JRST    MPOPJ
 541
 542 IRMV:   PUSH    TP,A
 543         PUSH    TP,B
 544         PUSH    TP,$TOBLS
 545         PUSH    TP,C
 546 IRMV1:  GETYP   0,A             ; CHECK 1ST ARG
 547         CAIN    0,TLINK
 548         JRST    .+3
 549         CAIE    0,TATOM         ; ATOM, TREAT ACCORDINGLY
 550         JRST    RMV1
 551
 552         HRRZ    D,2(B)          ; SKIP IF ON OBLIST AND GET SAME
 553         JUMPE   D,RMVDON
 554         CAMG    D,VECBOT        ; SKIP IF REAL OBLIST
 555         HRRZ    D,(D)           ; NO, REF, GET IT
 556
 557         JUMPGE  C,GOTOBL
 558         CAIE    D,(C)           ; BETTER BE THE SAME
 559         JRST    ONOTH
 560
 561 GOTOBL: ADD     B,[3,,3]        ; POINT TO PNAME
 562         HLRE    A,B
 563         MOVNS   A
 564         PUSH    P,(B)           ; PUSH PNAME
 565         AOBJN   B,.-1
 566         PUSH    P,A
 567         HRROM   D,(TP)          ; SAVE OBLIST
 568         JRST    RMV3
 569
 570 RMV1:   JUMPGE  C,TFA
 571         CAIE    0,TCHRS
 572         CAIN    0,TCHSTR
 573         SKIPA   A,0
 574         JRST    WTYP1
 575         MOVEI   B,-3(TP)
 576         PUSHJ   P,CSTAK
 577 RMV3:   MOVE    B,(TP)
 578         MOVSI   A,TOBLS
 579         PUSHJ   P,ILOOK
 580         POP     P,D
 581         HRLI    D,(D)
 582         SUB     P,D
 583         JUMPE   B,RMVDON
 584
 585         MOVEI   A,(B)
 586         CAIGE   A,HIBOT         ; SKIP IF PURE
 587         JRST    RMV2
 588         PUSH    TP,$TATOM
 589         PUSH    TP,0
 590         PUSHJ   P,IMPURIFY
 591         MOVE    0,(TP)
 592         SUB     TP,[2,,2]
 593         MOVE    A,-3(TP)
 594         MOVE    B,-2(TP)
 595         MOVE    C,(TP)
 596         JRST    IRMV1
 597
 598 RMV2:   JUMPN   0,RMV9          ; JUMP IF FIRST NOT IN BUCKET
 599         HLRZ    0,2(B)          ; POINT TO NEXT
 600         MOVEM   0,(C)
 601         JRST    RMV8
 602
 603 RMV9:   MOVE    C,0             ; C IS PREV ATOM
 604         HLRZ    0,2(B)          ; NEXT
 605         HRLM    0,2(C)
 606
 607 RMV8:   SETZM   2(B)            ; CLOBBER OBLIST SLOT
 608         MOVE    C,(TP)          ; GET OBLIST FOR SPLICE OUT
 609         MOVEI   0,-1
 610         HRRZ    E,(C)
 611
 612 RMV7:   JUMPE   E,RMVDON
 613         CAMN    B,1(E)          ; SEARCH OBLIST
 614         JRST    RMV6
 615         MOVE    C,E
 616         HRRZ    E,(C)
 617         SOJG    0,RMV7
 618
 619 RMVDON: SUB     TP,[4,,4]
 620         MOVSI   A,TATOM
 621         POPJ    P,
 622
 623 RMV6:   HRRZ    E,(E)
 624         HRRM    E,(C)           ; SMASH IN
 625         JRST    RMVDON
 626
 627 \f
 628 ;INTERNAL CALL FROM THE READER
 629
 630 RLOOKU: PUSH    TP,$TFIX        ;PUSH A FLAG
 631         POP     P,C             ;POP OFF RET ADR
 632         PUSH    TP,C            ;AND USE AS A FLAG FOR INTERNAL
 633         MOVE    C,(P)           ; CHANGE CHAR COUNT TO WORD
 634         ADDI    C,4
 635         IDIVI   C,5
 636         MOVEM   C,(P)
 637         GETYP   D,A
 638
 639         CAIN    D,TOBLS         ;IS IT ONE OBLIST?
 640         JRST    .+3
 641         CAIE    D,TLIST         ;IS IT A LIST
 642         JRST    BADOBL
 643
 644         JUMPE   B,BADLST
 645         PUSH    TP,$TUVEC       ; SLOT FOR REMEBERIG
 646         PUSH    TP,[0]
 647         PUSH    TP,$TOBLS
 648         PUSH    TP,[0]
 649         PUSH    TP,A
 650         PUSH    TP,B
 651         CAIE    D,TLIST
 652         JRST    RLOOK1
 653
 654         PUSH    TP,$TLIST
 655         PUSH    TP,B
 656 RLOOK2: GETYP   A,(B)           ;CHECK THIS IS AN OBLIST
 657         CAIE    A,TOBLS
 658         JRST    DEFALT
 659
 660         SKIPE   -4(TP)          ; SKIP IF DEFAULT NOT STORED
 661         JRST    RLOOK4
 662         MOVE    D,1(B)          ; OBLIST
 663         MOVEM   D,-4(TP)
 664 RLOOK4: INTGO
 665         HRRZ    B,@(TP)         ;CDR THE LIST
 666         HRRZM   B,(TP)
 667         JUMPN   B,RLOOK2
 668         SUB     TP,[2,,2]
 669         JRST    .+3
 670
 671 RLOOK1: MOVE    B,(TP)
 672         MOVEM   B,-2(TP)
 673         MOVE    A,-1(TP)
 674         MOVE    B,(TP)
 675         PUSHJ   P,ILOOK
 676         JUMPN   B,RLOOK3
 677         SKIPN   D,-2(TP)        ; RESTORE FOR INSERT
 678         JRST    BADDEF          ; NO DEFAULT, USER LOST ON SPECIFICATION
 679         SUB     TP,[6,,6]       ; FLUSH CRAP
 680         SKIPN   NOATMS
 681          JRST   INSRT1
 682           JRST  INSRT1
 683
 684 DEFFLG==1       ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
 685                 ; SPECIFIED
 686 DEFALT: MOVE    0,1(B)
 687         CAIN    A,TATOM         ;SPECIAL DEFAULT INDICATING ATOM ?
 688         CAME    0,MQUOTE DEFAULT
 689         JRST    BADDEF          ;NO, LOSE
 690         MOVEI   A,DEFFLG
 691         XORB    A,-11(TP)       ;SET AND TEST FLAG
 692         TRNN    A,DEFFLG        ; HAVE WE BEEN HERE BEFORE ?
 693         JRST    BADDEF          ; YES, LOSE
 694         SETZM   -6(TP)          ;ZERO OUT PREVIOUS DEFAULT
 695         SETZM   -4(TP)
 696         JRST    RLOOK4          ;CONTINUE
 697
 698
 699 INSRT2: JRST    .+2             ;
 700 RLOOK3: SUB     TP,[6,,6]       ;POP OFF LOSSAGE
 701         PUSHJ   P,ILINK         ;IF THIS IS A LINK FOLLOW IT
 702         PUSH    P,(TP)          ;GET BACK RET ADR
 703         SUB     TP,[2,,2]       ;POP TP
 704         JRST    IATM1           ;AND RETURN
 705
 706
 707 BADOBL: ERRUUO  EQUOTE BAD-OBLIST-OR-LIST-THEREOF
 708
 709 BADDEF: ERRUUO  EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
 710
 711 ONOTH:  ERRUUO  EQUOTE ATOM-ON-DIFFERENT-OBLIST
 712 \f;SUBROUTINE TO MAKE AN ATOM
 713
 714 IMFUNCTION ATOM,SUBR
 715
 716         ENTRY   1
 717
 718         MOVE    A,(AB)
 719         MOVE    B,1(AB)
 720         PUSHJ   P,IATOMI
 721         JRST    FINIS
 722
 723 CATOM:  SUBM    M,(P)
 724         PUSHJ   P,IATOMI
 725         JRST    MPOPJ
 726
 727 IATOMI: GETYP   0,A             ;CHECK ARG TYPE
 728         CAIE    0,TCHRS
 729         CAIN    0,TCHSTR
 730         JRST    .+2             ;JUMP IF WINNERS
 731         JRST    WTYP1
 732
 733         PUSH    TP,A
 734         PUSH    TP,B
 735         MOVEI   B,-1(TP)
 736         MOVE    A,0
 737         PUSHJ   P,CSTAK         ;COPY ONTO STACK
 738         PUSHJ   P,IATOM         ;NOW MAKE THE ATOM
 739         SUB     TP,[2,,2]
 740         POPJ    P,
 741
 742 ;INTERNAL ATOM MAKER
 743
 744 IATOM:  MOVE    A,-1(P)         ;GET WORDS IN PNAME
 745         ADDI    A,3             ;FOR VALUE CELL
 746         PUSHJ   P,IBLOCK        ; GET BLOCK
 747         MOVSI   C,<(GENERAL)>+SATOM     ;FOR TYPE FIELD
 748         MOVE    D,-1(P)         ;RE-GOBBLE LENGTH
 749         ADDI    D,3(B)          ;POINT TO DOPE WORD
 750         MOVEM   C,(D)
 751         SKIPG   -1(P)           ;EMPTY PNAME ?
 752         JRST    IATM0           ;YES, NO CHARACTERS TO MOVE
 753         MOVE    E,B             ;COPY ATOM POINTER
 754         ADD     E,[3,,3]        ;POINT TO PNAME AREA
 755         MOVEI   C,-1(P)
 756         SUB     C,-1(P)         ;POINT TO STRING ON STACK
 757         MOVE    D,(C)           ;GET SOME CHARS
 758         MOVEM   D,(E)           ;AND COPY THEM
 759         ADDI    C,1
 760         AOBJN   E,.-3
 761 IATM0:  MOVSI   A,TATOM ;TYPE TO ATOM
 762 IATM1:  POP     P,D             ;RETURN ADR
 763         POP     P,C
 764         HRLI    C,(C)
 765         SUB     P,C
 766         JRST    (D)             ;RETURN
 767
 768 \f;SUBROUTINE TO GET AN ATOM'S PNAME
 769
 770 MFUNCTION PNAME,SUBR
 771
 772         ENTRY 1
 773
 774         GETYP   A,(AB)
 775         CAIE    A,TATOM         ;CHECK TYPE IS ATOM
 776         JRST    WTYP1
 777         MOVE    A,1(AB)
 778         PUSHJ   P,IPNAME
 779         JRST    FINIS
 780
 781 CIPNAM: SUBM    M,(P)
 782         PUSHJ   P,IPNAME
 783         JRST    MPOPJ
 784
 785 IPNAME: ADD     A,[3,,3]
 786         HLRE    B,A
 787         MOVM    B,B
 788         PUSH    P,(A)           ;FLUSH PNAME ONTO P
 789         AOBJN   A,.-1
 790         MOVE    0,(P)           ; LAST WORD
 791         PUSHJ   P,PNMCNT
 792         PUSH    P,B
 793         PUSHJ   P,CHMAK         ;MAKE A STRING
 794         POPJ    P,
 795
 796 PNMCNT: IMULI   B,5             ; CHARS TO B
 797         MOVE    A,0
 798         SUBI    A,1             ; FIND LAST 1
 799         ANDCM   0,A             ; 0 HAS 1ST 1
 800         JFFO    0,.+1
 801         HRREI   0,-34.(A)       ; FIND HOW MUCH TO ADD
 802         IDIVI   0,7
 803         ADD     B,0
 804         POPJ    P,
 805
 806 MFUNCTION SPNAME,SUBR
 807
 808         ENTRY   1
 809
 810         GETYP   0,(AB)
 811         CAIE    0,TATOM
 812         JRST    WTYP1
 813
 814         MOVE    B,1(AB)
 815         PUSHJ   P,CSPNAM
 816         JRST    FINIS
 817
 818 CSPNAM: ADD     B,[3,,3]
 819         MOVEI   D,(B)
 820         HLRE    A,B
 821         SUBM    B,A
 822         MOVE    0,-1(A)
 823         HLRES   B
 824         MOVMS   B
 825         PUSHJ   P,PNMCNT
 826         MOVSI   A,TCHSTR
 827         HRRI    A,(B)
 828         MOVSI   B,010700
 829         HRRI    B,-1(D)
 830         POPJ    P,
 831
 832 \f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
 833
 834 IMFUNCTION BLK,SUBR,BLOCK
 835
 836         ENTRY   1
 837
 838         GETYP   A,(AB)  ;CHECK TYPE OF ARG
 839         CAIE    A,TOBLS ;IS IT AN OBLIST
 840         CAIN    A,TLIST ;OR A LIAT
 841         JRST    .+2
 842         JRST    WTYP1
 843         MOVSI   A,TATOM ;LOOK UP OBLIST
 844         MOVE    B,IMQUOTE OBLIST
 845         PUSHJ   P,IDVAL ;GET VALUE
 846         PUSH    TP,A
 847         PUSH    TP,B
 848         MOVE    PVP,PVSTOR+1
 849         PUSH    TP,.BLOCK(PVP)  ;HACK THE LIST
 850         PUSH    TP,.BLOCK+1(PVP)
 851         MCALL   2,CONS  ;CONS THE LIST
 852         MOVE    PVP,PVSTOR+1
 853         MOVEM   A,.BLOCK(PVP)   ;STORE IT BACK
 854         MOVEM   B,.BLOCK+1(PVP)
 855         PUSH    TP,$TATOM
 856         PUSH    TP,IMQUOTE OBLIST
 857         PUSH    TP,(AB)
 858         PUSH    TP,1(AB)
 859         MCALL   2,SET   ;SET OBLIST TO ARG
 860         JRST    FINIS
 861
 862 MFUNCTION ENDBLOCK,SUBR
 863
 864         ENTRY   0
 865
 866         MOVE    PVP,PVSTOR+1
 867         SKIPN   B,.BLOCK+1(PVP) ;IS THE LIST NIL?
 868         JRST    BLKERR  ;YES, LOSE
 869         HRRZ    C,(B)   ;CDR THE LIST
 870         HRRZM   C,.BLOCK+1(PVP)
 871         PUSH    TP,$TATOM       ;NOW RESET OBLIST
 872         PUSH    TP,IMQUOTE OBLIST
 873         HLLZ    A,(B)   ;PUSH THE TYPE OF THE CAR
 874         PUSH    TP,A
 875         PUSH    TP,1(B) ;AND VALUE OF CAR
 876         MCALL   2,SET
 877         JRST    FINIS
 878
 879 BLKERR: ERRUUO  EQUOTE UNMATCHED
 880
 881 BADLST: ERRUUO  EQUOTE NIL-LIST-OF-OBLISTS
 882 \f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
 883
 884 CHMAK:  MOVE    A,-1(P)
 885         ADDI    A,4
 886         IDIVI   A,5
 887         PUSHJ   P,IBLOCK
 888         MOVEI   C,-1(P)         ;FIND START OF CHARS
 889         HLRE    E,B             ; - LENGTH
 890         ADD     C,E             ;C POINTS TO START
 891         MOVE    D,B             ;COPY VECTOR RESULT
 892         JUMPGE  D,NULLST        ;JUMP IF EMPTY
 893         MOVE    A,(C)           ;GET ONE
 894         MOVEM   A,(D)
 895         ADDI    C,1             ;BUMP POINTER
 896         AOBJN   D,.-3           ;COPY
 897 NULLST: MOVSI   C,TCHRS+.VECT.          ;GET TYPE
 898         MOVEM   C,(D)           ;CLOBBER IT IN
 899         MOVE    A,-1(P)         ; # WORDS
 900         HRLI    A,TCHSTR
 901         HRLI    B,010700
 902         MOVMM   E,-1(P)         ; SO IATM1 WORKS
 903         SOJA    B,IATM1         ;RETURN
 904
 905 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.
 906 ;   TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
 907 ; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
 908
 909 NXTDCL: GETYP   B,(A)           ;CHECK TYPE
 910         CAIE    B,TDEFER                ;LOSE IF NOT DEFERRED
 911         POPJ    P,
 912
 913         MOVE    B,1(A)          ;GET REAL BYTE POINTER
 914 CHRWRD: PUSH    P,C
 915         GETYP   C,(B)           ;CHECK IT IS CHSTR
 916         CAIE    C,TCHSTR
 917         JRST    CPOPJC          ;NO, QUIT
 918         PUSH    P,D
 919         PUSH    P,E
 920         PUSH    P,0
 921         MOVEI   E,0             ;INITIALIZE DESTINATION
 922         HRRZ    C,(B)           ; GET CHAR COUNT
 923         JUMPE   C,GOTDCL        ; NULL, FINISHED
 924         MOVE    B,1(B)          ;GET BYTE POINTER
 925         MOVE    D,[440700,,E]   ;BYTE POINT TO E
 926 CHLOOP: ILDB    0,B             ; GET A CHR
 927         IDPB    0,D             ;CLOBBER AWAY
 928         SOJE    C,GOTDCL        ; JUMP IF DONE
 929         TLNE    D,760000        ; SKIP IF WORD FULL
 930         JRST    CHLOOP          ; MORE THAN 5 CHARS
 931         TRO     E,1             ; TURN ON FLAG
 932
 933 GOTDCL: MOVE    B,E             ;RESULT TO B
 934         AOS     -4(P)           ;SKIP RETURN
 935 CPOPJ0: POP     P,0
 936         POP     P,E
 937         POP     P,D
 938 CPOPJC: POP     P,C
 939         POPJ    P,
 940
 941 \f;ROUTINES TO DEFINE AND HANDLE LINKS
 942
 943 MFUNCTION LINK,SUBR
 944         ENTRY
 945         CAML    AB,[-6,,0]      ;NO MORE THAN 3 ARGS
 946         CAML    AB,[-2,,0]      ;NO LESS THAN 2 ARGS
 947         JRST    WNA
 948         CAML    AB,[-4,,0]      ;ONLY TWO ARGS SUPPLIED ?
 949         JRST    GETOB           ;YES, GET OBLIST FROM CURRENT PATH
 950         MOVE    A,2(AB)
 951         MOVE    B,3(AB)
 952         MOVE    C,5(AB)
 953         JRST    LINKIN
 954 GETOB:  MOVSI   A,TATOM
 955         MOVE    B,IMQUOTE OBLIST
 956         PUSHJ   P,IDVAL
 957         CAMN    A,$TOBLS
 958         JRST    LINKP
 959         CAME    A,$TLIST
 960         JRST    BADOBL
 961         JUMPE   B,BADLST
 962         GETYPF  A,(B)
 963         MOVE    B,(B)+1
 964 LINKP:  MOVE    C,B
 965         MOVE    A,2(AB)
 966         MOVE    B,3(AB)
 967 LINKIN: PUSHJ   P,IINSRT
 968         CAMN    A,$TFALSE       ;LINK NAME ALREADY USED ?
 969         JRST    ALRDY           ;YES, LOSE
 970         MOVE    C,B
 971         MOVE    A,(AB)
 972         MOVE    B,1(AB)
 973         PUSHJ   P,CSETG
 974         JRST    FINIS
 975
 976
 977 ILINK:  HLRE    A,B
 978         SUBM    B,A             ;FOUND A LINK ?
 979         MOVE    A,(A)
 980         TRNE    A,LNKBIT
 981          JRST   .+3
 982         MOVSI   A,TATOM
 983         POPJ    P,              ;NO, FINISHED
 984         MOVSI   A,TATOM
 985         PUSHJ   P,IGVAL         ;GET THE LINK'S DESTINATION
 986         CAME    A,$TUNBOUND     ;WELL FORMED LINK ?
 987         POPJ    P,              ;YES
 988         ERRUUO  EQUOTE BAD-LINK
 989
 990 \f
 991 ; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
 992
 993 IMPURIFY:
 994         PUSH    TP,$TATOM
 995         PUSH    TP,B
 996         MOVE    C,B
 997         MOVEI   0,(C)
 998         CAIGE   0,HIBOT
 999         JRST    RTNATM          ; NOT PURE, RETURN
1000         JRST    IMPURX
1001
1002 ; ROUTINE PASSED TO GCHACK
1003
1004 ATFIX:  CAME    D,(TP)
1005          CAMN   D,-2(TP)
1006           JRST  .+2
1007         POPJ    P,
1008
1009         ASH     C,1
1010         ADD     C,TYPVEC+1      ; COMPUTE SAT
1011         HRRZ    C,(C)
1012         ANDI    C,SATMSK
1013         CAIE    C,SATOM
1014 CPOPJ:  POPJ    P,
1015
1016         SUB     D,-2(TP)
1017         ADD     D,-4(TP)
1018         SKIPE   B
1019         MOVEM   D,1(B)
1020         POPJ    P,
1021
1022
1023 ; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
1024 ; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
1025
1026 BYTDOP: PUSH    P,B             ; SAVE SOME ACS
1027         PUSH    P,D
1028         PUSH    P,E
1029         MOVE    B,1(C)          ; GET BYTE POINTER
1030         LDB     D,[360600,,B]   ; POSITION TO D
1031         LDB     E,[300600,,B]   ; AND BYTE SIZE
1032         MOVEI   A,(E)           ; A COPY IN A
1033         IDIVI   D,(E)           ; D=> # OF BYTES IN WORD 1
1034         HRRZ    E,(C)           ; GET LENGTH
1035         SUBM    E,D             ; # OF BYTES IN OTHER WORDS
1036         JUMPL   D,BYTDO1        ; NEAR DOPE WORD
1037         MOVEI   B,36.           ; COMPUTE BYTES PER WORD
1038         IDIVM   B,A
1039         ADDI    D,-1(A)         ; NOW COMPUTE WORDS
1040         IDIVI   D,(A)           ; D/ # NO. OF WORDS PAST 1ST
1041         ADD     D,1(C)          ; D POINTS TO DOPE WORD
1042         MOVEI   A,2(D)
1043
1044 BYTDO2: POP     P,E
1045         POP     P,D
1046         POP     P,B
1047         POPJ    P,
1048 BYTDO1: MOVEI   A,2(B)
1049         JRST    BYTDO2
1050
1051 ; 1) IMPURIFY ITS OBLIST LIST
1052
1053 IMPURX: HRRZ    B,2(C)          ; PICKUP OBLIST IF IT EXISTS
1054         JUMPE   B,IMPUR0        ; NOT ON ONE, IGNORE THIS CODE
1055
1056         HRRO    E,(B)
1057         PUSH    TP,$TOBLS       ; SAVE BUCKET
1058         PUSH    TP,E
1059
1060         MOVE    B,(E)           ; GET NEXT ONE
1061 IMPUR4: MOVEI   0,(B)
1062         MOVE    D,1(B)
1063         CAME    D,-2(TP)
1064         JRST    .+3
1065         SKIPE   GPURFL          ; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
1066                                 ;   ATOM
1067         HRRM    D,1(B)
1068         CAIGE   0,HIBOT         ; SKIP IF PURE
1069         JRST    IMPUR3          ; FOUND IMPURE NESS, SKIP IT
1070         HLLZ    C,(B)           ; SET UP ICONS CALL
1071         HRRZ    E,(B)
1072 IMPR1:  PUSHJ   P,ICONS         ; CONS IT UP
1073 IMPR2:  HRRZ    E,(TP)          ; RETRV PREV
1074         HRRM    B,(E)           ; AND CLOBBER
1075 IMPUR3: MOVE    D,1(B)
1076         CAMN    D,-2(TP)        ; HAVE GOTTEN TO OUR SLOT?
1077         JRST    IMPPR3
1078         MOVSI   0,TLIST
1079         MOVEM   0,-1(TP)        ; FIX TYPE
1080         HRRZM   B,(TP)          ; STORE GOODIE
1081         HRRZ    B,(B)           ; CDR IT
1082         JUMPN   B,IMPUR4        ; LOOP
1083 IMPPR3: SUB     TP,[2,,2]       ; FLUSH TP CRUFT
1084
1085 ; 1.5)  IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
1086
1087 IMPUR0: MOVE    C,(TP)          ; GET ATOM
1088
1089         HRRZ    B,2(C)
1090         MOVE    B,(B)
1091         ADD     C,[3,,3]        ; POINT TO PNAME
1092         HLRE    A,C             ; GET LNTH IN WORDS OF PNAME
1093         MOVNS   A
1094 ;       PUSH    P,[SETZ IMPUR2] ; FAKE OUT ILOOKC
1095         XMOVEI  0,IMPUR2
1096         PUSH    P,0
1097         PUSH    P,(C)           ; PUSH UP THE PNAME
1098         AOBJN   C,.-1
1099         PUSH    P,A             ; NOW THE COUNT
1100         MOVSI   A,TOBLS
1101         JRST    ILOOKC          ; GO FIND BUCKET
1102
1103 IMPUR2: JUMPE   B,IMPUR1
1104         JUMPE   0,IMPUR1                ; YUP, DONE
1105         HRRZ    C,0
1106         CAIG    C,HIBOT         ; SKIP IF PREV IS PURE
1107         JRST    IMPUR1
1108
1109         MOVE    B,0
1110         PUSH    P,GPURFL        ; PRERTEND OUT OF PURIFY
1111         HLRE    C,B
1112         SUBM    B,C
1113         HRRZ    C,(C)           ; ARE WE ON PURIFY LIST
1114         CAIG    C,HIBOT         ; IF SO, WE ARE STILL PURIFY
1115         SETZM   GPURFL
1116         PUSHJ   P,IMPURIF       ; RECURSE
1117         POP     P,GPURFL
1118         MOVE    B,(TP)          ; AND RETURN ORIGINAL
1119
1120 ; 2) GENERATE A DUPLICATE ATOM
1121
1122 IMPUR1: SKIPE   GPURFL          ; SEE IF IN PURIFY
1123         JRST    IMPUR7
1124         HLRE    A,(TP)          ; GET LNTH OF ATOM
1125         MOVNS   A
1126         PUSH    P,A
1127         PUSHJ   P,IBLOCK        ; GET NEW BLOCK FOR ATOM
1128         PUSH    TP,$TATOM
1129         PUSH    TP,B
1130         HRL     B,-2(TP)                ; SETUP BLT
1131         POP     P,A
1132         ADDI    A,(B)           ; END OF BLT
1133         BLT     B,(A)           ; CLOBBER NEW ATOM
1134         MOVSI   B,.VECT.        ; TURN ON BIT FOR GCHACK
1135         IORM    B,(A)
1136
1137 ; 3) NOW COPY GLOBAL VALUE
1138
1139 IMPUR7: MOVE    B,(TP)          ; ATOM BACK
1140         GETYP   0,(B)
1141         SKIPE   A,1(B)          ; NON-ZER POINTER?
1142         CAIN    0,TUNBOU        ; BOUND?
1143         JRST    IMPUR5          ; NO, DONT COPY GLOB VAL
1144         PUSH    TP,(A)
1145         PUSH    TP,1(A)
1146         PUSH    TP,$TATOM
1147         PUSH    TP,B
1148         SETZM   (B)
1149         SETZM   1(B)
1150         SKIPN   GPURFL          ; HERE IS SOME CODE NEEDED FOR PURIFY
1151         JRST    IMPUR8
1152         PUSH    P,LPVP
1153         MOVE    PVP,PVSTOR+1
1154         PUSH    P,AB            ; GET AB BACK
1155         MOVE    AB,ABSTO+1(PVP)
1156 IMPUR8: PUSHJ   P,BSETG         ; SETG IT
1157         SKIPN   GPURFL
1158         JRST    .+3             ; RESTORE SP AND AB FOR PURIFY
1159         POP     P,TYPNT
1160         POP     P,SP
1161         SUB     TP,[2,,2]       ; KILL ATOM SLOTS ON TP
1162         POP     TP,C            ;POP OFF VALUE SLOTS
1163         POP     TP,A
1164         MOVEM   A,(B)           ; FILL IN SLOTS ON GLOBAL STACK
1165         MOVEM   C,1(B)
1166 IMPUR5: SKIPE   GPURFL          ; FINISH OFF DIFFERENTLY FOR PURIFY
1167         JRST    IMPUR9
1168
1169         PUSH    TP,$TFIX        ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
1170         PUSH    TP,-3(TP)
1171         PUSH    TP,$TFIX        ; OTHER KIND OF POINTER ALSO
1172         HLRE    0,-1(TP)
1173         HRRZ    A,-1(TP)
1174         SUB     A,0
1175         PUSH    TP,A
1176
1177 ; 4) UPDATE ALL POINTERS TO THIS ATOM
1178
1179         MOVE    A,[PUSHJ P,ATFIX]       ; INS TO PASS TO GCHACK
1180         MOVEI   PVP,1           ; SAY MIGHT BE NON-ATOMS
1181         PUSHJ   P,GCHACK
1182         SUB     TP,[6,,6]
1183
1184 RTNATM: POP     TP,B
1185         POP     TP,A
1186         POPJ    P,
1187
1188 IMPUR9: SUB     TP,[2,,2]
1189         POPJ    P,              ; RESTORE AND GO
1190
1191
1192
1193 END