<mdl.int>/atomhk.151

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