MUDDLE/atomhk.27

   1
   2 TITLE ATOMHACKER FOR MUDDLE
   3
   4 RELOCATABLE
   5
   6 .INSRT MUDDLE >
   7 .GLOBAL RLOOKU,CHMAK,WRONGT,ERRTMA,OBLNT,ROOT,INTOBL,ERROBL
   8 .GLOBAL .BLOCK,CALER1,IDVAL,NXTDCL,CHRWRD
   9
  10
  11 ; FUNCTION TO GENERATE AN EMPTY OBLIST
  12
  13 MFUNCTION MOBLIST,SUBR
  14
  15         ENTRY
  16         CAMGE   AB,[-3,,0]      ;CHECK NUMBER OF ARGS
  17         JRST    ERRTMA
  18         MOVE    A,OBLNT         ;GET DEFAULT LENGTH
  19         CAML    AB,[-1,,0]      ;IS LENGTH SUPPLIED
  20         JRST    MOBL1           ;NO, USE STANDARD LENGTH
  21         HLRZ    C,(AB)          ;GET ARG TYPE
  22         CAIE    C,TFIX
  23         JRST    WRONGT          ;LOSE
  24         MOVE    A,1(AB)         ;GET LENGTH
  25 MOBL1:  PUSH    TP,$TFIX
  26         PUSH    TP,A
  27         MCALL   1,UVECTOR       ;GET A UNIFORM VECTOR
  28         MOVSI   C,TLIST         ;IT IS OF TYPE LIST
  29         HLRE    D,B             ;-LENGTH TO D
  30         SUBM    B,D             ;D POINTS TO DOPE WORD
  31         MOVEM   C,(D)           ;CLOBBER TYPE IN
  32         MOVSI   A,TOBLS
  33         JRST    FINIS
  34
  35
  36 MFUNCTION GROOT,SUBR,ROOT
  37         ENTRY 0
  38         MOVE    B,ROOT+1(TVP)
  39         HRRZ    B,(B)   ;CDR THE LIST
  40         HLLZ    A,(B)
  41         MOVE    B,1(B)  ;RETURN ROOT OBLIST
  42         JRST    FINIS
  43
  44 MFUNCTION GINTS,SUBR,INTERRUPTS
  45         ENTRY 0
  46         MOVE    A,INTOBL(TVP)
  47         MOVE    B,INTOBL+1(TVP)
  48         JRST FINIS
  49
  50 MFUNCTION GERRS,SUBR,ERRORS
  51         ENTRY 0
  52         MOVE    A,ERROBL(TVP)
  53         MOVE    B,ERROBL+1(TVP)
  54         JRST    FINIS
  55
  56 \f
  57 ; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
  58
  59 MFUNCTION LOOKUP,SUBR
  60
  61         ENTRY   2
  62
  63         PUSHJ   P,ILOOKU        ;CAL INTERNAL ROUTINE
  64         JRST    FINIS
  65
  66 ILOOKU: PUSHJ   P,ARGCHK        ;CHECK ARGS
  67         PUSHJ   P,CSTACK        ;PUT CHARACTERS ON THE STACK
  68
  69 CALLIT: MOVE    B,3(AB)         ;GET OBLIST
  70         PUSHJ   P,ILOOK         ;LOOK IT UP
  71         POP     P,D             ;RESTORE COUNT
  72         HRLI    D,(D)           ;TO BOTH SIDES
  73         SUB     P,D
  74         POPJ    P,
  75
  76 ;THIS ROUTINE CHECKS ARG TYPES
  77
  78 ARGCHK: HLRZ    A,(AB)          ;GET TYPES
  79         HLRZ    C,2(AB)
  80         CAIE    A,TCHRS         ;IS IT EITHER CHAR STRING
  81         CAIN    A,TCHSTR
  82         CAIE    C,TOBLS         ;IS 2ND AN OBLIST
  83         JRST    WRONGT          ;TYPES ARE WRONG
  84         POPJ    P,
  85
  86 ;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
  87
  88
  89 CSTACK: POP     P,D             ;RETURN ADDRESS TO D
  90         CAIE    A,TCHRS         ;IMMEDIATE?
  91         JRST    NOTIMM          ;NO, HAIR
  92         PUSH    P,1(AB)         ;ONTO P
  93         PUSH    P,[1]           ;WITH NUMBER
  94         JRST    (D)             ;GO CALL SEARCHER
  95
  96 NOTIMM: SETZB   A,E             ;INITIALIZE WORD COUNT AND CHAR WORD
  97         HRRZ    C,(AB)          ;POINT TO DOPE WORD
  98         SUBI    C,1
  99         MOVE    B,1(AB)         ;GET BYTE POINTER
 100         LDB     0,B             ;GET 1ST CHR
 101         JUMPE   0,CDONE1
 102
 103 CLOOP1: PUSH    P,[440700,,E]   ;SETUP A BYTE POINTER FOR STORING
 104         JUMPN   0,.+2           ;DON'T READ FOR 1ST
 105 CLOOP:  ILDB    0,B             ;GET A CHARACTER
 106         CAIN    C,(B)           ;AT END OF INPUT
 107         JRST    CDONE           ;YES, QUIT
 108         JUMPE   0,CDONE         ;FINISHED?
 109         IDPB    0,(P)           ;STORE IT
 110         TRNN    E,377           ;WORD FULL
 111         JRST    CLOOP           ;NO CONTINUE
 112         MOVEM   E,(P)           ;STORE CHARS
 113         SETZB   E,0             ;RESET CHAR WORD
 114         AOJA    A,CLOOP1        ;AND CONTINUE
 115
 116 CDONE:  SUB     P,[1,,1]        ;REMOVE BYTE POINTER
 117         JUMPE   E,CDONE1
 118         ADDI    A,1
 119         PUSH    P,E             ;PUSH  LAST WORD
 120 CDONE1: PUSH    P,A             ;AND NUMBER OF WORDS
 121         JRST    (D)             ;RETURN
 122 \f
 123 ; THIS FUNCTION LOOKS FOR ATOMS.  CALLED BY PUSHJ P,ILOOK
 124 ;       B/      OBLIST POINTER
 125 ;       -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
 126 ;       CHAR STRING IS ON THE STACK
 127
 128 ILOOK:  MOVN    A,-1(P)         ;GET -LENGTH
 129         HRLI    A,-1(A)         ;<-LENGTH-1>,,-LENGTH
 130         PUSH    TP,$TFIX        ;SAVE
 131         PUSH    TP,A
 132         ADDI    A,-1(P)         ;HAVE AOBJN POINTER TO CHARS
 133         MOVEI   D,0             ;HASH WORD
 134         XOR     D,(A)
 135         AOBJN   A,.-1           ;XOR THEM ALL TOGETHER
 136         HLRE    A,B             ;GET LENGTH OF OBLIST
 137         MOVNS   A
 138         MOVMS   D               ;MAKE SURE OF + HASH CODE
 139         IDIVI   D,(A)           ;DIVIDE
 140         HRLI    E,(E)           ;TO BOTH HALVES
 141         ADD     B,E             ;POINT TO BUCKET
 142
 143         MOVEI   0,(B)           ;IN CASE REMOVING 1ST
 144         SKIPN   C,(B)           ;BUCKET EMPTY?
 145         JRST    NOTFND          ;YES, GIVE UP
 146 LOOK2:  SKIPN   A,1(C)          ;NIL CAR ON LIST?
 147         JRST    NEXT            ;YES TRY NEXT
 148         ADD     A,[2,,2]        ;POINT TO ATOMS PNAME
 149         MOVE    D,(TP)          ;GET PSEUDO AOBJN POINTER TO CHARS
 150         ADDI    D,-1(P)         ;NOW ITS A REAL AOBJN POINTER
 151 LOOK1:  MOVE    E,(D)           ;GET A WORD
 152         CAME    E,(A)           ;COMPARE
 153         JRST    NEXT            ;THIS ONE DOESN'T MATCH
 154         AOBJP   D,CHECK         ;ONE RAN OUT
 155         AOBJN   A,LOOK1         ;JUMP IF STILL MIGHT WIN
 156
 157 NEXT:   MOVEI   0,(C)           ;POINT TO PREVIOUS ELEMENT
 158         HRRZ    C,(C)           ;STEP THROUGH
 159         JUMPN   C,LOOK2
 160
 161 NOTFND: EXCH    C,B             ;RETURN BUCKET IN B
 162         MOVSI   A,TFALSE
 163 CPOPJT: SUB     TP,[2,,2]       ;REMOVE RANDOM TP STUFF
 164         POPJ    P,
 165
 166 CHECK:  AOBJN   A,NEXT          ;JUMP IF NO MATCH
 167         MOVE    B,1(C)          ;GET ATOM
 168         MOVSI   A,TATOM
 169         JRST    CPOPJT
 170
 171
 172 \f
 173 ; FUNCTION TO INSERT AN ATOM ON AN OBLIST
 174
 175 MFUNCTION INSERT,SUBR
 176
 177         ENTRY   2
 178         PUSH    TP,$TFIX        ;FLAG CALL
 179         PUSH    TP,[0]
 180
 181         PUSHJ   P,ARGCHK        ;CHECK ARGS
 182         PUSHJ   P,CSTACK        ;COPY ONTO STACK
 183         MOVE    B,3(AB)         ;GET OBLIST
 184         PUSHJ   P,ILOOK         ;LOOK IT UP (BUCKET RETURNS IN C)
 185         JUMPN   B,RETFLS        ;EXISTS, RETURN FALSE
 186 INSRT1: PUSH    TP,$TOBLS       ;SAVE BUCKET POINTER
 187         PUSH    TP,C
 188         PUSHJ   P,IATOM         ;MAKE AN ATOM
 189         PUSH    TP,$TATOM
 190         PUSH    TP,B            ;PUSH ATOM
 191         PUSH    TP,$TLIST       ;AND LIST NOW IN BUCKET
 192         MOVE    C,-3(TP)                ;GET BUCKET BACK
 193         PUSH    TP,(C)          ;PUSH ITS LIST
 194         MCALL   2,CONS
 195         MOVE    C,(TP)          ;BUCKET AGAIN
 196         HRRM    B,(C)           ;INTO NEW BUCKET
 197         MOVSI   A,TATOM
 198         MOVE    B,1(B)          ;GET ATOM BACK
 199         MOVE    C,-2(TP)        ;GET FLAG
 200         SUB     TP,[4,,4]       ;POP STACK
 201         JUMPE   C,FINIS
 202         JRST    (C)             ;RETURN INTERNAL
 203
 204 RETFLS: PUSH    P,CFINIS        ;FOR POPJ TO WORK
 205         MOVEI   B,0
 206         MOVSI   A,TFALSE
 207         JRST    IATM1           ;RETURN
 208 ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
 209
 210 MFUNCTION REMOVE,SUBR
 211
 212         ENTRY   2
 213
 214         PUSHJ   P,ILOOKU        ;LOOK IT UP
 215 CFINIS: JUMPE   B,FINIS         ;NOT THERE
 216         HRRZ    D,0             ;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR)
 217         HRRZ    C,(C)           ;GET NEXT OF LOSING PAIR
 218         HRRM    C,(D)           ;AND SPLICE
 219         JRST    FINIS
 220
 221 ;INTERNAL CALL FROM THE READER
 222
 223 RLOOKU: PUSH    TP,$TFIX        ;PUSH A FLAG
 224         POP     P,C             ;POP OFF RET ADR
 225         PUSH    TP,C            ;AND USE AS A FLAG FOR INTERNAL
 226
 227         CAMN    A,$TOBLS        ;IS IT ONE OBLIST?
 228         JRST    RLOOK1
 229         CAME    A,$TLIST        ;IS IT A LIST
 230         JRST    WRONGT
 231
 232         JUMPE   B,BADLST
 233         PUSH    TP,A
 234         PUSH    TP,B    ;TWO COPIES OF ARG
 235         PUSH    TP,A
 236         PUSH    TP,B
 237
 238 RLOOK2: INTGO
 239         HLRZ    A,(B)   ;CHECK THIS IS AN OBLIST
 240         CAIE    A,TOBLS
 241         JRST    WRONGT
 242         MOVE    B,1(B)  ;LOOK FOR IT
 243         PUSHJ   P,ILOOK ;LOOK IT UP
 244         JUMPN   B,RLOOK3        ;WIN
 245         HRRZ    B,@(TP) ;CDR THE LIST
 246         HRRZM   B,(TP)
 247         JUMPN   B,RLOOK2
 248         MOVE    B,-2(TP)        ;FAILED USE FIRST
 249         MOVE    B,1(B)
 250         SUB     TP,[4,,4]       ;POP TP
 251
 252 RLOOK1: PUSHJ   P,ILOOK ;LOOK IT UP THERE
 253         JUMPE   B,INSRT1        ;GO INSET IT
 254
 255
 256 INSRT2: JRST    .+2             ;
 257 RLOOK3: SUB     TP,[4,,4]       ;POP OFF LOSSAGE
 258         PUSH    P,(TP)          ;GET BACK RET ADR
 259         SUB     TP,[2,,2]       ;POP TP
 260         JRST    IATM1           ;AND RETURN
 261 \f
 262 ;SUBROUTINE TO MAKE AN ATOM
 263
 264 MFUNCTION ATOM,SUBR
 265
 266         ENTRY   1
 267
 268         HLRZ    A,(AB)          ;CHECK ARG TYPE
 269         CAIE    A,TCHRS
 270         CAIN    A,TCHSTR
 271         JRST    .+2             ;JUMP IF WINNERS
 272         JRST    WRONGT
 273
 274         PUSHJ   P,CSTACK        ;COPY ONTO STACK
 275         PUSHJ   P,IATOM         ;NOW MAKE THE ATOM
 276         JRST    FINIS           ;AND LEAVE
 277
 278 ;INTERNAL ATOM MAKER
 279
 280 IATOM:  MOVE    A,-1(P)         ;GET WORDS IN PNAME
 281         ADDI    A,2             ;FOR VALUE CELL
 282         PUSH    TP,$TFIX
 283         PUSH    TP,A            ;LENGTH IS ARG
 284         MCALL   1,UVECTOR       ;GET STORAGE
 285         MOVSI   C,<(GENERAL)>+SATOM     ;FOR TYPE FIELD
 286         MOVE    D,-1(P)         ;RE-GOBBLE LENGTH
 287         ADDI    D,2(B)          ;POINT TO DOPE WORD
 288         MOVEM   C,(D)
 289         MOVE    E,B             ;COPY ATOM POINTER
 290         ADD     E,[2,,2]        ;POINT TO PNAME AREA
 291         MOVEI   C,-1(P)
 292         SUB     C,-1(P)         ;POINT TO STRING ON STACK
 293         MOVE    D,(C)           ;GET SOME CHARS
 294         MOVEM   D,(E)           ;AND COPY THEM
 295         ADDI    C,1
 296         AOBJN   E,.-3
 297         MOVSI   A,TATOM ;TYPE TO ATOM
 298 IATM1:  POP     P,D             ;RETURN ADR
 299         POP     P,C             ;WORDA OF CHARS
 300         HRLI    C,(C)
 301         SUB     P,C
 302         JRST    (D)             ;RETURN
 303
 304 \f
 305 ; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
 306
 307 MFUNCTION BLK,SUBR,BLOCK
 308
 309         ENTRY   1
 310
 311         HLRZ    A,(AB)  ;CHECK TYPE OF ARG
 312         CAIE    A,TOBLS ;IS IT AN OBLIST
 313         CAIN    A,TLIST ;OR A LIAT
 314         JRST    .+2
 315         JRST    WRONGT
 316         MOVSI   A,TATOM ;LOOK UP OBLIST
 317         MOVE    B,MQUOTE OBLIST
 318         PUSHJ   P,IDVAL ;GET VALUE
 319         PUSH    TP,A
 320         PUSH    TP,B
 321         PUSH    TP,.BLOCK(PVP)  ;HACK THE LIST
 322         PUSH    TP,.BLOCK+1(PVP)
 323         MCALL   2,CONS  ;CONS THE LIST
 324         MOVEM   A,.BLOCK(PVP)   ;STORE IT BACK
 325         MOVEM   B,.BLOCK+1(PVP)
 326         PUSH    TP,$TATOM
 327         PUSH    TP,MQUOTE OBLIST
 328         PUSH    TP,(AB)
 329         PUSH    TP,1(AB)
 330         MCALL   2,SET   ;SET OBLIST TO ARG
 331         JRST    FINIS
 332
 333 MFUNCTION ENDBLOCK,SUBR
 334
 335         ENTRY   0
 336
 337         SKIPN   B,.BLOCK+1(PVP) ;IS THE LIST NIL?
 338         JRST    BLKERR  ;YES,\0 LOSE
 339         HRRZ    C,(B)   ;CDR THE LIST
 340         HRRZM   C,.BLOCK+1(PVP)
 341         PUSH    TP,$TATOM       ;NOW RESET OBLIST
 342         PUSH    TP,MQUOTE OBLIST
 343         HLLZ    A,(B)   ;PUSH THE TYPE OF THE CAR
 344         PUSH    TP,A
 345         PUSH    TP,1(B) ;AND VALUE OF CAR
 346         MCALL   2,SET
 347         JRST    FINIS
 348
 349 BLKERR: PUSH    TP,$TATOM
 350         PUSH    TP,MQUOTE UNMATCHED
 351         JRST    CALER1
 352
 353 BADLST: PUSH    TP,$TATOM
 354         PUSH    TP,MQUOTE NIL-LIST-OF-OBLISTS
 355         JRST    CALER1
 356 \f
 357 ;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
 358
 359 CHMAK:  PUSH    TP,$TFIX        ;SET UP CALL TO UVECTOR
 360         PUSH    TP,-1(P)
 361         MCALL   1,UVECTOR
 362         MOVEI   C,-1(P)         ;FIND START OF CHARS
 363         SUB     C,-1(P)         ;C POINTS TO START
 364         MOVE    D,B             ;COPY VECTOR RESULT
 365         JUMPGE  D,NULLST        ;JUMP IF EMPTY
 366         MOVE    A,(C)           ;GET ONE
 367         MOVEM   A,(D)
 368         ADDI    C,1             ;BUMP POINTER
 369         AOBJN   D,.-3           ;COPY
 370 NULLST: MOVSI   C,TCHRS         ;GET TYPE
 371         MOVEM   C,(D)           ;CLOBBER IT IN
 372         MOVSI   A,TCHSTR        ;SETUP TYPE
 373         HRRI    A,1(D)          ;POINT TO DOPE
 374         HRLI    B,350700        ;MAKE A BYTE POINTER
 375         JRST    IATM1           ;RETURN
 376
 377 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.  TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT, THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
 378
 379 NXTDCL: GETYP   B,(A)           ;CHECK TYPE
 380         CAIE    B,TDEFER                ;LOSE IF NOT DEFERRED
 381         POPJ    P,
 382
 383         MOVE    B,1(A)          ;GET REAL BYTE POINTER
 384 CHRWRD: PUSH    P,C
 385         GETYP   C,(B)           ;CHECK IT IS CHSTR
 386         CAIE    C,TCHSTR
 387         JRST    CPOPJC          ;NO, QUIT
 388         PUSH    P,D
 389         PUSH    P,E
 390         PUSH    P,0
 391         MOVEI   E,0             ;INITIALIZE DESTINATION
 392         HRRZ    C,(B)           ;POINT TO DOPE WORD
 393         MOVE    B,1(B)          ;GET BYTE POINTER
 394         CAIN    C,1(B)          ;CHECK FULLNESS
 395         JRST    GOTDCL          ;RETURN NIL WORD
 396         MOVE    D,[440700,,E]   ;BYTE POINT TO E
 397         LDB     0,B             ;GET 1ST CHR
 398 CHLOOP: JUMPE   0,GOTDCL        ;FINISHED, WIN
 399         TRNE    E,377           ;WORD FULL?
 400         JRST    CHREXT          ;YES, LOSE
 401         IDPB    0,D             ;CLOBBER AWAY
 402         ILDB    0,B             ;AND GET NEXT
 403         CAILE   C,1(B)  ;FULL NOW?
 404         JRST    CHLOOP          ;NO, CONTINUE
 405
 406 GOTDCL: MOVE    B,E             ;RESULT TO B
 407         AOS     -4(P)           ;SKIP RETURN
 408 CPOPJ0: POP     P,0
 409         POP     P,E
 410         POP     P,D
 411 CPOPJC: POP     P,C
 412         POPJ    P,
 413
 414 CHREXT: TRO     E,1             ;MAKE IT LOOK FUNNY
 415         JRST    GOTDCL
 416
 417
 418
 419 END
 420 \f\f\f\f\ 3\f