<mdl.int>/eval.mid.124

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