sumex/atomhk.mcr098

   1 TITLE ATOMHACKER FOR MUDDLE\r
   2 \r
   3 RELOCATABLE\r
   4 \r
   5 .INSRT MUDDLE >\r
   6 .GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE\r
   7 .GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP\r
   8 .GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY\r
   9 .GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG\r
  10 \r
  11 .VECT.==40000           ; BIT FOR GCHACK\r
  12 \r
  13 ; FUNCTION TO GENERATE AN EMPTY OBLIST\r
  14 \r
  15 MFUNCTION MOBLIST,SUBR\r
  16 \r
  17         ENTRY\r
  18         CAMGE   AB,[-5,,0]      ;CHECK NUMBER OF ARGS\r
  19         JRST    TMA\r
  20         JUMPGE  AB,MOBL2                ; NO ARGS\r
  21         PUSH    TP,(AB)\r
  22         PUSH    TP,1(AB)\r
  23         PUSH    TP,$TATOM\r
  24         PUSH    TP,IMQUOTE OBLIST\r
  25         MCALL   2,GET           ; CHECK IF IT EXISTS ALREADY\r
  26         CAMN    A,$TOBLS\r
  27         JRST    FINIS\r
  28 MOBL2:  MOVE    A,OBLNT         ;GET DEFAULT LENGTH\r
  29         CAML    AB,[-3,,0]      ;IS LENGTH SUPPLIED\r
  30         JRST    MOBL1           ;NO, USE STANDARD LENGTH\r
  31         GETYP   C,2(AB)         ;GET ARG TYPE\r
  32         CAIE    C,TFIX\r
  33         JRST    WTYP2           ;LOSE\r
  34         MOVE    A,3(AB)         ;GET LENGTH\r
  35 MOBL1:  PUSH    TP,$TFIX\r
  36         PUSH    TP,A\r
  37         MCALL   1,UVECTOR       ;GET A UNIFORM VECTOR\r
  38         MOVSI   C,TLIST+.VECT.  ;IT IS OF TYPE LIST\r
  39         HLRE    D,B             ;-LENGTH TO D\r
  40         SUBM    B,D             ;D POINTS TO DOPE WORD\r
  41         MOVEM   C,(D)           ;CLOBBER TYPE IN\r
  42         MOVSI   A,TOBLS\r
  43         JUMPGE  AB,FINIS        ; IF NO ARGS, DONE\r
  44         GETYP   A,(AB)\r
  45         CAIE    A,TATOM\r
  46         JRST    WTYP1\r
  47         PUSH    TP,$TOBLS\r
  48         PUSH    TP,B\r
  49         PUSH    TP,$TOBLS\r
  50         PUSH    TP,B\r
  51         PUSH    TP,$TATOM\r
  52         PUSH    TP,IMQUOTE OBLIST\r
  53         PUSH    TP,(AB)\r
  54         PUSH    TP,1(AB)\r
  55         MCALL   3,PUT   ; PUT THE NAME ON THE OBLIST\r
  56         PUSH    TP,(AB)\r
  57         PUSH    TP,1(AB)\r
  58         PUSH    TP,$TATOM\r
  59         PUSH    TP,IMQUOTE OBLIST\r
  60         PUSH    TP,(TB)\r
  61         PUSH    TP,1(TB)\r
  62         MCALL   3,PUT   ; PUT THE OBLIST ON THE NAME\r
  63 \r
  64         POP     TP,B\r
  65         POP     TP,A\r
  66         JRST    FINIS\r
  67 \r
  68 MFUNCTION GROOT,SUBR,ROOT\r
  69         ENTRY 0\r
  70         MOVE    A,ROOT(TVP)\r
  71         MOVE    B,ROOT+1(TVP)\r
  72         JRST    FINIS\r
  73 \r
  74 MFUNCTION GINTS,SUBR,INTERRUPTS\r
  75         ENTRY 0\r
  76         MOVE    A,INTOBL(TVP)\r
  77         MOVE    B,INTOBL+1(TVP)\r
  78         JRST FINIS\r
  79 \r
  80 MFUNCTION GERRS,SUBR,ERRORS\r
  81         ENTRY 0\r
  82         MOVE    A,ERROBL(TVP)\r
  83         MOVE    B,ERROBL+1(TVP)\r
  84         JRST    FINIS\r
  85 \r
  86 \r
  87 COBLQ:  SKIPN   B,2(B)          ; SKIP IF EXISTS\r
  88         JRST    IFLS\r
  89         MOVSI   A,TOBLS\r
  90         JUMPL   B,CPOPJ1\r
  91         ADDI    B,(TVP)\r
  92         MOVE    B,(B)\r
  93 CPOPJ1: AOS     (P)\r
  94         POPJ    P,\r
  95 \r
  96 IFLS:   MOVEI   B,0\r
  97         MOVSI   A,TFALSE\r
  98         POPJ    P,\r
  99 \r
 100 MFUNCTION OBLQ,SUBR,[OBLIST?]\r
 101 \r
 102         ENTRY   1\r
 103         GETYP   A,(AB)\r
 104         CAIE    A,TATOM\r
 105         JRST    WTYP1\r
 106         MOVE    B,1(AB)         ; GET ATOM\r
 107         PUSHJ   P,COBLQ\r
 108         JFCL\r
 109         JRST    FINIS\r
 110 \r
 111 \f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME\r
 112 \r
 113 MFUNCTION LOOKUP,SUBR\r
 114 \r
 115         ENTRY   2\r
 116         PUSHJ   P,ILOOKU        ;CALL INTERNAL ROUTINE\r
 117         JRST    FINIS\r
 118 \r
 119 CLOOKU: SUBM    M,(P)\r
 120         PUSH    TP,A\r
 121         PUSH    TP,B\r
 122         MOVEI   B,-1(TP)\r
 123         PUSH    TP,$TOBLS\r
 124         PUSH    TP,C\r
 125         GETYP   A,A\r
 126         PUSHJ   P,CSTAK\r
 127         MOVE    B,(TP)\r
 128         PUSHJ   P,ILOOK\r
 129         POP     P,D\r
 130         HRLI    D,(D)\r
 131         SUB     P,D\r
 132         SKIPE   B\r
 133         SOS     (P)\r
 134         SUB     TP,[4,,4]\r
 135         JRST    MPOPJ\r
 136 \r
 137 ILOOKU: PUSHJ   P,ARGCHK        ;CHECK ARGS\r
 138         PUSHJ   P,CSTACK        ;PUT CHARACTERS ON THE STACK\r
 139 \r
 140 CALLIT: MOVE    B,3(AB)         ;GET OBLIST\r
 141 ILOOKC: PUSHJ   P,ILOOK         ;LOOK IT UP\r
 142         POP     P,D             ;RESTORE COUNT\r
 143         HRLI    D,(D)           ;TO BOTH SIDES\r
 144         SUB     P,D\r
 145         POPJ    P,\r
 146 \r
 147 ;THIS ROUTINE CHECKS ARG TYPES\r
 148 \r
 149 ARGCHK: GETYP   A,(AB)          ;GET TYPES\r
 150         GETYP   C,2(AB)\r
 151         CAIE    A,TCHRS         ;IS IT EITHER CHAR STRING\r
 152         CAIN    A,TCHSTR\r
 153         CAIE    C,TOBLS         ;IS 2ND AN OBLIST\r
 154         JRST    WRONGT          ;TYPES ARE WRONG\r
 155         POPJ    P,\r
 156 \r
 157 ;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)\r
 158 \r
 159 \r
 160 CSTACK: MOVEI   B,(AB)\r
 161 CSTAK:  POP     P,D             ;RETURN ADDRESS TO D\r
 162         CAIE    A,TCHRS         ;IMMEDIATE?\r
 163         JRST    NOTIMM          ;NO, HAIR\r
 164         MOVE    A,1(B)          ; GET CHAR\r
 165         LSH     A,29.           ; POSITION\r
 166         PUSH    P,A             ;ONTO P\r
 167         PUSH    P,[1]           ;WITH NUMBER\r
 168         JRST    (D)             ;GO CALL SEARCHER\r
 169 \r
 170 NOTIMM: MOVEI   A,1             ; CLEAR CHAR COUNT\r
 171         HRRZ    C,(B)           ; GET COUNT OF CHARS\r
 172         JUMPE   C,NULST ; FLUSH NULL STRING\r
 173         MOVE    B,1(B)          ;GET BYTE POINTER\r
 174 \r
 175 CLOOP1: PUSH    P,[0]           ; STORE CHARS ON STACK\r
 176         MOVSI   E,(<440700,,(P)>)       ; SETUP BYTE POINTER\r
 177 CLOOP:  ILDB    0,B             ;GET A CHARACTER\r
 178         IDPB    0,E             ;STORE IT\r
 179         SOJE    C,CDONE         ; ANY MORE?\r
 180         TLNE    E,760000        ; WORD FULL\r
 181         JRST    CLOOP           ;NO CONTINUE\r
 182         AOJA    A,CLOOP1        ;AND CONTINUE\r
 183 \r
 184 CDONE:\r
 185 CDONE1: PUSH    P,A             ;AND NUMBER OF WORDS\r
 186         JRST    (D)             ;RETURN\r
 187 \r
 188 \r
 189 NULST:  PUSH    TP,$TATOM\r
 190         PUSH    TP,EQUOTE NULL-STRING\r
 191         JRST    CALER1\r
 192 \f; THIS FUNCTION LOOKS FOR ATOMS.  CALLED BY PUSHJ P,ILOOK\r
 193 ;       B/      OBLIST POINTER\r
 194 ;       -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK\r
 195 ;       CHAR STRING IS ON THE STACK\r
 196 \r
 197 ILOOK:  MOVN    A,-1(P)         ;GET -LENGTH\r
 198         HRLI    A,-1(A)         ;<-LENGTH-1>,,-LENGTH\r
 199         PUSH    TP,$TFIX        ;SAVE\r
 200         PUSH    TP,A\r
 201         ADDI    A,-1(P)         ;HAVE AOBJN POINTER TO CHARS\r
 202         MOVEI   D,0             ;HASH WORD\r
 203         XOR     D,(A)\r
 204         AOBJN   A,.-1           ;XOR THEM ALL TOGETHER\r
 205         HLRE    A,B             ;GET LENGTH OF OBLIST\r
 206         MOVNS   A\r
 207         TLZ     D,400000        ; MAKE SURE + HASH CODE\r
 208         IDIVI   D,(A)           ;DIVIDE\r
 209         HRLI    E,(E)           ;TO BOTH HALVES\r
 210         ADD     B,E             ;POINT TO BUCKET\r
 211 \r
 212         MOVEI   0,(B)           ;IN CASE REMOVING 1ST\r
 213         SKIPN   C,(B)           ;BUCKET EMPTY?\r
 214         JRST    NOTFND          ;YES, GIVE UP\r
 215 LOOK2:  SKIPN   A,1(C)          ;NIL CAR ON LIST?\r
 216         JRST    NEXT            ;YES TRY NEXT\r
 217         ADD     A,[3,,3]        ;POINT TO ATOMS PNAME\r
 218         MOVE    D,(TP)          ;GET PSEUDO AOBJN POINTER TO CHARS\r
 219         ADDI    D,-1(P)         ;NOW ITS A REAL AOBJN POINTER\r
 220         JUMPE   D,CHECK0        ;ONE IS EMPTY\r
 221 LOOK1:  MOVE    E,(D)           ;GET A WORD\r
 222         CAME    E,(A)           ;COMPARE\r
 223         JRST    NEXT            ;THIS ONE DOESN'T MATCH\r
 224         AOBJP   D,CHECK         ;ONE RAN OUT\r
 225         AOBJN   A,LOOK1         ;JUMP IF STILL MIGHT WIN\r
 226 \r
 227 NEXT:   MOVEI   0,(C)           ;POINT TO PREVIOUS ELEMENT\r
 228         HRRZ    C,(C)           ;STEP THROUGH\r
 229         JUMPN   C,LOOK2\r
 230 \r
 231 NOTFND: EXCH    C,B             ;RETURN BUCKET IN B\r
 232         MOVSI   A,TFALSE\r
 233 CPOPJT: SUB     TP,[2,,2]       ;REMOVE RANDOM TP STUFF\r
 234         POPJ    P,\r
 235 \r
 236 CHECK0: JUMPN   A,NEXT          ;JUMP IF NOT ALSO EMPTY\r
 237         SKIPA\r
 238 CHECK:  AOBJN   A,NEXT          ;JUMP IF NO MATCH\r
 239         HLLZ    A,(C)\r
 240         MOVE    E,B             ; RETURN BUCKET\r
 241         MOVE    B,1(C)          ;GET ATOM\r
 242         JRST    CPOPJT\r
 243 \r
 244 \r
 245 \f; FUNCTION TO INSERT AN ATOM ON AN OBLIST\r
 246 \r
 247 MFUNCTION INSERT,SUBR\r
 248 \r
 249         ENTRY   2\r
 250         GETYP   A,2(AB)\r
 251         CAIE    A,TOBLS\r
 252         JRST    WTYP2\r
 253         MOVE    A,(AB)\r
 254         MOVE    B,1(AB)\r
 255         MOVE    C,3(AB)\r
 256         PUSHJ   P,IINSRT\r
 257         JRST    FINIS\r
 258 \r
 259 CINSER: SUBM    M,(P)\r
 260         PUSHJ   P,IINSRT\r
 261         JRST    MPOPJ\r
 262 \r
 263 IINSRT: PUSH    TP,A\r
 264         PUSH    TP,B\r
 265         PUSH    TP,$TOBLS\r
 266         PUSH    TP,C\r
 267         GETYP   A,A\r
 268         CAIN    A,TATOM\r
 269         JRST    INSRT0\r
 270 \r
 271 ;INSERT WITH A GIVEN PNAME\r
 272 \r
 273         CAIE    A,TCHRS\r
 274         CAIN    A,TCHSTR\r
 275         JRST    .+2\r
 276         JRST    WTYP1\r
 277 \r
 278         PUSH    TP,$TFIX        ;FLAG CALL\r
 279         PUSH    TP,[0]\r
 280         MOVEI   B,-5(TP)\r
 281         PUSHJ   P,CSTAK         ;COPY ONTO STACK\r
 282         MOVE    B,-2(TP)\r
 283         PUSHJ   P,ILOOK         ;LOOK IT UP (BUCKET RETURNS IN C)\r
 284         JUMPN   B,ALRDY         ;EXISTS, LOSE\r
 285         MOVE    D,-2(TP)        ; GET OBLIST BACK\r
 286 INSRT1: PUSH    TP,$TOBLS       ;SAVE BUCKET POINTER\r
 287         PUSH    TP,C\r
 288         PUSH    TP,$TOBLS\r
 289         PUSH    TP,D            ; SAVE OBLIST\r
 290 INSRT3: PUSHJ   P,IATOM         ; MAKE AN ATOM\r
 291         PUSHJ   P,LINKCK        ; A LINK REALLY NEEDED ?\r
 292         MOVE    E,-2(TP)\r
 293         HRRZ    E,(E)           ; GET BUCKET\r
 294         PUSHJ   P,ICONS\r
 295         MOVE    C,-2(TP)        ;BUCKET AGAIN\r
 296         HRRM    B,(C)           ;INTO NEW BUCKET\r
 297         MOVSI   A,TATOM\r
 298         MOVE    B,1(B)          ;GET ATOM BACK\r
 299         MOVE    D,(TP)          ; GET OBLIST\r
 300         MOVEM   D,2(B)          ; AND CLOBBER\r
 301         MOVE    C,-4(TP)        ;GET FLAG\r
 302         SUB     TP,[6,,6]       ;POP STACK\r
 303         JUMPN   C,(C)\r
 304         SUB     TP,[4,,4]\r
 305         POPJ    P,\r
 306 \r
 307 ;INSERT WITH GIVEN ATOM\r
 308 INSRT0: MOVE    A,-2(TP)        ;GOBBLE PNAME\r
 309         SKIPE   2(A)            ; SKIP IF NOT ON AN OBLIST\r
 310         JRST    ONOBL\r
 311         ADD     A,[3,,3]\r
 312         HLRE    C,A\r
 313         MOVNS   C\r
 314         PUSH    P,(A)           ;FLUSH PNAME ONTO P STACK\r
 315         AOBJN   A,.-1\r
 316         PUSH    P,C\r
 317         MOVE    B,(TP)          ; GET OBLIST FOR LOOKUP\r
 318         PUSHJ   P,ILOOK         ;ALREADY THERE?\r
 319         JUMPN   B,ALRDY\r
 320         PUSH    TP,$TOBLS       ;SAVE NECESSARY STUFF AWAY FROM CONS\r
 321         PUSH    TP,C            ;WHICH WILL MAKE A LIST FROM THE ATOM\r
 322         MOVSI   C,TATOM\r
 323         MOVE    D,-4(TP)\r
 324         PUSHJ   P,INCONS\r
 325         MOVE    C,(TP)          ;RESTORE\r
 326         HRRZ    D,(C)\r
 327         HRRM    B,(C)\r
 328         HRRM    D,(B)\r
 329         MOVE    C,-2(TP)\r
 330         MOVE    B,-4(TP)        ; GET BACK ATOM\r
 331         MOVEM   C,2(B)          ; CLOBBER OBLIST IN\r
 332         MOVSI   A,TATOM\r
 333         SUB     TP,[6,,6]\r
 334         POP     P,C\r
 335         HRLI    C,(C)\r
 336         SUB     P,C\r
 337         POPJ    P,\r
 338 \r
 339 LINKCK: HRRZ    C,FSAV(TB)      ;CALLER'S NAME\r
 340         CAIN    C,LINK\r
 341         SKIPA   C,$TLINK        ;LET US INSERT A LINK INSTEAD OF AN ATOM\r
 342         MOVSI   C,TATOM         ;GET REAL ATOM FOR CALL TO ICONS\r
 343         MOVE    D,B\r
 344         POPJ    P,\r
 345 \r
 346 \r
 347 \r
 348 ALRDY:  PUSH    TP,$TATOM\r
 349         PUSH    TP,EQUOTE ATOM-ALREADY-THERE\r
 350         JRST    CALER1\r
 351 \r
 352 ONOBL:  PUSH    TP,$TATOM\r
 353         PUSH    TP,EQUOTE ON-AN-OBLIST-ALREADY\r
 354         JRST    CALER1\r
 355 \r
 356 ; INTERNAL INSERT CALL\r
 357 \r
 358 INSRTX: POP     P,0             ; GET RET ADDR\r
 359         PUSH    TP,$TFIX\b       \r
 360         PUSH    TP,0\r
 361         PUSH    TP,$TOBLS\r
 362         PUSH    TP,B\r
 363         PUSH    TP,$TOBLS\r
 364         PUSH    TP,B\r
 365         PUSHJ   P,ILOOK\r
 366         JUMPN   B,INSRXT\r
 367         MOVEM   C,-2(TP)\r
 368         JRST    INSRT3          ; INTO INSERT CODE\r
 369 \r
 370 INSRXT: PUSH    P,-4(TP)\r
 371         SUB     TP,[6,,6]\r
 372         POPJ    P,\r
 373         JRST    IATM1\r
 374 \f\r
 375 ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST\r
 376 \r
 377 MFUNCTION REMOVE,SUBR\r
 378 \r
 379         ENTRY\r
 380 \r
 381         JUMPGE  AB,TFA\r
 382         CAMGE   AB,[-5,,]\r
 383         JRST    TMA\r
 384         MOVEI   C,0\r
 385         CAML    AB,[-3,,]       ; SKIP IF OBLIST GIVEN\r
 386         JRST    .+5\r
 387         GETYP   0,2(AB)\r
 388         CAIE    0,TOBLS\r
 389         JRST    WTYP2\r
 390         MOVE    C,3(AB)\r
 391         MOVE    A,(AB)\r
 392         MOVE    B,1(AB)\r
 393         PUSHJ   P,IRMV\r
 394         JRST    FINIS\r
 395 \r
 396 CIRMV:  SUBM    M,(P)\r
 397         PUSHJ   P,IRMV\r
 398         JRST    MPOPJ\r
 399 \r
 400 IRMV:   PUSH    TP,A\r
 401         PUSH    TP,B\r
 402         PUSH    TP,$TOBLS\r
 403         PUSH    TP,C\r
 404 IRMV1:  GETYP   0,A             ; CHECK 1ST ARG\r
 405         CAIN    0,TLINK\r
 406         JRST    .+3\r
 407         CAIE    0,TATOM         ; ATOM, TREAT ACCORDINGLY\r
 408         JRST    RMV1\r
 409 \r
 410         SKIPN   D,2(B)          ; SKIP IF ON OBLIST AND GET SAME\r
 411         JRST    IFALSE\r
 412         JUMPL   D,.+3\r
 413         ADDI    D,(TVP)\r
 414         MOVE    D,(D)\r
 415         JUMPE   C,GOTOBL\r
 416         CAME    C,D             ; BETTER BE THE SAME\r
 417         JRST    ONOTH\r
 418 \r
 419 GOTOBL: ADD     B,[3,,3]        ; POINT TO PNAME\r
 420         HLRE    A,B\r
 421         MOVNS   A\r
 422         PUSH    P,(B)           ; PUSH PNAME\r
 423         AOBJN   B,.-1\r
 424         PUSH    P,A\r
 425         MOVEM   D,(TP)          ; SAVE OBLIST\r
 426         JRST    RMV3\r
 427 \r
 428 RMV1:   JUMPE   C,TFA\r
 429         CAIE    0,TCHRS\r
 430         CAIN    0,TCHSTR\r
 431         SKIPA   A,0\r
 432         JRST    WTYP1\r
 433         MOVEI   B,-3(TP)\r
 434         PUSHJ   P,CSTAK\r
 435 RMV3:   MOVE    B,(TP)\r
 436         PUSHJ   P,ILOOK\r
 437         POP     P,D\r
 438         HRLI    D,(D)\r
 439         SUB     P,D\r
 440         JUMPE   B,RMVDON\r
 441         HRRZ    D,0             ;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR)\r
 442         HRRZ    C,(C)           ;GET NEXT OF LOSING PAIR\r
 443         MOVEI   0,(B)\r
 444         CAIGE   0,HIBOT         ; SKIP IF PURE\r
 445         JRST    RMV2\r
 446         PUSHJ   P,IMPURIFY\r
 447         MOVE    A,-3(TP)\r
 448         MOVE    B,-2(TP)\r
 449         MOVE    C,(TP)\r
 450         JRST    IRMV1\r
 451 RMV2:   HRRM    C,(D)           ;AND SPLICE\r
 452         SETZM   2(B)            ; CLOBBER OBLIST SLOT\r
 453 RMVDON: SUB     TP,[4,,4]\r
 454         POPJ    P,\r
 455 \r
 456 \f\r
 457 ;INTERNAL CALL FROM THE READER\r
 458 \r
 459 RLOOKU: PUSH    TP,$TFIX        ;PUSH A FLAG\r
 460         POP     P,C             ;POP OFF RET ADR\r
 461         PUSH    TP,C            ;AND USE AS A FLAG FOR INTERNAL\r
 462         MOVE    C,(P)           ; CHANGE CHAR COUNT TO WORD\r
 463         ADDI    C,4\r
 464         IDIVI   C,5\r
 465         MOVEM   C,(P)\r
 466 \r
 467         CAMN    A,$TOBLS        ;IS IT ONE OBLIST?\r
 468         JRST    RLOOK1\r
 469         CAME    A,$TLIST        ;IS IT A LIST\r
 470         JRST    BADOBL\r
 471 \r
 472         JUMPE   B,BADLST\r
 473         PUSH    TP,$TOBLS       ; SLOT FOR REMEBERIG\r
 474         PUSH    TP,[0]\r
 475         PUSH    TP,$TOBLS\r
 476         PUSH    TP,[0]\r
 477         PUSH    TP,A\r
 478         PUSH    TP,B\r
 479 \r
 480 RLOOK2: GETYP   A,(B)           ;CHECK THIS IS AN OBLIST\r
 481         MOVE    B,1(B)          ;VALUE\r
 482         CAIE    A,TOBLS\r
 483         JRST    DEFALT\r
 484         PUSHJ   P,ILOOK         ;LOOK IT UP\r
 485         JUMPN   B,RLOOK3        ;WIN\r
 486         SKIPE   -2(TP)          ; SKIP IF DEFAULT NOT STORED\r
 487         JRST    RLOOK4\r
 488         HRRZ    D,(TP)          ; GET CURRENT\r
 489         MOVE    D,1(D)          ; OBLIST\r
 490         MOVEM   D,-2(TP)\r
 491         MOVEM   C,-4(TP)        ; FOR INSERT IF NEEDED\r
 492 RLOOK4: INTGO\r
 493         HRRZ    B,@(TP)         ;CDR THE LIST\r
 494         HRRZM   B,(TP)\r
 495         JUMPN   B,RLOOK2\r
 496         SKIPN   D,-2(TP)        ; RESTORE FOR INSERT\r
 497         JRST    BADDEF          ; NO DEFAULT, USER LOST ON SPECIFICATION\r
 498         MOVE    C,-4(TP)\r
 499         SUB     TP,[6,,6]       ; FLUSH CRAP\r
 500         JRST    INSRT1\r
 501 \r
 502 DEFFLG==1       ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN SPECIFIED\r
 503 DEFALT: CAIN    A,TATOM         ;SPECIAL DEFAULT INDICATING ATOM ?\r
 504         CAME    B,MQUOTE DEFAULT\r
 505         JRST    BADDEF          ;NO, LOSE\r
 506         MOVSI   A,DEFFLG\r
 507         XORB    A,-6(TP)        ;SET AND TEST FLAG\r
 508         TLNN    A,DEFFLG        ; HAVE WE BEEN HERE BEFORE ?\r
 509         JRST    BADDEF          ; YES, LOSE\r
 510         SETZM   -2(TP)          ;ZERO OUT PREVIOUS DEFAULT\r
 511         SETZM   -4(TP)\r
 512         JRST    RLOOK4          ;CONTINUE\r
 513 \r
 514 RLOOK1: PUSH    TP,$TOBLS\r
 515         PUSH    TP,B            ; SAVE OBLIST\r
 516         PUSHJ   P,ILOOK ;LOOK IT UP THERE\r
 517         MOVE    D,(TP)          ; GET OBLIST\r
 518         SUB     TP,[2,,2]\r
 519         JUMPE   B,INSRT1        ;GO INSET IT\r
 520 \r
 521 \r
 522 INSRT2: JRST    .+2             ;\r
 523 RLOOK3: SUB     TP,[6,,6]       ;POP OFF LOSSAGE\r
 524         PUSHJ   P,ILINK         ;IF THIS IS A LINK FOLLOW IT\r
 525         PUSH    P,(TP)          ;GET BACK RET ADR\r
 526         SUB     TP,[2,,2]       ;POP TP\r
 527         JRST    IATM1           ;AND RETURN\r
 528 \r
 529 \r
 530 BADOBL: PUSH    TP,$TATOM\r
 531         PUSH    TP,EQUOTE BAD-OBLIST-OR-LIST-THEREOF\r
 532         JRST    CALER1\r
 533 \r
 534 BADDEF: PUSH    TP,$TATOM\r
 535         PUSH    TP,EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION\r
 536         JRST    CALER1\r
 537 \r
 538 ONOTH:  PUSH    TP,$TATOM\r
 539         PUSH    TP,EQUOTE ATOM-ON-DIFFERENT-OBLIST\r
 540         JRST    CALER1\r
 541 \f;SUBROUTINE TO MAKE AN ATOM\r
 542 \r
 543 MFUNCTION ATOM,SUBR\r
 544 \r
 545         ENTRY   1\r
 546 \r
 547         MOVE    A,(AB)\r
 548         MOVE    B,1(AB)\r
 549         PUSHJ   P,IATOMI\r
 550         JRST    FINIS\r
 551 \r
 552 CATOM:  SUBM    M,(P)\r
 553         PUSHJ   P,IATOMI\r
 554         JRST    MPOPJ\r
 555 \r
 556 IATOMI: GETYP   0,A             ;CHECK ARG TYPE\r
 557         CAIE    0,TCHRS\r
 558         CAIN    0,TCHSTR\r
 559         JRST    .+2             ;JUMP IF WINNERS\r
 560         JRST    WTYP1\r
 561 \r
 562         PUSH    TP,A\r
 563         PUSH    TP,B\r
 564         MOVEI   B,-1(TP)\r
 565         MOVE    A,0\r
 566         PUSHJ   P,CSTAK         ;COPY ONTO STACK\r
 567         PUSHJ   P,IATOM         ;NOW MAKE THE ATOM\r
 568         POPJ    P,\r
 569 \r
 570 ;INTERNAL ATOM MAKER\r
 571 \r
 572 IATOM:  MOVE    A,-1(P)         ;GET WORDS IN PNAME\r
 573         ADDI    A,3             ;FOR VALUE CELL\r
 574         PUSHJ   P,IBLOCK        ; GET BLOCK\r
 575         MOVSI   C,<(GENERAL)>+SATOM+.VECT.      ;FOR TYPE FIELD\r
 576         MOVE    D,-1(P)         ;RE-GOBBLE LENGTH\r
 577         ADDI    D,3(B)          ;POINT TO DOPE WORD\r
 578         MOVEM   C,(D)\r
 579         SKIPG   -1(P)           ;EMPTY PNAME ?\r
 580         JRST    IATM0           ;YES, NO CHARACTERS TO MOVE\r
 581         MOVE    E,B             ;COPY ATOM POINTER\r
 582         ADD     E,[3,,3]        ;POINT TO PNAME AREA\r
 583         MOVEI   C,-1(P)\r
 584         SUB     C,-1(P)         ;POINT TO STRING ON STACK\r
 585         MOVE    D,(C)           ;GET SOME CHARS\r
 586         MOVEM   D,(E)           ;AND COPY THEM\r
 587         ADDI    C,1\r
 588         AOBJN   E,.-3\r
 589 IATM0:  MOVSI   A,TATOM ;TYPE TO ATOM\r
 590 IATM1:  POP     P,D             ;RETURN ADR\r
 591         POP     P,C\r
 592         HRLI    C,(C)\r
 593         SUB     P,C\r
 594         JRST    (D)             ;RETURN\r
 595 \r
 596 \f;SUBROUTINE TO GET AN ATOM'S PNAME\r
 597 \r
 598 MFUNCTION PNAME,SUBR\r
 599 \r
 600         ENTRY 1\r
 601 \r
 602         GETYP   A,(AB)\r
 603         CAIE    A,TATOM         ;CHECK TYPE IS ATOM\r
 604         JRST    WTYP1\r
 605         MOVE    A,1(AB)\r
 606         PUSHJ   P,IPNAME\r
 607         JRST    FINIS\r
 608 \r
 609 CIPNAM: SUBM    M,(P)\r
 610         PUSHJ   P,IPNAME\r
 611         JRST    MPOPJ\r
 612 \r
 613 IPNAME: ADD     A,[3,,3]\r
 614         HLRE    B,A\r
 615         MOVM    B,B\r
 616         PUSH    P,(A)           ;FLUSH PNAME ONTO P\r
 617         AOBJN   A,.-1\r
 618         IMULI   B,5             ; CHARS TO B\r
 619         MOVE    0,(P)           ; LAST WORD\r
 620         MOVE    A,0\r
 621         SUBI    A,1             ; FIND LAST 1\r
 622         ANDCM   0,A             ; 0 HAS 1ST 1\r
 623         JFFO    0,.+1\r
 624         HRREI   0,-34.(A)       ; FIND HOW MUCH TO ADD\r
 625         IDIVI   0,7\r
 626         ADD     B,0\r
 627         PUSH    P,B\r
 628         PUSHJ   P,CHMAK         ;MAKE A STRING\r
 629         POPJ    P,\r
 630 \r
 631 \f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE\r
 632 \r
 633 MFUNCTION BLK,SUBR,BLOCK\r
 634 \r
 635         ENTRY   1\r
 636 \r
 637         GETYP   A,(AB)  ;CHECK TYPE OF ARG\r
 638         CAIE    A,TOBLS ;IS IT AN OBLIST\r
 639         CAIN    A,TLIST ;OR A LIAT\r
 640         JRST    .+2\r
 641         JRST    WTYP1\r
 642         MOVSI   A,TATOM ;LOOK UP OBLIST\r
 643         MOVE    B,IMQUOTE OBLIST\r
 644         PUSHJ   P,IDVAL ;GET VALUE\r
 645         PUSH    TP,A\r
 646         PUSH    TP,B\r
 647         PUSH    TP,.BLOCK(PVP)  ;HACK THE LIST\r
 648         PUSH    TP,.BLOCK+1(PVP)\r
 649         MCALL   2,CONS  ;CONS THE LIST\r
 650         MOVEM   A,.BLOCK(PVP)   ;STORE IT BACK\r
 651         MOVEM   B,.BLOCK+1(PVP)\r
 652         PUSH    TP,$TATOM\r
 653         PUSH    TP,IMQUOTE OBLIST\r
 654         PUSH    TP,(AB)\r
 655         PUSH    TP,1(AB)\r
 656         MCALL   2,SET   ;SET OBLIST TO ARG\r
 657         JRST    FINIS\r
 658 \r
 659 MFUNCTION ENDBLOCK,SUBR\r
 660 \r
 661         ENTRY   0\r
 662 \r
 663         SKIPN   B,.BLOCK+1(PVP) ;IS THE LIST NIL?\r
 664         JRST    BLKERR  ;YES, LOSE\r
 665         HRRZ    C,(B)   ;CDR THE LIST\r
 666         HRRZM   C,.BLOCK+1(PVP)\r
 667         PUSH    TP,$TATOM       ;NOW RESET OBLIST\r
 668         PUSH    TP,IMQUOTE OBLIST\r
 669         HLLZ    A,(B)   ;PUSH THE TYPE OF THE CAR\r
 670         PUSH    TP,A\r
 671         PUSH    TP,1(B) ;AND VALUE OF CAR\r
 672         MCALL   2,SET\r
 673         JRST    FINIS\r
 674 \r
 675 BLKERR: PUSH    TP,$TATOM\r
 676         PUSH    TP,EQUOTE UNMATCHED\r
 677         JRST    CALER1\r
 678 \r
 679 BADLST: PUSH    TP,$TATOM\r
 680         PUSH    TP,EQUOTE NIL-LIST-OF-OBLISTS\r
 681         JRST    CALER1\r
 682 \f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE\r
 683 \r
 684 CHMAK:  MOVE    A,-1(P)\r
 685         ADDI    A,4\r
 686         IDIVI   A,5\r
 687         PUSHJ   P,IBLOCK\r
 688         MOVEI   C,-1(P)         ;FIND START OF CHARS\r
 689         HLRE    E,B             ; - LENGTH\r
 690         ADD     C,E             ;C POINTS TO START\r
 691         MOVE    D,B             ;COPY VECTOR RESULT\r
 692         JUMPGE  D,NULLST        ;JUMP IF EMPTY\r
 693         MOVE    A,(C)           ;GET ONE\r
 694         MOVEM   A,(D)\r
 695         ADDI    C,1             ;BUMP POINTER\r
 696         AOBJN   D,.-3           ;COPY\r
 697 NULLST: MOVSI   C,TCHRS+.VECT.          ;GET TYPE\r
 698         MOVEM   C,(D)           ;CLOBBER IT IN\r
 699         MOVE    A,-1(P)         ; # WORDS\r
 700         HRLI    A,TCHSTR\r
 701         HRLI    B,440700\r
 702         MOVMM   E,-1(P)         ; SO IATM1 WORKS\r
 703         JRST    IATM1           ;RETURN\r
 704 \r
 705 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.\r
 706 ;   TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,\r
 707 ; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT\r
 708 \r
 709 NXTDCL: GETYP   B,(A)           ;CHECK TYPE\r
 710         CAIE    B,TDEFER                ;LOSE IF NOT DEFERRED\r
 711         POPJ    P,\r
 712 \r
 713         MOVE    B,1(A)          ;GET REAL BYTE POINTER\r
 714 CHRWRD: PUSH    P,C\r
 715         GETYP   C,(B)           ;CHECK IT IS CHSTR\r
 716         CAIE    C,TCHSTR\r
 717         JRST    CPOPJC          ;NO, QUIT\r
 718         PUSH    P,D\r
 719         PUSH    P,E\r
 720         PUSH    P,0\r
 721         MOVEI   E,0             ;INITIALIZE DESTINATION\r
 722         HRRZ    C,(B)           ; GET CHAR COUNT\r
 723         JUMPE   C,GOTDCL        ; NULL, FINISHED\r
 724         MOVE    B,1(B)          ;GET BYTE POINTER\r
 725         MOVE    D,[440700,,E]   ;BYTE POINT TO E\r
 726 CHLOOP: ILDB    0,B             ; GET A CHR\r
 727         IDPB    0,D             ;CLOBBER AWAY\r
 728         SOJE    C,GOTDCL        ; JUMP IF DONE\r
 729         TLNE    D,760000        ; SKIP IF WORD FULL\r
 730         JRST    CHLOOP          ; MORE THAN 5 CHARS\r
 731         TRO     E,1             ; TURN ON FLAG\r
 732 \r
 733 GOTDCL: MOVE    B,E             ;RESULT TO B\r
 734         AOS     -4(P)           ;SKIP RETURN\r
 735 CPOPJ0: POP     P,0\r
 736         POP     P,E\r
 737         POP     P,D\r
 738 CPOPJC: POP     P,C\r
 739         POPJ    P,\r
 740 \r
 741 ; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD\r
 742 ; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A\r
 743 \r
 744 BYTDOP: PUSH    P,B             ; SAVE SOME ACS\r
 745         PUSH    P,D\r
 746         PUSH    P,E\r
 747         MOVE    B,1(C)          ; GET BYTE POINTER\r
 748         LDB     D,[360600,,B]   ; POSITION TO D\r
 749         LDB     E,[300600,,B]   ; AND BYTE SIZE\r
 750         MOVEI   A,(E)           ; A COPY IN A\r
 751         IDIVI   D,(E)           ; D=> # OF BYTES IN WORD 1\r
 752         HRRZ    E,(C)           ; GET LENGTH\r
 753         SUBM    E,D             ; # OF BYTES IN OTHER WORDS\r
 754         JUMPL   D,BYTDO1        ; NEAR DOPE WORD\r
 755         MOVEI   B,36.           ; COMPUTE BYTES PER WORD\r
 756         IDIVM   B,A\r
 757         ADDI    D,-1(A)         ; NOW COMPUTE WORDS\r
 758         IDIVI   D,(A)           ; D/ # NO. OF WORDS PAST 1ST\r
 759         ADD     D,1(C)          ; D POINTS TO DOPE WORD\r
 760         MOVEI   A,2(D)\r
 761 \r
 762 BYTDO2: POP     P,E\r
 763         POP     P,D\r
 764         POP     P,B\r
 765         POPJ    P,\r
 766 BYTDO1: MOVEI   A,1(B)\r
 767         CAME    D,[-5]\r
 768         AOJA    A,BYTDO2\r
 769         JRST    BYTDO2\r
 770 \f;ROUTINES TO DEFINE AND HANDLE LINKS\r
 771 \r
 772 MFUNCTION LINK,SUBR\r
 773         ENTRY\r
 774         CAML    AB,[-6,,0]      ;NO MORE THAN 3 ARGS\r
 775         CAML    AB,[-2,,0]      ;NO LESS THAN 2 ARGS\r
 776         JRST    WNA\r
 777         CAML    AB,[-4,,0]      ;ONLY TWO ARGS SUPPLIED ?\r
 778         JRST    GETOB           ;YES, GET OBLIST FROM CURRENT PATH\r
 779         MOVE    A,2(AB)\r
 780         MOVE    B,3(AB)\r
 781         MOVE    C,5(AB)\r
 782         JRST    LINKIN\r
 783 GETOB:  MOVSI   A,TATOM\r
 784         MOVE    B,IMQUOTE OBLIST\r
 785         PUSHJ   P,IDVAL\r
 786         CAMN    A,$TOBLS\r
 787         JRST    LINKP\r
 788         CAME    A,$TLIST\r
 789         JRST    BADOBL\r
 790         JUMPE   B,BADLST\r
 791         GETYPF  A,(B)\r
 792         MOVE    B,(B)+1\r
 793 LINKP:  MOVE    C,B\r
 794         MOVE    A,2(AB)\r
 795         MOVE    B,3(AB)\r
 796 LINKIN: PUSHJ   P,IINSRT\r
 797         CAMN    A,$TFALSE       ;LINK NAME ALREADY USED ?\r
 798         JRST    ALRDY           ;YES, LOSE\r
 799         MOVE    C,B\r
 800         MOVE    A,(AB)\r
 801         MOVE    B,1(AB)\r
 802         PUSHJ   P,CSETG\r
 803         JRST    FINIS\r
 804 \r
 805 \r
 806 ILINK:  CAME    A,$TLINK        ;FOUND A LINK ?\r
 807         POPJ    P,              ;NO, FINISHED\r
 808         MOVSI   A,TATOM\r
 809         PUSHJ   P,IGVAL         ;GET THE LINK'S DESTINATION\r
 810         CAME    A,$TUNBOUND     ;WELL FORMED LINK ?\r
 811         POPJ    P,              ;YES\r
 812         PUSH    TP,$TATOM\r
 813         PUSH    TP,EQUOTE BAD-LINK\r
 814         JRST    CALER1\r
 815 \r
 816 \f\r
 817 ; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS\r
 818 \r
 819 IMPURIFY:\r
 820         PUSH    TP,$TATOM\r
 821         PUSH    TP,B\r
 822         MOVE    C,B\r
 823         MOVEI   0,(C)\r
 824         CAIGE   0,HIBOT\r
 825         JRST    RTNATM          ; NOT PURE, RETURN\r
 826 \r
 827 ; 1) IMPURIFY ITS OBLIST BUCKET\r
 828 \r
 829         SKIPN   B,2(C)          ; PICKUP OBLIST IF IT EXISTS\r
 830         JRST    IMPUR1          ; NOT ON ONE, IGNORE THIS CODE\r
 831 \r
 832         ADDI    B,(TVP)         ; POINT TO SLOT\r
 833         MOVE    B,(B)           ; GET THE REAL THING\r
 834         ADD     C,[3,,3]        ; POINT TO PNAME\r
 835         HLRE    A,C             ; GET LNTH IN WORDS OF PNAME\r
 836         MOVNS   A\r
 837         PUSH    P,[IMPUR2]      ; FAKE OUT ILOOKC\r
 838         PUSH    P,(C)           ; PUSH UP THE PNAME\r
 839         AOBJN   C,.-1\r
 840         PUSH    P,A             ; NOW THE COUNT\r
 841         JRST    ILOOKC          ; GO FIND BUCKET\r
 842 \r
 843 IMPUR2: JUMPE   B,IMPUR1        ; NOT THERE, GO\r
 844         PUSH    TP,$TOBLS               ; SAVE BUCKET\r
 845         PUSH    TP,E\r
 846 \r
 847         MOVE    B,(E)           ; GET NEXT ONE\r
 848 IMPUR4: MOVEI   0,(B)\r
 849         CAIGE   0,HIBOT         ; SKIP IF PURE\r
 850         JRST    IMPUR3          ; FOUND IMPURE NESS, SKIP IT\r
 851         HLLZ    C,(B)           ; SET UP ICONS CALL\r
 852         HRRZ    E,(B)\r
 853         MOVE    D,1(B)\r
 854         PUSHJ   P,ICONS         ; CONS IT UP\r
 855         HRRZ    E,(TP)          ; RETRV PREV\r
 856         HRRM    B,(E)           ; AND CLOBBER\r
 857 IMPUR3: MOVSI   0,TLIST\r
 858         MOVEM   0,-1(TP)        ; FIX TYPE\r
 859         HRRZM   B,(TP)          ; STORE GOODIE\r
 860         HRRZ    B,(B)           ; CDR IT\r
 861         JUMPN   B,IMPUR4        ; LOOP\r
 862         SUB     TP,[2,,2]       ; FLUSH TP CRUFT\r
 863 \r
 864 ; 2) GENERATE A DUPLICATE ATOM\r
 865 \r
 866 IMPUR1: HLRE    A,(TP)          ; GET LNTH OF ATOM\r
 867         MOVNS   A\r
 868         PUSH    P,A\r
 869         PUSHJ   P,IBLOCK        ; GET NEW BLOCK FOR ATOM\r
 870         PUSH    TP,$TATOM\r
 871         PUSH    TP,B\r
 872         HRL     B,-2(TP)                ; SETUP BLT\r
 873         POP     P,A\r
 874         ADDI    A,(B)           ; END OF BLT\r
 875         BLT     B,(A)           ; CLOBBER NEW ATOM\r
 876         MOVSI   B,.VECT.        ; TURN ON BIT FOR GCHACK\r
 877         IORM    B,(A)\r
 878 \r
 879 ; 3) NOW COPY GLOBAL VALUE\r
 880 \r
 881         MOVE    B,(TP)          ; ATOM BACK\r
 882         GETYP   0,(B)\r
 883         SKIPE   A,1(B)          ; NON-ZER POINTER?\r
 884         CAIN    0,TUNBOU        ; BOUND?\r
 885         JRST    IMPUR5          ; NO, DONT COPY GLOB VAL\r
 886         PUSH    TP,$TATOM\r
 887         PUSH    TP,B\r
 888         PUSH    TP,(A)\r
 889         PUSH    TP,1(A)         \r
 890         SETZM   (B)\r
 891         SETZM   1(B)\r
 892         MCALL   2,SETG\r
 893 IMPUR5: PUSH    TP,$TFIX        ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE\r
 894         PUSH    TP,-3(TP)\r
 895 \r
 896 ; 4) UPDATE ALL POINTERS TO THIS ATOM\r
 897 \r
 898         MOVE    A,[PUSHJ P,ATFIX]       ; INS TO PASS TO GCHACK\r
 899         PUSHJ   P,GCHACK\r
 900         SUB     TP,[4,,4]\r
 901 \r
 902 RTNATM: POP     TP,B\r
 903         POP     TP,A\r
 904         POPJ    P,\r
 905 \r
 906 ; ROUTINE PASSED TO GCHACK\r
 907 \r
 908 ATFIX:  CAIE    C,TGATOM        ; GLOBAL TYPE ATOM\r
 909         CAIN    C,TATOM\r
 910         CAME    D,(TP)          ; SKIP IF WINNER\r
 911         POPJ    P,\r
 912         MOVE    D,-2(TP)\r
 913         SKIPE   B\r
 914         MOVEM   D,1(B)\r
 915         POPJ    P,\r
 916 \r
 917 \r
 918 END\r
 919 \f\f\r