MUDDLE/neval.222

   1 TITLE EVAL -- MUDDLE EVALUATOR
   2
   3 RELOCATABLE
   4
   5 ; GERALD JAY SUSSMAN, 1971
   6 ; DREW MCDERMOTT, 1972
   7
   8 .GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP
   9 .GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM
  10 .GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA
  11 .GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL
  12 .GLOBAL PDLBUF,MESS,FACTI,ITRUTH,FLFLG,PDLOSS,AGC
  13 .GLOBAL PGROW,TPGROW,PDLGRO,SPCSTE,CNTIN2
  14
  15 .INSRT MUDDLE >
  16
  17         MFUNCTION       EVAL,SUBR
  18         INTGO
  19         HLRZ    A,AB            ;GET NUMBER OF ARGS
  20         CAIE    A,-2            ;EXACTLY 1?
  21         JRST    AEVAL           ;EVAL WITH AN ALIST
  22 NORMEV: HLRZ    A,(AB)          ;GET TYPE OF ARG
  23         CAILE   A,NUMPRI        ;PRIMITIVE?
  24         JRST    NONEVT          ;NO
  25         JRST    @EVTYPT(A)      ;YES-DISPATCH
  26
  27 SELF:   MOVE    A,(AB)          ;TYPES WHICH EVALUATE
  28         MOVE    B,1(AB)
  29         JRST    FINIS           ;TO SELF-EG NUMBERS
  30
  31 ;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
  32
  33 MFUNCTION VALUE,SUBR
  34         JSP     E,CHKAT
  35         PUSHJ   P,IDVAL
  36         JRST    FINIS
  37
  38 IDVAL:  PUSH    TP,A
  39         PUSH    TP,B            ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
  40         PUSHJ   P,ILVAL         ;LOCAL VALUE FINDER
  41         CAMN    A,$TUNAS
  42         JRST    UNAS
  43         CAME    A,$TUNBOUND     ;IF NOT UNBOUND OR UNASSIGNED
  44         JRST    RIDVAL          ;DONE - CLEAN UP AND RETURN
  45         POP     TP,B            ;GET ARG BACK
  46         POP     TP,A
  47         PUSHJ   P,IGVAL
  48         CAMN    A,$TUNBOUND
  49         JRST    UNBOU
  50         POPJ    P,
  51 RIDVAL: SUB     TP,[2,,2]
  52         POPJ    P,
  53
  54 ;GETS THE LOCAL VALUE OF AN IDENTIFIER
  55
  56 MFUNCTION LVAL,SUBR
  57         JSP     E,CHKAT
  58 LVAL2:  PUSHJ   P,ILVAL
  59         CAMN    A,$TUNBO
  60         JRST    UNBOU           ;UNBOUND
  61         CAMN    A,$TUNAS
  62         JRST    UNAS            ;UNASSIGNED
  63         JRST    FINIS           ;OTHER
  64
  65
  66 MFUNCTION RLVAL,SUBR
  67         JSP     E,CHKAT
  68         PUSHJ   P,ILVAL
  69         CAME    A,$TUNBO
  70         JRST    FINIS
  71         PUSH    TP,(AB)         ;IF UNBOUND,
  72         PUSH    TP,1(AB)        ;BIND IT GLOBALLY TO ?()
  73         PUSH    TP,$TUNAS
  74         PUSH    TP,[0]
  75         MCALL   2,SET
  76         JRST    FINIS
  77
  78
  79 MFUNCTION UNASSP,SUBR,[UNASSIGNED?]
  80         JSP     E,CHKAT
  81         PUSHJ   P,ILVAL
  82         CAMN    A,$TUNBO
  83         JRST    UNBOU
  84         CAME    A,$TUNAS
  85         JRST    IFALSE
  86         JRST    FINIS
  87 \f
  88 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
  89
  90 MFUNCTION LLOC,SUBR
  91         JSP     E,CHKAT
  92         PUSHJ   P,ILOC
  93         CAMN    A,$TUNBOUND
  94         JRST    UNBOU
  95         MOVSI   A,TLOCD
  96         HRR     A,2(B)
  97         JRST    FINIS
  98
  99 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
 100
 101 MFUNCTION BOUND,SUBR,[BOUND?]
 102         JSP     E,CHKAT
 103         PUSHJ   P,ILVAL
 104         CAMN    A,$TUNBOUND
 105         JUMPE   B,IFALSE
 106         JRST    TRUTH
 107
 108 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
 109
 110 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
 111         JSP     E,CHKAT
 112         PUSHJ   P,ILVAL
 113         CAMN    A,$TUNBOU
 114         JRST    UNBOU
 115         CAMN    A,$TUNAS
 116         JRST    IFALSE
 117         JRST    TRUTH
 118
 119 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER
 120
 121 MFUNCTION GVAL,SUBR
 122         JSP     E,CHKAT
 123         PUSHJ   P,IGVAL
 124         CAMN    A,$TUNBOUND
 125         JRST    UNAS
 126         JRST    FINIS
 127
 128 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
 129
 130 MFUNCTION GLOC,SUBR
 131         JSP     E,CHKAT
 132         PUSHJ   P,IGLOC
 133         CAMN    A,$TUNBOUND
 134         JRST    UNAS
 135         MOVSI   A,TLOCD
 136         JRST    FINIS
 137
 138 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
 139
 140 MFUNCTION GASSIG,SUBR,[GASSIGNED?]
 141         JSP     E,CHKAT
 142         PUSHJ   P,IGVAL
 143         CAMN    A,$TUNBOUND
 144         JRST    IFALSE
 145         JRST    TRUTH
 146
 147 \f
 148
 149 CHKAT:  ENTRY   1
 150         HLLZ    A,(AB)
 151         CAME    A,$TATOM
 152         JRST    NONATM
 153         MOVE    B,1(AB)
 154         JRST    2,(E)
 155
 156 ;EVALUATE A FORM. IF CAR IS AN ATOM USE GLOBAL VALUE OVER LOCAL ONE.
 157
 158 EVFORM: SKIPN   C,1(AB)         ;EMPTY?
 159         JRST    IFALSE
 160         HLLZ    A,(C)           ;GET CAR TYPE
 161         CAME    A, $TATOM       ;ATOMIC?
 162         JRST    EV0             ;NO -- CALCULATE IT
 163         MOVE    B,1(C)          ;GET PTR TO ATOM
 164         CAMN    B,MQUOTE LVAL
 165         JRST    EVATOM          ;".X" EVALUATED QUICKLY
 166 EVFRM1: PUSHJ   P,IGVAL
 167         CAMN    A,$TUNBOUND
 168         JRST    LFUN
 169         PUSH    TP,A
 170         PUSH    TP,B
 171         JRST    IAPPLY          ;APPLY IT
 172 EV0:    PUSH    TP,A            ;SET UP CAR OF FORM AND
 173         PUSH    TP,1(C)
 174         JSP     E,CHKARG
 175         MCALL   1,EVAL          ;EVALUATE IT
 176         PUSH    TP,A            ;APPLY THE RESULT
 177         PUSH    TP,B            ;AS A FUNCTION
 178         JRST    IAPPLY
 179
 180 LFUN:   MOVE    B,1(AB)
 181         PUSH    TP,$TATOM
 182         PUSH    TP,1(B)
 183         MCALL   1,VALUE
 184         PUSH    TP,A
 185         PUSH    TP,B
 186         JRST    IAPPLY
 187
 188 ;HERE TO EVALUATE AN ATOM
 189
 190 EVATOM: HRRZ    D,(C)           ;D _ REST OF FORM
 191         MOVE    A,(D)           ;A _ TYPE OF ARG
 192         CAME    A,$TATOM
 193         JRST    EVFRM1
 194         MOVE    B,1(D)          ;B _ ATOM POINTER
 195         JRST    LVAL2           ;SIMULATE .MCALL TO LVAL
 196
 197 ;DISPATCH TABLE FOR EVAL
 198 DISTBL EVTYPT,SELF,[[TLIST,EVLIST],[TFORM,EVFORM],[TVEC,EVECT],[TSEG,ILLSEG],[TUVEC,EUVEC]]
 199
 200 \f;AEVAL DOES RELATIVE EVALUATIONS WITH RESPECT TO
 201 ;AN ENVIRONMENT OR FRAME.  A FALSE ENVIRONMENT IS EQUIVALENT TO THE
 202 ;CURRENT ONE.
 203
 204 AEVAL:  CAIE    A,-4            ;EXACTLY 2 ARGS?
 205         JRST    WNA             ;NO-ERROR
 206         HLRZ    A,2(AB)         ;CHECK THAT WE HAVE AN ENV OR FRAME
 207         CAIN    A,TENV
 208         JRST    EWRTNV
 209         CAIN    A,TFALSE
 210         JRST    NORMEV          ;OR <>
 211         CAIE    A,TFRAME
 212         JRST    WTYP
 213
 214         MOVE    A,3(AB)         ;A _ FRAME POINTER
 215         HRR     B,A
 216         HLL     B,OTBSAV(A)     ;CHECK ITS TIME...
 217         CAME    A,B
 218         JRST    ILLFRA
 219         GETYP   C,FSAV(A)
 220         CAIE    C,TENTRY        ;...AND CONTENTS
 221         JRST    ILLFRA
 222
 223 EWRTFM: MOVE    B,SPSAV(A)      ;NOW USE THE NITTY-GRITTY
 224         CAMN    SP,B            ;NAMELY, THE FRAME'S ACCESS ENVIRONMENT
 225         JRST    NORMEV          ;UNLESS IT ISN'T NEW
 226         PUSH    TP,2(AB)        ;NOW SIMULATE AN EWRTNV ON A TENV
 227         PUSH    TP,A
 228         MOVSI   A,TENV
 229         MOVEM   A,2(AB)
 230         MOVEM   B,3(AB)
 231         MOVEI   C,
 232         PUSHJ   P,ISPLIC
 233         POP     TP,3(AB)        ;RESTORE WITH FRAME
 234         POP     TP,2(AB)
 235         JRST    NORMEV\fMFUNCTION SPLICE,SUBR
 236         ENTRY   2               ;<SPLICE CURRENT NEW>
 237         GETYP   A,2(AB)
 238         CAIN    A,TFALSE
 239         JRST    ITRUTH          ;IF .NEW = <>, EASY;
 240         CAIE    A,TENV
 241         JRST    WTYP            ;OTHERWISE,
 242         GETYP   A,(AB)          ;TWO ENVIRONMENTS NEEDED
 243         CAIE    A,TENV
 244         JRST    WTYP
 245         MOVE    A,1(AB)         ;.CURRENT = .NEW?
 246         CAMN    A,3(AB)
 247         JRST    ITRUTH          ;HOPEFULLY
 248         PUSH    TP,$TSP
 249         PUSH    TP,SP           ;SAVE CURRENT SP
 250         AOSN    E,PTIME
 251         .VALUE  [ASCIZ /TIMEOUT/]
 252         PUSHJ   P,FINDSP        ;SP _ A, AMONG OTHER THINGS
 253         PUSHJ   P,ISPLIC        ;SPLICE IT
 254         EXCH    SP,1(TB)        ;RESTORE SP,
 255         SKIPN   C
 256         MOVE    SP,1(TB)        ;UNLESS SPLICE DONE TO TOP OF SP
 257         MOVEM   SP,SPSAV(TB)    ;SPSAV SLOT CLOBBERED BY FINDSP
 258         PUSH    TP,$TFIX        ;SAVE OLD PROCID
 259         PUSH    TP,E
 260         FPOINT  UNSPLI,4        ;SET FAILPOINT
 261         JRST    IFALSE
 262
 263 ;FAIL BACK TO HERE
 264
 265 UNSPLI: MOVE    A,1(TB)         ;A _ SPLICE VECTOR ADDRESS
 266         MOVEM   SP,1(TB)        ;SAVE SP
 267         MOVE    E,3(TB)         ;E _ OLD PROCID
 268         PUSHJ   P,FINDSP        ;SP _ SPLICE VECTOR
 269         MOVEM   E,PROCID+1(PVP) ;RESET OLD PROCID
 270         MOVE    SP,3(SP)        ;SP _ REBIND ENVIRONMENT
 271         JUMPE   C,IFAIL         ;IF C = 0, KEEP FAILING
 272         MOVEM   SP,1(C)         ;RECLOBBER ACCESS TO REBIND
 273         MOVE    SP,1(TB)        ;IF NOTHING LOWER, SP _ SAME AS BEFORE
 274         JRST    IFAIL
 275
 276
 277 ;SPECIAL CASE FOR EVAL WITH ENVIRONMENT
 278
 279 EWRTNV: CAMN    SP,3(AB)                ;ALREADY GOT?
 280         JRST    NORMEV
 281         AOSN    E,PTIME
 282         .VALUE  [ASCIZ /TIMEOUT/]
 283         MOVEI   C,
 284         PUSHJ   P,ISPLICE
 285         JRST    NORMEV
 286
 287 ;SEARCH FOR A THROUGH ENVIRONMENTS, SETTING SP AS YOU GO
 288 ;CLOBBER ALL PROCID'S OF BOUND ATOMS TO E, AND CLOBBER
 289 ;LOCATIVES IN ALL BIND BLOCKS EXCEPT FOR LAST VECTOR
 290
 291 FINDSP: MOVEI   C,
 292         SKIPA
 293 SPLOOP: MOVE    SP,1(C)
 294         CAMN    SP,A            ;DONE?
 295         POPJ    P,
 296         SKIPN   SP
 297         .VALUE  [ASCIZ /SPOVERPOP/]
 298         JUMPE   C,JBVEC2
 299
 300 ;CLOBBER ALL LOCATIVES IN LAST BIND VECTOR
 301
 302 BLOOP3: GETYP   C,(B)
 303         CAIE    C,TBIND
 304         JRST    JBVEC2
 305         MOVEI   C,TFALSE        ;MAKE FALSE LOCATIVE
 306         HRLM    C,4(B)
 307         SETZM   5(B)
 308         HRRZ    B,(B)
 309         JRST    BLOOP3
 310 JBVEC2: HRRZ    B,SP            ;B _ SP
 311         MOVE    C,SP            ;C _ BIND BLOCK ADDRESS = SP
 312 BLOOP4: GETYP   D,(C)           ;SEARCH THROUGH BLOCKS ON THIS VECTOR
 313         CAIE    D,TBIND
 314         JRST    SPLOOP          ;GOT TO END
 315         MOVE    D,1(C)          ;ALTER PROCID OF BOUND ATOM
 316         HRRM    E,(D)
 317         HRRZ    C,(C)           ;NEXT BLOCK
 318         JRST    BLOOP4
 319
 320 ;SPLICE 3(AB) INTO SP
 321
 322 ISPLIC: PUSH    TP,$TVEC        ;SAVE C
 323         PUSH    TP,C
 324         PUSH    TP,$TFIX
 325         PUSH    TP,E            ;AND E
 326         PUSH    TP,$TFIX
 327         PUSH    TP,[3]
 328         MCALL   1,VECTOR        ;B _ <VECTOR 3>
 329         MOVSI   D,TSP
 330         MOVEM   D,(B)
 331         MOVEM   D,2(B)
 332         MOVE    D,3(AB)
 333         MOVEM   D,1(B)          ;<PUT .B 1 <3 .AB>>
 334         MOVEM   SP,3(B)         ;<PUT .B 2 .SP>
 335         MOVE    SP,B            ;SP _ B
 336         MOVSI   D,TFIX
 337         MOVEM   D,4(SP)         ;GET SET TO STORE NEW PROCID
 338         MOVE    E,(TP)          ;E _ NEW PROCID
 339         EXCH    E,PROCID+1(PVP) ;E _ OLD PROCID
 340         MOVEM   E,5(SP)         ;SAVE OLD PROCID IN BIND VECTOR
 341         SUB     TP,[4,,4]
 342         SKIPE   C,2(TP)         ;RECOVER C
 343         MOVEM   SP,1(C)         ;COMPLETE SPLICE
 344         POPJ    P,\fMFUNCTION APPLY,SUBR
 345         ENTRY   2
 346         MOVE    A,(AB)          ;SAVE FUNCTION
 347         PUSH    TP,A
 348         MOVE    B,1(AB)
 349         PUSH    TP,B
 350         GETYP   A,2(AB)         ;AND ARG LIST
 351         CAIE    A,TLIST
 352         JRST    WTYP            ;WHICH SHOULD BE LIST
 353         PUSH    TP,$TLIST
 354         MOVE    B,3(AB)
 355         PUSH    TP,B
 356         MOVEI   0,
 357         MOVEI   B,ARGNEV        ;ARGS NOT EVALED
 358         JRST    IAPPL1
 359
 360 IAPPLY: MOVSI   A,TLIST
 361         PUSH    TP,A
 362         HRRZ    B,@1(AB)
 363         PUSH    TP,B
 364         HRRZ    0,1(AB)         ;0 _ CALL
 365         MOVEI   B,ARGEV         ;ARGS TO BE EVALED
 366 IAPPL1: GETYP   A,(TB)
 367         CAIN    A,TEXPR         ;EXPR?
 368         JRST    APEXPR          ;YES
 369         CAIN    A,TFSUBR        ;NO -- FSUBR?
 370         JRST    APFSUBR         ;YES
 371         CAIN    A,TFUNARG       ;NO -- FUNARG?
 372         JRST    APFUNARG        ;YES
 373         CAIN    A,TPVP          ;NO -- PROCESS TO BE RESUMED?
 374         JRST    NOTIMP          ;YES
 375         SUBI    B,ARGNEV        ;B _ 0 IFF NO EVALUATION
 376         PUSH    P,B             ;PUSH SWITCH
 377         CAIN    A,TSUBR         ;NO -- SUBR?
 378         JRST    APSUBR          ;YES
 379         CAIN    A,TFIX          ;NO -- CALL TO NTH?
 380         JRST    APNUM           ;YES
 381         CAIN    A,TACT          ;NO -- ACTIVATION?
 382         JRST    APACT           ;YES
 383         JRST    NAPT            ;NONE OF THE ABOVE
 384
 385
 386 ;APFSUBR CALLS FSUBRS
 387
 388 APFSUBR:
 389         MCALL   1,@1(TB)
 390         JRST    FINIS
 391
 392 ;APSUBR CALLS SUBRS
 393
 394 APSUBR: PUSH    P,[0]           ;MAKE SLOT FOR ARGCNT
 395 TUPLUP:
 396         SKIPN   A,3(TB)         ;IS IT NIL?
 397         JRST    MAKPTR          ;YES -- DONE
 398         PUSH    TP,(A)          ;NO -- GET CAR OF THE
 399         HLLZS   (TP)            ;ARGLIST
 400         PUSH    TP,1(A)
 401         JSP     E,CHKARG
 402         SKIPN   -1(P)           ;EVAL?
 403         JRST    BUMP            ;NO
 404         MCALL   1,EVAL          ;AND EVAL IT.
 405         PUSH    TP,A            ;SAVE THE RESULT IN
 406         PUSH    TP,B            ;THE GROWING TUPLE
 407 BUMP:   AOS     (P)             ;BUMP THE ARGCNT
 408         HRRZ    A,@3(TB)        ;SET THE ARGLIST TO
 409         MOVEM   A,3(TB)         ;CDR OF THE ARGLIST
 410         JRST    TUPLUP
 411 MAKPTR:
 412         POP     P,A
 413         ACALL   A,@1(TB)
 414         JRST    FINIS
 415
 416 ;APACT INTERPRETS ACTIVATIONS AS CALLS TO FUNCTION EXIT
 417
 418 APACT:  MOVE    A,(TP)          ;A _ ARGLIST
 419         JUMPE   A,TFA
 420         GETYP   B,(A)           ;SETUP SECOND ARGUMENT
 421         HRLZM   B,-1(TP)
 422         MOVE    B,1(A)
 423         MOVEM   B,(TP)
 424         HRRZ    A,(A)           ;MAKE SURE ONLY ONE
 425         JUMPN   A,TMA
 426         JSP     E,CHKARG
 427         SKIPN   (P)             ;IF ARGUMENT AS YET UNEVALED,
 428         MCALL   2,EXIT
 429         MCALL   1,EVAL          ;EVAL IT
 430         PUSH    TP,A
 431         PUSH    TP,B
 432         MCALL   2,EXIT          ;AND EXIT GIVEN ACTIVATION\f
 433
 434 ;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
 435
 436 APNUM:
 437         MOVE    A,(TP)          ;GET ARLIST
 438         JUMPE   A,ERRTFA        ;NO ARGUMENT
 439         PUSH    TP,(A)          ;GET CAR OF ARGL
 440         HLLZS   (TP)
 441         PUSH    TP,1(A)
 442         HRRZ    A,(A)           ;MAKE SURE ONLY ONE ARG
 443         JUMPN   A,ERRTMA
 444         JSP     E,CHKARG        ;HACK DEFERRED
 445         SKIPN   (P)             ;EVAL?
 446         JRST    DONTH
 447         MCALL   1,EVAL          ;YES
 448         PUSH    TP,A
 449         PUSH    TP,B
 450 DONTH:  PUSH    TP,(TB)
 451         PUSH    TP,1(TB)
 452         MCALL   2,NTH
 453         JRST    FINIS
 454
 455 ;APEXPR APPLIES EXPRS
 456 ;EXPRESSION IS IN 0(AB),  FUNCTION IS IN 0(TB)
 457
 458 APEXPR:
 459
 460         SKIPN   C,1(TB)         ;BODY?
 461         JRST    NOBODY          ;NO, ERROR
 462         MOVE    D,(TP)          ;D _ ARG LIST
 463         SETZM   (TP)            ;ZERO (TP) FOR BODY
 464         PUSH    P,[0]           ;SWITCHES OFF
 465         PUSH    P,B             ;ARGS EVALER OR NON-EVALER
 466         PUSHJ   P,BINDER        ;DO THE BINDINGS
 467
 468         HRRZ    C,1(TB)         ;GET BODY BACK
 469         TRNE    A,H             ;SKIP IF NO HEWITT ATOM
 470         HRRZ    C,(C)           ;ELSE CDR AGAIN
 471         MOVEM   C,3(TB)
 472         JRST    STPROG
 473
 474 ;MAKE SURE ARGUMENT PUSHED ON STACK IS NOT OF TYPE DEFER
 475 ;(CLOBBERS A AND E)
 476
 477 CHKARG: GETYP   A,-1(TP)
 478         CAIE    A,TDEFER
 479         JRST    (E)
 480         HRRZS   (TP)            ;MAKE SURE INDIRECT WINS
 481         MOVE    A,@(TP)
 482         MOVEM   A,-1(TP)                ;CLOBBER IN TYPE SLOT
 483         MOVE    A,(TP)          ;NOW GET POINTER
 484         MOVE    A,1(A)          ;GET VALUE
 485         MOVEM   A,(TP)          ;CLOBBER IN
 486         JRST    (E)
 487 \f;LIST EVALUATOR
 488
 489 EVLIST: PUSHJ   P,PSHRG1        ;EVALUATE EVERYTHING
 490         PUSH    P,C             ;SAVE COUNTER
 491 EVLIS1: JUMPE   C,EVLDON        ;IF C=0, DONE
 492         PUSH    TP,A            ;ELSE, CONS
 493         PUSH    TP,B
 494         MCALL   2,CONS          ;(A,B) _ ((TP) !(A,B))
 495         SOS     C,(P)           ;DECREMENT COUNTER
 496         JRST    EVLIS1
 497 EVLDON: SUB     P,[1,,1]
 498         JRST    FINIS
 499
 500
 501 ;VECTOR EVALUATOR
 502
 503 EVECT:  PUSH    P,[0]           ;COUNTER
 504         GETYPF  A,(AB)          ;COPY INPUT VECTOR POINTER
 505         PUSH    TP,A
 506         PUSH    TP,1(AB)
 507
 508 EVCT2:  INTGO
 509         SKIPL   A,1(TB)         ;IF VECTOR EMPTY,
 510         JRST    MAKVEC          ;GO MAKE ITS VALUE
 511         GETYPF  C,(A)           ;C _ TYPE OF NEXT ELEMENT
 512         PUSH    P,C
 513         CAMN    C,$TSEG
 514         MOVSI   C,TFORM         ;EVALUATE SEGMENTS LIKE FORMS
 515         PUSH    TP,C
 516         PUSH    TP,1(A)
 517         ADD     A,[2,,2]        ;TO NEXT VALUE
 518         MOVEM   A,1(TB)
 519         MCALL   1,EVAL          ;(A,B) _ VALUE OF NEXT ELEMENT
 520         POP     P,C
 521         CAME    C,$TSEG         ;IF SEGMENT,
 522         JRST    EVCT1
 523         PUSHJ   P,PSHSEG        ;PUSH ITS ELEMENTS
 524         JRST    EVCT2
 525 EVCT1:  PUSH    TP,A            ;ELSE PUSH IT
 526         PUSH    TP,B
 527         AOS     (P)             ;BUMP COUNTER
 528         JRST    EVCT2
 529
 530 MAKVEC: POP     P,A             ;A _ COUNTER
 531         .ACALL  A,EVECTOR       ;CALL VECTOR CONSTRUCTOR
 532         JRST    FINIS           ;QUIT
 533
 534
 535 ;UNIFORM VECTOR EVALUATOR
 536
 537 EUVEC:  GETYPF  A,(AB)          ;COPY INPUT VECTOR POINTER
 538         PUSH    TP,A
 539         PUSH    TP,1(AB)
 540         HLRE    C,1(TB)         ;C _ - NO. OF WORDS: TO DOPE WORD
 541         HRRZ    A,1(TB)
 542         SUBM    A,C             ;C _ ADDRESS OF DOPE WORD
 543         GETYPF  A,(C)
 544         PUSH    P,A             ;-1(P) _ TYPE OF UVECTOR
 545         PUSH    P,[0]           ;0(P) _ COUNTER
 546 EUVCT2: INTGO
 547         SKIPL   A,1(TB)         ;IF VECTOR EMPTY,
 548         JRST    MAKUVC          ;GO MAKE ITS VALUE
 549         MOVE    C,-1(P)         ;C _ TYPE
 550         CAMN    C,$TSEG
 551         MOVSI   C,TFORM         ;EVALUATE SEGMENTS LIKE FORMS
 552         PUSH    TP,C
 553         PUSH    TP,(A)
 554         ADD     A,[1,,1]        ;TO NEXT VALUE
 555         MOVEM   A,1(TB)
 556         MCALL   1,EVAL          ;(A,B) _ VALUE OF NEXT ELEMENT
 557         MOVE    C,-1(P)
 558         CAME    C,$TSEG         ;IF SEGMENT,
 559         JRST    EUVCT1
 560         PUSHJ   P,PSHSEG        ;PUSH ITS ELEMENTS
 561         JRST    EUVCT2
 562 EUVCT1: PUSH    TP,A            ;ELSE PUSH IT
 563         PUSH    TP,B
 564         AOS     (P)             ;BUMP COUNTER
 565         JRST    EUVCT2
 566
 567 MAKUVC: POP     P,A             ;A _ COUNTER
 568         .ACALL  A,EUVECT        ;CALL VECTOR CONSTRUCTOR
 569         SUB     P,[1,,1]        ;FLUSH TYPE
 570         JRST    FINIS           ;QUIT
 571 \f;ENTRY POINT FOR PUSHING ALL BUT LAST SEGMENT, IF ANY,
 572 ;WHICH IS IN (A,B) INSTEAD OF ON STACK.  IF NO LAST SEGMENT
 573 ;(OR IT IS NOT A LIST), (A,B) = () INSTEAD.
 574
 575 PSHSW=-1                ;SWITCH BENEATH COUNTER ON STACK
 576 CPYLST==1               ;SWITCH ON IFF LAST SEGMENT TO BE COPIED LIKE OTHERS
 577
 578 PSHRG1: PUSH    P,[0]           ;DON'T COPY LAST SEGMENT
 579         JRST    PSHRG2
 580
 581 ;INTERNAL ARG LIST PUSHER-- ACCEPTS SEGMENTS, LEAVES COUNTER OF
 582 ;THINGS PUSHED IN C
 583
 584 PSHRGL: PUSH    P,[1]           ;COPY FINAL SEGMENT
 585 PSHRG2: PUSH    P,[0]           ;(P) IS A COUNTER
 586         GETYPF  A,(AB)          ;COPY ARGLIST POINTER
 587         PUSH    TP,A
 588         PUSH    TP,1(AB)
 589
 590 IEVL2:  INTGO
 591         SKIPN   A,1(TB)         ;A _ NEXT LIST CELL ADDRESS
 592         JRST    ARGSDN          ;IF 0, DONE
 593         HRRZ    B,(A)           ;CDR THE ARGS
 594         MOVEM   B,1(TB)
 595         GETYP   C,(A)           ;C _ TRUE TYPE OF CELL ELEMENT
 596         MOVSI   C,(C)
 597         CAME    C,$TDEFER       ;DON'T ACCEPT DEFERREDS
 598         JRST    IEVL3
 599         MOVE    A,1(A)
 600         MOVE    C,(A)
 601 IEVL3:  PUSH    P,C             ;SAVE TYPE
 602         CAMN    C,$TSEG         ;IF SEGMENT
 603         MOVSI   C,TFORM         ;EVALUATE IT LIKE A FORM
 604         PUSH    TP,C
 605         PUSH    TP,1(A)
 606         MCALL   1,EVAL          ;(A,B) _ VALUE OF NEXT ELEMENT
 607         POP     P,C
 608         CAME    C,$TSEG         ;IF SEGMENT,
 609         JRST    IEVL4
 610         CAMN    A,$TLIST        ;THAT TURNED OUT TO BE A LIST,
 611         SKIPE   1(TB)           ;CHECK IF LAST
 612         JRST    IEVL1           ;IF NOT, COPY IT
 613         MOVE    0,PSHSW(P)      ;IF SO, AND "COPY LAST"
 614         TRNN    0,CPYLST        ;   SWITCH IS OFF
 615         JRST    IEVL5           ;DON'T COPY
 616 IEVL1:  PUSHJ   P,PSHSEG        ;PUSH SEGMENT'S ELEMENTS
 617         JRST    IEVL2
 618 IEVL4:  PUSH    TP,A            ;ELSE PUSH IT
 619         PUSH    TP,B
 620         AOS     (P)             ;BUMP COUNTER
 621         JRST    IEVL2
 622
 623 ARGSDN: MOVE    B,PSHSW(P)      ;B _ SWITCH WORD
 624         TRNN    B,CPYLST        ;IF COPY LAST SWITCH OFF,
 625         MOVSI   A,TLIST         ;    (A,B) _ ()
 626 IEVL5:  POP     P,C             ;C _ FINAL COUNT
 627         SUB     P,[1,,1]        ;PITCH SWITCH WORD
 628         POPJ    P,\f;THIS FUNCTION PUSHES THE ELEMENTS OF THE STRUCTURE (A,B) ONTO
 629 ;TP; (P) = RETURN ADDRESS; -1(P) = COUNTER (SET UP BY CALLER)
 630
 631 PSHSEG: MOVEM   A,BSTO(PVP)     ;TYPE FOR AGC
 632         GETYP   A,A
 633         PUSHJ   P,SAT           ;A _ PRIMITIVE TYPE OF (A,B)
 634         CAIN    A,S2WORD        ;LIST?
 635         JRST    PSHLST          ;YES-- DO IT!
 636         HLRE    C,B             ;MUST BE SOME KIND OF VECTOR OR TUPLE
 637         MOVNS   C               ;C _ NUMBER OF WORDS TO DOPE WORD
 638         CAIN    A,SNWORD        ;UVECTOR?
 639         JRST    PSHUVC          ;YES-- DO IT!!
 640         ASH     C,-1            ;NO-- C _ C/2 = NUMBER OF ELEMENTS
 641         ADDM    C,-1(P)         ;BUMP COUNTER
 642         CAIN    A,S2NWORD       ;VECTOR?
 643         JRST    PSHVEC          ;YES-- DO IT!!!
 644         CAIE    A,SARGS         ;ARGS TUPLE?
 645         JRST    ILLSEG          ;NO-- DO IT!!!!
 646         PUSH    TP,BSTO(PVP)    ;YES-- CHECK FOR LEGALITY
 647         PUSH    TP,B
 648         SETZM   BSTO(PVP)
 649         MOVEI   B,-1(TP)        ;B _ ARGS POINTER ADDRESS
 650         PUSHJ   P,CHARGS        ;CHECK IT OUT
 651         POP     TP,B            ;RESTORE WORLD
 652         POP     TP,BSTO(PVP)
 653
 654 PSHVEC: INTGO
 655         JUMPGE  B,SEGDON        ;IF B = [], QUIT
 656         PUSH    TP,(B)          ;PUSH NEXT ELEMENT
 657         PUSH    TP,1(B)
 658         ADD     B,[2,,2]        ;B _ <REST .B>
 659         JRST    PSHVEC
 660
 661 PSHUVC: ADDM    C,-1(P)         ;BUMP COUNTER
 662         ADDM    B,C             ;C _ DOPE WORD ADDRESS
 663         GETYP   A,(C)           ;A _ UVECTOR ELEMENTS TYPE
 664         MOVSI   A,(A)
 665 PSHUV1: INTGO
 666         JUMPGE  B,SEGDON        ;IF B = ![], QUIT
 667         PUSH    TP,A            ;PUSH NEXT ELEMENT WITH TYPE
 668         PUSH    TP,(B)
 669         ADD     B,[1,,1]        ;B _ <REST .B>
 670         JRST    PSHUV1
 671
 672 PSHLST: INTGO
 673         JUMPE   B,SEGDON        ;IF B = (), QUIT
 674         GETYP   A,(B)
 675         MOVSI   A,(A)           ;PUSH NEXT ELEMENT
 676         PUSH    TP,A
 677         PUSH    TP,1(B)
 678         JSP     E,CHKARG        ;KILL TDEFERS
 679         AOS     -1(P)           ;COUNT ELEMENT
 680         HRRZ    B,(B)           ;CDR LIST
 681         JRST    PSHLST
 682
 683 SEGDON: SETZM   BSTO(PVP)               ;FIX TYPE
 684         POPJ    P,\f;THESE THREE CONSTRUCTOR FUNCTIONS ARE USED
 685 ;TO SIMULATE "VARIABLE BRACKETS"; FOR EXAMPLE, <CONSV ...>
 686 ;MEANS [...].
 687
 688 ;LIST CONSTRUCTOR
 689
 690 MFUNCTION CONSL,FSUBR
 691         JRST    EVLIST          ;DEGENERATE CASE
 692
 693 ;VECTOR CONSTRUCTOR
 694
 695 MFUNCTION CONSV,FSUBR
 696         PUSHJ   P,PSHRGL        ;EVALUATE ARGS
 697         .ACALL  C,EVECTOR       ;AND CALL EVECTOR ON THEM
 698         JRST    FINIS
 699
 700 ;UVECTOR CONSTRUCTOR
 701
 702 MFUNCTION CONSU,FSUBR
 703         PUSHJ   P,PSHRGL        ;VERY SIMILAR
 704         .ACALL  C,EUVECT        ;BUT CALL EUVECT INSTEAD
 705         JRST    FINIS\f
 706
 707 ;APFUNARG APPLIES OBJECTS OF TYPE FUNARG
 708
 709 APFUNARG:
 710         HRRZ    A,@1(TB)        ;GET CDR OF FUNARG
 711         JUMPE   A,FUNERR        ;NON -- NIL
 712         HLRZ    B,(A)           ;GET TYPE OF CADR
 713         CAIE    B,TLIST         ;BETTR BE LIST
 714         JRST    FUNERR
 715         PUSH    TP,$TLIST       ;SAVE IT UP
 716         PUSH    TP,1(A)
 717 FUNLP:
 718         INTGO
 719         SKIPN   A,3(TB)         ;ANY MORE
 720         JRST    DOF             ;NO -- APPLY IT
 721         HRRZ    B,(A)
 722         MOVEM   B,3(TB)
 723         HLRZ    C,(A)
 724         CAIE    C,TLIST
 725         JRST    FUNERR
 726         HRRZ    A,1(A)
 727         HLRZ    C,(A)           ;GET FIRST VAR
 728         CAIE    C,TATOM         ;MAKE SURE IT IS ATOMIC
 729         JRST    FUNERR
 730         PUSH    TP,BNDA         ;SET IT UP
 731         PUSH    TP,1(A)
 732         HRRZ    A,(A)
 733         PUSH    TP,(A)          ;SET IT UP
 734         PUSH    TP,1(A)
 735         JSP     E,CHKARG
 736 \r       PUSH    TP,[0]
 737         PUSH    TP,[0]
 738         JRST    FUNLP
 739 DOF:
 740         PUSHJ   P,SPECBIND      ;BIND THEM
 741         MOVE    A,1(TB)         ;GET GOODIE
 742         HLLZ    B,(A)
 743         PUSH    TP,B
 744         PUSH    TP,1(A)
 745         HRRZ    A,3(TB)         ;A _ ARG LIST
 746         PUSH    TP,$TLIST
 747         PUSH    TP,A
 748         MCALL   2,CONS
 749         PUSH    TP,$TFORM
 750         PUSH    TP,B
 751         MCALL   1,EVAL
 752         JRST    FINIS
 753 \f
 754
 755 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT
 756 ;IN A AND B.  IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,
 757 ; IT IS CALLED BY PUSHJ P,ILOC.  IT CLOBBERS A, B, C, & 0
 758
 759 ILOC:   MOVSI   A,TLOCI         ;MAKE A LOCATIVE TYPE CELL
 760         HRR     A,PROCID+1(PVP) ;FOR THE CURRENT PROCESS
 761         CAME    A,(B)           ;IS THERE ONE IN THE VALUE CELL?
 762         JRST    SCHSP           ;NO -- SEARCH THE LOCAL BINDINGS
 763         MOVE    B,1(B)          ;YES -- GET LOCATIVE POINTER
 764         POPJ    P,              ;FROM THE VALUE CELL
 765
 766 SCHSP:  PUSH    P,0             ;SAVE 0
 767         MOVE    C,SP            ;GET TOP OF BINDINGS
 768 SCHLP:  JUMPE   C,NPOPJ         ;IF NO MORE, LOSE
 769 SCHLP1: GETYP   0,(C)
 770         CAIN    0,TSP           ;INDIRECT LINK TO NEXT BIND BLOCK?
 771         JRST    NXVEC2
 772         CAMN    B,1(C)          ;FOUND ATOM?
 773         JRST    SCHFND
 774         HRR     C,(C)           ;FOLLOW CHAIN
 775         SUB     C,[6,,0]
 776         JRST    SCHLP
 777 NXVEC2: MOVE    C,1(C)          ;GET NEXT BLOCK
 778         JRST    SCHLP
 779
 780 SCHFND: EXCH    B,C             ;SAVE THE ATOM PTR IN C
 781         ADD     B,[2,,2]        ;MAKE UP THE LOCATIVE
 782
 783         MOVEM   A,(C)           ;CLOBBER IT AWAY INTO THE
 784         MOVEM   B,1(C)          ;ATOM'S VALUE CELL
 785 SCHPOP: POP     P,0             ;RESTORE 0
 786         POPJ    P,
 787
 788 NPOPJ:  POP     P,0             ;RESTORE 0
 789 UNPOPJ: MOVSI   A,TUNBOUND
 790         MOVEI   B,0
 791         POPJ    P,0
 792
 793 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
 794 ;IDENTIFIER PASSED TO IT IN A AND B.  IF THE IDENTIFIER IS GLOBALLY
 795 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
 796
 797 \rIGLOC: MOVSI   A,TLOCI         ;DO WE HAVE A LOCATIVE TO
 798         CAME    A,(B)           ;A PROCESS #0 VALUE?
 799         JRST    SCHGSP          ;NO -- SEARCH
 800         MOVE    B,1(B)          ;YES -- GET VALUE CELL
 801         POPJ    P,
 802
 803 SCHGSP: MOVE    D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR
 804
 805 SCHG1:  JUMPGE  D,UNPOPJ        ;IF NO MORE, LEAVE
 806         CAMN    B,1(D)          ;ARE WE FOUND?
 807         JRST    GLOCFOUND       ;YES
 808         ADD     D,[4,,4]        ;NO -- TRY NEXT
 809         JRST    SCHG1
 810
 811 GLOCFOUND:      EXCH    B,D             ;SAVE ATOM PTR
 812         ADD     B,[2,,2]        ;MAKE LOCATIVE
 813         MOVEM   A,(D)           ;CLOBBER IT AWAY
 814         MOVEM   B,1(D)
 815         POPJ    P,
 816
 817
 818 \f
 819
 820 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
 821 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
 822 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B.  CALL - PUSHJ P,IVAL
 823
 824 ILVAL:
 825         PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
 826 CHVAL:  CAMN    A,$TUNBOUND     ;BOUND
 827         POPJ    P,              ;NO -- RETURN
 828         MOVE    A,(B)           ;GET THE TYPE OF THE VALUE
 829         MOVE    B,1(B)          ;GET DATUM
 830         POPJ    P,
 831
 832 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
 833
 834 IGVAL:  PUSHJ   P,IGLOC
 835         JRST    CHVAL
 836
 837
 838 \fMFUNCTION BIND,FSUBR
 839         ENTRY   1
 840         GETYP   A,(AB)
 841         CAIE    A,TLIST         ;ARG MUST BE LIST
 842         JRST    WTYP
 843         SKIPN   C,1(AB)         ;C _ BODY
 844         JRST    TFA             ;NON-EMPTY
 845         PUSH    TP,$TLIST
 846         PUSH    TP,C
 847         PUSH    TP,(C)          ;EVAL FIRST ELEMENT
 848         HLLZS   (TP)
 849         PUSH    TP,1(C)
 850         JSP     E,CHKARG
 851         MCALL   1,EVAL
 852         PUSH    TP,A
 853         PUSH    TP,B            ;SAVE VALUE
 854         GETYP   A,A             ;WHICH MUST BE LIST
 855         PUSHJ   P,SAT
 856         CAIE    A,S2WORD
 857         JRST    WTYP
 858         HRRZ    C,-2(TP)        ;C _ <REST .C>
 859         HRRZ    C,(C)
 860         JUMPE   C,NOBODY        ;MUST NOT BE EMPTY
 861         PUSH    TP,(C)          ;EVALUATE FIRST ELEMENT
 862         HLLZS   (TP)
 863         PUSH    TP,1(C)
 864         JSP     E,CHKARG
 865         MCALL   1,EVAL
 866         MOVEI   D,              ;ASSUME AUX
 867         PUSH    P,[AUX]
 868         GETYP   A,A
 869         CAIN    A,TFALSE        ;CAN BE #FALSE OR LIST
 870         JRST    DOBI            ;IF <>, AUXILIARY BINDINGS
 871         PUSHJ   P,SAT           ;OTHERWISE, TAKE SECOND ARG AS ARGLIST
 872         CAIE    A,S2WORD
 873         JRST    WTYP
 874         MOVEI   D,(B)           ;D _ DECLARATIONS
 875         SETZM   (P)             ;CLEAR SWITCHES
 876 DOBI:   POP     TP,C            ;RESTORE C _ FIRST ARG
 877         SUB     TP,[1,,1]
 878         MOVEI   0,              ;NO CALL
 879         PUSHJ   P,BINDEV
 880         HRRZ    C,1(AB)
 881         HRRZ    C,(C)
 882         HRRZ    C,(C)           ;C _ <REST <REST .ARG>>
 883         JRST    BIPROG          ;NOW EXECUTE BODY AS PROG\f;BINDER - THIS SUBROUTINE PROCESSES FUNCTION DECLARATIONS AND BINDS
 884 ;       ARGUMENTS       AND TEMPORARIES APPROPRIATELY.
 885 ;
 886 ;       CALL:   PUSHJ   P,BINDER OR BINDRR
 887 ;
 888 ;       BINDER - TAKES SWITCHES AND EVALER AS ARGS ON P
 889 ;
 890 ;       BINDEV - ASSUMES ARGS ARE TO BE EVALED
 891 ;
 892 ;       BINDRR - RESUME HACK - ARGS ON A LIST TO BE
 893 ;               EVALED IN PARENT PROCESS
 894 ;
 895
 896 ;       C/      POINTS TO FUNCTION BEING HACKED
 897 ;       D/      POINTS TO ARG LIST
 898 ;       0/      IF NON-ZERO POINTS TO EXPRESSION GENREATING CALL
 899 ;
 900 ;EVALER IS STORED ON THE STACK P AND USED TO EVALUATE ARGS WHEN NEEDED
 901 EVALER==-1
 902
 903 ;SWTCHS,STORED ON THE STACK, HOLDS MANY SWITCHES:
 904 SWTCHS==-2
 905
 906 OPT==1          ;ON IFF ARGUMENTS MAY BE OMITTED
 907 QUO==2          ;ON IFF ARGUMENT IS TO BE QUOTED
 908 AUX==4          ;ON IFF BINDING "AUX" VARS
 909 H==10           ;ON IFF THERE EXISTS A HEWITT ATOM
 910 DEF==20         ;ON IFF DEFAULT VALUE OF AN ARG HAS BEEN TAKEN
 911 STC==40         ;ON IFF "STACK" APPEARS IN DECLARATIONS
 912 BINDEV: POP     P,A             ;A _ RETURN ADDRESS
 913         PUSH    P,[ARGEV]
 914         JRST    BIND1
 915 BINDRR: POP     P,A
 916         PUSH    P,[NOTIMP]
 917 BIND1:  PUSH    P,A             ;REPUSH ADDRESS
 918 BINDER: PUSH    TP,$TLIST
 919         PUSH    TP,0            ;SAVE CALL, IF ANY
 920         PUSHJ   P,BNDVEC        ;E _ TOP OF BINDING STACK
 921         GETYP   A,(C)
 922         CAIE    A,TATOM         ;HEWITT ATOM?
 923         JRST    BIND2
 924         MOVSI   A,TBIND
 925         MOVEM   A,-6(B)         ;BUILD BIND BLOCK FOR ATOM
 926         MOVE    A,1(C)          ;A _ HEWITT ATOM
 927         MOVEM   A,-5(B)
 928         MOVE    A,TB
 929         HLL     A,OTBSAV(TB)    ;A _ POINTER TO THIS ACTIVATION
 930         MOVEM   A,-3(B)
 931         MOVEI   0,(PVP)
 932         HLRE    A,PVP
 933         SUBI    0,-1(A)         ;0 _ PROCESS VEC DOPE WORD
 934         HRLI    0,TACT          ;0 IS FIRST WORD OF ACT VALUE
 935         MOVEM   0,-4(B)         ;STORED IN BIND BLOCK
 936         HRRZ    C,(C)           ;CDR THE FUNCTION
 937 BIND2:  POP     TP,0            ;0 _ CALLING EXPRESSION
 938         SUB     TP,[1,,1]
 939         PUSHJ   P,CARLST        ;C _ DECLS LIST
 940         JRST    BINDC           ;IF (), QUIT
 941         MOVE    B,SWTCHS(P)
 942         TRNE    B,STC           ;CDR PAST "STACK" IF IT APPEARS
 943         HRRZ    C,(C)
 944         TRNE    B,AUX
 945         JRST    AUXDO           ;IN CASE OF PROG, GO TO AUXDO
 946         MOVEI   A,(C)
 947         JUMPE   A,BINDC         ;IF NO DECLS, TRY QUITTING
 948         PUSHJ   P,NXTDCL        ;B _ NEXT STRING
 949         JRST    BINDRG          ;ATOM INSTEAD
 950         HRRZ    C,(C)           ;CDR DECLS
 951
 952
 953 ;CHECK FOR "BIND"
 954
 955         CAME    B,[ASCII /BIND/ ]
 956         JRST    CHCALL
 957         JUMPE   C,MPD           ;GOT "BIND", NOW...
 958         PUSHJ   P,CARATE        ;GET ATOM & START BIND BLOCK
 959         HRLZI   A,TENV
 960         MOVE    B,1(SP)         ;B _ ENV BEFORE BNDVEC
 961         PUSHJ   P,PSHBND        ;FINISH BIND BLOCK
 962         HRRZ    C,(C)
 963         JUMPE   C,BINDC         ;MAY BE DONE
 964         MOVEI   A,(C)
 965         PUSHJ   P,NXTDCL        ;NEXT ONE
 966         JRST    BINDRG          ;ATOM INSTEAD
 967         HRRZ    C,(C)           ;CDR DECLS
 968
 969 ;CHECK FOR "CALL"
 970
 971 CHCALL: CAME    B,[ASCII /CALL/ ]
 972         JRST    CHOPTI          ;GO INTO MAIN BINDING LOOP
 973         JUMPE   0,MPD           ;GOT "CALL", SO 0 MUST BE CALL
 974         JUMPE   C,MPD
 975         PUSHJ   P,CARATE        ;GET ATOM & START BIND BLOCK\f   MOVE    B,0             ;B _ CALL
 976         MOVSI   A,TLIST
 977         PUSHJ   P,PSHBND        ;MAKE BIND BLOCK
 978         HRRZ    C,(C)           ;CDR PAST "CALL" ATOM
 979         JUMPE   C,BINDC         ;IF DONE, QUIT
 980
 981 ;DECLLP IS THE MAIN BINDING LOOP FOR HANDLING FUNCTIONAL ARGUMENTS AND
 982 ;THE STRINGS SCATTERED THEREIN
 983
 984 DECLLP: MOVEI   A,(C)
 985         PUSHJ   P,NXTDCL        ;NEXT STRING...
 986         JRST    BINDRG          ;...UNLESS SOMETHING ELSE
 987         HRRZ    C,(C)           ;CDR DECLARATIONS
 988 CHOPTI: TRZ     B,1             ;GOD KNOWS WHY TRZ B,1 (SOMETHING TO DO WITH OPTIO)
 989
 990 ;CHECK FOR "OPTIONAL"
 991
 992         CAME    B,[ASCII /OPTIO/]
 993         JRST    CHREST
 994         MOVE    0,SWTCHS(P)     ;OPT _ ON
 995         TRO     0,OPT
 996         MOVEM   0,SWTCHS(P)
 997         JUMPE   C,BINDC
 998         PUSHJ   P,EBINDS        ;BIND ALL PREVIOUS ARGUMENTS
 999         JRST    DECLLP
1000
1001 ;CHECK FOR "REST"
1002
1003 CHREST: MOVE    0,SWTCHS(P)     ;0 _ SWITCHES
1004         TRZ     0,OPT           ;OPT _ OFF
1005         MOVEM   0,SWTCHS(P)
1006         MOVEI   A,(C)
1007         CAME    B,[ASCII /REST/]
1008         JRST    CHTUPL
1009         PUSHJ   P,NXTDCL        ;GOT "REST"-- LOOK AT NEXT THING
1010         SKIPN   C
1011         JRST    MPD             ;WHICH CAN'T BE STRING
1012         PUSHJ   P,BINDB         ;GET NEXT ATOM
1013         TRNE    0,QUO           ;QUOTED?
1014         JRST    ARGSDO          ;YES-- JUST USE ARGS
1015         JRST    TUPLDO
1016
1017 ;CHECK FOR "TUPLE"
1018
1019 CHTUPL: CAME    B,[ASCII /TUPLE/]
1020         JRST    CHARG
1021         PUSHJ   P,NXTDCL        ;GOT "TUPLE"-- LOOK AT NEXT THING
1022         SKIPN   C
1023         JRST    MPD
1024         PUSHJ   P,CARATE        ;WHICH BETTER BE ATOM
1025
1026 TUPLDO: PUSH    TP,$TLIST       ;SAVE STUFF
1027         PUSH    TP,C
1028         PUSH    TP,$TVEC
1029         PUSH    TP,E
1030         PUSH    P,[0]           ;ARG COUNTER\f;THIS LOOP BUILDS A TUPLE ON THE STACK, ON THE TOP OF THE ENTITIES
1031 ;JUST SAVED-- DON'T WORRY; THEY'RE SAFE
1032
1033 TUPLP:  JUMPE   D,TUPDON        ;IF NO MORE ARGS, DONE
1034         INTGO                   ;WATCH OUT FOR BIG TUPLES AND SMALL STACKS
1035         PUSH    TP,$TLIST       ;SAVE D
1036         PUSH    TP,D
1037         GETYP   A,(D)           ;GET NEXT ARG
1038         MOVSI   A,(A)
1039         PUSH    TP,A            ;EVAL IT
1040         PUSH    TP,1(D)
1041         TRZ     0,DEF           ;OFF DEFAULT
1042         PUSHJ   P,@EVALER-1(P)
1043         POP     TP,D            ;RESTORE D
1044         SUB     TP,[1,,1]
1045         PUSH    TP,A            ;BUILD TUPLE
1046         PUSH    TP,B
1047         SOS     (P)             ;COUNT ELEMENTS
1048         HRRZ    D,(D)           ;CDR THE ARGS
1049         JRST    TUPLP
1050 TUPDON: PUSHJ   P,MRKTUP        ;MAKE A TUPLE OF (P) ENTRIES
1051         SUB     P,[1,,1]        ;FLUSH COUNTER
1052         JRST    BNDRST\f;CHECK FOR "ARGS"
1053
1054 CHARG:  CAME    B,[ASCII /ARGS/]
1055         JRST    CHAUX
1056         PUSHJ   P,NXTDCL        ;GOT "ARGS"-- CHECK NEXT THING
1057         SKIPN   C
1058         JRST    MPD
1059         PUSHJ   P,CARATE        ;WHICH MUST BE ATOM
1060
1061 ;HERE TO BIND AN ATOM TO THE REMAINING ARGS, UNEVALUATED
1062
1063 ARGSDO: MOVSI   A,TLIST         ;(A,B) _ CURRENT ARGS LEFT
1064         MOVE    B,D
1065         MOVEI   D,
1066
1067 ;BNDRST COMPLETES THE BIND BLOCK FOR BOTH TUPLES AND ARGS
1068
1069 BNDRST: PUSHJ   P,PSHBND
1070         HRRZ    C,(C)           ;CDR THE DECLS
1071         JUMPE   C,BINDC
1072         MOVEI   A,(C)
1073         PUSHJ   P,NXTDCL        ;WHAT NEXT?
1074         JRST    MPD             ;MUST BE A STRING OR ELSE
1075         HRRZ    C,(C)           ;CDR DECLS
1076
1077 ;CHECK FOR "AUX"
1078
1079 CHAUX:  CAME    B,[ASCII /AUX/]
1080         JRST    CHACT
1081         JUMPG   D,TMA           ;ARGS MUST BE USED UP BY NOW
1082         PUSH    P,C             ;SAVE C ON P (NO GC POSSIBLE)
1083         PUSHJ   P,EBIND         ;BIND ALL ARG ATOMS
1084         POP     P,C             ;RESTORE C
1085
1086 ;HERE FOR AUXIES OF "AUX" OR PROG VARIETY
1087
1088 AUXDO:  MOVE    0,SWTCHS(P)
1089         TRO     0,AUX\OPT\DEF   ;OPTIONALS OBVIOUSLY ALLOWED
1090         MOVEM   0,SWTCHS(P)
1091 AUXLP:  JUMPE   C,BNDHAT        ;IF NO MORE, QUIT
1092         MOVEI   A,(C)
1093         PUSHJ   P,NXTDCL        ;GET NEXT DECLARATION STRING
1094         JRST    AUXIE           ;INSTEAD, ANOTHER AUXIE-- DO IT
1095         HRRZ    C,(C)           ;CDR PAST STRING
1096         JRST    CHACT1          ;...WHICH MUST BE "ACT"
1097
1098 ;NORMAL AUXILIARY DECLARATION HANDLER
1099
1100 AUXIE:  MOVE    0,SWTCHS(P)
1101         PUSH    TP,$TLIST       ;SAVE C
1102         PUSH    TP,C
1103         PUSHJ   P,BINDB         ;PUSH NEXT ATOM ONTO E
1104         MOVE    A,$TVEC         ;SAVE E UNDER DEFAULT VALUE
1105         EXCH    A,-1(TP)
1106         EXCH    E,(TP)
1107         PUSH    TP,A            ;(DEFAULT VALUE MUST BE REPUSHED)
1108         PUSH    TP,E
1109         PUSHJ   P,@EVALER(P)    ;EVAL THE VALUE IT IS TO RECEIVE
1110         POP     TP,E            ;RESTORE E
1111         SUB     TP,[1,,1]
1112         PUSHJ   P,PSHBND        ;COMPLETE BINDING BLOCK WITH VALUE
1113         PUSHJ   P,EBIND         ;BIND THE ATOM
1114         POP     TP,C            ;RESTORE C
1115         SUB     TP,[1,,1]
1116         HRRZ    C,(C)           ;CDR THE DECLARATIONS
1117         JRST    AUXLP
1118 \f;"ACT" CAN OCCUR ONLY AT THE END, HEWITT ATOMS NOTWITHSTANDING
1119
1120 CHACT1: MOVEI   D,              ;MAKE IT CLEAR THAT THERE ARE NO ARGS
1121 CHACT:  CAME    B,[ASCII /ACT/] ;ONLY THING POSSIBLE
1122         JRST    MPD
1123         JUMPE   C,MPD           ;BETTER HAVE AN ATOM TO BIND TO ACT
1124         PUSHJ   P,CARATE        ;START BIND BLOCK WITH IT
1125         MOVEI   A,(PVP)
1126         HLRE    B,PVP
1127         SUBI    A,-1(B)         ;A _ PROCESS VEC DOPE WORD
1128         HRLI    A,TACT
1129         MOVE    B,TB
1130         HLL     B,OTBSAV(TB)    ;(A,B) _ ACTIVATION POINTER
1131         PUSHJ   P,PSHBND
1132         HRRZ    C,(C)           ;"ACT" MUST HAVE BEEN LAST
1133         JUMPN   C,MPD
1134
1135 ;AT THIS POINT, ALL ENTRIES ARE FINAL AND ALL THINGS LOOSED
1136 ;IN E SHALL BE BOUND IN E, EVENTUALLY
1137
1138 BINDC:  JUMPG   D,TMA           ;ARGS SHOULD BE USED UP BY NOW
1139         PUSHJ   P,EBIND         ;BIND EVERYTHING NOT BOUND
1140 BNDHAT: MOVE    0,SWTCHS(P)     ;EVEN THE HEWITT ATOM
1141         TRNN    0,H             ;IF THERE IS ONE
1142         JRST    BNDRET
1143         ADD     E,[2,,2]        ;E _ POINTER TO SECOND WORD OF NEXT BLOCK
1144         PUSHJ   P,COMBLK        ;CHAIN THIS BLOCK TO PREVIOUS THING IN VECTOR
1145         ADD     E,[4,,4]        ;E _ LAST WORD OF BINDING VECTOR
1146         PUSHJ   P,EBIND         ;BIND THE HEWITT ATOM
1147
1148 ;THIS IS THE WAY OUT OF THE BINDER
1149
1150 BNDRET: SUB     P,[2,,2]        ;FLUSH EVALER
1151         POP     P,A             ;A _ SWITCHES
1152         JRST    @3(P)           ;RETURN FROM BINDER\f;TO BIND A PERFECTLY ORDINARY ARGUMENT SPECIFICATION
1153 ;FOUND IN A DECLS LIST, JUMP HERE
1154
1155 BINDRG: MOVE    0,SWTCHS(P)
1156         PUSHJ   P,BINDB         ;GET ATOM IN THE NEXT DECL
1157         JUMPE   D,CHOPT3        ;IF ARG EXISTS,
1158         TRNE    0,OPT
1159         SUB     TP,[2,,2]       ;PITCH ANY DEFAULT THAT MAY EXIST
1160         GETYP   A,(D)           ;(A,B) _ NEXT ARG
1161         MOVSI   A,(A)
1162         MOVE    B,1(D)
1163         HRRZ    D,(D)           ;CDR THE ARGS
1164         TRZN    0,QUO           ;ARG QUOTED?
1165         JRST    BNDRG1          ;NO-- GO EVAL
1166 CHDEFR: MOVEM   0,SWTCHS(P)
1167         CAME    A,$TDEFER       ;QUOTED-- PUNT ANY TDEFER'S YOU FIND
1168         JRST    DCLCDR
1169         GETYP   A,(B)           ;(A,B) _ REAL POINTER, NOT DEFERRED
1170         MOVE    B,1(B)
1171         JRST    DCLCDR          ;AND FINISH BIND BLOCK
1172
1173 ;OPTIONAL ARGUMENT?
1174
1175 CHOPT3: TRNN    0,OPT           ;IF NO ARG, BETTER BE OPTIONAL
1176         JRST    TFA
1177         POP     TP,B            ;(A,B) _ DEFAULT VALUE
1178         POP     TP,A
1179         TRZE    0,QUO           ;IF QUOTED,
1180         JRST    CHDEFR          ;JUST PUSH
1181         TRO     0,DEF           ;ON DEFAULT
1182
1183 ;EVALUATE WHATEVER YOU HAVE AT THIS POINT
1184
1185 BNDRG1: PUSH    TP,$TLIST       ;SAVE STUFF
1186         PUSH    TP,D
1187         PUSH    TP,$TLIST
1188         PUSH    TP,C
1189         PUSH    TP,$TVEC
1190         PUSH    TP,E
1191         PUSH    TP,A
1192         PUSH    TP,B
1193         PUSHJ   P,@EVALER(P)    ;(A,B) _ <EVAL (A,B)>
1194         MOVE    E,(TP)          ;RESTORE C, D, & E
1195         MOVE    C,-2(TP)
1196         MOVE    D,-4(TP)
1197         SUB     TP,[6,,6]
1198         MOVE    0,SWTCHS(P)     ;RESTORE 0
1199
1200
1201 ;FINISH THE BIND BLOCK WITH (A,B) AND GO ON
1202
1203 DCLCDR: PUSHJ   P,PSHBND
1204         TRNE    0,OPT           ;IF OPTIONAL,
1205         PUSHJ   P,EBINDS        ;BIND IT
1206         HRRZ    C,(C)
1207         JUMPE   C,BINDC         ;IF NO MORE DECLS, QUIT
1208         JRST    DECLLP\f;THIS ROUTINE CREATES THE BIND BLOCK BINDER USES; IT ALLOCATES
1209 ;THREE SLOTS PER NON-STRING DECLARATION (I.E., ATOM TO BE BOUND),
1210 ;THREE FOR A HEWITT ATOM IF IT FINDS ONE, AND ONE FOR THE ACCESS
1211 ;TYPE-TSP POINTER TO SP.
1212
1213 ;THE BLOCK IS ALLOCATED AS A TUPLE IF "STACK" APPEARS
1214 ;FIRST IN THE DECLARATIONS, AS A VECTOR OTHERWISE
1215
1216
1217 ;BNDVEC SETS E TO THE CURRENT TOP OF THE BLOCK; IT FILLS IN
1218 ;ACCESS SLOT WITH SP, AND SETS SP TO POINT TO
1219 ;THE START OF THIS BLOCK.  IT SETS B TO POINT TO THE DOPE CELL
1220 ;OF THE TUPLE OR VECTOR.  IT MAY SET SWITCHES H OR STC TO ON,
1221 ;IFF IT FINDS A HEWITT ATOM OR A "STACK".  IT CLOBBERS A,
1222 ;RESTORES C & D, AND LEAVES THE SWITCHES IN 0
1223
1224 ;IF BNDVEC FINDS NO DECLARATIONS, IT TAKES THE LIBERTY OF EXITING
1225 ;FROM THE BINDER WITHOUT DISTURBING SP.  BNDVEC DOES SOME ERROR
1226 ;CHECKING, BUT NOT ALL, AS IT DOES NOT LOOK AT THE ARGS IN D.
1227 ;THIS EXPLAINS WHY BINDER OMITS SOME.
1228
1229 BNDVEC: PUSH    TP,$TLIST       ;SAVE C & D
1230         PUSH    TP,C
1231         PUSH    TP,$TLIST
1232         PUSH    TP,D
1233         JUMPE   C,NOBODY
1234         MOVE    0,SWTCHS-1(P)   ;UNBURY THE SWITCHES
1235         MOVEI   D,              ;D = COUNTER _ 0
1236         GETYP   A,(C)           ;A _ FIRST THING
1237         CAIE    A,TATOM         ;HEWITT ATOM?
1238         JRST    NOHATM
1239         TRO     0,H             ;TURN SWITCH H ON
1240         ADDI    D,3             ;YES-- SAVE 3 SLOTS FOR IT
1241         HRRZ    C,(C)           ;CDR THE FUNCTION
1242         JUMPE   C,NOBODY
1243 NOHATM: PUSHJ   P,CARLST        ;C _ <1 .C>
1244         JRST    CNTRET          ;IF (), ALL COUNTED
1245         MOVEI   A,(C)           ;A _ DECLS
1246         PUSHJ   P,NXTDCL        ;LOOK FOR "STACK"
1247         JRST    DINC            ;NO STRING
1248         TRZ     B,1
1249         CAMN    B,[ASCII /STACK/]
1250         TRO     0,STC           ;TURN ON STACK SWITCH
1251
1252 ;HERE IS THE QUICK LOOP THROUGH THE DECLARATIONS
1253
1254 DCNTLP: HRRZ    A,(A)           ;CDR DECLS
1255         JUMPE   A,CNTRET        ;IF NO MORE, DONE
1256         PUSHJ   P,NXTDCL        ;SKIP IF NEXT ONE IS A STRING
1257 DINC:   ADDI    D,3             ;3 SLOTS FOR AN ATOM
1258         JRST    DCNTLP
1259
1260 ;IF ANYTHING WAS FOUND, INITIALIZE THE VECTOR
1261
1262 CNTRET: JUMPE   D,NODCLS        ;OTHERWISE, BIND NOTHING
1263         AOJ     D,              ;DON'T FORGET ACCESS SLOT
1264         MOVEM   0,SWTCHS-1(P)   ;SAVE SWITCHES
1265         TRNE    0,STC           ;FOUND "STACK"?
1266         JRST    TUPBND
1267         PUSH    TP,$TFIX
1268         PUSH    TP,D
1269         MCALL   1,VECTOR        ;B _ <VECTOR .D>
1270         MOVE    E,B             ;FROM NOW ON, E _ BIND VECTOR TOP
1271         HLRE    C,B
1272         SUB     B,C             ;B _ VECTOR DOPE CELL ADDRESS
1273 SETSP:  MOVE    A,E
1274         MOVSI   0,TSP
1275         MOVEM   0,(E)           ;FILL ACCESS SLOT
1276         PUSH    E,SP
1277         MOVE    SP,A            ;SP NOW POINTS THROUGH THIS VECTOR
1278         MOVE    D,(TP)          ;RESTORE C & D
1279         MOVE    C,-2(TP)
1280         SUB     TP,[4,,4]
1281         POPJ    P,
1282
1283 ;IF THERE ARE NO DECLS (E.G. <FUNCTION ()...>), JUST QUIT
1284
1285 NODCLS: MOVE    D,(TP)          ;RESTORE C & D
1286         MOVE    C,-2(TP)
1287         SUB     TP,[6,,6]
1288         SUB     P,[1,,1]        ;PITCH RETURN ADDRESS
1289         JRST    BNDRET\f;HERE TO BIND BUGGERS ON STACK
1290
1291 TUPBND: LSH     D,1             ;D _ 2*NUMBER OF CELLS
1292         MOVN    C,D             ;SAVE -D ON P
1293         PUSH    P,C
1294         ADDI    D,2             ;2 MORE FOR TTB MARKER
1295         HRLI    D,(D)
1296         MOVE    C,TP
1297         ADD     TP,D            ;TP _ ADDRESS OF LAST TUPLE WORD
1298         ADD     C,[1,,1]        ;C _ ADDRESS OF FIRST WORD OF TUPLE
1299         MOVSI   0,TTP
1300         MOVEM   0,CSTO(PVP)     ;IN CASE OF GC
1301         SETZM   (C)             ;ZERO IT
1302         MOVE    D,C
1303         HRLI    D,(D)
1304         ADDI    D,1             ;ZERO ENTIRE TUPLE SPACE
1305         HRRZI   E,(TP)          ;BUT--
1306         HLRE    B,TP            ;   IF TP BLOWN,
1307         SKIPLE  B               ;    ZERO ONLY UP TO END OF PDL
1308         SUBI    E,1(B)
1309         BLT     D,(E)
1310         SKIPL   TP              ;IF BLOWN,
1311         PUSHJ   P,NBLOTP        ;NOW SAFE TO UNBLOW IT
1312         SETZM   CSTO(PVP)
1313         MOVEI   D,-5(TP)
1314         HRLI    D,-6(C)
1315         BLT     D,(TP)          ;MOVE SAVED 0, C & D TO TOP OF STACK
1316         POP     P,D
1317         HRLI    D,TTB           ;D _ [TTB,,-LENGTH]
1318         MOVEI   B,-7(TP)        ;B _ POINTER TO TUPLE DOPE CELL
1319         MOVEM   D,(B)
1320         MOVEM   TB,1(B) ;FENCEPOST TUPLE
1321         MOVE    E,C             ;E _ POINTER TO TUPLE START
1322         SUB     E,[6,,6]        ;     ON TP STACK
1323         HLRE    D,C
1324         SUB     C,D             ;C = DOPE WORD POINTER?
1325         CAME    C,TPGROW"
1326         ADD     E,[-PDLBUF,,0]  ;MAKE E TRUE VECTOR POINTER
1327         JRST    SETSP\f;THIS ROUTINE CREATES A POINTER TO THE TUPLE RESTING ON TOP OF
1328 ;TP.  IT TAKES ITS NEGATIVE LENGTH (IN CELLS) IN (P).  IT ASSUMES
1329 ;THERE ARE TWO TEMPORARY CELLS BENEATH IT, AND RESTORES
1330 ;THEM INTO C AND E, MOVING THE TUPLE OVER THE TEMPORARY
1331 ;SLOTS.  IT RETURNS A CORRECT TARGS POINTER TO THE TUPLE IN A AND B
1332
1333 MRKTUP: MOVSI   A,TTB           ;FENCE-POST TUPLE
1334         PUSH    TP,A
1335         PUSH    TP,TB
1336         MOVEI   A,2             ;B_ADDRESS OF INFO CELL
1337         PUSHJ   P,CELL"         ;MAY CALL AGC
1338         MOVSI   A,TINFO
1339         MOVEM   A,(B)
1340         MOVEI   A,(TP)          ;GENERATE DOPE WORD POINTER
1341         HLRE    C,TP
1342         SUBI    A,-1(C)
1343         CAME    A,TPGROW"       ;ALLOWING FOR BLOWN PDL
1344         ADDI    A,PDLBUF
1345         HRLZI   A,-1(A)         ;A HAS 1ST DW PTR IN LEFT HALF
1346         HLR     A,OTBSAV(TB)    ;TIME TO RIGHT
1347         MOVEM   A,1(B)          ;TO SECOND WORD OF CELL
1348         EXCH    B,-1(P)         ;B _ - ARG COUNT
1349         ASH     B,1             ;B _ 2*B
1350         HRRM    B,-1(TP)        ;STORE IN TTB FENCEPOST
1351         HRRZI   A,-5(TP)
1352         ADD     A,B             ;A _ ADR OF TUPLE
1353         HRLI    A,(B)           ;A _ TUPLE POINTER
1354         MOVE    B,A             ;B, TOO
1355         HRLI    A,4(A)          ;LH A _ CURRENT PLACE OF TUPLE
1356         MOVE    C,1(A)          ;RESTORE C AND E
1357         MOVE    E,3(A)
1358         BLT     A,-4(TP)        ;MOVE TUPLE OVER OLD C, E COPIES
1359         SUB     TP,[4,,4]
1360         MOVE    A,-1(P)
1361         HRLI    A,TARGS         ;A _ FIRST WORD OF ARGS TUPLE VALUE
1362         POPJ    P,\f;THIS ROUTINE, GIVEN SWTCHS IN 0 AND DECLARATIONS LIST POINTER
1363 ;IN C, PUSHES ATOM IN THE FIRST DECLARATION ONTO E.  IT MAY SET
1364 ;SWITCHES OPT AND QUO, AND LEAVES SWITCHES IN 0.    IFF OPT = ON,
1365 ;BINDB PUSHES A DEFAULT VALUE (EVEN IF ?()) ONTO TP.  A & B ARE
1366 ;CLOBBERED.  C IS NOT ALTERED.
1367
1368 BINDB:  MOVE    A,C             ;A _ C
1369         GETYP   B,(A)
1370         CAIE    B,TLIST         ;A = ((...)...) ?
1371         JRST    CHOPT1
1372         TRNN    0,OPT           ;YES-- OPT MUST BE ON
1373         JRST    MPD
1374         MOVEM   0,SWTCHS-1(P)   ;SAVE SWITCHES
1375         MOVE    A,1(A)          ;A _ <1 .A> = (...)
1376         JUMPE   A,MPD           ;A = () NOT ALLOWED
1377         HRRZ    B,(A)           ;B _ <REST .A>
1378         JUMPE   B,MPD           ;B = () NOT ALLOWED
1379         PUSH    TP,(B)          ;SAVE <1 .B> AS DEFAULT
1380         PUSH    TP,1(B)         ;VALUE OF ATOM IN A
1381         HRRZ    B,(B)
1382         JUMPN   B,MPD           ;<REST .B> MUST = ()
1383         GETYP   B,(A)
1384         JRST    CHFORM          ;GO SEE WHAT <1 .A> IS
1385
1386 CHOPT1: TRNN    0,OPT           ;IF OPT = ON
1387         JRST    CHFORM
1388         PUSH    TP,$TUNAS       ;DEFAULT VALUE IS ?()
1389         PUSH    TP,[0]
1390
1391 ;AT THIS POINT, <1 .A> MUST BE ATOM OR <QUOTE ATOM>
1392
1393 CHFORM: TRNE    0,AUX           ;NO QUOTES ALLOWED IN AUXIES
1394         JRST    CHATOM
1395         CAIE    B,TFORM
1396         JRST    CHATOM
1397         MOVE    A,1(A)          ;A _ <1 .A> = <...>
1398         JUMPE   A,MPD           ;A = <> NOT ALLOWED
1399         MOVE    B,1(A)          ;B _ <1 .A>
1400         CAME    B,MQUOTE QUOTE
1401         JRST    MPD             ;ONLY A = <QUOTE...> ALLOWED
1402         TRO     0,QUO           ;QUO _ ON
1403         MOVEM   0,SWTCHS-1(P)
1404         HRRZ    A,(A)           ;A _ <REST .A>
1405         JUMPE   A,MPD           ;<QUOTE> NOT ALLOWED
1406         GETYP   B,(A)
1407
1408 ;AT THIS POINT WE HAVE THE ATOM OR AN ERROR
1409
1410 CHATOM: CAIE    B,TATOM         ;<1 .A> MUST BE ATOM
1411         JRST    MPD
1412         MOVE    A,1(A)          ;A _ THE ATOM!!!
1413         JRST    PSHATM          ;WHICH MUST BE PUSHED ONTO E
1414
1415
1416
1417 ;THE FOLLOWING LITTLE ROUTINE ACCEPTS THE NEXT DECLARATION ONLY
1418 ;IF IT IS ATOMIC, AND PUSHES IT ONTO E
1419
1420 CARATE: GETYP   A,(C)
1421         CAIE    A,TATOM
1422         JRST    MPD
1423         MOVE    A,1(C)          ;A _ ATOM
1424         MOVE    0,SWTCHS-1(P)
1425 PSHATM: PUSH    E,$TBIND        ;FILL FIRST TWO SLOTS OF BIND BLOCK
1426         PUSH    E,A
1427
1428 ;EACH BIND BLOCK MUST POINT TO THE PREVIOUS ONE OR TO AN ACCESS
1429 ;POINTER TO ANOTHER VECTOR ALTOGETHER.  COMBLK MAKES SURE IT DOES.
1430
1431 COMBLK: GETYP   B,-7(E)         ;LOOK FOR PREVIOUS BIND
1432         CAIE    B,TBIND         ;IF FOUND, MAKE NORMAL LINK
1433         JRST    ABNORM
1434         MOVEI   B,-7(E)         ;IN MOST CASES, SEVEN
1435 MAKLNK: HRRM    B,-1(E)         ;MAKE THE LINK
1436         POPJ    P,
1437 ABNORM: MOVEI   B,-3(E)
1438         JRST    MAKLNK
1439 \f;THIS ROUTINE COMPLETES A BIND BLOCK BEGUN BY CARATE OR BINDB
1440 ;WITH THE VALUE (A,B)
1441
1442 PSHBND: PUSH    E,A
1443         PUSH    E,B
1444         ADD     E,[2,,2]        ;ASSUME BIND VECTOR IS FULL OF 0'S
1445         POPJ    P,
1446
1447 ;THIS ONE DOES AN EBIND, SAVING C & D:
1448
1449 EBINDS: PUSH    P,C             ;SAVE C & D (NO DANGER OF GC)
1450         PUSH    P,D
1451         PUSHJ   P,EBIND         ;BIND ALL NON-OPTIONAL ARGUMENTS
1452         POP     P,D
1453         POP     P,C             ;RESTORE C & D
1454         POPJ    P,
1455
1456
1457 ;THE FOLLOWING RETURNS THE CAR OF C IN C, SKIPPING IF
1458 ;<EMPTY? <1 .C>>, AND ERRING IF <NOT <==? <TYPE <1 .C>> LIST>>
1459
1460 CARLST: GETYP   A,(C)
1461         CAIE    A,TLIST
1462         JRST    MPD             ;NOT A LIST, FATAL
1463         SKIPE   C,1(C)
1464         AOS     (P)
1465         POPJ    P,
1466
1467
1468 ;...AND THERE ARE A FEW PEOPLE STILL CALLING THE FOLLOWING:
1469
1470 MAKENV: PUSH    P,C             ;SAVE AN AC
1471         HLRE    C,PVP           ;GET -LNTH OF PROC VECTOR
1472         MOVEI   A,(PVP)         ;COPY PVP
1473         SUBI    A,-1(C)         ;POINT TO DOPWD WITH A
1474         HRLI    A,TFRAME        ;MAKE INTO A FRAME
1475         HLL     B,OTBSAV(B)     ;TIME TO B
1476         POP     P,C
1477         POPJ    P,
1478
1479
1480
1481 \f;THESE ROUTINES ARE CALLED TO EVALUATE THE VALUE PUSHED
1482 ;ON TP    ****THEY ARE ASSUMED TO CLOBBER EVERYTHING****
1483
1484 ARGEV:  JSP     E,CHKARG
1485         MCALL   1,EVAL
1486         POPJ    P,
1487
1488
1489
1490
1491 ;WHEN APPLY-ING, ARGS ARE ALREADY EVALUATED
1492
1493 ARGNEV: JSP     E,CHKARG        ;PITCH ANY TDEFERS
1494         TRNN    0,DEF           ;DEFAULT VALUES...
1495         JRST    NOEV
1496         MCALL   1,EVAL          ;...ARE ALWAYS EVALUATED
1497         POPJ    P,
1498 NOEV:   POP     TP,B            ;OTHERWISE,
1499         POP     TP,A            ;JUST RESTORE A&B
1500         POPJ    P,\f;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
1501 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
1502 ;EACH TRIPLET IS AS FOLLOWS:
1503 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
1504 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
1505 ;AND THE THIRD IS A PAIR OF ZEROES.
1506 ;FOR ENTRY SPECB1, REGISTER 0 CONTAINS SWITCHES.  ONLY RELEVANT ONE
1507 ;IS STC.
1508
1509
1510 BNDA:   TATOM,,-1
1511
1512 SPECBIND:       MOVEI   0,              ;DEFAULT IS STC _ OFF
1513 SPECB1: MOVE    E,TP            ;GET THE POINTER TO TOP
1514         ADD     E,[1,,1]        ;BUMP POINTER ONCE
1515         MOVEI   B,              ;ZERO COUNTER
1516         MOVE    D,E
1517 SZLOOP: MOVE    A,-6(D)         ;COUNT ATOM BLOCKS AS 3
1518         CAME    A,BNDA
1519         JRST    GETVEC
1520         SUB     D,[6,,6]        ;D _ ADDRESS OF BOTTOM BLOCK
1521         ADDI    B,3
1522         JRST    SZLOOP
1523 GETVEC: JUMPE   B,DEGEN
1524         TRNE    0,STC           ;IF STC IS ON,
1525         JRST    TPSPCB          ;    LEAVE BLOCKS ON TP
1526         PUSH    P,B
1527         AOJ     B,
1528         PUSH    TP,$TTP
1529         PUSH    TP,E
1530         PUSH    TP,$TTP
1531         PUSH    TP,D
1532         PUSH    TP,$TFIX
1533         PUSH    TP,B
1534         MCALL   1,VECTOR        ;<VECTOR .B>
1535         POP     TP,D            ;RESTORE D = POINTER TO BOTTOM TRIPLE
1536         SUB     TP,[1,,1]
1537         MOVE    A,$TSP          ;MAKE THIS BLOCK POINT TO PREVIOUS
1538         MOVEM   A,(B)
1539         MOVEM   SP,1(B)
1540         ADDI    B,2
1541
1542 ;MOVE TRIPLES TO VECTOR
1543
1544         POP     P,E             ;E _ LENGTH  - 1
1545         ASH     E,1             ;TIMES 2
1546         ADDI    E,(B)           ;E _ POINTER TO VECTOR DOPE WORD
1547         HRLI    A,(D)
1548         HRRI    A,(B)
1549         BLT     A,-1(E)         ;MOVE BIND TRIPLES TO VECTOR
1550
1551 ;CHANGE ALL [TATOM,,-1]'S TO [TBIND,,LINK TO PREVIOUS BLOCK]
1552
1553         HRRZI   B,(B)           ;ZERO LEFT HALF OF B
1554         HRRI    C,-2(B)         ;C = LINK _ ADR OF FIRST OF VECTOR
1555         PUSH    P,[POPOFF]
1556 LNKBLK: HRLI    C,TBIND
1557 FIXLP:  MOVEM   C,(B)           ;STORE LINK TO PREVIOUS BLOCK IN BLOCK B
1558         HRRI    C,(B)           ;C _ LINK TO THIS BLOCK
1559         ADDI    B,6
1560         CAIE    B,(E)           ;GOT TO DOPE WORD?
1561         JRST    FIXLP
1562         POPJ    P,
1563
1564 ;CLEAN UP TP
1565
1566 POPOFF: POP     TP,C
1567         SUB     TP,[1,,1]
1568         CAMLE   C,TP            ;ANYTHING ABOVE TRIPLES?
1569         JRST    NOBLT2
1570         SUBI    TP,(C)          ;TP _ NUMBER THERE
1571         HRLS    TP              ;IN BOTH HALVES
1572         ADD     TP,D            ;NEW TP
1573         HRLI    D,(C)
1574         BLT     D,(TP)          ;BLLLLLLLLT!
1575         JRST    SPCBE2
1576 DEGEN:  SUB     TP,[2,,2]
1577         POPJ,
1578 NOBLT2: MOVE    TP,D            ;OR JUST RESTORE IT
1579         SUB     TP,[1,,1]
1580         JRST    SPCBE2
1581
1582 ;HERE TO JUST BIND THE LOSERS ON THIS STACK
1583
1584 TPSPCB: AOJ     B,
1585         PUSH    TP,$TSP         ;PUSH ACCESS POINTER
1586         MOVE    E,TP
1587         PUSH    TP,SP
1588         LSH     B,1
1589         MOVN    B,B             ;B _ -2B
1590         HRLI    B,TTB
1591         PUSH    TP,B            ;FENCEPOST BIND TRIPLES AS TUPLE
1592         PUSH    TP,TB
1593         HRRZ    B,D
1594         HRRI    C,-3(TP)
1595         PUSHJ   P,LNKBLK        ;LINK BIND BLOCKS TOGETHER
1596         HLRE    C,D             ;MAKE E A REAL VECTOR POINTER
1597         SUB     D,C
1598         CAME    C,TPGROW"       ;BY FINDING REAL DOPE WORD
1599         ADD     E,[-PDLBUF,,0]
1600
1601 \f;HERE TO BIND EVERYTHING IN BLOCK WITH DOPE WORD (E)
1602
1603 SPCBE2: SUB     E,[1,,1]        ;E _ LAST WORD OF LAST BLOCK
1604
1605 ;EBIND BINDS THE ATOMS SPECIFIED BY THE BLOCK WHOSE LAST WORD
1606 ;E POINTS TO, THEN THE BLOCK LINKED TO IT, ETC., UNTIL
1607 ;IT FINDS ONE ALREADY BOUND, WHEN IT RESTORES E AND EXITS.
1608 ;IT RESETS SP TO POINT TO THE FIRST ONE BOUND.  IT CLOBBERS
1609 ;ALL OTHER REGISTERS
1610
1611 EBIND:  HLRZ    A,-1(E)
1612         SKIPE   A               ;ALREADY BOUND?
1613         POPJ    P,              ;YES-- EBIND IS A NO-OP
1614         MOVEI   D,              ;D WILL BE THE NEW SP
1615         PUSH    P,E             ;SAVE E
1616         JRST    DOBIND
1617
1618 BINDLP: HLRZ    A,-1(E)
1619         SKIPE   A               ;HAS THIS BLOCK BEEN BOUND ALREADY?
1620         JRST    SPECBD          ;YES, RESTORE AND QUIT
1621 DOBIND: SUB     E,[6,,6]
1622         SKIPN   D               ;HAS NEW SP ALREADY BEEN SET?
1623         MOVE    D,E             ;NO, SET TO THIS BLOCK FOR NOW
1624         MOVE    A,1(E)
1625         MOVE    B,2(E)
1626         PUSHJ   P,ILOC          ;(A,B) _ LOCATIVE OF (A,B)
1627         HLR     A,OTBSAV(TB)
1628         MOVEM   A,5(E)          ;CLOBBER IT AWAY
1629         MOVEM   B,6(E)          ;IN RESTORE CELLS
1630
1631         HRRZ    A,PROCID+1(PVP) ;GET PROCESS NUMBER
1632         HRLI    A,TLOCI         ;MAKE LOC PTR
1633         MOVE    B,E             ;TO NEW VALUE
1634         ADD     B,[3,,3]
1635         MOVE    C,2(E)          ;GET ATOM PTR
1636         MOVEM   A,(C)           ;CLOBBER ITS VALUE
1637         MOVEM   B,1(C)          ;CELL
1638         JRST    BINDLP
1639
1640 SPECBD: MOVE    SP,D            ;SP _ D
1641         ADD     SP,[1,,1]       ;FIX SP
1642         POP     P,E             ;RESTORE E TO TOP OF BIND VECTOR
1643         POPJ    P,
1644
1645 \f
1646
1647 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
1648 ;SPSAV (TB).  IT IS CALLED BY PUSHJ P,SPECSTORE.
1649
1650 SPECSTORE:
1651         MOVE    E,SPSAV (TB)    ;GET TARGET POINTER
1652 SPCSTE: HRRZ    SP,SP           ;CLEAR LEFT HALF OF SP
1653 STLOOP:
1654         CAIN    SP,(E)          ;ARE WE DONE?
1655         JRST    STPOPJ
1656         HLRZ    C,(SP)          ;GET TYPE OF BIND
1657         CAIE    C,TBIND         ;NORMAL IDENTIFIER?
1658         JRST    JBVEC           ;NO-- FIND & FOLLOW REBIND POINTER
1659
1660
1661         MOVE    C,1(SP)         ;GET TOP ATOM
1662         MOVE    D,4(SP)         ;GET STORED LOCATIVE
1663 \r       HRR     D,PROCID+1(PVP) ;STORE SIGNATURE
1664         MOVEM   D,(C)           ;CLOBBER INTO ATOM
1665         MOVE    D,5(SP)
1666         MOVEM   D,1(C)
1667         HRRZS   4(SP)           ;NOW LOOKS LIKE A VIRGIN BLOCK
1668         SETZM   5(SP)
1669         HRRZ    SP,(SP)         ;GET NEXT BLOCK
1670         JRST    STLOOP
1671
1672 ;IN JUMPING TO A NEW BIND VECTOR, FOLLOW
1673 ;REBIND POINTER IF IT DIFFERS FROM ACCESS POINTER
1674
1675 JBVEC:  CAIE    C,TSP           ;THIS JUST BETTER BE TRUE, THAT'S ALL
1676         .VALUE  [ASCIZ /BADSP/]
1677         GETYP   D,2(SP)         ;REBIND POINTER?
1678         CAIE    D,TSP
1679         JRST    XCHVEC          ;NO-- USE ACCESS
1680         MOVE    D,5(SP)         ;YES-- RESTORE PROCID
1681         EXCH    D,PROCID+1(PVP)
1682         MOVEM   D,5(SP)         ;SAVING CURRENT ONE FOR LATER FAILURES
1683         ADD     SP,[2,,2]
1684
1685 ;IF WE JUST RAN OFF THE END OF THE ENVIRONMENT CHAIN, BARF
1686
1687 XCHVEC: HRRZ    SP,1(SP)
1688         JUMPN   SP,STLOOP
1689         JUMPE   E,STPOPJ        ;UNLESS THAT'S AS FAR AS WE WANTED TO GO
1690         .VALUE  [ASCIZ /SPOVERPOP/]
1691
1692 STPOPJ:
1693         MOVE    SP,E
1694         POPJ    P,
1695
1696
1697 \f
1698
1699 MFUNCTION REP,FSUBR,[REPEAT]
1700         JRST    PROG
1701 MFUNCTION PROG,FSUBR
1702         ENTRY   1
1703         GETYP   A,(AB)          ;GET ARG TYPE
1704         CAIE    A,TLIST         ;IS IT A LIST?
1705         JRST    WTYP            ;WRONG TYPE
1706         SKIPN   C,1(AB)         ;GET AND CHECK ARGUMENT
1707         JRST    ERRTFA          ;TOO FEW ARGS
1708         PUSH    TP,$TLIST       ;PUSH GOODIE
1709         PUSH    TP,C
1710 BIPROG: PUSH    TP,$TLIST
1711         PUSH    TP,C            ;SLOT FOR WHOLE BODY
1712         MOVE    C,3(TB)         ;PROG BODY
1713         MOVEI   D,
1714         PUSH    P,[AUX]         ;TELL BINDER WE ARE APROG
1715         PUSHJ   P,BINDEV
1716         HRRZ    C,3(TB)         ;RESTORE PROG
1717         TRNE    A,H             ;SKIP IF NO NAME ALA HEWITT
1718         HRRZ    C,(C)
1719         JUMPE   C,NOBODY
1720         MOVEM   C,3(TB)         ;SAVE FOR AGAIN, ETC.
1721         MOVE    0,A             ;SWITCHES TO 0
1722 BLPROG: PUSHJ   P,PROGAT        ;BIND OBSCURE ATOM
1723         MOVE    C,3(TB)
1724 STPROG: HRRZ    C,(C)           ;SKIP DCLS
1725         JUMPE   C,NOBODY
1726
1727 ; HERE TO RUN PROGS FUNCTIONS ETC.
1728
1729 DOPROG:
1730         HRRZM   C,1(TB)         ;CLOBBER AWAY BODY
1731         PUSH    TP,(C)          ;EVALUATE THE
1732         HLLZS   (TP)
1733         PUSH    TP,1(C)         ;STATEMENT
1734         JSP     E,CHKARG
1735         MCALL   1,EVAL
1736         HRRZ    C,@1(TB)        ;GET THE REST OF THE BODY
1737         JUMPN   C,DOPROG        ;IF MORE -- DO IT
1738 ENDPROG:
1739         HRRZ    C,FSAV(TB)
1740         MOVE    C,@-1(C)
1741         CAME    C,MQUOTE REP,REPEAT
1742         JRST    FINIS
1743         SKIPN   C,3(TB)         ;CHECK IT
1744         JRST    FINIS
1745         MOVEM   C,1(TB)
1746         JRST    CNTIN2
1747
1748 ;HERE TO BIND PROG ATOM (AND ANYTHING ELSE ON STACK)
1749
1750 PROGAT: PUSH    TP,BNDA
1751         PUSH    TP,MQUOTE [LPROG ],INTRUP
1752         MOVE    B,TB
1753         PUSHJ   P,MAKENV                ;B _ POINTER TO CURRENT FRAME
1754         PUSH    TP,A
1755         PUSH    TP,B
1756         PUSH    TP,[0]
1757         PUSH    TP,[0]
1758         JRST    SPECB1\f
1759
1760 MFUNCTION RETURN,SUBR
1761         ENTRY   1
1762         PUSHJ   P,PROGCH        ;CKECK IN A PROG
1763         PUSHJ   P,SAVE          ;RESTORE PROG'S FRAME, BCKTRKING IF NECESSARY
1764         MOVE    A,(AB)
1765         MOVE    B,1(AB)
1766         JRST    FINIS
1767
1768
1769 MFUNCTION AGAIN,SUBR
1770         ENTRY
1771         HLRZ    A,AB            ;GET # OF ARGS
1772         CAIN    A,-2            ;1 ARG?
1773         JRST    NLCLA           ;YES
1774         JUMPN   A,WNA           ;0 ARGS?
1775         PUSHJ   P,PROGCH        ;CHECK FOR IN A PROG
1776         JRST    AGAD
1777 NLCLA:  HLRZ    A,(AB)
1778         CAIE    A,TACT
1779         JRST    WTYP
1780         MOVE    A,1(AB)
1781         HRR     B,A
1782         HLL     B,OTBSAV (B)
1783         HRRZ    C,A
1784         CAIG    C,1(TP)
1785         CAME    A,B
1786         JRST    ILLFRA
1787         HLRZ    C,FSAV (C)
1788         CAIE    C,TENTRY
1789         JRST    ILLFRA
1790 AGAD:   PUSHJ   P,SAVE          ;RESTORE FRAME TO REPEAT
1791         MOVE    B,3(TB)
1792         MOVEM   B,1(TB)
1793         JRST    CNTIN2
1794
1795 MFUNCTION GO,SUBR
1796         ENTRY   1
1797         PUSHJ   P,PROGCH        ;CHECK FOR A PROG
1798         PUSH    TP,A            ;SAVE
1799         PUSH    TP,B
1800         MOVE    A,(AB)
1801         CAME    A,$TATOM
1802         JRST    NLCLGO
1803         PUSH    TP,A
1804         PUSH    TP,1(AB)
1805         PUSH    TP,2(B)
1806         PUSH    TP,3(B)
1807         MCALL   2,MEMQ          ;DOES IT HAVE THIS TAG?
1808         JUMPE   B,NXTAG         ;NO -- ERROR
1809 FNDGO:  EXCH    B,(TP)          ;SAVE PLACE TO GO
1810         MOVSI   D,TLIST
1811         MOVEM   D,-1(TP)
1812         JRST    GODON
1813
1814 NLCLGO: CAME    A,$TTAG         ;CHECK TYPE
1815         JRST    WTYP
1816         MOVE    A,1(AB)         ;GET ARG
1817         HRR     B,3(A)
1818         HLL     B,OTBSAV(B)
1819         HRRZ    C,B
1820         CAIG    C,1(TP)
1821         CAME    B,3(A)          ;CHECK TIME
1822         JRST    ILLFRA
1823         HLRZ    C,FSAV(C)
1824         CAIE    C,TENTRY
1825         JRST    ILLFRA
1826         PUSH    TP,(A)          ;SAVE BODY
1827         PUSH    TP,1(A)
1828 GODON:  PUSHJ   P,SAVE          ;GO BACK TO CORRECT FRAME
1829         MOVE    B,(TP)          ;RESTORE ITERATION MARKER
1830         MOVEM   B,1(TB)
1831         MOVE    A,(AB)
1832         MOVE    B,1(AB)
1833         JRST    CNTIN2
1834
1835 \f
1836
1837
1838 MFUNCTION TAG,SUBR
1839         ENTRY   1
1840         HLRZ    A,(AB)          ;GET TYPE OF ARGUMENT
1841         CAIE    A,TATOM         ;CHECK THAT IT IS AN ATOM
1842         JRST    WTYP
1843         PUSHJ   P,PROGCH        ;CHECK PROG
1844         PUSH    TP,A            ;SAVE VAL
1845         PUSH    TP,B
1846         PUSH    TP,0(AB)
1847         PUSH    TP,1(AB)
1848         PUSH    TP,2(B)
1849         PUSH    TP,3(B)
1850         MCALL   2,MEMQ
1851         JUMPE   B,NXTAG         ;IF NOT FOUND -- ERROR
1852         EXCH    A,-1(TP)        ;SAVE PLACE
1853         EXCH    B,(TP)
1854         PUSH    TP,A            ;UNDER PROG FRAME
1855         PUSH    TP,B
1856         MCALL   2,EVECTOR
1857         MOVSI   A,TTAG
1858         JRST    FINIS
1859
1860 PROGCH: MOVE    B,MQUOTE [LPROG ],INTRUP
1861         PUSHJ   P,ILVAL         ;GET VALUE
1862         GETYP   C,A
1863         CAIE    C,TFRAME
1864         JRST    NXPRG
1865         MOVE    C,B             ;CHECK TIME
1866         HLL     C,OTBSAV(B)
1867         CAME    C,B
1868         JRST    ILLFRA
1869         HRRZI   C,(B)           ;PLACE
1870         CAILE   C,1(TP)
1871         JRST    ILLFRA
1872         GETYP   C,FSAV(C)
1873         CAIE    C,TENTRY
1874         JRST    ILLFRA
1875         POPJ    P,
1876
1877 MFUNCTION EXIT,SUBR
1878         ENTRY   2
1879         PUSHJ   P,TILLFM        ;TEST FRAME
1880         PUSHJ   P,SAVE          ;RESTORE FRAME
1881         JRST    EXIT2
1882
1883 ;IF GIVEN, RETURN SECOND ARGUMENT
1884
1885 RETRG2: MOVE    A,2(AB)
1886         MOVE    B,3(AB)
1887         MOVE    AB,ABSAV(TB)    ;IN CASE OF GC
1888         JRST    FINIS
1889
1890 MFUNCTION COND,FSUBR
1891         ENTRY   1
1892         HLRZ    A,(AB)
1893         CAIE    A,TLIST
1894         JRST    WTYP
1895         PUSH    TP,(AB)
1896         PUSH    TP,1(AB)                ;CREATE UNNAMED TEMP
1897 CLSLUP: SKIPN   B,1(TB)         ;IS THE CLAUSELIST NIL?
1898         JRST    IFALSE          ;YES -- RETURN NIL
1899         HLRZ    A,(B)           ;NO -- GET TYPE OF CAR
1900         CAIE    A,TLIST         ;IS IT A LIST?
1901         JRST    BADCLS          ;
1902         MOVE    A,1(B)          ;YES -- GET CLAUSE
1903         JUMPE   A,BADCLS
1904         PUSH    TP,(A)          ;EVALUATION OF
1905         HLLZS   (TP)
1906         PUSH    TP,1(A)         ;THE PREDICATE
1907         JSP     E,CHKARG
1908         MCALL   1,EVAL
1909         CAMN    A,$TFALSE       ;IF THE RESULT IS
1910         JRST    NXTCLS          ;FALSE TRY NEXT CLAUSE
1911         MOVE    C,1(TB)         ;IF NOT, DO FIRST CLAUSE
1912         MOVE    C,1(C)
1913         HRRZ    C,(C)
1914         JUMPE   C,FINIS         ;(UNLESS DONE WITH IT)
1915         JRST    DOPROG          ;AS THOUGH IT WERE A PROG
1916 NXTCLS: HRRZ    A,@1(TB)        ;SET THE CLAUSLIST
1917         HRRZM   A,1(TB)         ;TO CDR OF THE CLAUSLIST
1918         JRST    CLSLUP
1919
1920 IFALSE:
1921         MOVSI   A,TFALSE        ;RETURN FALSE
1922         MOVEI   B,0
1923         JRST    FINIS
1924
1925
1926
1927
1928 ;RESTORE TB TO STACK FRAME POINTED TO BY B, SAVING INTERMEDIATE FRAMES ON THE PLANNER PDL
1929 ;IF NECESSARY;   CLOBBERS EVERYTHING BUT B
1930 SAVE:   MOVE    E,SPSAV(B)
1931         PUSHJ   P,SPCSTE        ;RESTORE BINDINGS IF NECESSARY
1932         SKIPN   C,OTBSAV(B)     ;PREVIOUS FRAME?
1933         JRST    QWKRET
1934         CAMN    PP,PPSAV(C)     ;ANYTHING HAPPEN TO PP BETWEEN B AND HERE?
1935         JRST    QWKRET          ;NO-- JUST RETURN
1936         PUSH    TP,$TTB
1937         PUSH    TP,B
1938 SVLP:   HRRZ    B,(TP)
1939         CAIN    B,(TB)          ;DONE?
1940         JRST    SVRET
1941         HRRZ    C,OTBSAV(TB)    ;ANYTHING TO SAVE YET?
1942         CAME    PP,PPSAV(C)
1943         PUSHJ   P,BCKTRK        ;DO IT
1944         HRR     TB,OTBSAV(TB)   ;AND POP UP
1945         JRST    SVLP
1946 QWKRET: HRR     TB,B            ;SKIP OVER EVERYTHING
1947         POPJ    P,
1948 SVRET:  SUB     TP,[2,,2]       ;POP CRAP OFF TP
1949         POPJ    P,\f
1950
1951 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
1952 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT.  ITS VALUE IS
1953 ; ITS SECOND ARGUMENT.
1954
1955 MFUNCTION SETG,SUBR
1956         ENTRY   2
1957         HLLZ    A,(AB)          ;GET TYPE OF FIRST ARGUMENT
1958         CAME    A,$TATOM        ;CHECK THAT IT IS AN ATOM
1959         JRST    NONATM          ;IF NOT -- ERROR
1960         MOVE    B,1(AB)         ;GET POINTER TO ATOM
1961         PUSHJ   P,IGLOC         ;GET LOCATIVE TO VALUE
1962         CAMN    A,$TUNBOUND     ;IF BOUND
1963         PUSHJ   P,BSETG         ;IF NOT -- BIND IT
1964         MOVE    C,B             ;SAVE PTR
1965         MOVE    A,2(AB)         ;GET SECOND ARGUMENT
1966         MOVE    B,3(AB)         ;INTO THE RETURN POSITION
1967         MOVEM   A,(C)           ;DEPOSIT INTO THE
1968         MOVEM   B,1(C)          ;INDICATED VALUE CELL
1969         JRST    FINIS
1970
1971 BSETG:  HRRZ    A,GLOBASE+1(TVP)
1972         HRRZ    B,GLOBSP+1(TVP)
1973         SUB     B,A
1974         CAIL    B,6
1975         JRST    SETGIT
1976         PUSH    TP,GLOBASE(TVP)
1977         PUSH    TP,GLOBASE+1 (TVP)
1978         PUSH    TP,$TFIX
1979         PUSH    TP,[0]
1980         PUSH    TP,$TFIX
1981         PUSH    TP,[100]
1982         MCALL   3,GROW
1983         MOVEM   A,GLOBASE(TVP)
1984         MOVEM   B,GLOBASE+1(TVP)
1985 SETGIT:
1986         MOVE    B,GLOBSP+1(TVP)
1987         SUB     B,[4,,4]
1988         MOVE    C,(AB)
1989         MOVEM   C,(B)
1990         MOVE    C,1(AB)
1991         MOVEM   C,1(B)
1992         MOVEM   B,GLOBSP+1(TVP)
1993         ADD     B,[2,,2]
1994         MOVSI   A,TLOCI
1995         POPJ    P,
1996
1997 \f
1998
1999
2000 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
2001 ;FIRST ARGUMENT TO THE SECOND ARG.  ITS VALUE IS ITS SECOND ARGUMENT.
2002
2003 MFUNCTION SET,SUBR
2004         ENTRY   2
2005         HLLZ    A,(AB)          ;GET TYPE OF FIRST
2006         CAME    A,$TATOM        ;ARGUMENT --
2007         JRST    WTYP            ;BETTER BE AN ATOM
2008         MOVE    B,1(AB)         ;GET PTR TO IT
2009         PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
2010         CAMN    A,$TUNBOUND     ;BOUND?
2011         PUSHJ   P, BSET         ;BIND IT
2012         MOVE    C,B             ;SAVE PTR
2013         MOVE    A,2(AB)         ;GET SECOND ARG
2014         MOVE    B,3(AB)         ;INTO RETURN VALUE
2015         MOVEM   A,(C)           ;CLOBBER IDENTIFIER
2016         MOVEM   B,1(C)
2017         JRST    FINIS
2018 BSET:   PUSH    TP,$TFIX
2019         PUSH    TP,[4]
2020         MCALL   1,VECTOR        ;GET NEW BIND VECTOR
2021         MOVE    A,$TSP
2022         MOVEM   A,(B)           ;MARK IT
2023         SETZM   A,1(B)
2024         MOVSI   A,TBIND
2025         HRRI    A,(B)
2026         MOVEM   A,2(B)          ;CHAIN FIRST BLOCK
2027         MOVE    A,1(AB)         ;A _ ATOM
2028         MOVEM   A,3(B)
2029         MOVE    C,SPBASE+1(PVP) ;CHAIN TO PREVIOUS BIND VECTOR
2030         MOVEM   B,SPBASE+1(PVP) ;SET NEW TOP
2031         ADD     B,[2,,2]
2032         MOVEM   B,1(C)
2033         ADD     B,[2,,2]        ;POINT TO LOCATIVE
2034         MOVSI   A,TLOCI
2035         HRR     A,PROCID+1(PVP) ;WHICH MAKE
2036         MOVE    C,1(AB)         ;C _ ATOM _ VALUE CELL ADDRESS
2037         MOVEM   A,(C)
2038         MOVEM   B,1(C)          ;CLOBBER LOCATIVE SLOT
2039         POPJ    P,
2040 \f
2041
2042 MFUNCTION NOT,SUBR
2043         ENTRY   1
2044         HLRZ    A,(AB)          ; GET TYPE
2045         CAIE    A,TFALSE        ;IS IT FALSE?
2046         JRST    IFALSE          ;NO -- RETURN FALSE
2047
2048 TRUTH:
2049         MOVSI   A,TATOM         ;RETURN T (VERITAS)
2050         MOVE    B,MQUOTE T
2051         JRST    FINIS
2052
2053 MFUNCTION ANDA,FSUBR,AND
2054         ENTRY   1
2055         HLRZ    A,(AB)
2056         CAIE    A,TLIST
2057         JRST    WTYP            ;IF ARG DOESN'T CHECK OUT
2058         SKIPN   C,1(AB)         ;IF NIL
2059         JRST    TRUTH           ;RETURN TRUTH
2060         PUSH    TP,$TLIST               ;CREATE UNNAMED TEMP
2061         PUSH    TP,C
2062 ANDLP:
2063         JUMPE   C,FINIS         ;ANY MORE ARGS?
2064         MOVEM   C,1(TB)         ;STORE CRUFT
2065         PUSH    TP,(C)          ;EVALUATE THE
2066         HLLZS   (TP)            ;FIRST REMAINING
2067         PUSH    TP,1(C)         ;ARGUMENT
2068         JSP     E,CHKARG
2069         MCALL   1,EVAL
2070         CAMN    A,$TFALSE
2071         JRST    FINIS           ;IF FALSE -- RETURN
2072         HRRZ    C,@1(TB)        ;GET CDR OF ARGLIST
2073         JRST    ANDLP
2074
2075 MFUNCTION OR,FSUBR
2076         ENTRY   1
2077         HLRZ    A,(AB)
2078         CAIE    A,TLIST         ;CHECK OUT ARGUMENT
2079         JRST    WTYP
2080         MOVE    C,1(AB)         ;PICK IT UP TO ENTER LOOP
2081         PUSH    TP,$TLIST       ;CREATE UNNAMED TEMP
2082         PUSH    TP,C
2083 ORLP:
2084         JUMPE   C,IFALSE        ;IF NO MORE OPTIONS -- FALSE
2085         MOVEM   C,1(TB)         ;CLOBBER IT AWAY
2086         PUSH    TP,(C)
2087         HLLZS   (TP)
2088         PUSH    TP,1(C)         ;EVALUATE THE FIRST REMAINING
2089         JSP     E,CHKARG
2090         MCALL   1,EVAL          ;ARGUMENT
2091         CAME    A,$TFALSE       ;IF NON-FALSE RETURN
2092         JRST    FINIS
2093         HRRZ    C,@1(TB)        ;IF FALSE -- TRY AGAIN
2094         JRST    ORLP
2095
2096 MFUNCTION FUNCTION,FSUBR
2097         PUSH    TP,(AB)
2098         PUSH    TP,1(AB)
2099         PUSH    TP,$TATOM
2100         PUSH    TP,MQUOTE FUNCTION
2101         MCALL   2,CHTYPE
2102         JRST    FINIS
2103
2104 \f
2105
2106 MFUNCTION CLOSURE,SUBR
2107         ENTRY
2108         SKIPL   A,AB            ;ANY ARGS
2109         JRST    ERRTFA          ;NO -- LOSE
2110         ADD     A,[2,,2]        ;POINT AT IDS
2111         PUSH    TP,$TAB
2112         PUSH    TP,A
2113         PUSH    P,[0]           ;MAKE COUNTER
2114
2115 CLOLP:  SKIPL   A,1(TB)         ;ANY MORE IDS?
2116         JRST    CLODON          ;NO -- LOSE
2117         PUSH    TP,(A)          ;SAVE ID
2118         PUSH    TP,1(A)
2119         PUSH    TP,(A)          ;GET ITS VALUE
2120         PUSH    TP,1(A)
2121         ADD     A,[2,,2]        ;BUMP POINTER
2122         MOVEM   A,1(TB)
2123         AOS     (P)
2124         MCALL   1,VALUE
2125         PUSH    TP,A
2126         PUSH    TP,B
2127         MCALL   2,LIST          ;MAKE PAIR
2128         PUSH    TP,A
2129         PUSH    TP,B
2130         JRST    CLOLP
2131
2132 CLODON: POP     P,A
2133         ACALL   A,LIST          ;MAKE UP LIST
2134         PUSH    TP,(AB)         ;GET FUNCTION
2135         PUSH    TP,1(AB)
2136         PUSH    TP,A
2137         PUSH    TP,B
2138         MCALL   2,LIST          ;MAKE LIST
2139         MOVSI   A,TFUNARG
2140         JRST    FINIS
2141
2142
2143 MFUNCTION FALSE,SUBR
2144         ENTRY
2145         JUMPGE  AB,IFALSE
2146         HLRZ    A,(AB)
2147         CAIE    A,TLIST
2148         JRST    WTYP
2149         MOVSI   A,TFALSE
2150         MOVE    B,1(AB)
2151         JRST    FINIS
2152 \f;BCKTRK SAVES THINGS ON PP
2153
2154 ;IT AND ITS FRIENDS FLAG PP "FRAMES" WITH MARKERS OF FORM "TTP,,SWITCHES", WHERE SWITCHES INCLUDES
2155
2156 COP==1          ;ON IFF CALL TO BCKTRK IS TO COPY FRAME (TB) AS WELL
2157                 ;AS OTBSAV(TB)
2158 SAV==2          ;ON IFF TUPLES OF (TB) ARE TO BE SAVED; COP IMPLIES
2159                 ;SAV
2160 TUP==4          ;ON IFF (TB) CONTAINS ANY TUPLES BESIDES ARGS
2161 ON==10          ;ON IFF THIS FRAME OR FAILPOINT "RESTS ON TOP OF"
2162                 ;FRAME DESIGNATED BY TTP POINTER, OR IS INTENDED TO
2163                 ;TAKE ITS PLACE
2164
2165 ;BELOW THE TTP POINTER IS ONE OR TWO BLOCKS FLAGGED BY A TFIX
2166 ;VALUE.  IF ON=ON AND TUP=ON IN THE RIGHT HALF OF THE TFIX,
2167 ;THE TFIX BEGINS A BLOCK OF TUPLE DEBRIS; OTHERWISE,
2168 ;IT BEGINS A SAVED TP FRAME.
2169
2170
2171 BCKTRK: HRRZ    A,-1(PP)        ;SLOT LEFT BY FAILPOINT?
2172         TRNN    A,COP           ;(I.E., TO BE COPIED?)
2173         JRST    NBCK
2174         MOVE    E,TB            ;YES-- FIRST SAVE THIS FRAME
2175         PUSHJ   P,BCKTRE
2176         HRRZ    A,-1(PP)
2177         JRST    NBCK1
2178 NBCK:   TRNN    A,SAV
2179         JRST    RMARK
2180
2181 ;SAVE TUPLES OF FRAME ON TOP OF PP
2182
2183 NBCK1:  MOVSI   B,TTP           ;FAKE OUT GC
2184         MOVEM   B,BSTO(PVP)
2185         MOVSI   C,TPP
2186         MOVEM   C,CSTO(PVP)
2187         MOVEM   C,ESTO(PVP)
2188         MOVE    B,(PP)          ;B _ TPIFIED TB POINTER
2189         SUB     PP,[2,,2]       ;CLEAN OFF POINTER TO MAKE ROOM FOR ARGS
2190         MOVE    E,PP
2191         MOVE    C,PP            ;C _ E _ PP
2192         SUB     C,(PP)          ;C _ ADDRESS OF SAVED OTB
2193         HLRE    D,1(C)          ;D _ NO. OF ARGS
2194         JUMPE   D,NOARGS
2195         SUB     B,[FRAMLN,,FRAMLN]      ;B _ FIRST OF SAVE BLOCK
2196         MOVNS   D
2197         HRLS    D
2198         SUB     B,D             ;B _ FIRST OF ARGS
2199 MVARGS: INTGO
2200         PUSH    PP,(B)          ;MOVE NEXT
2201         PUSH    PP,1(B)
2202         ADD     B,[2,,2]
2203         SUB     D,[2,,2]
2204         JUMPG   D,MVARGS
2205         ADD     B,[FRAMLN,,FRAMLN]      ;B _ TB ADDRESS
2206         JRST    MVTUPS
2207 NOARGS: TRNN    A,TUP           ;ANY OTHER TUPLES?
2208         JRST    RMARK
2209 MVTUPS: ADD     C,[FRAMLN-1,,FRAMLN-1]  ;C _ PP TB SLOT
2210         SUB     E,[1,,1]        ;E _ TFIX SLOT ADDRESS
2211 MTOLP:  CAML    C,E             ;C REACHED E?
2212         JRST    MTDON           ;YES-- ALL TUPLES FOUND
2213         INTGO
2214         GETYP   A,(C)           ;ELSE
2215         CAIE    A,TTBS          ;LOOK FOR TUPLE
2216         JRST    ARND22
2217         HRRE    D,(C)           ;D _ NO. OF ELEMENTS
2218 MTILP:  JUMPGE  D,ARND22
2219         INTGO
2220         PUSH    PP,(B)
2221         PUSH    PP,1(B)
2222         ADD     B,[2,,2]
2223         ADDI    D,2
2224         JRST    MTILP
2225 ARND22: ADD     B,[2,,2]        ;ADVANCE IN STEP
2226         ADD     C,[2,,2]
2227         JRST    MTOLP
2228 ;ALL TUPLES MOVED
2229 MTDON:  HRRZ    C,PP
2230         SUBI    C,1(E)          ;C _ NO. OF THINGS MOVED
2231         HRLS    C
2232         PUSH    PP,[TFIX,,TUP]  ;MARK AS TUPLE CRUFT
2233         PUSH    PP,C
2234 ;NEW TTP MARKER
2235 RMARK:  MOVE    E,OTBSAV(TB)    ;SAVE PREVIOUS FRAME
2236         HRRZ    D,E
2237         HRLS    D
2238         HLRE    C,B
2239         SUBI    C,(B)
2240         HRLZS   C
2241         ADD     D,C
2242         PUSH    PP,[TTP,,ON]
2243         PUSH    PP,D
2244         MOVSI   B,TFIX          ;RESTORE B TYPE
2245         MOVEM   B,BSTO(PVP)
2246
2247 ;BCKTRE SAVE CONTENTS OF FRAME E OF TP ON PLANNER PDL
2248
2249 BCKTRE: MOVSI   A,TPDL          ;FOR AGC
2250         MOVEM   A,ASTO(PVP)
2251         MOVSI   C,TTP
2252         MOVEM   C,CSTO(PVP)
2253         MOVSI   A,TTB
2254         MOVEM   A,ESTO(PVP)
2255
2256 ;MOVE P BLOCK OF PREVIOUS FRAME TO PP
2257
2258         MOVE    C,PSAV(E)       ;C _ LAST OF P "FRAME"
2259         HRRZ    A,OTBSAV(E)
2260         MOVE    A,PSAV(A)       ;A _ LAST OF PREVIOUS P "FRAME"
2261         ADD     A,[1,,1]
2262 MVPB:   CAMLE   A,C             ;IF BLOCK EMPTY,
2263         JRST    MVTPB           ;DO NOTHING
2264         HRRZ    D,C
2265         SUBI    D,-1(A)         ;ELSE, SET COUNTER
2266         PUSH    PP,$TPDLS       ;MARK BLOCK
2267         HRRM    D,(PP)
2268         HRLS    D
2269         PUSH    P,D
2270 PSHLP1: PUSH    PP,(A)
2271         INTGO           ;MOVE BLOCK
2272         ADD     A,[1,,1]
2273         CAMG    A,C
2274         JRST    PSHLP1
2275         PUSH    PP,$TFIX
2276         PUSH    PP,[0]          ;PUSH BLOCK COUNTER
2277         POP     P,(PP)
2278 ;NOW DO SIMILAR THING FOR TP
2279 MVTPB:  MOVSI   A,TTP           ;FOR AGC
2280         MOVEM   A,ASTO(PVP)
2281         MOVE    C,TPSAV(E)      ;C POINT TO LAST OF BLOCK
2282         PUSH    TP,$TPP         ;SAVE INITIAL PP
2283         PUSH    TP,PP           ;FOR SUBTRACTION
2284         HRRZ    A,E             ;A _ TPIFIED E
2285         HLRE    B,C
2286         SUBI    B,(C)
2287         HRLZS   B
2288         HRLS    A
2289         ADD     A,B
2290         GETYP   D,FSAV(A)
2291         CAIE    D,TENTRY
2292         .VALUE  [ASCIZ /TPFUCKED/]
2293 ;MOVE THE SAVE BLOCK
2294
2295 MSVBLK: MOVSI   D,TENTS         ;MAKE TYPE TENTS
2296         HRR     D,FSAV(A)
2297         PUSH    PP,D
2298         HLLZ    D,OTBSAV(E)     ;RELATIVIZE OTB AND AB POINTERS
2299         PUSH    PP,D
2300         HLLZ    D,ABSAV(E)
2301         PUSH    PP,D
2302         PUSH    PP,SPSAV(E)
2303         PUSH    PP,PSAV(E)
2304         PUSH    PP,TPSAV(E)
2305         PUSH    PP,PPSAV(E)
2306         PUSH    PP,PCSAV(E)
2307         MOVEI   0,              ;0 _ 0 (NO TUPLES)
2308 PSHLP2: INTGO
2309         CAMLE   A,C             ;DONE?
2310         JRST    MRKFIX
2311         GETYP   D,(A)
2312         CAIN    D,TTB           ;TUPLE?
2313         JRST    MVTB
2314         PUSH    PP,(A)          ;NO, JUST MOVE IT
2315         PUSH    PP,1(A)
2316 ARND4:  ADD     A,[2,,2]
2317         JRST    PSHLP2
2318 MRKFIX: HRRZ    C,(TP)          ;C _ PREVIOUS PP POINTER
2319         SUB     TP,[2,,2]
2320         HRRZ    D,PP            ;D _ CURRENT PP TOP
2321         SUBI    D,(C)           ;D _ DIFFERENCE
2322         HRLS    D
2323         PUSH    PP,$TFIX        ;PUSH BLOCK COUNTER
2324         PUSH    PP,D
2325
2326
2327 ;NOW SAVE LOCATION OF THIS FRAME
2328
2329         HRLS    E
2330         MOVE    C,TPSAV(E)
2331         HLRE    B,C
2332         SUBI    B,(C)
2333         HRLZS   B
2334         ADD     E,B             ;CONVERSION TO TTP
2335         HRLI    0,TTP
2336         TRO     0,SAV           ;PUSH A TTP MARKER WITH SAV & MAYBE TUP ON
2337         PUSH    PP,0
2338         PUSH    PP,E
2339
2340 ;RETURN
2341
2342         MOVSI   A,TFIX
2343         MOVEM   A,ASTO(PVP)
2344         MOVEM   A,CSTO(PVP)
2345         MOVEM   A,ESTO(PVP)
2346         POPJ    P,
2347
2348 ;RELATIVIZE A TB POINTER
2349
2350 MVTB:   HRRE    D,(A)           ;D _ - LENGTH OF TUPLE
2351         MOVNS   D
2352         HRLS    D               ;D _ LENGTH,,LENGTH
2353         SUB     PP,D            ;THROW TUPLE AWAY!!!
2354         TRO     0,TUP
2355         MOVNS   D
2356         HRLI    D,TTBS
2357         PUSH    PP,D
2358         MOVE    D,1(A)
2359         SUBI    D,(E)
2360         PUSH    PP,D
2361         JRST    ARND4
2362 \fMFUNCTION FAIL,SUBR
2363
2364 ;SINCE FAILURES ARE NOT INTERRUPTIBLE FOR ANYTHING BUT GARBAGE
2365 ;COLLECTIONS, THE FOLLOWING MACRO REPLACES INTGO FOR STACK-BUILDING
2366 ;LOOPS
2367
2368 DEFINE UNBLOW STK
2369         SKIPL   STK
2370         PUSHJ   P,NBLO!STK
2371 TERMIN
2372
2373
2374         ENTRY
2375         HLRE    A,AB
2376         MOVNS   A
2377         CAILE   A,4             ;AT MOST 2 ARGS
2378         JRST    WNA
2379         CAIGE   A,2             ;IF FIRST ARG NOT GIVEN,
2380         JRST    MFALS           ;ASSUME <>
2381         MOVE    B,(AB)          ;OTHERWISE, FIRST ARG IS MESSAGE
2382         MOVEM   B,MESS(PVP)
2383         MOVE    B,1(AB)
2384         MOVEM   B,MESS+1(PVP)
2385
2386         CAIE    A,4             ;PLACE TO FAIL TO GIVEN?
2387         JRST    AFALS1
2388         HLRZ    A,2(AB)
2389         CAIE    A,TACT          ;CAN ONLY FAIL TO AN ACTIVATION
2390         JRST    TAFALS
2391 SAVACT: MOVE    B,2(AB)         ;TRANSMIT ACTIVATION TO FAILPOINT
2392         MOVEM   B,FACTI(PVP)    ;VIA PVP
2393         MOVE    B,3(AB)
2394         MOVEM   B,FACTI+1(PVP)
2395 ;NOW REBUILD TP FROM PP
2396 IFAIL:  SETOM   FLFLG           ;FLFLG _ ON
2397         HRRZ    A,(PP)          ;GET FRAME TO NESTLE IN
2398         JUMPE   A,BDFAIL
2399         HRRZ    0,-1(PP)        ;0 _ SWITCHES FOR FRAME
2400         CAIN    A,(TB)
2401         JRST    RSTFRM
2402         GETYP   B,FACTI(PVP)    ;IF FALSE ACTIVATION,
2403         CAIN    B,TFALSE        ;JUST GO TO FRAME
2404         JRST    POPFS
2405         HRRZI   B,(TB)          ;OTHERWISE, CHECK TO SEE IF WE ARE LEAVING
2406         HRRZ    D,FACTI+1(PVP)
2407 ALOOP:  CAIN    B,(A)           ;     FRAME FACTI(PVP)
2408         JRST    POPFS           ;NO-- IT'S ABOVE FAILPOINT (A)
2409         CAIN    B,(D)           ;FOUND FACTI?
2410         JRST    AFALS2          ;YES-- CLOBBER FACTI TO #FALSE()
2411         HRRZ    B,OTBSAV(B)     ;NO-- KEEP LOOKING
2412         JRST    ALOOP
2413 AFALS2: MOVSI   B,TFALSE        ;SET IT TO FALSE FROM HERE ON
2414         MOVEM   B,FACTI(PVP)
2415         SETZB   D,FACTI+1(PVP)
2416 POPFS:  HRR     TB,A            ;MAY TAKE MORE WORK
2417 RSTFRM: MOVE    P,PSAV(TB)
2418         MOVE    TP,TPSAV(TB)
2419         SUB     PP,[2,,2]
2420         GETYP   A,-1(PP)
2421         CAIN    A,TPC
2422         JRST    MHFRAM
2423         CAIE    A,TFIX
2424         JRST    BADPP
2425
2426 ;MOVE A TP BLOCK FROM PP TO TP
2427         MOVSI   A,TPP
2428         MOVEM   A,ASTO(PVP)
2429         MOVEM   A,CSTO(PVP)
2430         MOVE    A,PP
2431         SUB     A,(PP)          ;A POINTS TO BOTTOM OF BLOCK
2432         TRNN    0,ON            ;"ON" BLOCK?
2433         JRST    INBLK
2434 ONBLK:  CAME    SP,SPSAV(TB)    ;YES-- FIX UP ENVIRONMENT
2435         PUSHJ   P,SPECST
2436         MOVE    C,A
2437         HRRZ    0,-1(PP)        ;ANY TUPLES?
2438         TRNN    0,TUP
2439         JRST    USVBLK          ;NO-- GO MOVE SAVE BLOCK
2440         SUB     A,[2,,2]        ;A _ BLOCK UNDER THIS ONE
2441         SUB     A,(A)
2442 ;FILL IN ARGS TUPLE
2443         GETYP   B,-1(A)
2444         CAIE    B,TENTS         ;LOOK IN SAVE BLOCK
2445         JRST    BADPP
2446         HLRE    D,FRAMLN+ABSAV-1(A)
2447         PUSHJ   P,USVTUP
2448
2449 ;MOVE SAVE BLOCK BACK TO TP
2450
2451 USVBLK: ADD     A,[FRAMLN,,FRAMLN]
2452         MOVSI   D,TENTRY
2453         HRR     D,FSAV-1(A)
2454         PUSH    TP,D
2455         MOVEI   AB,(TP)         ;REGENERATE AB & OTBSAV
2456         HLRE    D,ABSAV-1(A)
2457         MOVNS   D
2458         HRLS    D
2459         SUB     AB,D
2460         MOVEI   D,(TB)
2461         HLL     D,OTBSAV-1(A)
2462         PUSH    TP,D
2463         PUSH    TP,AB
2464         PUSH    TP,SPSAV-1(A)
2465         PUSH    TP,PSAV-1(A)
2466         PUSH    TP,TPSAV-1(A)
2467         PUSH    TP,PPSAV-1(A)
2468         PUSH    TP,PCSAV-1(A)
2469         HRRI    TB,1(TP)
2470
2471 PSHLP4: CAML    TP,TPSAV(TB)
2472         JRST    USTPDN
2473         UNBLOW  TP
2474         GETYP   B,-1(A)
2475         CAIN    B,TTBS          ;FOUND A TUPLE?
2476         JRST    USVTB
2477         PUSH    TP,-1(A)        ;NO-- JUST MOVE IT
2478         PUSH    TP,(A)
2479 ARND12: ADD     A,[2,,2]        ;BUMP POINTER
2480         JRST    PSHLP4
2481 USVTB:  HRRE    D,-1(A)
2482         PUSHJ   P,USVTUP
2483         MOVE    D,-1(A)         ;UNRELATIVIZE A TTB
2484         HRLI    D,TTB
2485         PUSH    TP,D
2486         MOVE    D,(A)
2487         ADDI    D,(TB)
2488         PUSH    TP,D
2489         JRST    ARND12
2490 USTPDN: MOVE    0,-1(PP)        ;IF TUPLES,
2491         TRNN    0,TUP
2492         JRST    USTPD3
2493         SUB     PP,(PP)         ;SKIP OVER TUPLE DEBRIS
2494         SUB     PP,[2,,2]
2495 USTPD3: CAME    TP,TPSAV(TB)    ;BETTER HAVE WORKED
2496         JRST    BADPP
2497         CAMN    SP,SPSAV(TB)    ;PLEASE GOD, NO MORE BINDINGS
2498         JRST    USV2            ;PRAYER CAN MOVE MOUNTAINS
2499         MOVEI   E,              ;E _ 0 = INITIAL LOWER BIND BLOCK
2500         MOVE    C,SPSAV(TB)     ;C _ SPSAV = INITIAL UPPER BLOCK
2501
2502 ;REBIND EVERYTHING IN THIS FRAME-- FIRST, FIND THE TOPMOST BLOCK,
2503 ;SINCE THEY MUST BE REBOUND IN THE ORDER BOUND
2504
2505 BLOOP1: GETYP   D,(C)
2506         CAIE    D,TBIND         ;C POINTS TO BIND BLOCK?
2507         JRST    SPLBLK
2508         ADD     C,[5,,5]        ;YES-- C _ ADDRESS OF ITS LAST WORD
2509         MOVEM   E,(C)           ;(C) _ E = LOWER BIND POINTER
2510         MOVE    E,C             ;E _ C
2511         SKIPA   D,-5(C)         ;FIND REBIND POINTER
2512 BLOOP5: HRRZ    D,(D)           ;D _ NEXT BIND BLOCK
2513         GETYP   0,(D)
2514         CAIE    0,TSP           ;LOOK FOR REBINDER
2515         JRST    BLOOP5
2516         MOVE    C,1(D)          ;C _ REBIND BLOCK
2517         JRST    JBVEC3
2518 SPLBLK: GETYP   D,2(C)
2519         CAIN    D,TSP
2520         ADD     C,[2,,2]
2521         ADD     C,[1,,1]        ;C _ REBIND POINTER ADDRESS
2522         MOVE    D,(C)           ;D _ HIGHER BLOCK
2523         MOVEM   E,(C)           ;(C) _ E
2524         MOVE    E,C             ;E _ C
2525         MOVE    C,D             ;C _ D = HIGHER BIND BLOCK
2526 JBVEC3: CAME    SP,C            ;GOT TO SP YET?
2527         JRST    BLOOP1
2528
2529
2530 ;NOW REBIND EVERYTHING, RESET PROCID'S PROPERLY, ETC.;
2531 ;THIS MUST BE DONE IN PROPER ORDER, FROM TOPMOST BLOCK DOWN
2532
2533 BLOOP2: HLRZ    D,-1(E)         ;WHAT DOES E POINT TO?
2534         PUSH    P,(E)
2535         JUMPN   D,TUGSP         ;IF NON-ZERO, MUST BE REBIND SLOT
2536         PUSHJ   P,EBIND         ;OTHERWISE, BIND BLOCK TO BE REBOUND
2537         JRST    DOWNBL
2538 TUGSP:  MOVEM   SP,(E)          ;RECONNECT UPPER BLOCK
2539         GETYP   0,1(E)
2540         CAIE    0,TBIND
2541         SUB     E,[2,,2]
2542         MOVE    SP,E
2543         SUB     SP,[1,,1]       ;TUG SP DOWN
2544         CAIE    0,TSP           ;ID SWAP?
2545         JRST    DOWNBL
2546         MOVE    0,PROCID+1(PVP)
2547         EXCH    0,5(SP)
2548         MOVEM   0,PROCID+1(PVP)
2549 DOWNBL: POP     P,E             ;E _ LOWER BLOCK
2550         JUMPN   E,BLOOP2
2551
2552 RBDON:  CAME    SP,SPSAV(TB)    ;ALL THAT BETTER HAVE WORKED
2553         JRST    BADPP
2554         JRST    USV2
2555
2556 ;RESTORE A BLOCK "INTO" TB
2557
2558 INBLK:  ADD     A,[FRAMLN,,FRAMLN]
2559         MOVSI   C,TTP
2560         MOVEM   C,CSTO(PVP)
2561         MOVSI   C,SPSAV-1(A)
2562         HRRI    C,SPSAV(TB)
2563         BLT     C,-1(TB)        ;RESTORE ALL OF SAVE BLOCK BUT FSAV,
2564         MOVEI   C,-1(TB)        ;    OTBSAV, AND ABSAV
2565         HRLS    C
2566         MOVE    B,TPSAV(TB)
2567         HLRE    D,B
2568         SUBI    D,(B)
2569         HRLZS   D
2570         ADD     C,D             ;C _ "-1(TB)"TPIFIED
2571 PSHLP6: CAML    A,PP
2572         JRST    TPDON
2573         GETYP   B,-1(A)         ;GOT TUPLE?
2574         CAIN    B,TTBS
2575         JRST    SKTUPL          ;YES-- SKIP IT
2576         PUSH    C,-1(A)
2577         PUSH    C,(A)
2578 ARND2:  CAMLE   C,TP
2579         MOVE    TP,C            ;PROTECT STACK FROM GARBAGE COLLECTION
2580         UNBLOW  TP
2581         ADD     A,[2,,2]
2582         JRST    PSHLP6
2583 SKTUPL: HRRE    D,-1(A)         ;D _ - LENGTH OF TUPLE
2584         MOVNS   D
2585         HRLS    D
2586         ADD     C,D             ;SKIP!
2587         ADD     C,[2,,2]        ;AND DON'T FORGET TTB
2588         JRST    ARND2
2589 TPDON:  MOVE    TP,C            ;IN CASE TP TOO BIG
2590         CAME    TP,TPSAV(TB)    ;CHECK THAT INBLK WORKED
2591         JRST    BADPP
2592         MOVE    C,OTBSAV(TB)    ;RESTORE P STARTING FROM PREVIOUS
2593         MOVE    P,PSAV(C)       ;FRAME
2594
2595 ;MOVE A P BLOCK BACK TO P
2596
2597 USV2:   MOVSI   C,TFIX
2598         MOVEM   C,CSTO(PVP)
2599 \r       SUB     PP,(PP)
2600         SUB     PP,[2,,2]       ;NOW BACK BEYOND TP BLOCK
2601         GETYP   A,-1(PP)
2602         CAIE    A,TFIX          ;GET P BLOCK...
2603         JRST    CHPC2           ;...IF ANY
2604         MOVE    A,PP
2605         SUB     A,(PP)          ;A POINTS TO FIRST
2606 PSHLP5: PUSH    P,-1(A)         ;MOVE BLOCK
2607         ADD     A,[1,,1]
2608         UNBLOW  P
2609         CAMGE   A,PP
2610         JRST    PSHLP5
2611         SUB     PP,(PP)
2612         SUB     PP,[3,,3]               ;NOW AT NEXT PP "FRAME"
2613         GETYP   A,-1(PP)
2614 CHPC2:  CAME    P,PSAV(TB)      ;MAKE SURE P RESTORED OKAY
2615         JRST    BADPP
2616         CAIN    A,TTP
2617         JRST    IFAIL
2618         JRST    BADPP
2619
2620 ;FRAME IS ALREADY ON THE STACK--- BINDINGS ONLY HASSLE
2621
2622 MHFRAM: MOVE    AB,ABSAV(TB)    ;RESTORE ARGS POINTER
2623         CAME    SP,SPSAV(TB)    ;AND ENVIRONMENT
2624         PUSHJ   P,SPECSTO
2625         MOVSI   A,TFIX
2626         MOVEM   A,ASTO(PVP)
2627         SETZM   FLFLG           ;FLFLG _ OFF
2628         INTGO                   ;HANDLE POSTPONED INTERRUPTS
2629         SUB     PP,[2,,2]
2630         JRST    @2(PP)
2631
2632 ;HERE TO PUSH TUPLE STARTING AT (C), OF LENGTH -D
2633
2634 USVTUP: SKIPL   D
2635         POPJ    P,
2636         PUSH    TP,-1(C)
2637         PUSH    TP,(C)
2638         UNBLOW TP
2639         ADD     C,[2,,2]
2640         ADDI    D,2
2641         JRST    USVTUP
2642
2643 ;DEFAULT MESSAGE IS <>
2644
2645 MFALS:  MOVSI   B,TFALSE        ;TYPE FALSE
2646         MOVEM   B,MESS(PVP)
2647         SETZM   MESS+1(PVP)
2648
2649
2650 ;DEFAULT ACTIVATION IS <>, ALSO
2651 AFALS1: MOVSI   B,TFALSE
2652         MOVEM   B,FACTI(PVP)
2653 \r       SETZM   FACTI+1(PVP)
2654         JRST    IFAIL
2655
2656 ;FALSE IS ALLOWED EXPLICITLY
2657
2658 TAFALS: CAIE    A,TFALSE
2659         JRST    WTYP
2660         JRST    SAVACT
2661
2662
2663 ;FLAG FOR INTERRUPT SYSTEM
2664
2665 FLFLG:  0
2666
2667 ;HERE TO UNBLOW P
2668
2669 NBLOP:  HRRZ    E,P
2670         HLRE    B,P
2671         SUBI    E,-PDLBUF-1(P)  ;E _ ADR OF REAL 2ND DOPE WORD
2672         SKIPE   PGROW
2673         JRST    PDLOSS          ;SORRY, ONLY ONE GROWTH PER FAMILY
2674         HRRM    E,PGROW         ;SET PGROW
2675         JRST    NBLO2
2676
2677 ;HERE TO UNBLOW TP
2678
2679 NBLOTP: HRRZ    E,TP            ;MORE OR LESS THE SAME
2680         HLRE    B,TP
2681         SUBI    E,-PDLBUF-1(TP)
2682         SKIPE   TPGROW
2683         JRST    PDLOSS
2684         HRRM    E,TPGROW
2685 NBLO2:  MOVEI   B,PDLGRO_-6
2686         DPB     B,[111100,,-1(E)]
2687         JRST    AGC
2688 \fMFUNCTION FINALIZE,SUBR,[FINALIZE]
2689         ENTRY
2690         SKIPL   AB              ;IF NOARGS;
2691         JRST    GETTOP          ;FINALIZE ALL FAILPOINTS
2692         HLRE    A,AB            ;AT MOST ONE ARG
2693         CAME    A,[-2]
2694         JRST    WNA
2695         PUSHJ   P,TILLFM        ;MAKE SURE ARG IS LEGAL
2696         HRR     B,OTBSAV(B)     ;B _ FRAME BEFORE ACTIVATION
2697 RESTPP: MOVE    PP,PPSAV(B)     ;RESTORE PP
2698         HRRZ    A,TB            ;IN EVERY FRAME
2699 FLOOP:  CAIN    A,(B)           ;FOR EACH ONE,
2700         JRST    FDONE
2701         MOVEM   PP,PPSAV(A)
2702         HRR     A,OTBSAV(A)
2703         JRST    FLOOP
2704 FDONE:  MOVE    A,$TFALSE
2705         MOVEI   B,
2706         JRST    FINIS
2707
2708 ;TILLFM SETS B _ FIRST ARGUMENT IFF IT IS A LEGAL ACTIVATION
2709
2710 TILLFM: HLRZ    A,(AB)          ;FIRST ARG MUST BE ACTIVATION
2711         CAIE    A,TACT
2712         JRST    WTYP
2713         MOVE    A,1(AB)         ;WITH RIGHT TIME
2714         HRR     B,A
2715         HLL     B,OTBSAV(B)
2716         HRRZ    C,A             ;AND PLACE
2717         CAIG    C,1(TP)
2718         CAME    A,B
2719         JRST    ILLFRA
2720         GETYP   C,FSAV(C)       ;AND STRUCTURE
2721         CAIE    C,TENTRY
2722         JRST    ILLFRA
2723         POPJ    P,
2724
2725
2726 ;LET B BE TOP LEVEL FRAME
2727
2728 GETTOP: MOVE    B,TPBASE+1(PVP) ;B _ BOTTOM OF TP
2729         MOVEI   B,FRAMLN+1(B)   ;B _ TOP LEVEL FRAME
2730         JRST    RESTPP\fMFUNCTION FAILPOINT,FSUBR,[FAILPOINT]
2731         ENTRY   1
2732         GETYP   A,(AB)          ;ARGUMENT MUST BE LIST
2733         CAIE    A,TLIST
2734         JRST    WTYP
2735         SKIPN   C,1(AB)         ;NON-NIL
2736         JRST    ERRTFA
2737         PUSH    TP,$TLIST       ;SLOT FOR BODY
2738         PUSH    TP,[0]
2739         PUSH    TP,$TLIST
2740         PUSH    TP,[0]
2741         PUSH    TP,$TSP
2742         PUSH    TP,TP           ;SAVE SLOT FOR PRE-(MESS ACT) ENV
2743         MOVE    C,1(AB)         ;GET SET TO CALL BINDER
2744         MOVEI   D,0
2745         PUSH    P,[AUX]         ;---AS A PROG
2746         PUSHJ   P,BINDEV        ;AND GO
2747         HRRZ    C,1(AB)         ;SKIP OVER THINGS BOUND
2748         TRNE    A,H             ;INCLUDING HEWITT ATOM IF THERE
2749         HRRZ    C,(C)
2750         JUMPE   C,NOBODY
2751         HRRZ    C,(C)           ;C _ (EXPR (MESS ACT) -FAIL-BODY-)
2752         JUMPE   C,NOBODY
2753         HRRZ    A,(C)           ;A _ ((MESS ACT) -FAIL-BODY-)
2754         MOVEM   A,3(TB)
2755         MOVE    A,5(TB)
2756         SUB     A,[4,,4]
2757         PUSH    PP,$TPC         ;ESTABLISH FAIL POINT
2758         PUSH    PP,[FP]
2759         PUSH    PP,[TTP,,COP\ON]
2760         PUSH    PP,A            ;SAVE LOCATION OF THIS FRAME
2761         PUSH    TP,(C)
2762         HLLZS   (TP)
2763         PUSH    TP,1(C)
2764         JSP     E,CHKARG
2765         MCALL   1,EVAL          ;EVALUATE EXPR
2766         JRST    FINIS           ;IF SUCCESSFUL, DO NORMAL FINIS
2767
2768 ;FAIL TO HERE--BIND MESSAGE AND ACTIVATION
2769
2770 FP:     MOVEM   SP,5(TB)        ;SAVE SP BEFORE MESS AND ACT BOUND
2771         HRRZ    A,3(TB)         ;A _ ((MESS ACT) -BODY-)
2772         GETYP   C,(A)
2773         CAIE    C,TLIST
2774         JRST    MPD
2775         MOVEI   0,
2776         HRRZ    A,1(A)          ;C _ (MESS ACT)
2777         JUMPE   A,TFMESS        ;IF (), THINGS MUST BE <>
2778         PUSHJ   P,NXTDCL        ;CHECK FOR "STACK"
2779         JRST    NOSTAC
2780         TRZ     B,1
2781         CAME    B,[ASCII /STACK/]
2782         JRST    MPD
2783         TRO     0,STC           ;FOUND,  TURN ON STC SWITCH
2784         HRRZ    C,(A)
2785         JUMPE   C,TFMESS        ;IF ONLY "STACK", MUST HAVE FALSE MESSAGE
2786 NOSTAC: PUSHJ   P,CARATM        ;E _ MESS
2787         JRST    MPD
2788         PUSH    TP,BNDA         ;ELSE BIND IT
2789         PUSH    TP,E
2790         PUSH    TP,MESS(PVP)
2791         PUSH    TP,MESS+1(PVP)
2792         PUSH    TP,[0]
2793         PUSH    TP,[0]
2794         HRRZ    C,(C)           ;C _ (ACT)
2795         JUMPE   C,TFACT         ;IF (), ACT MUST BE <>
2796         PUSHJ   P,CARATM        ;E _ ACT
2797         JRST    MPD
2798         PUSH    TP,BNDA         ;BIND IT
2799         PUSH    TP,E
2800         PUSH    TP,FACTI(PVP)
2801         PUSH    TP,FACTI+1(PVP)
2802         PUSH    TP,[0]
2803         PUSH    TP,[0]
2804         JRST BLPROG
2805 TFMESS: GETYP   A,MESS(PVP)
2806         CAIE    A,TFALSE
2807         JRST    IFAIL
2808 TFACT:  GETYP   A,FACTI(PVP)
2809         CAIE    A,TFALSE
2810         JRST    IFAIL
2811         JRST    BLPROG
2812
2813 ;THIS ROUTINE SETS E TO THE NEXT THING IN THE LIST C POINTS TO,
2814 ;SKIPPING IFF IT IS AN ATOM
2815
2816 CARATM: GETYP   E,(C)
2817         CAIE    E,TATOM
2818         POPJ    P,
2819         MOVE    E,1(C)
2820         AOS     (P)
2821         POPJ    P,
2822
2823
2824 MFUNCTION RESTORE,SUBR,[RESTORE]
2825
2826         ENTRY
2827         HLRE    A,AB
2828         MOVNS   A
2829         CAIG    A,4             ;1 OR 2 ARGUMENTS
2830         CAIGE   A,2
2831         JRST    WNA
2832         PUSHJ   P,TILLFM        ;B _ FRAME TO RESTORE (IF LEGAL)
2833         HRRZ    C,FSAV(B)
2834         CAIE    C,FAILPO        ;ONLY FAILPOINTS RESTORABLE
2835         JRST    ILLFRA
2836         PUSHJ   P,SAVE          ;RESTORE IT
2837         SKIPN   D,5(TB)         ;ARE WE IN EXPR INSTEAD OF BODY?
2838         JRST    EXIT2           ;YES-- EXIT
2839         MOVEM   D,SPSAV(TB)
2840         PUSHJ   P,SPECSTO       ;UNBIND MESS AND ACT
2841         MOVE    TP,TPSAV(TB)
2842         MOVE    P,PSAV(TB)
2843         PUSH    PP,$TPC
2844         PUSH    PP,[FP]
2845         MOVE    E,TB
2846         HRLS    E
2847         MOVE    C,TPSAV(E)
2848         HLRE    B,C
2849         SUBI    B,(C)
2850         HRLZS   B
2851         ADD     E,B             ;CONVERSION TO TTP
2852         PUSH    PP,[TTP,,COP\ON]        ;REESTABLISH FAILPOINT
2853         PUSH    PP,E
2854 EXIT2:  HLRE    C,AB
2855         MOVNS   C
2856         CAIN    C,4             ;VALUE GIVEN?
2857         JRST    RETRG2          ;YES-- RETURN IT
2858         MOVE    AB,ABSAV(TB)    ;IN CASE OF GARBAGE COLLECTION
2859         JRST    IFALSE\f
2860
2861 ;ERROR COMMENTS FOR EVAL
2862
2863 UNBOU:  PUSH    TP,$TATOM
2864         PUSH    TP,MQUOTE UNBOUND-VARIABLE
2865         JRST    ER1ARG
2866
2867 UNAS:   PUSH    TP,$TATOM
2868         PUSH    TP,MQUOTE UNASSIGNED-VARIABLE
2869         JRST    ER1ARG
2870
2871 TFA:
2872 ERRTFA: PUSH    TP,$TATOM
2873         PUSH    TP,MQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
2874         JRST    CALER1
2875
2876 TMA:
2877 ERRTMA: PUSH    TP,$TATOM
2878         PUSH    TP,MQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
2879         JRST    CALER1
2880
2881 BADENV:
2882         PUSH    TP,$TATOM
2883         PUSH    TP,MQUOTE BAD-ENVIRONMENT
2884         JRST    CALER1
2885
2886 FUNERR:
2887         PUSH    TP,$TATOM
2888         PUSH    TP,MQUOTE BAD-FUNARG
2889         JRST    CALER1
2890
2891 WRONGT:
2892 WTYP:   PUSH    TP,$TATOM
2893         PUSH    TP,MQUOTE WRONG-TYPE
2894         JRST    CALER1
2895
2896 MPD:    PUSH    TP,$TATOM
2897         PUSH    TP,MQUOTE MEANINGLESS-PARAMETER-DECLARATION
2898         JRST    CALER1
2899
2900 NOBODY: PUSH    TP,$TATOM
2901         PUSH    TP,MQUOTE HAS-EMPTY-BODY
2902         JRST    CALER1
2903
2904 BADCLS: PUSH    TP,$TATOM
2905         PUSH    TP,MQUOTE BAD-CLAUSE
2906         JRST    CALER1
2907
2908 NXTAG:  PUSH    TP,$TATOM
2909         PUSH    TP,MQUOTE NON-EXISTENT-TAG
2910         JRST    CALER1
2911
2912 NXPRG:  PUSH    TP,$TATOM
2913         PUSH    TP,MQUOTE NOT-IN-PROG
2914         JRST    CALER1
2915
2916 NAPT:   PUSH    TP,$TATOM
2917         PUSH    TP,MQUOTE NON-APPLICABLE-TYPE
2918         JRST    CALER1
2919
2920 NONEVT: PUSH    TP,$TATOM
2921         PUSH    TP,MQUOTE NON-EVALUATEABLE-TYPE
2922         JRST    CALER1
2923
2924
2925 NONATM: PUSH    TP,$TATOM
2926         PUSH    TP,MQUOTE NON-ATOMIC-ARGUMENT
2927         JRST    CALER1
2928
2929
2930 ILLFRA: PUSH    TP,$TATOM
2931         PUSH    TP,MQUOTE FRAME-NO-LONGER-EXISTS
2932         JRST    CALER1
2933
2934 NOTIMP: PUSH    TP,$TATOM
2935         PUSH    TP,MQUOTE NOT-YET-IMPLEMENTED
2936         JRST    CALER1
2937
2938 ILLSEG: PUSH    TP,$TATOM
2939         PUSH    TP,MQUOTE ILLEGAL-SEGMENT
2940         JRST    CALER1
2941
2942 BADPP:  PUSH    TP,$TATOM
2943         PUSH    TP,MQUOTE PP-IN-ILLEGAL-CONFIGURATION
2944         JRST    CALER1
2945
2946
2947 BDFAIL: PUSH    TP,$TATOM
2948         PUSH    TP,MQUOTE OVERPOP--FAIL
2949         JRST    CALER1
2950
2951
2952 ER1ARG: PUSH    TP,(AB)
2953         PUSH    TP,1(AB)
2954         MOVEI   A,2
2955         JRST    CALER
2956 CALER1: MOVEI   A,1
2957 CALER:
2958         HRRZ    C,FSAV(TB)
2959         PUSH    TP,$TATOM
2960         PUSH    TP,@-1(C)
2961         ADDI    A,1
2962         ACALL   A,ERROR
2963         JRST    FINIS
2964
2965 END
2966 ***\f\f\ 3\f