<mdl.int>/decl.mid.103

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