sumex/decl.mcr072

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