<mdl.int>/eval.mid.123

   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         PUSH    P,PVP
2203         PUSH    P,SP
2204         MOVEI   E,(TP)
2205         PUSHJ   P,STLOOP
2206 SSPEC2: SUBI    E,(SP)          ; MAKE SP BE AOBJN
2207         MOVSI   E,(E)
2208         HLL     SP,TP
2209         SUB     SP,E
2210         MOVEM   SP,SPSTOR+1
2211         POP     P,SP
2212         POP     P,PVP
2213         POP     P,E
2214         POPJ    P,
2215
2216 ; ENTRY FOR FUNNY COMPILER UNBIND (2)
2217
2218 SSPEC1: PUSH    P,E
2219         PUSH    P,PVP
2220         PUSH    P,SP
2221         SUBI    E,1             ; MAKE SURE GET CURRENT BINDING
2222         PUSHJ   P,STLOOP        ; UNBIND
2223         MOVEI   E,(TP)          ; NOW RESET SP
2224         JRST    SSPEC2
2225 \f
2226 EFINIS: MOVE    PVP,PVSTOR+1
2227         SKIPN   C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED
2228         JRST    FINIS
2229         PUSH    TP,$TATOM
2230         PUSH    TP,MQUOTE EVLOUT
2231         PUSH    TP,A                    ;SAVE EVAL RESULTS
2232         PUSH    TP,B
2233         PUSH    TP,[TINFO,,2]   ; FENCE POST
2234         PUSHJ   P,TBTOTP
2235         PUSH    TP,D
2236         PUSHJ   P,MAKINF        ; MAKE ARG BLOCK INFO
2237         PUSH    TP,A
2238         MOVEI   B,-6(TP)
2239         HRLI    B,-4            ; AOBJN TO ARGS BLOCK
2240         PUSH    TP,B
2241         MOVE    PVP,PVSTOR+1
2242         PUSH    TP,1STEPR(PVP)
2243         PUSH    TP,1STEPR+1(PVP)        ; PROCESS DOING THE 1STEPPING
2244         MCALL   2,RESUME
2245         MOVE    A,-3(TP)        ; GET BACK EVAL VALUE
2246         MOVE    B,-2(TP)
2247         JRST    FINIS
2248
2249 1STEPI: PUSH    TP,$TATOM
2250         PUSH    TP,MQUOTE EVLIN
2251         PUSH    TP,$TAB         ; PUSH EVALS ARGGS
2252         PUSH    TP,AB
2253         PUSHJ   P,MAKINF        ; TURN INTO ARGS BLOCK
2254         MOVEM   A,-1(TP)        ; AND CLOBBER
2255         PUSH    TP,[TINFO,,2]   ; FENCE POST 2D TUPLE
2256         PUSHJ   P,TBTOTP
2257         PUSH    TP,D
2258         PUSHJ   P,MAKINF        ; TURN IT INTO ARGS BLOCK
2259         PUSH    TP,A
2260         MOVEI   B,-6(TP)        ; SETUP TUPLE
2261         HRLI    B,-4
2262         PUSH    TP,B
2263         MOVE    PVP,PVSTOR+1
2264         PUSH    TP,1STEPR(PVP)
2265         PUSH    TP,1STEPR+1(PVP)
2266         MCALL   2,RESUME        ; START UP 1STEPERR
2267         SUB     TP,[6,,6]       ; REMOVE CRUD
2268         GETYP   A,A             ; GET 1STEPPERS TYPE
2269         CAIE    A,TDISMI                ; IF DISMISS, STOP 1 STEPPING
2270         JRST    EVALON
2271
2272 ; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN
2273
2274         MOVE    D,PVP
2275         ADD     D,[1STEPR,,1STEPR]      ; POINT TO 1 STEP SLOT
2276         PUSH    TP,$TSP         ; SAVE CURRENT SP
2277         PUSH    TP,SPSTOR+1
2278         PUSH    TP,BNDV
2279         PUSH    TP,D            ; BIND IT
2280         PUSH    TP,$TPVP
2281         PUSH    TP,[0]          ; NO 1 STEPPER UNTIL POPJ
2282         PUSHJ   P,SPECBIND
2283
2284 ; NOW PUSH THE ARGS UP TO RE-CALL EVAL
2285
2286         MOVEI   A,0
2287 EFARGL: JUMPGE  AB,EFCALL
2288         PUSH    TP,(AB)
2289         PUSH    TP,1(AB)
2290         ADD     AB,[2,,2]
2291         AOJA    A,EFARGL
2292
2293 EFCALL: ACALL   A,EVAL          ; NOW DO THE EVAL
2294         MOVE    C,(TP)          ; PRE-UNBIND
2295         MOVE    PVP,PVSTOR+1
2296         MOVEM   C,1STEPR+1(PVP)
2297         MOVE    SP,-4(TP)       ; AVOID THE UNBIND
2298         MOVEM   SP,SPSTOR+1
2299         SUB     TP,[6,,6]       ; AND FLUSH LOSERS
2300         JRST    EFINIS          ; AND TRY TO FINISH UP
2301
2302 MAKINF: HLRZ    A,OTBSAV(TB)    ; TIME IT
2303         HRLI    A,TARGS
2304         POPJ    P,
2305
2306
2307 TBTOTP: MOVEI   D,(TB)          ; COMPUTE REL DIST FROM TP TO TB
2308         SUBI    D,(TP)
2309         POPJ    P,
2310 ; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE
2311 ; D/ LENGTH OF THE TUPLE IN WORDS
2312
2313 MAKTU2: MOVE    D,-1(P)         ; GET LENGTH
2314         ASH     D,1
2315         PUSHJ   P,MAKTUP
2316         PUSH    TP,A
2317         PUSH    TP,B
2318         POPJ    P,
2319
2320 MAKTUP: HRLI    D,TINFO         ; FIRST WORD OF FENCE POST
2321         PUSH    TP,D
2322         HRROI   B,(TP)          ; TOP OF TUPLE
2323         SUBI    B,(D)
2324         TLC     B,-1(D)         ; AOBJN IT
2325         PUSHJ   P,TBTOTP
2326         PUSH    TP,D
2327         HLRZ    A,OTBSAV(TB)    ; TIME IT
2328         HRLI    A,TARGS
2329         POPJ    P,
2330
2331 ; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)
2332
2333 TPALOC: SUBM    M,(P)
2334                                 ;Once here ==>ADDI      A,1     Bug???
2335         HRLI    A,(A)
2336         ADD     TP,A
2337         PUSH    P,A
2338         SKIPL   TP
2339         PUSHJ   P,TPOVFL        ; IN CASE IT LOST
2340         INTGO                   ; TAKE THE GC IF NEC
2341         HRRI    A,2(TP)
2342         SUB     A,(P)
2343         SETZM   -1(A)
2344         HRLI    A,-1(A)
2345         BLT     A,(TP)
2346         SUB     P,[1,,1]
2347         JRST    POPJM
2348
2349
2350 NTPALO: PUSH    TP,[0]
2351         SOJG    0,.-1
2352         POPJ    P,
2353
2354 \f;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
2355
2356 IMFUNCTION VALUE,SUBR
2357         JSP     E,CHKAT
2358         PUSHJ   P,IDVAL
2359         JRST    FINIS
2360
2361 IDVAL:  PUSHJ   P,IDVAL1
2362         CAMN    A,$TUNBOU
2363         JRST    UNBOU
2364         POPJ    P,
2365
2366 IDVAL1: PUSH    TP,A
2367         PUSH    TP,B            ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
2368         PUSHJ   P,ILVAL         ;LOCAL VALUE FINDER
2369         CAME    A,$TUNBOUND     ;IF NOT UNBOUND OR UNASSIGNED
2370         JRST    RIDVAL          ;DONE - CLEAN UP AND RETURN
2371         POP     TP,B            ;GET ARG BACK
2372         POP     TP,A
2373         JRST    IGVAL
2374 RIDVAL: SUB     TP,[2,,2]
2375         POPJ    P,
2376
2377 ;GETS THE LOCAL VALUE OF AN IDENTIFIER
2378
2379 IMFUNCTION LVAL,SUBR
2380         JSP     E,CHKAT
2381         PUSHJ   P,AILVAL
2382         CAME    A,$TUNBOUND
2383         JRST    FINIS
2384         JUMPN   B,UNAS
2385         JRST    UNBOU
2386
2387 ; MAKE AN ATOM UNASSIGNED
2388
2389 MFUNCTION UNASSIGN,SUBR
2390         JSP     E,CHKAT         ; GET ATOM ARG
2391         PUSHJ   P,AILOC
2392 UNASIT: CAMN    A,$TUNBOU       ; IF UNBOUND
2393         JRST    RETATM
2394         MOVSI   A,TUNBOU
2395         MOVEM   A,(B)
2396         SETOM   1(B)            ; MAKE SURE
2397 RETATM: MOVE    B,1(AB)
2398         MOVE    A,(AB)
2399         JRST    FINIS
2400
2401 ; UNASSIGN GLOBALLY
2402
2403 MFUNCTION GUNASSIGN,SUBR
2404         JSP     E,CHKAT2
2405         PUSHJ   P,IGLOC
2406         CAMN    A,$TUNBOU
2407         JRST    RETATM
2408         MOVE    B,1(AB)         ; ATOM BACK
2409         MOVEI   0,(B)
2410         CAIL    0,HIBOT         ; SKIP IF IMPURE
2411         PUSHJ   P,IMPURIFY      ; YES, MAKE IT IMPURE
2412         PUSHJ   P,IGLOC         ; RESTORE LOCATIVE
2413         HRRZ    0,-2(B)         ; SEE IF MANIFEST
2414         GETYP   A,(B)           ; AND CURRENT TYPE
2415         CAIN    0,-1
2416         CAIN    A,TUNBOU
2417         JRST    UNASIT
2418         SKIPE   IGDECL
2419         JRST    UNASIT
2420         MOVE    D,B
2421         JRST    MANILO
2422 \f
2423 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
2424
2425 MFUNCTION LLOC,SUBR
2426         JSP     E,CHKAT
2427         PUSHJ   P,AILOC
2428         CAMN    A,$TUNBOUND
2429         JRST    UNBOU
2430         MOVSI   A,TLOCD
2431         HRR     A,2(B)
2432         JRST    FINIS
2433
2434 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
2435
2436 MFUNCTION BOUND,SUBR,[BOUND?]
2437         JSP     E,CHKAT
2438         PUSHJ   P,AILVAL
2439         CAMN    A,$TUNBOUND
2440         JUMPE   B,IFALSE
2441         JRST    TRUTH
2442
2443 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
2444
2445 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
2446         JSP     E,CHKAT
2447         PUSHJ   P,AILVAL
2448         CAME    A,$TUNBOUND
2449         JRST    TRUTH
2450 ;       JUMPE   B,UNBOU
2451         JRST    IFALSE
2452
2453 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER
2454
2455 IMFUNCTION GVAL,SUBR
2456         JSP     E,CHKAT2
2457         PUSHJ   P,IGVAL
2458         CAMN    A,$TUNBOUND
2459         JRST    UNAS
2460         JRST    FINIS
2461
2462 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
2463
2464 MFUNCTION RGLOC,SUBR
2465
2466         JRST    GLOC
2467
2468 MFUNCTION GLOC,SUBR
2469
2470         JUMPGE  AB,TFA
2471         CAMGE   AB,[-5,,]
2472         JRST    TMA
2473         JSP     E,CHKAT1
2474         MOVEI   E,IGLOC
2475         CAML    AB,[-2,,]
2476         JRST    .+4
2477         GETYP   0,2(AB)
2478         CAIE    0,TFALSE
2479         MOVEI   E,IIGLOC
2480         PUSHJ   P,(E)
2481         CAMN    A,$TUNBOUND
2482         JRST    UNAS
2483         MOVSI   A,TLOCD
2484         HRRZ    0,FSAV(TB)
2485         CAIE    0,GLOC
2486         MOVSI   A,TLOCR
2487         CAIE    0,GLOC
2488         SUB     B,GLOTOP+1
2489         MOVE    C,1(AB)         ; GE ATOM
2490         MOVEI   0,(C)
2491         CAIGE   0,HIBOT         ; SKIP IF PURE ATOM
2492         JRST    FINIS
2493
2494 ; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT
2495
2496         MOVE    B,C             ; ATOM TO B
2497         PUSHJ   P,IMPURIFY
2498         JRST    GLOC            ; AND TRY AGAIN
2499
2500 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
2501
2502 MFUNCTION GASSIG,SUBR,[GASSIGNED?]
2503         JSP     E,CHKAT2
2504         PUSHJ   P,IGVAL
2505         CAMN    A,$TUNBOUND
2506         JRST    IFALSE
2507         JRST    TRUTH
2508
2509 ; TEST FOR GLOBALLY BOUND
2510
2511 MFUNCTION GBOUND,SUBR,[GBOUND?]
2512
2513         JSP     E,CHKAT2
2514         PUSHJ   P,IGLOC
2515         JUMPE   B,IFALSE
2516         JRST    TRUTH
2517
2518 \f
2519
2520 CHKAT2: ENTRY   1
2521 CHKAT1: GETYP   A,(AB)
2522         MOVSI   A,(A)
2523         CAME    A,$TATOM
2524         JRST    NONATM
2525         MOVE    B,1(AB)
2526         JRST    (E)
2527
2528 CHKAT:  HLRE    A,AB            ; - # OF ARGS
2529         ASH     A,-1            ; TO ACTUAL WORDS
2530         JUMPGE  AB,TFA
2531         MOVE    C,SPSTOR+1      ; FOR BINDING LOOKUPS
2532         AOJE    A,CHKAT1        ; ONLY ONE ARG, NO ENVIRONMENT
2533         AOJL    A,TMA           ; TOO MANY
2534         GETYP   A,2(AB)         ; MAKE SURE OF TENV OR TFRAME
2535         CAIE    A,TFRAME
2536         CAIN    A,TENV
2537         JRST    CHKAT3
2538         CAIN    A,TACT          ; FOR PFISTERS LOSSAGE
2539         JRST    CHKAT3
2540         CAIE    A,TPVP          ; OR PROCESS
2541         JRST    WTYP2
2542         MOVE    B,3(AB)         ; GET PROCESS
2543         MOVE    C,SPSTOR+1      ; IN CASE ITS ME
2544         CAME    B,PVSTOR+1      ; SKIP IF DIFFERENT
2545         MOVE    C,SPSTO+1(B)    ; GET ITS SP
2546         JRST    CHKAT1
2547 CHKAT3: MOVEI   B,2(AB)         ; POINT TO FRAME POINTER
2548         PUSHJ   P,CHFRM         ; VALIDITY CHECK
2549         MOVE    B,3(AB)         ; GET TB FROM FRAME
2550         MOVE    C,SPSAV(B)      ; GET ENVIRONMENT POINTER
2551         JRST    CHKAT1
2552
2553 \f
2554 ; SILOC--CALLS ILOC IGNORING SPECIAL CHECKING
2555
2556 SILOC:  JFCL
2557
2558 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER
2559 ; PASSED TO IT IN A AND B.  IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS
2560 ; $TUNBOUND IN A AND 0 IN B, IT IS CALLED BY PUSHJ P,ILOC.
2561
2562 ILOC:   MOVE    C,SPSTOR+1      ; SETUP SEARCH START
2563 AILOC:  SKIPN   (B)             ; ANY KIND OF VALUE AT ALL?
2564         JUMPN   B,FUNPJ
2565         MOVSI   A,TLOCI         ;MAKE A LOCATIVE TYPE CELL
2566         PUSH    P,E
2567         PUSH    P,D
2568         MOVEI   E,0             ; FLAG TO CLOBBER ATOM
2569         JUMPE   B,SCHSP         ; IF LOOKING FOR SLOT, SEARCH NOW
2570         CAME    C,SPSTOR+1      ; ENVIRONMENT CHANGE?
2571         JRST    SCHSP           ; YES, MUST SEARCH
2572         MOVE    PVP,PVSTOR+1
2573         HRR     A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS
2574         CAME    A,(B)           ;IS THERE ONE IN THE VALUE CELL?
2575         JRST    SCHLP           ;NO -- SEARCH THE LOCAL BINDINGS
2576         MOVE    B,1(B)          ;YES -- GET LOCATIVE POINTER
2577         MOVE    C,PVP
2578 ILCPJ:  MOVE    E,SPCCHK
2579         TRNN    E,1             ; SKIP IF DOING SPEC UNSPEC CHECK
2580         JRST    ILOCPJ
2581         HRRZ    E,-2(P)         ; IF IGNORING, IGNORE
2582         HRRZ    E,-1(E)
2583         CAIN    E,SILOC
2584         JRST    ILOCPJ
2585         HLRZ    E,-2(B)
2586         CAIE    E,TUBIND
2587         JRST    ILOCPJ
2588         CAMGE   B,CURFCN+1(PVP)
2589         JRST    SCHLPX
2590         MOVEI   D,-2(B)
2591         HRRZ    SP,SPSTOR+1
2592         CAIG    D,(SP)
2593         CAMGE   B,SPBASE+1(PVP)
2594         JRST    SCHLPX
2595         MOVE    C,PVSTOR+1
2596 ILOCPJ: POP     P,D
2597         POP     P,E
2598         POPJ    P,              ;FROM THE VALUE CELL
2599
2600 SCHLPX: MOVEI   E,1
2601         MOVE    C,SPSTOR+1
2602         MOVE    B,-1(B)
2603         JRST    SCHLP
2604
2605
2606 SCHLP5: SETOM   (P)
2607         JRST    SCHLP2
2608
2609 SCHLP:  MOVEI   D,(B)
2610         CAIL    D,HIBOT         ; SKIP IF IMPURE ATOM
2611 SCHSP:  MOVEI   E,1             ; DONT STORE LOCATIVE
2612
2613         PUSH    P,E             ; PUSH SWITCH
2614         MOVE    E,PVSTOR+1      ; GET PROC
2615 SCHLP1: JUMPE   C,UNPJ          ;IF NO MORE -- LOSE
2616         CAMN    B,1(C)          ;ARE WE POINTING AT THE WINNER?
2617         JRST    SCHFND          ;YES
2618         GETYP   D,(C)           ; CHECK SKIP
2619         CAIE    D,TSKIP
2620         JRST    SCHLP2
2621         PUSH    P,B             ; CHECK DETOUR
2622         MOVEI   B,2(C)
2623         PUSHJ   P,CHFRAM        ; NON-FATAL FRAME CHECKER
2624         HRRZ    E,2(C)          ; CONS UP PROCESS
2625         SUBI    E,PVLNT*2+1
2626         HRLI    E,-2*PVLNT
2627         JUMPE   B,SCHLP3        ; LOSER, FIX IT
2628         POP     P,B
2629         MOVEI   C,1(C)          ; FOLLOW LOOKUP CHAIN
2630 SCHLP2: HRRZ    C,(C)           ;FOLLOW LINK
2631         JRST    SCHLP1
2632
2633 SCHLP3: POP     P,B
2634         HRRZ    SP,SPSTOR+1
2635         MOVEI   C,(SP)          ; *** NDR'S BUG ***
2636         CAME    E,PVSTOR+1      ; USE IF CURRENT PROCESS
2637         HRRZ    C,SPSTO+1(E)    ; USE CURRENT SP FOR PROC
2638         JRST    SCHLP1
2639
2640 SCHFND: MOVE    D,SPCCHK
2641         TRNN    D,1             ; SKIP IF DOING SPEC UNSPEC CHECK
2642         JRST    SCHFN1
2643         HRRZ    D,-2(P)         ; IF IGNORING, IGNORE
2644         HRRZ    D,-1(D)
2645         CAIN    D,SILOC
2646         JRST    ILOCPJ
2647         HLRZ    D,(C)
2648         CAIE    D,TUBIND
2649         JRST    SCHFN1
2650         HRRZ    D,CURFCN+1(PVP)
2651         CAIL    D,(C)
2652         JRST    SCHLP5
2653         HRRZ    SP,SPSTOR+1
2654         HRRZ    D,SPBASE+1(PVP)
2655         CAIL    SP,(C)
2656         CAIL    D,(C)
2657         JRST    SCHLP5
2658
2659 SCHFN1: EXCH    B,C             ;SAVE THE ATOM PTR IN C
2660         MOVEI   B,2(B)          ;MAKE UP THE LOCATIVE
2661         SUB     B,TPBASE+1(E)
2662         HRLI    B,(B)
2663         ADD     B,TPBASE+1(E)
2664         EXCH    C,E             ; RET PROCESS IN C
2665         POP     P,D             ; RESTORE SWITCH
2666
2667         JUMPN   D,ILOCPJ                ; DONT CLOBBER  ATOM
2668         MOVEM   A,(E)           ;CLOBBER IT AWAY INTO THE
2669         MOVE    D,1(E)          ; GET OLD POINTER
2670         MOVEM   B,1(E)          ;ATOM'S VALUE CELL
2671         JUMPE   D,ILOCPJ        ; IF POINTS TO GLOBAL OR OTHER PROCES
2672                                 ;       MAKE SURE BINDING SO INDICATES
2673         MOVE    D,B             ; POINT TO BINDING
2674         SKIPL   E,3(D)          ; GO TO FIRST ONE, JUST IN CASE
2675          JRST   .+3
2676         MOVE    D,E
2677         JRST    .-3             ; LOOP THROUGH
2678         MOVEI   E,1
2679         MOVEM   E,3(D)          ; MAGIC INDICATION
2680         JRST    ILOCPJ
2681
2682 UNPJ:   SUB     P,[1,,1]        ; FLUSH CRUFT
2683 UNPJ1:  MOVE    C,E             ; RET PROCESS ANYWAY
2684 UNPJ11: POP     P,D
2685         POP     P,E
2686 UNPOPJ: MOVSI   A,TUNBOUND
2687         MOVEI   B,0
2688         POPJ    P,
2689
2690 FUNPJ:  MOVE    C,PVSTOR+1
2691         JRST    UNPOPJ
2692
2693 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
2694 ;IDENTIFIER PASSED TO IT IN A AND B.  IF THE IDENTIFIER IS GLOBALLY
2695 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
2696
2697 IGLOC:  MOVSI   A,TLOCI         ;DO WE HAVE A LOCATIVE TO
2698         CAME    A,(B)           ;A PROCESS #0 VALUE?
2699         JRST    SCHGSP          ;NO -- SEARCH
2700         MOVE    B,1(B)          ;YES -- GET VALUE CELL
2701         POPJ    P,
2702
2703 SCHGSP: SKIPN   (B)
2704         JRST    UNPOPJ
2705         MOVE    D,GLOBSP+1      ;GET GLOBAL SP PTR
2706
2707 SCHG1:  JUMPGE  D,UNPOPJ        ;IF NO MORE, LEAVE
2708         CAMN    B,1(D)          ;ARE WE FOUND?
2709         JRST    GLOCFOUND       ;YES
2710         ADD     D,[4,,4]        ;NO -- TRY NEXT
2711         JRST    SCHG1
2712
2713 GLOCFOUND:
2714         EXCH    B,D             ;SAVE ATOM PTR
2715         ADD     B,[2,,2]        ;MAKE LOCATIVE
2716         MOVEI   0,(D)
2717         CAIL    0,HIBOT
2718         POPJ    P,
2719         MOVEM   A,(D)           ;CLOBBER IT AWAY
2720         MOVEM   B,1(D)
2721         POPJ    P,
2722
2723 IIGLOC: PUSH    TP,$TATOM
2724         PUSH    TP,B
2725         PUSHJ   P,IGLOC
2726         MOVE    C,(TP)
2727         SUB     TP,[2,,2]
2728         GETYP   0,A
2729         CAIE    0,TUNBOU
2730         POPJ    P,
2731         PUSH    TP,$TATOM
2732         PUSH    TP,C
2733         MOVEI   0,(C)
2734         MOVE    B,C
2735         CAIL    0,$TLOSE
2736         PUSHJ   P,IMPURI        ; IMPURIFY THE POOR ATOM
2737         PUSHJ   P,BSETG         ; MAKE A SLOT
2738         SETOM   1(B)            ; UNBOUNDIFY IT
2739         MOVSI   A,TLOCD
2740         MOVSI   0,TUNBOU
2741         MOVEM   0,(B)
2742         SUB     TP,[2,,2]
2743         POPJ    P,
2744
2745 \f
2746
2747 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
2748 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
2749 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B.  CALL - PUSHJ P,IVAL
2750
2751 AILVAL:
2752         PUSHJ   P,AILOC ; USE SUPPLIED SP
2753         JRST    CHVAL
2754 ILVAL:
2755         PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
2756 CHVAL:  CAMN    A,$TUNBOUND     ;BOUND
2757         POPJ    P,              ;NO -- RETURN
2758         MOVSI   A,TLOCD         ; GET GOOD TYPE
2759         HRR     A,2(B)          ; SHOULD BE TIME OR 0
2760         PUSH    P,0
2761         PUSHJ   P,RMONC0        ; CHECK READ MONITOR
2762         POP     P,0
2763         MOVE    A,(B)           ;GET THE TYPE OF THE VALUE
2764         MOVE    B,1(B)          ;GET DATUM
2765         POPJ    P,
2766
2767 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
2768
2769 IGVAL:  PUSHJ   P,IGLOC
2770         JRST    CHVAL
2771
2772
2773 \f
2774 ; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET
2775
2776 CILVAL: MOVE    PVP,PVSTOR+1
2777         MOVE    0,BINDID+1(PVP) ; CURRENT BIND
2778         HRLI    0,TLOCI
2779         CAME    0,(B)           ; HURRAY FOR SPEED
2780         JRST    CILVA1          ; TOO BAD
2781         MOVE    C,1(B)          ; POINTER
2782         MOVE    A,(C)           ; VAL TYPE
2783         TLNE    A,.RDMON        ; MONITORS?
2784         JRST    CILVA1
2785         GETYP   0,A
2786         CAIN    0,TUNBOU
2787         JRST    CUNAS           ; COMPILER ERROR
2788         MOVE    B,1(C)          ; GOT VAL
2789         MOVE    0,SPCCHK
2790         TRNN    0,1
2791         POPJ    P,
2792         HLRZ    0,-2(C)         ; SPECIAL CHECK
2793         CAIE    0,TUBIND
2794         POPJ    P,              ; RETURN
2795         MOVE    PVP,PVSTOR+1
2796         CAMGE   C,CURFCN+1(PVP)
2797         JRST    CUNAS
2798         POPJ    P,
2799
2800 CUNAS:
2801 CILVA1: SUBM    M,(P)           ; FIX (P)
2802         PUSH    TP,$TATOM       ; SAVE ATOM
2803         PUSH    TP,B
2804         MCALL   1,LVAL          ; GET ERROR/MONITOR
2805
2806 POPJM:  SUBM    M,(P)           ; REPAIR DAMAGE
2807         POPJ    P,
2808
2809 ; COMPILERS INTERFACE TO SET C/ ATOM  A,B/ NEW VALUE
2810
2811 CISET:  MOVE    PVP,PVSTOR+1
2812         MOVE    0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT
2813         HRLI    0,TLOCI
2814         CAME    0,(C)           ; CAN WE WIN?
2815         JRST    CISET1          ; NO, MORE HAIR
2816         MOVE    D,1(C)          ; POINT TO SLOT
2817 CISET3: HLLZ    0,(D)           ; MON CHECK
2818         TLNE    0,.WRMON
2819         JRST    CISET4          ; YES, LOSE
2820         TLZ     0,TYPMSK
2821         IOR     A,0             ; LEAVE MONITOR ON
2822         MOVE    0,SPCCHK
2823         TRNE    0,1
2824         JRST    CISET5          ; SPEC/UNSPEC CHECK
2825 CISET6: MOVEM   A,(D)           ; STORE
2826         MOVEM   B,1(D)
2827         POPJ    P,
2828
2829 CISET5: HLRZ    0,-2(D)
2830         CAIE    0,TUBIND
2831         JRST    CISET6
2832         MOVE    PVP,PVSTOR+1
2833         CAMGE   D,CURFCN+1(PVP)
2834         JRST    CISET4
2835         JRST    CISET6
2836
2837 CISET1: SUBM    M,(P)           ; FIX ADDR
2838         PUSH    TP,$TATOM       ; SAVE ATOM
2839         PUSH    TP,C
2840         PUSH    TP,A
2841         PUSH    TP,B
2842         MOVE    B,C             ; GET ATOM
2843         PUSHJ   P,ILOC          ; SEARCH
2844         MOVE    D,B             ; POSSIBLE POINTER
2845         GETYP   E,A
2846         MOVE    0,A
2847         MOVE    A,-1(TP)        ; VAL BACK
2848         MOVE    B,(TP)
2849         CAIE    E,TUNBOU        ; SKIP IF WIN
2850         JRST    CISET2          ; GO CLOBBER IT IN
2851         MCALL   2,SET
2852         JRST    POPJM
2853
2854 CISET2: MOVE    C,-2(TP)        ; ATOM BACK
2855         SUBM    M,(P)           ; RESET (P)
2856         SUB     TP,[4,,4]
2857         JRST    CISET3
2858
2859 ; HERE TO DO A MONITORED SET
2860
2861 CISET4: SUBM    M,(P)           ; AGAIN FIX (P)
2862         PUSH    TP,$TATOM
2863         PUSH    TP,C
2864         PUSH    TP,A
2865         PUSH    TP,B
2866         MCALL   2,SET
2867         JRST    POPJM
2868
2869 ; COMPILER LLOC
2870
2871 CLLOC:  MOVE    PVP,PVSTOR+1
2872         MOVE    0,BINDID+1(PVP) ; GET CURRENT LOCATIVE
2873         HRLI    0,TLOCI
2874         CAME    0,(B)           ; WIN?
2875         JRST    CLLOC1
2876         MOVE    B,1(B)
2877         MOVE    0,SPCCHK
2878         TRNE    0,1             ; SKIP IF NOT CHECKING
2879         JRST    CLLOC9
2880 CLLOC3: MOVSI   A,TLOCD
2881         HRR     A,2(B)          ; GET BIND TIME
2882         POPJ    P,
2883
2884 CLLOC1: SUBM    M,(P)
2885         PUSH    TP,$TATOM
2886         PUSH    TP,B
2887         PUSHJ   P,ILOC          ; LOOK IT UP
2888         JUMPE   B,CLLOC2
2889         SUB     TP,[2,,2]
2890 CLLOC4: SUBM    M,(P)
2891         JRST    CLLOC3
2892
2893 CLLOC2: MCALL   1,LLOC
2894         JRST    CLLOC4
2895
2896 CLLOC9: HLRZ    0,-2(B)
2897         CAIE    0,TUBIND
2898         JRST    CLLOC3
2899         MOVE    PVP,PVSTOR+1
2900         CAMGE   B,CURFCN+1(PVP)
2901         JRST    CLLOC2
2902         JRST    CLLOC3
2903
2904 ; COMPILER BOUND?
2905
2906 CBOUND: SUBM    M,(P)
2907         PUSHJ   P,ILOC
2908         JUMPE   B,PJFALS        ; IF UNBOUND RET FALSE AND NO SSKIP
2909 PJT1:   SOS     (P)
2910         MOVSI   A,TATOM
2911         MOVE    B,IMQUOTE T
2912         JRST    POPJM
2913
2914 PJFALS: MOVEI   B,0
2915         MOVSI   A,TFALSE
2916         JRST    POPJM
2917
2918 ; COMPILER ASSIGNED?
2919
2920 CASSQ:  SUBM    M,(P)
2921         PUSHJ   P,ILOC
2922         JUMPE   B,PJFALS
2923         GETYP   0,(B)
2924         CAIE    0,TUNBOU
2925         JRST    PJT1
2926         JRST    PJFALS
2927 \f
2928
2929 ; COMPILER GVAL B/ ATOM
2930
2931 CIGVAL: MOVE    0,(B)           ; GLOBAL VAL HERE?
2932         CAME    0,$TLOCI        ; TIME=0 ,TYPE=TLOCI => GLOB VAL
2933         JRST    CIGVA1          ; NO, GO LOOK
2934         MOVE    C,1(B)          ; POINT TO SLOT
2935         MOVE    A,(C)           ; GET TYPE
2936         TLNE    A,.RDMON
2937         JRST    CIGVA1
2938         GETYP   0,A             ; CHECK FOR UNBOUND
2939         CAIN    0,TUNBOU        ; SKIP IF WINNER
2940         JRST    CGUNAS
2941         MOVE    B,1(C)
2942         POPJ    P,
2943
2944 CGUNAS:
2945 CIGVA1: SUBM    M,(P)
2946         PUSH    TP,$TATOM
2947         PUSH    TP,B
2948         .MCALL  1,GVAL          ; GET ERROR/MONITOR
2949         JRST    POPJM
2950
2951 ; COMPILER INTERFACET TO SETG
2952
2953 CSETG:  MOVE    0,(C)           ; GET V CELL
2954         CAME    0,$TLOCI        ; SKIP IF FAST
2955         JRST    CSETG1
2956         HRRZ    D,1(C)          ; POINT TO SLOT
2957         MOVE    0,(D)           ; OLD VAL
2958 CSETG3: CAIG    D,HIBOT         ; SKIP IF PURE ATOM
2959         TLNE    0,.WRMON        ; MONITOR
2960         JRST    CSETG2
2961         MOVEM   A,(D)
2962         MOVEM   B,1(D)
2963         POPJ    P,
2964
2965 CSETG1: SUBM    M,(P)           ; FIX UP P
2966         PUSH    TP,$TATOM
2967         PUSH    TP,C
2968         PUSH    TP,A
2969         PUSH    TP,B
2970         MOVE    B,C
2971         PUSHJ   P,IGLOC         ; FIND GLOB LOCATIVE
2972         GETYP   E,A
2973         MOVE    0,A
2974         MOVEI   D,(B)           ; SETUP TO RESTORE NEW VAL
2975         MOVE    A,-1(TP)
2976         MOVE    B,(TP)
2977         CAIE    E,TUNBOU
2978         JRST    CSETG4
2979         MCALL   2,SETG
2980         JRST    POPJM
2981
2982 CSETG4: MOVE    C,-2(TP)        ; ATOM BACK
2983         SUBM    M,(P)           ; RESET (P)
2984         SUB     TP,[4,,4]
2985         JRST    CSETG3
2986
2987 CSETG2: SUBM    M,(P)
2988         PUSH    TP,$TATOM               ; CAUSE A SETG MONITOR
2989         PUSH    TP,C
2990         PUSH    TP,A
2991         PUSH    TP,B
2992         MCALL   2,SETG
2993         JRST    POPJM
2994
2995 ; COMPILER GLOC
2996
2997 CGLOC:  MOVE    0,(B)           ; GET CURRENT GUY
2998         CAME    0,$TLOCI        ; WIN?
2999         JRST    CGLOC1          ; NOPE
3000         HRRZ    D,1(B)          ; POINT TO SLOT
3001         CAILE   D,HIBOT         ; PURE?
3002         JRST    CGLOC1
3003         MOVE    A,$TLOCD
3004         MOVE    B,1(B)
3005         POPJ    P,
3006
3007 CGLOC1: SUBM    M,(P)
3008         PUSH    TP,$TATOM
3009         PUSH    TP,B
3010         MCALL   1,GLOC
3011         JRST    POPJM
3012
3013 ; COMPILERS GASSIGNED?
3014
3015 CGASSQ: MOVE    0,(B)
3016         SUBM    M,(P)
3017         CAMN    0,$TLOCD
3018         JRST    PJT1
3019         PUSHJ   P,IGLOC
3020         JUMPE   B,PJFALS
3021         GETYP   0,(B)
3022         CAIE    0,TUNBOU
3023         JRST    PJT1
3024         JRST    PJFALS
3025
3026 ; COMPILERS GBOUND?
3027
3028 CGBOUN: MOVE    0,(B)
3029         SUBM    M,(P)
3030         CAMN    0,$TLOCD
3031         JRST    PJT1
3032         PUSHJ   P,IGLOC
3033         JUMPE   B,PJFALS
3034         JRST    PJT1
3035 \f
3036
3037 IMFUNCTION REP,FSUBR,[REPEAT]
3038         JRST    PROG
3039 MFUNCTION BIND,FSUBR
3040         JRST    PROG
3041 IMFUNCTION PROG,FSUBR
3042         ENTRY   1
3043         GETYP   A,(AB)          ;GET ARG TYPE
3044         CAIE    A,TLIST         ;IS IT A LIST?
3045         JRST    WRONGT          ;WRONG TYPE
3046         SKIPN   C,1(AB)         ;GET AND CHECK ARGUMENT
3047         JRST    TFA             ;TOO FEW ARGS
3048         SETZB   E,D             ; INIT HEWITT ATOM AND DECL
3049         PUSHJ   P,CARATC        ; IS 1ST THING AN ATOM
3050         JFCL
3051         PUSHJ   P,RSATY1        ; CDR AND GET TYPE
3052         CAIE    0,TLIST         ; MUST BE LIST
3053         JRST    MPD.13
3054         MOVE    B,1(C)          ; GET ARG LIST
3055         PUSH    TP,$TLIST
3056         PUSH    TP,C
3057         PUSHJ   P,RSATYP
3058         CAIE    0,TDECL
3059         JRST    NOP.DC          ; JUMP IF NO DCL
3060         MOVE    D,1(C)
3061         MOVEM   C,(TP)
3062         PUSHJ   P,RSATYP        ; CDR ON
3063 NOP.DC: PUSH    TP,$TLIST
3064         PUSH    TP,B            ; AND ARG LIST
3065         PUSHJ   P,PRGBND        ; BIND AUX VARS
3066         HRRZ    E,FSAV(TB)
3067         CAIE    E,BIND
3068         SKIPA   E,IMQUOTE LPROG,[LPROG ]INTRUP
3069         JRST    .+3
3070         PUSHJ   P,MAKACT        ; MAKE ACTIVATION
3071         PUSHJ   P,PSHBND        ; BIND AND CHECK
3072         PUSHJ   P,SPECBI        ; NAD BIND IT
3073
3074 ; HERE TO RUN PROGS FUNCTIONS ETC.
3075
3076 DOPROG: MOVEI   A,REPROG
3077         HRLI    A,TDCLI         ; FLAG AS FUNNY
3078         MOVEM   A,(TB)          ; WHERE TO AGAIN TO
3079         MOVE    C,1(TB)
3080         MOVEM   C,3(TB)         ; RESTART POINTER
3081         JRST    .+2             ; START BY SKIPPING DECL
3082
3083 DOPRG1: PUSHJ   P,FASTEV
3084         HRRZ    C,@1(TB)        ;GET THE REST OF THE BODY
3085 DOPRG2: MOVEM   C,1(TB)
3086         JUMPN   C,DOPRG1
3087 ENDPROG:
3088         HRRZ    C,FSAV(TB)
3089         CAIN    C,REP
3090 REPROG: SKIPN   C,@3(TB)
3091         JRST    PFINIS
3092         HRRZM   C,1(TB)
3093         INTGO
3094         MOVE    C,1(TB)
3095         JRST    DOPRG1
3096
3097
3098 PFINIS: GETYP   0,(TB)
3099         CAIE    0,TDCLI         ; DECL'D ?
3100         JRST    PFINI1
3101         HRRZ    0,(TB)          ; SEE IF RSUBR
3102         JUMPE   0,RSBVCK        ; CHECK RSUBR VALUE
3103         HRRZ    C,3(TB)         ; GET START OF FCN
3104         GETYP   0,(C)           ; CHECK FOR DECL
3105         CAIE    0,TDECL
3106         JRST    PFINI1          ; NO, JUST RETURN
3107         MOVE    E,IMQUOTE VALUE
3108         PUSHJ   P,PSHBND        ; BUILD FAKE BINDING
3109         MOVE    C,1(C)          ; GET DECL LIST
3110         MOVE    E,TP
3111         PUSHJ   P,CHKDCL        ; AND CHECK IT
3112         MOVE    A,-3(TP)                ; GET VAL BAKC
3113         MOVE    B,-2(TP)
3114         SUB     TP,[6,,6]
3115
3116 PFINI1: HRRZ    C,FSAV(TB)
3117         CAIE    C,EVAL
3118         JRST    FINIS
3119         JRST    EFINIS
3120
3121 RSATYP: HRRZ    C,(C)
3122 RSATY1: JUMPE   C,TFA
3123         GETYP   0,(C)
3124         POPJ    P,
3125
3126 ; HERE TO CHECK RSUBR VALUE
3127
3128 RSBVCK: PUSH    TP,A
3129         PUSH    TP,B
3130         MOVE    C,A
3131         MOVE    D,B
3132         MOVE    A,1(TB)         ; GET DECL
3133         MOVE    B,1(A)
3134         HLLZ    A,(A)
3135         PUSHJ   P,TMATCH
3136         JRST    RSBVC1
3137         POP     TP,B
3138         POP     TP,A
3139         POPJ    P,
3140
3141 RSBVC1: MOVE    C,1(TB)
3142         POP     TP,B
3143         POP     TP,D
3144         MOVE    A,IMQUOTE VALUE
3145         JRST    TYPMIS
3146 \f
3147
3148 MFUNCTION MRETUR,SUBR,[RETURN]
3149         ENTRY
3150         HLRE    A,AB            ; GET # OF ARGS
3151         ASH     A,-1            ; TO NUMBER
3152         AOJL    A,RET2          ; 2 OR MORE ARGS
3153         PUSHJ   P,PROGCH        ;CHECK IN A PROG
3154         PUSH    TP,A
3155         PUSH    TP,B
3156         MOVEI   B,-1(TP)        ; VERIFY IT
3157 COMRET: PUSHJ   P,CHFSWP
3158         SKIPL   C               ; ARGS?
3159         MOVEI   C,0             ; REAL NONE
3160         PUSHJ   P,CHUNW
3161         JUMPN   A,CHFINI        ; WINNER
3162         MOVSI   A,TATOM
3163         MOVE    B,IMQUOTE T
3164
3165 ; SEE IF MUST  CHECK RETURNS TYPE
3166
3167 CHFINI: GETYP   0,(TB)          ; SPECIAL TYPE IF SO
3168         CAIE    0,TDCLI
3169         JRST    FINIS           ; NO, JUST FINIS
3170         MOVEI   0,PFINIS        ; CAUSE TO FALL INTO FUNCTION CODE
3171         HRRM    0,PCSAV(TB)
3172         JRST    CONTIN
3173
3174
3175 RET2:   AOJL    A,TMA
3176         GETYP   A,(AB)+2
3177         CAIE    A,TACT          ; AS FOR "EXIT" SHOULD BE ACTIVATION
3178         JRST    WTYP2
3179         MOVEI   B,(AB)+2        ; ADDRESS OF FRAME POINTER
3180         JRST    COMRET
3181
3182
3183
3184 MFUNCTION AGAIN,SUBR
3185         ENTRY
3186         HLRZ    A,AB            ;GET # OF ARGS
3187         CAIN    A,-2            ;1 ARG?
3188         JRST    NLCLA           ;YES
3189         JUMPN   A,TMA           ;0 ARGS?
3190         PUSHJ   P,PROGCH        ;CHECK FOR IN A PROG
3191         PUSH    TP,A
3192         PUSH    TP,B
3193         JRST    AGAD
3194 NLCLA:  GETYP   A,(AB)
3195         CAIE    A,TACT
3196         JRST    WTYP1
3197         PUSH    TP,(AB)
3198         PUSH    TP,1(AB)
3199 AGAD:   MOVEI   B,-1(TP)        ; POINT TO FRAME
3200         PUSHJ   P,CHFSWP
3201         HRRZ    C,(B)           ; GET RET POINT
3202 GOJOIN: PUSH    TP,$TFIX
3203         PUSH    TP,C
3204         MOVEI   C,-1(TP)
3205         PUSHJ   P,CHUNW         ; RESTORE FRAME, UNWIND IF NEC.
3206         HRRM    B,PCSAV(TB)
3207         HRRZ    0,FSAV(TB)      ; CHECK FOR RSUBR
3208         CAIGE   0,HIBOT
3209         CAIGE   0,STOSTR
3210         JRST    CONTIN
3211         HRRZ    E,1(TB)
3212         PUSH    TP,$TFIX
3213         PUSH    TP,B
3214         MOVEI   C,-1(TP)
3215         MOVEI   B,(TB)
3216         PUSHJ   P,CHUNW1
3217         MOVE    TP,1(TB)
3218         MOVE    SP,SPSTOR+1
3219         MOVEM   SP,SPSAV(TB)
3220         MOVEM   TP,TPSAV(TB)
3221         MOVE    C,OTBSAV(TB)    ; AND RESTORE P FROM FATHER
3222         MOVE    P,PSAV(C)
3223         MOVEM   P,PSAV(TB)
3224         SKIPGE  PCSAV(TB)
3225         HRLI    B,400000+M
3226         MOVEM   B,PCSAV(TB)
3227         JRST    CONTIN
3228
3229 MFUNCTION GO,SUBR
3230         ENTRY   1
3231         GETYP   A,(AB)
3232         CAIE    A,TATOM
3233         JRST    NLCLGO
3234         PUSHJ   P,PROGCH        ;CHECK FOR A PROG
3235         PUSH    TP,A            ;SAVE
3236         PUSH    TP,B
3237         MOVEI   B,-1(TP)
3238         PUSHJ   P,CHFSWP
3239         PUSH    TP,$TATOM
3240         PUSH    TP,1(C)
3241         PUSH    TP,2(B)
3242         PUSH    TP,3(B)
3243         MCALL   2,MEMQ          ;DOES IT HAVE THIS TAG?
3244         JUMPE   B,NXTAG         ;NO -- ERROR
3245 FNDGO:  EXCH    B,(TP)          ;SAVE PLACE TO GO
3246         MOVSI   D,TLIST
3247         MOVEM   D,-1(TP)
3248         JRST    GODON
3249
3250 NLCLGO: CAIE    A,TTAG          ;CHECK TYPE
3251         JRST    WTYP1
3252         MOVE    B,1(AB)
3253         MOVEI   B,2(B)          ; POINT TO SLOT
3254         PUSHJ   P,CHFSWP
3255         MOVE    A,1(C)
3256         GETYP   0,(A)           ; SEE IF COMPILED
3257         CAIE    0,TFIX
3258         JRST    GODON1
3259         MOVE    C,1(A)
3260         JRST    GOJOIN
3261
3262 GODON1: PUSH    TP,(A)          ;SAVE BODY
3263         PUSH    TP,1(A)
3264 GODON:  MOVEI   C,0
3265         PUSHJ   P,CHUNW         ;GO BACK TO CORRECT FRAME
3266         MOVE    B,(TP)          ;RESTORE ITERATION MARKER
3267         MOVEM   B,1(TB)
3268         MOVSI   A,TATOM
3269         MOVE    B,1(B)
3270         JRST    CONTIN
3271
3272 \f
3273
3274
3275 MFUNCTION TAG,SUBR
3276         ENTRY
3277         JUMPGE  AB,TFA
3278         HLRZ    0,AB
3279         GETYP   A,(AB)          ;GET TYPE OF ARGUMENT
3280         CAIE    A,TFIX          ; FIX ==> COMPILED
3281         JRST    ATOTAG
3282         CAIE    0,-4
3283         JRST    WNA
3284         GETYP   A,2(AB)
3285         CAIE    A,TACT
3286         JRST    WTYP2
3287         PUSH    TP,(AB)
3288         PUSH    TP,1(AB)
3289         PUSH    TP,2(AB)
3290         PUSH    TP,3(AB)
3291         JRST    GENTV
3292 ATOTAG: CAIE    A,TATOM         ;CHECK THAT IT IS AN ATOM
3293         JRST    WTYP1
3294         CAIE    0,-2
3295         JRST    TMA
3296         PUSHJ   P,PROGCH        ;CHECK PROG
3297         PUSH    TP,A            ;SAVE VAL
3298         PUSH    TP,B
3299         PUSH    TP,$TATOM
3300         PUSH    TP,1(AB)
3301         PUSH    TP,2(B)
3302         PUSH    TP,3(B)
3303         MCALL   2,MEMQ
3304         JUMPE   B,NXTAG         ;IF NOT FOUND -- ERROR
3305         EXCH    A,-1(TP)        ;SAVE PLACE
3306         EXCH    B,(TP)
3307         HRLI    A,TFRAME
3308         PUSH    TP,A
3309         PUSH    TP,B
3310 GENTV:  MOVEI   A,2
3311         PUSHJ   P,IEVECT
3312         MOVSI   A,TTAG
3313         JRST    FINIS
3314
3315 PROGCH: MOVE    B,IMQUOTE LPROG,[LPROG ]INTRUP
3316         PUSHJ   P,ILVAL         ;GET VALUE
3317         GETYP   0,A
3318         CAIE    0,TACT
3319         JRST    NXPRG
3320         POPJ    P,
3321
3322 ; HERE TO UNASSIGN LPROG IF NEC
3323
3324 UNPROG: MOVE    B,IMQUOTE LPROG,[LPROG ]INTRUP
3325         PUSHJ   P,ILVAL
3326         GETYP   0,A
3327         CAIE    0,TACT          ; SKIP IF MUST UNBIND
3328         JRST    UNMAP
3329         MOVSI   A,TUNBOU
3330         MOVNI   B,1
3331         MOVE    E,IMQUOTE LPROG,[LPROG ]INTRUP
3332         PUSHJ   P,PSHBND
3333 UNMAP:  HRRZ    0,FSAV(TB)      ; CHECK FOR FUNNY
3334         CAIN    0,MAPPLY        ; SKIP IF NOT
3335         POPJ    P,
3336         MOVE    B,IMQUOTE LMAP,[LMAP ]INTRUP
3337         PUSHJ   P,ILVAL
3338         GETYP   0,A
3339         CAIE    0,TFRAME
3340         JRST    UNSPEC
3341         MOVSI   A,TUNBOU
3342         MOVNI   B,1
3343         MOVE    E,IMQUOTE LMAP,[LMAP ]INTRUP
3344         PUSHJ   P,PSHBND
3345 UNSPEC: PUSH    TP,BNDV
3346         MOVE    B,PVSTOR+1
3347         ADD     B,[CURFCN,,CURFCN]
3348         PUSH    TP,B
3349         PUSH    TP,$TSP
3350         MOVE    E,SPSTOR+1
3351         ADD     E,[3,,3]
3352         PUSH    TP,E
3353         POPJ    P,
3354
3355 REPEAT 0,[
3356 MFUNCTION MEXIT,SUBR,[EXIT]
3357         ENTRY   2
3358         GETYP   A,(AB)
3359         CAIE    A,TACT
3360         JRST    WTYP1
3361         MOVEI   B,(AB)
3362         PUSHJ   P,CHFSWP
3363         ADD     C,[2,,2]
3364         PUSHJ   P,CHUNW         ;RESTORE FRAME
3365         JRST    CHFINI          ; CHECK FOR WINNING VALUE
3366 ]
3367
3368 MFUNCTION COND,FSUBR
3369         ENTRY   1
3370         GETYP   A,(AB)
3371         CAIE    A,TLIST
3372         JRST    WRONGT
3373         PUSH    TP,(AB)
3374         PUSH    TP,1(AB)                ;CREATE UNNAMED TEMP
3375         MOVEI   B,0             ; SET TO FALSE IN CASE
3376
3377 CLSLUP: SKIPN   C,1(TB)         ;IS THE CLAUSELIST NIL?
3378         JRST    IFALS1          ;YES -- RETURN NIL
3379         GETYP   A,(C)           ;NO -- GET TYPE OF CAR
3380         CAIE    A,TLIST         ;IS IT A LIST?
3381         JRST    BADCLS          ;
3382         MOVE    A,1(C)          ;YES -- GET CLAUSE
3383         JUMPE   A,BADCLS
3384         GETYPF  B,(A)
3385         PUSH    TP,B            ; EVALUATION OF
3386         HLLZS   (TP)
3387         PUSH    TP,1(A)         ;THE PREDICATE
3388         JSP     E,CHKARG
3389         MCALL   1,EVAL
3390         GETYP   0,A
3391         CAIN    0,TFALSE
3392         JRST    NXTCLS          ;FALSE TRY NEXT CLAUSE
3393         MOVE    C,1(TB)         ;IF NOT, DO FIRST CLAUSE
3394         MOVE    C,1(C)
3395         HRRZ    C,(C)
3396         JUMPE   C,FINIS         ;(UNLESS DONE WITH IT)
3397         JRST    DOPRG2          ;AS THOUGH IT WERE A PROG
3398 NXTCLS: HRRZ    C,@1(TB)        ;SET THE CLAUSLIST
3399         HRRZM   C,1(TB)         ;TO CDR OF THE CLAUSLIST
3400         JRST    CLSLUP
3401
3402 IFALSE:
3403         MOVEI   B,0
3404 IFALS1: MOVSI   A,TFALSE        ;RETURN FALSE
3405         JRST    FINIS
3406
3407
3408 \f
3409 MFUNCTION UNWIND,FSUBR
3410
3411         ENTRY   1
3412
3413         GETYP   0,(AB)          ; CHECK THE ARGS FOR WINNAGE
3414         SKIPN   A,1(AB)         ; NONE?
3415         JRST    TFA
3416         HRRZ    B,(A)           ; CHECK FOR 2D
3417         JUMPE   B,TFA
3418         HRRZ    0,(B)           ; 3D?
3419         JUMPN   0,TMA
3420
3421 ; Unbind LPROG and LMAPF so that nothing cute happens
3422
3423         PUSHJ   P,UNPROG
3424
3425 ; Push thing to do upon UNWINDing
3426
3427         PUSH    TP,$TLIST
3428         PUSH    TP,[0]
3429
3430         MOVEI   C,UNWIN1
3431         PUSHJ   P,IUNWIN        ; GOT TO INTERNAL SET UP
3432
3433 ; Now EVAL the first form
3434
3435         MOVE    A,1(AB)
3436         HRRZ    0,(A)           ; SAVE POINTER TO OTHER GUY
3437         MOVEM   0,-12(TP)
3438         MOVE    B,1(A)
3439         GETYP   A,(A)
3440         MOVSI   A,(A)
3441         JSP     E,CHKAB         ; DEFER?
3442         PUSH    TP,A
3443         PUSH    TP,B
3444         MCALL   1,EVAL          ; EVAL THE LOSER
3445
3446         JRST    FINIS
3447
3448 ; Now push slots to hold undo info on the way down
3449
3450 IUNWIN: JUMPE   M,NOUNRE
3451         HLRE    0,M             ; CHECK BOUNDS
3452         SUBM    M,0
3453         ANDI    0,-1
3454         CAIL    C,(M)
3455         CAML    C,0
3456         JRST    .+2
3457         SUBI    C,(M)
3458
3459 NOUNRE: PUSH    TP,$TTB         ; DESTINATION FRAME
3460         PUSH    TP,[0]
3461         PUSH    TP,[0]          ; ARGS TO WHOEVER IS DOING IT
3462         PUSH    TP,[0]
3463
3464 ; Now bind UNWIND word
3465
3466         PUSH    TP,$TUNWIN      ; FIRST WORD OF IT
3467         MOVE    SP,SPSTOR+1
3468         HRRM    SP,(TP)         ; CHAIN
3469         MOVEM   TP,SPSTOR+1
3470         PUSH    TP,TB           ; AND POINT TO HERE
3471         PUSH    TP,$TTP
3472         PUSH    TP,[0]
3473         HRLI    C,TPDL
3474         PUSH    TP,C
3475         PUSH    TP,P            ; SAVE PDL ALSO
3476         MOVEM   TP,-2(TP)       ; SAVE FOR LATER
3477         POPJ    P,
3478
3479 ; Do a non-local return with UNWIND checking
3480
3481 CHUNW:  HRRZ    E,SPSAV(B)      ; GET DESTINATION FRAME
3482 CHUNW1: PUSH    TP,(C)          ; FINAL VAL
3483         PUSH    TP,1(C)
3484         JUMPN   C,.+3           ; WAS THERE REALLY ANYTHING
3485         SETZM   (TP)
3486         SETZM   -1(TP)
3487         PUSHJ   P,STLOOP        ; UNBIND
3488 CHUNPC: SKIPA                   ; WILL NOT SKIP UNLESS UNWIND FOUND
3489         JRST    GOTUND
3490         MOVEI   A,(TP)
3491         SUBI    A,(SP)
3492         MOVSI   A,(A)
3493         HLL     SP,TP
3494         SUB     SP,A
3495         MOVEM   SP,SPSTOR+1
3496         HRRI    TB,(B)          ; UPDATE TB
3497         PUSHJ   P,UNWFRMS
3498         POP     TP,B
3499         POP     TP,A
3500         POPJ    P,
3501
3502 POPUNW: MOVE    SP,SPSTOR+1
3503         HRRZ    SP,(SP)
3504         MOVEI   E,(TP)
3505         SUBI    E,(SP)
3506         MOVSI   E,(E)
3507         HLL     SP,TP
3508         SUB     SP,E
3509         MOVEM   SP,SPSTOR+1
3510         POPJ    P,
3511
3512
3513 UNWFRM: JUMPE   FRM,CPOPJ
3514         MOVE    B,FRM
3515 UNWFR2: JUMPE   B,UNWFR1
3516         CAMG    B,TPSAV(TB)
3517         JRST    UNWFR1
3518         MOVE    B,(B)
3519         JRST    UNWFR2
3520
3521 UNWFR1: MOVE    FRM,B
3522         POPJ    P,
3523
3524 ; Here if an UNDO found
3525
3526 GOTUND: MOVE    TB,1(SP)        ; GET FRAME OF UNDO
3527         MOVE    A,-1(TP)        ; GET FUNNY ARG FOR PASS ON
3528         MOVE    C,(TP)
3529         MOVE    TP,3(SP)        ; GET FUTURE TP
3530         MOVEM   C,-6(TP)        ; SAVE ARG
3531         MOVEM   A,-7(TP)
3532         MOVE    C,(TP)          ; SAVED P
3533         SUB     C,[1,,1]
3534         MOVEM   C,PSAV(TB)      ; MAKE CONTIN WIN
3535         MOVEM   TP,TPSAV(TB)
3536         MOVEM   SP,SPSAV(TB)
3537         HRRZ    C,(P)           ; PC OF CHUNW CALLER
3538         HRRM    C,-11(TP)       ; SAVE ALSO AND GET WHERE TO GO PC
3539         MOVEM   B,-10(TP)       ; AND DESTINATION FRAME
3540         HRRZ    C,-1(TP)                ; WHERE TO UNWIND PC
3541         HRRZ    0,FSAV(TB)      ; RSUBR?
3542         CAIGE   0,HIBOT
3543         CAIGE   0,STOSTR
3544         JRST    .+3
3545         SKIPGE  PCSAV(TB)
3546         HRLI    C,400000+M
3547         MOVEM   C,PCSAV(TB)
3548         JRST    CONTIN
3549
3550 UNWIN1: MOVE    B,-12(TP)       ; POINT TO THING TO DO UNWINDING
3551         GETYP   A,(B)
3552         MOVSI   A,(A)
3553         MOVE    B,1(B)
3554         JSP     E,CHKAB
3555         PUSH    TP,A
3556         PUSH    TP,B
3557         MCALL   1,EVAL
3558 UNWIN2: MOVEI   C,-7(TP)        ; POINT TO SAVED RET VALS
3559         MOVE    B,-10(TP)
3560         HRRZ    E,-11(TP)
3561         PUSH    P,E
3562         MOVE    SP,SPSTOR+1
3563         HRRZ    SP,(SP)         ; UNBIND THIS GUY
3564         MOVEI   E,(TP)          ; AND FIXUP SP
3565         SUBI    E,(SP)
3566         MOVSI   E,(E)
3567         HLL     SP,TP
3568         SUB     SP,E
3569         MOVEM   SP,SPSTOR+1
3570         JRST    CHUNW           ; ANY MORE TO UNWIND?
3571
3572 \f
3573 ; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.
3574 ; CALLED BY ALL CONTROL FLOW
3575 ; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)
3576
3577 CHFSWP: PUSHJ   P,CHFRM         ; CHECK FOR VALID FRAME
3578         HRRZ    D,(B)           ; PROCESS VECTOR DOPE WD
3579         HLRZ    C,(D)           ; LENGTH
3580         SUBI    D,-1(C)         ; POINT TO TOP
3581         MOVNS   C               ; NEGATE COUNT
3582         HRLI    D,2(C)          ; BUILD PVP
3583         MOVE    E,PVSTOR+1
3584         MOVE    C,AB
3585         MOVE    A,(B)           ; GET FRAME
3586         MOVE    B,1(B)
3587         CAMN    E,D             ; SKIP IF SWAP NEEDED
3588         POPJ    P,
3589         PUSH    TP,A            ; SAVE FRAME
3590         PUSH    TP,B
3591         MOVE    B,D
3592         PUSHJ   P,PROCHK        ; FIX UP PROCESS LISTS
3593         MOVE    A,PSTAT+1(B)    ; GET STATE
3594         CAIE    A,RESMBL
3595         JRST    NOTRES
3596         MOVE    D,B             ; PREPARE TO SWAP
3597         POP     P,0             ; RET ADDR
3598         POP     TP,B
3599         POP     TP,A
3600         JSP     C,SWAP          ; SWAP IN
3601         MOVE    C,ABSTO+1(E)    ; GET OLD ARRGS
3602         MOVEI   A,RUNING        ; FIX STATES
3603         MOVE    PVP,PVSTOR+1
3604         MOVEM   A,PSTAT+1(PVP)
3605         MOVEI   A,RESMBL
3606         MOVEM   A,PSTAT+1(E)
3607         JRST    @0
3608
3609 NOTRES: ERRUUO  EQUOTE PROCESS-NOT-RESUMABLE
3610 \f
3611
3612 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
3613 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT.  ITS VALUE IS
3614 ; ITS SECOND ARGUMENT.
3615
3616 IMFUNCTION SETG,SUBR
3617         ENTRY   2
3618         GETYP   A,(AB)          ;GET TYPE OF FIRST ARGUMENT
3619         CAIE    A,TATOM ;CHECK THAT IT IS AN ATOM
3620         JRST    NONATM          ;IF NOT -- ERROR
3621         MOVE    B,1(AB)         ;GET POINTER TO ATOM
3622         PUSH    TP,$TATOM
3623         PUSH    TP,B
3624         MOVEI   0,(B)
3625         CAIL    0,HIBOT         ; PURE ATOM?
3626         PUSHJ   P,IMPURIFY      ; YES IMPURIFY
3627         PUSHJ   P,IGLOC         ;GET LOCATIVE TO VALUE
3628         CAMN    A,$TUNBOUND     ;IF BOUND
3629         PUSHJ   P,BSETG         ;IF NOT -- BIND IT
3630         MOVE    C,2(AB)         ; GET PROPOSED VVAL
3631         MOVE    D,3(AB)
3632         MOVSI   A,TLOCD         ; MAKE SURE MONCH WINS
3633         PUSHJ   P,MONCH0        ; WOULD YOU BELIEVE MONITORS!!!!
3634         EXCH    D,B             ;SAVE PTR
3635         MOVE    A,C
3636         HRRZ    E,-2(D)         ; POINT TO POSSIBLE GDECL (OR MAINIFEST)
3637         JUMPE   E,OKSETG        ; NONE ,OK
3638         CAIE    E,-1            ; MANIFEST?
3639         JRST    SETGTY
3640         GETYP   0,(D)           ; IF UNBOUND, LET IT HAPPEN
3641         SKIPN   IGDECL
3642         CAIN    0,TUNBOU
3643         JRST    OKSETG
3644 MANILO: GETYP   C,(D)
3645         GETYP   0,2(AB)
3646         CAIN    0,(C)
3647         CAME    B,1(D)
3648         JRST    .+2
3649         JRST    OKSETG
3650         PUSH    TP,$TVEC
3651         PUSH    TP,D
3652         MOVE    B,IMQUOTE REDEFINE
3653         PUSHJ   P,ILVAL         ; SEE IF REDEFINE OK
3654         GETYP   A,A
3655         CAIE    A,TUNBOU
3656         CAIN    A,TFALSE
3657         JRST    .+2
3658         JRST    OKSTG
3659         PUSH    TP,$TATOM
3660         PUSH    TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE
3661         PUSH    TP,$TATOM
3662         PUSH    TP,1(AB)
3663         MOVEI   A,2
3664         JRST    CALER
3665
3666 SETGTY: PUSH    TP,$TVEC
3667         PUSH    TP,D
3668         MOVE    C,A
3669         MOVE    D,B
3670         GETYP   A,(E)
3671         MOVSI   A,(A)
3672         MOVE    B,1(E)
3673         JSP     E,CHKAB
3674         PUSHJ   P,TMATCH
3675         JRST    TYPMI3
3676
3677 OKSTG:  MOVE    D,(TP)
3678         MOVE    A,2(AB)
3679         MOVE    B,3(AB)
3680
3681 OKSETG: MOVEM   A,(D)           ;DEPOSIT INTO THE
3682         MOVEM   B,1(D)          ;INDICATED VALUE CELL
3683         JRST    FINIS
3684
3685 TYPMI3: MOVE    C,(TP)
3686         HRRZ    C,-2(C)
3687         MOVE    D,2(AB)
3688         MOVE    B,3(AB)
3689         MOVE    0,(AB)
3690         MOVE    A,1(AB)
3691         JRST    TYPMIS
3692
3693 BSETG:  HRRZ    A,GLOBASE+1
3694         HRRZ    B,GLOBSP+1
3695         SUB     B,A
3696         CAIL    B,6
3697         JRST    SETGIT
3698         MOVEI   B,0             ; MAKE SURE OF NO EMPTY SLOTS
3699         PUSHJ   P,IGLOC
3700         CAMN    A,$TUNBOU       ; SKIP IF SLOT FOUND
3701         JRST    BSETG1
3702         MOVE    C,(TP)          ; GET ATOM
3703         MOVEM   C,-1(B)         ; CLOBBER ATOM SLOT
3704         HLLZS   -2(B)           ; CLOBBER OLD DECL
3705         JRST    BSETGX
3706 ; BSETG1:       PUSH    TP,GLOBASE      ; MUST REALLY GROW STACK
3707 ;       PUSH    TP,GLOBASE+1
3708 ;       PUSH    TP,$TFIX
3709 ;       PUSH    TP,[0]
3710 ;       PUSH    TP,$TFIX
3711 ;       PUSH    TP,[100]
3712 ;       MCALL   3,GROW
3713 BSETG1: PUSH    P,0
3714         PUSH    P,C
3715         MOVE    C,GLOBASE+1
3716         HLRE    B,C
3717         SUB     C,B
3718         MOVE    B,GVLINC        ; GROW BY INDICATED GVAL SLOTS
3719         DPB     B,[001100,,(C)]
3720 ;       MOVEM   A,GLOBASE
3721         MOVE    C,[6,,4]                ; INDICATOR FOR AGC
3722         PUSHJ   P,AGC
3723         MOVE    B,GLOBASE+1
3724         MOVE    0,GVLINC        ; ADJUST GLOBAL SPBASE
3725         ASH     0,6
3726         SUB     B,0
3727         HRLZS   0
3728         SUB     B,0
3729         MOVEM   B,GLOBASE+1
3730 ;       MOVEM   B,GLOBASE+1
3731         POP     P,0
3732         POP     P,C
3733 SETGIT:
3734         MOVE    B,GLOBSP+1
3735         SUB     B,[4,,4]
3736         MOVSI   C,TGATOM
3737         MOVEM   C,(B)
3738         MOVE    C,(TP)
3739         MOVEM   C,1(B)
3740         MOVEM   B,GLOBSP+1
3741         ADD     B,[2,,2]
3742 BSETGX: MOVSI   A,TLOCI
3743         PUSHJ   P,PATSCH                ; FIXUP SCHLPAGE
3744         MOVEM   A,(C)
3745         MOVEM   B,1(C)
3746         POPJ    P,
3747
3748 PATSCH: GETYP   0,(C)
3749         CAIN    0,TLOCI
3750         SKIPL   D,1(C)
3751         POPJ    P,
3752
3753 PATL:   SKIPL   E,3(D)          ; SKIP IF NEXT EXISTS
3754         JRST    PATL1
3755         MOVE    D,E
3756         JRST    PATL
3757
3758 PATL1:  MOVEI   E,1
3759         MOVEM   E,3(D)          ; SAY GVAL ETC. EXISTS IF WE UNBIND
3760         POPJ    P,
3761
3762
3763 IMFUNCTION DEFMAC,FSUBR
3764
3765         ENTRY   1
3766
3767         PUSH    P,.
3768         JRST    DFNE2
3769
3770 IMFUNCTION DFNE,FSUBR,[DEFINE]
3771
3772         ENTRY   1
3773
3774         PUSH    P,[0]
3775 DFNE2:  GETYP   A,(AB)
3776         CAIE    A,TLIST
3777         JRST    WRONGT
3778         SKIPN   B,1(AB)         ; GET ATOM
3779         JRST    TFA
3780         GETYP   A,(B)           ; MAKE SURE ATOM
3781         MOVSI   A,(A)
3782         PUSH    TP,A
3783         PUSH    TP,1(B)
3784         JSP     E,CHKARG
3785         MCALL   1,EVAL          ; EVAL IT TO AN ATOM
3786         CAME    A,$TATOM
3787         JRST    NONATM
3788         PUSH    TP,A            ; SAVE TWO COPIES
3789         PUSH    TP,B
3790         PUSHJ   P,IGVAL         ; SEE IF A VALUE EXISTS
3791         CAMN    A,$TUNBOU       ; SKIP IF A WINNER
3792         JRST    .+3
3793         PUSHJ   P,ASKUSR        ; CHECK WITH USER
3794         JRST    DFNE1
3795         PUSH    TP,$TATOM
3796         PUSH    TP,-1(TP)
3797         MOVE    B,1(AB)
3798         HRRZ    B,(B)
3799         MOVSI   A,TEXPR
3800         SKIPN   (P)             ; SKIP IF MACRO
3801         JRST    DFNE3
3802         MOVEI   D,(B)           ; READY TO CONS
3803         MOVSI   C,TEXPR
3804         PUSHJ   P,INCONS
3805         MOVSI   A,TMACRO
3806 DFNE3:  PUSH    TP,A
3807         PUSH    TP,B
3808         MCALL   2,SETG
3809 DFNE1:  POP     TP,B            ; RETURN ATOM
3810         POP     TP,A
3811         JRST    FINIS
3812
3813
3814 ASKUSR: MOVE    B,IMQUOTE REDEFINE
3815         PUSHJ   P,ILVAL         ; SEE IF REDEFINE OK
3816         GETYP   A,A
3817         CAIE    A,TUNBOU
3818         CAIN    A,TFALSE
3819         JRST    ASKUS1
3820         JRST    ASKUS2
3821 ASKUS1: PUSH    TP,$TATOM
3822         PUSH    TP,-1(TP)
3823         PUSH    TP,$TATOM
3824         PUSH    TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE
3825         MCALL   2,ERROR
3826         GETYP   0,A
3827         CAIE    0,TFALSE
3828 ASKUS2: AOS     (P)
3829         MOVE    B,1(AB)
3830         POPJ    P,
3831 \f
3832
3833
3834 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
3835 ;FIRST ARGUMENT TO THE SECOND ARG.  ITS VALUE IS ITS SECOND ARGUMENT.
3836
3837 IMFUNCTION SET,SUBR
3838         HLRE    D,AB            ; 2 TIMES # OF ARGS TO D
3839         ASH     D,-1            ; - # OF ARGS
3840         ADDI    D,2
3841         JUMPG   D,TFA           ; NOT ENOUGH
3842         MOVE    B,PVSTOR+1
3843         MOVE    C,SPSTOR+1
3844         JUMPE   D,SET1          ; NO ENVIRONMENT
3845         AOJL    D,TMA           ; TOO MANY
3846         GETYP   A,4(AB)         ; CHECK ARG IS A FRAME OR PROCESS
3847         CAIE    A,TFRAME
3848         CAIN    A,TENV
3849         JRST    SET2            ; WINNING ENVIRONMENT/FRAME
3850         CAIN    A,TACT
3851         JRST    SET2            ; TO MAKE PFISTER HAPPY
3852         CAIE    A,TPVP
3853         JRST    WTYP2
3854         MOVE    B,5(AB)         ; GET PROCESS
3855         MOVE    C,SPSTO+1(B)
3856         JRST    SET1
3857 SET2:   MOVEI   B,4(AB)         ; POINT TO FRAME
3858         PUSHJ   P,CHFRM ; CHECK IT OUT
3859         MOVE    B,5(AB)         ; GET IT BACK
3860         MOVE    C,SPSAV(B)      ; GET BINDING POINTER
3861         HRRZ    B,4(AB)         ; POINT TO PROCESS
3862         HLRZ    A,(B)           ; GET LENGTH
3863         SUBI    B,-1(A)         ; POINT TO START THEREOF
3864         HLL     B,PVSTOR+1      ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)
3865 SET1:   PUSH    TP,$TPVP        ; SAVE PROCESS
3866         PUSH    TP,B
3867         PUSH    TP,$TSP         ; SAVE PATH POINTER
3868         PUSH    TP,C
3869         GETYP   A,(AB)          ;GET TYPE OF FIRST
3870         CAIE    A,TATOM ;ARGUMENT --
3871         JRST    WTYP1           ;BETTER BE AN ATOM
3872         MOVE    B,1(AB)         ;GET PTR TO IT
3873         MOVEI   0,(B)
3874         CAIL    0,HIBOT
3875         PUSHJ   P,IMPURIFY
3876         MOVE    C,(TP)
3877         PUSHJ   P,AILOC         ;GET LOCATIVE TO VALUE
3878 GOTLOC: CAMN    A,$TUNBOUND     ;BOUND?
3879         PUSHJ   P, BSET         ;BIND IT
3880         MOVE    C,2(AB)         ; GET NEW VAL
3881         MOVE    D,3(AB)
3882         MOVSI   A,TLOCD         ; FOR MONCH
3883         HRR     A,2(B)
3884         PUSHJ   P,MONCH0        ; HURRAY FOR MONITORS!!!!!
3885         MOVE    E,B
3886         HLRZ    A,2(E)          ; GET DECLS
3887         JUMPE   A,SET3          ; NONE, GO
3888         PUSH    TP,$TSP
3889         PUSH    TP,E
3890         MOVE    B,1(A)
3891         HLLZ    A,(A)           ; GET PATTERN
3892         PUSHJ   P,TMATCH        ; MATCH TMEM
3893         JRST    TYPMI2          ; LOSES
3894         MOVE    E,(TP)
3895         SUB     TP,[2,,2]
3896         MOVE    C,2(AB)
3897         MOVE    D,3(AB)
3898 SET3:   MOVEM   C,(E)           ;CLOBBER IDENTIFIER
3899         MOVEM   D,1(E)
3900         MOVE    A,C
3901         MOVE    B,D
3902         MOVE    C,-2(TP)        ; GET PROC
3903         HRRZ    C,BINDID+1(C)
3904         HRLI    C,TLOCI
3905
3906 ; HERE WE NOTE THAT EFFICIENCY CAN SOMETIMES GET IN THE WAY OF CORRECTNESS
3907 ; BY SETTING THE SHALLOW BINDING WE MANAGE TO CLOBBER THE TOP LEVEL LVAL
3908 ; EVEN IF WE ARE SETTING WITH RESPECT TO A DIFFERENT FRAME.  TO CORRECT
3909 ; THIS GLITCH THIS ACTIVITY WILL ONLY TAKE PLACE IF THE ATOM ALREADY POINTS
3910 ; TO A BINDING
3911
3912         MOVE    D,1(AB)
3913         SKIPE   (D)
3914         JRST    NSHALL
3915         MOVEM   C,(D)
3916         MOVEM   E,1(D)
3917 NSHALL: SUB     TP,[4,,4]
3918         JRST    FINIS
3919 BSET:
3920         MOVE    PVP,PVSTOR+1
3921         CAMN    PVP,-2(TP)      ; SKIP IF PROC DIFFERS
3922         MOVEM   C,-2(TP)        ; ELSE USE RESULT FROM LOC SEARCH
3923         MOVE    B,-2(TP)        ; GET PROCESS
3924         HRRZ    A,TPBASE+1(B)   ;GET ACTUAL STACK BASE
3925         HRRZ    B,SPBASE+1(B)   ;AND FIRST BINDING
3926         SUB     B,A             ;ARE THERE 6
3927         CAIL    B,6             ;CELLS AVAILABLE?
3928         JRST    SETIT           ;YES
3929         MOVE    C,(TP)          ; GET POINTER BACK
3930         MOVEI   B,0             ; LOOK FOR EMPTY SLOT
3931         PUSHJ   P,AILOC
3932         CAMN    A,$TUNBOUND     ; SKIP IF FOUND
3933         JRST    BSET1
3934         MOVE    E,1(AB)         ; GET ATOM
3935         MOVEM   E,-1(B)         ; AND STORE
3936         JRST    BSET2
3937 BSET1:  MOVE    B,-2(TP)        ; GET PROCESS
3938 ;       PUSH    TP,TPBASE(B)    ;NO -- GROW THE TP
3939 ;       PUSH    TP,TPBASE+1(B)  ;AT THE BASE END
3940 ;       PUSH    TP,$TFIX
3941 ;       PUSH    TP,[0]
3942 ;       PUSH    TP,$TFIX
3943 ;       PUSH    TP,[100]
3944 ;       MCALL   3,GROW
3945 ;       MOVE    C,-2(TP)                ; GET PROCESS
3946 ;       MOVEM   A,TPBASE(C)     ;SAVE RESULT
3947         PUSH    P,0             ; MANUALLY GROW VECTOR
3948         PUSH    P,C
3949         MOVE    C,TPBASE+1(B)
3950         HLRE    B,C
3951         SUB     C,B
3952         MOVEI   C,1(C)
3953         CAME    C,TPGROW
3954         ADDI    C,PDLBUF
3955         MOVE    D,LVLINC
3956         DPB     D,[001100,,-1(C)]
3957         MOVE    C,[5,,3]        ; SET UP INDICATORS FOR AGC
3958         PUSHJ   P,AGC
3959         MOVE    PVP,PVSTOR+1
3960         MOVE    B,TPBASE+1(PVP) ; MODIFY POINTER
3961         MOVE    0,LVLINC        ; ADJUST SPBASE POINTER
3962         ASH     0,6
3963         SUB     B,0
3964         HRLZS   0
3965         SUB     B,0
3966         MOVEM   B,TPBASE+1(PVP)
3967         POP     P,C
3968         POP     P,0
3969 ;       MOVEM   B,TPBASE+1(C)
3970 SETIT:  MOVE    C,-2(TP)                ; GET PROCESS
3971         MOVE    B,SPBASE+1(C)
3972         MOVEI   A,-6(B)         ;MAKE UP BINDING
3973         HRRM    A,(B)           ;LINK PREVIOUS BIND BLOCK
3974         MOVSI   A,TBIND
3975         MOVEM   A,-6(B)
3976         MOVE    A,1(AB)
3977         MOVEM   A,-5(B)
3978         SUB     B,[6,,6]
3979         MOVEM   B,SPBASE+1(C)
3980         ADD     B,[2,,2]
3981 BSET2:  MOVE    C,-2(TP)        ; GET PROC
3982         MOVSI   A,TLOCI
3983         HRR     A,BINDID+1(C)
3984         HLRZ    D,OTBSAV(TB)    ; TIME IT
3985         MOVEM   D,2(B)          ; AND FIX IT
3986         POPJ    P,
3987
3988 ; HERE TO ELABORATE ON TYPE MISMATCH
3989
3990 TYPMI2: MOVE    C,(TP)          ; FIND DECLS
3991         HLRZ    C,2(C)
3992         MOVE    D,2(AB)
3993         MOVE    B,3(AB)
3994         MOVE    0,(AB)          ; GET ATOM
3995         MOVE    A,1(AB)
3996         JRST    TYPMIS
3997
3998 \f
3999
4000 MFUNCTION NOT,SUBR
4001         ENTRY   1
4002         GETYP   A,(AB)          ; GET TYPE
4003         CAIE    A,TFALSE        ;IS IT FALSE?
4004         JRST    IFALSE          ;NO -- RETURN FALSE
4005
4006 TRUTH:
4007         MOVSI   A,TATOM         ;RETURN T (VERITAS)
4008         MOVE    B,IMQUOTE T
4009         JRST    FINIS
4010
4011 IMFUNCTION OR,FSUBR
4012
4013         PUSH    P,[0]
4014         JRST    ANDOR
4015
4016 MFUNCTION ANDA,FSUBR,AND
4017
4018         PUSH    P,[1]
4019 ANDOR:  ENTRY   1
4020         GETYP   A,(AB)
4021         CAIE    A,TLIST
4022         JRST    WRONGT          ;IF ARG DOESN'T CHECK OUT
4023         MOVE    E,(P)
4024         SKIPN   C,1(AB)         ;IF NIL
4025         JRST    TF(E)           ;RETURN TRUTH
4026         PUSH    TP,$TLIST               ;CREATE UNNAMED TEMP
4027         PUSH    TP,C
4028 ANDLP:
4029         MOVE    E,(P)
4030         JUMPE   C,TFI(E)        ;ANY MORE ARGS?
4031         MOVEM   C,1(TB)         ;STORE CRUFT
4032         GETYP   A,(C)
4033         MOVSI   A,(A)
4034         PUSH    TP,A
4035         PUSH    TP,1(C)         ;ARGUMENT
4036         JSP     E,CHKARG
4037         MCALL   1,EVAL
4038         GETYP   0,A
4039         MOVE    E,(P)
4040         XCT     TFSKP(E)
4041         JRST    FINIS           ;IF FALSE -- RETURN
4042         HRRZ    C,@1(TB)        ;GET CDR OF ARGLIST
4043         JRST    ANDLP
4044
4045 TF:     JRST    IFALSE
4046         JRST    TRUTH
4047
4048 TFI:    JRST    IFALS1
4049         JRST    FINIS
4050
4051 TFSKP:  CAIE    0,TFALSE
4052         CAIN    0,TFALSE
4053
4054 IMFUNCTION FUNCTION,FSUBR
4055
4056         ENTRY   1
4057
4058         MOVSI   A,TEXPR
4059         MOVE    B,1(AB)
4060         JRST    FINIS
4061
4062 \f;SUBR VERSIONS OF AND/OR
4063
4064 MFUNCTION       ANDP,SUBR,[AND?]
4065         JUMPGE  AB,TRUTH
4066         MOVE    C,[CAIN 0,TFALSE]
4067         JRST    BOOL
4068
4069 MFUNCTION       ORP,SUBR,[OR?]
4070         JUMPGE  AB,IFALSE
4071         MOVE    C,[CAIE 0,TFALSE]
4072 BOOL:   HLRE    A,AB            ; GET ARG COUNTER
4073         MOVMS   A
4074         ASH     A,-1            ; DIVIDES BY 2
4075         MOVE    D,AB
4076         PUSHJ   P,CBOOL
4077         JRST    FINIS
4078
4079 CANDP:  SKIPA   C,[CAIN 0,TFALSE]
4080 CORP:   MOVE    C,[CAIE 0,TFALSE]
4081         JUMPE   A,CNOARG
4082         MOVEI   D,(A)
4083         ASH     D,1             ; TIMES 2
4084         HRLI    D,(D)
4085         SUBB    TP,D            ; POINT TO ARGS & FIXUP TP PTR
4086         AOBJP   D,.+1           ; FIXUP ARG PTR AND FALL INTO CBOOL
4087
4088 CBOOL:  GETYP   0,(D)
4089         XCT     C               ; WINNER ?
4090         JRST    CBOOL1          ; YES RETURN IT
4091         ADD     D,[2,,2]
4092         SOJG    A,CBOOL         ; ANY MORE ?
4093         SUB     D,[2,,2]        ; NO, USE LAST
4094 CBOOL1: MOVE    A,(D)
4095         MOVE    B,(D)+1
4096         POPJ    P,
4097
4098
4099 CNOARG: MOVSI   0,TFALSE
4100         XCT     C
4101         JRST    CNOAND
4102         MOVSI   A,TFALSE
4103         MOVEI   B,0
4104         POPJ    P,
4105 CNOAND: MOVSI   A,TATOM
4106         MOVE    B,IMQUOTE T
4107         POPJ    P,
4108 \f
4109
4110 MFUNCTION CLOSURE,SUBR
4111         ENTRY
4112         SKIPL   A,AB            ;ANY ARGS
4113         JRST    TFA             ;NO -- LOSE
4114         ADD     A,[2,,2]        ;POINT AT IDS
4115         PUSH    TP,$TAB
4116         PUSH    TP,A
4117         PUSH    P,[0]           ;MAKE COUNTER
4118
4119 CLOLP:  SKIPL   A,1(TB)         ;ANY MORE IDS?
4120         JRST    CLODON          ;NO -- LOSE
4121         PUSH    TP,(A)          ;SAVE ID
4122         PUSH    TP,1(A)
4123         PUSH    TP,(A)          ;GET ITS VALUE
4124         PUSH    TP,1(A)
4125         ADD     A,[2,,2]        ;BUMP POINTER
4126         MOVEM   A,1(TB)
4127         AOS     (P)
4128         MCALL   1,VALUE
4129         PUSH    TP,A
4130         PUSH    TP,B
4131         MCALL   2,LIST          ;MAKE PAIR
4132         PUSH    TP,A
4133         PUSH    TP,B
4134         JRST    CLOLP
4135
4136 CLODON: POP     P,A
4137         ACALL   A,LIST          ;MAKE UP LIST
4138         PUSH    TP,(AB)         ;GET FUNCTION
4139         PUSH    TP,1(AB)
4140         PUSH    TP,A
4141         PUSH    TP,B
4142         MCALL   2,LIST          ;MAKE LIST
4143         MOVSI   A,TFUNARG
4144         JRST    FINIS
4145
4146 \f
4147
4148 ;ERROR COMMENTS FOR EVAL
4149
4150 BADNUM: ERRUUO  EQUOTE NEGATIVE-ARGUMENT
4151
4152 WTY1TP: ERRUUO  EQUOTE FIRST-ARG-WRONG-TYPE
4153
4154 UNBOU:  PUSH    TP,$TATOM
4155         PUSH    TP,EQUOTE UNBOUND-VARIABLE
4156         JRST    ER1ARG
4157
4158 UNAS:   PUSH    TP,$TATOM
4159         PUSH    TP,EQUOTE UNASSIGNED-VARIABLE
4160         JRST    ER1ARG
4161
4162 BADENV:
4163         ERRUUO  EQUOTE BAD-ENVIRONMENT
4164
4165 FUNERR:
4166         ERRUUO  EQUOTE BAD-FUNARG
4167
4168
4169 MPD.0:
4170 MPD.1:
4171 MPD.2:
4172 MPD.3:
4173 MPD.4:
4174 MPD.5:
4175 MPD.6:
4176 MPD.7:
4177 MPD.8:
4178 MPD.9:
4179 MPD.10:
4180 MPD.11:
4181 MPD.12:
4182 MPD.13:
4183 MPD:    ERRUUO  EQUOTE MEANINGLESS-PARAMETER-DECLARATION
4184
4185 NOBODY: ERRUUO  EQUOTE HAS-EMPTY-BODY
4186
4187 BADCLS: ERRUUO  EQUOTE BAD-CLAUSE
4188
4189 NXTAG:  ERRUUO  EQUOTE NON-EXISTENT-TAG
4190
4191 NXPRG:  ERRUUO  EQUOTE NOT-IN-PROG
4192
4193 NAPTL:
4194 NAPT:   ERRUUO  EQUOTE NON-APPLICABLE-TYPE
4195
4196 NONEVT: ERRUUO  EQUOTE NON-EVALUATEABLE-TYPE
4197
4198
4199 NONATM: ERRUUO  EQUOTE NON-ATOMIC-ARGUMENT
4200
4201
4202 ILLFRA: ERRUUO  EQUOTE FRAME-NO-LONGER-EXISTS
4203
4204 ILLSEG: ERRUUO  EQUOTE ILLEGAL-SEGMENT
4205
4206 BADMAC: ERRUUO  EQUOTE BAD-USE-OF-MACRO
4207
4208 BADFSB: ERRUUO  EQUOTE APPLY-OR-STACKFORM-OF-FSUBR
4209
4210
4211 ER1ARG: PUSH    TP,(AB)
4212         PUSH    TP,1(AB)
4213         MOVEI   A,2
4214         JRST    CALER
4215
4216 END
4217 \f