MUDDLE/neval.nostac

   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
  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         PUSH    P,[0]           ;"UNEVAL" MARKER
 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         PUSH    P,[-1]          ;"EVAL" MARKER
 366 IAPPL1: GETYP   A,(TB)
 367         CAIN    A,TEXPR         ;EXPR?
 368         JRST    APEXPR          ;YES
 369         CAIN    A,TSUBR         ;NO -- SUBR?
 370         JRST    APSUBR          ;YES
 371         CAIN    A,TFSUBR        ;NO -- FSUBR?
 372         JRST    APFSUBR         ;YES
 373         CAIN    A,TFIX          ;NO -- CALL TO NTH?
 374         JRST    APNUM           ;YES
 375         CAIN    A,TACT          ;NO -- ACTIVATION?
 376         JRST    APACT           ;YES
 377         CAIN    A,TFUNARG       ;NO -- FUNARG?
 378         JRST    APFUNARG        ;YES
 379         CAIN    A,TPVP          ;NO -- PROCESS TO BE RESUMED?
 380         JRST    NOTIMP          ;YES
 381         JRST    NAPT            ;NONE OF THE ABOVE
 382
 383
 384 ;APFSUBR CALLS FSUBRS
 385
 386 APFSUBR:
 387         MCALL   1,@1(TB)
 388         JRST    FINIS
 389
 390 ;APSUBR CALLS SUBRS
 391
 392 APSUBR:
 393         PUSH    P,[0]           ;MAKE SLOT FOR ARGCNT
 394 TUPLUP:
 395         SKIPN   A,3(TB)         ;IS IT NIL?
 396         JRST    MAKPTR          ;YES -- DONE
 397         PUSH    TP,(A)          ;NO -- GET CAR OF THE
 398         HLLZS   (TP)            ;ARGLIST
 399         PUSH    TP,1(A)
 400         JSP     E,CHKARG
 401         SKIPN   -1(P)           ;EVAL?
 402         JRST    BUMP            ;NO
 403         MCALL   1,EVAL          ;AND EVAL IT.
 404         PUSH    TP,A            ;SAVE THE RESULT IN
 405         PUSH    TP,B            ;THE GROWING TUPLE
 406 BUMP:   AOS     (P)             ;BUMP THE ARGCNT
 407         HRRZ    A,@3(TB)        ;SET THE ARGLIST TO
 408         MOVEM   A,3(TB)         ;CDR OF THE ARGLIST
 409         JRST    TUPLUP
 410 MAKPTR:
 411         POP     P,A
 412         ACALL   A,@1(TB)
 413         JRST    FINIS
 414
 415 ;APACT INTERPRETS ACTIVATIONS AS CALLS TO FUNCTION EXIT
 416
 417 APACT:  MOVE    A,(TP)          ;A _ ARGLIST
 418         JUMPE   A,TFA
 419         GETYP   B,(A)           ;SETUP SECOND ARGUMENT
 420         HRLZM   B,-1(TP)
 421         MOVE    B,1(A)
 422         MOVEM   B,(TP)
 423         HRRZ    A,(A)           ;MAKE SURE ONLY ONE
 424         JUMPN   A,TMA
 425         JSP     E,CHKARG
 426         SKIPN   (P)             ;IF ARGUMENT AS YET UNEVALED,
 427         MCALL   2,EXIT
 428         MCALL   1,EVAL          ;EVAL IT
 429         PUSH    TP,A
 430         PUSH    TP,B
 431         MCALL   2,EXIT          ;AND EXIT GIVEN ACTIVATION\f
 432
 433 ;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
 434
 435 APNUM:
 436         MOVE    A,(TP)          ;GET ARLIST
 437         JUMPE   A,ERRTFA        ;NO ARGUMENT
 438         PUSH    TP,(A)          ;GET CAR OF ARGL
 439         HLLZS   (TP)
 440         PUSH    TP,1(A)
 441         HRRZ    A,(A)           ;MAKE SURE ONLY ONE ARG
 442         JUMPN   A,ERRTMA
 443         JSP     E,CHKARG        ;HACK DEFERRED
 444         SKIPN   (P)             ;EVAL?
 445         JRST    DONTH
 446         MCALL   1,EVAL          ;YES
 447         PUSH    TP,A
 448         PUSH    TP,B
 449 DONTH:  PUSH    TP,(TB)
 450         PUSH    TP,1(TB)
 451         MCALL   2,NTH
 452         JRST    FINIS
 453
 454 ;APEXPR APPLIES EXPRS
 455 ;EXPRESSION IS IN 0(AB),  FUNCTION IS IN 0(TB)
 456
 457 APEXP2: HRRZ    0,1(AB)
 458         PUSH    P,[ARGEV]
 459
 460 APEXPR:
 461
 462         SKIPN   C,1(TB)         ;BODY?
 463         JRST    NOBODY          ;NO, ERROR
 464         MOVE    D,(TP)          ;D _ ARG LIST
 465         SETZM   (TP)            ;ZERO (TP) FOR BODY
 466         PUSHJ   P,BINDAP        ;DO THE BINDINGS
 467
 468 APEXP1: 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         SETO    D,
 867         GETYP   A,A
 868         CAIN    A,TFALSE        ;CAN BE #FALSE OR LIST
 869         JRST    DOBI            ;IF <>, AUXILIARY BINDINGS
 870         PUSHJ   P,SAT
 871         CAIE    A,S2WORD
 872         JRST    WTYP
 873         MOVEI   D,(B)           ;D _ DECLARATIONS
 874 DOBI:   POP     TP,C            ;RESTORE C _ FIRST ARG
 875         SUB     TP,[1,,1]
 876         MOVEI   0,              ;NO CALL
 877         PUSHJ   P,BINDER
 878         HRRZ    C,1(AB)
 879         HRRZ    C,(C)
 880         HRRZ    C,(C)           ;C _ <REST <REST .ARG>>
 881         JRST    BIPROG          ;NOW EXECUTE BODY AS PROG\f
 882
 883 ;BINDER - THIS SUBROUTINE PROCESSES FUNCTION DECLARATIONS AND BINDS
 884 ;       ARGUMENTS       AND TEMPORARIES APPROPRIATELY.
 885 ;
 886 ;       CALL:   PUSHJ   P,BINDER OR BINDRR
 887 ;
 888 ;       BINDAP - ARGS ARE ON A LIST, EVALED IFF (P) NOT = 0
 889 ;
 890 ;       BINDER - 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 (IF <0, CALLED FROM A PROG)
 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==0
 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
 912
 913 BINDAP: MOVE    A,[ARGNEV]
 914         SKIPE   -1(P)
 915         MOVE    A,[ARGEV]
 916         POP     P,-1(P)         ;FLUSH EVAL MARKER
 917         PUSH    P,A
 918         JRST    BIND1
 919 BINDER: PUSH    P,[ARGEV]
 920         JRST    BIND1
 921 BINDRR: PUSH    P,[NOTIMP]
 922 BIND1:  PUSH    P,[0]           ;OPT _ QUO _ AUX _ H _ OFF
 923         PUSH    P,0             ;SAVE CALL, IF ANY
 924         PUSHJ   P,BNDVEC        ;E _ TOP OF BINDING STACK
 925         GETYP   A,(C)
 926         CAIE    A,TATOM         ;HEWITT ATOM?
 927         JRST    BIND2
 928         HLRE    A,E
 929         HRRZ    B,E
 930         SUB     B,A             ;B _ FIRST DOPE WORD OF E
 931         MOVSI   A,TBIND
 932         MOVEM   A,-6(B)         ;BUILD BIND BLOCK FOR ATOM
 933         MOVE    A,1(C)          ;A _ HEWITT ATOM
 934         MOVEM   A,-5(B)
 935         MOVE    A,TB
 936         HLL     A,OTBSAV(TB)    ;A _ POINTER TO THIS ACTIVATION
 937         MOVEM   A,-3(B)
 938         MOVEI   0,(PVP)
 939         HLRE    A,PVP
 940         SUBI    0,-1(A)         ;0 _ PROCESS VEC DOPE WORD
 941         HRLI    0,TACT          ;0 IS FIRST WORD OF ACT VALUE
 942         MOVEM   0,-4(B)         ;STORED IN BIND BLOCK
 943         HRRZ    C,(C)           ;CDR THE FUNCTION
 944 BIND2:  POP     P,0             ;0 _ CALLING EXPRESSION
 945         PUSHJ   P,CARLST        ;C _ DECLS LIST
 946         JRST    BINDC           ;IF (), QUIT
 947         JUMPL   D,AUXDO         ;IN CASE OF PROG
 948         MOVEI   A,(C)
 949         PUSHJ   P,NXTDCL        ;B _ NEXT STRING
 950         JRST    BINDRG          ;ATOM INSTEAD
 951         HRRZ    C,(C)           ;CDR DECLS
 952
 953
 954 ;CHECK FOR "BIND"
 955
 956         CAME    B,[ASCII /BIND/ ]
 957         JRST    CHCALL
 958         JUMPE   C,MPD           ;GOT "BIND", NOW...
 959         PUSHJ   P,CARATE        ;GET ATOM & START BIND BLOCK
 960         HRLZI   A,TENV
 961         MOVE    B,1(SP)         ;B _ ENV BEFORE BNDVEC
 962         PUSHJ   P,PSHBND        ;FINISH BIND BLOCK
 963         HRRZ    C,(C)
 964         JUMPE   C,BINDC         ;MAY BE DONE
 965         MOVEI   A,(C)
 966         PUSHJ   P,NXTDCL        ;NEXT ONE
 967         JRST    BINDRG          ;ATOM INSTEAD
 968         HRRZ    C,(C)           ;CDR DECLS
 969
 970 ;CHECK FOR "CALL"
 971
 972 CHCALL: CAME    B,[ASCII /CALL/ ]
 973         JRST    CHOPTI          ;GO INTO MAIN BINDING LOOP
 974         JUMPE   0,MPD           ;GOT "CALL", SO 0 MUST BE CALL
 975         JUMPE   C,MPD
 976         PUSHJ   P,CARATE        ;GET ATOM & START BIND BLOCK\f   MOVE    B,0             ;B _ CALL
 977         MOVSI   A,TLIST
 978         PUSHJ   P,PSHBND        ;MAKE BIND BLOCK
 979         HRRZ    C,(C)           ;CDR PAST "CALL" ATOM
 980         JUMPE   C,BINDC         ;IF DONE, QUIT
 981
 982 ;DECLLP IS THE MAIN BINDING LOOP FOR HANDLING FUNCTIONAL ARGUMENTS AND
 983 ;THE STRINGS SCATTERED THEREIN
 984
 985 DECLLP: MOVEI   A,(C)
 986         PUSHJ   P,NXTDCL        ;NEXT STRING...
 987         JRST    BINDRG          ;...UNLESS SOMETHING ELSE
 988         HRRZ    C,(C)           ;CDR DECLARATIONS
 989 CHOPTI: TRZ     B,1             ;GOD KNOWS WHY TRZ B,1 (SOMETHING TO DO WITH OPTIO)
 990
 991 ;CHECK FOR "OPTIONAL"
 992
 993         CAME    B,[ASCII /OPTIO/]
 994         JRST    CHREST
 995         MOVE    0,SWTCHS(P)     ;OPT _ ON
 996         TRO     0,OPT
 997         MOVEM   0,SWTCHS(P)
 998         JUMPE   C,BINDC
 999         PUSHJ   P,EBINDS        ;BIND ALL PREVIOUS ARGUMENTS
1000         JRST    DECLLP
1001
1002 ;CHECK FOR "REST"
1003
1004 CHREST: MOVE    0,SWTCHS(P)     ;0 _ SWITCHES
1005         TRZ     0,OPT           ;OPT _ OFF
1006         MOVEM   0,SWTCHS(P)
1007         MOVEI   A,(C)
1008         CAME    B,[ASCII /REST/]
1009         JRST    CHTUPL
1010         PUSHJ   P,NXTDCL        ;GOT "REST"-- LOOK AT NEXT THING
1011         SKIPN   C
1012         JRST    MPD             ;WHICH CAN'T BE STRING
1013         PUSHJ   P,BINDB         ;GET NEXT ATOM
1014         TRNE    0,QUO           ;QUOTED?
1015         JRST    ARGSDO          ;YES-- JUST USE ARGS
1016         JRST    TUPLDO
1017
1018 ;CHECK FOR "TUPLE"
1019
1020 CHTUPL: CAME    B,[ASCII /TUPLE/]
1021         JRST    CHARG
1022         PUSHJ   P,NXTDCL        ;GOT "TUPLE"-- LOOK AT NEXT THING
1023         SKIPN   C
1024         JRST    MPD
1025         PUSHJ   P,CARATE        ;WHICH BETTER BE ATOM
1026
1027 TUPLDO: PUSH    TP,$TLIST       ;SAVE STUFF
1028         PUSH    TP,C
1029         PUSH    TP,$TVEC
1030         PUSH    TP,E
1031         PUSH    P,[0]           ;ARG COUNTER\f;THIS LOOP BUILDS A TUPLE ON THE STACK, ON THE TOP OF THE ENTITIES
1032 ;JUST SAVED-- DON'T WORRY; THEY'RE SAFE
1033
1034 TUPLP:  JUMPE   D,TUPDON        ;IF NO MORE ARGS, DONE
1035         INTGO                   ;WATCH OUT FOR BIG TUPLES AND SMALL STACKS
1036         PUSH    TP,$TLIST       ;SAVE D
1037         PUSH    TP,D
1038         GETYP   A,(D)           ;GET NEXT ARG
1039         MOVSI   A,(A)
1040         PUSH    TP,A            ;EVAL IT
1041         PUSH    TP,1(D)
1042         TRZ     0,DEF           ;OFF DEFAULT
1043         PUSHJ   P,@EVALER-1(P)
1044         POP     TP,D            ;RESTORE D
1045         SUB     TP,[1,,1]
1046         PUSH    TP,A            ;BUILD TUPLE
1047         PUSH    TP,B
1048         SOS     (P)             ;COUNT ELEMENTS
1049         HRRZ    D,(D)           ;CDR THE ARGS
1050         JRST    TUPLP
1051 TUPDON: PUSHJ   P,MRKTUP        ;MAKE A TUPLE OF (P) ENTRIES
1052         SUB     P,[1,,1]        ;FLUSH COUNTER
1053         JRST    BNDRST\f;CHECK FOR "ARGS"
1054
1055 CHARG:  CAME    B,[ASCII /ARGS/]
1056         JRST    CHAUX
1057         PUSHJ   P,NXTDCL        ;GOT "ARGS"-- CHECK NEXT THING
1058         SKIPN   C
1059         JRST    MPD
1060         PUSHJ   P,CARATE        ;WHICH MUST BE ATOM
1061
1062 ;HERE TO BIND AN ATOM TO THE REMAINING ARGS, UNEVALUATED
1063
1064 ARGSDO: MOVSI   A,TLIST         ;(A,B) _ CURRENT ARGS LEFT
1065         MOVE    B,D
1066         MOVEI   D,
1067
1068 ;BNDRST COMPLETES THE BIND BLOCK FOR BOTH TUPLES AND ARGS
1069
1070 BNDRST: PUSHJ   P,PSHBND
1071         HRRZ    C,(C)           ;CDR THE DECLS
1072         JUMPE   C,BINDC
1073         MOVEI   A,(C)
1074         PUSHJ   P,NXTDCL        ;WHAT NEXT?
1075         JRST    MPD             ;MUST BE A STRING OR ELSE
1076         HRRZ    C,(C)           ;CDR DECLS
1077
1078 ;CHECK FOR "AUX"
1079
1080 CHAUX:  CAME    B,[ASCII /AUX/]
1081         JRST    CHACT
1082         JUMPG   D,TMA           ;ARGS MUST BE USED UP BY NOW
1083         PUSH    P,C             ;SAVE C ON P (NO GC POSSIBLE)
1084         PUSHJ   P,EBIND         ;BIND ALL ARG ATOMS
1085         POP     P,C             ;RESTORE C
1086
1087 ;HERE FOR AUXIES OF "AUX" OR PROG VARIETY
1088
1089 AUXDO:  MOVE    0,SWTCHS(P)
1090         TRO     0,AUX\OPT\DEF   ;OPTIONALS OBVIOUSLY ALLOWED
1091         MOVEM   0,SWTCHS(P)
1092 AUXLP:  JUMPE   C,BNDHAT        ;IF NO MORE, QUIT
1093         MOVEI   A,(C)
1094         PUSHJ   P,NXTDCL        ;GET NEXT DECLARATION STRING
1095         JRST    AUXIE           ;INSTEAD, ANOTHER AUXIE-- DO IT
1096         HRRZ    C,(C)           ;CDR PAST STRING
1097         JRST    CHACT1          ;...WHICH MUST BE "ACT"
1098
1099 ;NORMAL AUXILIARY DECLARATION HANDLER
1100
1101 AUXIE:  MOVE    0,SWTCHS(P)
1102         PUSH    TP,$TLIST       ;SAVE C
1103         PUSH    TP,C
1104         PUSHJ   P,BINDB         ;PUSH NEXT ATOM ONTO E
1105         MOVE    A,$TVEC         ;SAVE E UNDER DEFAULT VALUE
1106         EXCH    A,-1(TP)
1107         EXCH    E,(TP)
1108         PUSH    TP,A            ;(DEFAULT VALUE MUST BE REPUSHED)
1109         PUSH    TP,E
1110         PUSHJ   P,@EVALER(P)    ;EVAL THE VALUE IT IS TO RECEIVE
1111         POP     TP,E            ;RESTORE E
1112         SUB     TP,[1,,1]
1113         PUSHJ   P,PSHBND        ;COMPLETE BINDING BLOCK WITH VALUE
1114         PUSHJ   P,EBIND         ;BIND THE ATOM
1115         POP     TP,C            ;RESTORE C
1116         SUB     TP,[1,,1]
1117         HRRZ    C,(C)           ;CDR THE DECLARATIONS
1118         JRST    AUXLP
1119 \f;"ACT" CAN OCCUR ONLY AT THE END, HEWITT ATOMS NOTWITHSTANDING
1120
1121 CHACT1: MOVEI   D,              ;MAKE IT CLEAR THAT THERE ARE NO ARGS
1122 CHACT:  CAME    B,[ASCII /ACT/] ;ONLY THING POSSIBLE
1123         JRST    MPD
1124         JUMPE   C,MPD           ;BETTER HAVE AN ATOM TO BIND TO ACT
1125         PUSHJ   P,CARATE        ;START BIND BLOCK WITH IT
1126         MOVEI   A,(PVP)
1127         HLRE    B,PVP
1128         SUBI    A,-1(B)         ;A _ PROCESS VEC DOPE WORD
1129         HRLI    A,TACT
1130         MOVE    B,TB
1131         HLL     B,OTBSAV(TB)    ;(A,B) _ ACTIVATION POINTER
1132         PUSHJ   P,PSHBND
1133         HRRZ    C,(C)           ;"ACT" MUST HAVE BEEN LAST
1134         JUMPN   C,MPD
1135
1136 ;AT THIS POINT, ALL ENTRIES ARE FINAL AND ALL THINGS LOOSED
1137 ;IN E SHALL BE BOUND IN E, EVENTUALLY
1138
1139 BINDC:  JUMPG   D,TMA           ;ARGS SHOULD BE USED UP BY NOW
1140         PUSHJ   P,EBIND         ;BIND EVERYTHING NOT BOUND
1141 BNDHAT: MOVE    0,SWTCHS(P)     ;EVEN THE HEWITT ATOM
1142         TRNN    0,H             ;IF THERE IS ONE
1143         JRST    BNDRET
1144         HLRE    B,E
1145         HRRZI   E,(E)
1146         SUB     E,B             ;E _ DOPE WORD OF BINDING VECTOR
1147         SUB     E,[5,,5]        ;E _ POINTER TO HEWITT ATOM SLOT
1148         PUSHJ   P,COMBLK        ;CHAIN THIS BLOCK TO PREVIOUS THING IN VECTOR
1149         ADD     E,[4,,4]        ;E _ LAST WORD OF BINDING VECTOR
1150         PUSHJ   P,EBIND         ;BIND THE HEWITT ATOM
1151
1152 ;THIS IS THE WAY OUT OF THE BINDER
1153
1154 BNDRET: POP     P,A             ;A _ SWITCHES
1155         SUB     P,[1,,1]        ;FLUSH EVALER
1156         POPJ    P,              ;RETURN FROM BINDER\f;TO BIND A PERFECTLY ORDINARY ARGUMENT SPECIFICATION
1157 ;FOUND IN A DECLS LIST, JUMP HERE
1158
1159 BINDRG: MOVE    0,SWTCHS(P)
1160         PUSHJ   P,BINDB         ;GET ATOM IN THE NEXT DECL
1161         JUMPE   D,CHOPT3        ;IF ARG EXISTS,
1162         TRNE    0,OPT
1163         SUB     TP,[2,,2]       ;PITCH ANY DEFAULT THAT MAY EXIST
1164         GETYP   A,(D)           ;(A,B) _ NEXT ARG
1165         MOVSI   A,(A)
1166         MOVE    B,1(D)
1167         HRRZ    D,(D)           ;CDR THE ARGS
1168         TRZN    0,QUO           ;ARG QUOTED?
1169         JRST    BNDRG1          ;NO-- GO EVAL
1170 CHDEFR: MOVEM   0,SWTCHS(P)
1171         CAME    A,$TDEFER       ;QUOTED-- PUNT ANY TDEFER'S YOU FIND
1172         JRST    DCLCDR
1173         GETYP   A,(B)           ;(A,B) _ REAL POINTER, NOT DEFERRED
1174         MOVE    B,1(B)
1175         JRST    DCLCDR          ;AND FINISH BIND BLOCK
1176
1177 ;OPTIONAL ARGUMENT?
1178
1179 CHOPT3: TRNN    0,OPT           ;IF NO ARG, BETTER BE OPTIONAL
1180         JRST    TFA
1181         POP     TP,B            ;(A,B) _ DEFAULT VALUE
1182         POP     TP,A
1183         TRZE    0,QUO           ;IF QUOTED,
1184         JRST    CHDEFR          ;JUST PUSH
1185         TRO     0,DEF           ;ON DEFAULT
1186
1187 ;EVALUATE WHATEVER YOU HAVE AT THIS POINT
1188
1189 BNDRG1: PUSH    TP,$TLIST       ;SAVE STUFF
1190         PUSH    TP,D
1191         PUSH    TP,$TLIST
1192         PUSH    TP,C
1193         PUSH    TP,$TVEC
1194         PUSH    TP,E
1195         PUSH    TP,A
1196         PUSH    TP,B
1197         PUSHJ   P,@EVALER(P)    ;(A,B) _ <EVAL (A,B)>
1198         MOVE    E,(TP)          ;RESTORE C, D, & E
1199         MOVE    C,-2(TP)
1200         MOVE    D,-4(TP)
1201         SUB     TP,[6,,6]
1202         MOVE    0,SWTCHS(P)     ;RESTORE 0
1203
1204
1205 ;FINISH THE BIND BLOCK WITH (A,B) AND GO ON
1206
1207 DCLCDR: PUSHJ   P,PSHBND
1208         TRNE    0,OPT           ;IF OPTIONAL,
1209         PUSHJ   P,EBINDS        ;BIND IT
1210         HRRZ    C,(C)
1211         JUMPE   C,BINDC         ;IF NO MORE DECLS, QUIT
1212         JRST    DECLLP\f;THIS ROUTINE CREATES THE BIND VECTOR BINDER USES; IT ALLOCATES
1213 ;THREE SLOTS PER NON-STRING DECLARATION (I.E., ATOM TO BE BOUND),
1214 ;THREE FOR A HEWITT ATOM IF IT FINDS ONE, AND ONE FOR THE ACCESS
1215 ;TYPE-TSP POINTER TO SP.
1216
1217 ;IT SETS E TO THE CURRENT TOP OF THE VECTOR; IT FILLS IN
1218 ;ACCESS SLOT WITH SP, AND SETS SP TO POINT TO
1219 ;THE START OF THIS VECTOR.  IT MAY SET SWITCH H TO ON, IFF IT FINDS
1220 ;A HEWITT ATOM.  IT CLOBBERS A & B, RESTORES C & D, AND LEAVES THE
1221 ;SWITCHES IN 0
1222
1223 ;IF BNDVEC FINDS NO DECLARATIONS, IT TAKES THE LIBERTY OF EXITING
1224 ;FROM THE BINDER WITHOUT DISTURBING SP.  BNDVEC DOES SOME ERROR
1225 ;CHECKING, BUT NOT ALL, AS IT DOES NOT LOOK AT THE ARGS IN D.
1226 ;THIS EXPLAINS WHY BINDER OMITS SOME.
1227
1228 BNDVEC: PUSH    TP,$TLIST       ;SAVE C & D
1229         PUSH    TP,C
1230         PUSH    TP,$TLIST
1231         PUSH    TP,D
1232         JUMPE   C,NOBODY
1233         MOVE    0,SWTCHS-2(P)   ;UNBURY THE SWITCHES
1234         MOVEI   D,              ;D = COUNTER _ 0
1235         GETYP   A,(C)           ;A _ FIRST THING
1236         CAIE    A,TATOM         ;HEWITT ATOM?
1237         JRST    NOHATM
1238         TRO     0,H             ;TURN SWITCH H ON
1239         ADDI    D,3             ;YES-- SAVE 3 SLOTS FOR IT
1240         HRRZ    C,(C)           ;CDR THE FUNCTION
1241         JUMPE   C,NOBODY
1242 NOHATM: PUSHJ   P,CARLST        ;C _ <1 .C>
1243         JRST    CNTRET          ;IF (), ALL COUNTED
1244         MOVEI   A,(C)           ;A _ DECLS
1245
1246 ;HERE IS THE QUICK LOOP THROUGH THE DECLARATIONS
1247
1248 DCNTLP: PUSHJ   P,NXTDCL        ;SKIP IF NEXT ONE IS A STRING
1249 DINC:   ADDI    D,3             ;3 SLOTS FOR AN ATOM
1250         HRRZ    A,(A)           ;GO AROUND AGAIN
1251         JUMPN   A,DCNTLP
1252
1253 ;IF ANYTHING WAS FOUND, INITIALIZE THE VECTOR
1254
1255 CNTRET: JUMPE   D,NODCLS        ;OTHERWISE, BIND NOTHING
1256         AOJ     D,              ;DON'T FORGET ACCESS SLOT
1257         MOVEM   0,SWTCHS-2(P)   ;SAVE SWITCHES
1258         PUSH    TP,$TFIX
1259         PUSH    TP,D
1260         MCALL   1,VECTOR        ;B _ <VECTOR .D>
1261         MOVE    D,(TP)          ;RESTORE C & D
1262         MOVE    C,-2(TP)
1263         SUB     TP,[4,,4]
1264         MOVE    E,B             ;FROM NOW ON, E _ BIND VECTOR TOP
1265         MOVE    A,B
1266         MOVSI   B,TSP
1267         MOVEM   B,(E)           ;FILL ACCESS SLOT
1268         PUSH    E,SP
1269         MOVE    SP,A            ;SP NOW POINTS THROUGH THIS VECTOR
1270         POPJ    P,
1271
1272 ;IF THERE ARE NO DECLS (E.G. <FUNCTION ()...>), JUST QUIT
1273
1274 NODCLS: MOVE    D,(TP)          ;RESTORE C & D
1275         MOVE    C,-2(TP)
1276         SUB     TP,[4,,4]
1277         SUB     P,[2,,2]        ;PITCH RETURN ADDRESS AND CALL
1278         JRST    BNDRET\f;THIS ROUTINE CREATES A POINTER TO THE TUPLE RESTING ON TOP OF
1279 ;TP.  IT TAKES ITS NEGATIVE LENGTH (IN CELLS) IN (P).  IT ASSUMES
1280 ;THERE ARE TWO TEMPORARY CELLS BENEATH IT, AND RESTORES
1281 ;THEM INTO C AND E, MOVING THE TUPLE OVER THE TEMPORARY
1282 ;SLOTS.  IT RETURNS A CORRECT TARGS POINTER TO THE TUPLE IN A AND B
1283
1284 MRKTUP: MOVSI   A,TTB           ;FENCE-POST TUPLE
1285         PUSH    TP,A
1286         PUSH    TP,TB
1287         MOVEI   A,2             ;B_ADDRESS OF INFO CELL
1288         PUSHJ   P,CELL"         ;MAY CALL AGC
1289         MOVSI   A,TINFO
1290         MOVEM   A,(B)
1291         MOVEI   A,(TP)          ;GENERATE DOPE WORD POINTER
1292         HLRE    C,TP
1293         SUBI    A,-1(C)
1294         CAME    A,TPGROW"       ;ALLOWING FOR BLOWN PDL
1295         ADDI    A,PDLBUF
1296         HRLZI   A,-1(A)         ;A HAS 1ST DW PTR IN LEFT HALF
1297         HLR     A,OTBSAV(TB)    ;TIME TO RIGHT
1298         MOVEM   A,1(B)          ;TO SECOND WORD OF CELL
1299         EXCH    B,-1(P)         ;B _ - ARG COUNT
1300         ASH     B,1             ;B _ 2*B
1301         HRRM    B,-1(TP)        ;STORE IN TTB FENCEPOST
1302         HRRZI   A,-5(TP)
1303         ADD     A,B             ;A _ ADR OF TUPLE
1304         HRLI    A,(B)           ;A _ TUPLE POINTER
1305         MOVE    B,A             ;B, TOO
1306         HRLI    A,4(A)          ;LH A _ CURRENT PLACE OF TUPLE
1307         MOVE    C,1(A)          ;RESTORE C AND E
1308         MOVE    E,3(A)
1309         BLT     A,-4(TP)        ;MOVE TUPLE OVER OLD C, E COPIES
1310         SUB     TP,[4,,4]
1311         MOVE    A,-1(P)
1312         HRLI    A,TARGS         ;A _ FIRST WORD OF ARGS TUPLE VALUE
1313         POPJ    P,\f;THIS ROUTINE, GIVEN SWTCHS IN 0 AND DECLARATIONS LIST POINTER
1314 ;IN C, PUSHES ATOM IN THE FIRST DECLARATION ONTO E.  IT MAY SET
1315 ;SWITCHES OPT AND QUO, AND LEAVES SWITCHES IN 0.    IFF OPT = ON,
1316 ;BINDB PUSHES A DEFAULT VALUE (EVEN IF ?()) ONTO TP.  A & B ARE
1317 ;CLOBBERED.  C IS NOT ALTERED.
1318
1319 BINDB:  MOVE    A,C             ;A _ C
1320         GETYP   B,(A)
1321         CAIE    B,TLIST         ;A = ((...)...) ?
1322         JRST    CHOPT1
1323         TRNN    0,OPT           ;YES-- OPT MUST BE ON
1324         JRST    MPD
1325         MOVEM   0,SWTCHS-1(P)   ;SAVE SWITCHES
1326         MOVE    A,1(A)          ;A _ <1 .A> = (...)
1327         JUMPE   A,MPD           ;A = () NOT ALLOWED
1328         HRRZ    B,(A)           ;B _ <REST .A>
1329         JUMPE   B,MPD           ;B = () NOT ALLOWED
1330         PUSH    TP,(B)          ;SAVE <1 .B> AS DEFAULT
1331         PUSH    TP,1(B)         ;VALUE OF ATOM IN A
1332         HRRZ    B,(B)
1333         JUMPN   B,MPD           ;<REST .B> MUST = ()
1334         GETYP   B,(A)
1335         JRST    CHFORM          ;GO SEE WHAT <1 .A> IS
1336
1337 CHOPT1: TRNN    0,OPT           ;IF OPT = ON
1338         JRST    CHFORM
1339         PUSH    TP,$TUNAS       ;DEFAULT VALUE IS ?()
1340         PUSH    TP,[0]
1341
1342 ;AT THIS POINT, <1 .A> MUST BE ATOM OR <QUOTE ATOM>
1343
1344 CHFORM: TRNE    0,AUX           ;NO QUOTES ALLOWED IN AUXIES
1345         JRST    CHATOM
1346         CAIE    B,TFORM
1347         JRST    CHATOM
1348         MOVE    A,1(A)          ;A _ <1 .A> = <...>
1349         JUMPE   A,MPD           ;A = <> NOT ALLOWED
1350         MOVE    B,1(A)          ;B _ <1 .A>
1351         CAME    B,MQUOTE QUOTE
1352         JRST    MPD             ;ONLY A = <QUOTE...> ALLOWED
1353         TRO     0,QUO           ;QUO _ ON
1354         MOVEM   0,SWTCHS-1(P)
1355         HRRZ    A,(A)           ;A _ <REST .A>
1356         JUMPE   A,MPD           ;<QUOTE> NOT ALLOWED
1357         GETYP   B,(A)
1358
1359 ;AT THIS POINT WE HAVE THE ATOM OR AN ERROR
1360
1361 CHATOM: CAIE    B,TATOM         ;<1 .A> MUST BE ATOM
1362         JRST    MPD
1363         MOVE    A,1(A)          ;A _ THE ATOM!!!
1364         JRST    PSHATM          ;WHICH MUST BE PUSHED ONTO E
1365
1366
1367
1368 ;THE FOLLOWING LITTLE ROUTINE ACCEPTS THE NEXT DECLARATION ONLY
1369 ;IF IT IS ATOMIC, AND PUSHES IT ONTO E
1370
1371 CARATE: GETYP   A,(C)
1372         CAIE    A,TATOM
1373         JRST    MPD
1374         MOVE    A,1(C)          ;A _ ATOM
1375         MOVE    0,SWTCHS-1(P)
1376 PSHATM: PUSH    E,$TBIND        ;FILL FIRST TWO SLOTS OF BIND BLOCK
1377         PUSH    E,A
1378
1379 ;EACH BIND BLOCK MUST POINT TO THE PREVIOUS ONE OR TO AN ACCESS
1380 ;POINTER TO ANOTHER VECTOR ALTOGETHER.  COMBLK MAKES SURE IT DOES.
1381
1382 COMBLK: GETYP   B,-7(E)         ;LOOK FOR PREVIOUS BIND
1383         CAIE    B,TBIND         ;IF FOUND, MAKE NORMAL LINK
1384         JRST    ABNORM
1385         MOVEI   B,-7(E)         ;IN MOST CASES, SEVEN
1386 MAKLNK: HRRM    B,-1(E)         ;MAKE THE LINK
1387         POPJ    P,
1388 ABNORM: MOVEI   B,-3(E)
1389         JRST    MAKLNK
1390 \f;THIS ROUTINE COMPLETES A BIND BLOCK BEGUN BY CARATE OR BINDB
1391 ;WITH THE VALUE (A,B)
1392
1393 PSHBND: PUSH    E,A
1394         PUSH    E,B
1395         ADD     E,[2,,2]        ;ASSUME BIND VECTOR IS FULL OF 0'S
1396         POPJ    P,
1397
1398 ;THIS ONE DOES AN EBIND, SAVING C & D:
1399
1400 EBINDS: PUSH    P,C             ;SAVE C & D (NO DANGER OF GC)
1401         PUSH    P,D
1402         PUSHJ   P,EBIND         ;BIND ALL NON-OPTIONAL ARGUMENTS
1403         POP     P,D
1404         POP     P,C             ;RESTORE C & D
1405         POPJ    P,
1406
1407
1408 ;THE FOLLOWING RETURNS THE CAR OF C IN C, SKIPPING IF
1409 ;<EMPTY? <1 .C>>, AND ERRING IF <NOT <==? <TYPE <1 .C>> LIST>>
1410
1411 CARLST: GETYP   A,(C)
1412         CAIE    A,TLIST
1413         JRST    MPD             ;NOT A LIST, FATAL
1414         SKIPE   C,1(C)
1415         AOS     (P)
1416         POPJ    P,
1417
1418
1419 ;...AND THERE ARE A FEW PEOPLE STILL CALLING THE FOLLOWING:
1420
1421 MAKENV: PUSH    P,C             ;SAVE AN AC
1422         HLRE    C,PVP           ;GET -LNTH OF PROC VECTOR
1423         MOVEI   A,(PVP)         ;COPY PVP
1424         SUBI    A,-1(C)         ;POINT TO DOPWD WITH A
1425         HRLI    A,TFRAME        ;MAKE INTO A FRAME
1426         HLL     B,OTBSAV(B)     ;TIME TO B
1427         POP     P,C
1428         POPJ    P,
1429
1430
1431
1432 \f;THESE ROUTINES ARE CALLED TO EVALUATE THE VALUE PUSHED
1433 ;ON TP    ****THEY ARE ASSUMED TO CLOBBER EVERYTHING****
1434
1435 ARGEV:  JSP     E,CHKARG
1436         MCALL   1,EVAL
1437         POPJ    P,
1438
1439
1440
1441
1442 ;WHEN APPLY-ING, ARGS ARE ALREADY EVALUATED
1443
1444 ARGNEV: JSP     E,CHKARG        ;PITCH ANY TDEFERS
1445         TRNN    0,DEF           ;DEFAULT VALUES...
1446         JRST    NOEV
1447         MCALL   1,EVAL          ;...ARE ALWAYS EVALUATED
1448         POPJ    P,
1449 NOEV:   POP     TP,B            ;OTHERWISE,
1450         POP     TP,A            ;JUST RESTORE A&B
1451         POPJ    P,\f
1452
1453 ;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
1454 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
1455 ;EACH TRIPLET IS AS FOLLOWS:
1456 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
1457 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
1458 ;AND THE THIRD IS A PAIR OF ZEROES.
1459
1460 BNDA:   TATOM,,-1
1461
1462 SPECBIND:       MOVE    E,TP            ;GET THE POINTER TO TOP
1463         ADD     E,[1,,1]        ;BUMP POINTER ONCE
1464         PUSH    TP,$TTP
1465         PUSH    TP,E
1466         MOVEI   B,              ;ZERO COUNTER
1467         MOVE    D,E
1468 SZLOOP: MOVE    A,-6(D)         ;COUNT ATOM BLOCKS AS 3
1469         CAME    A,BNDA
1470         JRST    GETVEC
1471         SUB     D,[6,,6]
1472         ADDI    B,3
1473         JRST    SZLOOP
1474 GETVEC: JUMPE   B,DEGEN
1475         PUSH    P,B
1476         AOJ     B,
1477         PUSH    TP,$TTP
1478         PUSH    TP,D
1479         PUSH    TP,$TFIX
1480         PUSH    TP,B
1481         MCALL   1,VECTOR        ;<VECTOR .B>
1482         POP     TP,D            ;RESTORE D = POINTER TO BOTTOM TRIPLE
1483         SUB     TP,[1,,1]
1484         MOVE    A,$TSP          ;MAKE THIS BLOCK POINT TO PREVIOUS
1485         MOVEM   A,(B)
1486         MOVEM   SP,1(B)
1487         ADDI    B,2
1488
1489 ;MOVE TRIPLES TO VECTOR
1490
1491         POP     P,E             ;E _ LENGTH  - 1
1492         ASH     E,1             ;TIMES 2
1493         ADDI    E,(B)           ;E _ POINTER TO VECTOR DOPE WORD
1494         HRLI    A,(D)
1495         HRRI    A,(B)
1496         BLT     A,-1(E)         ;MOVE BIND TRIPLES TO VECTOR
1497
1498 ;CHANGE ALL [TATOM,,-1]'S TO [TBIND,,LINK TO PREVIOUS BLOCK]
1499
1500         HRRZI   B,(B)           ;ZERO LEFT HALF OF B
1501         MOVSI   C,TBIND
1502         HRRI    C,-2(B)         ;C = LINK _ ADR OF FIRST OF VECTOR
1503 FIXLP:  MOVEM   C,(B)           ;STORE LINK TO PREVIOUS BLOCK IN BLOCK B
1504         HRRI    C,(B)           ;C _ LINK TO THIS BLOCK
1505         ADDI    B,6
1506         CAIE    B,(E)           ;GOT TO DOPE WORD?
1507         JRST    FIXLP
1508
1509 ;CLEAN UP TP
1510
1511         POP     TP,C
1512         SUB     TP,[1,,1]
1513         CAMLE   C,TP            ;ANYTHING ABOVE TRIPLES?
1514         JRST    NOBLT2
1515         SUBI    TP,(C)          ;TP _ NUMBER THERE
1516         HRLS    TP              ;IN BOTH HALVES
1517         ADD     TP,D            ;NEW TP
1518         HRLI    D,(C)
1519         BLT     D,(TP)          ;BLLLLLLLLT!
1520         JRST    SPCBE2
1521 DEGEN:  SUB     TP,[2,,2]
1522         POPJ,
1523 NOBLT2: MOVE    TP,D            ;OR JUST RESTORE IT
1524         SUB     TP,[1,,1]
1525
1526 ;HERE TO BIND EVERYTHING IN VECTOR WITH DOPE WORD (E)
1527
1528 SPCBE2: SUB     E,[1,,1]        ;E _ LAST WORD OF LAST BLOCK
1529
1530 ;EBIND BINDS THE ATOMS SPECIFIED BY THE BLOCK WHOSE LAST WORD
1531 ;E POINTS TO, THEN THE BLOCK LINKED TO IT, ETC., UNTIL
1532 ;IT FINDS ONE ALREADY BOUND, WHEN IT RESTORES E AND EXITS.
1533 ;IT RESETS SP TO POINT TO THE FIRST ONE BOUND.  IT CLOBBERS
1534 ;ALL OTHER REGISTERS
1535
1536 EBIND:  HLRZ    A,-1(E)
1537         SKIPE   A               ;ALREADY BOUND?
1538         POPJ    P,              ;YES-- EBIND IS A NO-OP
1539         MOVEI   D,              ;D WILL BE THE NEW SP
1540         PUSH    P,E             ;SAVE E
1541         JRST    DOBIND
1542
1543 BINDLP: HLRZ    A,-1(E)
1544         SKIPE   A               ;HAS THIS BLOCK BEEN BOUND ALREADY?
1545         JRST    SPECBD          ;YES, RESTORE AND QUIT
1546 DOBIND: SUB     E,[6,,6]
1547         SKIPN   D               ;HAS NEW SP ALREADY BEEN SET?
1548         MOVE    D,E             ;NO, SET TO THIS BLOCK FOR NOW
1549         MOVE    A,1(E)
1550         MOVE    B,2(E)
1551         PUSHJ   P,ILOC          ;(A,B) _ LOCATIVE OF (A,B)
1552         HLR     A,OTBSAV(TB)
1553         MOVEM   A,5(E)          ;CLOBBER IT AWAY
1554         MOVEM   B,6(E)          ;IN RESTORE CELLS
1555
1556         HRRZ    A,PROCID+1(PVP) ;GET PROCESS NUMBER
1557         HRLI    A,TLOCI         ;MAKE LOC PTR
1558         MOVE    B,E             ;TO NEW VALUE
1559         ADD     B,[3,,3]
1560         MOVE    C,2(E)          ;GET ATOM PTR
1561         MOVEM   A,(C)           ;CLOBBER ITS VALUE
1562         MOVEM   B,1(C)          ;CELL
1563         JRST    BINDLP
1564
1565 SPECBD: MOVE    SP,D            ;SP _ D
1566         ADD     SP,[1,,1]       ;FIX SP
1567         POP     P,E             ;RESTORE E TO TOP OF BIND VECTOR
1568         POPJ    P,
1569
1570 \f
1571
1572 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
1573 ;SPSAV (TB).  IT IS CALLED BY PUSHJ P,SPECSTORE.
1574
1575 SPECSTORE:
1576         HRRZ    E,SPSAV (TB)    ;GET TARGET POINTER
1577
1578 STLOOP:
1579         CAIN    E,(SP)          ;ARE WE DONE?
1580         JRST    STPOPJ
1581         HLRZ    C,(SP)          ;GET TYPE OF BIND
1582         CAIE    C,TBIND         ;NORMAL IDENTIFIER?
1583         JRST    JBVEC           ;NO-- FIND & FOLLOW REBIND POINTER
1584
1585
1586         MOVE    C,1(SP)         ;GET TOP ATOM
1587         MOVE    D,4(SP)         ;GET STORED LOCATIVE
1588 \r       HRR     D,PROCID+1(PVP) ;STORE SIGNATURE
1589         MOVEM   D,(C)           ;CLOBBER INTO ATOM
1590         MOVE    D,5(SP)
1591         MOVEM   D,1(C)
1592         HRRZS   4(SP)           ;NOW LOOKS LIKE A VIRGIN BLOCK
1593         SETZM   5(SP)
1594         HRRZ    SP,(SP)         ;GET NEXT BLOCK
1595         JRST    STLOOP
1596
1597 ;IN JUMPING TO A NEW BIND VECTOR, FOLLOW
1598 ;REBIND POINTER IF IT DIFFERS FROM ACCESS POINTER
1599
1600 JBVEC:  CAIE    C,TSP           ;THIS JUST BETTER BE TRUE, THAT'S ALL
1601         .VALUE  [ASCIZ /BADSP/]
1602         GETYP   D,2(SP)         ;REBIND POINTER?
1603         CAIE    D,TSP
1604         JRST    XCHVEC          ;NO-- USE ACCESS
1605         MOVE    D,5(SP)         ;YES-- RESTORE PROCID
1606         EXCH    D,PROCID+1(PVP)
1607         MOVEM   D,5(SP)         ;SAVING CURRENT ONE FOR LATER FAILURES
1608         ADD     SP,[2,,2]
1609
1610 ;IF WE JUST RAN OFF THE END OF THE ENVIRONMENT CHAIN, BARF
1611
1612 XCHVEC: SKIPE   SP,1(SP)
1613         JRST    STLOOP
1614         JUMPE   E,STPOPJ        ;UNLESS THAT'S AS FAR AS WE WANTED TO GO
1615         .VALUE  [ASCIZ /SPOVERPOP/]
1616
1617 STPOPJ:
1618         MOVE    SP,SPSAV(TB)
1619         POPJ    P,
1620
1621
1622 \f
1623
1624 MFUNCTION REP,FSUBR,[REPEAT]
1625         JRST    PROG
1626 MFUNCTION PROG,FSUBR
1627         ENTRY   1
1628         GETYP   A,(AB)          ;GET ARG TYPE
1629         CAIE    A,TLIST         ;IS IT A LIST?
1630         JRST    WTYP            ;WRONG TYPE
1631         SKIPN   C,1(AB)         ;GET AND CHECK ARGUMENT
1632         JRST    ERRTFA          ;TOO FEW ARGS
1633         PUSH    TP,$TLIST       ;PUSH GOODIE
1634         PUSH    TP,C
1635 BIPROG: PUSH    TP,$TLIST
1636         PUSH    TP,C            ;SLOT FOR WHOLE BODY
1637         PUSHJ   P,PROGAT        ;BIND FUNNY PROG MARKER
1638         MOVE    C,3(TB)         ;PROG BODY
1639         MOVNI   D,1             ;TELL BINDER WE ARE APROG
1640         PUSHJ   P,BINDER
1641         HRRZ    C,3(TB)         ;RESTORE PROG
1642         TRNE    A,H             ;SKIP IF NO NAME ALA HEWITT
1643         HRRZ    C,(C)
1644         JUMPE   C,NOBODY
1645         MOVEM   C,3(TB)         ;SAVE FOR AGAIN, ETC.
1646 STPROG: HRRZ    C,(C)           ;SKIP DCLS
1647         JUMPE   C,NOBODY
1648
1649 ; HERE TO RUN PROGS FUNCTIONS ETC.
1650
1651 DOPROG:
1652         HRRZM   C,1(TB)         ;CLOBBER AWAY BODY
1653         PUSH    TP,(C)          ;EVALUATE THE
1654         HLLZS   (TP)
1655         PUSH    TP,1(C)         ;STATEMENT
1656         JSP     E,CHKARG
1657         MCALL   1,EVAL
1658         HRRZ    C,@1(TB)        ;GET THE REST OF THE BODY
1659         JUMPN   C,DOPROG        ;IF MORE -- DO IT
1660 ENDPROG:
1661         HRRZ    C,FSAV(TB)
1662         MOVE    C,@-1(C)
1663         CAME    C,MQUOTE REP,REPEAT
1664         JRST    FINIS
1665         SKIPN   C,3(TB)         ;CHECK IT
1666         JRST    FINIS
1667         MOVEM   C,1(TB)
1668         JRST    CONTINUE
1669
1670 ;HERE TO BIND PROG ATOM (AND ANYTHING ELSE ON STACK)
1671
1672 PROGAT: PUSH    TP,BNDA
1673         PUSH    TP,MQUOTE [LPROG ],INTRUP
1674         MOVE    B,TB
1675         PUSHJ   P,MAKENV                ;B _ POINTER TO CURRENT FRAME
1676         PUSH    TP,A
1677         PUSH    TP,B
1678         PUSH    TP,[0]
1679         PUSH    TP,[0]
1680         JRST    SPECBI\f
1681
1682 MFUNCTION RETURN,SUBR
1683         ENTRY   1
1684         PUSHJ   P,PROGCH        ;CKECK IN A PROG
1685         PUSHJ   P,SAVE          ;RESTORE PROG'S FRAME, BCKTRKING IF NECESSARY
1686         MOVE    A,(AB)
1687         MOVE    B,1(AB)
1688         JRST    FINIS
1689
1690
1691 MFUNCTION AGAIN,SUBR
1692         ENTRY
1693         HLRZ    A,AB            ;GET # OF ARGS
1694         CAIN    A,-2            ;1 ARG?
1695         JRST    NLCLA           ;YES
1696         JUMPN   A,WNA           ;0 ARGS?
1697         PUSHJ   P,PROGCH        ;CHECK FOR IN A PROG
1698         JRST    AGAD
1699 NLCLA:  HLRZ    A,(AB)
1700         CAIE    A,TACT
1701         JRST    WTYP
1702         MOVE    A,1(AB)
1703         HRR     B,A
1704         HLL     B,OTBSAV (B)
1705         HRRZ    C,A
1706         CAIG    C,1(TP)
1707         CAME    A,B
1708         JRST    ILLFRA
1709         HLRZ    C,FSAV (C)
1710         CAIE    C,TENTRY
1711         JRST    ILLFRA
1712 AGAD:   PUSHJ   P,SAVE          ;RESTORE FRAME TO REPEAT
1713         MOVE    B,3(TB)
1714         MOVEM   B,1(TB)
1715         JRST    CONTIN
1716
1717 MFUNCTION GO,SUBR
1718         ENTRY   1
1719         PUSHJ   P,PROGCH        ;CHECK FOR A PROG
1720         PUSH    TP,A            ;SAVE
1721         PUSH    TP,B
1722         MOVE    A,(AB)
1723         CAME    A,$TATOM
1724         JRST    NLCLGO
1725         PUSH    TP,A
1726         PUSH    TP,1(AB)
1727         PUSH    TP,2(B)
1728         PUSH    TP,3(B)
1729         MCALL   2,MEMQ          ;DOES IT HAVE THIS TAG?
1730         JUMPE   B,NXTAG         ;NO -- ERROR
1731 FNDGO:  EXCH    B,(TP)          ;SAVE PLACE TO GO
1732         MOVSI   D,TLIST
1733         MOVEM   D,-1(TP)
1734         JRST    GODON
1735
1736 NLCLGO: CAME    A,$TTAG         ;CHECK TYPE
1737         JRST    WTYP
1738         MOVE    A,1(AB)         ;GET ARG
1739         HRR     B,3(A)
1740         HLL     B,OTBSAV(B)
1741         HRRZ    C,B
1742         CAIG    C,1(TP)
1743         CAME    B,3(A)          ;CHECK TIME
1744         JRST    ILLFRA
1745         HLRZ    C,FSAV(C)
1746         CAIE    C,TENTRY
1747         JRST    ILLFRA
1748         PUSH    TP,(A)          ;SAVE BODY
1749         PUSH    TP,1(A)
1750 GODON:  PUSHJ   P,SAVE          ;GO BACK TO CORRECT FRAME
1751         MOVE    B,(TP)          ;RESTORE ITERATION MARKER
1752         MOVEM   B,1(TB)
1753         MOVE    A,(AB)
1754         MOVE    B,1(AB)
1755         JRST    CONTIN
1756
1757 \f
1758
1759
1760 MFUNCTION TAG,SUBR
1761         ENTRY   1
1762         HLRZ    A,(AB)          ;GET TYPE OF ARGUMENT
1763         CAIE    A,TATOM         ;CHECK THAT IT IS AN ATOM
1764         JRST    WTYP
1765         PUSHJ   P,PROGCH        ;CHECK PROG
1766         PUSH    TP,A            ;SAVE VAL
1767         PUSH    TP,B
1768         PUSH    TP,0(AB)
1769         PUSH    TP,1(AB)
1770         PUSH    TP,2(B)
1771         PUSH    TP,3(B)
1772         MCALL   2,MEMQ
1773         JUMPE   B,NXTAG         ;IF NOT FOUND -- ERROR
1774         EXCH    A,-1(TP)        ;SAVE PLACE
1775         EXCH    B,(TP)
1776         PUSH    TP,A            ;UNDER PROG FRAME
1777         PUSH    TP,B
1778         MCALL   2,EVECTOR
1779         MOVSI   A,TTAG
1780         JRST    FINIS
1781
1782 PROGCH: MOVE    B,MQUOTE [LPROG ],INTRUP
1783         PUSHJ   P,ILVAL         ;GET VALUE
1784         GETYP   C,A
1785         CAIE    C,TFRAME
1786         JRST    NXPRG
1787         MOVE    C,B             ;CHECK TIME
1788         HLL     C,OTBSAV(B)
1789         CAME    C,B
1790         JRST    ILLFRA
1791         HRRZI   C,(B)           ;PLACE
1792         CAILE   C,1(TP)
1793         JRST    ILLFRA
1794         GETYP   C,FSAV(C)
1795         CAIE    C,TENTRY
1796         JRST    ILLFRA
1797         POPJ    P,
1798
1799 MFUNCTION EXIT,SUBR
1800         ENTRY   2
1801         PUSHJ   P,TILLFM        ;TEST FRAME
1802         PUSHJ   P,SAVE          ;RESTORE FRAME
1803         JRST    EXIT2
1804
1805 ;IF GIVEN, RETURN SECOND ARGUMENT
1806
1807 RETRG2: MOVE    A,2(AB)
1808         MOVE    B,3(AB)
1809         MOVE    AB,ABSAV(TB)    ;IN CASE OF GC
1810         JRST    FINIS
1811
1812 MFUNCTION COND,FSUBR
1813         ENTRY   1
1814         HLRZ    A,(AB)
1815         CAIE    A,TLIST
1816         JRST    WTYP
1817         PUSH    TP,(AB)
1818         PUSH    TP,1(AB)                ;CREATE UNNAMED TEMP
1819 CLSLUP: SKIPN   B,1(TB)         ;IS THE CLAUSELIST NIL?
1820         JRST    IFALSE          ;YES -- RETURN NIL
1821         HLRZ    A,(B)           ;NO -- GET TYPE OF CAR
1822         CAIE    A,TLIST         ;IS IT A LIST?
1823         JRST    BADCLS          ;
1824         MOVE    A,1(B)          ;YES -- GET CLAUSE
1825         JUMPE   A,BADCLS
1826         PUSH    TP,(A)          ;EVALUATION OF
1827         HLLZS   (TP)
1828         PUSH    TP,1(A)         ;THE PREDICATE
1829         JSP     E,CHKARG
1830         MCALL   1,EVAL
1831         CAMN    A,$TFALSE       ;IF THE RESULT IS
1832         JRST    NXTCLS          ;FALSE TRY NEXT CLAUSE
1833         MOVE    C,1(TB)         ;IF NOT, DO FIRST CLAUSE
1834         MOVE    C,1(C)
1835         HRRZ    C,(C)
1836         JUMPE   C,FINIS         ;(UNLESS DONE WITH IT)
1837         JRST    DOPROG          ;AS THOUGH IT WERE A PROG
1838 NXTCLS: HRRZ    A,@1(TB)        ;SET THE CLAUSLIST
1839         HRRZM   A,1(TB)         ;TO CDR OF THE CLAUSLIST
1840         JRST    CLSLUP
1841
1842 IFALSE:
1843         MOVSI   A,TFALSE        ;RETURN FALSE
1844         MOVEI   B,0
1845         JRST    FINIS
1846
1847
1848
1849
1850 ;RESTORE TB TO STACK FRAME POINTED TO BY B, SAVING INTERMEDIATE FRAMES ON THE PLANNER PDL
1851 ;IF NECESSARY;   CLOBBERS EVERYTHING BUT B
1852 SAVE:   SKIPN   C,OTBSAV(B)     ;PREVIOUS FRAME?
1853         JRST    QWKRET
1854         CAMN    PP,PPSAV(C)     ;ANYTHING HAPPEN TO PP BETWEEN B AND HERE?
1855         JRST    QWKRET          ;NO-- JUST RETURN
1856         PUSH    TP,$TTB
1857         PUSH    TP,B
1858 SVLP:   HRRZ    B,(TP)
1859         CAIN    B,(TB)          ;DONE?
1860         JRST    SVRET
1861         HRRZ    C,OTBSAV(TB)    ;ANYTHING TO SAVE YET?
1862         CAME    PP,PPSAV(C)
1863         PUSHJ   P,BCKTRK        ;DO IT
1864         HRR     TB,OTBSAV(TB)   ;AND POP UP
1865         JRST    SVLP
1866 QWKRET: HRR     TB,B            ;SKIP OVER EVERYTHING
1867         POPJ    P,
1868 SVRET:  SUB     TP,[2,,2]       ;POP CRAP OFF TP
1869         POPJ    P,\f
1870
1871 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
1872 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT.  ITS VALUE IS
1873 ; ITS SECOND ARGUMENT.
1874
1875 MFUNCTION SETG,SUBR
1876         ENTRY   2
1877         HLLZ    A,(AB)          ;GET TYPE OF FIRST ARGUMENT
1878         CAME    A,$TATOM        ;CHECK THAT IT IS AN ATOM
1879         JRST    NONATM          ;IF NOT -- ERROR
1880         MOVE    B,1(AB)         ;GET POINTER TO ATOM
1881         PUSHJ   P,IGLOC         ;GET LOCATIVE TO VALUE
1882         CAMN    A,$TUNBOUND     ;IF BOUND
1883         PUSHJ   P,BSETG         ;IF NOT -- BIND IT
1884         MOVE    C,B             ;SAVE PTR
1885         MOVE    A,2(AB)         ;GET SECOND ARGUMENT
1886         MOVE    B,3(AB)         ;INTO THE RETURN POSITION
1887         MOVEM   A,(C)           ;DEPOSIT INTO THE
1888         MOVEM   B,1(C)          ;INDICATED VALUE CELL
1889         JRST    FINIS
1890
1891 BSETG:  HRRZ    A,GLOBASE+1(TVP)
1892         HRRZ    B,GLOBSP+1(TVP)
1893         SUB     B,A
1894         CAIL    B,6
1895         JRST    SETGIT
1896         PUSH    TP,GLOBASE(TVP)
1897         PUSH    TP,GLOBASE+1 (TVP)
1898         PUSH    TP,$TFIX
1899         PUSH    TP,[0]
1900         PUSH    TP,$TFIX
1901         PUSH    TP,[100]
1902         MCALL   3,GROW
1903         MOVEM   A,GLOBASE(TVP)
1904         MOVEM   B,GLOBASE+1(TVP)
1905 SETGIT:
1906         MOVE    B,GLOBSP+1(TVP)
1907         SUB     B,[4,,4]
1908         MOVE    C,(AB)
1909         MOVEM   C,(B)
1910         MOVE    C,1(AB)
1911         MOVEM   C,1(B)
1912         MOVEM   B,GLOBSP+1(TVP)
1913         ADD     B,[2,,2]
1914         MOVSI   A,TLOCI
1915         POPJ    P,
1916
1917 \f
1918
1919
1920 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
1921 ;FIRST ARGUMENT TO THE SECOND ARG.  ITS VALUE IS ITS SECOND ARGUMENT.
1922
1923 MFUNCTION SET,SUBR
1924         ENTRY   2
1925         HLLZ    A,(AB)          ;GET TYPE OF FIRST
1926         CAME    A,$TATOM        ;ARGUMENT --
1927         JRST    WTYP            ;BETTER BE AN ATOM
1928         MOVE    B,1(AB)         ;GET PTR TO IT
1929         PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
1930         CAMN    A,$TUNBOUND     ;BOUND?
1931         PUSHJ   P, BSET         ;BIND IT
1932         MOVE    C,B             ;SAVE PTR
1933         MOVE    A,2(AB)         ;GET SECOND ARG
1934         MOVE    B,3(AB)         ;INTO RETURN VALUE
1935         MOVEM   A,(C)           ;CLOBBER IDENTIFIER
1936         MOVEM   B,1(C)
1937         JRST    FINIS
1938 BSET:   PUSH    TP,$TFIX
1939         PUSH    TP,[4]
1940         MCALL   1,VECTOR        ;GET NEW BIND VECTOR
1941         MOVE    A,$TSP
1942         MOVEM   A,(B)           ;MARK IT
1943         SETZM   A,1(B)
1944         MOVSI   A,TBIND
1945         HRRI    A,(B)
1946         MOVEM   A,2(B)          ;CHAIN FIRST BLOCK
1947         MOVE    A,1(AB)         ;A _ ATOM
1948         MOVEM   A,3(B)
1949         MOVE    C,SPBASE+1(PVP) ;CHAIN TO PREVIOUS BIND VECTOR
1950         MOVEM   B,SPBASE+1(PVP) ;SET NEW TOP
1951         ADD     B,[2,,2]
1952         MOVEM   B,1(C)
1953         ADD     B,[2,,2]        ;POINT TO LOCATIVE
1954         MOVSI   A,TLOCI
1955         HRR     A,PROCID+1(PVP) ;WHICH MAKE
1956         MOVE    C,1(AB)         ;C _ ATOM _ VALUE CELL ADDRESS
1957         MOVEM   A,(C)
1958         MOVEM   B,1(C)          ;CLOBBER LOCATIVE SLOT
1959         POPJ    P,
1960 \f
1961
1962 MFUNCTION NOT,SUBR
1963         ENTRY   1
1964         HLRZ    A,(AB)          ; GET TYPE
1965         CAIE    A,TFALSE        ;IS IT FALSE?
1966         JRST    IFALSE          ;NO -- RETURN FALSE
1967
1968 TRUTH:
1969         MOVSI   A,TATOM         ;RETURN T (VERITAS)
1970         MOVE    B,MQUOTE T
1971         JRST    FINIS
1972
1973 MFUNCTION ANDA,FSUBR,AND
1974         ENTRY   1
1975         HLRZ    A,(AB)
1976         CAIE    A,TLIST
1977         JRST    WTYP            ;IF ARG DOESN'T CHECK OUT
1978         SKIPN   C,1(AB)         ;IF NIL
1979         JRST    TRUTH           ;RETURN TRUTH
1980         PUSH    TP,$TLIST               ;CREATE UNNAMED TEMP
1981         PUSH    TP,C
1982 ANDLP:
1983         JUMPE   C,FINIS         ;ANY MORE ARGS?
1984         MOVEM   C,1(TB)         ;STORE CRUFT
1985         PUSH    TP,(C)          ;EVALUATE THE
1986         HLLZS   (TP)            ;FIRST REMAINING
1987         PUSH    TP,1(C)         ;ARGUMENT
1988         JSP     E,CHKARG
1989         MCALL   1,EVAL
1990         CAMN    A,$TFALSE
1991         JRST    FINIS           ;IF FALSE -- RETURN
1992         HRRZ    C,@1(TB)        ;GET CDR OF ARGLIST
1993         JRST    ANDLP
1994
1995 MFUNCTION OR,FSUBR
1996         ENTRY   1
1997         HLRZ    A,(AB)
1998         CAIE    A,TLIST         ;CHECK OUT ARGUMENT
1999         JRST    WTYP
2000         MOVE    C,1(AB)         ;PICK IT UP TO ENTER LOOP
2001         PUSH    TP,$TLIST       ;CREATE UNNAMED TEMP
2002         PUSH    TP,C
2003 ORLP:
2004         JUMPE   C,IFALSE        ;IF NO MORE OPTIONS -- FALSE
2005         MOVEM   C,1(TB)         ;CLOBBER IT AWAY
2006         PUSH    TP,(C)
2007         HLLZS   (TP)
2008         PUSH    TP,1(C)         ;EVALUATE THE FIRST REMAINING
2009         JSP     E,CHKARG
2010         MCALL   1,EVAL          ;ARGUMENT
2011         CAME    A,$TFALSE       ;IF NON-FALSE RETURN
2012         JRST    FINIS
2013         HRRZ    C,@1(TB)        ;IF FALSE -- TRY AGAIN
2014         JRST    ORLP
2015
2016 MFUNCTION FUNCTION,FSUBR
2017         PUSH    TP,(AB)
2018         PUSH    TP,1(AB)
2019         PUSH    TP,$TATOM
2020         PUSH    TP,MQUOTE FUNCTION
2021         MCALL   2,CHTYPE
2022         JRST    FINIS
2023
2024 \f
2025
2026 MFUNCTION CLOSURE,SUBR
2027         ENTRY
2028         SKIPL   A,AB            ;ANY ARGS
2029         JRST    ERRTFA          ;NO -- LOSE
2030         ADD     A,[2,,2]        ;POINT AT IDS
2031         PUSH    TP,$TAB
2032         PUSH    TP,A
2033         PUSH    P,[0]           ;MAKE COUNTER
2034
2035 CLOLP:  SKIPL   A,1(TB)         ;ANY MORE IDS?
2036         JRST    CLODON          ;NO -- LOSE
2037         PUSH    TP,(A)          ;SAVE ID
2038         PUSH    TP,1(A)
2039         PUSH    TP,(A)          ;GET ITS VALUE
2040         PUSH    TP,1(A)
2041         ADD     A,[2,,2]        ;BUMP POINTER
2042         MOVEM   A,1(TB)
2043         AOS     (P)
2044         MCALL   1,VALUE
2045         PUSH    TP,A
2046         PUSH    TP,B
2047         MCALL   2,LIST          ;MAKE PAIR
2048         PUSH    TP,A
2049         PUSH    TP,B
2050         JRST    CLOLP
2051
2052 CLODON: POP     P,A
2053         ACALL   A,LIST          ;MAKE UP LIST
2054         PUSH    TP,(AB)         ;GET FUNCTION
2055         PUSH    TP,1(AB)
2056         PUSH    TP,A
2057         PUSH    TP,B
2058         MCALL   2,LIST          ;MAKE LIST
2059         MOVSI   A,TFUNARG
2060         JRST    FINIS
2061
2062
2063 MFUNCTION FALSE,SUBR
2064         ENTRY
2065         JUMPGE  AB,IFALSE
2066         HLRZ    A,(AB)
2067         CAIE    A,TLIST
2068         JRST    WTYP
2069         MOVSI   A,TFALSE
2070         MOVE    B,1(AB)
2071         JRST    FINIS
2072 \f;BCKTRK SAVES THINGS ON PP
2073
2074 ;IT AND ITS FRIENDS FLAG PP "FRAMES" WITH MARKERS OF FORM "TTP,,SWITCHES", WHERE SWITCHES INCLUDES
2075
2076 COP==1          ;ON IFF CALL TO BCKTRK IS TO COPY FRAME (TB) AS WELL
2077                 ;AS OTBSAV(TB)
2078 SAV==2          ;ON IFF TUPLES OF (TB) ARE TO BE SAVED; COP IMPLIES
2079                 ;SAV
2080 TUP==4          ;ON IFF (TB) CONTAINS ANY TUPLES BESIDES ARGS
2081 ON==10          ;ON IFF THIS FRAME OR FAILPOINT "RESTS ON TOP OF"
2082                 ;FRAME DESIGNATED BY TTP POINTER, OR IS INTENDED TO
2083                 ;TAKE ITS PLACE
2084
2085 ;BELOW THE TTP POINTER IS ONE OR TWO BLOCKS FLAGGED BY A TFIX
2086 ;VALUE.  IF ON=ON AND TUP=ON IN THE RIGHT HALF OF THE TFIX,
2087 ;THE TFIX BEGINS A BLOCK OF TUPLE DEBRIS; OTHERWISE,
2088 ;IT BEGINS A SAVED TP FRAME.
2089
2090
2091 BCKTRK: HRRZ    A,-1(PP)        ;SLOT LEFT BY FAILPOINT?
2092         TRNN    A,COP           ;(I.E., TO BE COPIED?)
2093         JRST    NBCK
2094         MOVE    E,TB            ;YES-- FIRST SAVE THIS FRAME
2095         PUSHJ   P,BCKTRE
2096         HRRZ    A,-1(PP)
2097         JRST    NBCK1
2098 NBCK:   TRNN    A,SAV
2099         JRST    RMARK
2100
2101 ;SAVE TUPLES OF FRAME ON TOP OF PP
2102
2103 NBCK1:  MOVSI   B,TTP           ;FAKE OUT GC
2104         MOVEM   B,BSTO(PVP)
2105         MOVSI   C,TPP
2106         MOVEM   C,CSTO(PVP)
2107         MOVEM   C,ESTO(PVP)
2108         MOVE    B,(PP)          ;B _ TPIFIED TB POINTER
2109         SUB     PP,[2,,2]       ;CLEAN OFF POINTER TO MAKE ROOM FOR ARGS
2110         MOVE    E,PP
2111         MOVE    C,PP            ;C _ E _ PP
2112         SUB     C,(PP)          ;C _ ADDRESS OF SAVED OTB
2113         HLRE    D,1(C)          ;D _ NO. OF ARGS
2114         JUMPE   D,NOARGS
2115         SUB     B,[FRAMLN,,FRAMLN]      ;B _ FIRST OF SAVE BLOCK
2116         MOVNS   D
2117         HRLS    D
2118         SUB     B,D             ;B _ FIRST OF ARGS
2119 MVARGS: INTGO
2120         PUSH    PP,(B)          ;MOVE NEXT
2121         PUSH    PP,1(B)
2122         ADD     B,[2,,2]
2123         SUB     D,[2,,2]
2124         JUMPG   D,MVARGS
2125         ADD     B,[FRAMLN,,FRAMLN]      ;B _ TB ADDRESS
2126         JRST    MVTUPS
2127 NOARGS: TRNN    A,TUP           ;ANY OTHER TUPLES?
2128         JRST    RMARK
2129 MVTUPS: ADD     C,[FRAMLN-1,,FRAMLN-1]  ;C _ PP TB SLOT
2130         SUB     E,[1,,1]        ;E _ TFIX SLOT ADDRESS
2131 MTOLP:  CAML    C,E             ;C REACHED E?
2132         JRST    MTDON           ;YES-- ALL TUPLES FOUND
2133         INTGO
2134         GETYP   A,(C)           ;ELSE
2135         CAIE    A,TTBS          ;LOOK FOR TUPLE
2136         JRST    ARND22
2137         HRRE    D,(C)           ;D _ NO. OF ELEMENTS
2138 MTILP:  JUMPGE  D,ARND22
2139         INTGO
2140         PUSH    PP,(B)
2141         PUSH    PP,1(B)
2142         ADD     B,[2,,2]
2143         ADDI    D,2
2144         JRST    MTILP
2145 ARND22: ADD     B,[2,,2]        ;ADVANCE IN STEP
2146         ADD     C,[2,,2]
2147         JRST    MTOLP
2148 ;ALL TUPLES MOVED
2149 MTDON:  HRRZ    C,PP
2150         SUBI    C,1(E)          ;C _ NO. OF THINGS MOVED
2151         HRLS    C
2152         PUSH    PP,[TFIX,,TUP]  ;MARK AS TUPLE CRUFT
2153         PUSH    PP,C
2154 ;NEW TTP MARKER
2155 RMARK:  MOVE    E,OTBSAV(TB)    ;SAVE PREVIOUS FRAME
2156         HRRZ    D,E
2157         HRLS    D
2158         HLRE    C,B
2159         SUBI    C,(B)
2160         HRLZS   C
2161         ADD     D,C
2162         PUSH    PP,[TTP,,ON]
2163         PUSH    PP,D
2164         MOVSI   B,TFIX          ;RESTORE B TYPE
2165         MOVEM   B,BSTO(PVP)
2166
2167 ;BCKTRE SAVE CONTENTS OF FRAME E OF TP ON PLANNER PDL
2168
2169 BCKTRE: MOVSI   A,TPDL          ;FOR AGC
2170         MOVEM   A,ASTO(PVP)
2171         MOVSI   C,TTP
2172         MOVEM   C,CSTO(PVP)
2173         MOVSI   A,TTB
2174         MOVEM   A,ESTO(PVP)
2175
2176 ;MOVE P BLOCK OF PREVIOUS FRAME TO PP
2177
2178         MOVE    C,PSAV(E)       ;C _ LAST OF P "FRAME"
2179         HRRZ    A,OTBSAV(E)
2180         MOVE    A,PSAV(A)       ;A _ LAST OF PREVIOUS P "FRAME"
2181         ADD     A,[1,,1]
2182 MVPB:   CAMLE   A,C             ;IF BLOCK EMPTY,
2183         JRST    MVTPB           ;DO NOTHING
2184         HRRZ    D,C
2185         SUBI    D,-1(A)         ;ELSE, SET COUNTER
2186         PUSH    PP,$TPDLS       ;MARK BLOCK
2187         HRRM    D,(PP)
2188         HRLS    D
2189         PUSH    P,D
2190 PSHLP1: PUSH    PP,(A)
2191         INTGO           ;MOVE BLOCK
2192         ADD     A,[1,,1]
2193         CAMG    A,C
2194         JRST    PSHLP1
2195         PUSH    PP,$TFIX
2196         PUSH    PP,[0]          ;PUSH BLOCK COUNTER
2197         POP     P,(PP)
2198 ;NOW DO SIMILAR THING FOR TP
2199 MVTPB:  MOVSI   A,TTP           ;FOR AGC
2200         MOVEM   A,ASTO(PVP)
2201         MOVE    C,TPSAV(E)      ;C POINT TO LAST OF BLOCK
2202         PUSH    TP,$TPP         ;SAVE INITIAL PP
2203         PUSH    TP,PP           ;FOR SUBTRACTION
2204         HRRZ    A,E             ;A _ TPIFIED E
2205         HLRE    B,C
2206         SUBI    B,(C)
2207         HRLZS   B
2208         HRLS    A
2209         ADD     A,B
2210         GETYP   D,FSAV(A)
2211         CAIE    D,TENTRY
2212         .VALUE  [ASCIZ /TPFUCKED/]
2213 ;MOVE THE SAVE BLOCK
2214
2215 MSVBLK: MOVSI   D,TENTS         ;MAKE TYPE TENTS
2216         HRR     D,FSAV(A)
2217         PUSH    PP,D
2218         HLLZ    D,OTBSAV(E)     ;RELATIVIZE OTB AND AB POINTERS
2219         PUSH    PP,D
2220         HLLZ    D,ABSAV(E)
2221         PUSH    PP,D
2222         PUSH    PP,SPSAV(E)
2223         PUSH    PP,PSAV(E)
2224         PUSH    PP,TPSAV(E)
2225         PUSH    PP,PPSAV(E)
2226         PUSH    PP,PCSAV(E)
2227         MOVEI   0,              ;0 _ 0 (NO TUPLES)
2228 PSHLP2: INTGO
2229         CAMLE   A,C             ;DONE?
2230         JRST    MRKFIX
2231         GETYP   D,(A)
2232         CAIN    D,TTB           ;TUPLE?
2233         JRST    MVTB
2234         PUSH    PP,(A)          ;NO, JUST MOVE IT
2235         PUSH    PP,1(A)
2236 ARND4:  ADD     A,[2,,2]
2237         JRST    PSHLP2
2238 MRKFIX: HRRZ    C,(TP)          ;C _ PREVIOUS PP POINTER
2239         SUB     TP,[2,,2]
2240         HRRZ    D,PP            ;D _ CURRENT PP TOP
2241         SUBI    D,(C)           ;D _ DIFFERENCE
2242         HRLS    D
2243         PUSH    PP,$TFIX        ;PUSH BLOCK COUNTER
2244         PUSH    PP,D
2245
2246
2247 ;NOW SAVE LOCATION OF THIS FRAME
2248
2249         HRLS    E
2250         MOVE    C,TPSAV(E)
2251         HLRE    B,C
2252         SUBI    B,(C)
2253         HRLZS   B
2254         ADD     E,B             ;CONVERSION TO TTP
2255         HRLI    0,TTP
2256         TRO     0,SAV           ;PUSH A TTP MARKER WITH SAV & MAYBE TUP ON
2257         PUSH    PP,0
2258         PUSH    PP,E
2259
2260 ;RETURN
2261
2262         MOVSI   A,TFIX
2263         MOVEM   A,ASTO(PVP)
2264         MOVEM   A,CSTO(PVP)
2265         MOVEM   A,ESTO(PVP)
2266         POPJ    P,
2267
2268 ;RELATIVIZE A TB POINTER
2269
2270 MVTB:   HRRE    D,(A)           ;D _ - LENGTH OF TUPLE
2271         MOVNS   D
2272         HRLS    D               ;D _ LENGTH,,LENGTH
2273         SUB     PP,D            ;THROW TUPLE AWAY!!!
2274         TRO     0,TUP
2275         MOVNS   D
2276         HRLI    D,TTBS
2277         PUSH    PP,D
2278         MOVE    D,1(A)
2279         SUBI    D,(E)
2280         PUSH    PP,D
2281         JRST    ARND4
2282 \fMFUNCTION FAIL,SUBR
2283
2284 ;SINCE FAILURES ARE NOT INTERRUPTIBLE FOR ANYTHING BUT GARBAGE
2285 ;COLLECTIONS, THE FOLLOWING MACRO REPLACES INTGO FOR STACK-BUILDING
2286 ;LOOPS
2287
2288 DEFINE UNBLOW STK
2289         SKIPL   STK
2290         PUSHJ   P,NBLO!STK
2291 TERMIN
2292
2293
2294         ENTRY
2295         HLRE    A,AB
2296         MOVNS   A
2297         CAILE   A,4             ;AT MOST 2 ARGS
2298         JRST    WNA
2299         CAIGE   A,2             ;IF FIRST ARG NOT GIVEN,
2300         JRST    MFALS           ;ASSUME <>
2301         MOVE    B,(AB)          ;OTHERWISE, FIRST ARG IS MESSAGE
2302         MOVEM   B,MESS(PVP)
2303         MOVE    B,1(AB)
2304         MOVEM   B,MESS+1(PVP)
2305
2306         CAIE    A,4             ;PLACE TO FAIL TO GIVEN?
2307         JRST    AFALS1
2308         HLRZ    A,2(AB)
2309         CAIE    A,TACT          ;CAN ONLY FAIL TO AN ACTIVATION
2310         JRST    TAFALS
2311 SAVACT: MOVE    B,2(AB)         ;TRANSMIT ACTIVATION TO FAILPOINT
2312         MOVEM   B,FACTI(PVP)    ;VIA PVP
2313         MOVE    B,3(AB)
2314         MOVEM   B,FACTI+1(PVP)
2315 ;NOW REBUILD TP FROM PP
2316 IFAIL:  SETOM   FLFLG           ;FLFLG _ ON
2317         HRRZ    A,(PP)          ;GET FRAME TO NESTLE IN
2318         JUMPE   A,BDFAIL
2319         HRRZ    0,-1(PP)        ;0 _ SWITCHES FOR FRAME
2320         CAIN    A,(TB)
2321         JRST    RSTFRM
2322         GETYP   B,FACTI(PVP)    ;IF FALSE ACTIVATION,
2323         CAIN    B,TFALSE        ;JUST GO TO FRAME
2324         JRST    POPFS
2325         HRRZI   B,(TB)          ;OTHERWISE, CHECK TO SEE IF WE ARE LEAVING
2326         HRRZ    D,FACTI+1(PVP)
2327 ALOOP:  CAIN    B,(A)           ;     FRAME FACTI(PVP)
2328         JRST    POPFS           ;NO-- IT'S ABOVE FAILPOINT (A)
2329         CAIN    B,(D)           ;FOUND FACTI?
2330         JRST    AFALS2          ;YES-- CLOBBER FACTI TO #FALSE()
2331         HRRZ    B,OTBSAV(B)     ;NO-- KEEP LOOKING
2332         JRST    ALOOP
2333 AFALS2: MOVSI   B,TFALSE        ;SET IT TO FALSE FROM HERE ON
2334         MOVEM   B,FACTI(PVP)
2335         SETZB   D,FACTI+1(PVP)
2336 POPFS:  HRR     TB,A            ;MAY TAKE MORE WORK
2337 RSTFRM: MOVE    P,PSAV(TB)
2338         MOVE    TP,TPSAV(TB)
2339         SUB     PP,[2,,2]
2340         GETYP   A,-1(PP)
2341         CAIN    A,TPC
2342         JRST    MHFRAM
2343         CAIE    A,TFIX
2344         JRST    BADPP
2345
2346 ;MOVE A TP BLOCK FROM PP TO TP
2347         MOVSI   A,TPP
2348         MOVEM   A,ASTO(PVP)
2349         MOVEM   A,CSTO(PVP)
2350         MOVE    A,PP
2351         SUB     A,(PP)          ;A POINTS TO BOTTOM OF BLOCK
2352         TRNN    0,ON            ;"ON" BLOCK?
2353         JRST    INBLK
2354 ONBLK:  CAME    SP,SPSAV(TB)    ;YES-- FIX UP ENVIRONMENT
2355         PUSHJ   P,SPECST
2356         MOVE    C,A
2357         HRRZ    0,-1(PP)        ;ANY TUPLES?
2358         TRNN    0,TUP
2359         JRST    USVBLK          ;NO-- GO MOVE SAVE BLOCK
2360         SUB     A,[2,,2]        ;A _ BLOCK UNDER THIS ONE
2361         SUB     A,(A)
2362 ;FILL IN ARGS TUPLE
2363         GETYP   B,-1(A)
2364         CAIE    B,TENTS         ;LOOK IN SAVE BLOCK
2365         JRST    BADPP
2366         HLRE    D,FRAMLN+ABSAV-1(A)
2367         PUSHJ   P,USVTUP
2368
2369 ;MOVE SAVE BLOCK BACK TO TP
2370
2371 USVBLK: ADD     A,[FRAMLN,,FRAMLN]
2372         MOVSI   D,TENTRY
2373         HRR     D,FSAV-1(A)
2374         PUSH    TP,D
2375         MOVEI   AB,(TP)         ;REGENERATE AB & OTBSAV
2376         HLRE    D,ABSAV-1(A)
2377         MOVNS   D
2378         HRLS    D
2379         SUB     AB,D
2380         MOVEI   D,(TB)
2381         HLL     D,OTBSAV-1(A)
2382         PUSH    TP,D
2383         PUSH    TP,AB
2384         PUSH    TP,SPSAV-1(A)
2385         PUSH    TP,PSAV-1(A)
2386         PUSH    TP,TPSAV-1(A)
2387         PUSH    TP,PPSAV-1(A)
2388         PUSH    TP,PCSAV-1(A)
2389         HRRI    TB,1(TP)
2390
2391 PSHLP4: CAML    TP,TPSAV(TB)
2392         JRST    USTPDN
2393         UNBLOW  TP
2394         GETYP   B,-1(A)
2395         CAIN    B,TTBS          ;FOUND A TUPLE?
2396         JRST    USVTB
2397         PUSH    TP,-1(A)        ;NO-- JUST MOVE IT
2398         PUSH    TP,(A)
2399 ARND12: ADD     A,[2,,2]        ;BUMP POINTER
2400         JRST    PSHLP4
2401 USVTB:  HRRE    D,-1(A)
2402         PUSHJ   P,USVTUP
2403         MOVE    D,-1(A)         ;UNRELATIVIZE A TTB
2404         HRLI    D,TTB
2405         PUSH    TP,D
2406         MOVE    D,(A)
2407         ADDI    D,(TB)
2408         PUSH    TP,D
2409         JRST    ARND12
2410 USTPDN: MOVE    0,-1(PP)        ;IF TUPLES,
2411         TRNN    0,TUP
2412         JRST    USTPD3
2413         SUB     PP,(PP)         ;SKIP OVER TUPLE DEBRIS
2414         SUB     PP,[2,,2]
2415 USTPD3: CAME    TP,TPSAV(TB)    ;BETTER HAVE WORKED
2416         JRST    BADPP
2417         CAMN    SP,SPSAV(TB)    ;PLEASE GOD, NO MORE BINDINGS
2418         JRST    USV2            ;PRAYER CAN MOVE MOUNTAINS
2419         MOVEI   E,              ;E _ 0 = INITIAL LOWER BIND BLOCK
2420         MOVE    C,SPSAV(TB)     ;C _ SPSAV = INITIAL UPPER BLOCK
2421
2422 ;REBIND EVERYTHING IN THIS FRAME-- FIRST, FIND THE TOPMOST BLOCK,
2423 ;SINCE THEY MUST BE REBOUND IN THE ORDER BOUND
2424
2425 BLOOP1: GETYP   D,(C)
2426         CAIE    D,TBIND         ;C POINTS TO BIND BLOCK?
2427         JRST    SPLBLK
2428         ADD     C,[5,,5]        ;YES-- C _ ADDRESS OF ITS LAST WORD
2429         MOVEM   E,(C)           ;(C) _ E = LOWER BIND POINTER
2430         MOVE    E,C             ;E _ C
2431         HLRE    D,C
2432         SUB     C,D             ;C _ ADDRESS OF DOPE WORD
2433         HLRZ    D,1(C)
2434         SUB     D,[2,,2]
2435         SUBM    C,D             ;D _ FIRST WORD ADDRESS
2436         MOVE    C,1(D)          ;C _ REBIND BLOCK
2437         JRST    JBVEC3
2438 SPLBLK: GETYP   D,2(C)
2439         CAIN    D,TSP
2440         ADD     C,[2,,2]
2441         ADD     C,[1,,1]        ;C _ REBIND POINTER ADDRESS
2442         MOVE    D,(C)           ;D _ HIGHER BLOCK
2443         MOVEM   E,(C)           ;(C) _ E
2444         MOVE    E,C             ;E _ C
2445         MOVE    C,D             ;C _ D = HIGHER BIND BLOCK
2446 JBVEC3: CAME    SP,C            ;GOT TO SP YET?
2447         JRST    BLOOP1
2448
2449
2450 ;NOW REBIND EVERYTHING, RESET PROCID'S PROPERLY, ETC.;
2451 ;THIS MUST BE DONE IN PROPER ORDER, FROM TOPMOST BLOCK DOWN
2452
2453 BLOOP2: HLRZ    D,-1(E)         ;WHAT DOES E POINT TO?
2454         PUSH    P,(E)
2455         JUMPN   D,TUGSP         ;IF NON-ZERO, MUST BE REBIND SLOT
2456         PUSHJ   P,EBIND         ;OTHERWISE, BIND BLOCK TO BE REBOUND
2457         JRST    DOWNBL
2458 TUGSP:  MOVEM   SP,(E)          ;RECONNECT UPPER BLOCK
2459         GETYP   0,1(E)
2460         CAIE    0,TBIND
2461         SUB     E,[2,,2]
2462         MOVE    SP,E
2463         SUB     SP,[1,,1]       ;TUG SP DOWN
2464         CAIE    0,TSP           ;ID SWAP?
2465         JRST    DOWNBL
2466         MOVE    0,PROCID+1(PVP)
2467         EXCH    0,5(SP)
2468         MOVEM   0,PROCID+1(PVP)
2469 DOWNBL: POP     P,E             ;E _ LOWER BLOCK
2470         JUMPN   E,BLOOP2
2471
2472 RBDON:  CAME    SP,SPSAV(TB)    ;ALL THAT BETTER HAVE WORKED
2473         JRST    BADPP
2474         JRST    USV2
2475
2476 ;RESTORE A BLOCK "INTO" TB
2477
2478 INBLK:  ADD     A,[FRAMLN,,FRAMLN]
2479         MOVSI   C,TTP
2480         MOVEM   C,CSTO(PVP)
2481         MOVSI   C,SPSAV-1(A)
2482         HRRI    C,SPSAV(TB)
2483         BLT     C,-1(TB)        ;RESTORE ALL OF SAVE BLOCK BUT FSAV,
2484         MOVEI   C,-1(TB)        ;    OTBSAV, AND ABSAV
2485         HRLS    C
2486         MOVE    B,TPSAV(TB)
2487         HLRE    D,B
2488         SUBI    D,(B)
2489         HRLZS   D
2490         ADD     C,D             ;C _ "-1(TB)"TPIFIED
2491 PSHLP6: CAML    A,PP
2492         JRST    TPDON
2493         GETYP   B,-1(A)         ;GOT TUPLE?
2494         CAIN    B,TTBS
2495         JRST    SKTUPL          ;YES-- SKIP IT
2496         PUSH    C,-1(A)
2497         PUSH    C,(A)
2498 ARND2:  CAMLE   C,TP
2499         MOVE    TP,C            ;PROTECT STACK FROM GARBAGE COLLECTION
2500         UNBLOW  TP
2501         ADD     A,[2,,2]
2502         JRST    PSHLP6
2503 SKTUPL: HRRE    D,-1(A)         ;D _ - LENGTH OF TUPLE
2504         MOVNS   D
2505         HRLS    D
2506         ADD     C,D             ;SKIP!
2507         ADD     C,[2,,2]        ;AND DON'T FORGET TTB
2508         JRST    ARND2
2509 TPDON:  MOVE    TP,C            ;IN CASE TP TOO BIG
2510         CAME    TP,TPSAV(TB)    ;CHECK THAT INBLK WORKED
2511         JRST    BADPP
2512         MOVE    C,OTBSAV(TB)    ;RESTORE P STARTING FROM PREVIOUS
2513         MOVE    P,PSAV(C)       ;FRAME
2514
2515 ;MOVE A P BLOCK BACK TO P
2516
2517 USV2:   MOVSI   C,TFIX
2518         MOVEM   C,CSTO(PVP)
2519 \r       SUB     PP,(PP)
2520         SUB     PP,[2,,2]       ;NOW BACK BEYOND TP BLOCK
2521         GETYP   A,-1(PP)
2522         CAIE    A,TFIX          ;GET P BLOCK...
2523         JRST    CHPC2           ;...IF ANY
2524         MOVE    A,PP
2525         SUB     A,(PP)          ;A POINTS TO FIRST
2526 PSHLP5: PUSH    P,-1(A)         ;MOVE BLOCK
2527         ADD     A,[1,,1]
2528         UNBLOW  P
2529         CAMGE   A,PP
2530         JRST    PSHLP5
2531         SUB     PP,(PP)
2532         SUB     PP,[3,,3]               ;NOW AT NEXT PP "FRAME"
2533         GETYP   A,-1(PP)
2534 CHPC2:  CAME    P,PSAV(TB)      ;MAKE SURE P RESTORED OKAY
2535         JRST    BADPP
2536         CAIN    A,TTP
2537         JRST    IFAIL
2538         JRST    BADPP
2539
2540 ;FRAME IS ALREADY ON THE STACK--- BINDINGS ONLY HASSLE
2541
2542 MHFRAM: MOVE    AB,ABSAV(TB)    ;RESTORE ARGS POINTER
2543         CAME    SP,SPSAV(TB)    ;AND ENVIRONMENT
2544         PUSHJ   P,SPECSTO
2545         MOVSI   A,TFIX
2546         MOVEM   A,ASTO(PVP)
2547         SETZM   FLFLG           ;FLFLG _ OFF
2548         INTGO                   ;HANDLE POSTPONED INTERRUPTS
2549         SUB     PP,[2,,2]
2550         JRST    @2(PP)
2551
2552 ;HERE TO PUSH TUPLE STARTING AT (C), OF LENGTH -D
2553
2554 USVTUP: SKIPL   D
2555         POPJ    P,
2556         INTGO
2557         PUSH    TP,-1(C)
2558         PUSH    TP,(C)
2559         UNBLOW TP
2560         ADD     C,[2,,2]
2561         ADDI    D,2
2562         JRST    USVTUP
2563
2564 ;DEFAULT MESSAGE IS <>
2565
2566 MFALS:  MOVSI   B,TFALSE        ;TYPE FALSE
2567         MOVEM   B,MESS(PVP)
2568         SETZM   MESS+1(PVP)
2569
2570
2571 ;DEFAULT ACTIVATION IS <>, ALSO
2572 AFALS1: MOVSI   B,TFALSE
2573         MOVEM   B,FACTI(PVP)
2574 \r       SETZM   FACTI+1(PVP)
2575         JRST    IFAIL
2576
2577 ;FALSE IS ALLOWED EXPLICITLY
2578
2579 TAFALS: CAIE    A,TFALSE
2580         JRST    WTYP
2581         JRST    SAVACT
2582
2583
2584 ;FLAG FOR INTERRUPT SYSTEM
2585
2586 FLFLG:  0
2587
2588 ;HERE TO UNBLOW P
2589
2590 NBLOP:  HRRZ    E,P
2591         HLRE    B,P
2592         SUBI    E,-PDLBUF-1(P)  ;E _ ADR OF REAL 2ND DOPE WORD
2593         SKIPE   PGROW
2594         JRST    PDLOSS          ;SORRY, ONLY ONE GROWTH PER FAMILY
2595         HRRM    E,PGROW         ;SET PGROW
2596         JRST    NBLO2
2597
2598 ;HERE TO UNBLOW TP
2599
2600 NBLOTP: HRRZ    E,TP            ;MORE OR LESS THE SAME
2601         HLRE    B,TP
2602         SUBI    E,-PDLBUF-1(TP)
2603         SKIPE   TPGROW
2604         JRST    PDLOSS
2605         HRRM    E,TPGROW
2606 NBLO2:  MOVEI   B,PDLGRO_-6
2607         DPB     B,[111100,,-1(E)]
2608         JRST    AGC
2609 \fMFUNCTION FINALIZE,SUBR,[FINALIZE]
2610         ENTRY
2611         SKIPL   AB              ;IF NOARGS;
2612         JRST    GETTOP          ;FINALIZE ALL FAILPOINTS
2613         HLRE    A,AB            ;AT MOST ONE ARG
2614         CAME    A,[-2]
2615         JRST    WNA
2616         PUSHJ   P,TILLFM        ;MAKE SURE ARG IS LEGAL
2617         HRR     B,OTBSAV(B)     ;B _ FRAME BEFORE ACTIVATION
2618 RESTPP: MOVE    PP,PPSAV(B)     ;RESTORE PP
2619         HRRZ    A,TB            ;IN EVERY FRAME
2620 FLOOP:  CAIN    A,(B)           ;FOR EACH ONE,
2621         JRST    FDONE
2622         MOVEM   PP,PPSAV(A)
2623         HRR     A,OTBSAV(A)
2624         JRST    FLOOP
2625 FDONE:  MOVE    A,$TFALSE
2626         MOVEI   B,
2627         JRST    FINIS
2628
2629 ;TILLFM SETS B _ FIRST ARGUMENT IFF IT IS A LEGAL ACTIVATION
2630
2631 TILLFM: HLRZ    A,(AB)          ;FIRST ARG MUST BE ACTIVATION
2632         CAIE    A,TACT
2633         JRST    WTYP
2634         MOVE    A,1(AB)         ;WITH RIGHT TIME
2635         HRR     B,A
2636         HLL     B,OTBSAV(B)
2637         HRRZ    C,A             ;AND PLACE
2638         CAIG    C,1(TP)
2639         CAME    A,B
2640         JRST    ILLFRA
2641         GETYP   C,FSAV(C)       ;AND STRUCTURE
2642         CAIE    C,TENTRY
2643         JRST    ILLFRA
2644         POPJ    P,
2645
2646
2647 ;LET B BE TOP LEVEL FRAME
2648
2649 GETTOP: MOVE    B,TPBASE+1(PVP) ;B _ BOTTOM OF TP
2650         MOVEI   B,FRAMLN+1(B)   ;B _ TOP LEVEL FRAME
2651         JRST    RESTPP\fMFUNCTION FAILPOINT,FSUBR,[FAILPOINT]
2652         ENTRY   1
2653         GETYP   A,(AB)          ;ARGUMENT MUST BE LIST
2654         CAIE    A,TLIST
2655         JRST    WTYP
2656         SKIPN   C,1(AB)         ;NON-NIL
2657         JRST    ERRTFA
2658         PUSH    TP,$TLIST       ;SLOT FOR BODY
2659         PUSH    TP,[0]
2660         PUSH    TP,$TLIST
2661         PUSH    TP,[0]
2662         PUSH    TP,$TSP
2663         PUSH    TP,[0]          ;SAVE SLOT FOR PRE-(MESS ACT) ENV
2664         MOVE    C,1(AB)         ;GET SET TO CALL BINDER
2665         MOVNI   D,1             ;---AS A PROG
2666         PUSHJ   P,BINDER        ;AND GO
2667         HRRZ    C,1(AB)         ;SKIP OVER THINGS BOUND
2668         TRNE    A,H             ;INCLUDING HEWITT ATOM IF THERE
2669         HRRZ    C,(C)
2670         JUMPE   C,NOBODY
2671         HRRZ    C,(C)           ;C _ (EXPR (MESS ACT) -FAIL-BODY-)
2672         JUMPE   C,NOBODY
2673         HRRZ    A,(C)           ;A _ ((MESS ACT) -FAIL-BODY-)
2674         MOVEM   A,1(AB)         ;SAVE FOR FAILURE
2675         MOVEM   A,3(TB)
2676         MOVE    A,TP
2677         SUB     A,[5,,5]
2678         PUSH    PP,$TPC         ;ESTABLISH FAIL POINT
2679         PUSH    PP,[FP]
2680         PUSH    PP,[TTP,,COP\ON]
2681         PUSH    PP,A            ;SAVE LOCATION OF THIS FRAME
2682         PUSH    TP,(C)
2683         HLLZS   (TP)
2684         PUSH    TP,1(C)
2685         JSP     E,CHKARG
2686         MCALL   1,EVAL          ;EVALUATE EXPR
2687         JRST    FINIS           ;IF SUCCESSFUL, DO NORMAL FINIS
2688
2689 ;FAIL TO HERE--BIND MESSAGE AND ACTIVATION
2690
2691 FP:     MOVEM   SP,5(TB)        ;SAVE SP BEFORE MESS AND ACT BOUND
2692         HRRZ    A,1(AB)         ;A _ ((MESS ACT) -BODY-)
2693         GETYP   C,(A)
2694         CAIE    C,TLIST
2695         JRST    MPD
2696         HRRZ    C,1(A)          ;C _ (MESS ACT)
2697         JUMPE   C,TFMESS        ;IF (), THINGS MUST BE <>
2698         PUSHJ   P,CARATM        ;E _ MESS
2699         JRST    MPD
2700         PUSH    TP,BNDA         ;ELSE BIND IT
2701         PUSH    TP,E
2702         PUSH    TP,MESS(PVP)
2703         PUSH    TP,MESS+1(PVP)
2704         PUSH    TP,[0]
2705         PUSH    TP,[0]
2706         HRRZ    C,(C)           ;C _ (ACT)
2707         JUMPE   C,TFACT         ;IF (), ACT MUST BE <>
2708         PUSHJ   P,CARATM        ;E _ ACT
2709         JRST    MPD
2710         PUSH    TP,BNDA         ;BIND IT
2711         PUSH    TP,E
2712         PUSH    TP,FACTI(PVP)
2713         PUSH    TP,FACTI+1(PVP)
2714         PUSH    TP,[0]
2715         PUSH    TP,[0]
2716 BLPROG: PUSHJ   P,PROGAT
2717         HRRZ    C,1(AB)
2718         JRST    STPROG
2719 TFMESS: GETYP   A,MESS(PVP)
2720         CAIE    A,TFALSE
2721         JRST    IFAIL
2722 TFACT:  GETYP   A,FACTI(PVP)
2723         CAIE    A,TFALSE
2724         JRST    IFAIL
2725         JRST    BLPROG
2726
2727 ;THIS ROUTINE SETS E TO THE NEXT THING IN THE LIST C POINTS TO,
2728 ;SKIPPING IFF IT IS AN ATOM
2729
2730 CARATM: GETYP   E,(C)
2731         CAIE    E,TATOM
2732         POPJ    P,
2733         MOVE    E,1(C)
2734         AOS     (P)
2735         POPJ    P,
2736
2737
2738 MFUNCTION RESTORE,SUBR,[RESTORE]
2739
2740         ENTRY
2741         HLRE    A,AB
2742         MOVNS   A
2743         CAIG    A,4             ;1 OR 2 ARGUMENTS
2744         CAIGE   A,2
2745         JRST    WNA
2746         PUSHJ   P,TILLFM        ;B _ FRAME TO RESTORE (IF LEGAL)
2747         HRRZ    C,FSAV(B)
2748         CAIE    C,FAILPO        ;ONLY FAILPOINTS RESTORABLE
2749         JRST    ILLFRA
2750         PUSHJ   P,SAVE          ;RESTORE IT
2751         SKIPN   D,5(TB)         ;ARE WE IN EXPR INSTEAD OF BODY?
2752         JRST    EXIT2           ;YES-- EXIT
2753         MOVEM   D,SPSAV(TB)
2754         PUSHJ   P,SPECSTO       ;UNBIND MESS AND ACT
2755         MOVE    TP,TPSAV(TB)
2756         MOVE    P,PSAV(TB)
2757         PUSH    PP,$TPC
2758         PUSH    PP,[FP]
2759         MOVE    E,TP
2760         SUB     E,[5,,5]
2761         PUSH    PP,[TTP,,COP\ON]        ;REESTABLISH FAILPOINT
2762         PUSH    PP,E
2763 EXIT2:  HLRE    C,AB
2764         MOVNS   C
2765         CAIN    C,4             ;VALUE GIVEN?
2766         JRST    RETRG2          ;YES-- RETURN IT
2767         MOVE    AB,ABSAV(TB)    ;IN CASE OF GARBAGE COLLECTION
2768         JRST    IFALSE\f
2769
2770 ;ERROR COMMENTS FOR EVAL
2771
2772 UNBOU:  PUSH    TP,$TATOM
2773         PUSH    TP,MQUOTE UNBOUND-VARIABLE
2774         JRST    ER1ARG
2775
2776 UNAS:   PUSH    TP,$TATOM
2777         PUSH    TP,MQUOTE UNASSIGNED-VARIABLE
2778         JRST    ER1ARG
2779
2780 TFA:
2781 ERRTFA: PUSH    TP,$TATOM
2782         PUSH    TP,MQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
2783         JRST    CALER1
2784
2785 TMA:
2786 ERRTMA: PUSH    TP,$TATOM
2787         PUSH    TP,MQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
2788         JRST    CALER1
2789
2790 BADENV:
2791         PUSH    TP,$TATOM
2792         PUSH    TP,MQUOTE BAD-ENVIRONMENT
2793         JRST    CALER1
2794
2795 FUNERR:
2796         PUSH    TP,$TATOM
2797         PUSH    TP,MQUOTE BAD-FUNARG
2798         JRST    CALER1
2799
2800 WRONGT:
2801 WTYP:   PUSH    TP,$TATOM
2802         PUSH    TP,MQUOTE WRONG-TYPE
2803         JRST    CALER1
2804
2805 MPD:    PUSH    TP,$TATOM
2806         PUSH    TP,MQUOTE MEANINGLESS-PARAMETER-DECLARATION
2807         JRST    CALER1
2808
2809 NOBODY: PUSH    TP,$TATOM
2810         PUSH    TP,MQUOTE HAS-EMPTY-BODY
2811         JRST    CALER1
2812
2813 BADCLS: PUSH    TP,$TATOM
2814         PUSH    TP,MQUOTE BAD-CLAUSE
2815         JRST    CALER1
2816
2817 NXTAG:  PUSH    TP,$TATOM
2818         PUSH    TP,MQUOTE NON-EXISTENT-TAG
2819         JRST    CALER1
2820
2821 NXPRG:  PUSH    TP,$TATOM
2822         PUSH    TP,MQUOTE NOT-IN-PROG
2823         JRST    CALER1
2824
2825 NAPT:   PUSH    TP,$TATOM
2826         PUSH    TP,MQUOTE NON-APPLICABLE-TYPE
2827         JRST    CALER1
2828
2829 NONEVT: PUSH    TP,$TATOM
2830         PUSH    TP,MQUOTE NON-EVALUATEABLE-TYPE
2831         JRST    CALER1
2832
2833
2834 NONATM: PUSH    TP,$TATOM
2835         PUSH    TP,MQUOTE NON-ATOMIC-ARGUMENT
2836         JRST    CALER1
2837
2838
2839 ILLFRA: PUSH    TP,$TATOM
2840         PUSH    TP,MQUOTE FRAME-NO-LONGER-EXISTS
2841         JRST    CALER1
2842
2843 NOTIMP: PUSH    TP,$TATOM
2844         PUSH    TP,MQUOTE NOT-YET-IMPLEMENTED
2845         JRST    CALER1
2846
2847 ILLSEG: PUSH    TP,$TATOM
2848         PUSH    TP,MQUOTE ILLEGAL-SEGMENT
2849         JRST    CALER1
2850
2851 BADPP:  PUSH    TP,$TATOM
2852         PUSH    TP,MQUOTE PP-IN-ILLEGAL-CONFIGURATION
2853         JRST    CALER1
2854
2855
2856 BDFAIL: PUSH    TP,$TATOM
2857         PUSH    TP,MQUOTE OVERPOP--FAIL
2858         JRST    CALER1
2859
2860
2861 ER1ARG: PUSH    TP,(AB)
2862         PUSH    TP,1(AB)
2863         MOVEI   A,2
2864         JRST    CALER
2865 CALER1: MOVEI   A,1
2866 CALER:
2867         HRRZ    C,FSAV(TB)
2868         PUSH    TP,$TATOM
2869         PUSH    TP,@-1(C)
2870         ADDI    A,1
2871         ACALL   A,ERROR
2872         JRST    FINIS
2873
2874 END
2875 ***\f\ 3\f