<mdl.int>/atomhk.mid.150

   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         HLRE    A,B
 299         SUBM    B,A
 300         MOVE    A,(A)
 301         TRNE    A,LNKBIT
 302          SKIPA  A,$TLINK
 303           MOVSI A,TATOM
 304         JRST    CPOPJT
 305
 306 CHECK1: MOVE    D,-2(TP)        ; ANY LEFT?
 307         CAMN    A,1(D)          ; MATCH
 308         JRST    CHECK2
 309         JRST    NEXT
 310
 311 CHECK3: MOVE    D,-2(TP)
 312         HRRZ    D,(D)
 313         MOVEM   D,-2(TP)
 314         JUMPE   D,NOTFND
 315         JUMPE   B,CHECK6
 316         HLRZ    E,2(B)
 317 CHECK7: HLRZ    A,1(E)
 318         ANDI    A,377777        ; SIGN MIGHT BE ON IF IN PURIFY ETC.
 319         SUBI    A,2
 320         HRLS    A
 321         SUBB    E,A
 322         JRST    CHECK5
 323
 324 CHECK6: HRRZ    E,(C)
 325         JRST    CHECK7
 326
 327 \f; FUNCTION TO INSERT AN ATOM ON AN OBLIST
 328
 329 MFUNCTION INSERT,SUBR
 330
 331         ENTRY   2
 332         GETYP   A,2(AB)
 333         CAIE    A,TOBLS
 334         JRST    WTYP2
 335         MOVE    A,(AB)
 336         MOVE    B,1(AB)
 337         MOVE    C,3(AB)
 338         PUSHJ   P,IINSRT
 339         JRST    FINIS
 340
 341 CINSER: SUBM    M,(P)
 342         PUSHJ   P,IINSRT
 343         JRST    MPOPJ
 344
 345 IINSRT: PUSH    TP,A
 346         PUSH    TP,B
 347         PUSH    TP,$TOBLS
 348         PUSH    TP,C
 349         GETYP   A,A
 350         CAIN    A,TATOM
 351         JRST    INSRT0
 352
 353 ;INSERT WITH A GIVEN PNAME
 354
 355         CAIE    A,TCHRS
 356         CAIN    A,TCHSTR
 357         JRST    .+2
 358         JRST    WTYP1
 359
 360         PUSH    TP,$TFIX        ;FLAG CALL
 361         PUSH    TP,[0]
 362         MOVEI   B,-5(TP)
 363         PUSHJ   P,CSTAK         ;COPY ONTO STACK
 364         MOVE    B,-2(TP)
 365         MOVSI   A,TOBLS
 366         PUSHJ   P,ILOOK         ;LOOK IT UP (BUCKET RETURNS IN C)
 367         SETZM   -4(TP)
 368         SETZM   -5(TP)          ; KILL STRING POINTER TO KEEP FROM CONFUSING GC
 369         JUMPN   B,ALRDY         ;EXISTS, LOSE
 370         MOVE    D,-2(TP)        ; GET OBLIST BACK
 371 INSRT1: PUSH    TP,$TATOM
 372         PUSH    TP,0            ; PREV ATOM
 373         PUSH    TP,$TUVEC       ;SAVE BUCKET POINTER
 374         PUSH    TP,C
 375         PUSH    TP,$TOBLS
 376         PUSH    TP,D            ; SAVE OBLIST
 377 INSRT3: PUSHJ   P,IATOM         ; MAKE AN ATOM
 378         HLRE    A,B             ; FIND DOPE WORD
 379         SUBM    B,A
 380         ANDI    A,-1
 381         SKIPN   E,-4(TP)        ; AFTER AN ATOM?
 382          JRST   INSRT7          ; NO, FIRST IN BUCKET
 383         MOVEI   0,(E)           ; CHECK IF PURE
 384         CAIG    0,HIBOT
 385          JRST   INSRNP
 386         PUSH    TP,$TATOM       ; SAVE NEW ATOM
 387         PUSH    TP,B
 388         MOVE    B,E
 389         PUSHJ   P,IMPURIF
 390         MOVE    B,(TP)
 391         MOVE    E,-6(TP)
 392         SUB     TP,[2,,2]
 393         HLRE    A,B             ; FIND DOPE WORD
 394         SUBM    B,A
 395         ANDI    A,-1
 396
 397 INSRNP: HLRZ    0,2(E)          ; NEXT
 398         HRLM    A,2(E)          ; SPLICE
 399         HRLM    0,2(B)
 400         JRST    INSRT8
 401
 402 INSRT7: MOVE    E,-2(TP)
 403         EXCH    A,(E)
 404         HRLM    A,2(B)          ; IN CASE OLD ONE
 405
 406 INSRT8: MOVE    E,(TP)          ; GET OBLIST
 407         HRRM    E,2(B)          ; STORE OBLIST
 408         MOVE    E,(E)           ; POINT TO LIST OF ATOMS
 409         PUSHJ   P,LINKCK
 410         PUSHJ   P,ICONS
 411         MOVE    E,(TP)
 412         HRRM    B,(E)           ;INTO NEW BUCKET
 413         MOVSI   A,TATOM
 414         MOVE    B,1(B)          ;GET ATOM BACK
 415         MOVE    C,-6(TP)        ;GET FLAG
 416         SUB     TP,[8,,8]       ;POP STACK
 417         JUMPN   C,(C)
 418         SUB     TP,[4,,4]
 419         POPJ    P,
 420
 421 ;INSERT WITH GIVEN ATOM
 422 INSRT0: MOVE    A,-2(TP)        ;GOBBLE PNAME
 423         SKIPE   2(A)            ; SKIP IF NOT ON AN OBLIST
 424         JRST    ONOBL
 425         ADD     A,[3,,3]
 426         HLRE    C,A
 427         MOVNS   C
 428         PUSH    P,(A)           ;FLUSH PNAME ONTO P STACK
 429         AOBJN   A,.-1
 430         PUSH    P,C
 431         MOVE    B,(TP)          ; GET OBLIST FOR LOOKUP
 432         MOVSI   A,TOBLS
 433         PUSHJ   P,ILOOK         ;ALREADY THERE?
 434         JUMPN   B,ALRDY
 435         MOVE    D,-2(TP)
 436
 437         HLRE    A,-2(TP)        ; FIND DOPE WORD
 438         SUBM    D,A             ; TO A
 439         JUMPE   0,INSRT9        ; NO CURRENT ATOM
 440         MOVE    E,0
 441         MOVEI   0,(E)
 442         CAIGE   0,HIBOT         ; PURE?
 443          JRST   INSRPN
 444         PUSH    TP,$TATOM
 445         PUSH    TP,E
 446         PUSH    TP,$TATOM
 447         PUSH    TP,D
 448         MOVE    B,E
 449         PUSHJ   P,IMPURIF
 450         MOVE    D,(TP)
 451         MOVE    E,-2(TP)
 452         SUB     TP,[4,,4]
 453         HLRE    A,D
 454         SUBM    D,A
 455
 456
 457 INSRPN: HLRZ    0,2(E)          ; POINT TO NEXT
 458         HRLM    A,2(E)          ; CLOBBER NEW GUY IN
 459         HRLM    0,2(D)          ; FINISH SLPICE
 460         JRST    INSRT6
 461
 462 INSRT9: ANDI    A,-1
 463         EXCH    A,(C)           ; INTO BUCKET
 464         HRLM    A,2(D)
 465
 466 INSRT6: HRRZ    E,(TP)
 467         HRRZ    E,(E)
 468         MOVE    B,D
 469         PUSHJ   P,LINKCK
 470         PUSHJ   P,ICONS
 471         MOVE    C,(TP)          ;RESTORE OBLIST
 472         HRRZM   B,(C)
 473         MOVE    B,-2(TP)        ; GET BACK ATOM
 474         HRRM    C,2(B)          ; CLOBBER OBLIST IN
 475         MOVSI   A,TATOM
 476         SUB     TP,[4,,4]
 477         POP     P,C
 478         HRLI    C,(C)
 479         SUB     P,C
 480         POPJ    P,
 481
 482 LINKCK: HRRZ    C,FSAV(TB)      ;CALLER'S NAME
 483         MOVE    D,B
 484         CAIE    C,LINK
 485         SKIPA   C,$TATOM        ;LET US INSERT A LINK INSTEAD OF AN ATOM
 486         SKIPA   C,$TLINK        ;GET REAL ATOM FOR CALL TO ICONS
 487         POPJ    P,
 488         HLRE    A,D
 489         SUBM    D,A
 490         MOVEI   B,LNKBIT
 491         IORM    B,(A)
 492         POPJ    P,
 493
 494
 495 ALRDY:  ERRUUO  EQUOTE ATOM-ALREADY-THERE
 496
 497 ONOBL:  ERRUUO  EQUOTE ON-AN-OBLIST-ALREADY
 498
 499 ; INTERNAL INSERT CALL
 500
 501 INSRTX: POP     P,0             ; GET RET ADDR
 502         PUSH    TP,$TFIX
 503         PUSH    TP,0
 504         PUSH    TP,$TATOM
 505         PUSH    TP,[0]
 506         PUSH    TP,$TUVEC
 507         PUSH    TP,[0]
 508         PUSH    TP,$TOBLS
 509         PUSH    TP,B
 510         MOVSI   A,TOBLS
 511         PUSHJ   P,ILOOK
 512         JUMPN   B,INSRXT
 513         MOVEM   0,-4(TP)
 514         MOVEM   C,-2(TP)
 515         JRST    INSRT3          ; INTO INSERT CODE
 516
 517 INSRXT: PUSH    P,-4(TP)
 518         SUB     TP,[6,,6]
 519         POPJ    P,
 520         JRST    IATM1
 521 \f
 522 ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
 523
 524 MFUNCTION REMOVE,SUBR
 525
 526         ENTRY
 527
 528         JUMPGE  AB,TFA
 529         CAMGE   AB,[-5,,]
 530         JRST    TMA
 531         MOVEI   C,0
 532         CAML    AB,[-3,,]       ; SKIP IF OBLIST GIVEN
 533         JRST    .+5
 534         GETYP   0,2(AB)
 535         CAIE    0,TOBLS
 536         JRST    WTYP2
 537         MOVE    C,3(AB)
 538         MOVE    A,(AB)
 539         MOVE    B,1(AB)
 540         PUSHJ   P,IRMV
 541         JRST    FINIS
 542
 543 CIRMV:  SUBM    M,(P)
 544         PUSHJ   P,IRMV
 545         JRST    MPOPJ
 546
 547 IRMV:   PUSH    TP,A
 548         PUSH    TP,B
 549         PUSH    TP,$TOBLS
 550         PUSH    TP,C
 551 IRMV1:  GETYP   0,A             ; CHECK 1ST ARG
 552         CAIN    0,TLINK
 553         JRST    .+3
 554         CAIE    0,TATOM         ; ATOM, TREAT ACCORDINGLY
 555         JRST    RMV1
 556
 557         HRRZ    D,2(B)          ; SKIP IF ON OBLIST AND GET SAME
 558         JUMPE   D,RMVDON
 559         CAMG    D,VECBOT        ; SKIP IF REAL OBLIST
 560         HRRZ    D,(D)           ; NO, REF, GET IT
 561
 562         JUMPGE  C,GOTOBL
 563         CAIE    D,(C)           ; BETTER BE THE SAME
 564         JRST    ONOTH
 565
 566 GOTOBL: ADD     B,[3,,3]        ; POINT TO PNAME
 567         HLRE    A,B
 568         MOVNS   A
 569         PUSH    P,(B)           ; PUSH PNAME
 570         AOBJN   B,.-1
 571         PUSH    P,A
 572         HRROM   D,(TP)          ; SAVE OBLIST
 573         JRST    RMV3
 574
 575 RMV1:   JUMPGE  C,TFA
 576         CAIE    0,TCHRS
 577         CAIN    0,TCHSTR
 578         SKIPA   A,0
 579         JRST    WTYP1
 580         MOVEI   B,-3(TP)
 581         PUSHJ   P,CSTAK
 582 RMV3:   MOVE    B,(TP)
 583         MOVSI   A,TOBLS
 584         PUSHJ   P,ILOOK
 585         POP     P,D
 586         HRLI    D,(D)
 587         SUB     P,D
 588         JUMPE   B,RMVDON
 589
 590         MOVEI   A,(B)
 591         CAIGE   A,HIBOT         ; SKIP IF PURE
 592         JRST    RMV2
 593         PUSH    TP,$TATOM
 594         PUSH    TP,0
 595         PUSHJ   P,IMPURIFY
 596         MOVE    0,(TP)
 597         SUB     TP,[2,,2]
 598         MOVE    A,-3(TP)
 599         MOVE    B,-2(TP)
 600         MOVE    C,(TP)
 601         JRST    IRMV1
 602
 603 RMV2:   JUMPN   0,RMV9          ; JUMP IF FIRST NOT IN BUCKET
 604         HLRZ    0,2(B)          ; POINT TO NEXT
 605         MOVEM   0,(C)
 606         JRST    RMV8
 607
 608 RMV9:   MOVE    C,0             ; C IS PREV ATOM
 609         HLRZ    0,2(B)          ; NEXT
 610         HRLM    0,2(C)
 611
 612 RMV8:   SETZM   2(B)            ; CLOBBER OBLIST SLOT
 613         MOVE    C,(TP)          ; GET OBLIST FOR SPLICE OUT
 614         MOVEI   0,-1
 615         HRRZ    E,(C)
 616
 617 RMV7:   JUMPE   E,RMVDON
 618         CAMN    B,1(E)          ; SEARCH OBLIST
 619         JRST    RMV6
 620         MOVE    C,E
 621         HRRZ    E,(C)
 622         SOJG    0,RMV7
 623
 624 RMVDON: SUB     TP,[4,,4]
 625         MOVSI   A,TATOM
 626         POPJ    P,
 627
 628 RMV6:   HRRZ    E,(E)
 629         HRRM    E,(C)           ; SMASH IN
 630         JRST    RMVDON
 631
 632 \f
 633 ;INTERNAL CALL FROM THE READER
 634
 635 RLOOKU: PUSH    TP,$TFIX        ;PUSH A FLAG
 636         POP     P,C             ;POP OFF RET ADR
 637         PUSH    TP,C            ;AND USE AS A FLAG FOR INTERNAL
 638         MOVE    C,(P)           ; CHANGE CHAR COUNT TO WORD
 639         ADDI    C,4
 640         IDIVI   C,5
 641         MOVEM   C,(P)
 642         GETYP   D,A
 643
 644         CAIN    D,TOBLS         ;IS IT ONE OBLIST?
 645         JRST    .+3
 646         CAIE    D,TLIST         ;IS IT A LIST
 647         JRST    BADOBL
 648
 649         JUMPE   B,BADLST
 650         PUSH    TP,$TUVEC       ; SLOT FOR REMEBERIG
 651         PUSH    TP,[0]
 652         PUSH    TP,$TOBLS
 653         PUSH    TP,[0]
 654         PUSH    TP,A
 655         PUSH    TP,B
 656         CAIE    D,TLIST
 657         JRST    RLOOK1
 658
 659         PUSH    TP,$TLIST
 660         PUSH    TP,B
 661 RLOOK2: GETYP   A,(B)           ;CHECK THIS IS AN OBLIST
 662         CAIE    A,TOBLS
 663         JRST    DEFALT
 664
 665         SKIPE   -4(TP)          ; SKIP IF DEFAULT NOT STORED
 666         JRST    RLOOK4
 667         MOVE    D,1(B)          ; OBLIST
 668         MOVEM   D,-4(TP)
 669 RLOOK4: INTGO
 670         HRRZ    B,@(TP)         ;CDR THE LIST
 671         HRRZM   B,(TP)
 672         JUMPN   B,RLOOK2
 673         SUB     TP,[2,,2]
 674         JRST    .+3
 675
 676 RLOOK1: MOVE    B,(TP)
 677         MOVEM   B,-2(TP)
 678         MOVE    A,-1(TP)
 679         MOVE    B,(TP)
 680         PUSHJ   P,ILOOK
 681         JUMPN   B,RLOOK3
 682         SKIPN   D,-2(TP)        ; RESTORE FOR INSERT
 683         JRST    BADDEF          ; NO DEFAULT, USER LOST ON SPECIFICATION
 684         SUB     TP,[6,,6]       ; FLUSH CRAP
 685         SKIPN   NOATMS
 686          JRST   INSRT1
 687           JRST  INSRT1
 688
 689 DEFFLG==1       ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
 690                 ; SPECIFIED
 691 DEFALT: MOVE    0,1(B)
 692         CAIN    A,TATOM         ;SPECIAL DEFAULT INDICATING ATOM ?
 693         CAME    0,MQUOTE DEFAULT
 694         JRST    BADDEF          ;NO, LOSE
 695         MOVEI   A,DEFFLG
 696         XORB    A,-11(TP)       ;SET AND TEST FLAG
 697         TRNN    A,DEFFLG        ; HAVE WE BEEN HERE BEFORE ?
 698         JRST    BADDEF          ; YES, LOSE
 699         SETZM   -6(TP)          ;ZERO OUT PREVIOUS DEFAULT
 700         SETZM   -4(TP)
 701         JRST    RLOOK4          ;CONTINUE
 702
 703
 704 INSRT2: JRST    .+2             ;
 705 RLOOK3: SUB     TP,[6,,6]       ;POP OFF LOSSAGE
 706         PUSHJ   P,ILINK         ;IF THIS IS A LINK FOLLOW IT
 707         PUSH    P,(TP)          ;GET BACK RET ADR
 708         SUB     TP,[2,,2]       ;POP TP
 709         JRST    IATM1           ;AND RETURN
 710
 711
 712 BADOBL: ERRUUO  EQUOTE BAD-OBLIST-OR-LIST-THEREOF
 713
 714 BADDEF: ERRUUO  EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
 715
 716 ONOTH:  ERRUUO  EQUOTE ATOM-ON-DIFFERENT-OBLIST
 717 \f;SUBROUTINE TO MAKE AN ATOM
 718
 719 IMFUNCTION ATOM,SUBR
 720
 721         ENTRY   1
 722
 723         MOVE    A,(AB)
 724         MOVE    B,1(AB)
 725         PUSHJ   P,IATOMI
 726         JRST    FINIS
 727
 728 CATOM:  SUBM    M,(P)
 729         PUSHJ   P,IATOMI
 730         JRST    MPOPJ
 731
 732 IATOMI: GETYP   0,A             ;CHECK ARG TYPE
 733         CAIE    0,TCHRS
 734         CAIN    0,TCHSTR
 735         JRST    .+2             ;JUMP IF WINNERS
 736         JRST    WTYP1
 737
 738         PUSH    TP,A
 739         PUSH    TP,B
 740         MOVEI   B,-1(TP)
 741         MOVE    A,0
 742         PUSHJ   P,CSTAK         ;COPY ONTO STACK
 743         PUSHJ   P,IATOM         ;NOW MAKE THE ATOM
 744         SUB     TP,[2,,2]
 745         POPJ    P,
 746
 747 ;INTERNAL ATOM MAKER
 748
 749 IATOM:  MOVE    A,-1(P)         ;GET WORDS IN PNAME
 750         ADDI    A,3             ;FOR VALUE CELL
 751         PUSHJ   P,IBLOCK        ; GET BLOCK
 752         MOVSI   C,<(GENERAL)>+SATOM     ;FOR TYPE FIELD
 753         MOVE    D,-1(P)         ;RE-GOBBLE LENGTH
 754         ADDI    D,3(B)          ;POINT TO DOPE WORD
 755         MOVEM   C,(D)
 756         SKIPG   -1(P)           ;EMPTY PNAME ?
 757         JRST    IATM0           ;YES, NO CHARACTERS TO MOVE
 758         MOVE    E,B             ;COPY ATOM POINTER
 759         ADD     E,[3,,3]        ;POINT TO PNAME AREA
 760         MOVEI   C,-1(P)
 761         SUB     C,-1(P)         ;POINT TO STRING ON STACK
 762         MOVE    D,(C)           ;GET SOME CHARS
 763         MOVEM   D,(E)           ;AND COPY THEM
 764         ADDI    C,1
 765         AOBJN   E,.-3
 766 IATM0:  MOVSI   A,TATOM ;TYPE TO ATOM
 767 IATM1:  POP     P,D             ;RETURN ADR
 768         POP     P,C
 769         HRLI    C,(C)
 770         SUB     P,C
 771         JRST    (D)             ;RETURN
 772
 773 \f;SUBROUTINE TO GET AN ATOM'S PNAME
 774
 775 MFUNCTION PNAME,SUBR
 776
 777         ENTRY 1
 778
 779         GETYP   A,(AB)
 780         CAIE    A,TATOM         ;CHECK TYPE IS ATOM
 781         JRST    WTYP1
 782         MOVE    A,1(AB)
 783         PUSHJ   P,IPNAME
 784         JRST    FINIS
 785
 786 CIPNAM: SUBM    M,(P)
 787         PUSHJ   P,IPNAME
 788         JRST    MPOPJ
 789
 790 IPNAME: ADD     A,[3,,3]
 791         HLRE    B,A
 792         MOVM    B,B
 793         PUSH    P,(A)           ;FLUSH PNAME ONTO P
 794         AOBJN   A,.-1
 795         MOVE    0,(P)           ; LAST WORD
 796         PUSHJ   P,PNMCNT
 797         PUSH    P,B
 798         PUSHJ   P,CHMAK         ;MAKE A STRING
 799         POPJ    P,
 800
 801 PNMCNT: IMULI   B,5             ; CHARS TO B
 802         MOVE    A,0
 803         SUBI    A,1             ; FIND LAST 1
 804         ANDCM   0,A             ; 0 HAS 1ST 1
 805         JFFO    0,.+1
 806         HRREI   0,-34.(A)       ; FIND HOW MUCH TO ADD
 807         IDIVI   0,7
 808         ADD     B,0
 809         POPJ    P,
 810
 811 MFUNCTION SPNAME,SUBR
 812
 813         ENTRY   1
 814
 815         GETYP   0,(AB)
 816         CAIE    0,TATOM
 817         JRST    WTYP1
 818
 819         MOVE    B,1(AB)
 820         PUSHJ   P,CSPNAM
 821         JRST    FINIS
 822
 823 CSPNAM: ADD     B,[3,,3]
 824         MOVEI   D,(B)
 825         HLRE    A,B
 826         SUBM    B,A
 827         MOVE    0,-1(A)
 828         HLRES   B
 829         MOVMS   B
 830         PUSHJ   P,PNMCNT
 831         MOVSI   A,TCHSTR
 832         HRRI    A,(B)
 833         MOVSI   B,010700
 834         HRRI    B,-1(D)
 835         POPJ    P,
 836
 837 \f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
 838
 839 IMFUNCTION BLK,SUBR,BLOCK
 840
 841         ENTRY   1
 842
 843         GETYP   A,(AB)  ;CHECK TYPE OF ARG
 844         CAIE    A,TOBLS ;IS IT AN OBLIST
 845         CAIN    A,TLIST ;OR A LIAT
 846         JRST    .+2
 847         JRST    WTYP1
 848         MOVSI   A,TATOM ;LOOK UP OBLIST
 849         MOVE    B,IMQUOTE OBLIST
 850         PUSHJ   P,IDVAL ;GET VALUE
 851         PUSH    TP,A
 852         PUSH    TP,B
 853         MOVE    PVP,PVSTOR+1
 854         PUSH    TP,.BLOCK(PVP)  ;HACK THE LIST
 855         PUSH    TP,.BLOCK+1(PVP)
 856         MCALL   2,CONS  ;CONS THE LIST
 857         MOVE    PVP,PVSTOR+1
 858         MOVEM   A,.BLOCK(PVP)   ;STORE IT BACK
 859         MOVEM   B,.BLOCK+1(PVP)
 860         PUSH    TP,$TATOM
 861         PUSH    TP,IMQUOTE OBLIST
 862         PUSH    TP,(AB)
 863         PUSH    TP,1(AB)
 864         MCALL   2,SET   ;SET OBLIST TO ARG
 865         JRST    FINIS
 866
 867 MFUNCTION ENDBLOCK,SUBR
 868
 869         ENTRY   0
 870
 871         MOVE    PVP,PVSTOR+1
 872         SKIPN   B,.BLOCK+1(PVP) ;IS THE LIST NIL?
 873         JRST    BLKERR  ;YES, LOSE
 874         HRRZ    C,(B)   ;CDR THE LIST
 875         HRRZM   C,.BLOCK+1(PVP)
 876         PUSH    TP,$TATOM       ;NOW RESET OBLIST
 877         PUSH    TP,IMQUOTE OBLIST
 878         HLLZ    A,(B)   ;PUSH THE TYPE OF THE CAR
 879         PUSH    TP,A
 880         PUSH    TP,1(B) ;AND VALUE OF CAR
 881         MCALL   2,SET
 882         JRST    FINIS
 883
 884 BLKERR: ERRUUO  EQUOTE UNMATCHED
 885
 886 BADLST: ERRUUO  EQUOTE NIL-LIST-OF-OBLISTS
 887 \f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
 888
 889 CHMAK:  MOVE    A,-1(P)
 890         ADDI    A,4
 891         IDIVI   A,5
 892         PUSHJ   P,IBLOCK
 893         MOVEI   C,-1(P)         ;FIND START OF CHARS
 894         HLRE    E,B             ; - LENGTH
 895         ADD     C,E             ;C POINTS TO START
 896         MOVE    D,B             ;COPY VECTOR RESULT
 897         JUMPGE  D,NULLST        ;JUMP IF EMPTY
 898         MOVE    A,(C)           ;GET ONE
 899         MOVEM   A,(D)
 900         ADDI    C,1             ;BUMP POINTER
 901         AOBJN   D,.-3           ;COPY
 902 NULLST: MOVSI   C,TCHRS+.VECT.          ;GET TYPE
 903         MOVEM   C,(D)           ;CLOBBER IT IN
 904         MOVE    A,-1(P)         ; # WORDS
 905         HRLI    A,TCHSTR
 906         HRLI    B,010700
 907         MOVMM   E,-1(P)         ; SO IATM1 WORKS
 908         SOJA    B,IATM1         ;RETURN
 909
 910 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.
 911 ;   TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
 912 ; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
 913
 914 NXTDCL: GETYP   B,(A)           ;CHECK TYPE
 915         CAIE    B,TDEFER                ;LOSE IF NOT DEFERRED
 916         POPJ    P,
 917
 918         MOVE    B,1(A)          ;GET REAL BYTE POINTER
 919 CHRWRD: PUSH    P,C
 920         GETYP   C,(B)           ;CHECK IT IS CHSTR
 921         CAIE    C,TCHSTR
 922         JRST    CPOPJC          ;NO, QUIT
 923         PUSH    P,D
 924         PUSH    P,E
 925         PUSH    P,0
 926         MOVEI   E,0             ;INITIALIZE DESTINATION
 927         HRRZ    C,(B)           ; GET CHAR COUNT
 928         JUMPE   C,GOTDCL        ; NULL, FINISHED
 929         MOVE    B,1(B)          ;GET BYTE POINTER
 930         MOVE    D,[440700,,E]   ;BYTE POINT TO E
 931 CHLOOP: ILDB    0,B             ; GET A CHR
 932         IDPB    0,D             ;CLOBBER AWAY
 933         SOJE    C,GOTDCL        ; JUMP IF DONE
 934         TLNE    D,760000        ; SKIP IF WORD FULL
 935         JRST    CHLOOP          ; MORE THAN 5 CHARS
 936         TRO     E,1             ; TURN ON FLAG
 937
 938 GOTDCL: MOVE    B,E             ;RESULT TO B
 939         AOS     -4(P)           ;SKIP RETURN
 940 CPOPJ0: POP     P,0
 941         POP     P,E
 942         POP     P,D
 943 CPOPJC: POP     P,C
 944         POPJ    P,
 945
 946 \f;ROUTINES TO DEFINE AND HANDLE LINKS
 947
 948 MFUNCTION LINK,SUBR
 949         ENTRY
 950         CAML    AB,[-6,,0]      ;NO MORE THAN 3 ARGS
 951         CAML    AB,[-2,,0]      ;NO LESS THAN 2 ARGS
 952         JRST    WNA
 953         CAML    AB,[-4,,0]      ;ONLY TWO ARGS SUPPLIED ?
 954         JRST    GETOB           ;YES, GET OBLIST FROM CURRENT PATH
 955         MOVE    A,2(AB)
 956         MOVE    B,3(AB)
 957         MOVE    C,5(AB)
 958         JRST    LINKIN
 959 GETOB:  MOVSI   A,TATOM
 960         MOVE    B,IMQUOTE OBLIST
 961         PUSHJ   P,IDVAL
 962         CAMN    A,$TOBLS
 963         JRST    LINKP
 964         CAME    A,$TLIST
 965         JRST    BADOBL
 966         JUMPE   B,BADLST
 967         GETYPF  A,(B)
 968         MOVE    B,(B)+1
 969 LINKP:  MOVE    C,B
 970         MOVE    A,2(AB)
 971         MOVE    B,3(AB)
 972 LINKIN: PUSHJ   P,IINSRT
 973         CAMN    A,$TFALSE       ;LINK NAME ALREADY USED ?
 974         JRST    ALRDY           ;YES, LOSE
 975         MOVE    C,B
 976         MOVE    A,(AB)
 977         MOVE    B,1(AB)
 978         PUSHJ   P,CSETG
 979         JRST    FINIS
 980
 981
 982 ILINK:  HLRE    A,B
 983         SUBM    B,A             ;FOUND A LINK ?
 984         MOVE    A,(A)
 985         TRNE    A,LNKBIT
 986          JRST   .+3
 987         MOVSI   A,TATOM
 988         POPJ    P,              ;NO, FINISHED
 989         MOVSI   A,TATOM
 990         PUSHJ   P,IGVAL         ;GET THE LINK'S DESTINATION
 991         CAME    A,$TUNBOUND     ;WELL FORMED LINK ?
 992         POPJ    P,              ;YES
 993         ERRUUO  EQUOTE BAD-LINK
 994
 995 \f
 996 ; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
 997
 998 IMPURIFY:
 999         PUSH    TP,$TATOM
1000         PUSH    TP,B
1001         MOVE    C,B
1002         MOVEI   0,(C)
1003         CAIGE   0,HIBOT
1004         JRST    RTNATM          ; NOT PURE, RETURN
1005         JRST    IMPURX
1006
1007 ; ROUTINE PASSED TO GCHACK
1008
1009 ATFIX:  CAME    D,(TP)
1010          CAMN   D,-2(TP)
1011           JRST  .+2
1012         POPJ    P,
1013
1014         ASH     C,1
1015         ADD     C,TYPVEC+1      ; COMPUTE SAT
1016         HRRZ    C,(C)
1017         ANDI    C,SATMSK
1018         CAIE    C,SATOM
1019 CPOPJ:  POPJ    P,
1020
1021         SUB     D,-2(TP)
1022         ADD     D,-4(TP)
1023         SKIPE   B
1024         MOVEM   D,1(B)
1025         POPJ    P,
1026
1027
1028 ; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
1029 ; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
1030
1031 BYTDOP: PUSH    P,B             ; SAVE SOME ACS
1032         PUSH    P,D
1033         PUSH    P,E
1034         MOVE    B,1(C)          ; GET BYTE POINTER
1035         LDB     D,[360600,,B]   ; POSITION TO D
1036         LDB     E,[300600,,B]   ; AND BYTE SIZE
1037         MOVEI   A,(E)           ; A COPY IN A
1038         IDIVI   D,(E)           ; D=> # OF BYTES IN WORD 1
1039         HRRZ    E,(C)           ; GET LENGTH
1040         SUBM    E,D             ; # OF BYTES IN OTHER WORDS
1041         JUMPL   D,BYTDO1        ; NEAR DOPE WORD
1042         MOVEI   B,36.           ; COMPUTE BYTES PER WORD
1043         IDIVM   B,A
1044         ADDI    D,-1(A)         ; NOW COMPUTE WORDS
1045         IDIVI   D,(A)           ; D/ # NO. OF WORDS PAST 1ST
1046         ADD     D,1(C)          ; D POINTS TO DOPE WORD
1047         MOVEI   A,2(D)
1048
1049 BYTDO2: POP     P,E
1050         POP     P,D
1051         POP     P,B
1052         POPJ    P,
1053 BYTDO1: MOVEI   A,2(B)
1054         JRST    BYTDO2
1055
1056 ; 1) IMPURIFY ITS OBLIST LIST
1057
1058 IMPURX: HRRZ    B,2(C)          ; PICKUP OBLIST IF IT EXISTS
1059         JUMPE   B,IMPUR0        ; NOT ON ONE, IGNORE THIS CODE
1060
1061         HRRO    E,(B)
1062         PUSH    TP,$TOBLS       ; SAVE BUCKET
1063         PUSH    TP,E
1064
1065         MOVE    B,(E)           ; GET NEXT ONE
1066 IMPUR4: MOVEI   0,(B)
1067         MOVE    D,1(B)
1068         CAME    D,-2(TP)
1069         JRST    .+3
1070         SKIPE   GPURFL          ; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
1071                                 ;   ATOM
1072         HRRM    D,1(B)
1073         CAIGE   0,HIBOT         ; SKIP IF PURE
1074         JRST    IMPUR3          ; FOUND IMPURE NESS, SKIP IT
1075         HLLZ    C,(B)           ; SET UP ICONS CALL
1076         HRRZ    E,(B)
1077 IMPR1:  PUSHJ   P,ICONS         ; CONS IT UP
1078 IMPR2:  HRRZ    E,(TP)          ; RETRV PREV
1079         HRRM    B,(E)           ; AND CLOBBER
1080 IMPUR3: MOVE    D,1(B)
1081         CAMN    D,-2(TP)        ; HAVE GOTTEN TO OUR SLOT?
1082         JRST    IMPPR3
1083         MOVSI   0,TLIST
1084         MOVEM   0,-1(TP)        ; FIX TYPE
1085         HRRZM   B,(TP)          ; STORE GOODIE
1086         HRRZ    B,(B)           ; CDR IT
1087         JUMPN   B,IMPUR4        ; LOOP
1088 IMPPR3: SUB     TP,[2,,2]       ; FLUSH TP CRUFT
1089
1090 ; 1.5)  IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
1091
1092 IMPUR0: MOVE    C,(TP)          ; GET ATOM
1093
1094         HRRZ    B,2(C)
1095         MOVE    B,(B)
1096         ADD     C,[3,,3]        ; POINT TO PNAME
1097         HLRE    A,C             ; GET LNTH IN WORDS OF PNAME
1098         MOVNS   A
1099 ;       PUSH    P,[SETZ IMPUR2] ; FAKE OUT ILOOKC
1100         XMOVEI  0,IMPUR2
1101         PUSH    P,0
1102         PUSH    P,(C)           ; PUSH UP THE PNAME
1103         AOBJN   C,.-1
1104         PUSH    P,A             ; NOW THE COUNT
1105         MOVSI   A,TOBLS
1106         JRST    ILOOKC          ; GO FIND BUCKET
1107
1108 IMPUR2: JUMPE   B,IMPUR1
1109         JUMPE   0,IMPUR1                ; YUP, DONE
1110         HRRZ    C,0
1111         CAIG    C,HIBOT         ; SKIP IF PREV IS PURE
1112         JRST    IMPUR1
1113
1114         MOVE    B,0
1115         PUSH    P,GPURFL        ; PRERTEND OUT OF PURIFY
1116         HLRE    C,B
1117         SUBM    B,C
1118         HRRZ    C,(C)           ; ARE WE ON PURIFY LIST
1119         CAIG    C,HIBOT         ; IF SO, WE ARE STILL PURIFY
1120         SETZM   GPURFL
1121         PUSHJ   P,IMPURIF       ; RECURSE
1122         POP     P,GPURFL
1123         MOVE    B,(TP)          ; AND RETURN ORIGINAL
1124
1125 ; 2) GENERATE A DUPLICATE ATOM
1126
1127 IMPUR1: SKIPE   GPURFL          ; SEE IF IN PURIFY
1128         JRST    IMPUR7
1129         HLRE    A,(TP)          ; GET LNTH OF ATOM
1130         MOVNS   A
1131         PUSH    P,A
1132         PUSHJ   P,IBLOCK        ; GET NEW BLOCK FOR ATOM
1133         PUSH    TP,$TATOM
1134         PUSH    TP,B
1135         HRL     B,-2(TP)                ; SETUP BLT
1136         POP     P,A
1137         ADDI    A,(B)           ; END OF BLT
1138         BLT     B,(A)           ; CLOBBER NEW ATOM
1139         MOVSI   B,.VECT.        ; TURN ON BIT FOR GCHACK
1140         IORM    B,(A)
1141
1142 ; 3) NOW COPY GLOBAL VALUE
1143
1144 IMPUR7: MOVE    B,(TP)          ; ATOM BACK
1145         GETYP   0,(B)
1146         SKIPE   A,1(B)          ; NON-ZER POINTER?
1147         CAIN    0,TUNBOU        ; BOUND?
1148         JRST    IMPUR5          ; NO, DONT COPY GLOB VAL
1149         PUSH    TP,(A)
1150         PUSH    TP,1(A)
1151         PUSH    TP,$TATOM
1152         PUSH    TP,B
1153         SETZM   (B)
1154         SETZM   1(B)
1155         SKIPN   GPURFL          ; HERE IS SOME CODE NEEDED FOR PURIFY
1156         JRST    IMPUR8
1157         PUSH    P,LPVP
1158         MOVE    PVP,PVSTOR+1
1159         PUSH    P,AB            ; GET AB BACK
1160         MOVE    AB,ABSTO+1(PVP)
1161 IMPUR8: PUSHJ   P,BSETG         ; SETG IT
1162         SKIPN   GPURFL
1163         JRST    .+3             ; RESTORE SP AND AB FOR PURIFY
1164         POP     P,TYPNT
1165         POP     P,SP
1166         SUB     TP,[2,,2]       ; KILL ATOM SLOTS ON TP
1167         POP     TP,C            ;POP OFF VALUE SLOTS
1168         POP     TP,A
1169         MOVEM   A,(B)           ; FILL IN SLOTS ON GLOBAL STACK
1170         MOVEM   C,1(B)
1171 IMPUR5: SKIPE   GPURFL          ; FINISH OFF DIFFERENTLY FOR PURIFY
1172         JRST    IMPUR9
1173
1174         PUSH    TP,$TFIX        ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
1175         PUSH    TP,-3(TP)
1176         PUSH    TP,$TFIX        ; OTHER KIND OF POINTER ALSO
1177         HLRE    0,-1(TP)
1178         HRRZ    A,-1(TP)
1179         SUB     A,0
1180         PUSH    TP,A
1181
1182 ; 4) UPDATE ALL POINTERS TO THIS ATOM
1183
1184         MOVE    A,[PUSHJ P,ATFIX]       ; INS TO PASS TO GCHACK
1185         MOVEI   PVP,1           ; SAY MIGHT BE NON-ATOMS
1186         PUSHJ   P,GCHACK
1187         SUB     TP,[6,,6]
1188
1189 RTNATM: POP     TP,B
1190         POP     TP,A
1191         POPJ    P,
1192
1193 IMPUR9: SUB     TP,[2,,2]
1194         POPJ    P,              ; RESTORE AND GO
1195
1196
1197
1198 END