<mdl.int>/eval.126

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