<mdl.int>/decl.mid.102

   1
   2 TITLE DECLARATION PROCESSOR
   3
   4 RELOCA
   5
   6 .INSRT MUDDLE >
   7
   8 .GLOBAL STBL,TYPFND,TYPSGR,CHKDCL,TESTR,VALG,INCR1,TYPG,ISTRUC,TMATCH,SAT
   9 .GLOBAL TYPMIS,CHKAB,CHKARG,IGDECL,LOCQQ,APLQ,CALER,IEQUAL,IIGLOC,IGLOC
  10 .GLOBAL CHLOCI,INCONS,SPCCHK,OUTRNG,WTYP1,FLGSET,IGET,PVSTOR,SPSTOR,DSTORE
  11
  12 ; Subr to allow user to access the DECL checking code
  13
  14 MFUNCTION CHECKD,SUBR,[DECL?]
  15
  16         ENTRY   2
  17
  18         MOVE    C,(AB)
  19         MOVE    D,1(AB)
  20         MOVE    A,2(AB)
  21         MOVE    B,3(AB)
  22         PUSHJ   P,TMATCX        ; CHECK THEM
  23         JRST    IFALS
  24
  25 RETT:   MOVSI   A,TATOM
  26         MOVE    B,IMQUOTE T
  27         JRST    FINIS
  28
  29 RETF:
  30 IFALS:  MOVEI   B,0
  31         MOVSI   A,TFALSE
  32         JRST    FINIS
  33
  34 ; Subr to turn DECL checking on and off.
  35
  36 MFUNCTION %DECL,SUBR,[DECL-CHECK]
  37
  38         ENTRY
  39
  40         HRROI   E,IGDECL
  41         JRST    FLGSET
  42
  43 ; Change special unspecial normal mode
  44
  45 MFUNCTION SPECM%,SUBR,[SPECIAL-MODE]
  46
  47         ENTRY
  48
  49         CAMGE   AB,[-3,,]
  50         JRST    TMA
  51         MOVE    C,SPCCHK        ; GET CURRENT
  52         JUMPGE  AB,MODER        ; RET CURRENT
  53         GETYP   0,(AB)          ; CHECK IT IS ATOM
  54         CAIE    0,TATOM
  55         JRST    WTYP1
  56         MOVE    0,1(AB)
  57         MOVEI   A,1
  58         CAMN    0,MQUOTE UNSPECIAL
  59         MOVSI   A,(SETZ)
  60         CAMN    0,MQUOTE SPECIAL
  61         MOVEI   A,0
  62         JUMPG   A,WTYP1
  63         HLLM    A,SPCCHK
  64
  65 MODER:  MOVSI   A,TATOM
  66         MOVE    B,MQUOTE SPECIAL
  67         SKIPGE  C
  68         MOVE    B,MQUOTE UNSPECIAL
  69         JRST    FINIS
  70
  71 ; Function to turn special checking on and of
  72
  73 MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK]
  74
  75         ENTRY
  76         CAMGE   AB,[-3,,]
  77         JRST    TMA
  78
  79         MOVE    C,SPCCHK
  80         JUMPGE  AB,SCHEK1
  81
  82         MOVEI   A,0
  83         GETYP   0,(AB)
  84         CAIE    0,TFALSE
  85         MOVEI   A,1
  86         HRRM    A,SPCCHK
  87
  88 SCHEK1: TRNN    C,1
  89         JRST    IFALS
  90         JRST    RETT
  91
  92 ; Finction to set decls for GLOBAL values.
  93
  94 MFUNCTION GDECL,FSUBR
  95
  96         ENTRY   1
  97
  98         GETYP   0,(AB)
  99         CAIE    0,TLIST
 100         JRST    WTYP1
 101
 102         PUSH    TP,$TLIST
 103         PUSH    TP,1(AB)
 104         PUSH    TP,$TLIST
 105         PUSH    TP,[0]
 106         PUSH    TP,$TLIST
 107         PUSH    TP,[0]
 108
 109 GDECL1: INTGO
 110         SKIPN   C,1(TB)
 111         JRST    RETT
 112         HRRZ    D,(C)           ; MAKE SURE PAIRS
 113         JUMPE   D,GDECLL        ; LOSER, GO AWAY
 114         GETYP   0,(C)
 115         CAIE    0,TLIST
 116         JRST    GDECLL
 117         HRRZ    0,(D)
 118         MOVEM   0,1(TB)         ; READY FOR NEXT CALL
 119         MOVE    C,1(C)          ; SAVE ATOM LIST
 120         MOVEM   C,5(TB)
 121         MOVEM   D,3(TB)
 122
 123 GDECL2: INTGO
 124         SKIPN   C,5(TB)
 125         JRST    GDECL1          ; OUT OF ATOMS
 126         GETYP   0,(C)           ; IS THIS AN ATOM
 127         CAIE    0,TATOM
 128         JRST    GDECLL          ; NO, LOSE
 129         MOVE    B,1(C)
 130         HRRZ    C,(C)
 131         MOVEM   C,5(TB)
 132         PUSHJ   P,IIGLOC        ; GET ITS VAL (OR MAKE ONE)
 133         GETYP   0,(B)           ; UNBOUND?
 134         CAIE    0,TUNBOU
 135         JRST    CHKCUR          ; CHECK CURRENT VALUE
 136         MOVE    C,3(TB)         ; GET DECL
 137         HRRM    C,-2(B)
 138         JRST    GDECL2
 139
 140 CHKCUR: HRRZ    D,3(TB)
 141         GETYP   A,(D)
 142         MOVSI   A,(A)
 143         MOVE    E,B
 144         MOVE    B,1(D)
 145         MOVE    C,(E)
 146         MOVE    D,1(E)
 147         PUSH    TP,$TVEC
 148         PUSH    TP,E
 149         JSP     E,CHKAB
 150         PUSHJ   P,TMATCH
 151         JRST    TYPMI3
 152         MOVE    E,(TP)
 153         SUB     TP,[2,,2]
 154         MOVE    D,3(TB)
 155         HRRM    D,-2(E)
 156         JRST    GDECL2
 157
 158 TYPMI3: MOVE    E,(TP)          ; POINT BACK TO SLOT
 159         MOVE    A,-1(E)         ; ATOM TO A
 160         MOVE    B,1(E)
 161         MOVE    D,(E)           ; GET OLD VALUE
 162         MOVE    C,3(TB)
 163         JRST    TYPMIS          ; GO COMPLAIN
 164
 165 GDECLL: ERRUUO  EQUOTE BAD-ARGUMENT-LIST
 166
 167 MFUNCTION UNMANIFEST,SUBR
 168
 169         ENTRY
 170
 171         PUSH    P,[HLLZS -2(B)]
 172         JRST    MANLP
 173
 174 MFUNCTION MANIFEST,SUBR
 175
 176         ENTRY
 177
 178         PUSH    P,[HLLOS -2(B)]
 179 MANLP:  JUMPGE  AB,RETT
 180         GETYP   0,(AB)
 181         CAIE    0,TATOM
 182         JRST    WTYP
 183         MOVE    B,1(AB)
 184         PUSHJ   P,IIGLOC
 185         XCT     (P)
 186         ADD     AB,[2,,2]
 187         JRST    MANLP
 188
 189 MFUNCTION MANIFQ,SUBR,[MANIFEST?]
 190
 191         ENTRY   1
 192
 193         GETYP   0,(AB)
 194         CAIE    0,TATOM
 195         JRST    WTYP1
 196
 197         MOVE    B,1(AB)
 198         PUSHJ   P,IGLOC         ; GET POINTER IF ANY
 199         GETYP   0,A
 200         CAIN    0,TUNBOU
 201         JRST    RETF
 202         HRRZ    0,-2(B)
 203         CAIE    0,-1
 204         JRST    RETF
 205         JRST    RETT
 206
 207 MFUNCTION GETDECL,SUBR,[GET-DECL]
 208
 209         ENTRY   1
 210
 211         GETYP   0,(AB)
 212         CAIN    0,TOFFS
 213          JRST   GETDOF
 214         PUSHJ   P,GTLOC
 215         JRST    GTLOCA
 216
 217         HRRZ    C,-2(B)         ; GET GLOBAL DECL
 218 GETD1:  JUMPE   C,RETF
 219         CAIN    C,-1
 220         JRST    RETMAN
 221         GETYP   A,(C)
 222         MOVSI   A,(A)
 223         MOVE    B,1(C)
 224         JSP     E,CHKAB
 225         JRST    FINIS
 226 GETDOF: HLRZ    B,1(AB)
 227         JUMPE   B,GETDO1
 228         MOVE    A,(B)
 229         MOVE    B,1(B)
 230         JRST    FINIS
 231 GETDO1: MOVSI   A,TATOM
 232         MOVE    B,IMQUOTE ANY
 233         JRST    FINIS
 234
 235 RETMAN: MOVSI   A,TATOM
 236         MOVE    B,MQUOTE MANIFEST
 237         JRST    FINIS
 238
 239 GTLOCA: HLRZ    C,2(B)          ; LOCAL DECL
 240         JRST    GETD1
 241
 242 MFUNCTION PUTDECL,SUBR,[PUT-DECL]
 243
 244         ENTRY   2
 245
 246         GETYP   0,(AB)
 247         CAIN    0,TOFFS
 248          JRST   PUTDOF          ; MAKE OFFSET WITH NEW DECL
 249         PUSHJ   P,GTLOC
 250         SKIPA   E,[HRLM B,2(C)]
 251         MOVE    E,[HRRM B,-2(C)]
 252         PUSH    P,E
 253         GETYP   0,(B)           ; ANY VALUE
 254         CAIN    0,TUNBOU
 255         JRST    PUTD1
 256         MOVE    C,(B)           ; GET CURRENT VALUE
 257         MOVE    D,1(B)
 258         MOVE    A,2(AB)
 259         MOVE    B,3(AB)
 260         PUSHJ   P,TMATCH
 261         JRST    TYPMI4
 262 PUTD1:  MOVE    C,2(AB)         ; GET DECL BACK
 263         MOVE    D,3(AB)
 264         PUSHJ   P,INCONS        ; CONS IT UP
 265         MOVE    C,1(AB)         ; LOCATIVE BACK
 266         XCT     (P)             ; CLOBBER
 267         MOVE    A,(AB)
 268         MOVE    B,1(AB)
 269         JRST    FINIS
 270
 271 TYPMI4: MOVE    E,1(AB)         ; GET LOCATIVE
 272         MOVE    A,-1(E)         ; NOW ATOM
 273         MOVEI   C,2(AB)         ; POINT TO DECL
 274         MOVE    D,(E)           ; AND CURRENT VAL
 275         MOVE    B,1(E)
 276         JRST    TYPMIS
 277
 278 GTLOC:  GETYP   0,(AB)
 279         CAIE    0,TLOCD
 280         JRST    WTYP1
 281         MOVEI   B,(AB)
 282         PUSHJ   P,CHLOCI
 283         HRRZ    0,(AB)          ; LOCAL OR GLOBAL
 284         SKIPN   0
 285         AOS     (P)
 286         MOVE    B,1(AB)         ; RETURN LOCATIVE IN B
 287         POPJ    P,
 288
 289 ; MAKE OFFSET WITH SUPPLIED DECL
 290 PUTDOF: MOVE    D,3(AB)
 291         GETYP   0,2(AB)
 292         CAIN    TATOM
 293          CAME   D,IMQUOTE ANY
 294           JRST  PUTDO1
 295         MOVSI   A,TOFFS
 296         HRRZ    B,1(AB)
 297         JRST    FINIS
 298 PUTDO1: MOVE    C,2(AB)
 299         PUSHJ   P,INCONS        ; BUILD A LIST
 300         MOVSI   A,TOFFS
 301         HRLS    B
 302         HRR     B,1(AB)         ; SET UP OFFSET
 303         JRST    FINIS
 304
 305 ; BUILD AN OFFSET--TAKES FIX AND DECL (OR ATOM FORM)
 306 ; JUMPS INTO PUT-DECL CODE FOR OFFSETS.
 307         MFUNCTION COFFSET,SUBR,[OFFSET]
 308
 309         ENTRY   2
 310         GETYP   0,(AB)
 311         CAIE    0,TFIX
 312          JRST   WTYP1
 313         SKIPG   1(AB)
 314          JRST   OUTRNG          ; CAN'T HAVE NEGATIVE OFFSETS
 315         GETYP   0,2(AB)
 316         CAIE    0,TATOM
 317          CAIN   0,TFORM
 318           JRST  PUTDOF
 319         JRST    WTYP2
 320
 321 ; GET FIX PART OF OFFSET
 322         MFUNCTION INDEX,SUBR
 323
 324         ENTRY   1
 325         GETYP   0,(AB)
 326         CAIE    0,TOFFS
 327          JRST   WTYP1
 328         MOVSI   A,TFIX
 329         HRRE    B,1(AB)
 330         JRST    FINIS
 331 \f
 332 ; Interface between EVAL and declaration processor.
 333 ; E points into stack at a binding and C points to decl list.
 334
 335 CHKDCL: SKIPE   IGDECL          ; IGNORING DECLS?
 336         POPJ    P,              ; YUP, JUST LEAVE
 337
 338         PUSH    TP,$TTP         ; SAVE BINDING
 339         PUSH    TP,E
 340         MOVE    A,-4(E)         ; GET ATOM
 341         MOVSI   0,TLIST         ; SETUP FOR INTERRUPTABLE
 342         MOVE    PVP,PVSTOR+1
 343         MOVEM   0,CSTO(PVP)
 344         MOVEM   0,BSTO(PVP)
 345         MOVSI   0,TATOM
 346         MOVEM   0,ASTO(PVP)
 347         SETZB   B,0             ; CLOBBER FOR INTGO
 348
 349 DCL2:   INTGO
 350         HRRZ    D,(C)           ; MAKE SURE EVEN ELEMENTS
 351         JUMPE   D,BADCL
 352         GETYP   B,(C)           ; MUST BE LIST OF ATOMS
 353         CAIE    B,TLIST
 354         JRST    BADCL
 355         MOVE    B,1(C)          ; GET LIST
 356
 357 DCL1:   INTGO
 358         CAMN    A,1(B)          ; SKIP IF NOT WINNER
 359         JRST    DCLQ            ; MAY BE WINNER
 360 DCL3:   HRRZ    B,(B)           ; CDR ON
 361         JUMPN   B,DCL1          ; JUMP IF MORE
 362
 363         HRRZ    C,(D)           ; CDR MAIN LIST
 364         JUMPN   C,DCL2          ; AND JUMP IF WINNING
 365
 366         PUSHJ   P,E.GET         ; GET BINDING BACK
 367         SUB     TP,[2,,2]       ; POP OF JUNK
 368         POPJ    P,
 369
 370 DCLQ:   GETYP   C,(B)           ; CHECK ATOMIC
 371         CAIE    C,TATOM
 372         JRST    BADCL           ; LOSER
 373         PUSHJ   P,E.GET         ; GOT IT
 374         PUSH    TP,$TLIST       ; SAVE PATTERN
 375         PUSH    TP,D
 376         MOVE    B,1(D)          ; GET PATTERN
 377         HLLZ    A,(D)
 378         MOVE    C,-3(E)         ; PROPOSED VALUE
 379         MOVE    D,-2(E)
 380         PUSHJ   P,TMATCH        ; MATCH TYPE
 381         JRST    TYPMI1          ; LOSER
 382 DCLQ1:  MOVE    E,-2(TP)
 383         MOVE    C,-5(E)         ; CHECK FOR SPEC CHANGE
 384         SKIPE   0               ; MAKE SURE NON ZERO IS -1
 385         MOVNI   0,1
 386         SKIPL   SPCCHK          ; SKIP IF NORMAL UNSPECIAL
 387         SETCM   0               ; COMPLEMENT
 388         ANDI    0,1             ; ONE BIT
 389         CAMN    C,[TATOM,,-1]
 390         JRST    .+3
 391         CAME    C,[TATOM,,-2]
 392         JRST    .+3
 393         ANDCMI  C,1
 394         IOR     C,0             ; MUNG BIT
 395         MOVEM   C,-5(E)
 396         HRRZ    C,(TP)
 397         SUB     TP,[4,,4]
 398         MOVEM   C,(E)           ; STORE DECLS
 399         MOVSI   C,TLIST
 400         MOVEM   C,-1(E)
 401         POPJ    P,
 402
 403 TYPMI1: MOVE    E,-2(TP)
 404         GETYP   C,-3(E)
 405         CAIN    C,TUNBOU
 406         JRST    DCLQ1
 407         MOVE    E,-2(TP)        ; GET POINTER TO BIND
 408         MOVE    D,-3(E)         ; GET VAL
 409         MOVE    B,-2(E)
 410         HRRZ    C,(TP)          ; DCL LIST
 411         MOVE    A,-4(E)         ; GET ATOM
 412         SUB     TP,[4,,4]
 413 TYPMIS: PUSH    TP,$TATOM
 414         PUSH    TP,EQUOTE TYPE-MISMATCH
 415         PUSH    TP,$TATOM
 416         PUSH    TP,A
 417         PUSH    TP,(C)
 418         HLLZS   (TP)
 419         PUSH    TP,1(C)
 420         JSP     E,CHKARG        ; HACK DEFER
 421         PUSH    TP,D
 422         PUSH    TP,B
 423         MOVEI   A,4             ; 3 ERROR ARGS
 424         JRST    CALER
 425
 426 BADCL:  PUSHJ   P,E.GET
 427         ERRUUO  EQUOTE BAD-DECLARATION-LIST
 428
 429 ; ROUTINE TO RESSET INT STUFF
 430
 431 E.GET:  MOVE    E,(TP)
 432         MOVE    PVP,PVSTOR+1
 433         SETZM   ASTO(PVP)
 434         SETZM   BSTO(PVP)
 435         SETZM   CSTO(PVP)
 436         POPJ    P,
 437
 438 ; Declarations processor for MUDDLE type declarations.
 439 ; Receives a pattern in a and B and an object in C and D.
 440 ; It skip returns if the object fits otherwise it doesn't.
 441 ; Declaration syntax errors are caught and sent to ERROR.
 442
 443 TMATCH: MOVEI   0,1             ; RET SPECIAL INDICATOR
 444         SKIPE   IGDECL          ; IGNORING DECLS?
 445         JRST    CPOPJ1          ; YUP, ACT LIKE THEY WON
 446
 447 TMATCX: GETYP   0,A             ; GET PATTERNS TYPE
 448         CAIE    0,TSEG
 449         CAIN    0,TFORM         ; MUST BE FORM OR ATOM
 450         JRST    TMAT1
 451         CAIE    0,TATOM
 452         JRST    TERR1           ; WRONG TYPE FOR A DCL
 453
 454 ; SIMPLE TYPE MATCHER
 455
 456 TYPMAT: GETYP   E,C             ; OBJECTS TYPE TO E
 457         PUSH    P,E             ; SAVE IT
 458         PUSH    TP,C
 459         PUSH    TP,D
 460         PUSHJ   P,TYPFND        ; CONVERT TYPE NAME TO CODE
 461         JRST    SPECS           ; NOT A TYPE NAME, TRY SPECIALS
 462         SUB     TP,[2,,2]
 463         POP     P,E             ; RESTORE TYPE OF OBJECT
 464         MOVEI   0,0             ; SPECIAL INDICATOR
 465         CAIN    E,(D)           ; SKIP IF LOSERS
 466 CPOPJ1: AOS     (P)             ; GOOD RETURN
 467 CPOPJ:  POPJ    P,
 468
 469 SPECS:  POP     P,A             ; RESTORE OBJECTS TYPE
 470         POP     TP,D
 471         POP     TP,C
 472         CAMN    B,IMQUOTE ANY
 473         JRST    CPOPJ1          ; RETURN IMMEDIATELY IF ANYTHING WINS
 474         CAMN    B,IMQUOTE STRUCTURED
 475         JRST    ISTRUC          ; LET ISTRUC DO THE WORK
 476         CAMN    B,IMQUOTE APPLICABLE
 477         JRST    APLQ
 478         CAMN    B,IMQUOTE LOCATIVE
 479         JRST    LOCQQ
 480         PUSH    TP,$TATOM
 481         PUSH    TP,B
 482         PUSH    TP,C
 483         PUSH    TP,D
 484         MOVSI   A,TATOM
 485         MOVSI   C,TATOM
 486         MOVE    D,IMQUOTE DECL
 487         PUSHJ   P,IGET
 488         JUMPE   B,TERR2X
 489         MOVEM   A,-3(TP)
 490         MOVEM   B,-2(TP)
 491         INTGO
 492         POP     TP,D
 493         POP     TP,C
 494         POP     TP,B
 495         POP     TP,A
 496         JRST    TMATCX
 497
 498 ; ARRIVE HERE FOR A FORM IN THE DCLS
 499
 500 TMAT1:  JUMPE   B,TERR3         ; EMPTY FORM LOSES
 501         HRRZ    E,(B)           ; CDR IT
 502         JUMPE   E,TMAT3         ; CANT BE SPECIAL/UNSPECIAL, LEAVE
 503         PUSHJ   P,0ATGET        ; GET POSSIBLE ATOM IN 0
 504         JRST    TEXP1           ; NOT ATOM
 505         CAME    0,MQUOTE SPECIAL
 506         CAMN    0,MQUOTE UNSPECIAL
 507         JRST    TMAT2           ; IGNORE SPECIAL/UNSPECIAL
 508 TMAT3:  PUSHJ   P,TEXP1
 509         JRST    .+2
 510         AOS     (P)
 511         MOVEI   0,0             ; RET UNSPECIAL INDICATION
 512         POPJ    P,
 513
 514 TEXP1:  JUMPE   B,TERR3         ; EMPTY FORM
 515         GETYP   E,A             ; CHECK CURRENT TYPE
 516         CAIN    E,TATOM         ; IF ATOM,
 517         JRST    TYPMA1          ; SIMPLE MATCH
 518         CAIN    E,TSEG
 519         JRST    .+3
 520         CAIE    E,TFORM
 521         JRST    TERR4
 522         GETYP   0,(B)           ; WHAT IS FIRST ELEMEMT
 523         CAIE    0,TFORM         ; FORM=> <<OR ..>....> OR <<PRIMTYPE FOO>....>
 524         JRST    TEXP12
 525         PUSH    TP,$TLIST       ; SAVE LIST
 526         PUSH    TP,B
 527         MOVE    B,1(B)          ; GET FORM
 528         PUSH    TP,C
 529         PUSH    TP,D
 530         PUSH    P,E
 531         PUSHJ   P,ACTRT1
 532         TDZA    0,0             ; REMEMBER LACK OF SKIP
 533         MOVEI   0,1
 534         POP     P,E
 535         POP     TP,D
 536         POP     TP,C
 537         MOVE    B,(TP)          ; GET BACK SAVED LIST
 538         SUB     TP,[2,,2]
 539         JUMPE   0,CPOPJ         ; LOSERS EXIT IMMEDIATELY
 540         HRRZ    B,(B)           ; OTHERWISE REST THE LIST AND FALL INTO ELETYPE
 541
 542 ; CHECKS TYPES OF ELEMENTS OF STRUCTURES
 543
 544 ELETYP: CAIE    E,TSEG          ; MUST BE EXAXT?
 545         JUMPE   B,CPOPJ1        ; EMPTY=> WON
 546         PUSH    TP,$TLIST       ; SAVE DCL LIST
 547         PUSH    TP,B
 548         MOVE    A,C             ; GET OBJ IN A AND B
 549         MOVE    B,D
 550         CAIE    E,TSEG
 551         TDZA    E,E
 552         MOVNI   E,1
 553         PUSH    P,E
 554         PUSHJ   P,TYPSGR        ; GET REST/NTH CODE
 555         JRST    ELETYL          ; LOSER
 556         CAIN    C,5             ; BYTE STRING COMES HERE
 557         JRST    ELEBYT          ; HACK IT
 558         PUSH    TP,DSTORE
 559         PUSH    TP,D
 560         PUSH    P,C             ; SAVE CODE
 561         PUSH    TP,[0]          ; AND SLOTS
 562         PUSH    TP,[0]
 563
 564 ; MAIN ELEMENT SCANNING LOOP
 565
 566 ELETY1: XCT     TESTR(C)        ; SKIP IF OBJ NOT EMPTY
 567         JRST    ELETY2          ; CHEK EMPTY WINNER
 568         SKIPN   -4(TP)
 569         JRST    ELETY4
 570         XCT     TYPG(C)         ; GET ELEMENT
 571         XCT     VALG(C)
 572         JSP     E,CHKAB         ; CHECK OUT DEFER
 573         MOVEM   A,-1(TP)        ; AND SAVE IT
 574         MOVEM   B,(TP)
 575         MOVE    C,A
 576         MOVE    D,B             ; FOR OTHER MATCHERS
 577         MOVE    B,-4(TP)        ; GET PATTERN
 578         MOVE    A,(B)
 579         GETYP   0,(B)           ; GET TYPE OF <1 pattern>
 580         MOVE    B,1(B)          ; GET ATOM OR WHATEVER
 581         CAIE    0,TATOM         ; ATOM ... SIMPLE TYPE
 582         JRST    ELETY3
 583         PUSHJ   P,TYPMAT        ; DO SIMPLE TYPE MATCH
 584         JRST    ELETY4          ; LOSER
 585
 586 ; HERE TO REST EVERYTHING AND GO ON BACK
 587
 588 ELETY6: MOVE    D,-2(TP)        ; GET OBJ POINTER
 589         MOVE    C,(P)           ; GET INCREMENT CODE
 590         XCT     INCR1(C)
 591         MOVEM   D,-2(TP)        ; SAVED INCREMENTED GOODIR
 592         MOVE    0,DSTORE
 593         MOVEM   0,-3(TP)
 594
 595 ELETY9: HRRZ    B,@-4(TP)       ; CDR IT
 596         MOVEM   B,-4(TP)
 597         JUMPN   B,ELETY1
 598
 599         SKIPN   -1(P)           ; SKIP IF EXACT REQUIRED
 600         JRST    ELETY8
 601         XCT     TESTR(C)
 602         JRST    ELETY8
 603         JRST    ELETY4
 604
 605
 606 ; HERE IF PATTERN EMPTY
 607
 608 ELETY8: AOS     -2(P)           ; SKIP RETURN
 609 ELETY4: SETZM   DSTORE
 610         SUB     P,[2,,2]
 611         SUB     TP,[6,,6]
 612         POPJ    P,
 613
 614 ELETYL: SUB     P,[1,,1]
 615         SUB     TP,[2,,2]
 616         POPJ    P,
 617
 618 ; HERE TO HANDLE EMPTY OBJECT
 619
 620 ELETY2: MOVE    B,-4(TP)        ; GET PATTERN
 621         JUMPE   B,ELETY8
 622         GETYP   0,(B)           ; CHECK FOR [REST ...]
 623         SETZM   DSTORE
 624         CAIE    0,TVEC
 625         JRST    ELETY4          ; LOSER
 626         HLRZ    0,1(B)          ; SIZE OF IT
 627         CAILE   0,-4            ; MUST BE 2
 628         JRST    ELETY4
 629         MOVE    B,1(B)          ; GET IT
 630         PUSHJ   P,0ATGET        ; LOOK FOR REST
 631         JRST    ELETY4
 632         CAMN    0,MQUOTE OPTIONAL
 633         JRST    ELETY8
 634         CAME    0,MQUOTE OPT
 635         CAMN    0,IMQUOTE REST
 636         JRST    ELETY8          ; WINNER!!!!
 637         JRST    ELETY4          ; LOSER
 638
 639 ; HERE TO CHECK OUT A FORM ELEMNT
 640
 641 ELETY3: CAIN    0,TSEG
 642         JRST    ELGO
 643         CAIE    0,TFORM
 644         JRST    ELETY7
 645 ELGO:   SETZM   DSTORE
 646         PUSHJ   P,TEXP1         ; AND ANALYSE IT
 647         JRST    ELETY4          ; LOSER
 648         MOVE    0,-3(TP)        ; RESET DSTO
 649         MOVEM   0,DSTORE
 650         JRST    ELETY6          ; WINNER
 651
 652 ; CHECK FOR VECTOR IN PATTERN
 653
 654 ELETY7: CAIE    0,TVEC          ; SKIP IF WINNER
 655         JRST    TERR12          ; YET ANOTHER ERROR
 656         HLRE    C,B             ; CHECK LEENGTH
 657         CAMLE   C,[-4]          ; MUST BE 2 LONG
 658         JRST    TERR13
 659         PUSHJ   P,0ATGET        ; 1ST ELEMENT ATOM?
 660         JRST    ELET71          ; COULD BE FORM
 661         CAME    0,MQUOTE OPT
 662         CAMN    0,MQUOTE OPTIONAL
 663         JRST    ELET72
 664         CAME    0,IMQUOTE REST
 665         JRST    TERR14
 666         MOVE    0,(P)           ; GET STRUC CODE
 667         CAIN    0,2
 668         CAME    C,[-4]
 669         JRST    ELNUVE
 670
 671         GETYP   0,2(B)          ; SEE IF UVECTOR REST SIMPLE TYPE
 672         CAIE    0,TATOM
 673         JRST    ELNUVE
 674
 675         MOVE    C,3(B)          ; GET ATOM
 676         HLRE    0,C
 677         SUB     C,0             ; POINT TO DOPE WDS
 678         HRRE    0,(C)
 679         JUMPE   0,ELNUVE
 680         MOVSI   A,TATOM
 681         MOVE    B,3(B)
 682         MOVE    C,-2(TP)
 683         HLRE    D,C
 684         SUB     C,D
 685         GETYP   C,(C)
 686         MOVSI   C,(C)
 687         PUSHJ   P,TMATCX
 688         JRST    ELETY4
 689         JRST    ELETY8
 690
 691 ELNUVE: TDOA    0,[-1]
 692 ELET72: MOVSI   0,(SETZ)        ; FLAG USED IN RESTIT
 693         PUSH    P,0
 694         PUSHJ   P,RESTIT        ; CHECK REST OF STRUCTUR
 695         JRST    ELET41
 696         POP     P,0
 697         TRNE    0,-1
 698         JRST    ELETY8          ; WIN AND DONE
 699         JRST    ELET81
 700
 701 ELET41: SUB     P,[1,,1]
 702         JRST    ELETY4
 703
 704 ; CHECK FOR [fix .... ]
 705
 706 ELET71: CAIE    0,TFIX
 707         JRST    TERR15
 708         MOVNS   C
 709         ASH     C,-1
 710         MOVE    0,1(B)          ; GET NUMBER
 711         IMULI   0,-1(C)         ; COUNT MORE
 712         PUSH    P,0
 713         PUSHJ   P,RESTIT        ; AND CHECK FIX NUM OF ELEMENTS
 714         TDZA    0,0
 715         MOVEI   0,1
 716         SUB     P,[1,,1]
 717         JUMPE   0,ELETY4
 718 ELET81: MOVE    D,-2(TP)        ; GET OBJECT BACK
 719         MOVE    0,-3(TP)        ; RESET DSTO
 720         MOVEM   0,DSTORE
 721         MOVE    C,(P)           ; RESTORE CODE FOR RESTING ETC.
 722         JRST    ELETY9
 723
 724
 725 ; HERE TO DO A TASTEFUL TYPMAT
 726
 727 TYPMA1: PUSH    TP,C
 728         PUSH    TP,D
 729         PUSHJ   P,TYPMAT
 730         TDZA    0,0             ; REMEMBER LOSSAGE
 731         MOVEI   0,1             ; OR WINNAGE
 732         POP     TP,D
 733         POP     TP,C            ; RESTORE OBJECT
 734         JUMPN   0,CPOPJ1        ; SKIPPED BEFORE, SKIP AGAIN
 735         POPJ    P,
 736
 737 ; HERE TO SKIP SPECIAL/UNSPECIAL
 738
 739 TMAT2:  CAME    0,MQUOTE SPECIAL
 740         TDZA    0,0
 741         MOVEI   0,1
 742         PUSH    P,0             ; SAVE INDICATOR
 743         HRRZ    A,(E)           ; CHECK FOR EXACT LENGTH
 744         JUMPN   A,TERR16
 745         GETYP   A,(E)           ; TYPE OF NEW PAT
 746         MOVE    B,1(E)          ; VALUE
 747         MOVSI   A,(A)
 748         PUSHJ   P,TEXP1
 749         JRST    .+2
 750         AOS     -1(P)
 751         POP     P,0
 752         POPJ    P,
 753
 754 ; LOOK FOR <OR...   OR <PRIMTYPE....
 755
 756 TEXP12: CAIE    0,TATOM
 757         JRST    TERR5
 758         MOVE    0,1(B)          ; GET ATOM
 759         CAMN    0,IMQUOTE QUOTE
 760         JRST    MQUOT           ; MATCH A QUOTED OBJECT
 761         CAME    0,IMQUOTE OR
 762         CAMN    0,IMQUOTE PRIMTYPE
 763         JRST    ACTORT          ; FALL INTO ACTOR HACKER
 764         PUSH    TP,$TLIST
 765         PUSH    TP,B
 766         MOVE    B,0             ; GET ATOM
 767         PUSH    TP,C            ; SAVE OBJ
 768         PUSH    TP,D
 769         PUSH    P,E
 770         PUSHJ   P,TYPMAT
 771         TDZA    0,0
 772         MOVEI   0,1
 773         POP     P,E
 774         MOVE    C,-1(TP)
 775         MOVE    D,(TP)
 776         MOVE    B,-2(TP)
 777         JUMPN   0,.+3           ; TO ELETYP IF WON
 778         SUB     TP,[4,,4]
 779         POPJ    P,              ; ELSE LOSE
 780
 781         HRRZ    0,(B)
 782         MOVSI   A,TFORM
 783         JUMPE   0,TERR3
 784         MOVE    B,0
 785         PUSHJ   P,ELETYP
 786 FOOPC:  TDZA    0,0
 787         MOVEI   0,1
 788 POPPIT: POP     TP,D
 789         POP     TP,C
 790         POP     TP,B
 791         POP     TP,A
 792         JUMPN   0,CPOPJ1
 793         POPJ    P,
 794
 795 ; THIS CODE HANDLES ORs AND PRIMTYPEs
 796 ACTRT1: SKIPA   E,[SETZ PACT]
 797
 798 ACTORT: MOVE    E,[SETZ TEXP1]
 799         JUMPE   B,TERR6         ; EMPTY, LOSE
 800         PUSHJ   P,0ATGET        ; ATOM TO 0
 801         JRST    PACT
 802         CAME    0,IMQUOTE OR
 803         JRST    PACT2
 804         HRRZ    0,(B)           ; REST IT FLUSHING OR
 805         JUMPE   0,TERR7
 806         PUSH    TP,$TLIST       ; SAVE LSIT
 807         PUSH    TP,0
 808         PUSH    P,E             ; SAVE ELEMENT CHECKER
 809
 810 ORLP:   SKIPN   B,(TP)          ; ANY LEFT?
 811         JRST    ORDON           ; NOPE, LOSE
 812         HRRZ    0,(B)           ; SAVE THE REST
 813         MOVEM   0,(TP)
 814         GETYP   0,(B)           ; WHAT ARE WE ORing
 815         MOVE    A,(B)           ; TYPE WORD
 816         MOVE    B,1(B)          ; AND ITEM
 817         PUSH    TP,C
 818         PUSH    TP,D
 819         PUSHJ   P,@(P)          ; EITHER PACT OR TEXP1
 820         TDZA    0,0
 821         MOVEI   0,1
 822         POP     TP,D
 823         POP     TP,C
 824         JUMPE   0,ORLP
 825         AOS     -1(P)           ; SKIP RETURN FOR WINNER
 826
 827 ORDON:  SUB     TP,[2,,2]       ; FLUSH TEMP
 828         SUB     P,[1,,1]
 829         POPJ    P,
 830
 831 ; HERE TO PRIMTYPE ACTORS
 832
 833 PACT:   CAIE    0,TFORM
 834         JRST    PACT1
 835         JUMPE   B,TERR6         ; EMPTY FORM
 836         MOVE    0,1(B)          ; FIRST ELEMENT MUST BE PRIMTYPE
 837 PACT2:  CAME    0,IMQUOTE PRIMTYPE
 838         JRST    TERR7
 839         HRRZ    A,(B)           ; GET PRIMTYPE
 840         JUMPE   A,TERR7
 841         HRRZ    0,(A)
 842         JUMPN   0,TERR18
 843         MOVEI   B,(A)
 844         GETYP   A,C             ; GET OBJ TYPE
 845         GETYP   0,(B)           ; GET PATTERN TYPE
 846         CAIE    0,TATOM         ; BETTER BE ATOM
 847         JRST    TERR8
 848         PUSH    TP,$TLIST       ; SAVE DCL LIST
 849         PUSH    TP,B
 850         PUSH    TP,C
 851         PUSH    TP,D
 852         PUSHJ   P,SAT           ; GET STORAGE TYPE
 853         CAILE   A,NUMSAT
 854         JRST    PTEMP
 855         MOVE    B,@STBL(A)      ; GET PRIM NAME
 856         PUSHJ   P,TYPFND
 857         JFCL                    ; MUST EXIST
 858         MOVSI   C,(D)           ; FAKE OUT TYPMAT
 859         MOVE    B,-2(TP)
 860         MOVE    B,1(B)
 861         PUSHJ   P,TYPMAT
 862         JRST    .+2
 863         AOS     (P)
 864         MOVE    C,-1(TP)
 865         MOVE    D,(TP)
 866         SUB     TP,[4,,4]
 867         POPJ    P,
 868
 869 PACT1:  CAIE    0,TATOM
 870         JRST    TERR4
 871         JRST    TYPMAT
 872
 873 PTEMP:  MOVE    B,-2(TP)
 874         MOVE    B,1(B)
 875         CAMN    B,IMQUOTE TEMPLATE
 876         AOS     (P)
 877         SUB     TP,[4,,4]
 878         POPJ    P,
 879
 880 ; RESTIT - TYPE CHECK SELECTED NUMBER OF ELEMENTS IN STRUCTURE
 881
 882 RESTIT: PUSH    TP,$TVEC        ; SAVE TYPE
 883         ADD     B,[2,,2]        ; SKIP OVER CRUFT
 884         PUSH    TP,B            ; AND VAL
 885         PUSH    TP,$TVEC
 886         PUSH    TP,B
 887 RESTI1: PUSH    P,A             ; SAVE DISP HACK
 888         PUSH    P,0             ; AND COUNT HACK
 889 RESTI4: SKIPL   (P)             ; SKIP IF DOING ALL
 890         SOSL    (P)             ; SKIP IF DONE
 891         JRST    RESTI6
 892         AOS     -2(P)           ; SKIP RET
 893 RESTI5: SUB     P,[2,,2]        ; POP JUNK
 894         SUB     TP,[4,,4]
 895         POPJ    P,
 896 RESTI6: SKIPGE  (TP)
 897         JRST    RESTX1
 898         HLRZ    0,(P)
 899         CAIN    0,(SETZ)
 900         JRST    RESTI2
 901 RESTX1: MOVE    C,-4(P)         ; REST CODE
 902         MOVE    D,-6(TP)        ; SET UP FOR REST
 903         MOVE    E,-7(TP)        ; DONT FORGET DSTO
 904         MOVEM   E,DSTORE
 905         XCT     TESTR(C)        ; DONE?
 906         JRST    RESTI2          ; YES, CHECK WINNAGE
 907         XCT     TYPG(C)
 908         XCT     VALG(C)         ; GET VAL ANDTYPE
 909         JSP     E,CHKAB         ; CHECK DEFER
 910         XCT     INCR1(C)        ; REST IT
 911         MOVEM   D,-6(TP)        ; SAVE LIST
 912         MOVE    E,DSTORE
 913         MOVEM   E,-7(TP)        ; FIXUP
 914         SETZM   DSTORE
 915         MOVE    C,A
 916         MOVE    D,B
 917         SKIPL   A,(TP)          ; ANY MORE?
 918         MOVE    A,-2(TP)        ; NO RECYCLE
 919         ADD     A,[2,,2]        ; BUMP
 920         MOVEM   A,(TP)          ; AND SAVE
 921         MOVE    B,-1(A)         ; GET ELEMENT
 922         MOVE    A,-2(A)
 923         GETYP   0,A
 924         MOVEI   E,TERR15
 925         CAIN    0,TATOM
 926         MOVEI   E,TYPMAT        ; ATOM --> SIMPLE TYPE
 927         CAIE    0,TSEG
 928         CAIN    0,TFORM         ; FORM--> HAIRY PATTERN
 929         MOVEI   E,TEXP1
 930         TLO     E,400000
 931         PUSHJ   P,(E)           ; DO IT
 932         JRST    RESTI5
 933         JRST    RESTI4
 934
 935 RESTI2: SKIPGE  (P)             ; SKIP IF WON
 936         AOS     -2(P)           ; COUNTERACT CPOPJ1
 937         JRST    RESTI5
 938
 939 RESTI3: TEXP1
 940         TYPMAT
 941
 942 ; HERE TO MATHC A QUOTED OBJ
 943 ;       B/ FORM QUOTE...  C,D/ OBJECT TO MATCH AGAINST
 944
 945 MQUOT:  HRRZ    B,(B)           ; LOOK AT NEXT
 946         JUMPE   B,TERR7
 947         GETYP   A,(B)           ; GET TYPE
 948         MOVSI   A,(A)
 949         MOVE    B,1(B)          ; AND VALUE
 950         JSP     E,CHKAB         ; HACK DEFER
 951         PUSH    TP,A
 952         PUSH    TP,B
 953         PUSH    TP,C
 954         PUSH    TP,D
 955         MOVEI   D,-3(TP)
 956         MOVEI   C,-1(TP)
 957         PUSHJ   P,IEQUAL
 958         TDZA    0,0
 959         MOVEI   0,1
 960         JRST    POPPIT
 961
 962 ; HERE TO HANDLE SPECIAL BYTE STRING HAIR
 963
 964 ELEBYT: MOVE    B,(TP)          ; GET DECL LIST BACK
 965         POP     P,E             ; EXACTNESS FLAG
 966         JUMPE   B,ELEBY2
 967         GETYP   0,(B)
 968         CAIE    0,TFIX
 969         JRST    TERR17
 970         MOVE    A,1(B)
 971         HRRZ    B,(B)
 972         HRRZ    0,(B)
 973         SKIPE   B
 974         JUMPN   0,TERR17
 975         LDB     C,[300600,,D]   ; GET BYTE SIZE
 976         CAIE    A,(C)
 977         JRST    ELEBY3
 978         HRRZ    C,DSTORE
 979 ELEBY2: MOVEI   A,0
 980         JUMPE   B,ELEBY4
 981         GETYP   0,(B)
 982         CAIE    0,TFIX
 983         JRST    TERR17
 984         MOVE    A,1(B)
 985 ELEBY4: CAIGE   C,(A)
 986         JRST    ELEBY3
 987         CAIE    A,(C)
 988         JUMPN   E,ELEBY3
 989         AOS     (P)
 990 ELEBY3: SETZM   DSTORE
 991         SUB     TP,[2,,2]
 992         POPJ    P,
 993
 994
 995
 996 ; GET ATOM IN AC 0
 997
 998 0ATGET: GETYP   0,(B)
 999         CAIE    0,TATOM         ; SKIP IF ATOM
1000         POPJ    P,
1001         MOVE    0,1(B)          ; GET ATOM
1002         JRST    CPOPJ1
1003
1004 TERR17: MOVE    B,-2(TP)
1005         MOVE    B,1(B)
1006         HRRZ    0,(P)
1007         CAIN    0,FOOPC
1008         MOVE    B,-4(TP)
1009         MOVSI   A,TFORM
1010         MOVE    E,EQUOTE BAD-BYTES-DECL
1011         SETZM   DSTORE
1012         JRST    TERRD
1013
1014 TERR18: SKIPA   E,EQUOTE TOO-MANY-ARGS-TO-PRIMTYPE-DECL
1015 TERR16: MOVE    E,EQUOTE TOO-MANY-ARGS-TO-SPECIAL-UNSPECIAL-DECL
1016         MOVSI   A,TFORM
1017         JRST    TERRD
1018
1019 TERR9:  MOVS    A,0             ; TYPE TO A
1020 TERR4:
1021 TERR5:
1022 TERR15:
1023 TERR1:  MOVE    E,EQUOTE DECL-ELEMENT-NOT-FORM-OR-ATOM
1024         JRST    TERRD
1025
1026 TERR2X: SUB     TP,[2,,2]
1027         POP     TP,B
1028         POP     TP,A
1029
1030 TERR2:  MOVSI   A,TATOM
1031         MOVE    E,EQUOTE ATOM-NOT-TYPE-NAME-OR-SPECIAL-SYMBOL
1032         JRST    TERRD
1033 TERR6:
1034 TERR3:  MOVE    E,EQUOTE EMPTY-FORM-IN-DECL
1035         JRST    TERRD
1036 TERR7:  MOVE    E,EQUOTE EMPTY-OR/PRIMTYPE-FORM
1037         JRST    TERRD
1038
1039 TERR8:  MOVS    A,0             ; TYPE TO A
1040         MOVE    E,EQUOTE NON-TYPE-FOR-PRIMTYPE-ARG
1041         JRST    TERRD
1042 TERR12: MOVE    E,EQUOTE ELEMENT-TYPE-NOT-ATOM-FORM-OR-VECTOR
1043         JRST    TERRD
1044 TERR13: MOVE    E,EQUOTE VECTOR-LESS-THAN-2-ELEMENTS
1045         JRST    TERRD
1046 TERR14: MOVE    E,EQUOTE FIRST-VECTOR-ELEMENT-NOT-REST-OR-A-FIX
1047
1048 TERRD:  PUSH    TP,$TATOM
1049         PUSH    TP,EQUOTE BAD-TYPE-SPECIFICATION
1050         PUSH    TP,$TATOM
1051         PUSH    TP,E
1052         PUSH    TP,A
1053         PUSH    TP,B
1054         MOVEI   A,3
1055         JRST    CALER
1056
1057 IMPURE
1058
1059 IGDECL: 0
1060
1061 PURE
1062
1063 END
1064 \f\f