<mdl.int>/eval.mid.122

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