sumex/eval.mcr349

   1 TITLE EVAL -- MUDDLE EVALUATOR\r
   2 \r
   3 RELOCATABLE\r
   4 \r
   5 ; GERALD JAY SUSSMAN, 1971.  REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)\r
   6 \r
   7 \r
   8 .GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM\r
   9 .GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR\r
  10 .GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS\r
  11 .GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1\r
  12 .GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL\r
  13 .GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1\r
  14 .GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND\r
  15 .GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS\r
  16 .GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND\r
  17 .GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT\r
  18 .GLOBAL SPECBE\r
  19 .GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2\r
  20 \r
  21 .INSRT MUDDLE >\r
  22 \r
  23 MONITOR\r
  24 \r
  25 \f\r
  26 ; ENTRY TO EXPAND A MACRO\r
  27 \r
  28 MFUNCTION EXPAND,SUBR\r
  29 \r
  30         ENTRY   1\r
  31 \r
  32         MOVEI   A,PVLNT*2+1(PVP)\r
  33         HRLI    A,TFRAME\r
  34         MOVE    B,TBINIT+1(PVP)\r
  35         HLL     B,OTBSAV(B)\r
  36         PUSH    TP,A\r
  37         PUSH    TP,B\r
  38         MOVEI   B,-1(TP)\r
  39         JRST    AEVAL2\r
  40 \r
  41 ; MAIN EVAL ENTRANCE\r
  42 \r
  43 MFUNCTION       EVAL,SUBR\r
  44 \r
  45         ENTRY\r
  46 \r
  47         SKIPE   C,1STEPR+1(PVP) ; BEING 1 STEPPED?\r
  48         JRST    1STEPI          ; YES HANDLE\r
  49 EVALON: HLRZ    A,AB            ;GET NUMBER OF ARGS\r
  50         CAIE    A,-2            ;EXACTLY 1?\r
  51         JRST    AEVAL           ;EVAL WITH AN ALIST\r
  52 SEVAL:  GETYP   A,(AB)          ;GET TYPE OF ARG\r
  53         SKIPE   C,EVATYP+1(TVP) ; USER TYPE TABLE?\r
  54         JRST    EVDISP\r
  55 SEVAL1: CAIG    A,NUMPRI        ;PRIMITIVE?\r
  56         JRST    @EVTYPE(A)      ;YES-DISPATCH\r
  57 \r
  58 SELF:   MOVE    A,(AB)          ;TYPES WHICH EVALUATE \r
  59         MOVE    B,1(AB)\r
  60         JRST    EFINIS          ;TO SELF-EG NUMBERS\r
  61 \r
  62 ; HERE FOR USER EVAL DISPATCH\r
  63 \r
  64 EVDISP: ADDI    C,(A)           ; POINT TO SLOT\r
  65         ADDI    C,(A)\r
  66         SKIPE   (C)             ; SKIP EITHER A LOSER OR JRST DISP\r
  67         JRST    EVDIS1          ; APPLY EVALUATOR\r
  68         SKIPN   C,1(C)          ; GET ADDR OR GO TO PURE DISP\r
  69         JRST    SEVAL1\r
  70         JRST    (C)\r
  71 \r
  72 EVDIS1: PUSH    TP,(C)\r
  73         PUSH    TP,1(C)\r
  74         PUSH    TP,(AB)\r
  75         PUSH    TP,1(AB)\r
  76         MCALL   2,APPLY         ; APPLY HACKER TO OBJECT\r
  77         JRST    EFINIS\r
  78 \r
  79 \r
  80 ; EVAL DISPATCH TABLE\r
  81 \r
  82 DISTBL EVTYPE,SELF,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC]\r
  83 [TSEG,ILLSEG]]\r
  84 \f\r
  85 \r
  86 ;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID\r
  87 AEVAL:\r
  88         CAIE    A,-4            ;EXACTLY 2 ARGS?\r
  89         JRST    WNA             ;NO-ERROR\r
  90         GETYP   A,2(AB)         ;CHECK THAT WE HAVE A FRAME\r
  91         CAIE    A,TACT\r
  92         CAIN    A,TFRAME\r
  93         JRST    .+3\r
  94         CAIE    A,TENV\r
  95         JRST    TRYPRO          ; COULD BE PROCESS\r
  96         MOVEI   B,2(AB)         ; POINT TO FRAME\r
  97 AEVAL2: PUSHJ   P,CHENV         ; HACK ENVIRONMENT CHANGE\r
  98 AEVAL1: PUSH    TP,(AB)\r
  99         PUSH    TP,1(AB)\r
 100         MCALL   1,EVAL\r
 101 AEVAL3: HRRZ    0,FSAV(TB)\r
 102         CAIN    0,EVAL\r
 103         JRST    EFINIS\r
 104         JRST    FINIS\r
 105 \r
 106 TRYPRO: CAIE    A,TPVP          ; SKIP IF IT IS A PROCESS\r
 107         JRST    WTYP2\r
 108         MOVE    C,3(AB)         ; GET PROCESS\r
 109         CAMN    C,PVP           ; DIFFERENT FROM ME?\r
 110         JRST    SEVAL           ; NO, NORMAL EVAL WINS\r
 111         MOVE    B,SPSTO+1(C)    ; GET SP FOR PROCESS\r
 112         MOVE    D,TBSTO+1(C)    ; GET TOP FRAME\r
 113         HLL     D,OTBSAV(D)     ; TIME IT\r
 114         MOVEI   C,PVLNT*2+1(C)  ; CONS UP POINTER TO PROC DOPE WORD\r
 115         HRLI    C,TFRAME        ; LOOK LIK E A FRAME\r
 116         PUSHJ   P,SWITSP        ; SPLICE ENVIRONMENT\r
 117         JRST    AEVAL1\r
 118 \r
 119 ; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS \r
 120 \r
 121 CHENV:  PUSHJ   P,CHFRM         ; CHECK OUT FRAME\r
 122         MOVE    C,(B)           ; POINT TO PROCESS\r
 123         MOVE    D,1(B)          ; GET TB POINTER FROM FRAME\r
 124         CAMN    SP,SPSAV(D)     ; CHANGE?\r
 125         POPJ    P,              ; NO, JUST RET\r
 126         MOVE    B,SPSAV(D)      ; GET SP OF INTEREST\r
 127 SWITSP: MOVSI   0,TSKIP         ; SET UP SKIP\r
 128         HRRI    0,1(TP)         ; POINT TO UNBIND PATH\r
 129         MOVE    A,PVP\r
 130         ADD     A,[BINDID,,BINDID]      ; BIND THE BINDING ID\r
 131         PUSH    TP,BNDV\r
 132         PUSH    TP,A\r
 133         PUSH    TP,$TFIX\r
 134         AOS     A,PTIME         ; NEW ID\r
 135         PUSH    TP,A\r
 136         MOVE    E,TP            ; FOR SPECBIND\r
 137         PUSH    TP,0\r
 138         PUSH    TP,B\r
 139         PUSH    TP,C            ; SAVE PROCESS\r
 140         PUSH    TP,D\r
 141         PUSHJ   P,SPECBE        ; BIND BINDID\r
 142         MOVE    SP,TP           ; GET NEW SP\r
 143         SUB     SP,[3,,3]       ; SET UP SP FORK\r
 144         POPJ    P,\r
 145 \f\r
 146 \r
 147 ; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK)\r
 148 \r
 149 EVFORM: SKIPN   C,1(AB)         ; EMPTY FORM, RETURN FALSE\r
 150         JRST    EFALSE\r
 151         GETYP   A,(C)           ; 1ST ELEMENT OF FORM\r
 152         CAIE    A,TATOM         ; ATOM?\r
 153         JRST    EV0             ; NO, EVALUATE IT\r
 154         MOVE    B,1(C)          ; GET ATOM\r
 155         PUSHJ   P,IGVAL         ; GET ITS GLOBAL VALUE\r
 156 \r
 157 ; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS\r
 158 \r
 159         CAIE    B,LVAL\r
 160         CAIN    B,GVAL\r
 161         JRST    ATMVAL          ; FAST ATOM VALUE\r
 162 \r
 163         GETYP   0,A\r
 164         CAIE    0,TUNBOU        ; BOUND?\r
 165         JRST    IAPPLY          ; YES APPLY IT\r
 166 \r
 167         MOVE    C,1(AB)         ; LOOK FOR LOCAL\r
 168         MOVE    B,1(C)\r
 169         PUSHJ   P,ILVAL\r
 170         GETYP   0,A\r
 171         CAIE    0,TUNBOU\r
 172         JRST    IAPPLY          ; WIN, GO APPLY IT\r
 173 \r
 174         PUSH    TP,$TATOM\r
 175         PUSH    TP,EQUOTE UNBOUND-VARIABLE\r
 176         PUSH    TP,$TATOM\r
 177         MOVE    C,1(AB)         ; FORM BACK\r
 178         PUSH    TP,1(C)\r
 179         PUSH    TP,$TATOM\r
 180         PUSH    TP,MQUOTE VALUE\r
 181         MCALL   3,ERROR         ; REPORT THE ERROR\r
 182         JRST    IAPPLY\r
 183 \r
 184 EFALSE: MOVSI   A,TFALSE        ; SPECIAL FALSE FOR EVAL OF EMPTY FORM\r
 185         MOVEI   B,0\r
 186         JRST    EFINIS\r
 187 \r
 188 ATMVAL: HRRZ    D,(C)           ; CDR THE FORM\r
 189         HRRZ    0,(D)           ; AND AGAIN\r
 190         JUMPN   0,IAPPLY\r
 191         GETYP   0,(D)           ; MAKE SURE APPLYING TO ATOM\r
 192         CAIE    0,TATOM\r
 193         JRST    IAPPLY\r
 194         MOVEI   E,IGVAL         ; ASSUME GLOBAAL\r
 195         CAIE    B,GVAL          ; SKIP IF OK\r
 196         MOVEI   E,ILVAL         ; ELSE USE LOCAL\r
 197         PUSH    P,B             ; SAVE SUBR\r
 198         MOVE    B,(D)+1         ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR)\r
 199         PUSHJ   P,(E)           ; AND GET VALUE\r
 200         CAME    A,$TUNBOU\r
 201         JRST    EFINIS          ; RETURN FROM EVAL\r
 202         POP     P,B\r
 203         MOVSI   A,TSUBR         ; CAUSE REAL SUBR TO GET EROR\r
 204         JRST    IAPPLY\r
 205 \f\r
 206 ; HERE FOR 1ST ELEMENT NOT A FORM\r
 207 \r
 208 EV0:    PUSHJ   P,FASTEV        ; EVAL IT\r
 209 \r
 210 ; HERE TO APPLY THINGS IN FORMS\r
 211 \r
 212 IAPPLY: PUSH    TP,(AB)         ; SAVE THE FORM\r
 213         PUSH    TP,1(AB)\r
 214         PUSH    TP,A\r
 215         PUSH    TP,B            ; SAVE THE APPLIER\r
 216         PUSH    TP,$TFIX        ; AND THE ARG GETTER\r
 217         PUSH    TP,[ARGCDR]\r
 218         PUSHJ   P,APLDIS        ; GO TO INTERNAL APPLIER\r
 219         JRST    EFINIS          ; LEAVE EVAL\r
 220 \r
 221 ; HERE TO EVAL 1ST ELEMENT OF A FORM\r
 222 \r
 223 FASTEV: SKIPE   1STEPR+1(PVP)   ; BEING 1 STEPPED?\r
 224         JRST    EV02            ; YES, LET LOSER SEE THIS EVAL\r
 225         GETYP   A,(C)           ; GET TYPE\r
 226         SKIPE   D,EVATYP+1(TVP) ; USER TABLE?\r
 227         JRST    EV01            ; YES, HACK IT\r
 228 EV03:   CAIG    A,NUMPRI        ; SKIP IF SELF\r
 229         SKIPA   A,EVTYPE(A)     ; GET DISPATCH\r
 230         MOVEI   A,SELF          ; USE SLEF\r
 231 \r
 232 EV04:   CAIE    A,SELF          ; IF EVAL'S TO SELF, JUST USE IT\r
 233         JRST    EV02\r
 234         MOVSI   A,TLIST\r
 235         MOVEM   A,CSTO(PVP)\r
 236         INTGO\r
 237         SETZM   CSTO(PVP)\r
 238         HLLZ    A,(C)           ; GET IT\r
 239         MOVE    B,1(C)\r
 240         JSP     E,CHKAB         ; CHECK DEFERS\r
 241         POPJ    P,              ; AND RETURN\r
 242 \r
 243 EV01:   ADDI    D,(A)           ; POINT TO SLOT OF USER EVAL TABLE\r
 244         ADDI    D,(A)\r
 245         SKIPE   (D)             ; EITHER NOT GIVEN OR SIMPLE\r
 246         JRST    EV02\r
 247         SKIPN   1(D)            ; SKIP IF SIMPLE\r
 248         JRST    EV03            ; NOT GIVEN\r
 249         MOVE    A,1(D)\r
 250         JRST    EV04\r
 251 \r
 252 EV02:   PUSH    TP,(C)\r
 253         HLLZS   (TP)            ; FIX UP LH\r
 254         PUSH    TP,1(C)\r
 255         JSP     E,CHKARG\r
 256         MCALL   1,EVAL\r
 257         POPJ    P,\r
 258 \r
 259 \f\r
 260 ; MAPF/MAPR CALL TO APPLY\r
 261 \r
 262         MQUOTE APPLY\r
 263 \r
 264 MAPPLY: JRST    APPLY\r
 265 \r
 266 ; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS\r
 267 \r
 268 MFUNCTION APPLY,SUBR\r
 269 \r
 270         ENTRY\r
 271 \r
 272         JUMPGE  AB,TFA          ; MUST BE AT LEAST 1 ARGUMENT\r
 273         MOVE    A,AB\r
 274         ADD     A,[2,,2]\r
 275         PUSH    TP,$TAB\r
 276         PUSH    TP,A\r
 277         PUSH    TP,(AB)         ; SAVE FCN\r
 278         PUSH    TP,1(AB)\r
 279         PUSH    TP,$TFIX        ; AND ARG GETTER\r
 280         PUSH    TP,[SETZ APLARG]\r
 281         PUSHJ   P,APLDIS\r
 282         JRST    FINIS\r
 283 \r
 284 ; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS\r
 285 \r
 286 MFUNCTION STACKFORM,FSUBR\r
 287 \r
 288         ENTRY   1\r
 289 \r
 290         GETYP   A,(AB)\r
 291         CAIE    A,TLIST\r
 292         JRST    WTYP1\r
 293         MOVEI   A,3             ; CHECK ALL GOODIES SUPPLIED\r
 294         HRRZ    B,1(AB)\r
 295 \r
 296         JUMPE   B,TFA\r
 297         HRRZ    B,(B)           ; CDR IT\r
 298         SOJG    A,.-2\r
 299 \r
 300         HRRZ    C,1(AB)         ; GET LIST BACK\r
 301         PUSHJ   P,FASTEV        ; DO A FAST EVALUATION\r
 302         PUSH    TP,(AB)\r
 303         HRRZ    C,@1(AB)        ; POINT TO ARG GETTING FORMS\r
 304         PUSH    TP,C\r
 305         PUSH    TP,A            ; AND FCN\r
 306         PUSH    TP,B\r
 307         PUSH    TP,$TFIX\r
 308         PUSH    TP,[SETZ EVALRG]\r
 309         PUSHJ   P,APLDIS\r
 310         JRST    FINIS\r
 311 \r
 312 \f\r
 313 ; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF\r
 314 \r
 315 E.FRM==0                ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM)\r
 316 E.FCN==2                ; FUNCTION/SUBR/RSUBR BEING APPLIED\r
 317 E.ARG==4                ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS)\r
 318 E.EXTR==6               ; CONTAINS 1ST ARG IN USER APPLY CASE\r
 319 E.SEG==10               ; POINTS TO SEGMENT IN FORM BEING HACKED\r
 320 E.CNT==12               ; COUNTER FOR TUPLES OF ARGS\r
 321 E.DECL==14              ; POINTS TO DECLARATION LIST IN FUNCTIONS\r
 322 E.ARGL==16              ; POINTS TO ARG LIST IN FUNCTIONS\r
 323 E.HEW==20               ; POINTS TO HEWITT ATOM IF IT EXISTS\r
 324 \r
 325 E.VAL==E.ARGL           ; VALUE TYPE FOR RSUBRS\r
 326 \r
 327 MINTM==E.EXTR+2         ; MIN # OF TEMPS EVER ALLOCATED\r
 328 E.TSUB==E.CNT+2         ; # OF TEMPS FOR SUBR/NUMBER APPLICATION\r
 329 XP.TMP==E.HEW-E.EXTR    ; # EXTRA TEMPS FOR FUNCTION APPLICATION\r
 330 R.TMP==4                ; TEMPS AFTER ARGS ARE BOUND\r
 331 TM.OFF==E.HEW+2-R.TMP   ; TEMPS TO FLUSH AFTER BIND OF ARGS\r
 332 \r
 333 RE.FCN==0               ; AFTER BINDING CONTAINS FCN BODY\r
 334 RE.ARG==2               ; ARG LIST AFTER BINDING\r
 335 \r
 336 ; GENERAL THING APPLYER\r
 337 \r
 338 APLDIS: PUSH    TP,[0]          ; SLOT USED FOR USER APPLYERS\r
 339         PUSH    TP,[0]\r
 340 APLDIX: GETYP   A,E.FCN(TB)     ; GET TYPE\r
 341 \r
 342 APLDI:  SKIPE   D,APLTYP+1(TVP) ; USER TABLE EXISTS?\r
 343         JRST    APLDI1          ; YES, USE IT\r
 344 APLDI2: CAIG    A,NUMPRI        ; SKIP IF NOT PRIM\r
 345         JRST    @APTYPE(A)\r
 346         JRST    NAPT\r
 347 \r
 348 APLDI1: ADDI    D,(A)           ; POINT TO SLOT\r
 349         ADDI    D,(A)\r
 350         SKIPE   (D)             ; SKIP IF NOT GIVEN OR STANDARD\r
 351         JRST    APLDI3\r
 352 APLDI4: SKIPE   D,1(D)          ; GET DISP\r
 353         JRST    (D)\r
 354         JRST    APLDI2          ; USE SYSTEM DISPATCH\r
 355 \r
 356 APLDI3: SKIPE   E.EXTR+1(TB)    ; SKIP IF HAVEN'T BEEN HERE BEFORE\r
 357         JRST    APLDI4\r
 358         MOVE    A,(D)           ; GET ITS HANDLER\r
 359         EXCH    A,E.FCN(TB)     ; AND USE AS FCN\r
 360         MOVEM   A,E.EXTR(TB)    ; SAVE\r
 361         MOVE    A,1(D)\r
 362         EXCH    A,E.FCN+1(TB)\r
 363         MOVEM   A,E.EXTR+1(TB)  ; STASH OLD FCN AS EXTRG\r
 364         GETYP   A,(D)           ; GET TYPE\r
 365         JRST    APLDI\r
 366 \r
 367 \r
 368 ; APPLY DISPATCH TABLE\r
 369 \r
 370 DISTBL APTYPE,<SETZ NAPTL>,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM]\r
 371 [TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR]]\f\r
 372 \r
 373 ; SUBR TO SAY IF TYPE IS APPLICABLE\r
 374 \r
 375 MFUNCTION APPLIC,SUBR,[APPLICABLE?]\r
 376 \r
 377         ENTRY   1\r
 378 \r
 379         GETYP   A,(AB)\r
 380         PUSHJ   P,APLQ\r
 381         JRST    IFALSE\r
 382         JRST    TRUTH\r
 383 \r
 384 ; HERE TO DETERMINE IF A TYPE IS APPLICABLE\r
 385 \r
 386 APLQ:   PUSH    P,B\r
 387         SKIPN   B,APLTYP+1(TVP)\r
 388         JRST    USEPUR          ; USE PURE TABLE\r
 389         ADDI    B,(A)\r
 390         ADDI    B,(A)           ; POINT TO SLOT\r
 391         SKIPG   1(B)            ; SKIP IF WINNER\r
 392         SKIPE   (B)             ; SKIP IF POTENIAL LOSER\r
 393         JRST    CPPJ1B          ; WIN\r
 394         SKIPE   1(B)            ; SKIP IF MUST USE PURE TABBLE\r
 395         JRST    CPOPJB\r
 396 USEPUR: CAIG    A,NUMPRI        ; SKIP IF NOT PRIM\r
 397         SKIPL   APTYPE(A)       ; SKIP IF APLLICABLE\r
 398 CPPJ1B: AOS     -1(P)\r
 399 CPOPJB: POP     P,B\r
 400         POPJ    P,\r
 401 \f\r
 402 ; FSUBR APPLYER\r
 403 \r
 404 APFSUBR:\r
 405         SKIPN   E.EXTR(TB)      ; IF EXTRA ARG\r
 406         SKIPGE  E.ARG+1(TB)     ; OR APPLY/STACKFORM, LOSE\r
 407         JRST    BADFSB\r
 408         MOVE    A,E.FCN+1(TB)   ; GET FCN\r
 409         HRRZ    C,@E.FRM+1(TB)  ; GET ARG LIST\r
 410         SUB     TP,[MINTM,,MINTM]       ; FLUSH UNWANTED TEMPS\r
 411         PUSH    TP,$TLIST\r
 412         PUSH    TP,C            ; ARG TO STACK\r
 413         .MCALL  1,(A)           ; AND CALL\r
 414         POPJ    P,              ; AND LEAVE\r
 415 \r
 416 ; SUBR APPLYER\r
 417 \r
 418 APSUBR: \r
 419         PUSHJ   P,PSH4ZR        ; SET UP ZEROED SLOTS\r
 420         SKIPN   A,E.EXTR(TB)    ; FUNNY ARGS\r
 421         JRST    APSUB1          ; NO, GO\r
 422         MOVE    B,E.EXTR+1(TB)  ; YES , GET VAL\r
 423         JRST    APSUB2          ; AND FALL IN\r
 424 \r
 425 APSUB1: PUSHJ   P,@E.ARG+1(TB)  ; EAT AN ARG\r
 426         JRST    APSUBD          ; DONE\r
 427 APSUB2: PUSH    TP,A\r
 428         PUSH    TP,B\r
 429         AOS     E.CNT+1(TB)     ; COUNT IT\r
 430         JRST    APSUB1\r
 431 \r
 432 APSUBD: MOVE    A,E.CNT+1(TB)   ; FINISHED, GET COUNT\r
 433         MOVE    B,E.FCN+1(TB)   ; AND SUBR\r
 434         GETYP   0,E.FCN(TB)\r
 435         CAIN    0,TENTER\r
 436         JRST    APENDN\r
 437         PUSHJ   P,BLTDN         ; FLUSH CRUFT\r
 438         .ACALL  A,(B)\r
 439         POPJ    P,\r
 440 \r
 441 BLTDN:  MOVEI   C,(TB)          ; POINT TO DEST\r
 442         HRLI    C,E.TSUB(C)     ; AND SOURCE\r
 443         BLT     C,-E.TSUB(TP)   ;BL..............T\r
 444         SUB     TP,[E.TSUB,,E.TSUB]\r
 445         POPJ    P,\r
 446 \r
 447 APENDN: PUSHJ   P,BLTDN\r
 448 APNDN1: .ECALL  A,(B)\r
 449         POPJ    P,\r
 450 \r
 451 ; FLAGS FOR RSUBR HACKER\r
 452 \r
 453 F.STR==1\r
 454 F.OPT==2\r
 455 F.QUO==4\r
 456 F.NFST==10\r
 457 \r
 458 ; APPLY OBJECTS OF TYPE RSUBR\r
 459 \r
 460 APENTR:\r
 461 APRSUBR:\r
 462         MOVE    C,E.FCN+1(TB)   ; GET THE RSUBR\r
 463         CAML    C,[-5,,]        ; IS IT LONG ENOUGH FOR DECLS\r
 464         JRST    APSUBR          ; NO TREAT AS A SUBR\r
 465         GETYP   0,4(C)          ; GET TYPE OF 3D ELEMENT\r
 466         CAIE    0,TDECL         ; DECLARATION?\r
 467         JRST    APSUBR          ; NO, TREAT AS SUBR\r
 468         PUSHJ   P,PSH4ZR        ; ALLOCATE SOME EXTRA ROOM\r
 469         PUSH    TP,$TDECL       ; PUSH UP THE DECLS\r
 470         PUSH    TP,5(C)\r
 471         PUSH    TP,$TLOSE       ; SAVE ROOM FOR VAL DECL\r
 472         PUSH    TP,[0]\r
 473 \r
 474         SKIPN   E.EXTR(TB)      ; "EXTRA" ARG?\r
 475         JRST    APRSU1          ; NO,\r
 476         MOVE    0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN\r
 477         EXCH    0,E.ARG+1(TB)\r
 478         HRRM    0,E.ARG(TB)     ; REMEMBER IT\r
 479 \r
 480 APRSU1: MOVEI   0,0             ; INIT FLAG REGISTER\r
 481         PUSH    P,0             ; SAVE\r
 482 \r
 483 APRSU2: HRRZ    A,E.DECL+1(TB)  ; GET DECL LIST\r
 484         JUMPE   A,APRSU3        ; DONE!\r
 485         HRRZ    B,(A)           ; CDR IT\r
 486         MOVEM   B,E.DECL+1(TB)\r
 487         PUSHJ   P,NXTDCL        ; IS NEXT THING A STRING?\r
 488         JRST    APRSU4          ; NO, BETTER BE A  TYPE\r
 489         CAMN    B,[ASCII /VALUE/]\r
 490         JRST    RSBVAL          ; SAVE VAL DECL\r
 491         TRON    0,F.NFST        ; IF NOT FIRST, LOSE\r
 492         CAME    B,[ASCII /CALL/] ; CALL DECL\r
 493         JRST    APRSU7\r
 494         SKIPGE  E.ARG+1(TB)     ; LEGAL?\r
 495         JRST    MPD\r
 496         MOVE    C,E.FRM(TB)\r
 497         MOVE    D,E.FRM+1(TB)   ; GET FORM\r
 498         JRST    APRS10          ; HACK IT\r
 499 \r
 500 APRSU5: TROE    0,F.STR         ; STRING STRING?\r
 501         JRST    MPD             ; LOSER\r
 502         CAME    B,[<ASCII /OPTIO/>+1]   ; OPTIONA?\r
 503         JRST    APRSU8\r
 504         TROE    0,F.OPT         ; CHECK AND SET\r
 505         JRST    MPD             ; OPTINAL OPTIONAL LOSES\r
 506         JRST    APRSU2  ; TO MAIN LOOP\r
 507 \r
 508 APRSU7: CAME    B,[ASCII /QUOTE/]\r
 509         JRST    APRSU5\r
 510         TRO     0,F.STR\r
 511         TROE    0,F.QUO         ; TURN ON AND CHECK QUOTE\r
 512         JRST    MPD             ; QUOTE QUOTE LOSES\r
 513         JRST    APRSU2          ; GO TO END OF LOOP\r
 514 \f\r
 515 \r
 516 APRSU8: CAME    B,[ASCII /ARGS/]\r
 517         JRST    APRSU9\r
 518         SKIPGE  E.ARG+1(TB)     ; SKIP IF LEGAL\r
 519         JRST    MPD\r
 520         HRRZ    D,@E.FRM+1(TB)  ; GET ARG LIST\r
 521         MOVSI   C,TLIST\r
 522 \r
 523 APRS10: HRRZ    A,(A)           ; GET THE DECL\r
 524         MOVEM   A,E.DECL+1(TB)  ; CLOBBER\r
 525         HRRZ    B,(A)           ; CHECK FOR TOO MUCH\r
 526         JUMPN   B,MPD\r
 527         MOVE    B,1(A)          ; GET DECL\r
 528         HLLZ    A,(A)           ; GOT THE DECL\r
 529         MOVEM   0,(P)           ; SAVE FLAGS\r
 530         JSP     E,CHKAB         ; CHECK DEFER\r
 531         PUSH    TP,C\r
 532         PUSH    TP,D            ; SAVE\r
 533         PUSHJ   P,TMATCH\r
 534         JRST    WTYP\r
 535         AOS     E.CNT+1(TB)     ; COUNT ARG\r
 536         JRST    APRDON          ; GO CALL RSUBR\r
 537 \r
 538 RSBVAL: HRRZ    A,E.DECL+1(TB)  ; GET DECL\r
 539         JUMPE   A,MPD\r
 540         HRRZ    B,(A)           ; POINT TO DECL\r
 541         MOVEM   B,E.DECL+1(TB)  ; SAVE NEW DECL POINTER\r
 542         PUSHJ   P,NXTDCL\r
 543         JRST    .+2\r
 544         JRST    MPD\r
 545         MOVEM   A,E.VAL+1(TB)   ; SAVE VAL DECL\r
 546         MOVSI   A,TDCLI\r
 547         MOVEM   A,E.VAL(TB)     ; SET ITS TYPE\r
 548         JRST    APRSU2\r
 549 \f\r
 550         \r
 551 APRSU9: CAME    B,[ASCII /TUPLE/]\r
 552         JRST    MPD\r
 553         MOVEM   0,(P)           ; SAVE FLAGS\r
 554         HRRZ    A,(A)           ; CDR DECLS\r
 555         MOVEM   A,E.DECL+1(TB)\r
 556         HRRZ    B,(A)\r
 557         JUMPN   B,MPD           ; LOSER\r
 558         PUSH    P,[0]           ; COUNT ELEMENTS IN TUPLE\r
 559 \r
 560 APRTUP: PUSHJ   P,@E.ARG+1(TB)  ; GOBBLE ARGS\r
 561         JRST    APRTPD          ; DONE\r
 562         PUSH    TP,A\r
 563         PUSH    TP,B\r
 564         AOS     (P)             ; COUNT IT\r
 565         JRST    APRTUP          ; AND GO\r
 566 \r
 567 APRTPD: POP     P,C             ; GET COUNT\r
 568         ADDM    C,E.CNT+1(TB)   ; UPDATE MAIN COUNT\r
 569         ASH     C,1             ; # OF WORDS\r
 570         HRLI    C,TINFO         ; BUILD FENCE POST\r
 571         PUSH    TP,C\r
 572         PUSHJ   P,TBTOTP        ; GEN REL OFFSET TO TOP\r
 573         PUSH    TP,D\r
 574         HRROI   D,-1(TP)                ; POINT TO TOP\r
 575         SUBI    D,(C)           ; TO BASE\r
 576         TLC     D,-1(C)\r
 577         MOVSI   C,TARGS         ; BUILD TYPE WORD\r
 578         HLR     C,OTBSAV(TB)\r
 579         MOVE    A,E.DECL+1(TB)\r
 580         MOVE    B,1(A)\r
 581         HLLZ    A,(A)           ; TYPE/VAL\r
 582         JSP     E,CHKAB         ; CHECK\r
 583         PUSHJ   P,TMATCH        ; GOTO TYPE CHECKER\r
 584         JRST    WTYP\r
 585 \r
 586         SUB     TP,[2,,2]       ; REMOVE FENCE POST\r
 587 \r
 588 APRDON: SUB     P,[1,,1]        ; FLUSH CRUFT\r
 589         MOVE    A,E.CNT+1(TB)   ; GET # OF ARGS\r
 590         MOVE    B,E.FCN+1(TB)\r
 591         GETYP   0,E.FCN(TB)     ; COULD BE ENTRY\r
 592         MOVEI   C,(TB)          ; PREPARE TO BLT DOWN\r
 593         HRLI    C,E.TSUB+2(C)\r
 594         BLT     C,-E.TSUB+2(TP)\r
 595         SUB     TP,[E.TSUB+2,,E.TSUB+2]\r
 596         CAIE    0,TRSUBR\r
 597         JRST    APNDN1\r
 598         .ACALL  A,(B)           ; CALL THE RSUBR\r
 599         JRST    PFINIS\r
 600 \f\r
 601 \r
 602 \r
 603 APRSU4: MOVEM   0,(P)           ; SAVE FLAGS\r
 604         MOVE    B,1(A)          ; GET DECL\r
 605         HLLZ    A,(A)\r
 606         JSP     E,CHKAB\r
 607         MOVE    0,(P)           ; RESTORE FLAGS\r
 608         PUSH    TP,A\r
 609         PUSH    TP,B            ; AND SAVE\r
 610         SKIPL   E.ARG+1(TB)     ; ALREADY EVAL'D\r
 611         TRZN    0,F.QUO\r
 612         JRST    APREVA          ; MUST EVAL ARG\r
 613         MOVEM   0,(P)\r
 614         HRRZ    C,@E.FRM+1(TB)  ; GET ARG?\r
 615         TRNE    0,F.OPT         ; OPTIONAL\r
 616         JUMPE   C,APRDN\r
 617         JUMPE   C,TFA           ; NO, TOO FEW ARGS\r
 618         MOVEM   C,E.FRM+1(TB)\r
 619         HLLZ    A,(C)           ; GET ARG\r
 620         MOVE    B,1(C)\r
 621         JSP     E,CHKAB         ; CHECK THEM\r
 622 \r
 623 APRTYC: MOVE    C,A             ; SET UP FOR TMATCH\r
 624         MOVE    D,B\r
 625         EXCH    B,(TP)\r
 626         EXCH    A,-1(TP)        ; SAVE STUFF\r
 627 APRS11: PUSHJ   P,TMATCH        ; CHECK TYPE\r
 628         JRST    WTYP\r
 629 \r
 630         MOVE    0,(P)           ; RESTORE FLAGS\r
 631         TRZ     0,F.STR\r
 632         AOS     E.CNT+1(TB)\r
 633         JRST    APRSU2          ; AND GO ON\r
 634 \r
 635 APREVA: PUSHJ   P,@E.ARG+1(TB)  ; EVAL ONE\r
 636         TDZA    C,C             ; C=0 ==> NONE LEFT\r
 637         MOVEI   C,1\r
 638         MOVE    0,(P)           ; FLAGS\r
 639         JUMPN   C,APRTYC        ; GO CHECK TYPE\r
 640 APRDN:  SUB     TP,[2,,2]       ; FLUSH DECL\r
 641         TRNE    0,F.OPT         ; OPTIONAL?\r
 642         JRST    APRDON  ; ALL DONE\r
 643         JRST    TFA\r
 644 \r
 645 APRSU3: TRNE    0,F.STR         ; END IN STRING?\b       \r
 646         JRST    MPD\r
 647         PUSHJ   P,@E.ARG+1(TB)  ; SEE IF ANYMORE ARGS\r
 648         JRST    APRDON\r
 649         JRST    TMA\r
 650 \r
 651 \f\r
 652 ; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS\r
 653 \r
 654 ARGCDR: HRRZ    C,@E.FRM+1(TB)  ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS)\r
 655         JUMPE   C,CPOPJ         ; LEAVE IF DONE\r
 656         MOVEM   C,E.FRM+1(TB)\r
 657         GETYP   0,(C)           ; GET TYPE OF ARG\r
 658         CAIN    0,TSEG\r
 659         JRST    ARGCD1          ; SEG MENT HACK\r
 660         PUSHJ   P,FASTEV\r
 661         JRST    CPOPJ1\r
 662 \r
 663 ARGCD1: PUSH    TP,$TFORM       ; PRETEND WE ARE A FORM\r
 664         PUSH    TP,1(C)\r
 665         MCALL   1,EVAL\r
 666         MOVEM   A,E.SEG(TB)\r
 667         MOVEM   B,E.SEG+1(TB)\r
 668         PUSHJ   P,TYPSEG                ; GET SEG TYPE CODE\r
 669         HRRM    C,E.ARG(TB)             ; SAVE IT IN OBSCCURE PLACE\r
 670         MOVE    C,[SETZ SGARG]\r
 671         MOVEM   C,E.ARG+1(TB)   ; SET NEW ARG GETTER\r
 672 \r
 673 ; FALL INTO SEGARG\r
 674 \r
 675 SGARG:  INTGO\r
 676         HRRZ    C,E.ARG(TB)     ; SEG CODE TO C\r
 677         MOVE    D,E.SEG+1(TB)\r
 678         MOVE    A,E.SEG(TB)\r
 679         MOVEM   A,DSTO(PVP)\r
 680         PUSHJ   P,NXTLM         ; GET NEXT ELEMENT\r
 681         JRST    SEGRG1          ; DONE\r
 682         MOVEM   D,E.SEG+1(TB)\r
 683         MOVE    D,DSTO(PVP)     ; KEEP TYPE WINNING\r
 684         MOVEM   D,E.SEG(TB)\r
 685         SETZM   DSTO(PVP)\r
 686         JRST    CPOPJ1          ; RETURN\r
 687 \r
 688 SEGRG1: SETZM   DSTO(PVP)\r
 689         MOVEI   C,ARGCDR\r
 690         MOVEM   C,E.ARG+1(TB)   ; RESET ARG GETTER\r
 691         JRST    ARGCDR\r
 692 \r
 693 ; ARGUMENT GETTER FOR APPLY\r
 694 \r
 695 APLARG: INTGO\r
 696         SKIPL   A,E.FRM+1(TB)   ; ANY ARGS LEFT\r
 697         POPJ    P,              ; NO, EXIT IMMEDIATELY\r
 698         ADD     A,[2,,2]\r
 699         MOVEM   A,E.FRM+1(TB)\r
 700         MOVE    B,-1(A)         ; RET NEXT ARG\r
 701         MOVE    A,-2(A)\r
 702         JRST    CPOPJ1\r
 703 \r
 704 ; STACKFORM ARG GETTER\r
 705 \r
 706 EVALRG: SKIPN   C,@E.FRM+1(TB)  ; ANY FORM?\r
 707         POPJ    P,\r
 708         PUSHJ   P,FASTEV\r
 709         GETYP   A,A             ; CHECK FOR FALSE\r
 710         CAIN    A,TFALSE\r
 711         POPJ    P,\r
 712         MOVE    C,E.FRM+1(TB)   ; GET OTHER FORM\r
 713         PUSHJ   P,FASTEV\r
 714         JRST    CPOPJ1\r
 715 \r
 716 \f\r
 717 ; HERE TOO APPLY NUMBERS\r
 718 \r
 719 APNUM:  PUSHJ   P,PSH4ZR        ; TP SLOSTS\r
 720         SKIPN   A,E.EXTR(TB)    ; FUNNY ARG?\r
 721         JRST    APNUM1          ; NOPE\r
 722         MOVE    B,E.EXTR+1(TB)  ; GET ARG\r
 723         JRST    APNUM2\r
 724 \r
 725 APNUM1: PUSHJ   P,@E.ARG+1(TB)  ; GET ARG\r
 726         JRST    TFA\r
 727 APNUM2: PUSH    TP,A\r
 728         PUSH    TP,B\r
 729         PUSH    TP,E.FCN(TB)\r
 730         PUSH    TP,E.FCN+1(TB)\r
 731         PUSHJ   P,@E.ARG+1(TB)\r
 732         JRST    .+2\r
 733         JRST    TMA\r
 734         PUSHJ   P,BLTDN         ; FLUSH JUNK\r
 735         MCALL   2,NTH\r
 736         POPJ    P,\r
 737 \f\r
 738 ; HERE TO APPLY SUSSMAN FUNARGS\r
 739 \r
 740 APFUNARG:\r
 741 \r
 742         SKIPN   C,E.FCN+1(TB)\r
 743         JRST    FUNERR\r
 744         HRRZ    D,(C)           ; MUST BE AT LEAST 2 LONG\r
 745         JUMPE   D,FUNERR\r
 746         GETYP   0,(D)           ; CHECK FOR LIST\r
 747         CAIE    0,TLIST\r
 748         JRST    FUNERR\r
 749         HRRZ    0,(D)           ; SHOULD BE END\r
 750         JUMPN   0,FUNERR\r
 751         GETYP   0,(C)           ; 1ST MUST BE FCN\r
 752         CAIE    0,TEXPR\r
 753         JRST    FUNERR\r
 754         SKIPN   C,1(C)\r
 755         JRST    NOBODY\r
 756         PUSHJ   P,APEXPF        ; BIND THE ARGS AND AUX'S\r
 757         HRRZ    C,RE.FCN+1(TB)  ; GET BODY OF FUNARG\r
 758         MOVE    B,1(C)          ; GET FCN\r
 759         MOVEM   B,RE.FCN+1(TB)  ; AND SAVE\r
 760         HRRZ    C,(C)           ; CDR FUNARG BODY\r
 761         MOVE    C,1(C)\r
 762         MOVSI   0,TLIST         ; SET UP TYPE\r
 763         MOVEM   0,CSTO(PVP)     ; FOR INTS TO WIN\r
 764 \r
 765 FUNLP:  INTGO\r
 766         JUMPE   C,DOF           ; RUN IT\r
 767         GETYP   0,(C)\r
 768         CAIE    0,TLIST         ; BETTER BE LIST\r
 769         JRST    FUNERR\r
 770         PUSH    TP,$TLIST\r
 771         PUSH    TP,C\r
 772         PUSHJ   P,NEXTDC        ; GET POSSIBILITY\r
 773         JRST    FUNERR          ; LOSER\r
 774         CAIE    A,2\r
 775         JRST    FUNERR\r
 776         HRRZ    B,(B)           ; GET TO VALUE\r
 777         MOVE    C,(TP)\r
 778         SUB     TP,[2,,2]\r
 779         PUSH    TP,BNDA\r
 780         PUSH    TP,E\r
 781         HLLZ    A,(B)           ; GET VAL\r
 782         MOVE    B,1(B)\r
 783         JSP     E,CHKAB         ; HACK DEFER\r
 784         PUSHJ   P,PSHAB4        ; PUT VAL IN\r
 785         HRRZ    C,(C)           ; CDR\r
 786         JUMPN   C,FUNLP\r
 787 \r
 788 ; HERE TO RUN FUNARG\r
 789 \r
 790 DOF:    SETZM   CSTO(PVP)       ; DONT CONFUSE GC\r
 791         PUSHJ   P,SPECBIND      ; BIND 'EM UP\r
 792         JRST    RUNFUN\r
 793 \r
 794 \r
 795 \f\r
 796 ; HERE TO DO MACROS\r
 797 \r
 798 APMACR: HRRZ    E,OTBSAV(TB)\r
 799         HRRZ    E,PCSAV(E)      ; SEE WHERE FROM\r
 800         CAIN    E,AEVAL3        ; SKIP IF NOT RIGHT\r
 801         JRST    APMAC1\r
 802         SKIPG   E.ARG+1(TB)     ; SKIP IF REAL FORM EXISTS\r
 803         JRST    BADMAC\r
 804         MOVE    A,E.FRM(TB)\r
 805         MOVE    B,E.FRM+1(TB)\r
 806         SUB     TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK\r
 807         PUSH    TP,A\r
 808         PUSH    TP,B\r
 809         MCALL   1,EXPAND        ; EXPAND THE MACRO\r
 810         PUSH    TP,A\r
 811         PUSH    TP,B\r
 812         MCALL   1,EVAL          ; EVAL THE RESULT\r
 813         POPJ    P,\r
 814 \r
 815 APMAC1: MOVE    C,E.FCN+1(TB)   ; GET MACRO BODY\r
 816         GETYP   A,(C)\r
 817         MOVE    B,1(C)\r
 818         MOVSI   A,(A)\r
 819         JSP     E,CHKAB         ; FIX DEFERS\r
 820         MOVEM   A,E.FCN(TB)\r
 821         MOVEM   B,E.FCN+1(TB)\r
 822         JRST    APLDIX\r
 823         \r
 824 ; HERE TO APPLY EXPRS (FUNCTIONS)\r
 825 \r
 826 APEXPR: PUSHJ   P,APEXP         ; BIND ARGS AND AUX'S\r
 827 RUNFUN: HRRZ    A,RE.FCN(TB)    ; AMOUNT OF FCN TO SKIP\r
 828         MOVEI   C,RE.FCN+1(TB)  ; POINT TO FCN\r
 829         HRRZ    C,(C)           ; SKIP SOMETHING\r
 830         SOJGE   A,.-1           ; UNTIL 1ST FORM\r
 831         MOVEM   C,RE.FCN+1(TB)  ; AND STORE\r
 832         JRST    DOPROG          ; GO RUN PROGRAM\r
 833 \r
 834 APEXP:  SKIPN   C,E.FCN+1(TB)   ; CHECK FRO BODY\r
 835         JRST    NOBODY\r
 836 APEXPF: PUSH    P,[0]           ; COUNT INIT CRAP\r
 837         ADD     TP,[XP.TMP,,XP.TMP]     ; SLOTS FOR HACKING\r
 838         SKIPL   TP\r
 839         PUSHJ   P,TPOVFL\r
 840         SETZM   1-XP.TMP(TP)    ; ZERO OUT\r
 841         MOVEI   A,-XP.TMP+2(TP)\r
 842         HRLI    A,-1(A)\r
 843         BLT     A,(TP)          ; ZERO SLOTS\r
 844         PUSHJ   P,CARATC        ; SEE IF HEWITT ATOM EXISTS\r
 845         JRST    APEXP1          ; NO, GO LOOK FOR ARGLIST\r
 846         MOVEM   E,E.HEW+1(TB)   ; SAVE ATOM\r
 847         MOVSM   0,E.HEW(TB)     ; AND TYPE\r
 848         AOS     (P)             ; COUNT HEWITT ATOM\r
 849 APEXP1: GETYP   0,(C)           ; LOOK AT NEXT THING\r
 850         CAIE    0,TLIST         ; BETTER BE LIST!!!\r
 851         JRST    MPD.0           ; LOSE\r
 852         MOVE    B,1(C)          ; GET LIST\r
 853         MOVEM   B,E.ARGL+1(TB)  ; SAVE\r
 854         MOVSM   0,E.ARGL(TB)    ; WITH TYPE\r
 855         HRRZ    C,(C)           ; CDR THE FCN\r
 856         JUMPE   C,NOBODY        ; BODYLESS FCN\r
 857         GETYP   0,(C)           ; SEE IF DCL LIST SUPPLIED\r
 858         CAIE    0,TDECL\r
 859         JRST    APEXP2          ; NO, START PROCESSING ARGS\r
 860         AOS     (P)             ; COUNT DCL\r
 861         MOVE    B,1(C)\r
 862         MOVEM   B,E.DECL+1(TB)\r
 863         MOVSM   0,E.DECL(TB)\r
 864         HRRZ    C,(C)           ; CDR ON\r
 865         JUMPE   C,NOBODY\r
 866 \r
 867  ; CHECK FOR EXISTANCE OF EXTRA ARG\r
 868 \r
 869 APEXP2: POP     P,A             ; GET COUNT\r
 870         HRRM    A,E.FCN(TB)     ; AND SAVE\r
 871         SKIPN   E.EXTR(TB)      ; SKIP IF FUNNY EXTRA ARG EXISTS\r
 872         JRST    APEXP3\r
 873         MOVE    0,[SETZ EXTRGT]\r
 874         EXCH    0,E.ARG+1(TB)\r
 875         HRRM    0,E.ARG(TB)     ; SAVE OLD GETTER AROUND\r
 876 \r
 877 ; FALL THROUGH\r
 878         \f\r
 879 ; LOOK FOR "BIND" DECLARATION\r
 880 \r
 881 APEXP3: PUSHJ   P,UNPROG        ; UNASSIGN LPROG IF NEC\r
 882 APXP3A: SKIPN   A,E.ARGL+1(TB)  ; GET ARGLIST\r
 883         JRST    APEXP4          ; NONE, VERIFY NONE WERE GIVEN\r
 884         PUSHJ   P,NXTDCL        ; SEE IF A DECL IS THERE\r
 885         JRST    BNDRG           ; NO, GO BIND NORMAL ARGS\r
 886         HRRZ    C,(A)           ; CDR THE DCLS\r
 887         CAME    B,[ASCII /BIND/]\r
 888         JRST    CH.CAL          ; GO LOOK FOR "CALL"\r
 889         PUSHJ   P,CARTMC        ; MUST BE AN ATOM\r
 890         MOVEM   C,E.ARGL+1(TB)  ; AND SAVE CDR'D ARGS\r
 891         PUSHJ   P,MAKENV        ; GENERATE AN ENVIRONMENT\r
 892         PUSHJ   P,PSBND1        ; PUSH THE BINDING AND CHECK THE DCL\r
 893         JRST    APXP3A          ; IN CASE <"BIND" B "BIND" C......\r
 894 \r
 895 \r
 896 ; LOOK FOR "CALL" DCL\r
 897 \r
 898 CH.CAL: CAME    B,[ASCII /CALL/]\r
 899         JRST    CHOPT           ; TRY SOMETHING ELSE\r
 900         SKIPG   E.ARG+1(TB)     ; DONT SKIP IF CANT WIN\r
 901         JRST    MPD.2\r
 902         PUSHJ   P,CARTMC        ; BETTER BE AN ATOM\r
 903         MOVEM   C,E.ARGL+1(TB)\r
 904         MOVE    A,E.FRM(TB)     ; RETURN FORM\r
 905         MOVE    B,E.FRM+1(TB)\r
 906         PUSHJ   P,PSBND1        ; BIND AND CHECK\r
 907         JRST    APEXP5\r
 908         \f\r
 909 ; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE\r
 910 \r
 911 BNDRG:  PUSHJ   P,BNDEM1        ; GO BIND THEM UP\r
 912         TRNN    A,4             ; SKIP IF HIT A DCL\r
 913         JRST    APEXP4          ; NOT A DCL, MUST BE DONE\r
 914 \r
 915 ; LOOK FOR "OPTIONAL" DECLARATION\r
 916 \r
 917 CHOPT:  CAME    B,[<ASCII /OPTIO/>+1]\r
 918         JRST    CHREST          ; TRY TUPLE/ARGS\r
 919         MOVEM   C,E.ARGL+1(TB)  ; SAVE RESTED ARGLIST\r
 920         PUSHJ   P,BNDEM2        ; DO ALL SUPPLIED OPTIONALS\r
 921         TRNN    A,4             ; SKIP IF NEW DCL READ\r
 922         JRST    APEXP4\r
 923 \r
 924 ; CHECK FOR "ARGS" DCL\r
 925 \r
 926 CHREST: CAME    B,[ASCII /ARGS/]\r
 927         JRST    CHRST1          ; GO LOOK FOR "TUPLE"\r
 928         SKIPGE  E.ARG+1(TB)     ; SKIP IF LEGAL \r
 929         JRST    MPD.3\r
 930         PUSHJ   P,CARTMC        ; GOBBLE ATOM\r
 931         MOVEM   C,E.ARGL+1(TB)  ; SAVE CDR'D ARG\r
 932         HRRZ    B,@E.FRM+1(TB)  ; GET ARG LIST\r
 933         MOVSI   A,TLIST         ; GET TYPE\r
 934         PUSHJ   P,PSBND1\r
 935         JRST    APEXP5\r
 936 \r
 937 ; HERE TO CHECK FOR "TUPLE"\r
 938 \r
 939 CHRST1: CAME    B,[ASCII /TUPLE/]\r
 940         JRST    APXP10\r
 941         PUSHJ   P,CARTMC        ; GOBBLE ATOM\r
 942         MOVEM   C,E.ARGL+1(TB)\r
 943         SETZB   A,B\r
 944         PUSHJ   P,PSHBND        ; SET UP BINDING\r
 945         SETZM   E.CNT+1(TB)     ; ZERO ARG COUNTER\r
 946 \r
 947 TUPLP:  PUSHJ   P,@E.ARG+1(TB)  ; GET AN ARG\r
 948         JRST    TUPDON          ; FINIS\r
 949         AOS     E.CNT+1(TB)\r
 950         PUSH    TP,A\r
 951         PUSH    TP,B\r
 952         JRST    TUPLP\r
 953 \r
 954 TUPDON: PUSHJ   P,MAKINF        ; MAKE INFO CELL\r
 955         PUSH    TP,$TINFO               ; FENCE POST TUPLE\r
 956         PUSHJ   P,TBTOTP\r
 957         ADDI    D,TM.OFF        ; COMPENSATE FOR MOVEMENT\r
 958         PUSH    TP,D\r
 959         MOVE    C,E.CNT+1(TB)   ; GET COUNT\r
 960         ASH     C,1             ; TO WORDS\r
 961         HRRM    C,-1(TP)        ; INTO FENCE POST\r
 962         MOVEI   B,-TM.OFF-1(TP) ; SETUP ARG POINTER\r
 963         SUBI    B,(C)           ; POINT TO BASE OF TUPLE\r
 964         MOVNS   C               ; FOR AOBJN POINTER\r
 965         HRLI    B,(C)           ; GOOD ARGS POINTER\r
 966         MOVEM   A,TM.OFF-4(B)   ; STORE\r
 967         MOVEM   B,TM.OFF-3(B)\r
 968 \r
 969 \f\r
 970 ; CHECK FOR VALID ENDING TO ARGS\r
 971 \r
 972 APEXP5: PUSHJ   P,NEXTD         ; READ NEXT THING IN ARGLIST\r
 973         JRST    APEXP8          ; DONE\r
 974         TRNN    A,4             ; SKIP IF DCL\r
 975         JRST    MPD.4           ; LOSER\r
 976 APEXP7: MOVSI   A,-NWINS        ; CHECK FOR A WINNER\r
 977         CAME    B,WINRS(A)\r
 978         AOBJN   A,.-1\r
 979         JUMPE   A,MPD.6         ; NOT A WINNER\r
 980 \r
 981 ; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS\r
 982 \r
 983 APEXP8: MOVE    0,E.HEW+1(TB)   ; GET HEWITT ATOM\r
 984         MOVE    E,E.FCN(TB)     ; SAVE COUNTER\r
 985         MOVE    C,E.FCN+1(TB)   ; FCN\r
 986         MOVE    B,E.ARGL+1(TB)  ; ARG LIST\r
 987         MOVE    D,E.DECL+1(TB)  ; AND DCLS\r
 988         MOVEI   A,R.TMP(TB)     ; SET UP BLT\r
 989         HRLI    A,TM.OFF(A)\r
 990         BLT     A,-TM.OFF(TP)   ; BLLLLLLLLLLLLLT\r
 991         SUB     TP,[TM.OFF,,TM.OFF]     ; FLUSH CRUFT\r
 992         MOVEM   E,RE.FCN(TB)\r
 993         MOVEM   C,RE.FCN+1(TB)\r
 994         MOVEM   B,RE.ARGL+1(TB)\r
 995         MOVE    E,TP\r
 996         PUSH    TP,$TATOM\r
 997         PUSH    TP,0\r
 998         PUSH    TP,$TDECL\r
 999         PUSH    TP,D\r
1000         GETYP   A,-5(TP)        ; TUPLE ON TOP?\r
1001         CAIE    A,TINFO         ; SKIP IF YES\r
1002         JRST    APEXP9\r
1003         HRRZ    A,-5(TP)                ; GET SIZE\r
1004         ADDI    A,2\r
1005         HRLI    A,(A)\r
1006         SUB     E,A             ; POINT TO BINDINGS\r
1007         SKIPE   C,(TP)          ; IF DCL\r
1008         PUSHJ   P,CHKDCL        ; CHECK TYPE SPEC ON TUPLE\r
1009 APEXP9: PUSHJ   P,USPCBE        ; DO ACTUAL BINDING\r
1010 \r
1011         MOVE    E,-2(TP)        ; RESTORE HEWITT ATOM\r
1012         MOVE    D,(TP)          ; AND DCLS\r
1013         SUB     TP,[4,,4]\r
1014 \r
1015         JRST    AUXBND          ; GO BIND AUX'S\r
1016 \r
1017 ; HERE TO VERIFY CHECK IF ANY ARGS LEFT\r
1018 \r
1019 APEXP4: PUSHJ   P,@E.ARG+1(TB)\r
1020         JRST    APEXP8          ; WIN\r
1021         JRST    TMA             ; TOO MANY ARGS\r
1022 \r
1023 APXP10: PUSH    P,B\r
1024         PUSHJ   P,@E.ARG+1(TB)\r
1025         JRST    .+2\r
1026         JRST    TMA\r
1027         POP     P,B\r
1028         JRST    APEXP7\r
1029 \r
1030 ; LIST OF POSSIBLE TERMINATING NAMES\r
1031 \r
1032 WINRS:\r
1033 AS.ACT: ASCII /ACT/\r
1034 AS.NAM: ASCII /NAME/\r
1035 AS.AUX: ASCII /AUX/\r
1036 AS.EXT: ASCII /EXTRA/\r
1037 NWINS==.-WINRS\r
1038 \r
1039  \f\r
1040 ; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS\r
1041 \r
1042 AUXBND: PUSH    P,E             ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK\r
1043                                 ;  WHEN NECESSARY)\r
1044         PUSH    P,D             ; SAME WITH DCL LIST\r
1045         PUSH    P,[-1]          ; FLAG SAYING WE ARE FCN\r
1046         SKIPN   C,RE.ARG+1(TB)  ; GET ARG LIST\r
1047         JRST    AUXDON\r
1048         GETYP   0,(C)           ; GET TYPE\r
1049         CAIE    0,TDEFER        ; SKIP IF CHSTR\r
1050         MOVMS   (P)             ; SAY WE ARE IN OPTIONALS\r
1051         JRST    AUXB1\r
1052 \r
1053 PRGBND: PUSH    P,E\r
1054         PUSH    P,D\r
1055         PUSH    P,[0]           ; WE ARE IN AUXS\r
1056 \r
1057 AUXB1:  HRRZ    C,RE.ARG+1(TB)  ; POINT TO ARGLIST\r
1058         PUSHJ   P,NEXTDC        ; GET NEXT THING OFF OF ARG LIST\r
1059         JRST    AUXDON\r
1060         TRNE    A,4             ; SKIP IF SOME KIND OF ATOM\r
1061         JRST    TRYDCL          ; COUDL BE DCL\r
1062         TRNN    A,1             ; SKIP IF QUOTED\r
1063         JRST    AUXB2\r
1064         SKIPN   (P)             ; SKIP IF QUOTED OK\r
1065         JRST    MPD.11\r
1066 AUXB2:  PUSHJ   P,PSHBND        ; SET UP BINDING\r
1067         PUSH    TP,$TDECL       ; SAVE HEWITT ATOM\r
1068         PUSH    TP,-1(P)\r
1069         PUSH    TP,$TATOM       ; AND DECLS\r
1070         PUSH    TP,-2(P)\r
1071 \r
1072         TRNN    A,2             ; SKIP IF INIT VAL EXISTS\r
1073         JRST    AUXB3           ; NO, USE UNBOUND\r
1074 \r
1075 ; EVALUATE EXPRESSION\r
1076 \r
1077         HRRZ    C,(B)           ; CDR ATOM OFF\r
1078 \r
1079 ; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>\r
1080 \r
1081         GETYP   0,(C)           ; GET TYPE OF GOODIE\r
1082         CAIE    0,TFORM         ; SMELLS LIKE A FORM\r
1083         JRST    AUXB13\r
1084         HRRZ    D,1(C)          ; GET 1ST ELEMENT\r
1085         GETYP   0,(D)           ; AND ITS VAL\r
1086         CAIE    0,TATOM         ; FEELS LIKE THE RIGHT FORM\r
1087         JRST    AUXB13\r
1088 \r
1089         MOVE    0,1(D)          ; GET THE ATOM\r
1090         CAME    0,MQUOTE TUPLE\r
1091         CAMN    0,MQUOTE ITUPLE\r
1092         JRST    DOTUPL          ; SURE GLAD I DIDN'T STEP IN THAT FORM\r
1093 \r
1094 \r
1095 AUXB13: PUSHJ   P,FASTEV\r
1096 AUXB14: MOVE    E,TP\r
1097 AUXB4:  MOVEM   A,-7(E)         ; STORE VAL IN BINDING\r
1098         MOVEM   B,-6(E)\r
1099 \r
1100 ; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING\r
1101 \r
1102 AUXB5:  SUB     E,[4,,4]        ; POINT TO BINDING TOP\r
1103         SKIPE   C,-2(TP)        ; POINT TO DECLARATINS\r
1104         PUSHJ   P,CHKDCL        ; CHECK  IT\r
1105         PUSHJ   P,USPCBE        ; AND BIND UP\r
1106         SKIPE   C,RE.ARG+1(TB)  ; CDR DCLS\r
1107         HRRZ    C,(C)           ; IF ANY TO CDR\r
1108         MOVEM   C,RE.ARG+1(TB)\r
1109         MOVE    A,(TP)          ; NOW PUT HEWITT ATOM AND DCL AWAY\r
1110         MOVEM   A,-2(P)\r
1111         MOVE    A,-2(TP)\r
1112         MOVEM   A,-1(P)\r
1113         SUB     TP,[4,,4]       ; FLUSH SLOTS\r
1114         JRST    AUXB1\r
1115 \r
1116 \r
1117 AUXB3:  MOVNI   B,1\r
1118         MOVSI   A,TUNBOU\r
1119         JRST    AUXB14\r
1120 \r
1121 \f\r
1122 \r
1123 ; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE\r
1124 \r
1125 DOTUPL: PUSH    TP,$TLIST       ; SAVE THE MAGIC FORM\r
1126         PUSH    TP,D\r
1127         CAME    0,MQUOTE TUPLE\r
1128         JRST    DOITUP          ; DO AN ITUPLE\r
1129 \r
1130 ; FALL INTO A TUPLE PUSHING LOOP\r
1131 \r
1132 DOTUP1: HRRZ    C,@(TP)         ; CDR THE FORM\r
1133         JUMPE   C,ATUPDN        ; FINISHED\r
1134         MOVEM   C,(TP)          ; SAVE CDR'D RESULT\r
1135         GETYP   0,(C)           ; CHECK FOR SEGMENT\r
1136         CAIN    0,TSEG\r
1137         JRST    DTPSEG          ; GO PULL IT APART\r
1138         PUSHJ   P,FASTEV        ; EVAL IT\r
1139         PUSHJ   P,CNTARG        ; PUSH IT UP AND COUNT THEM\r
1140         JRST    DOTUP1\r
1141 \r
1142 ; HERE WHEN WE FINISH\r
1143 \r
1144 ATUPDN: SUB     TP,[2,,2]       ; FLUSH THE LIST\r
1145         ASH     E,1             ; E HAS # OF ARGS DOUBLE IT\r
1146         MOVEI   D,(TP)          ; FIND BASE OF STACK AREA\r
1147         SUBI    D,(E)\r
1148         MOVSI   C,-3(D)         ; PREPARE BLT POINTER\r
1149         BLT     C,C             ; HEWITT ATOM AND DECL TO 0,A,B,C\r
1150 \r
1151 ; NOW PREPEARE TO BLT TUPLE DOWN\r
1152 \r
1153         MOVEI   D,-3(D)         ; NEW DEST\r
1154         HRLI    D,4(D)          ; SOURCE\r
1155         BLT     D,-4(TP)        ; SLURP THEM DOWN\r
1156 \r
1157         HRLI    E,TINFO         ; SET UP FENCE POST\r
1158         MOVEM   E,-3(TP)        ; AND STORE\r
1159         PUSHJ   P,TBTOTP        ; GET OFFSET\r
1160         ADDI    D,3             ; FUDGE FOR NOT AT TOP OF STACK\r
1161         MOVEM   D,-2(TP)\r
1162         MOVEM   0,-1(TP)        ; RESTORE HEW ATOM AND  DECLS\r
1163         MOVEM   A,(TP)\r
1164         PUSH    TP,B\r
1165         PUSH    TP,C\r
1166 \r
1167         PUSHJ   P,MAKINF        ; MAKE 1ST WORD OF FUNNYS\r
1168 \r
1169         HRRZ    E,-5(TP)        ; RESTORE WORDS OF TUPLE\r
1170         HRROI   B,-5(TP)        ; POINT TO TOP OF TUPLE\r
1171         SUBI    B,(E)           ; NOW BASE\r
1172         TLC     B,-1(E)         ; FIX UP AOBJN PNTR\r
1173         ADDI    E,2             ; COPNESATE FOR FENCE PST\r
1174         HRLI    E,(E)\r
1175         SUBM    TP,E            ; E POINT TO BINDING\r
1176         JRST    AUXB4           ; GO CLOBBER IT IN\r
1177 \f\r
1178 \r
1179 ; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS\r
1180 \r
1181 DTPSEG: PUSH    TP,$TFORM       ; SAVE THE HACKER\r
1182         PUSH    TP,1(C)\r
1183         MCALL   1,EVAL          ; AND EVALUATE IT\r
1184         MOVE    D,B             ; GET READY FOR A SEG LOOP\r
1185         MOVEM   A,DSTO(PVP)\r
1186         PUSHJ   P,TYPSEG        ; TYPE AND CHECK IT\r
1187 \r
1188 DTPSG1: INTGO                   ; DONT BLOW YOUR STACK\r
1189         PUSHJ   P,NXTLM         ; ELEMENT TO A AND B\r
1190         JRST    DTPSG2          ; DONE\r
1191         PUSHJ   P,CNTARG        ; PUSH AND COUNT\r
1192         JRST    DTPSG1\r
1193 \r
1194 DTPSG2: SETZM   DSTO(PVP)\r
1195         JRST    DOTUP1          ; REST OF ARGS STILL TO DO\r
1196 \r
1197 ; HERE TO HACK <ITUPLE .....>\r
1198 \r
1199 DOITUP: HRRZ    C,@(TP)         ; GET COUNT FILED\r
1200         JUMPE   C,TUPTFA\r
1201         MOVEM   C,(TP)\r
1202         PUSHJ   P,FASTEV        ; EVAL IT\r
1203         GETYP   0,A\r
1204         CAIE    0,TFIX\r
1205         JRST    WTY1TP\r
1206 \r
1207         JUMPL   B,BADNUM\r
1208 \r
1209         HRRZ    C,@(TP)         ; GET EXP TO EVAL\r
1210         MOVEI   0,0             ; DONT LOSE IN 1 ARG CASE\r
1211         HRRZ    0,(C)           ; VERIFY WINNAGE\r
1212         JUMPN   0,TUPTMA        ; TOO MANY\r
1213 \r
1214         JUMPE   B,DOIDON\r
1215         PUSH    P,B             ; SAVE COUNT\r
1216         PUSH    P,B\r
1217         JUMPE   C,DOILOS\r
1218         PUSHJ   P,FASTEV        ; EVAL IT ONCE\r
1219         MOVEM   A,-1(TP)\r
1220         MOVEM   B,(TP)\r
1221 \r
1222 DOILP:  INTGO\r
1223         PUSH    TP,-1(TP)\r
1224         PUSH    TP,-1(TP)\r
1225         MCALL   1,EVAL\r
1226         PUSHJ   P,CNTRG\r
1227         SOSLE   (P)\r
1228         JRST    DOILP\r
1229 \r
1230 DOIDO1: MOVE    B,-1(P)         ; RESTORE COUNT\r
1231         SUB     P,[2,,2]\r
1232 \r
1233 DOIDON: MOVEI   E,(B)\r
1234         JRST    ATUPDN\r
1235 \r
1236 ; FOR CASE OF NO EVALE\r
1237 \r
1238 DOILOS: SUB     TP,[2,,2]\r
1239 DOILLP: INTGO\r
1240         PUSH    TP,[0]\r
1241         PUSH    TP,[0]\r
1242         SOSL    (P)\r
1243         JRST    DOILLP\r
1244         JRST    DOIDO1\r
1245 \r
1246 ; ROUTINE TO PUSH NEXT TUPLE ELEMENT\r
1247 \r
1248 CNTARG: AOS     E,-1(TP)        ; KEEP ARG COUNT UP TO DATE IN E\r
1249 CNTRG:  EXCH    A,-1(TP)        ; STORE ELEM AND GET SAVED\r
1250         EXCH    B,(TP)\r
1251         PUSH    TP,A\r
1252         PUSH    TP,B\r
1253         POPJ    P,\r
1254 \r
1255 \r
1256 ; DUMMY TUPLE AND ITUPLE \r
1257 \r
1258 MFUNCTION TUPLE,SUBR\r
1259 \r
1260         ENTRY\r
1261         PUSH    TP,$TATOM\r
1262         PUSH    TP,EQUOTE NOT-IN-ARG-LIST\r
1263         JRST    CALER1\r
1264 \r
1265 MFUNCTIO ITUPLE,SUBR\r
1266         JRST    TUPLE\r
1267 \r
1268 \f\r
1269 ; PROCESS A DCL IN THE AUX VAR LISTS\r
1270 \r
1271 TRYDCL: SKIPN   (P)             ; SKIP IF NOT IN AUX'S\r
1272         JRST    AUXB7\r
1273         CAME    B,AS.AUX        ; "AUX" ?\r
1274         CAMN    B,AS.EXT        ; OR "EXTRA"\r
1275         JRST    AUXB9           ; YES\r
1276         CAME    B,[ASCII /TUPLE/]\r
1277         JRST    AUXB10\r
1278         PUSHJ   P,MAKINF        ; BUILD EMPTY TUPLE\r
1279         MOVEI   B,1(TP)\r
1280         PUSH    TP,$TINFO               ; FENCE POST\r
1281         PUSHJ   P,TBTOTP\r
1282         PUSH    TP,D\r
1283 AUXB6:  HRRZ    C,(C)           ; CDR PAST DCL\r
1284         MOVEM   C,RE.ARG+1(TB)\r
1285 AUXB8:  PUSHJ   P,CARTMC        ; GET ATOM\r
1286 AUXB12: PUSHJ   P,PSHBND        ; UP GOES THE BINDING\r
1287         PUSH    TP,$TATOM       ; HIDE HEWITT ATOM AND DCL\r
1288         PUSH    TP,-1(P)\r
1289         PUSH    TP,$TDECL\r
1290         PUSH    TP,-2(P)\r
1291         MOVE    E,TP\r
1292         JRST    AUXB5\r
1293 \r
1294 ; CHECK FOR ARGS\r
1295 \r
1296 AUXB10: CAME    B,[ASCII /ARGS/]\r
1297         JRST    AUXB7\r
1298         MOVEI   B,0             ; NULL ARG LIST\r
1299         MOVSI   A,TLIST\r
1300         JRST    AUXB6           ; GO BIND\r
1301 \r
1302 AUXB9:  SETZM   (P)             ; NOW READING AUX\r
1303         HRRZ    C,(C)\r
1304         MOVEM   C,RE.ARG+1(TB)\r
1305         JRST    AUXB1\r
1306 \r
1307 ; CHECK FOR NAME/ACT\r
1308 \r
1309 AUXB7:  CAME    B,AS.NAM\r
1310         CAMN    B,AS.ACT\r
1311         JRST    .+2\r
1312         JRST    MPD.12          ; LOSER\r
1313         HRRZ    C,(C)           ; CDR ON\r
1314         HRRZ    0,(C)           ; BETTER BE END\r
1315         JUMPN   0,MPD.13\r
1316         PUSHJ   P,CARTMC        ; FORCE ATOM READ\r
1317         SETZM   RE.ARG+1(TB)\r
1318 AUXB11: PUSHJ   P,MAKACT        ; MAKE ACTIVATION\r
1319         JRST    AUXB12          ; AND BIND IT\r
1320 \r
1321 \r
1322 ; DONE BIND HEWITT ATOM IF NECESARY\r
1323 \r
1324 AUXDON: SKIPN   E,-2(P)\r
1325         JRST    AUXD1\r
1326         SETZM   -2(P)\r
1327         JRST    AUXB11\r
1328 \r
1329 ; FINISHED, RETURN\r
1330 \r
1331 AUXD1:  SUB     P,[3,,3]\r
1332         POPJ    P,\r
1333 \r
1334 \r
1335 ; MAKE AN ACTIVATION OR ENVIRONMNENT\r
1336 \r
1337 MAKACT: MOVEI   B,(TB)\r
1338         MOVSI   A,TACT\r
1339 MAKAC1: HRRI    A,PVLNT*2+1(PVP)        ; POINT TO PROCESS\r
1340         HLL     B,OTBSAV(B)     ; GET TIME\r
1341         POPJ    P,\r
1342 \r
1343 MAKENV: MOVSI   A,TENV\r
1344         HRRZ    B,OTBSAV(TB)\r
1345         JRST    MAKAC1\r
1346 \f\r
1347 ; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF\r
1348 \r
1349 ; CARAT/CARATC/CARATM/CARTMC  ALL LOOK FOR THE NEXT ATOM\r
1350 \r
1351 CARAT:  HRRZ    C,E.ARGL+1(TB)  ; PICK UP ARGLIST\r
1352 CARATC: JUMPE   C,CPOPJ         ; FOUND\r
1353         GETYP   0,(C)           ; GET ITS TYPE\r
1354         CAIE    0,TATOM\r
1355 CPOPJ:  POPJ    P,              ; RETURN, NOT ATOM\r
1356         MOVE    E,1(C)          ; GET ATOM\r
1357         HRRZ    C,(C)           ; CDR DCLS\r
1358         JRST    CPOPJ1\r
1359 \r
1360 CARATM: HRRZ    C,E.ARGL+1(TB)\r
1361 CARTMC: PUSHJ   P,CARATC\r
1362         JRST    MPD.7           ; REALLY LOSE\r
1363         POPJ    P,\r
1364 \r
1365 \r
1366 ; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK\r
1367 \r
1368 PSBND1: PUSHJ   P,PSHBND        ; PUSH THEBINDING\r
1369         JRST    CHDCL           ; NOW CHECK IT AGAINST DECLARATION\r
1370 \r
1371 PSHBND: SKIPGE  SPCCHK          ; SKIP IF NORMAL SPECIAL\r
1372         PUSH    TP,BNDA1        ; ATOM IN E\r
1373         SKIPL   SPCCHK          ; SKIP IF NORMAL UNSPEC OR NO CHECK\r
1374         PUSH    TP,BNDA\r
1375         PUSH    TP,E            ; PUSH IT\r
1376 PSHAB4: PUSH    TP,A\r
1377         PUSH    TP,B\r
1378         PUSH    TP,[0]\r
1379         PUSH    TP,[0]\r
1380         POPJ    P,\r
1381 \r
1382 ; ROUTINE TO PUSH 4 0'S\r
1383 \r
1384 PSH4ZR: SETZB   A,B\r
1385         JRST    PSHAB4\r
1386 \r
1387 \r
1388 ; EXTRRA ARG GOBBLER\r
1389 \r
1390 EXTRGT: HRRZ    A,E.ARG(TB)     ; RESET SLOT\r
1391         CAIE    A,ARGCDR        ; IF NOT ARGCDR\r
1392         TLO     A,400000        ; SET FLAG\r
1393         MOVEM   A,E.ARG+1(TB)\r
1394         MOVE    A,E.EXTR(TB)    ; RET ARG\r
1395         MOVE    B,E.EXTR+1(TB)\r
1396         JRST    CPOPJ1\r
1397 \r
1398 ; CHECK A/B FOR DEFER\r
1399 \r
1400 CHKAB:  GETYP   0,A\r
1401         CAIE    0,TDEFER        ; SKIP IF DEFER\r
1402         JRST    (E)\r
1403         MOVE    A,(B)\r
1404         MOVE    B,1(B)          ; GET REAL THING\r
1405         JRST    (E)\r
1406 ; IF DECLARATIONS EXIST, DO THEM\r
1407 \r
1408 CHDCL:  MOVE    E,TP\r
1409 CHDCLE: SKIPN   C,E.DECL+1(TB)\r
1410         POPJ    P,\r
1411         JRST    CHKDCL\r
1412 \f\r
1413 ; ROUTINE TO READ NEXT THING FROM ARGLIST\r
1414 \r
1415 NEXTD:  HRRZ    C,E.ARGL+1(TB)  ; GET ARG LIST\r
1416 NEXTDC: JUMPE   C,CPOPJ\r
1417         PUSHJ   P,CARATC        ; TRY FOR AN ATOM\r
1418         JRST    NEXTD1          ; NO\r
1419         MOVEI   A,0             ; SET FLAG\r
1420         JRST    CPOPJ1\r
1421 \r
1422 NEXTD1: CAIE    0,TFORM         ; FORM?\r
1423         JRST    NXT.L           ; COULD BE LIST\r
1424         PUSHJ   P,CHQT          ; VERIFY 'ATOM\r
1425         MOVEI   A,1\r
1426         JRST    CPOPJ1\r
1427 \r
1428 NXT.L:  CAIE    0,TLIST         ; COULD BE (A <EXPRESS>) OR ('A <EXPRESS>)\r
1429         JRST    NXT.S           ; BETTER BE A DCL\r
1430         PUSHJ   P,LNT.2         ; VERIFY LENGTH IS 2\r
1431         JRST    MPD.8\r
1432         CAIE    0,TATOM         ; TYPE OF 1ST RET IN 0\r
1433         JRST    LST.QT          ; MAY BE 'ATOM\r
1434         MOVE    E,1(B)          ; GET ATOM\r
1435         MOVEI   A,2\r
1436         JRST    CPOPJ1\r
1437 LST.QT: CAIE    0,TFORM         ; FORM?\r
1438         JRST    MPD.9           ; LOSE\r
1439         PUSH    P,C\r
1440         MOVEI   C,(B)           ; VERIFY 'ATOM\r
1441         PUSHJ   P,CHQT\r
1442         MOVEI   B,(C)           ; POINT BACK TO LIST\r
1443         POP     P,C\r
1444         MOVEI   A,3             ; CODE\r
1445         JRST    CPOPJ1\r
1446 \r
1447 NXT.S:  MOVEI   A,(C)           ; LET NXTDCL FIND OUT\r
1448         PUSHJ   P,NXTDCL\r
1449         JRST    MPD.3           ; LOSER\r
1450         MOVEI   A,4             ; SET DCL READ FLAG\r
1451         JRST    CPOPJ1\r
1452 \r
1453 ; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2\r
1454 \r
1455 LNT.2:  HRRZ    B,1(C)          ; GET LIST/FORM\r
1456         JUMPE   B,CPOPJ\r
1457         HRRZ    B,(B)\r
1458         JUMPE   B,CPOPJ\r
1459         HRRZ    B,(B)           ; BETTER END HERE\r
1460         JUMPN   B,CPOPJ\r
1461         HRRZ    B,1(C)          ; LIST BACK\r
1462         GETYP   0,(B)           ; TYPE OF 1ST ELEMENT\r
1463         JRST    CPOPJ1\r
1464 \r
1465 ; ROUTINE TO  VERIFY FORM IS 'ATOM AND RET ATOM\r
1466 \r
1467 CHQT:   PUSHJ   P,LNT.2         ; 1ST LENGTH CHECK\r
1468         JRST    MPD.5\r
1469         CAIE    0,TATOM\r
1470         JRST    MPD.5\r
1471         MOVE    0,1(B)\r
1472         CAME    0,MQUOTE QUOTE\r
1473         JRST    MPD.5           ; BETTER BE QUOTE\r
1474         HRRZ    E,(B)           ; CDR\r
1475         GETYP   0,(E)           ; TYPE\r
1476         CAIE    0,TATOM\r
1477         JRST    MPD.5\r
1478         MOVE    E,1(E)          ; GET QUOTED ATOM\r
1479         POPJ    P,\r
1480 \f\r
1481 ; ARG BINDER FOR REGULAR ARGS AND OPTIONALS\r
1482 \r
1483 BNDEM1: PUSH    P,[0]           ; REGULAR FLAG\r
1484         JRST    .+2\r
1485 BNDEM2: PUSH    P,[1]\r
1486 BNDEM:  PUSHJ   P,NEXTD         ; GET NEXT THING\r
1487         JRST    CCPOPJ          ; END OF THINGS\r
1488         TRNE    A,4             ; CHECK FOR DCL\r
1489         JRST    BNDEM4\r
1490         TRNE    A,2             ; SKIP IF NOT (ATM ..) OR ('ATM ...)\r
1491         SKIPE   (P)             ; SKIP IF REG ARGS\r
1492         JRST    .+2             ; WINNER, GO ON\r
1493         JRST    MPD.6           ; LOSER\r
1494         SKIPGE  SPCCHK\r
1495         PUSH    TP,BNDA1        ; SAVE ATOM\r
1496         SKIPL   SPCCHK\r
1497         PUSH    TP,BNDA\r
1498         PUSH    TP,E\r
1499         SKIPL   E.ARG+1(TB)     ; SKIP IF MUST EVAL ARG\r
1500         TRNN    A,1             ; SKIP IF ARG QUOTED\r
1501         JRST    RGLARG\r
1502         HRRZ    D,@E.FRM+1(TB)  ; GET AND CDR ARG\r
1503         JUMPE   D,TFACHK        ; OH OH MAYBE TOO FEW ARGS\r
1504         MOVEM   D,E.FRM+1(TB)   ; STORE WINNER\r
1505         HLLZ    A,(D)           ; GET ARG\r
1506         MOVE    B,1(D)\r
1507         JSP     E,CHKAB ; HACK DEFER\r
1508         JRST    BNDEM3          ; AND GO ON\r
1509 \r
1510 RGLARG: PUSH    P,A             ; SAVE FLAGS\r
1511         PUSHJ   P,@E.ARG+1(TB)\r
1512         JRST    TFACH1          ; MAY GE TOO FEW\r
1513         SUB     P,[1,,1]\r
1514 BNDEM3: HRRZ    C,@E.ARGL+1(TB) ; CDR THHE ARGS\r
1515         MOVEM   C,E.ARGL+1(TB)\r
1516         PUSHJ   P,PSHAB4        ; PUSH VALUE AND SLOTS\r
1517         PUSHJ   P,CHDCL         ; CHECK DCLS\r
1518         JRST    BNDEM           ; AND BIND ON!\r
1519 \r
1520 ; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA\r
1521 \r
1522 TFACH1: POP     P,A\r
1523 TFACHK: SUB     TP,[2,,2]       ; FLUSH ATOM\r
1524         SKIPN   (P)             ; SKIP IF OPTIONALS\r
1525         JRST    TFA\r
1526 CCPOPJ: SUB     P,[1,,1]\r
1527         POPJ    P,\r
1528 \r
1529 BNDEM4: HRRZ    C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL\r
1530         JRST    CCPOPJ\r
1531 \f\r
1532 \r
1533 ; EVALUATE LISTS, VECTORS, UNIFROM VECTORS\r
1534 \r
1535 EVLIST: PUSH    P,[-1]          ;-1 -- THIS IS A LIST\r
1536         JRST    EVL1            ;GO TO HACKER\r
1537 \r
1538 EVECT:  PUSH    P,[0]           ;0 -- THIS IS A GENERAL VECTOR\r
1539         JRST    EVL1\r
1540 \r
1541 EUVEC:  PUSH    P,[1]           ;1 -- THIS IS A UNIFORM VECTOR\r
1542 \r
1543 EVL1:   PUSH    P,[0]           ;PUSH A COUNTER\r
1544         GETYPF  A,(AB)          ;GET FULL TYPE\r
1545         PUSH    TP,A\r
1546         PUSH    TP,1(AB)        ;AND VALUE\r
1547 \r
1548 EVL2:   INTGO                   ;CHECK INTERRUPTS\r
1549         SKIPN   A,1(TB)         ;ANYMORE\r
1550         JRST    EVL3            ;NO, QUIT\r
1551         SKIPL   -1(P)           ;SKIP IF LIST\r
1552         JUMPG   A,EVL3          ;JUMP IF VECTOR EMPTY\r
1553         GETYPF  B,(A)           ;GET FULL TYPE\r
1554         SKIPGE  C,-1(P)         ;SKIP IF NOT LIST\r
1555         HLLZS   B               ;CLOBBER CDR FIELD\r
1556         JUMPG   C,EVL7          ;HACK UNIFORM VECS\r
1557 EVL8:   PUSH    P,B             ;SAVE TYPE WORD ON P\r
1558         CAMN    B,$TSEG         ;SEGMENT?\r
1559         MOVSI   B,TFORM         ;FAKE OUT EVAL\r
1560         PUSH    TP,B            ;PUSH TYPE\r
1561         PUSH    TP,1(A)         ;AND VALUE\r
1562         JSP     E,CHKARG        ; CHECK DEFER\r
1563         MCALL   1,EVAL          ;AND EVAL IT\r
1564         POP     P,C             ;AND RESTORE REAL TYPE\r
1565         CAMN    C,$TSEG         ;SEGMENT?\r
1566         JRST    DOSEG           ;YES, HACK IT\r
1567         AOS     (P)             ;COUNT ELEMENT\r
1568         PUSH    TP,A            ;AND PUSH IT\r
1569         PUSH    TP,B\r
1570 EVL6:   SKIPGE  A,-1(P) ;DONT SKIP IF LIST\r
1571         HRRZ    B,@1(TB)        ;CDR IT\r
1572         JUMPL   A,ASTOTB        ;AND STORE IT\r
1573         MOVE    B,1(TB)         ;GET VECTOR POINTER\r
1574         ADD     B,AMNT(A)       ;INCR BY APPROPRIATE AMOUNT\r
1575 ASTOTB: MOVEM   B,1(TB)         ;AND STORE BACK\r
1576         JRST    EVL2            ;AND LOOP BACK\r
1577 \r
1578 AMNT:   2,,2                    ;INCR FOR GENERAL VECTOR\r
1579         1,,1                    ;SAME FOR UNIFORM VECTOR\r
1580 \r
1581 CHKARG: GETYP   A,-1(TP)\r
1582         CAIE    A,TDEFER\r
1583         JRST    (E)\r
1584         HRRZS   (TP)            ;MAKE SURE INDIRECT WINS\r
1585         MOVE    A,@(TP)\r
1586         MOVEM   A,-1(TP)                ;CLOBBER IN TYPE SLOT\r
1587         MOVE    A,(TP)          ;NOW GET POINTER\r
1588         MOVE    A,1(A)          ;GET VALUE\r
1589         MOVEM   A,(TP)          ;CLOBBER IN\r
1590         JRST    (E)\r
1591 \r
1592 \f\r
1593 \r
1594 EVL7:   HLRE    C,A             ; FIND TYPE OF UVECTOR\r
1595         SUBM    A,C             ;C POINTS TO DOPE WORD\r
1596         GETYP   B,(C)           ;GET TYPE\r
1597         MOVSI   B,(B)           ;TO LH NOW\r
1598         SOJA    A,EVL8          ;AND RETURN TO DO EVAL\r
1599 \r
1600 EVL3:   SKIPL   -1(P)           ;SKIP IF LIST\r
1601         JRST    EVL4            ;EITHER VECTOR OR UVECTOR\r
1602 \r
1603         MOVEI   B,0             ;GET A NIL\r
1604 EVL9:   MOVSI   A,TLIST         ;MAKE TYPE WIN\r
1605 EVL5:   SOSGE   (P)             ;COUNT DOWN\r
1606         JRST    EVL10           ;DONE, RETURN\r
1607         PUSH    TP,$TLIST       ;SET TO CALL CONS\r
1608         PUSH    TP,B\r
1609         MCALL   2,CONS\r
1610         JRST    EVL5            ;LOOP TIL DONE\r
1611 \r
1612 \r
1613 EVL4:   MOVEI   B,EUVECT        ;UNIFORM CASE\r
1614         SKIPG   -1(P)           ;SKIP IF UNIFORM CASE\r
1615         MOVEI   B,EVECTO        ;NO, GENERAL CASE\r
1616         POP     P,A             ;GET COUNT\r
1617         .ACALL  A,(B)           ;CALL CREATOR\r
1618 EVL10:  GETYPF  A,(AB)          ; USE SENT TYPE\r
1619         JRST    EFINIS\r
1620 \r
1621 \f\r
1622 ; PROCESS SEGMENTS FOR THESE  HACKS\r
1623 \r
1624 DOSEG:  PUSHJ   P,TYPSEG        ; FIND WHAT IS BEING SEGMENTED\r
1625         JUMPE   C,LSTSEG        ; CHECK END SPLICE IF LIST\r
1626 \r
1627 SEG3:   PUSHJ   P,NXTELM        ; GET THE NEXTE ELEMT\r
1628         JRST    SEG4            ; RETURN TO CALLER\r
1629         AOS     (P)             ; COUNT\r
1630         JRST    SEG3            ; TRY AGAIN\r
1631 SEG4:   SETZM   DSTO(PVP)\r
1632         JRST    EVL6\r
1633 \r
1634 TYPSEG: PUSHJ   P,TYPSGR\r
1635         JRST    ILLSEG\r
1636         POPJ    P,\r
1637 \r
1638 TYPSGR: MOVEM   A,DSTO(PVP)     ;WILL BECOME INTERRUPTABLE WITH GOODIE IN D\r
1639         GETYP   A,A             ; TYPE TO RH\r
1640         PUSHJ   P,SAT           ;GET STORAGE TYPE\r
1641         MOVE    D,B             ; GOODIE TO D\r
1642 \r
1643         MOVNI   C,1             ; C <0 IF ILLEGAL\r
1644         CAIN    A,S2WORD        ;LIST?\r
1645         MOVEI   C,0\r
1646         CAIN    A,S2NWORD       ;GENERAL VECTOR?\r
1647         MOVEI   C,1\r
1648         CAIN    A,SNWORD        ;UNIFORM VECTOR?\r
1649         MOVEI   C,2\r
1650         CAIN    A,SCHSTR\r
1651         MOVEI   C,3\r
1652         CAIN    A,SSTORE        ;SPECIAL AFREE STORAGE ?\r
1653         MOVEI   C,2             ;TREAT LIKE A UVECTOR\r
1654         CAIN    A,SARGS         ;ARGS TUPLE?\r
1655         JRST    SEGARG          ;NO, ERROR\r
1656         CAILE   A,NUMSAT        ; SKIP IF NOT TEMPLATE\r
1657         JRST    SEGTMP\r
1658         JUMPGE  C,CPOPJ1\r
1659         SETZM   DSTO(PVP)       ; DON'T CONFUSE AGC LATER!\r
1660         POPJ    P,\r
1661 \r
1662 SEGTMP: MOVEI   C,4\r
1663         HRRM    A,DSTO(PVP)     ; SAVE FOR HACKERS\r
1664         JRST    CPOPJ1\r
1665 \r
1666 SEGARG: PUSH    TP,DSTO(PVP)    ;PREPARE TO CHECK ARGS\r
1667         PUSH    TP,D\r
1668         SETZM   DSTO(PVP)       ;TYPE NOT SPECIAL\r
1669         MOVEI   B,-1(TP)        ;POINT TO SAVED COPY\r
1670         PUSHJ   P,CHARGS        ;CHECK ARG POINTER\r
1671         POP     TP,D            ;AND RESTORE WINNER\r
1672         POP     TP,DSTO(PVP)    ;AND TYPE AND FALL INTO VECTOR CODE\r
1673         MOVEI   C,1\r
1674         JRST    CPOPJ1\r
1675 \r
1676 LSTSEG: SKIPL   -1(P)           ;SKIP IF IN A LIST\r
1677         JRST    SEG3            ;ELSE JOIN COMMON CODE\r
1678         HRRZ    A,@1(TB)        ;CHECK FOR END OF LIST\r
1679         JUMPN   A,SEG3          ;NO, JOIN COMMON CODE\r
1680         SETZM   DSTO(PVP)       ;CLOBBER SAVED GOODIES\r
1681         JRST    EVL9            ;AND FINISH UP\r
1682 \r
1683 NXTELM: INTGO\r
1684         PUSHJ   P,NXTLM         ; GOODIE TO A AND B\r
1685         POPJ    P,              ; DONE\r
1686         PUSH    TP,A\r
1687         PUSH    TP,B\r
1688         JRST    CPOPJ1\r
1689 NXTLM:  XCT     TESTR(C)        ; SKIP IF MORE IN SEGEMNT\r
1690         POPJ    P,\r
1691         XCT     TYPG(C)         ; GET THE TYPE\r
1692         XCT     VALG(C)         ; AND VALUE\r
1693         JSP     E,CHKAB         ; CHECK DEFERRED\r
1694         XCT     INCR1(C)        ; AND INCREMENT TO NEXT\r
1695 CPOPJ1: AOS     (P)             ; SKIP RETURN\r
1696         POPJ    P,\r
1697 \r
1698 ; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING)\r
1699 \r
1700 TESTR:  SKIPN   D\r
1701         SKIPL   D\r
1702         SKIPL   D\r
1703         PUSHJ   P,CHRDON\r
1704         PUSHJ   P,TM1\r
1705 \r
1706 TYPG:   PUSHJ   P,LISTYP\r
1707         GETYPF  A,(D)\r
1708         PUSHJ   P,UTYPE\r
1709         MOVSI   A,TCHRS\r
1710         PUSHJ   P,TM2\r
1711 \r
1712 VALG:   MOVE    B,1(D)\r
1713         MOVE    B,1(D)\r
1714         MOVE    B,(D)\r
1715         PUSHJ   P,1CHGT\r
1716         PUSHJ   P,TM3\r
1717 \r
1718 INCR1:  HRRZ    D,(D)\r
1719         ADD     D,[2,,2]\r
1720         ADD     D,[1,,1]\r
1721         PUSHJ   P,1CHINC\r
1722         ADD     D,[1,,]\r
1723 \r
1724 TM1:    HRRZ    A,DSTO(PVP)     ; GET SAT\r
1725         SUBI    A,NUMSAT+1\r
1726         ADD     A,TD.LNT+1(TVP)\r
1727         EXCH    C,D\r
1728         XCT     (A)\r
1729         HLRZ    0,C             ; GET AMNT RESTED\r
1730         SUB     B,0\r
1731         EXCH    C,D\r
1732         TRNE    B,-1\r
1733         AOS     (P)\r
1734         POPJ    P,\r
1735 \r
1736 TM3:\r
1737 TM2:    HRRZ    0,DSTO(PVP)\r
1738         PUSH    P,C\r
1739         PUSH    P,D\r
1740         PUSH    P,E\r
1741         MOVE    B,D\r
1742         MOVEI   C,0             ; GET "1ST ELEMENT"\r
1743         PUSHJ   P,TMPLNT        ; GET NTH IN A AND B\r
1744         POP     P,E\r
1745         POP     P,D\r
1746         POP     P,C\r
1747         POPJ    P,\r
1748 \r
1749 \r
1750 CHRDON: HRRZ    B,DSTO(PVP)     ; POIT TO DOPE WORD\r
1751         JUMPE   B,CHRFIN\r
1752         AOS     (P)\r
1753 CHRFIN: POPJ    P,\r
1754 \r
1755 LISTYP: GETYP   A,(D)\r
1756         MOVSI   A,(A)\r
1757         POPJ    P,\r
1758 1CHGT:  MOVE    B,D\r
1759         ILDB    B,B\r
1760         POPJ    P,\r
1761 \r
1762 1CHINC: SOS     DSTO(PVP)\r
1763         IBP     D\r
1764         POPJ    P,\r
1765 \r
1766 UTYPE:  HLRE    A,D\r
1767         SUBM    D,A\r
1768         GETYP   A,(A)\r
1769         MOVSI   A,(A)\r
1770         POPJ    P,\r
1771 \r
1772 \r
1773 ;COMPILER's CALL TO DOSEG\r
1774 SEGMNT: PUSHJ   P,TYPSEG\r
1775 SEGLP1: SETZB   A,B\r
1776 SEGLOP: PUSHJ   P,NXTELM\r
1777         JRST    SEGRET\r
1778         AOS     (P)-2           ; INCREMENT COMPILER'S COUNT\r
1779         JRST    SEGLOP\r
1780 \r
1781 SEGRET: SETZM   DSTO(PVP)\r
1782         POPJ    P,\r
1783 \r
1784 SEGLST: PUSHJ   P,TYPSEG\r
1785         JUMPN   C,SEGLS2\r
1786 SEGLS3: SETZM   DSTO(PVP)\r
1787         MOVSI   A,TLIST\r
1788 SEGLS1: SOSGE   -2(P)           ; START COUNT DOWN\r
1789         POPJ    P,\r
1790         MOVEI   E,(B)\r
1791         POP     TP,D\r
1792         POP     TP,C\r
1793         PUSHJ   P,ICONS\r
1794         JRST    SEGLS1\r
1795 \r
1796 SEGLS2: PUSHJ   P,NXTELM\r
1797         JRST    SEGLS4\r
1798         AOS     -2(P)\r
1799         JRST    SEGLS2\r
1800 \r
1801 SEGLS4: MOVEI   B,0\r
1802         JRST    SEGLS3\r
1803 \f\r
1804 \r
1805 ;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.\r
1806 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.  \r
1807 ;EACH TRIPLET IS AS FOLLOWS:\r
1808 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],\r
1809 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,\r
1810 ;AND THE THIRD IS A PAIR OF ZEROES.\r
1811 \r
1812 BNDA1:  TATOM,,-2\r
1813 BNDA:   TATOM,,-1\r
1814 BNDV:   TVEC,,-1\r
1815 \r
1816 USPECBIND:\r
1817         MOVE    E,TP\r
1818 USPCBE: PUSH    P,$TUBIND\r
1819         JRST    .+3\r
1820 \r
1821 SPECBIND:\r
1822         MOVE    E,TP            ;GET THE POINTER TO TOP\r
1823 SPECBE: PUSH    P,$TBIND\r
1824         ADD     E,[1,,1]        ;BUMP POINTER ONCE\r
1825         SETZB   0,D             ;CLEAR TEMPS\r
1826         PUSH    P,0\r
1827         MOVEI   0,(TB)          ; FOR CHECKS\r
1828 \r
1829 BINDLP: MOVE    A,-4(E)         ; CHECK FOR VEC BIND\r
1830         CAMN    A,BNDV\r
1831         JRST    NONID\r
1832         MOVE    A,-6(E)         ;GET TYPE\r
1833         CAME    A,BNDA1         ; FOR UNSPECIAL\r
1834         CAMN    A,BNDA          ;NORMAL ID BIND?\r
1835         CAILE   0,-6(E)         ; MAKE SURE NOT GOING UNDER FRAME\r
1836         JRST    SPECBD\r
1837         SUB     E,[6,,6]        ;MOVE PTR\r
1838         SKIPE   D               ;LINK?\r
1839         HRRM    E,(D)           ;YES --  LOBBER\r
1840         SKIPN   (P)             ;UPDATED?\r
1841         MOVEM   E,(P)           ;NO -- DO IT\r
1842 \r
1843         MOVE    A,0(E)          ;GET ATOM PTR\r
1844         MOVE    B,1(E)  \r
1845         PUSHJ   P,ILOC          ;GET LAST BINDING\r
1846         MOVS    A,OTBSAV (TB)   ;GET TIME\r
1847         HRL     A,5(E)          ; GET DECL POINTER\r
1848         MOVEM   A,4(E)          ;CLOBBER IT AWAY\r
1849         MOVE    A,(E)           ; SEE IF SPEC/UNSPEC\r
1850         TRNN    A,1             ; SKIP, ALWAYS SPEC\r
1851         SKIPA   A,-1(P)         ; USE SUPPLIED\r
1852         MOVSI   A,TBIND\r
1853         MOVEM   A,(E)           ;IDENTIFY AS BIND BLOCK\r
1854         HRRZ    C,SPBASE(PVP)   ; CHECK FOR CROSS OF PROC\r
1855         MOVEI   A,(TP)\r
1856         CAIL    A,(B)           ; LOSER\r
1857         CAILE   C,(B)           ; SKIP IFF WINNER\r
1858         JRST    .+2\r
1859         MOVEM   B,5(E)          ;IN RESTORE CELLS\r
1860 \r
1861         MOVE    C,1(E)          ;GET ATOM PTR\r
1862         MOVEI   A,(C)\r
1863         MOVEI   B,0             ; FOR SPCUNP\r
1864         CAIL    A,HIBOT         ; SKIP IF IMPURE ATOM\r
1865         PUSHJ   P,SPCUNP\r
1866         HRRZ    A,BINDID+1(PVP) ;GET PROCESS NUMBER\r
1867         HRLI    A,TLOCI         ;MAKE LOC PTR\r
1868         MOVE    B,E             ;TO NEW VALUE\r
1869         ADD     B,[2,,2]\r
1870         MOVEM   A,(C)           ;CLOBBER ITS VALUE\r
1871         MOVEM   B,1(C)          ;CELL\r
1872         MOVE    D,E             ;REMEMBER LINK\r
1873         JRST    BINDLP          ;DO NEXT\r
1874 \r
1875 NONID:  CAILE   0,-4(E)\r
1876         JRST    SPECBD\r
1877         SUB      E,[4,,4]\r
1878         SKIPE   D\r
1879         HRRM    E,(D)\r
1880         SKIPN   (P)\r
1881         MOVEM   E,(P)\r
1882 \r
1883         MOVE    D,1(E)          ;GET PTR TO VECTOR\r
1884         MOVE    C,(D)           ;EXCHANGE TYPES\r
1885         EXCH    C,2(E)\r
1886         MOVEM   C,(D)\r
1887 \r
1888         MOVE    C,1(D)          ;EXCHANGE DATUMS\r
1889         EXCH    C,3(E)\r
1890         MOVEM   C,1(D)\r
1891 \r
1892         MOVEI   A,TBVL  \r
1893         HRLM    A,(E)           ;IDENTIFY BIND BLOCK\r
1894         MOVE    D,E             ;REMEMBER LINK\r
1895         JRST    BINDLP\r
1896 \r
1897 SPECBD: SKIPE   D\r
1898         HRRM    SP,(D)\r
1899         SKIPE   D,(P)\r
1900         MOVE    SP,D\r
1901         SUB     P,[2,,2]\r
1902         POPJ    P,\r
1903 \r
1904 \r
1905 ; HERE TO IMPURIFY THE ATOM\r
1906 \r
1907 SPCUNP: PUSH    TP,$TSP\r
1908         PUSH    TP,E\r
1909         PUSH    TP,$TSP\r
1910         PUSH    TP,-1(P)        ; LINK BACK IS AN SP\r
1911         PUSH    TP,$TSP\r
1912         PUSH    TP,B\r
1913         MOVE    B,C\r
1914         PUSHJ   P,IMPURIFY\r
1915         MOVE    0,-2(TP)        ; RESTORE LINK BACK POINTER\r
1916         MOVEM   0,-1(P)\r
1917         MOVE    E,-4(TP)\r
1918         MOVE    C,B\r
1919         MOVE    B,(TP)\r
1920         SUB     TP,[6,,6]\r
1921         MOVEI   0,(TB)\r
1922         POPJ    P,\r
1923 \r
1924 ; ENTRY FROM COMPILER TO SET UP A BINDING\r
1925 \r
1926 IBIND:  SUBI    E,-5(SP)        ; CHANGE TO PDL POINTER\r
1927         HRLI    E,(E)\r
1928         ADD     E,SP\r
1929         MOVEM   C,-4(E)\r
1930         MOVEM   A,-3(E)\r
1931         MOVEM   B,-2(E)\r
1932         HRLOI   A,TATOM\r
1933         MOVEM   A,-5(E)\r
1934         MOVSI   A,TLIST\r
1935         MOVEM   A,-1(E)\r
1936         MOVEM   D,(E)\r
1937         JRST    SPECB1          ; NOW BIND IT\r
1938 \r
1939 ; "FAST CALL TO SPECBIND"\r
1940 \r
1941 \r
1942 \r
1943 ; Compiler's call to SPECBIND all atom bindings, no TBVLs etc.\r
1944 \r
1945 SPECBND:\r
1946         MOVE    E,TP            ; POINT TO BINDING WITH E\r
1947 SPECB1: PUSH    P,[0]           ; SLOTS OF INTEREST\r
1948         PUSH    P,[0]\r
1949         SUBM    M,-2(P)\r
1950 \r
1951 SPECB2: MOVEI   0,(TB)          ; FOR FRAME CHECK\r
1952         MOVE    A,-5(E)         ; LOOK AT FIRST THING\r
1953         CAMN    A,BNDA          ; SKIP IF LOSER\r
1954         CAILE   0,-5(E)         ; SKIP IF REAL WINNER\r
1955         JRST    SPECB3\r
1956 \r
1957         SUB     E,[5,,5]        ; POINT TO BINDING\r
1958         SKIPE   A,(P)           ; LINK?\r
1959         HRRM    E,(A)           ; YES DO IT\r
1960         SKIPN   -1(P)           ; FIRST ONE?\r
1961         MOVEM   E,-1(P)         ; THIS IS IT\r
1962 \r
1963         MOVE    A,1(E)          ; POINT TO ATOM\r
1964         MOVE    0,BINDID+1(PVP) ; QUICK CHECK\r
1965         HRLI    0,TLOCI\r
1966         CAMN    0,(A)           ; WINNERE?\r
1967         JRST    SPECB4          ; YES, GO ON\r
1968 \r
1969         PUSH    P,B             ; SAVE REST OF ACS\r
1970         PUSH    P,C\r
1971         PUSH    P,D\r
1972         MOVE    B,A             ; FOR ILOC TO WORK\r
1973         PUSHJ   P,ILOC          ; GO LOOK IT UP\r
1974         HRRZ    C,SPBASE+1(PVP)\r
1975         MOVEI   A,(TP)\r
1976         CAIL    A,(B)           ; SKIP IF LOSER\r
1977         CAILE   C,(B)           ; SKIP IF WINNER\r
1978         MOVEI   B,0             ; SAY NO BACK POINTER\r
1979         MOVE    C,1(E)          ; POINT TO ATOM\r
1980         MOVEI   A,(C)           ; PURE ATOM?\r
1981         CAIGE   A,HIBOT         ; SKIP IF OK\r
1982         JRST    .+4\r
1983         PUSH    P,-4(P)         ; MAKE HAPPINESS\r
1984         PUSHJ   P,SPCUNP        ; IMPURIFY\r
1985         POP     P,-5(P)\r
1986         MOVE    A,BINDID+1(PVP)\r
1987         HRLI    A,TLOCI\r
1988         MOVEM   A,(C)           ; STOR POINTER INDICATOR\r
1989         MOVE    A,B\r
1990         POP     P,D\r
1991         POP     P,C\r
1992         POP     P,B\r
1993         JRST    SPECB5\r
1994 \r
1995 SPECB4: MOVE    A,1(A)          ; GET LOCATIVE\r
1996 SPECB5: EXCH    A,5(E)          ; CLOBBER INTO REBIND SLOT (GET DECL)\r
1997         HLL     A,OTBSAV(TB)    ; TIME IT\r
1998         MOVSM   A,4(E)          ; SAVE DECL AND TIME\r
1999         MOVEI   A,TBIND\r
2000         HRLM    A,(E)           ; CHANGE TO A BINDING\r
2001         MOVE    A,1(E)          ; POINT TO ATOM\r
2002         MOVEM   E,(P)           ; REMEMBER THIS GUY\r
2003         ADD     E,[2,,2]        ; POINT TO VAL CELL\r
2004         MOVEM   E,1(A)          ; INTO ATOM SLOT\r
2005         SUB     E,[3,,3]        ; POINT TO NEXT ONE\r
2006         JRST    SPECB2\r
2007 \r
2008 SPECB3: SKIPE   A,(P)\r
2009         HRRM    SP,(A)          ; LINK OLD STUFF\r
2010         SKIPE   A,-1(P)         ; NEW SP?\r
2011         MOVE    SP,A\r
2012         SUB     P,[2,,2]\r
2013         INTGO                   ; IN CASE BLEW STACK\r
2014         SUBM    M,(P)\r
2015         POPJ    P,\r
2016 \f\r
2017 \r
2018 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN \r
2019 ;SPSAV (TB).  IT IS CALLED BY PUSHJ P,SPECSTORE.\r
2020 \r
2021 SPECSTORE:\r
2022         PUSH    P,E\r
2023         HRRZ    E,SPSAV (TB)    ;GET TARGET POINTER\r
2024         PUSHJ   P,STLOOP\r
2025         POP     P,E\r
2026         MOVE    SP,SPSAV(TB)    ; GET NEW SP\r
2027         POPJ    P,\r
2028 \r
2029 STLOOP: PUSH    P,D\r
2030         PUSH    P,C\r
2031 \r
2032 STLOO1: CAIL    E,(SP)          ;ARE WE DONE?\r
2033         JRST    STLOO2\r
2034         HLRZ    C,(SP)          ;GET TYPE OF BIND\r
2035         CAIN    C,TUBIND\r
2036         JRST    .+3\r
2037         CAIE    C,TBIND         ;NORMAL IDENTIFIER?\r
2038         JRST    ISTORE          ;NO -- SPECIAL HACK\r
2039 \r
2040 \r
2041         MOVE    C,1(SP)         ;GET TOP ATOM\r
2042         MOVSI   0,TLOCI         ; MAYBE LOCI OR UNBOUND\r
2043         SKIPN   D,5(SP)\r
2044         MOVSI   0,TUNBOU\r
2045 \r
2046         HRR     0,BINDID+1(PVP) ;STORE SIGNATURE\r
2047         MOVEM   0,(C)           ;CLOBBER INTO ATOM\r
2048         MOVEM   D,1(C)\r
2049         SETZM   4(SP)\r
2050 SPLP:   HRRZ    SP,(SP)         ;FOLOW LINK\r
2051         JUMPN   SP,STLOO1       ;IF MORE\r
2052         SKIPE   E               ; OK IF E=0\r
2053         FATAL SP OVERPOP\r
2054 STLOO2: POP     P,C\r
2055         POP     P,D\r
2056         POPJ    P,\r
2057 \r
2058 ISTORE: CAIE    C,TBVL\r
2059         JRST    CHSKIP\r
2060         MOVE    C,1(SP)\r
2061         MOVE    D,2(SP)\r
2062         MOVEM   D,(C)\r
2063         MOVE    D,3(SP)\r
2064         MOVEM   D,1(C)\r
2065         JRST    SPLP\r
2066 \r
2067 CHSKIP: CAIN    C,TSKIP\r
2068         JRST    SPLP\r
2069         CAIE    C,TUNWIN        ; UNWIND HACK\r
2070         FATAL BAD SP\r
2071         HRRZ    C,-2(P)         ; WHERE FROM?\r
2072         CAIE    C,CHUNPC\r
2073         JRST    SPLP            ; IGNORE\r
2074         MOVEI   E,(TP)          ; FIXUP SP\r
2075         SUBI    E,(SP)\r
2076         MOVSI   E,(E)\r
2077         HLL     SP,TP\r
2078         SUB     SP,E\r
2079         POP     P,C\r
2080         POP     P,D\r
2081         AOS     (P)\r
2082         POPJ    P,\r
2083 \r
2084 ; ENTRY FOR FUNNY COMPILER UNBIND (1)\r
2085 \r
2086 SSPECS: PUSH    P,E\r
2087         MOVEI   E,(TP)\r
2088         PUSHJ   P,STLOOP\r
2089 SSPEC2: SUBI    E,(SP)          ; MAKE SP BE AOBJN\r
2090         MOVSI   E,(E)\r
2091         HLL     SP,TP\r
2092         SUB     SP,E\r
2093         POP     P,E\r
2094         POPJ    P,\r
2095 \r
2096 ; ENTRY FOR FUNNY COMPILER UNBIND (2)\r
2097 \r
2098 SSPEC1: PUSH    P,E\r
2099         SUBI    E,1             ; MAKE SURE GET CURRENT BINDING\r
2100         PUSHJ   P,STLOOP        ; UNBIND\r
2101         MOVEI   E,(TP)          ; NOW RESET SP\r
2102         JRST    SSPEC2\r
2103 \fEFINIS:        SKIPN   C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED\r
2104         JRST    FINIS\r
2105         PUSH    TP,$TATOM\r
2106         PUSH    TP,MQUOTE EVLOUT\r
2107         PUSH    TP,A                    ;SAVE EVAL RESULTS\r
2108         PUSH    TP,B\r
2109         PUSH    TP,[TINFO,,2]   ; FENCE POST\r
2110         PUSHJ   P,TBTOTP\r
2111         PUSH    TP,D\r
2112         PUSHJ   P,MAKINF        ; MAKE ARG BLOCK INFO\r
2113         PUSH    TP,A\r
2114         MOVEI   B,-6(TP)\r
2115         HRLI    B,-4            ; AOBJN TO ARGS BLOCK\r
2116         PUSH    TP,B\r
2117         PUSH    TP,1STEPR(PVP)\r
2118         PUSH    TP,1STEPR+1(PVP)        ; PROCESS DOING THE 1STEPPING\r
2119         MCALL   2,RESUME\r
2120         MOVE    A,-3(TP)        ; GET BACK EVAL VALUE\r
2121         MOVE    B,-2(TP)\r
2122         JRST    FINIS\r
2123 \r
2124 1STEPI: PUSH    TP,$TATOM\r
2125         PUSH    TP,MQUOTE EVLIN\r
2126         PUSH    TP,$TAB         ; PUSH EVALS ARGGS\r
2127         PUSH    TP,AB\r
2128         PUSHJ   P,MAKINF        ; TURN INTO ARGS BLOCK\r
2129         MOVEM   A,-1(TP)        ; AND CLOBBER\r
2130         PUSH    TP,[TINFO,,2]   ; FENCE POST 2D TUPLE\r
2131         PUSHJ   P,TBTOTP\r
2132         PUSH    TP,D\r
2133         PUSHJ   P,MAKINF        ; TURN IT INTO ARGS BLOCK\r
2134         PUSH    TP,A\r
2135         MOVEI   B,-6(TP)        ; SETUP TUPLE\r
2136         HRLI    B,-4\r
2137         PUSH    TP,B\r
2138         PUSH    TP,1STEPR(PVP)\r
2139         PUSH    TP,1STEPR+1(PVP)\r
2140         MCALL   2,RESUME        ; START UP 1STEPERR\r
2141         SUB     TP,[6,,6]       ; REMOVE CRUD\r
2142         GETYP   A,A             ; GET 1STEPPERS TYPE\r
2143         CAIE    A,TDISMI                ; IF DISMISS, STOP 1 STEPPING\r
2144         JRST    EVALON\r
2145 \r
2146 ; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN\r
2147 \r
2148         MOVE    D,PVP\r
2149         ADD     D,[1STEPR,,1STEPR]      ; POINT TO 1 STEP SLOT\r
2150         PUSH    TP,$TSP         ; SAVE CURRENT SP\r
2151         PUSH    TP,SP\r
2152         PUSH    TP,BNDV\r
2153         PUSH    TP,D            ; BIND IT\r
2154         PUSH    TP,$TPVP\r
2155         PUSH    TP,[0]          ; NO 1 STEPPER UNTIL POPJ\r
2156         PUSHJ   P,SPECBIND\r
2157 \r
2158 ; NOW PUSH THE ARGS UP TO RE-CALL EVAL\r
2159 \r
2160         MOVEI   A,0\r
2161 EFARGL: JUMPGE  AB,EFCALL\r
2162         PUSH    TP,(AB)\r
2163         PUSH    TP,1(AB)\r
2164         ADD     AB,[2,,2]\r
2165         AOJA    A,EFARGL\r
2166 \r
2167 EFCALL: ACALL   A,EVAL          ; NOW DO THE EVAL\r
2168         MOVE    C,(TP)          ; PRE-UNBIND\r
2169         MOVEM   C,1STEPR+1(PVP)\r
2170         MOVE    SP,-4(TP)       ; AVOID THE UNBIND\r
2171         SUB     TP,[6,,6]       ; AND FLUSH LOSERS\r
2172         JRST    EFINIS          ; AND TRY TO FINISH UP\r
2173 \r
2174 MAKINF: HLRZ    A,OTBSAV(TB)    ; TIME IT\r
2175         HRLI    A,TARGS\r
2176         POPJ    P,\r
2177 \r
2178 \r
2179 TBTOTP: MOVEI   D,(TB)          ; COMPUTE REL DIST FROM TP TO TB\r
2180         SUBI    D,(TP)\r
2181         POPJ    P,\r
2182 ; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE\r
2183 ; D/ LENGTH OF THE TUPLE IN WORDS\r
2184 \r
2185 MAKTU2: MOVE    D,-1(P)         ; GET LENGTH\r
2186 MAKTUP: HRLI    D,TINFO         ; FIRST WORD OF FENCE POST\r
2187         PUSH    TP,D\r
2188         HRROI   B,(TP)          ; TOP OF TUPLE\r
2189         SUBI    B,(D)\r
2190         TLC     B,-1(D)         ; AOBJN IT\r
2191         PUSHJ   P,TBTOTP\r
2192         PUSH    TP,D\r
2193         HLRZ    A,OTBSAV(TB)    ; TIME IT\r
2194         HRLI    A,TARGS\r
2195         POPJ    P,\r
2196 \r
2197 ; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)\r
2198 \r
2199 TPALOC: HRLI    A,(A)\r
2200         ADD     TP,A\r
2201         SKIPL   TP\r
2202         PUSHJ   P,TPOVFL        ; IN CASE IT LOST\r
2203         INTGO                   ; TAKE THE GC IF NEC\r
2204         PUSH    P,A\r
2205         HRRI    A,2(TP)\r
2206         SUB     A,(P)\r
2207         SETZM   -1(A)   \r
2208         HRLI    A,-1(A)\r
2209         BLT     A,(TP)\r
2210         SUB     P,[1,,1]\r
2211         POPJ    P,\r
2212 \r
2213 NTPALO: PUSH    TP,[0]\r
2214         SOJG    0,.-1\r
2215         POPJ    P,\r
2216 \r
2217 \f;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.\r
2218 \r
2219 MFUNCTION VALUE,SUBR\r
2220         JSP     E,CHKAT\r
2221         PUSHJ   P,IDVAL\r
2222         JRST    FINIS\r
2223 \r
2224 IDVAL:  PUSHJ   P,IDVAL1\r
2225         CAMN    A,$TUNBOU\r
2226         JRST    UNBOU\r
2227         POPJ    P,\r
2228 \r
2229 IDVAL1: PUSH    TP,A\r
2230         PUSH    TP,B            ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE\r
2231         PUSHJ   P,ILVAL         ;LOCAL VALUE FINDER\r
2232         CAME    A,$TUNBOUND     ;IF NOT UNBOUND OR UNASSIGNED\r
2233         JRST    RIDVAL          ;DONE - CLEAN UP AND RETURN\r
2234         POP     TP,B            ;GET ARG BACK\r
2235         POP     TP,A\r
2236         JRST    IGVAL\r
2237 RIDVAL: SUB     TP,[2,,2]\r
2238         POPJ    P,\r
2239 \r
2240 ;GETS THE LOCAL VALUE OF AN IDENTIFIER\r
2241 \r
2242 MFUNCTION LVAL,SUBR\r
2243         JSP     E,CHKAT\r
2244         PUSHJ   P,AILVAL\r
2245         CAME    A,$TUNBOUND\r
2246         JRST    FINIS\r
2247         JUMPN   B,UNAS\r
2248         JRST    UNBOU\r
2249 \r
2250 ; MAKE AN ATOM UNASSIGNED\r
2251 \r
2252 MFUNCTION UNASSIGN,SUBR\r
2253         JSP     E,CHKAT         ; GET ATOM ARG\r
2254         PUSHJ   P,AILOC\r
2255 UNASIT: CAMN    A,$TUNBOU       ; IF UNBOUND\r
2256         JRST    RETATM\r
2257         MOVSI   A,TUNBOU\r
2258         MOVEM   A,(B)\r
2259         SETOM   1(B)            ; MAKE SURE\r
2260 RETATM: MOVE    B,1(AB)\r
2261         MOVE    A,(AB)\r
2262         JRST    FINIS\r
2263 \r
2264 ; UNASSIGN GLOBALLY\r
2265 \r
2266 MFUNCTION GUNASSIGN,SUBR\r
2267         JSP     E,CHKAT2\r
2268         PUSHJ   P,IGLOC\r
2269         CAMN    A,$TUNBOU\r
2270         JRST    RETATM\r
2271         MOVE    B,1(AB)         ; ATOM BACK\r
2272         MOVEI   0,(B)\r
2273         CAIL    0,HIBOT         ; SKIP IF IMPURE\r
2274         PUSHJ   P,IMPURIFY      ; YES, MAKE IT IMPURE\r
2275         PUSHJ   P,IGLOC         ; RESTORE LOCATIVE\r
2276         HRRZ    0,-2(B)         ; SEE IF MANIFEST\r
2277         GETYP   A,(B)           ; AND CURRENT TYPE\r
2278         CAIN    0,-1\r
2279         CAIN    A,TUNBOU\r
2280         JRST    UNASIT\r
2281         SKIPE   IGDECL\r
2282         JRST    UNASIT\r
2283         MOVE    D,B\r
2284         JRST    MANILO\r
2285 \f\r
2286 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.\r
2287 \r
2288 MFUNCTION LLOC,SUBR\r
2289         JSP     E,CHKAT\r
2290         PUSHJ   P,AILOC\r
2291         CAMN    A,$TUNBOUND\r
2292         JRST    UNBOU\r
2293         MOVSI   A,TLOCD\r
2294         HRR     A,2(B)\r
2295         JRST    FINIS\r
2296 \r
2297 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND\r
2298 \r
2299 MFUNCTION BOUND,SUBR,[BOUND?]\r
2300         JSP     E,CHKAT\r
2301         PUSHJ   P,AILVAL\r
2302         CAMN    A,$TUNBOUND\r
2303         JUMPE   B,IFALSE\r
2304         JRST    TRUTH\r
2305 \r
2306 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED\r
2307 \r
2308 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]\r
2309         JSP     E,CHKAT\r
2310         PUSHJ   P,AILVAL\r
2311         CAME    A,$TUNBOUND\r
2312         JRST    TRUTH\r
2313 ;       JUMPE   B,UNBOU\r
2314         JRST    IFALSE\r
2315 \r
2316 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER\r
2317 \r
2318 MFUNCTION GVAL,SUBR\r
2319         JSP     E,CHKAT2\r
2320         PUSHJ   P,IGVAL\r
2321         CAMN    A,$TUNBOUND\r
2322         JRST    UNAS\r
2323         JRST    FINIS\r
2324 \r
2325 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER\r
2326 \r
2327 MFUNCTION GLOC,SUBR\r
2328 \r
2329         JUMPGE  AB,TFA\r
2330         CAMGE   AB,[-5,,]\r
2331         JRST    TMA\r
2332         JSP     E,CHKAT1\r
2333         MOVEI   E,IGLOC\r
2334         CAML    AB,[-2,,]\r
2335         JRST    .+4\r
2336         GETYP   0,2(AB)\r
2337         CAIE    0,TFALSE\r
2338         MOVEI   E,IIGLOC\r
2339         PUSHJ   P,(E)\r
2340         CAMN    A,$TUNBOUND\r
2341         JRST    UNAS\r
2342         MOVSI   A,TLOCD\r
2343         MOVE    C,1(AB)         ; GE ATOM\r
2344         MOVEI   0,(C)\r
2345         CAIGE   0,HIBOT         ; SKIP IF PURE ATOM\r
2346         JRST    FINIS\r
2347 \r
2348 ; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT\r
2349 \r
2350         MOVE    B,C             ; ATOM TO B\r
2351         PUSHJ   P,IMPURIFY\r
2352         JRST    GLOC            ; AND TRY AGAIN\r
2353 \r
2354 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED\r
2355 \r
2356 MFUNCTION GASSIG,SUBR,[GASSIGNED?]\r
2357         JSP     E,CHKAT2\r
2358         PUSHJ   P,IGVAL\r
2359         CAMN    A,$TUNBOUND\r
2360         JRST    IFALSE\r
2361         JRST    TRUTH\r
2362 \r
2363 ; TEST FOR GLOBALLY BOUND\r
2364 \r
2365 MFUNCTION GBOUND,SUBR,[GBOUND?]\r
2366 \r
2367         JSP     E,CHKAT2\r
2368         PUSHJ   P,IGLOC\r
2369         JUMPE   B,IFALSE\r
2370         JRST    TRUTH\r
2371 \r
2372 \f\r
2373 \r
2374 CHKAT2: ENTRY   1\r
2375 CHKAT1: GETYP   A,(AB)\r
2376         MOVSI   A,(A)\r
2377         CAME    A,$TATOM\r
2378         JRST    NONATM\r
2379         MOVE    B,1(AB)\r
2380         JRST    2,(E)\r
2381 \r
2382 CHKAT:  HLRE    A,AB            ; - # OF ARGS\r
2383         ASH     A,-1            ; TO ACTUAL WORDS\r
2384         JUMPGE  AB,TFA\r
2385         MOVE    C,SP            ; FOR BINDING LOOKUPS\r
2386         AOJE    A,CHKAT1        ; ONLY ONE ARG, NO ENVIRONMENT\r
2387         AOJL    A,TMA           ; TOO MANY\r
2388         GETYP   A,2(AB)         ; MAKE SURE OF TENV OR TFRAME\r
2389         CAIE    A,TFRAME\r
2390         CAIN    A,TENV\r
2391         JRST    CHKAT3\r
2392         CAIN    A,TACT          ; FOR PFISTERS LOSSAGE\r
2393         JRST    CHKAT3\r
2394         CAIE    A,TPVP          ; OR PROCESS\r
2395         JRST    WTYP2\r
2396         MOVE    B,3(AB)         ; GET PROCESS\r
2397         MOVE    C,SP            ; IN CASE ITS ME\r
2398         CAME    B,PVP           ; SKIP IF DIFFERENT\r
2399         MOVE    C,SPSTO+1(B)    ; GET ITS SP\r
2400         JRST    CHKAT1\r
2401 CHKAT3: MOVEI   B,2(AB)         ; POINT TO FRAME POINTER\r
2402         PUSHJ   P,CHFRM         ; VALIDITY CHECK\r
2403         MOVE    B,3(AB)         ; GET TB FROM FRAME\r
2404         MOVE    C,SPSAV(B)      ; GET ENVIRONMENT POINTER\r
2405         JRST    CHKAT1\r
2406 \r
2407 \f\r
2408 \r
2409 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT\r
2410 ;IN A AND B.  IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,\r
2411 ; IT IS CALLED BY PUSHJ P,ILOC.\r
2412 \r
2413 ILOC:   MOVE    C,SP            ; SETUP SEARCH START\r
2414 AILOC:  MOVSI   A,TLOCI         ;MAKE A LOCATIVE TYPE CELL\r
2415         PUSH    P,E\r
2416         PUSH    P,D\r
2417         MOVEI   E,0             ; FLAG TO CLOBBER ATOM\r
2418         JUMPE   B,SCHSP         ; IF LOOKING FOR SLOT, SEARCH NOW\r
2419         CAME    C,SP            ; ENVIRONMENT CHANGE?\r
2420         JRST    SCHSP           ; YES, MUST SEARCH\r
2421         HRR     A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS\r
2422         CAME    A,(B)           ;IS THERE ONE IN THE VALUE CELL?\r
2423         JRST    SCHLP           ;NO -- SEARCH THE LOCAL BINDINGS\r
2424         MOVE    B,1(B)          ;YES -- GET LOCATIVE POINTER\r
2425         MOVE    C,PVP\r
2426 ILCPJ:  MOVE    E,SPCCHK\r
2427         TRNN    E,1             ; SKIP IF DOING SPEC UNSPEC CHECK\r
2428         JRST    ILOCPJ\r
2429         HLRZ    E,-2(B)\r
2430         CAIE    E,TUBIND\r
2431         JRST    ILOCPJ\r
2432         CAMGE   B,CURFCN+1(PVP)\r
2433         JRST    UNPJ11\r
2434         MOVEI   D,-2(B)\r
2435         CAIG    D,(SP)\r
2436         CAMGE   B,SPBASE+1(PVP)\r
2437         JRST    UNPJ11\r
2438 ILOCPJ: POP     P,D\r
2439         POP     P,E\r
2440         POPJ    P,              ;FROM THE VALUE CELL\r
2441 \r
2442 SCHLP:  MOVEI   D,(B)\r
2443         CAIL    D,HIBOT         ; SKIP IF IMPURE ATOM\r
2444 SCHSP:  MOVEI   E,1             ; DONT STORE LOCATIVE\r
2445 \r
2446         PUSH    P,E             ; PUSH SWITCH\r
2447         MOVE    E,PVP           ; GET PROC\r
2448 SCHLP1: JUMPE   C,UNPJ          ;IF NO MORE -- LOSE\r
2449         CAMN    B,1(C)          ;ARE WE POINTING AT THE WINNER?\r
2450         JRST    SCHFND          ;YES\r
2451         GETYP   D,(C)           ; CHECK SKIP\r
2452         CAIE    D,TSKIP\r
2453         JRST    SCHLP2\r
2454         PUSH    P,B             ; CHECK DETOUR\r
2455         MOVEI   B,2(C)\r
2456         PUSHJ   P,CHFRAM        ; NON-FATAL FRAME CHECKER\r
2457         HRRZ    E,2(C)          ; CONS UP PROCESS\r
2458         SUBI    E,PVLNT*2+1\r
2459         HRLI    E,-2*PVLNT\r
2460         JUMPE   B,SCHLP3        ; LOSER, FIX IT\r
2461         POP     P,B\r
2462         MOVEI   C,1(C)          ; FOLLOW LOOKUP CHAIN\r
2463 SCHLP2: HRRZ    C,(C)           ;FOLLOW LINK\r
2464         JRST    SCHLP1\r
2465 \r
2466 SCHLP3: POP     P,B\r
2467         MOVEI   C,(SP)          ; *** NDR'S BUG ***\r
2468         CAME    E,PVP           ; USE IF CURRENT PROCESS\r
2469         HRRZ    C,SPSTO+1(E)    ; USE CURRENT SP FOR PROC\r
2470         JRST    SCHLP1\r
2471         \r
2472 SCHFND: EXCH    B,C             ;SAVE THE ATOM PTR IN C\r
2473         MOVEI   B,2(B)          ;MAKE UP THE LOCATIVE\r
2474         SUB     B,TPBASE+1(E)\r
2475         HRLI    B,(B)\r
2476         ADD     B,TPBASE+1(E)\r
2477         EXCH    C,E             ; RET PROCESS IN C\r
2478         POP     P,D             ; RESTORE SWITCH\r
2479 \r
2480         JUMPN   D,ILOCPJ                ; DONT CLOBBER  ATOM\r
2481         MOVEM   A,(E)           ;CLOBBER IT AWAY INTO THE\r
2482         MOVEM   B,1(E)          ;ATOM'S VALUE CELL\r
2483         JRST    ILCPJ\r
2484 \r
2485 UNPJ:   SUB     P,[1,,1]        ; FLUSH CRUFT\r
2486 UNPJ1:  MOVE    C,E             ; RET PROCESS ANYWAY\r
2487 UNPJ11: POP     P,D\r
2488         POP     P,E\r
2489 UNPOPJ: MOVSI   A,TUNBOUND\r
2490         MOVEI   B,0\r
2491         POPJ    P,\r
2492 \r
2493 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE \r
2494 ;IDENTIFIER PASSED TO IT IN A AND B.  IF THE IDENTIFIER IS GLOBALLY\r
2495 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.\r
2496 \r
2497 \r
2498 IGLOC:  MOVSI   A,TLOCI         ;DO WE HAVE A LOCATIVE TO\r
2499         CAME    A,(B)           ;A PROCESS #0 VALUE?\r
2500         JRST    SCHGSP          ;NO -- SEARCH\r
2501         MOVE    B,1(B)          ;YES -- GET VALUE CELL\r
2502         POPJ    P,\r
2503 \r
2504 SCHGSP: MOVE    D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR\r
2505 \r
2506 SCHG1:  JUMPGE  D,UNPOPJ        ;IF NO MORE, LEAVE\r
2507         CAMN    B,1(D)          ;ARE WE FOUND?\r
2508         JRST    GLOCFOUND       ;YES\r
2509         ADD     D,[4,,4]        ;NO -- TRY NEXT\r
2510         JRST    SCHG1\r
2511 \r
2512 GLOCFOUND:\r
2513         EXCH    B,D             ;SAVE ATOM PTR\r
2514         ADD     B,[2,,2]        ;MAKE LOCATIVE\r
2515         MOVEI   0,(D)\r
2516         CAIL    0,HIBOT\r
2517         POPJ    P,\r
2518         MOVEM   A,(D)           ;CLOBBER IT AWAY\r
2519         MOVEM   B,1(D)\r
2520         POPJ    P,\r
2521 \r
2522 IIGLOC: PUSH    TP,$TATOM\r
2523         PUSH    TP,B\r
2524         PUSHJ   P,IGLOC\r
2525         MOVE    C,(TP)\r
2526         SUB     TP,[2,,2]\r
2527         GETYP   0,A\r
2528         CAIE    0,TUNBOU\r
2529         POPJ    P,\r
2530         PUSH    TP,$TATOM\r
2531         PUSH    TP,C\r
2532         PUSHJ   P,BSETG         ; MAKE A SLOT\r
2533         SETOM   1(B)            ; UNBOUNDIFY IT\r
2534         MOVSI   A,TLOCD\r
2535         MOVSI   0,TUNBOU\r
2536         MOVEM   0,(B)\r
2537         SUB     TP,[2,,2]\r
2538         POPJ    P,\r
2539         \r
2540 \f\r
2541 \r
2542 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B\r
2543 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF\r
2544 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B.  CALL - PUSHJ P,IVAL\r
2545 \r
2546 AILVAL:\r
2547         PUSHJ   P,AILOC ; USE SUPPLIED SP\r
2548         JRST    CHVAL\r
2549 ILVAL:\r
2550         PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE\r
2551 CHVAL:  CAMN    A,$TUNBOUND     ;BOUND\r
2552         POPJ    P,              ;NO -- RETURN\r
2553         MOVSI   A,TLOCD         ; GET GOOD TYPE\r
2554         HRR     A,2(B)          ; SHOULD BE TIME OR 0\r
2555         PUSH    P,0\r
2556         PUSHJ   P,RMONC0        ; CHECK READ MONITOR\r
2557         POP     P,0\r
2558         MOVE    A,(B)           ;GET THE TYPE OF THE VALUE\r
2559         MOVE    B,1(B)          ;GET DATUM\r
2560         POPJ    P,\r
2561 \r
2562 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES\r
2563 \r
2564 IGVAL:  PUSHJ   P,IGLOC\r
2565         JRST    CHVAL\r
2566 \r
2567 \r
2568 \f\r
2569 ; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET\r
2570 \r
2571 CILVAL: MOVE    0,BINDID+1(PVP) ; CURRENT BIND\r
2572         HRLI    0,TLOCI\r
2573         CAME    0,(B)           ; HURRAY FOR SPEED\r
2574         JRST    CILVA1          ; TOO BAD\r
2575         MOVE    C,1(B)          ; POINTER\r
2576         MOVE    A,(C)           ; VAL TYPE\r
2577         TLNE    A,.RDMON        ; MONITORS?\r
2578         JRST    CILVA1\r
2579         GETYP   0,A\r
2580         CAIN    0,TUNBOU\r
2581         JRST    CUNAS           ; COMPILER ERROR\r
2582         MOVE    B,1(C)          ; GOT VAL\r
2583         MOVE    0,SPCCHK\r
2584         TRNN    0,1\r
2585         POPJ    P,\r
2586         HLRZ    0,-2(C)         ; SPECIAL CHECK\r
2587         CAIE    0,TUBIND\r
2588         POPJ    P,              ; RETURN\r
2589         CAMGE   C,CURFCN+1(PVP)\r
2590         JRST    CUNAS\r
2591         POPJ    P,\r
2592 \r
2593 CUNAS:\r
2594 CILVA1: SUBM    M,(P)           ; FIX (P)\r
2595         PUSH    TP,$TATOM       ; SAVE ATOM\r
2596         PUSH    TP,B\r
2597         MCALL   1,LVAL          ; GET ERROR/MONITOR\r
2598 MPOPJ:\r
2599 POPJM:  SUBM    M,(P)           ; REPAIR DAMAGE\r
2600         POPJ    P,\r
2601 \r
2602 ; COMPILERS INTERFACE TO SET C/ ATOM  A,B/ NEW VALUE\r
2603 \r
2604 CISET:  MOVE    0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT\r
2605         HRLI    0,TLOCI\r
2606         CAME    0,(C)           ; CAN WE WIN?\r
2607         JRST    CISET1          ; NO, MORE HAIR\r
2608         MOVE    D,1(C)          ; POINT TO SLOT\r
2609         HLLZ    0,(D)           ; MON CHECK\r
2610 CISET3: TLNE    0,.WRMON\r
2611         JRST    CISET4          ; YES, LOSE\r
2612         TLZ     0,TYPMSK\r
2613         IOR     A,0             ; LEAVE MONITOR ON\r
2614         MOVE    0,SPCCHK\r
2615         TRNE    0,1\r
2616         JRST    CISET5          ; SPEC/UNSPEC CHECK\r
2617 CISET6: MOVEM   A,(D)           ; STORE\r
2618         MOVEM   B,1(D)\r
2619         POPJ    P,\r
2620 \r
2621 CISET5: HLRZ    0,-2(D)\r
2622         CAIE    0,TUBIND\r
2623         JRST    CISET6\r
2624         CAMGE   D,CURFCN+1(PVP)\r
2625         JRST    CISET4\r
2626         JRST    CISET6\r
2627         \r
2628 CISET1: SUBM    M,(P)           ; FIX ADDR\r
2629         PUSH    TP,$TATOM       ; SAVE ATOM\r
2630         PUSH    TP,C\r
2631         PUSH    TP,A\r
2632         PUSH    TP,B\r
2633         MOVE    B,C             ; GET ATOM\r
2634         PUSHJ   P,ILOC          ; SEARCH\r
2635         MOVE    D,B             ; POSSIBLE POINTER\r
2636         GETYP   E,A\r
2637         MOVE    0,A\r
2638         MOVE    A,-1(TP)        ; VAL BACK\r
2639         MOVE    B,(TP)\r
2640         CAIE    E,TUNBOU        ; SKIP IF WIN\r
2641         JRST    CISET2          ; GO CLOBBER IT IN\r
2642         MCALL   2,SET\r
2643         JRST    POPJM\r
2644         \r
2645 CISET2: MOVE    C,-2(TP)        ; ATOM BACK\r
2646         SUBM    M,(P)           ; RESET (P)\r
2647         SUB     TP,[4,,4]\r
2648         JRST    CISET3\r
2649 \r
2650 ; HERE TO DO A MONITORED SET\r
2651 \r
2652 CISET4: SUBM    M,(P)           ; AGAIN FIX (P)\r
2653         PUSH    TP,$TATOM\r
2654         PUSH    TP,C\r
2655         PUSH    TP,A\r
2656         PUSH    TP,B\r
2657         MCALL   2,SET\r
2658         JRST    POPJM\r
2659 \r
2660 ; COMPILER LLOC\r
2661 \r
2662 CLLOC:  MOVE    0,BINDID+1(PVP) ; GET CURRENT LOCATIVE\r
2663         HRLI    0,TLOCI\r
2664         CAME    0,(B)           ; WIN?\r
2665         JRST    CLLOC1\r
2666         MOVE    B,1(B)\r
2667         MOVE    0,SPCCHK\r
2668         TRNE    0,1             ; SKIP IF NOT CHECKING\r
2669         JRST    CLLOC9\r
2670 CLLOC3: MOVSI   A,TLOCD\r
2671         HRR     A,2(B)          ; GET BIND TIME\r
2672         POPJ    P,\r
2673 \r
2674 CLLOC1: SUBM    M,(P)\r
2675         PUSH    TP,$TATOM\r
2676         PUSH    TP,B\r
2677         PUSHJ   P,ILOC          ; LOOK IT UP\r
2678         JUMPE   B,CLLOC2\r
2679         SUB     TP,[2,,2]\r
2680 CLLOC4: SUBM    M,(P)\r
2681         JRST    CLLOC3\r
2682 \r
2683 CLLOC2: MCALL   1,LLOC\r
2684         JRST    CLLOC4\r
2685 \r
2686 CLLOC9: HLRZ    0,-2(B)\r
2687         CAIE    0,TUBIND\r
2688         JRST    CLLOC3\r
2689         CAMGE   B,CURFCN+1(PVP)\r
2690         JRST    CLLOC2\r
2691         JRST    CLLOC3\r
2692 \r
2693 ; COMPILER BOUND?\r
2694 \r
2695 CBOUND: SUBM    M,(P)\r
2696         PUSHJ   P,ILOC\r
2697         JUMPE   B,PJFALS        ; IF UNBOUND RET FALSE AND NO SSKIP\r
2698 PJT1:   SOS     (P)\r
2699         MOVSI   A,TATOM\r
2700         MOVE    B,MQUOTE T\r
2701         JRST    POPJM\r
2702 \r
2703 PJFALS: MOVEI   B,0\r
2704         MOVSI   A,TFALSE\r
2705         JRST    POPJM\r
2706 \r
2707 ; COMPILER ASSIGNED?\r
2708 \r
2709 CASSQ:  SUBM    M,(P)\r
2710         PUSHJ   P,ILOC\r
2711         JUMPE   B,PJFALS\r
2712         GETYP   0,(B)\r
2713         CAIE    0,TUNBOU\r
2714         JRST    PJT1\r
2715         JRST    PJFALS\r
2716 \f\r
2717 \r
2718 ; COMPILER GVAL B/ ATOM\r
2719 \r
2720 CIGVAL: MOVE    0,(B)           ; GLOBAL VAL HERE?\r
2721         CAME    0,$TLOCI        ; TIME=0 ,TYPE=TLOCI => GLOB VAL\r
2722         JRST    CIGVA1          ; NO, GO LOOK\r
2723         MOVE    C,1(B)          ; POINT TO SLOT\r
2724         MOVE    A,(C)           ; GET TYPE\r
2725         TLNE    A,.RDMON\r
2726         JRST    CIGVA1\r
2727         GETYP   0,A             ; CHECK FOR UNBOUND\r
2728         CAIN    0,TUNBOU        ; SKIP IF WINNER\r
2729         JRST    CGUNAS\r
2730         MOVE    B,1(C)\r
2731         POPJ    P,\r
2732 \r
2733 CGUNAS:\r
2734 CIGVA1: SUBM    M,(P)\r
2735         PUSH    TP,$TATOM\r
2736         PUSH    TP,B\r
2737         .MCALL  1,GVAL          ; GET ERROR/MONITOR\r
2738         JRST    POPJM\r
2739 \r
2740 ; COMPILER INTERFACET TO SETG\r
2741 \r
2742 CSETG:  MOVE    0,(C)           ; GET V CELL\r
2743         CAME    0,$TLOCI        ; SKIP IF FAST\r
2744         JRST    CSETG1\r
2745         HRRZ    D,1(C)          ; POINT TO SLOT\r
2746         MOVE    0,(D)           ; OLD VAL\r
2747 CSETG3: CAIG    D,HIBOT         ; SKIP IF PURE ATOM\r
2748         TLNE    0,.WRMON        ; MONITOR\r
2749         JRST    CSETG2\r
2750         MOVEM   A,(D)\r
2751         MOVEM   B,1(D)\r
2752         POPJ    P,\r
2753 \r
2754 CSETG1: SUBM    M,(P)           ; FIX UP P\r
2755         PUSH    TP,$TATOM\r
2756         PUSH    TP,C\r
2757         PUSH    TP,A\r
2758         PUSH    TP,B\r
2759         MOVE    B,C\r
2760         PUSHJ   P,IGLOC         ; FIND GLOB LOCATIVE\r
2761         GETYP   E,A\r
2762         MOVE    0,A\r
2763         MOVEI   D,(B)           ; SETUP TO RESTORE NEW VAL\r
2764         MOVE    A,-1(TP)\r
2765         MOVE    B,(TP)\r
2766         CAIE    E,TUNBOU\r
2767         JRST    CSETG4\r
2768         MCALL   2,SETG\r
2769         JRST    POPJM\r
2770 \r
2771 CSETG4: MOVE    C,-2(TP)        ; ATOM BACK\r
2772         SUBM    M,(P)           ; RESET (P)\r
2773         SUB     TP,[4,,4]\r
2774         JRST    CSETG3\r
2775 \r
2776 CSETG2: SUBM    M,(P)\r
2777         PUSH    TP,$TATOM               ; CAUSE A SETG MONITOR\r
2778         PUSH    TP,C\r
2779         PUSH    TP,A\r
2780         PUSH    TP,B\r
2781         MCALL   2,SETG\r
2782         JRST    POPJM\r
2783 \r
2784 ; COMPILER GLOC\r
2785 \r
2786 CGLOC:  MOVE    0,(B)           ; GET CURRENT GUY\r
2787         CAME    0,$TLOCI        ; WIN?\r
2788         JRST    CGLOC1          ; NOPE\r
2789         HRRZ    D,1(B)          ; POINT TO SLOT\r
2790         CAILE   D,HIBOT         ; PURE?\r
2791         JRST    CGLOC1\r
2792         MOVE    A,$TLOCD\r
2793         MOVE    B,1(B)\r
2794         POPJ    P,\r
2795 \r
2796 CGLOC1: SUBM    M,(P)\r
2797         PUSH    TP,$TATOM\r
2798         PUSH    TP,B\r
2799         MCALL   1,GLOC\r
2800         JRST    POPJM\r
2801 \r
2802 ; COMPILERS GASSIGNED?\r
2803 \r
2804 CGASSQ: MOVE    0,(B)\r
2805         SUBM    M,(P)\r
2806         CAMN    0,$TLOCD\r
2807         JRST    PJT1\r
2808         PUSHJ   P,IGLOC\r
2809         JUMPE   B,PJFALS\r
2810         GETYP   0,(B)\r
2811         CAIE    0,TUNBOU\r
2812         JRST    PJT1\r
2813         JRST    PJFALS\r
2814 \r
2815 ; COMPILERS GBOUND?\r
2816 \r
2817 CGBOUN: MOVE    0,(B)\r
2818         SUBM    M,(P)\r
2819         CAMN    0,$TLOCD\r
2820         JRST    PJT1\r
2821         PUSHJ   P,IGLOC\r
2822         JUMPE   B,PJFALS\r
2823         JRST    PJT1\r
2824 \f\r
2825 \r
2826 MFUNCTION REP,FSUBR,[REPEAT]\r
2827         JRST    PROG\r
2828 MFUNCTION PROG,FSUBR\r
2829         ENTRY   1\r
2830         GETYP   A,(AB)          ;GET ARG TYPE\r
2831         CAIE    A,TLIST         ;IS IT A LIST?\r
2832         JRST    WRONGT          ;WRONG TYPE\r
2833         SKIPN   C,1(AB)         ;GET AND CHECK ARGUMENT\r
2834         JRST    TFA             ;TOO FEW ARGS\r
2835         SETZB   E,D             ; INIT HEWITT ATOM AND DECL\r
2836         PUSHJ   P,CARATC        ; IS 1ST THING AN ATOM\r
2837         JFCL\r
2838         PUSHJ   P,RSATY1        ; CDR AND GET TYPE\r
2839         CAIE    0,TLIST         ; MUST BE LIST\r
2840         JRST    MPD.13\r
2841         MOVE    B,1(C)          ; GET ARG LIST\r
2842         PUSH    TP,$TLIST\r
2843         PUSH    TP,C\r
2844         PUSHJ   P,RSATYP\r
2845         CAIE    0,TDECL\r
2846         JRST    NOP.DC          ; JUMP IF NO DCL\r
2847         MOVE    D,1(C)\r
2848         MOVEM   C,(TP)\r
2849         PUSHJ   P,RSATYP        ; CDR ON\r
2850 NOP.DC: PUSH    TP,$TLIST       \r
2851         PUSH    TP,B            ; AND ARG LIST\r
2852         PUSHJ   P,PRGBND        ; BIND AUX VARS\r
2853         MOVE    E,MQUOTE LPROG,[LPROG ]INTRUP\r
2854         PUSHJ   P,MAKACT        ; MAKE ACTIVATION\r
2855         PUSHJ   P,PSHBND        ; BIND AND CHECK\r
2856         PUSHJ   P,SPECBI        ; NAD BIND IT\r
2857 \r
2858 ; HERE TO RUN PROGS FUNCTIONS ETC.\r
2859 \r
2860 DOPROG: MOVEI   A,REPROG\r
2861         HRLI    A,TDCLI         ; FLAG AS FUNNY\r
2862         MOVEM   A,(TB)          ; WHERE TO AGAIN TO\r
2863         MOVE    C,1(TB)\r
2864         MOVEM   C,3(TB)         ; RESTART POINTER\r
2865         JRST    .+2             ; START BY SKIPPING DECL\r
2866 \r
2867 DOPRG1: PUSHJ   P,FASTEV\r
2868         HRRZ    C,@1(TB)        ;GET THE REST OF THE BODY\r
2869 DOPRG2: MOVEM   C,1(TB)\r
2870         JUMPN   C,DOPRG1\r
2871 ENDPROG:\r
2872         HRRZ    C,FSAV(TB)\r
2873         CAIN    C,REP\r
2874 REPROG: SKIPN   C,@3(TB)\r
2875         JRST    PFINIS\r
2876         HRRZM   C,1(TB)\r
2877         INTGO\r
2878         MOVE    C,1(TB)\r
2879         JRST    DOPRG1\r
2880 \r
2881 \r
2882 PFINIS: GETYP   0,(TB)\r
2883         CAIE    0,TDCLI         ; DECL'D ?\r
2884         JRST    PFINI1\r
2885         HRRZ    0,(TB)          ; SEE IF RSUBR\r
2886         JUMPE   0,RSBVCK        ; CHECK RSUBR VALUE\r
2887         HRRZ    C,3(TB)         ; GET START OF FCN\r
2888         GETYP   0,(C)           ; CHECK FOR DECL\r
2889         CAIE    0,TDECL\r
2890         JRST    PFINI1          ; NO, JUST RETURN\r
2891         MOVE    E,MQUOTE VALUE\r
2892         PUSHJ   P,PSHBND        ; BUILD FAKE BINDING\r
2893         MOVE    C,1(C)          ; GET DECL LIST\r
2894         MOVE    E,TP\r
2895         PUSHJ   P,CHKDCL        ; AND CHECK IT\r
2896         MOVE    A,-3(TP)                ; GET VAL BAKC\r
2897         MOVE    B,-2(TP)\r
2898         SUB     TP,[6,,6]\r
2899 \r
2900 PFINI1: HRRZ    C,FSAV(TB)\r
2901         CAIE    C,EVAL\r
2902         JRST    FINIS\r
2903         JRST    EFINIS\r
2904 \r
2905 RSATYP: HRRZ    C,(C)\r
2906 RSATY1: JUMPE   C,TFA\r
2907         GETYP   0,(C)\r
2908         POPJ    P,\r
2909 \r
2910 ; HERE TO CHECK RSUBR VALUE\r
2911 \r
2912 RSBVCK: PUSH    TP,A\r
2913         PUSH    TP,B\r
2914         MOVE    C,A\r
2915         MOVE    D,B\r
2916         MOVE    A,1(TB)         ; GET DECL\r
2917         MOVE    B,1(A)\r
2918         HLLZ    A,(A)\r
2919         PUSHJ   P,TMATCH\r
2920         JRST    RSBVC1\r
2921         POP     TP,B\r
2922         POP     TP,A\r
2923         POPJ    P,\r
2924 \r
2925 RSBVC1: MOVE    C,1(TB)\r
2926         POP     TP,B\r
2927         POP     TP,D\r
2928         MOVE    A,MQUOTE VALUE\r
2929         JRST    TYPMIS\r
2930 \f\r
2931 \r
2932 MFUNCTION MRETUR,SUBR,[RETURN]\r
2933         ENTRY\r
2934         HLRE    A,AB            ; GET # OF ARGS\r
2935         ASH     A,-1            ; TO NUMBER\r
2936         AOJL    A,RET2          ; 2 OR MORE ARGS\r
2937         PUSHJ   P,PROGCH        ;CHECK IN A PROG\r
2938         PUSH    TP,A\r
2939         PUSH    TP,B\r
2940         MOVEI   B,-1(TP)        ; VERIFY IT\r
2941 COMRET: PUSHJ   P,CHFSWP\r
2942         SKIPL   C               ; ARGS?\r
2943         MOVEI   C,0             ; REAL NONE\r
2944         PUSHJ   P,CHUNW\r
2945         JUMPN   A,CHFINI        ; WINNER\r
2946         MOVSI   A,TATOM\r
2947         MOVE    B,MQUOTE T\r
2948 \r
2949 ; SEE IF MUST  CHECK RETURNS TYPE\r
2950 \r
2951 CHFINI: GETYP   0,(TB)          ; SPECIAL TYPE IF SO\r
2952         CAIE    0,TDCLI\r
2953         JRST    FINIS           ; NO, JUST FINIS\r
2954         MOVEI   0,PFINIS        ; CAUSE TO FALL INTO FUNCTION CODE\r
2955         HRRM    0,PCSAV(TB)\r
2956         JRST    CONTIN\r
2957 \r
2958 \r
2959 RET2:   AOJL    A,TMA\r
2960         GETYP   A,(AB)+2\r
2961         CAIE    A,TACT          ; AS FOR "EXIT" SHOULD BE ACTIVATION\r
2962         JRST    WTYP2\r
2963         MOVEI   B,(AB)+2        ; ADDRESS OF FRAME POINTER\r
2964         JRST    COMRET\r
2965 \r
2966 \r
2967 \r
2968 MFUNCTION AGAIN,SUBR\r
2969         ENTRY   \r
2970         HLRZ    A,AB            ;GET # OF ARGS\r
2971         CAIN    A,-2            ;1 ARG?\r
2972         JRST    NLCLA           ;YES\r
2973         JUMPN   A,TMA           ;0 ARGS?\r
2974         PUSHJ   P,PROGCH        ;CHECK FOR IN A PROG\r
2975         PUSH    TP,A\r
2976         PUSH    TP,B\r
2977         JRST    AGAD\r
2978 NLCLA:  GETYP   A,(AB)\r
2979         CAIE    A,TACT\r
2980         JRST    WTYP1\r
2981         PUSH    TP,(AB)\r
2982         PUSH    TP,1(AB)\r
2983 AGAD:   MOVEI   B,-1(TP)        ; POINT TO FRAME\r
2984         PUSHJ   P,CHFSWP\r
2985         HRRZ    C,(B)           ; GET RET POINT\r
2986 GOJOIN: PUSH    TP,$TFIX\r
2987         PUSH    TP,C\r
2988         MOVEI   C,-1(TP)\r
2989         PUSHJ   P,CHUNW         ; RESTORE FRAME, UNWIND IF NEC.\r
2990         HRRZM   B,PCSAV(TB)\r
2991         HRRZ    0,FSAV(TB)      ; CHECK FOR RSUBR\r
2992         CAMGE   0,VECTOP\r
2993         CAMG    0,VECBOT\r
2994         JRST    CONTIN\r
2995         HRRZ    E,1(TB)\r
2996         PUSH    TP,$TFIX\r
2997         PUSH    TP,B\r
2998         MOVEI   C,-1(TP)\r
2999         MOVEI   B,(TB)\r
3000         PUSHJ   P,CHUNW1\r
3001         MOVE    TP,1(TB)\r
3002         MOVEM   SP,SPSAV(TB)\r
3003         MOVEM   TP,TPSAV(TB)\r
3004         MOVE    C,OTBSAV(TB)    ; AND RESTORE P FROM FATHER\r
3005         MOVE    P,PSAV(C)\r
3006         MOVEM   P,PSAV(TB)\r
3007         HRLI    B,M\r
3008         MOVEM   B,PCSAV(TB)\r
3009         JRST    CONTIN\r
3010 \r
3011 MFUNCTION GO,SUBR\r
3012         ENTRY   1\r
3013         GETYP   A,(AB)\r
3014         CAIE    A,TATOM\r
3015         JRST    NLCLGO\r
3016         PUSHJ   P,PROGCH        ;CHECK FOR A PROG\r
3017         PUSH    TP,A            ;SAVE\r
3018         PUSH    TP,B\r
3019         MOVEI   B,-1(TP)\r
3020         PUSHJ   P,CHFSWP\r
3021         PUSH    TP,$TATOM\r
3022         PUSH    TP,1(C)\r
3023         PUSH    TP,2(B)\r
3024         PUSH    TP,3(B)\r
3025         MCALL   2,MEMQ          ;DOES IT HAVE THIS TAG?\r
3026         JUMPE   B,NXTAG         ;NO -- ERROR\r
3027 FNDGO:  EXCH    B,(TP)          ;SAVE PLACE TO GO\r
3028         MOVSI   D,TLIST\r
3029         MOVEM   D,-1(TP)\r
3030         JRST    GODON\r
3031 \r
3032 NLCLGO: CAIE    A,TTAG          ;CHECK TYPE\r
3033         JRST    WTYP1\r
3034         MOVE    B,1(AB)\r
3035         MOVEI   B,2(B)          ; POINT TO SLOT\r
3036         PUSHJ   P,CHFSWP\r
3037         MOVE    A,1(C)\r
3038         GETYP   0,(A)           ; SEE IF COMPILED\r
3039         CAIE    0,TFIX\r
3040         JRST    GODON1\r
3041         MOVE    C,1(A)\r
3042         JRST    GOJOIN\r
3043 \r
3044 GODON1: PUSH    TP,(A)          ;SAVE BODY\r
3045         PUSH    TP,1(A)\r
3046 GODON:  MOVEI   C,0\r
3047         PUSHJ   P,CHUNW         ;GO BACK TO CORRECT FRAME\r
3048         MOVE    B,(TP)          ;RESTORE ITERATION MARKER\r
3049         MOVEM   B,1(TB)\r
3050         MOVSI   A,TFALSE\r
3051         MOVEI   B,0\r
3052         JRST    CONTIN\r
3053 \r
3054 \f\r
3055 \r
3056 \r
3057 MFUNCTION TAG,SUBR\r
3058         ENTRY\r
3059         JUMPGE  AB,TFA\r
3060         HLRZ    0,AB\r
3061         GETYP   A,(AB)          ;GET TYPE OF ARGUMENT\r
3062         CAIE    A,TFIX          ; FIX ==> COMPILED\r
3063         JRST    ATOTAG\r
3064         CAIE    0,-4\r
3065         JRST    WNA\r
3066         GETYP   A,2(AB)\r
3067         CAIE    A,TACT\r
3068         JRST    WTYP2\r
3069         PUSH    TP,(AB)\r
3070         PUSH    TP,1(AB)\r
3071         PUSH    TP,2(AB)\r
3072         PUSH    TP,3(AB)\r
3073         JRST    GENTV\r
3074 ATOTAG: CAIE    A,TATOM         ;CHECK THAT IT IS AN ATOM\r
3075         JRST    WTYP1\r
3076         CAIE    0,-2\r
3077         JRST    TMA\r
3078         PUSHJ   P,PROGCH        ;CHECK PROG\r
3079         PUSH    TP,A            ;SAVE VAL\r
3080         PUSH    TP,B\r
3081         PUSH    TP,$TATOM\r
3082         PUSH    TP,1(AB)\r
3083         PUSH    TP,2(B)\r
3084         PUSH    TP,3(B)\r
3085         MCALL   2,MEMQ\r
3086         JUMPE   B,NXTAG         ;IF NOT FOUND -- ERROR\r
3087         EXCH    A,-1(TP)        ;SAVE PLACE\r
3088         EXCH    B,(TP)  \r
3089         HRLI    A,TFRAME\r
3090         PUSH    TP,A\r
3091         PUSH    TP,B\r
3092 GENTV:  MOVEI   A,2\r
3093         PUSHJ   P,IEVECT\r
3094         MOVSI   A,TTAG\r
3095         JRST    FINIS\r
3096 \r
3097 PROGCH: MOVE    B,MQUOTE LPROG,[LPROG ]INTRUP\r
3098         PUSHJ   P,ILVAL         ;GET VALUE\r
3099         GETYP   0,A\r
3100         CAIE    0,TACT\r
3101         JRST    NXPRG\r
3102         POPJ    P,\r
3103 \r
3104 ; HERE TO UNASSIGN LPROG IF NEC\r
3105 \r
3106 UNPROG: MOVE    B,MQUOTE LPROG,[LPROG ]INTRUP\r
3107         PUSHJ   P,ILVAL\r
3108         GETYP   0,A\r
3109         CAIE    0,TACT          ; SKIP IF MUST UNBIND\r
3110         JRST    UNMAP\r
3111         MOVSI   A,TUNBOU\r
3112         MOVNI   B,1\r
3113         MOVE    E,MQUOTE LPROG,[LPROG ]INTRUP\r
3114         PUSHJ   P,PSHBND\r
3115 UNMAP:  HRRZ    0,FSAV(TB)      ; CHECK FOR FUNNY\r
3116         CAIN    0,MAPPLY        ; SKIP IF NOT\r
3117         POPJ    P,\r
3118         MOVE    B,MQUOTE LMAP,[LMAP ]INTRUP\r
3119         PUSHJ   P,ILVAL\r
3120         GETYP   0,A\r
3121         CAIE    0,TFRAME\r
3122         JRST    UNSPEC\r
3123         MOVSI   A,TUNBOU\r
3124         MOVNI   B,1\r
3125         MOVE    E,MQUOTE LMAP,[LMAP ]INTRUP\r
3126         PUSHJ   P,PSHBND\r
3127 UNSPEC: PUSH    TP,BNDV\r
3128         MOVE    B,PVP\r
3129         ADD     B,[CURFCN,,CURFCN]\r
3130         PUSH    TP,B\r
3131         PUSH    TP,$TSP\r
3132         MOVE    E,SP\r
3133         ADD     E,[3,,3]\r
3134         PUSH    TP,E\r
3135         POPJ    P,\r
3136 \r
3137 REPEAT 0,[\r
3138 MFUNCTION MEXIT,SUBR,[EXIT]\r
3139         ENTRY   2\r
3140         GETYP   A,(AB)\r
3141         CAIE    A,TACT\r
3142         JRST    WTYP1\r
3143         MOVEI   B,(AB)\r
3144         PUSHJ   P,CHFSWP\r
3145         ADD     C,[2,,2]\r
3146         PUSHJ   P,CHUNW         ;RESTORE FRAME\r
3147         JRST    CHFINI          ; CHECK FOR WINNING VALUE\r
3148 ]\r
3149 \r
3150 MFUNCTION COND,FSUBR\r
3151         ENTRY   1\r
3152         GETYP   A,(AB)\r
3153         CAIE    A,TLIST\r
3154         JRST    WRONGT\r
3155         PUSH    TP,(AB)\r
3156         PUSH    TP,1(AB)                ;CREATE UNNAMED TEMP\r
3157         MOVEI   B,0             ; SET TO FALSE IN CASE\r
3158 \r
3159 CLSLUP: SKIPN   C,1(TB)         ;IS THE CLAUSELIST NIL?\r
3160         JRST    IFALS1          ;YES -- RETURN NIL\r
3161         GETYP   A,(C)           ;NO -- GET TYPE OF CAR\r
3162         CAIE    A,TLIST         ;IS IT A LIST?\r
3163         JRST    BADCLS          ;\r
3164         MOVE    A,1(C)          ;YES -- GET CLAUSE\r
3165         JUMPE   A,BADCLS\r
3166         GETYPF  B,(A)\r
3167         PUSH    TP,B            ; EVALUATION OF\r
3168         HLLZS   (TP)\r
3169         PUSH    TP,1(A)         ;THE PREDICATE\r
3170         JSP     E,CHKARG\r
3171         MCALL   1,EVAL\r
3172         GETYP   0,A\r
3173         CAIN    0,TFALSE\r
3174         JRST    NXTCLS          ;FALSE TRY NEXT CLAUSE\r
3175         MOVE    C,1(TB)         ;IF NOT, DO FIRST CLAUSE\r
3176         MOVE    C,1(C)\r
3177         HRRZ    C,(C)\r
3178         JUMPE   C,FINIS         ;(UNLESS DONE WITH IT)\r
3179         JRST    DOPRG2          ;AS THOUGH IT WERE A PROG\r
3180 NXTCLS: HRRZ    C,@1(TB)        ;SET THE CLAUSLIST\r
3181         HRRZM   C,1(TB)         ;TO CDR OF THE CLAUSLIST\r
3182         JRST    CLSLUP\r
3183         \r
3184 IFALSE:\r
3185         MOVEI   B,0\r
3186 IFALS1: MOVSI   A,TFALSE        ;RETURN FALSE\r
3187         JRST    FINIS\r
3188 \r
3189 \r
3190 \f\r
3191 MFUNCTION UNWIND,FSUBR\r
3192 \r
3193         ENTRY   1\r
3194 \r
3195         GETYP   0,(AB)          ; CHECK THE ARGS FOR WINNAGE\r
3196         SKIPN   A,1(AB)         ; NONE?\r
3197         JRST    TFA\r
3198         HRRZ    B,(A)           ; CHECK FOR 2D\r
3199         JUMPE   B,TFA\r
3200         HRRZ    0,(B)           ; 3D?\r
3201         JUMPN   0,TMA\r
3202 \r
3203 ; Unbind LPROG and LMAPF so that nothing cute happens\r
3204 \r
3205         PUSHJ   P,UNPROG\r
3206 \r
3207 ; Push thing to do upon UNWINDing\r
3208 \r
3209         PUSH    TP,$TLIST\r
3210         PUSH    TP,[0]\r
3211 \r
3212         MOVEI   C,UNWIN1\r
3213         PUSHJ   P,IUNWIN        ; GOT TO INTERNAL SET UP\r
3214 \r
3215 ; Now EVAL the first form\r
3216 \r
3217         MOVE    A,1(AB)\r
3218         HRRZ    0,(A)           ; SAVE POINTER TO OTHER GUY\r
3219         MOVEM   0,-12(TP)\r
3220         MOVE    B,1(A)\r
3221         GETYP   A,(A)\r
3222         MOVSI   A,(A)\r
3223         JSP     E,CHKAB         ; DEFER?\r
3224         PUSH    TP,A\r
3225         PUSH    TP,B\r
3226         MCALL   1,EVAL          ; EVAL THE LOSER\r
3227 \r
3228         JRST    FINIS\r
3229 \r
3230 ; Now push slots to hold undo info on the way down\r
3231 \r
3232 IUNWIN:\r
3233 REPEAT 0,[\r
3234         JUMPE   M,NOTRSB\r
3235         MOVEI   C,(C)\r
3236         HLRE    0,M\r
3237         SUBM    M,0\r
3238         ANDI    0,-1\r
3239         CAIL    C,HIBOT\r
3240         JRST    NOTRSB\r
3241         CAIL    C,(M)\r
3242         CAML    C,0\r
3243         JRST    .+2\r
3244         SUBI    C,(M)\r
3245 NOTRSB:]\r
3246         PUSH    TP,$TTB         ; DESTINATION FRAME\r
3247         PUSH    TP,[0]\r
3248         PUSH    TP,[0]          ; ARGS TO WHOEVER IS DOING IT\r
3249         PUSH    TP,[0]\r
3250 \r
3251 ; Now bind UNWIND word\r
3252 \r
3253         PUSH    TP,$TUNWIN      ; FIRST WORD OF IT\r
3254         HRRM    SP,(TP)         ; CHAIN\r
3255         MOVE    SP,TP\r
3256         PUSH    TP,TB           ; AND POINT TO HERE\r
3257         PUSH    TP,$TTP\r
3258         PUSH    TP,[0]\r
3259         HRLI    C,TPDL\r
3260         PUSH    TP,C\r
3261         PUSH    TP,P            ; SAVE PDL ALSO\r
3262         MOVEM   TP,-2(TP)       ; SAVE FOR LATER\r
3263         POPJ    P,\r
3264 \r
3265 ; Do a non-local return with UNWIND checking\r
3266 \r
3267 CHUNW:  HRRZ    E,SPSAV(B)      ; GET DESTINATION FRAME\r
3268 CHUNW1: PUSH    TP,(C)          ; FINAL VAL\r
3269         PUSH    TP,1(C)\r
3270         JUMPN   C,.+3           ; WAS THERE REALLY ANYTHING\r
3271         SETZM   (TP)\r
3272         SETZM   -1(TP)\r
3273         PUSHJ   P,STLOOP        ; UNBIND\r
3274 CHUNPC: SKIPA                   ; WILL NOT SKIP UNLESS UNWIND FOUND\r
3275         JRST    GOTUND\r
3276         MOVEI   A,(TP)\r
3277         SUBI    A,(SP)\r
3278         MOVSI   A,(A)\r
3279         HLL     SP,TP\r
3280         SUB     SP,A\r
3281         HRRI    TB,(B)          ; UPDATE TB\r
3282         POP     TP,B\r
3283         POP     TP,A\r
3284         POPJ    P,\r
3285 \r
3286 ; Here if an UNDO found\r
3287 \r
3288 GOTUND: MOVE    TB,1(SP)        ; GET FRAME OF UNDO\r
3289         MOVE    A,-1(TP)        ; GET FUNNY ARG FOR PASS ON\r
3290         MOVE    C,(TP)\r
3291         MOVE    TP,3(SP)        ; GET FUTURE TP\r
3292         MOVEM   C,-6(TP)        ; SAVE ARG\r
3293         MOVEM   A,-7(TP)\r
3294         MOVE    C,(TP)          ; SAVED P\r
3295         SUB     C,[1,,1]\r
3296         MOVEM   C,PSAV(TB)      ; MAKE CONTIN WIN\r
3297         MOVEM   TP,TPSAV(TB)\r
3298         MOVEM   SP,SPSAV(TB)\r
3299         HRRZ    C,(P)           ; PC OF CHUNW CALLER\r
3300         HRRM    C,-11(TP)       ; SAVE ALSO AND GET WHERE TO GO PC\r
3301         MOVEM   B,-10(TP)       ; AND DESTINATION FRAME\r
3302         HRRZ    C,-1(TP)                ; WHERE TO UNWIND PC\r
3303         HRRZ    0,FSAV(TB)      ; RSUBR?\r
3304         CAMG    0,VECTOP\r
3305         CAMGE   0,VECBOT\r
3306         TLZA    C,-1            ; 0 LH OF C AND SKIP\r
3307         HRLI    C,M             ; RELATIVIZE\r
3308         MOVEM   C,PCSAV(TB)\r
3309         JRST    CONTIN\r
3310 \r
3311 UNWIN1: MOVE    B,-12(TP)       ; POINT TO THING TO DO UNWINDING\r
3312         GETYP   A,(B)\r
3313         MOVSI   A,(A)\r
3314         MOVE    B,1(B)\r
3315         JSP     E,CHKAB\r
3316         PUSH    TP,A\r
3317         PUSH    TP,B\r
3318         MCALL   1,EVAL\r
3319 UNWIN2: MOVEI   C,-7(TP)        ; POINT TO SAVED RET VALS\r
3320         MOVE    B,-10(TP)\r
3321         HRRZ    E,-11(TP)\r
3322         PUSH    P,E\r
3323         HRRZ    SP,(SP)         ; UNBIND THIS GUY\r
3324         MOVEI   E,(TP)          ; AND FIXUP SP\r
3325         SUBI    E,(SP)\r
3326         MOVSI   E,(E)\r
3327         HLL     SP,TP\r
3328         SUB     SP,E\r
3329         JRST    CHUNW           ; ANY MORE TO UNWIND?\r
3330 \r
3331 \f\r
3332 ; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.\r
3333 ; CALLED BY ALL CONTROL FLOW\r
3334 ; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)\r
3335 \r
3336 CHFSWP: PUSHJ   P,CHFRM         ; CHECK FOR VALID FRAME\r
3337         HRRZ    D,(B)           ; PROCESS VECTOR DOPE WD\r
3338         HLRZ    C,(D)           ; LENGTH\r
3339         SUBI    D,-1(C)         ; POINT TO TOP\r
3340         MOVNS   C               ; NEGATE COUNT\r
3341         HRLI    D,2(C)          ; BUILD PVP\r
3342         MOVE    E,PVP\r
3343         MOVE    C,AB\r
3344         MOVE    A,(B)           ; GET FRAME\r
3345         MOVE    B,1(B)\r
3346         CAMN    E,D             ; SKIP IF SWAP NEEDED\r
3347         POPJ    P,\r
3348         PUSH    TP,A            ; SAVE FRAME\r
3349         PUSH    TP,B\r
3350         MOVE    B,D\r
3351         PUSHJ   P,PROCHK        ; FIX UP PROCESS LISTS\r
3352         MOVE    A,PSTAT+1(B)    ; GET STATE\r
3353         CAIE    A,RESMBL\r
3354         JRST    NOTRES\r
3355         MOVE    D,B             ; PREPARE TO SWAP\r
3356         POP     P,0             ; RET ADDR\r
3357         POP     TP,B\r
3358         POP     TP,A\r
3359         JSP     C,SWAP          ; SWAP IN\r
3360         MOVE    C,ABSTO+1(E)    ; GET OLD ARRGS\r
3361         MOVEI   A,RUNING        ; FIX STATES\r
3362         MOVEM   A,PSTAT+1(PVP)\r
3363         MOVEI   A,RESMBL\r
3364         MOVEM   A,PSTAT+1(E)\r
3365         JRST    @0\r
3366 \r
3367 NOTRES: PUSH    TP,$TATOM\r
3368         PUSH    TP,EQUOTE PROCESS-NOT-RESUMABLE\r
3369         JRST    CALER1\r
3370 \f\r
3371 \r
3372 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,\r
3373 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT.  ITS VALUE IS\r
3374 ; ITS SECOND ARGUMENT.\r
3375 \r
3376 MFUNCTION SETG,SUBR\r
3377         ENTRY   2\r
3378         GETYP   A,(AB)          ;GET TYPE OF FIRST ARGUMENT\r
3379         CAIE    A,TATOM ;CHECK THAT IT IS AN ATOM\r
3380         JRST    NONATM          ;IF NOT -- ERROR\r
3381         MOVE    B,1(AB)         ;GET POINTER TO ATOM\r
3382         PUSH    TP,$TATOM\r
3383         PUSH    TP,B\r
3384         MOVEI   0,(B)\r
3385         CAIL    0,HIBOT         ; PURE ATOM?\r
3386         PUSHJ   P,IMPURIFY      ; YES IMPURIFY\r
3387         PUSHJ   P,IGLOC         ;GET LOCATIVE TO VALUE\r
3388         CAMN    A,$TUNBOUND     ;IF BOUND\r
3389         PUSHJ   P,BSETG         ;IF NOT -- BIND IT\r
3390         MOVE    C,2(AB)         ; GET PROPOSED VVAL\r
3391         MOVE    D,3(AB)\r
3392         MOVSI   A,TLOCD         ; MAKE SURE MONCH WINS\r
3393         PUSHJ   P,MONCH0        ; WOULD YOU BELIEVE MONITORS!!!!\r
3394         EXCH    D,B             ;SAVE PTR\r
3395         MOVE    A,C\r
3396         HRRZ    E,-2(D)         ; POINT TO POSSIBLE GDECL (OR MAINIFEST)\r
3397         JUMPE   E,OKSETG        ; NONE ,OK\r
3398         CAIE    E,-1            ; MANIFEST?\r
3399         JRST    SETGTY\r
3400         GETYP   0,(D)           ; IF UNBOUND, LET IT HAPPEN\r
3401         SKIPN   IGDECL\r
3402         CAIN    0,TUNBOU\r
3403         JRST    OKSETG\r
3404 MANILO: GETYP   C,(D)\r
3405         GETYP   0,2(AB)\r
3406         CAIN    0,(C)\r
3407         CAME    B,1(D)\r
3408         JRST    .+2\r
3409         JRST    OKSETG\r
3410         PUSH    TP,$TVEC\r
3411         PUSH    TP,D\r
3412         MOVE    B,MQUOTE REDEFINE\r
3413         PUSHJ   P,ILVAL         ; SEE IF REDEFINE OK\r
3414         GETYP   A,A\r
3415         CAIE    A,TUNBOU\r
3416         CAIN    A,TFALSE\r
3417         JRST    .+2\r
3418         JRST    OKSTG\r
3419         PUSH    TP,$TATOM\r
3420         PUSH    TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE\r
3421         PUSH    TP,$TATOM\r
3422         PUSH    TP,1(AB)\r
3423         MOVEI   A,2\r
3424         JRST    CALER\r
3425 \r
3426 SETGTY: PUSH    TP,$TVEC\r
3427         PUSH    TP,D\r
3428         MOVE    C,A\r
3429         MOVE    D,B\r
3430         GETYP   A,(E)\r
3431         MOVSI   A,(A)\r
3432         MOVE    B,1(E)\r
3433         JSP     E,CHKAB\r
3434         PUSHJ   P,TMATCH\r
3435         JRST    TYPMI3\r
3436 \r
3437 OKSTG:  MOVE    D,(TP)\r
3438         MOVE    A,2(AB)\r
3439         MOVE    B,3(AB)\r
3440 \r
3441 OKSETG: MOVEM   A,(D)           ;DEPOSIT INTO THE \r
3442         MOVEM   B,1(D)          ;INDICATED VALUE CELL\r
3443         JRST    FINIS\r
3444 \r
3445 TYPMI3: MOVE    C,(TP)\r
3446         HRRZ    C,-2(C)\r
3447         MOVE    D,2(AB)\r
3448         MOVE    B,3(AB)\r
3449         MOVE    0,(AB)\r
3450         MOVE    A,1(AB)\r
3451         JRST    TYPMIS\r
3452 \r
3453 BSETG:  HRRZ    A,GLOBASE+1(TVP)\r
3454         HRRZ    B,GLOBSP+1(TVP)\r
3455         SUB     B,A\r
3456         CAIL    B,6\r
3457         JRST    SETGIT\r
3458         MOVEI   B,0             ; MAKE SURE OF NO EMPTY SLOTS\r
3459         PUSHJ   P,IGLOC\r
3460         CAMN    A,$TUNBOU       ; SKIP IF SLOT FOUND\r
3461         JRST    BSETG1\r
3462         MOVE    E,(TP)          ; GET ATOM\r
3463         MOVEM   E,-1(B)         ; CLOBBER ATOM SLOT\r
3464         POPJ    P,\r
3465 ; BSETG1:       PUSH    TP,GLOBASE(TVP) ; MUST REALLY GROW STACK\r
3466 ;       PUSH    TP,GLOBASE+1 (TVP)\r
3467 ;       PUSH    TP,$TFIX\r
3468 ;       PUSH    TP,[0]\r
3469 ;       PUSH    TP,$TFIX\r
3470 ;       PUSH    TP,[100]\r
3471 ;       MCALL   3,GROW\r
3472 BSETG1: PUSH    P,0\r
3473         PUSH    P,C\r
3474         MOVE    C,GLOBASE+1(TVP)\r
3475         HLRE    B,C\r
3476         SUB     C,B\r
3477         MOVE    B,GVLINC        ; GROW BY INDICATED GVAL SLOTS\r
3478         DPB     B,[001100,,(C)]\r
3479 ;       MOVEM   A,GLOBASE(TVP)\r
3480         MOVE    C,[6,,4]                ; INDICATOR FOR AGC\r
3481         PUSHJ   P,AGC\r
3482         MOVE    B,GLOBASE+1(TVP)\r
3483         MOVE    0,GVLINC        ; ADJUST GLOBAL SPBASE\r
3484         ASH     0,6\r
3485         SUB     B,0\r
3486         HRLZS   0\r
3487         SUB     B,0\r
3488         MOVEM   B,GLOBASE+1(TVP)\r
3489 ;       MOVEM   B,GLOBASE+1(TVP)\r
3490         POP     P,0\r
3491         POP     P,C\r
3492 SETGIT:\r
3493         MOVE    B,GLOBSP+1(TVP)\r
3494         SUB     B,[4,,4]\r
3495         MOVSI   C,TGATOM\r
3496         MOVEM   C,(B)\r
3497         MOVE    C,(TP)\r
3498         MOVEM   C,1(B)\r
3499         MOVEM   B,GLOBSP+1(TVP)\r
3500         ADD     B,[2,,2]\r
3501         MOVSI   A,TLOCI\r
3502         POPJ    P,\r
3503 \r
3504 \r
3505 MFUNCTION DEFMAC,FSUBR\r
3506 \r
3507         ENTRY   1\r
3508 \r
3509         PUSH    P,.\r
3510         JRST    DFNE2\r
3511 \r
3512 MFUNCTION DFNE,FSUBR,[DEFINE]\r
3513 \r
3514         ENTRY   1\r
3515 \r
3516         PUSH    P,[0]\r
3517 DFNE2:  GETYP   A,(AB)\r
3518         CAIE    A,TLIST\r
3519         JRST    WRONGT\r
3520         SKIPN   B,1(AB)         ; GET ATOM\r
3521         JRST    TFA\r
3522         GETYP   A,(B)           ; MAKE SURE ATOM\r
3523         MOVSI   A,(A)\r
3524         PUSH    TP,A\r
3525         PUSH    TP,1(B)\r
3526         JSP     E,CHKARG\r
3527         MCALL   1,EVAL          ; EVAL IT TO AN ATOM\r
3528         CAME    A,$TATOM\r
3529         JRST    NONATM\r
3530         PUSH    TP,A            ; SAVE TWO COPIES\r
3531         PUSH    TP,B\r
3532         PUSHJ   P,IGVAL         ; SEE IF A VALUE EXISTS\r
3533         CAMN    A,$TUNBOU       ; SKIP IF A WINNER\r
3534         JRST    .+3\r
3535         PUSHJ   P,ASKUSR        ; CHECK WITH USER\r
3536         JRST    DFNE1\r
3537         PUSH    TP,$TATOM\r
3538         PUSH    TP,-1(TP)\r
3539         MOVE    B,1(AB)\r
3540         HRRZ    B,(B)\r
3541         MOVSI   A,TEXPR\r
3542         SKIPN   (P)             ; SKIP IF MACRO\r
3543         JRST    DFNE3\r
3544         MOVEI   D,(B)           ; READY TO CONS\r
3545         MOVSI   C,TEXPR\r
3546         PUSHJ   P,INCONS\r
3547         MOVSI   A,TMACRO\r
3548 DFNE3:  PUSH    TP,A\r
3549         PUSH    TP,B\r
3550         MCALL   2,SETG\r
3551 DFNE1:  POP     TP,B            ; RETURN ATOM\r
3552         POP     TP,A\r
3553         JRST    FINIS\r
3554 \r
3555 \r
3556 ASKUSR: MOVE    B,MQUOTE REDEFINE\r
3557         PUSHJ   P,ILVAL         ; SEE IF REDEFINE OK\r
3558         GETYP   A,A\r
3559         CAIE    A,TUNBOU\r
3560         CAIN    A,TFALSE\r
3561         JRST    ASKUS1\r
3562         JRST    ASKUS2\r
3563 ASKUS1: PUSH    TP,$TATOM\r
3564         PUSH    TP,-1(TP)\r
3565         PUSH    TP,$TATOM\r
3566         PUSH    TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE\r
3567         MCALL   2,ERROR\r
3568         GETYP   0,A\r
3569         CAIE    0,TFALSE\r
3570 ASKUS2: AOS     (P)\r
3571         MOVE    B,1(AB)\r
3572         POPJ    P,\r
3573 \f\r
3574 \r
3575 \r
3576 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS\r
3577 ;FIRST ARGUMENT TO THE SECOND ARG.  ITS VALUE IS ITS SECOND ARGUMENT.\r
3578 \r
3579 MFUNCTION SET,SUBR\r
3580         HLRE    D,AB            ; 2 TIMES # OF ARGS TO D\r
3581         ASH     D,-1            ; - # OF ARGS\r
3582         ADDI    D,2\r
3583         JUMPG   D,TFA           ; NOT ENOUGH\r
3584         MOVE    B,PVP\r
3585         MOVE    C,SP\r
3586         JUMPE   D,SET1          ; NO ENVIRONMENT\r
3587         AOJL    D,TMA           ; TOO MANY\r
3588         GETYP   A,4(AB)         ; CHECK ARG IS A FRAME OR PROCESS\r
3589         CAIE    A,TFRAME\r
3590         CAIN    A,TENV\r
3591         JRST    SET2            ; WINNING ENVIRONMENT/FRAME\r
3592         CAIN    A,TACT\r
3593         JRST    SET2            ; TO MAKE PFISTER HAPPY\r
3594         CAIE    A,TPVP\r
3595         JRST    WTYP2\r
3596         MOVE    B,5(AB)         ; GET PROCESS\r
3597         MOVE    C,SPSTO+1(B)\r
3598         JRST    SET1\r
3599 SET2:   MOVEI   B,4(AB)         ; POINT TO FRAME\r
3600         PUSHJ   P,CHFRM ; CHECK IT OUT\r
3601         MOVE    B,5(AB)         ; GET IT BACK\r
3602         MOVE    C,SPSAV(B)      ; GET BINDING POINTER\r
3603         HRRZ    B,4(AB)         ; POINT TO PROCESS\r
3604         HLRZ    A,(B)           ; GET LENGTH\r
3605         SUBI    B,-1(A)         ; POINT TO START THEREOF\r
3606         HLL     B,PVP           ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)\r
3607 SET1:   PUSH    TP,$TPVP        ; SAVE PROCESS\r
3608         PUSH    TP,B\r
3609         PUSH    TP,$TSP         ; SAVE PATH POINTER\r
3610         PUSH    TP,C\r
3611         GETYP   A,(AB)          ;GET TYPE OF FIRST\r
3612         CAIE    A,TATOM ;ARGUMENT -- \r
3613         JRST    WTYP1           ;BETTER BE AN ATOM\r
3614         MOVE    B,1(AB)         ;GET PTR TO IT\r
3615         MOVEI   0,(B)\r
3616         CAIL    0,HIBOT\r
3617         PUSHJ   P,IMPURIFY\r
3618         MOVE    C,(TP)\r
3619         PUSHJ   P,AILOC         ;GET LOCATIVE TO VALUE\r
3620 GOTLOC: CAMN    A,$TUNBOUND     ;BOUND?\r
3621         PUSHJ   P, BSET         ;BIND IT\r
3622         SUB     TP,[4,,4]\r
3623         MOVE    C,2(AB)         ; GET NEW VAL\r
3624         MOVE    D,3(AB)\r
3625         MOVSI   A,TLOCD         ; FOR MONCH\r
3626         HRR     A,2(B)\r
3627         PUSHJ   P,MONCH0        ; HURRAY FOR MONITORS!!!!!\r
3628         MOVE    E,B\r
3629         HLRZ    A,2(E)          ; GET DECLS\r
3630         JUMPE   A,SET3          ; NONE, GO\r
3631         PUSH    TP,$TSP\r
3632         PUSH    TP,E\r
3633         MOVE    B,1(A)\r
3634         HLLZ    A,(A)           ; GET PATTERN\r
3635         PUSHJ   P,TMATCH        ; MATCH TMEM\r
3636         JRST    TYPMI2          ; LOSES\r
3637         MOVE    E,(TP)\r
3638         SUB     TP,[2,,2]\r
3639         MOVE    C,2(AB)\r
3640         MOVE    D,3(AB)\r
3641 SET3:   MOVEM   C,(E)           ;CLOBBER IDENTIFIER\r
3642         MOVEM   D,1(E)\r
3643         MOVE    A,C\r
3644         MOVE    B,D\r
3645         JRST    FINIS\r
3646 BSET:\r
3647         CAMN    PVP,-2(TP)      ; SKIP IF PROC DIFFERS\r
3648         MOVEM   C,-2(TP)        ; ELSE USE RESULT FROM LOC SEARCH\r
3649         MOVE    B,-2(TP)        ; GET PROCESS\r
3650         HRRZ    A,TPBASE+1(B)   ;GET ACTUAL STACK BASE\r
3651         HRRZ    B,SPBASE+1(B)   ;AND FIRST BINDING\r
3652         SUB     B,A             ;ARE THERE 6\r
3653         CAIL    B,6             ;CELLS AVAILABLE?\r
3654         JRST    SETIT           ;YES\r
3655         MOVE    C,(TP)          ; GET POINTER BACK\r
3656         MOVEI   B,0             ; LOOK FOR EMPTY SLOT\r
3657         PUSHJ   P,AILOC\r
3658         CAMN    A,$TUNBOUND     ; SKIP IF FOUND\r
3659         JRST    BSET1\r
3660         MOVE    E,1(AB)         ; GET ATOM\r
3661         MOVEM   E,-1(B)         ; AND STORE\r
3662         JRST    BSET2\r
3663 BSET1:  MOVE    B,-2(TP)        ; GET PROCESS\r
3664 ;       PUSH    TP,TPBASE(B)    ;NO -- GROW THE TP\r
3665 ;       PUSH    TP,TPBASE+1(B)  ;AT THE BASE END\r
3666 ;       PUSH    TP,$TFIX\r
3667 ;       PUSH    TP,[0]\r
3668 ;       PUSH    TP,$TFIX\r
3669 ;       PUSH    TP,[100]\r
3670 ;       MCALL   3,GROW\r
3671 ;       MOVE    C,-2(TP)                ; GET PROCESS\r
3672 ;       MOVEM   A,TPBASE(C)     ;SAVE RESULT\r
3673         PUSH    P,0             ; MANUALLY GROW VECTOR\r
3674         PUSH    P,C\r
3675         MOVE    C,TPBASE+1(B)\r
3676         HLRE    B,C\r
3677         SUB     C,B\r
3678         MOVEI   C,1(C)\r
3679         CAME    C,TPGROW\r
3680         ADDI    C,PDLBUF\r
3681         MOVE    D,LVLINC\r
3682         DPB     D,[001100,,-1(C)]\r
3683         MOVE    C,[5,,3]        ; SET UP INDICATORS FOR AGC\r
3684         PUSHJ   P,AGC\r
3685         MOVE    B,TPBASE+1(PVP) ; MODIFY POINTER\r
3686         MOVE    0,LVLINC        ; ADJUST SPBASE POINTER\r
3687         ASH     0,6\r
3688         SUB     B,0\r
3689         HRLZS   0\r
3690         SUB     B,0\r
3691         MOVEM   B,TPBASE+1(PVP)\r
3692         POP     P,C\r
3693         POP     P,0\r
3694 ;       MOVEM   B,TPBASE+1(C)\r
3695 SETIT:  MOVE    C,-2(TP)                ; GET PROCESS\r
3696         MOVE    B,SPBASE+1(C)\r
3697         MOVEI   A,-6(B)         ;MAKE UP BINDING\r
3698         HRRM    A,(B)           ;LINK PREVIOUS BIND BLOCK\r
3699         MOVSI   A,TBIND\r
3700         MOVEM   A,-6(B)\r
3701         MOVE    A,1(AB)\r
3702         MOVEM   A,-5(B)\r
3703         SUB     B,[6,,6]\r
3704         MOVEM   B,SPBASE+1(C)\r
3705         ADD     B,[2,,2]\r
3706 BSET2:  MOVE    C,-2(TP)        ; GET PROC\r
3707         MOVSI   A,TLOCI\r
3708         HRR     A,BINDID+1(C)\r
3709         HLRZ    D,OTBSAV(TB)    ; TIME IT\r
3710         MOVEM   D,2(B)          ; AND FIX IT\r
3711         POPJ    P,\r
3712 \r
3713 ; HERE TO ELABORATE ON TYPE MISMATCH\r
3714 \r
3715 TYPMI2: MOVE    C,(TP)          ; FIND DECLS\r
3716         HLRZ    C,2(C)\r
3717         MOVE    D,2(AB)\r
3718         MOVE    B,3(AB)\r
3719         MOVE    0,(AB)          ; GET ATOM\r
3720         MOVE    A,1(AB)\r
3721         JRST    TYPMIS\r
3722 \r
3723 \f\r
3724 \r
3725 MFUNCTION NOT,SUBR\r
3726         ENTRY   1\r
3727         GETYP   A,(AB)          ; GET TYPE\r
3728         CAIE    A,TFALSE        ;IS IT FALSE?\r
3729         JRST    IFALSE          ;NO -- RETURN FALSE\r
3730 \r
3731 TRUTH:\r
3732         MOVSI   A,TATOM         ;RETURN T (VERITAS) \r
3733         MOVE    B,MQUOTE T\r
3734         JRST    FINIS\r
3735 \r
3736 MFUNCTION OR,FSUBR\r
3737 \r
3738         PUSH    P,[0]\r
3739         JRST    ANDOR\r
3740 \r
3741 MFUNCTION ANDA,FSUBR,AND\r
3742 \r
3743         PUSH    P,[1]\r
3744 ANDOR:  ENTRY   1\r
3745         GETYP   A,(AB)\r
3746         CAIE    A,TLIST\r
3747         JRST    WRONGT          ;IF ARG DOESN'T CHECK OUT\r
3748         MOVE    E,(P)\r
3749         SKIPN   C,1(AB)         ;IF NIL\r
3750         JRST    TF(E)           ;RETURN TRUTH\r
3751         PUSH    TP,$TLIST               ;CREATE UNNAMED TEMP\r
3752         PUSH    TP,C\r
3753 ANDLP:\r
3754         MOVE    E,(P)\r
3755         JUMPE   C,TFI(E)        ;ANY MORE ARGS?\r
3756         MOVEM   C,1(TB)         ;STORE CRUFT\r
3757         GETYP   A,(C)\r
3758         MOVSI   A,(A)\r
3759         PUSH    TP,A\r
3760         PUSH    TP,1(C)         ;ARGUMENT\r
3761         JSP     E,CHKARG\r
3762         MCALL   1,EVAL\r
3763         GETYP   0,A\r
3764         MOVE    E,(P)\r
3765         XCT     TFSKP(E)\r
3766         JRST    FINIS           ;IF FALSE -- RETURN\r
3767         HRRZ    C,@1(TB)        ;GET CDR OF ARGLIST\r
3768         JRST    ANDLP\r
3769 \r
3770 TF:     JRST    IFALSE\r
3771         JRST    TRUTH\r
3772 \r
3773 TFI:    JRST    IFALS1\r
3774         JRST    FINIS\r
3775 \r
3776 TFSKP:  CAIE    0,TFALSE\r
3777         CAIN    0,TFALSE\r
3778 \r
3779 MFUNCTION FUNCTION,FSUBR\r
3780 \r
3781         ENTRY   1\r
3782 \r
3783         MOVSI   A,TEXPR\r
3784         MOVE    B,1(AB)\r
3785         JRST    FINIS\r
3786 \r
3787 \f\r
3788 \r
3789 MFUNCTION CLOSURE,SUBR\r
3790         ENTRY\r
3791         SKIPL   A,AB            ;ANY ARGS\r
3792         JRST    TFA             ;NO -- LOSE\r
3793         ADD     A,[2,,2]        ;POINT AT IDS\r
3794         PUSH    TP,$TAB\r
3795         PUSH    TP,A\r
3796         PUSH    P,[0]           ;MAKE COUNTER\r
3797 \r
3798 CLOLP:  SKIPL   A,1(TB)         ;ANY MORE IDS?\r
3799         JRST    CLODON          ;NO -- LOSE\r
3800         PUSH    TP,(A)          ;SAVE ID\r
3801         PUSH    TP,1(A)\r
3802         PUSH    TP,(A)          ;GET ITS VALUE\r
3803         PUSH    TP,1(A)\r
3804         ADD     A,[2,,2]        ;BUMP POINTER\r
3805         MOVEM   A,1(TB)\r
3806         AOS     (P)\r
3807         MCALL   1,VALUE\r
3808         PUSH    TP,A\r
3809         PUSH    TP,B\r
3810         MCALL   2,LIST          ;MAKE PAIR\r
3811         PUSH    TP,A\r
3812         PUSH    TP,B\r
3813         JRST    CLOLP\r
3814 \r
3815 CLODON: POP     P,A\r
3816         ACALL   A,LIST          ;MAKE UP LIST\r
3817         PUSH    TP,(AB)         ;GET FUNCTION\r
3818         PUSH    TP,1(AB)\r
3819         PUSH    TP,A\r
3820         PUSH    TP,B\r
3821         MCALL   2,LIST          ;MAKE LIST\r
3822         MOVSI   A,TFUNARG\r
3823         JRST    FINIS\r
3824 \r
3825 \f\r
3826 \r
3827 ;ERROR COMMENTS FOR EVAL\r
3828 TUPTFA: PUSH    TP,$TATOM\r
3829         PUSH    TP,EQUOTE TOO-FEW-ARGS-FOR-ITUPLE\r
3830         JRST    CALER1\r
3831 \r
3832 TUPTMA: PUSH    TP,$TATOM\r
3833         PUSH    TP,EQUOTE TOO-MANY-ARGS-TO-ITUPLE\r
3834         JRST    CALER1\r
3835 \r
3836 BADNUM: PUSH    TP,$TATOM\r
3837         PUSH    TP,EQUOTE NEGATIVE-ARG-TO-ITUPLE\r
3838         JRST    CALER1\r
3839 \r
3840 WTY1TP: PUSH    TP,$TATOM\r
3841         PUSH    TP,EQUOTE FIRST-ARG-TO-ITUPLE-NOT-FIX\r
3842         JRST    CALER1\r
3843 \r
3844 UNBOU:  PUSH    TP,$TATOM\r
3845         PUSH    TP,EQUOTE UNBOUND-VARIABLE\r
3846         JRST    ER1ARG\r
3847 \r
3848 UNAS:   PUSH    TP,$TATOM\r
3849         PUSH    TP,EQUOTE UNASSIGNED-VARIABLE\r
3850         JRST    ER1ARG\r
3851 \r
3852 BADENV:\r
3853         PUSH    TP,$TATOM\r
3854         PUSH    TP,EQUOTE BAD-ENVIRONMENT\r
3855         JRST    CALER1\r
3856 \r
3857 FUNERR:\r
3858         PUSH    TP,$TATOM\r
3859         PUSH    TP,EQUOTE BAD-FUNARG\r
3860         JRST    CALER1\r
3861 \r
3862 \r
3863 MPD.0:\r
3864 MPD.1:\r
3865 MPD.2:\r
3866 MPD.3:\r
3867 MPD.4:\r
3868 MPD.5:\r
3869 MPD.6:\r
3870 MPD.7:\r
3871 MPD.8:\r
3872 MPD.9:\r
3873 MPD.10:\r
3874 MPD.11:\r
3875 MPD.12:\r
3876 MPD.13:\r
3877 MPD:    PUSH    TP,$TATOM\r
3878         PUSH    TP,EQUOTE MEANINGLESS-PARAMETER-DECLARATION\r
3879         JRST    CALER1\r
3880 \r
3881 NOBODY: PUSH    TP,$TATOM\r
3882         PUSH    TP,EQUOTE HAS-EMPTY-BODY\r
3883         JRST    CALER1\r
3884 \r
3885 BADCLS: PUSH    TP,$TATOM\r
3886         PUSH    TP,EQUOTE BAD-CLAUSE\r
3887         JRST    CALER1\r
3888 \r
3889 NXTAG:  PUSH    TP,$TATOM\r
3890         PUSH    TP,EQUOTE NON-EXISTENT-TAG\r
3891         JRST    CALER1\r
3892 \r
3893 NXPRG:  PUSH    TP,$TATOM\r
3894         PUSH    TP,EQUOTE NOT-IN-PROG\r
3895         JRST    CALER1\r
3896 \r
3897 NAPTL:\r
3898 NAPT:   PUSH    TP,$TATOM\r
3899         PUSH    TP,EQUOTE NON-APPLICABLE-TYPE\r
3900         JRST    CALER1\r
3901 \r
3902 NONEVT: PUSH    TP,$TATOM\r
3903         PUSH    TP,EQUOTE NON-EVALUATEABLE-TYPE\r
3904         JRST    CALER1\r
3905 \r
3906 \r
3907 NONATM: PUSH    TP,$TATOM\r
3908         PUSH    TP,EQUOTE NON-ATOMIC-ARGUMENT\r
3909         JRST    CALER1\r
3910 \r
3911 \r
3912 ILLFRA: PUSH    TP,$TATOM\r
3913         PUSH    TP,EQUOTE FRAME-NO-LONGER-EXISTS\r
3914         JRST    CALER1\r
3915 \r
3916 ILLSEG: PUSH    TP,$TATOM\r
3917         PUSH    TP,EQUOTE ILLEGAL-SEGMENT\r
3918         JRST    CALER1\r
3919 \r
3920 BADMAC: PUSH    TP,$TATOM\r
3921         PUSH    TP,EQUOTE BAD-USE-OF-MACRO\r
3922         JRST    CALER1\r
3923 \r
3924 BADFSB: PUSH    TP,$TATOM\r
3925         PUSH    TP,EQUOTE APPLY-OR-STACKFORM-OF-FSUBR\r
3926         JRST    CALER1\r
3927 \r
3928 \r
3929 ER1ARG: PUSH    TP,(AB)\r
3930         PUSH    TP,1(AB)\r
3931         MOVEI   A,2\r
3932         JRST    CALER\r
3933 \r
3934 END\r
3935 \f\f\f\f\f