<mdl.int>/atomhk.mid.144

   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         JRST    INSRT1
 681
 682 DEFFLG==1       ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
 683                 ; SPECIFIED
 684 DEFALT: MOVE    0,1(B)
 685         CAIN    A,TATOM         ;SPECIAL DEFAULT INDICATING ATOM ?
 686         CAME    0,MQUOTE DEFAULT
 687         JRST    BADDEF          ;NO, LOSE
 688         MOVEI   A,DEFFLG
 689         XORB    A,-11(TP)       ;SET AND TEST FLAG
 690         TRNN    A,DEFFLG        ; HAVE WE BEEN HERE BEFORE ?
 691         JRST    BADDEF          ; YES, LOSE
 692         SETZM   -6(TP)          ;ZERO OUT PREVIOUS DEFAULT
 693         SETZM   -4(TP)
 694         JRST    RLOOK4          ;CONTINUE
 695
 696
 697 INSRT2: JRST    .+2             ;
 698 RLOOK3: SUB     TP,[6,,6]       ;POP OFF LOSSAGE
 699         PUSHJ   P,ILINK         ;IF THIS IS A LINK FOLLOW IT
 700         PUSH    P,(TP)          ;GET BACK RET ADR
 701         SUB     TP,[2,,2]       ;POP TP
 702         JRST    IATM1           ;AND RETURN
 703
 704
 705 BADOBL: ERRUUO  EQUOTE BAD-OBLIST-OR-LIST-THEREOF
 706
 707 BADDEF: ERRUUO  EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
 708
 709 ONOTH:  ERRUUO  EQUOTE ATOM-ON-DIFFERENT-OBLIST
 710 \f;SUBROUTINE TO MAKE AN ATOM
 711
 712 IMFUNCTION ATOM,SUBR
 713
 714         ENTRY   1
 715
 716         MOVE    A,(AB)
 717         MOVE    B,1(AB)
 718         PUSHJ   P,IATOMI
 719         JRST    FINIS
 720
 721 CATOM:  SUBM    M,(P)
 722         PUSHJ   P,IATOMI
 723         JRST    MPOPJ
 724
 725 IATOMI: GETYP   0,A             ;CHECK ARG TYPE
 726         CAIE    0,TCHRS
 727         CAIN    0,TCHSTR
 728         JRST    .+2             ;JUMP IF WINNERS
 729         JRST    WTYP1
 730
 731         PUSH    TP,A
 732         PUSH    TP,B
 733         MOVEI   B,-1(TP)
 734         MOVE    A,0
 735         PUSHJ   P,CSTAK         ;COPY ONTO STACK
 736         PUSHJ   P,IATOM         ;NOW MAKE THE ATOM
 737         SUB     TP,[2,,2]
 738         POPJ    P,
 739
 740 ;INTERNAL ATOM MAKER
 741
 742 IATOM:  MOVE    A,-1(P)         ;GET WORDS IN PNAME
 743         ADDI    A,3             ;FOR VALUE CELL
 744         PUSHJ   P,IBLOCK        ; GET BLOCK
 745         MOVSI   C,<(GENERAL)>+SATOM     ;FOR TYPE FIELD
 746         MOVE    D,-1(P)         ;RE-GOBBLE LENGTH
 747         ADDI    D,3(B)          ;POINT TO DOPE WORD
 748         MOVEM   C,(D)
 749         SKIPG   -1(P)           ;EMPTY PNAME ?
 750         JRST    IATM0           ;YES, NO CHARACTERS TO MOVE
 751         MOVE    E,B             ;COPY ATOM POINTER
 752         ADD     E,[3,,3]        ;POINT TO PNAME AREA
 753         MOVEI   C,-1(P)
 754         SUB     C,-1(P)         ;POINT TO STRING ON STACK
 755         MOVE    D,(C)           ;GET SOME CHARS
 756         MOVEM   D,(E)           ;AND COPY THEM
 757         ADDI    C,1
 758         AOBJN   E,.-3
 759 IATM0:  MOVSI   A,TATOM ;TYPE TO ATOM
 760 IATM1:  POP     P,D             ;RETURN ADR
 761         POP     P,C
 762         HRLI    C,(C)
 763         SUB     P,C
 764         JRST    (D)             ;RETURN
 765
 766 \f;SUBROUTINE TO GET AN ATOM'S PNAME
 767
 768 MFUNCTION PNAME,SUBR
 769
 770         ENTRY 1
 771
 772         GETYP   A,(AB)
 773         CAIE    A,TATOM         ;CHECK TYPE IS ATOM
 774         JRST    WTYP1
 775         MOVE    A,1(AB)
 776         PUSHJ   P,IPNAME
 777         JRST    FINIS
 778
 779 CIPNAM: SUBM    M,(P)
 780         PUSHJ   P,IPNAME
 781         JRST    MPOPJ
 782
 783 IPNAME: ADD     A,[3,,3]
 784         HLRE    B,A
 785         MOVM    B,B
 786         PUSH    P,(A)           ;FLUSH PNAME ONTO P
 787         AOBJN   A,.-1
 788         MOVE    0,(P)           ; LAST WORD
 789         PUSHJ   P,PNMCNT
 790         PUSH    P,B
 791         PUSHJ   P,CHMAK         ;MAKE A STRING
 792         POPJ    P,
 793
 794 PNMCNT: IMULI   B,5             ; CHARS TO B
 795         MOVE    A,0
 796         SUBI    A,1             ; FIND LAST 1
 797         ANDCM   0,A             ; 0 HAS 1ST 1
 798         JFFO    0,.+1
 799         HRREI   0,-34.(A)       ; FIND HOW MUCH TO ADD
 800         IDIVI   0,7
 801         ADD     B,0
 802         POPJ    P,
 803
 804 MFUNCTION SPNAME,SUBR
 805
 806         ENTRY   1
 807
 808         GETYP   0,(AB)
 809         CAIE    0,TATOM
 810         JRST    WTYP1
 811
 812         MOVE    B,1(AB)
 813         PUSHJ   P,CSPNAM
 814         JRST    FINIS
 815
 816 CSPNAM: ADD     B,[3,,3]
 817         MOVEI   D,(B)
 818         HLRE    A,B
 819         SUBM    B,A
 820         MOVE    0,-1(A)
 821         HLRES   B
 822         MOVMS   B
 823         PUSHJ   P,PNMCNT
 824         MOVSI   A,TCHSTR
 825         HRRI    A,(B)
 826         MOVSI   B,010700
 827         HRRI    B,-1(D)
 828         POPJ    P,
 829
 830 \f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
 831
 832 IMFUNCTION BLK,SUBR,BLOCK
 833
 834         ENTRY   1
 835
 836         GETYP   A,(AB)  ;CHECK TYPE OF ARG
 837         CAIE    A,TOBLS ;IS IT AN OBLIST
 838         CAIN    A,TLIST ;OR A LIAT
 839         JRST    .+2
 840         JRST    WTYP1
 841         MOVSI   A,TATOM ;LOOK UP OBLIST
 842         MOVE    B,IMQUOTE OBLIST
 843         PUSHJ   P,IDVAL ;GET VALUE
 844         PUSH    TP,A
 845         PUSH    TP,B
 846         MOVE    PVP,PVSTOR+1
 847         PUSH    TP,.BLOCK(PVP)  ;HACK THE LIST
 848         PUSH    TP,.BLOCK+1(PVP)
 849         MCALL   2,CONS  ;CONS THE LIST
 850         MOVE    PVP,PVSTOR+1
 851         MOVEM   A,.BLOCK(PVP)   ;STORE IT BACK
 852         MOVEM   B,.BLOCK+1(PVP)
 853         PUSH    TP,$TATOM
 854         PUSH    TP,IMQUOTE OBLIST
 855         PUSH    TP,(AB)
 856         PUSH    TP,1(AB)
 857         MCALL   2,SET   ;SET OBLIST TO ARG
 858         JRST    FINIS
 859
 860 MFUNCTION ENDBLOCK,SUBR
 861
 862         ENTRY   0
 863
 864         MOVE    PVP,PVSTOR+1
 865         SKIPN   B,.BLOCK+1(PVP) ;IS THE LIST NIL?
 866         JRST    BLKERR  ;YES, LOSE
 867         HRRZ    C,(B)   ;CDR THE LIST
 868         HRRZM   C,.BLOCK+1(PVP)
 869         PUSH    TP,$TATOM       ;NOW RESET OBLIST
 870         PUSH    TP,IMQUOTE OBLIST
 871         HLLZ    A,(B)   ;PUSH THE TYPE OF THE CAR
 872         PUSH    TP,A
 873         PUSH    TP,1(B) ;AND VALUE OF CAR
 874         MCALL   2,SET
 875         JRST    FINIS
 876
 877 BLKERR: ERRUUO  EQUOTE UNMATCHED
 878
 879 BADLST: ERRUUO  EQUOTE NIL-LIST-OF-OBLISTS
 880 \f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
 881
 882 CHMAK:  MOVE    A,-1(P)
 883         ADDI    A,4
 884         IDIVI   A,5
 885         PUSHJ   P,IBLOCK
 886         MOVEI   C,-1(P)         ;FIND START OF CHARS
 887         HLRE    E,B             ; - LENGTH
 888         ADD     C,E             ;C POINTS TO START
 889         MOVE    D,B             ;COPY VECTOR RESULT
 890         JUMPGE  D,NULLST        ;JUMP IF EMPTY
 891         MOVE    A,(C)           ;GET ONE
 892         MOVEM   A,(D)
 893         ADDI    C,1             ;BUMP POINTER
 894         AOBJN   D,.-3           ;COPY
 895 NULLST: MOVSI   C,TCHRS+.VECT.          ;GET TYPE
 896         MOVEM   C,(D)           ;CLOBBER IT IN
 897         MOVE    A,-1(P)         ; # WORDS
 898         HRLI    A,TCHSTR
 899         HRLI    B,010700
 900         MOVMM   E,-1(P)         ; SO IATM1 WORKS
 901         SOJA    B,IATM1         ;RETURN
 902
 903 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.
 904 ;   TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
 905 ; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
 906
 907 NXTDCL: GETYP   B,(A)           ;CHECK TYPE
 908         CAIE    B,TDEFER                ;LOSE IF NOT DEFERRED
 909         POPJ    P,
 910
 911         MOVE    B,1(A)          ;GET REAL BYTE POINTER
 912 CHRWRD: PUSH    P,C
 913         GETYP   C,(B)           ;CHECK IT IS CHSTR
 914         CAIE    C,TCHSTR
 915         JRST    CPOPJC          ;NO, QUIT
 916         PUSH    P,D
 917         PUSH    P,E
 918         PUSH    P,0
 919         MOVEI   E,0             ;INITIALIZE DESTINATION
 920         HRRZ    C,(B)           ; GET CHAR COUNT
 921         JUMPE   C,GOTDCL        ; NULL, FINISHED
 922         MOVE    B,1(B)          ;GET BYTE POINTER
 923         MOVE    D,[440700,,E]   ;BYTE POINT TO E
 924 CHLOOP: ILDB    0,B             ; GET A CHR
 925         IDPB    0,D             ;CLOBBER AWAY
 926         SOJE    C,GOTDCL        ; JUMP IF DONE
 927         TLNE    D,760000        ; SKIP IF WORD FULL
 928         JRST    CHLOOP          ; MORE THAN 5 CHARS
 929         TRO     E,1             ; TURN ON FLAG
 930
 931 GOTDCL: MOVE    B,E             ;RESULT TO B
 932         AOS     -4(P)           ;SKIP RETURN
 933 CPOPJ0: POP     P,0
 934         POP     P,E
 935         POP     P,D
 936 CPOPJC: POP     P,C
 937         POPJ    P,
 938
 939 \f;ROUTINES TO DEFINE AND HANDLE LINKS
 940
 941 MFUNCTION LINK,SUBR
 942         ENTRY
 943         CAML    AB,[-6,,0]      ;NO MORE THAN 3 ARGS
 944         CAML    AB,[-2,,0]      ;NO LESS THAN 2 ARGS
 945         JRST    WNA
 946         CAML    AB,[-4,,0]      ;ONLY TWO ARGS SUPPLIED ?
 947         JRST    GETOB           ;YES, GET OBLIST FROM CURRENT PATH
 948         MOVE    A,2(AB)
 949         MOVE    B,3(AB)
 950         MOVE    C,5(AB)
 951         JRST    LINKIN
 952 GETOB:  MOVSI   A,TATOM
 953         MOVE    B,IMQUOTE OBLIST
 954         PUSHJ   P,IDVAL
 955         CAMN    A,$TOBLS
 956         JRST    LINKP
 957         CAME    A,$TLIST
 958         JRST    BADOBL
 959         JUMPE   B,BADLST
 960         GETYPF  A,(B)
 961         MOVE    B,(B)+1
 962 LINKP:  MOVE    C,B
 963         MOVE    A,2(AB)
 964         MOVE    B,3(AB)
 965 LINKIN: PUSHJ   P,IINSRT
 966         CAMN    A,$TFALSE       ;LINK NAME ALREADY USED ?
 967         JRST    ALRDY           ;YES, LOSE
 968         MOVE    C,B
 969         MOVE    A,(AB)
 970         MOVE    B,1(AB)
 971         PUSHJ   P,CSETG
 972         JRST    FINIS
 973
 974
 975 ILINK:  HLRE    A,B
 976         SUBM    B,A             ;FOUND A LINK ?
 977         MOVE    A,(A)
 978         TRNE    A,LNKBIT
 979          JRST   .+3
 980         MOVSI   A,TATOM
 981         POPJ    P,              ;NO, FINISHED
 982         MOVSI   A,TATOM
 983         PUSHJ   P,IGVAL         ;GET THE LINK'S DESTINATION
 984         CAME    A,$TUNBOUND     ;WELL FORMED LINK ?
 985         POPJ    P,              ;YES
 986         ERRUUO  EQUOTE BAD-LINK
 987
 988 \f
 989 ; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
 990
 991 IMPURIFY:
 992         PUSH    TP,$TATOM
 993         PUSH    TP,B
 994         MOVE    C,B
 995         MOVEI   0,(C)
 996         CAIGE   0,HIBOT
 997         JRST    RTNATM          ; NOT PURE, RETURN
 998         JRST    IMPURX
 999
1000 ; ROUTINE PASSED TO GCHACK
1001
1002 ATFIX:  CAME    D,(TP)
1003         CAMN    D,-2(TP)
1004         JRST    .+2
1005         POPJ    P,
1006
1007         ASH     C,1
1008         ADD     C,TYPVEC+1      ; COMPUTE SAT
1009         HRRZ    C,(C)
1010         ANDI    C,SATMSK
1011         CAIE    C,SATOM
1012 CPOPJ:  POPJ    P,
1013
1014         SUB     D,-2(TP)
1015         ADD     D,-4(TP)
1016         SKIPE   B
1017         MOVEM   D,1(B)
1018         POPJ    P,
1019
1020
1021 ; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
1022 ; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
1023
1024 BYTDOP: PUSH    P,B             ; SAVE SOME ACS
1025         PUSH    P,D
1026         PUSH    P,E
1027         MOVE    B,1(C)          ; GET BYTE POINTER
1028         LDB     D,[360600,,B]   ; POSITION TO D
1029         LDB     E,[300600,,B]   ; AND BYTE SIZE
1030         MOVEI   A,(E)           ; A COPY IN A
1031         IDIVI   D,(E)           ; D=> # OF BYTES IN WORD 1
1032         HRRZ    E,(C)           ; GET LENGTH
1033         SUBM    E,D             ; # OF BYTES IN OTHER WORDS
1034         JUMPL   D,BYTDO1        ; NEAR DOPE WORD
1035         MOVEI   B,36.           ; COMPUTE BYTES PER WORD
1036         IDIVM   B,A
1037         ADDI    D,-1(A)         ; NOW COMPUTE WORDS
1038         IDIVI   D,(A)           ; D/ # NO. OF WORDS PAST 1ST
1039         ADD     D,1(C)          ; D POINTS TO DOPE WORD
1040         MOVEI   A,2(D)
1041
1042 BYTDO2: POP     P,E
1043         POP     P,D
1044         POP     P,B
1045         POPJ    P,
1046 BYTDO1: MOVEI   A,2(B)
1047         JRST    BYTDO2
1048
1049 ; 1) IMPURIFY ITS OBLIST LIST
1050
1051 IMPURX: HRRZ    B,2(C)          ; PICKUP OBLIST IF IT EXISTS
1052         JUMPE   B,IMPUR0        ; NOT ON ONE, IGNORE THIS CODE
1053
1054         HRRO    E,(B)
1055         PUSH    TP,$TOBLS       ; SAVE BUCKET
1056         PUSH    TP,E
1057
1058         MOVE    B,(E)           ; GET NEXT ONE
1059 IMPUR4: MOVEI   0,(B)
1060         MOVE    D,1(B)
1061         CAME    D,-2(TP)
1062         JRST    .+3
1063         SKIPE   GPURFL          ; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
1064                                 ;   ATOM
1065         HRRM    D,1(B)
1066         CAIGE   0,HIBOT         ; SKIP IF PURE
1067         JRST    IMPUR3          ; FOUND IMPURE NESS, SKIP IT
1068         HLLZ    C,(B)           ; SET UP ICONS CALL
1069         HRRZ    E,(B)
1070 IMPR1:  PUSHJ   P,ICONS         ; CONS IT UP
1071 IMPR2:  HRRZ    E,(TP)          ; RETRV PREV
1072         HRRM    B,(E)           ; AND CLOBBER
1073 IMPUR3: MOVE    D,1(B)
1074         CAMN    D,-2(TP)        ; HAVE GOTTEN TO OUR SLOT?
1075         JRST    IMPPR3
1076         MOVSI   0,TLIST
1077         MOVEM   0,-1(TP)        ; FIX TYPE
1078         HRRZM   B,(TP)          ; STORE GOODIE
1079         HRRZ    B,(B)           ; CDR IT
1080         JUMPN   B,IMPUR4        ; LOOP
1081 IMPPR3: SUB     TP,[2,,2]       ; FLUSH TP CRUFT
1082
1083 ; 1.5)  IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
1084
1085 IMPUR0: MOVE    C,(TP)          ; GET ATOM
1086
1087         HRRZ    B,2(C)
1088         MOVE    B,(B)
1089         ADD     C,[3,,3]        ; POINT TO PNAME
1090         HLRE    A,C             ; GET LNTH IN WORDS OF PNAME
1091         MOVNS   A
1092         PUSH    P,[IMPUR2]      ; FAKE OUT ILOOKC
1093         PUSH    P,(C)           ; PUSH UP THE PNAME
1094         AOBJN   C,.-1
1095         PUSH    P,A             ; NOW THE COUNT
1096         MOVSI   A,TOBLS
1097         JRST    ILOOKC          ; GO FIND BUCKET
1098
1099 IMPUR2: JUMPE   B,IMPUR1
1100         JUMPE   0,IMPUR1                ; YUP, DONE
1101         HRRZ    C,0
1102         CAIG    C,HIBOT         ; SKIP IF PREV IS PURE
1103         JRST    IMPUR1
1104
1105         MOVE    B,0
1106         PUSH    P,GPURFL        ; PRERTEND OUT OF PURIFY
1107         SETZM   GPURFL
1108         PUSHJ   P,IMPURIF       ; RECURSE
1109         POP     P,GPURFL
1110         MOVE    B,(TP)          ; AND RETURN ORIGINAL
1111
1112 ; 2) GENERATE A DUPLICATE ATOM
1113
1114 IMPUR1: SKIPE   GPURFL          ; SEE IF IN PURIFY
1115         JRST    IMPUR7
1116         HLRE    A,(TP)          ; GET LNTH OF ATOM
1117         MOVNS   A
1118         PUSH    P,A
1119         PUSHJ   P,IBLOCK        ; GET NEW BLOCK FOR ATOM
1120         PUSH    TP,$TATOM
1121         PUSH    TP,B
1122         HRL     B,-2(TP)                ; SETUP BLT
1123         POP     P,A
1124         ADDI    A,(B)           ; END OF BLT
1125         BLT     B,(A)           ; CLOBBER NEW ATOM
1126         MOVSI   B,.VECT.        ; TURN ON BIT FOR GCHACK
1127         IORM    B,(A)
1128
1129 ; 3) NOW COPY GLOBAL VALUE
1130
1131 IMPUR7: MOVE    B,(TP)          ; ATOM BACK
1132         GETYP   0,(B)
1133         SKIPE   A,1(B)          ; NON-ZER POINTER?
1134         CAIN    0,TUNBOU        ; BOUND?
1135         JRST    IMPUR5          ; NO, DONT COPY GLOB VAL
1136         PUSH    TP,(A)
1137         PUSH    TP,1(A)
1138         PUSH    TP,$TATOM
1139         PUSH    TP,B
1140         SETZM   (B)
1141         SETZM   1(B)
1142         SKIPN   GPURFL          ; HERE IS SOME CODE NEEDED FOR PURIFY
1143         JRST    IMPUR8
1144         PUSH    P,LPVP
1145         MOVE    PVP,PVSTOR+1
1146         PUSH    P,AB            ; GET AB BACK
1147         MOVE    AB,ABSTO+1(PVP)
1148 IMPUR8: PUSHJ   P,BSETG         ; SETG IT
1149         SKIPN   GPURFL
1150         JRST    .+3             ; RESTORE SP AND AB FOR PURIFY
1151         POP     P,TYPNT
1152         POP     P,SP
1153         SUB     TP,[2,,2]       ; KILL ATOM SLOTS ON TP
1154         POP     TP,C            ;POP OFF VALUE SLOTS
1155         POP     TP,A
1156         MOVEM   A,(B)           ; FILL IN SLOTS ON GLOBAL STACK
1157         MOVEM   C,1(B)
1158 IMPUR5: SKIPE   GPURFL          ; FINISH OFF DIFFERENTLY FOR PURIFY
1159         JRST    IMPUR9
1160
1161         PUSH    TP,$TFIX        ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
1162         PUSH    TP,-3(TP)
1163         PUSH    TP,$TFIX        ; OTHER KIND OF POINTER ALSO
1164         HLRE    0,-1(TP)
1165         HRRZ    A,-1(TP)
1166         SUB     A,0
1167         PUSH    TP,A
1168
1169 ; 4) UPDATE ALL POINTERS TO THIS ATOM
1170
1171         MOVE    A,[PUSHJ P,ATFIX]       ; INS TO PASS TO GCHACK
1172         MOVEI   PVP,1           ; SAY MIGHT BE NON-ATOMS
1173         PUSHJ   P,GCHACK
1174         SUB     TP,[6,,6]
1175
1176 RTNATM: POP     TP,B
1177         POP     TP,A
1178         POPJ    P,
1179
1180 IMPUR9: SUB     TP,[2,,2]
1181         POPJ    P,              ; RESTORE AND GO
1182
1183
1184
1185 END