MUDDLE/eval.234

   1 TITLE EVAL -- MUDDLE EVALUATOR
   2
   3 RELOCATABLE
   4
   5 ; GERALD JAY SUSSMAN, 1971
   6
   7 .GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME
   8 .GLOBAL IGVAL,CHKARG,SWAP,NXTDCL,TPOVFL,CHFRM
   9 .GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA
  10 .GLOBAL IDVAL,EVECTO,EUVECT,CHARGS
  11
  12 .INSRT MUDDLE >
  13
  14         MFUNCTION       EVAL,SUBR
  15         INTGO
  16         HLRZ    A,AB            ;GET NUMBER OF ARGS
  17         CAIE    A,-2            ;EXACTLY 1?
  18         JRST    AEVAL           ;EVAL WITH AN ALIST
  19         HLRZ    A,(AB)          ;GET TYPE OF ARG
  20         CAILE   A,NUMPRI        ;PRIMITIVE?
  21         JRST    NONEVT          ;NO
  22         JRST    @EVTYPT(A)      ;YES-DISPATCH
  23
  24 SELF:   MOVE    A,(AB)          ;TYPES WHICH EVALUATE
  25         MOVE    B,1(AB)
  26         JRST    FINIS           ;TO SELF-EG NUMBERS
  27
  28 ;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
  29
  30 MFUNCTION VALUE,SUBR
  31         JSP     E,CHKAT
  32         PUSHJ   P,IDVAL
  33         JRST    FINIS
  34
  35 IDVAL:  PUSH    TP,A
  36         PUSH    TP,B            ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE    PUSHJ   P,ILVAL         ;LOCAL VALUE FINDER
  37         CAME    A,$TUNBOUND     ;IF NOT UNBOUND OR UNASSIGNED
  38         JRST    RIDVAL          ;DONE - CLEAN UP AND RETURN
  39         JUMPN   B,UNAS          ;IF UNASSIGNED - ERROR
  40         POP     TP,B            ;GET ARG BACK
  41         POP     TP,A
  42         PUSHJ   P,IGVAL
  43         CAMN    A,$TUNBOUND
  44         JRST    UNBOU
  45         POPJ    P,
  46 RIDVAL: SUB     TP,[2,,2]
  47         POPJ    P,
  48
  49
  50 ;GETS THE LOCAL VALUE OF AN IDENTIFIER
  51
  52 MFUNCTION LVAL,SUBR
  53         JSP     E,CHKAT
  54         PUSHJ   P,ILVAL
  55         CAME    A,$TUNBOUND
  56         JRST    FINIS
  57         JUMPN   B,UNAS
  58         JRST    UNBOU
  59
  60 \f
  61 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
  62
  63 MFUNCTION LLOC,SUBR
  64         JSP     E,CHKAT
  65         PUSHJ   P,ILOC
  66         CAMN    A,$TUNBOUND
  67         JRST    UNBOU
  68         MOVSI   A,TLOCD
  69         HRR     A,2(B)
  70         JRST    FINIS
  71
  72 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
  73
  74 MFUNCTION BOUND,SUBR,[BOUND?]
  75         JSP     E,CHKAT
  76         PUSHJ   P,ILVAL
  77         CAMN    A,$TUNBOUND
  78         JUMPE   B,IFALSE
  79         JRST    TRUTH
  80
  81 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
  82
  83 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
  84         JSP     E,CHKAT
  85         PUSHJ   P,ILVAL
  86         CAME    A,$TUNBOUND
  87         JRST    TRUTH
  88         JUMPE   B,UNBOU
  89         JRST    IFALSE
  90
  91 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER
  92
  93 MFUNCTION GVAL,SUBR
  94         JSP     E,CHKAT
  95         PUSHJ   P,IGVAL
  96         CAMN    A,$TUNBOUND
  97         JRST    UNAS
  98         JRST    FINIS
  99
 100 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
 101
 102 MFUNCTION GLOC,SUBR
 103         JSP     E,CHKAT
 104         PUSHJ   P,IGLOC
 105         CAMN    A,$TUNBOUND
 106         JRST    UNAS
 107         MOVSI   A,TLOCD
 108         JRST    FINIS
 109
 110 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
 111
 112 MFUNCTION GASSIG,SUBR,[GASSIGNED?]
 113         JSP     E,CHKAT
 114         PUSHJ   P,IGVAL
 115         CAMN    A,$TUNBOUND
 116         JRST    IFALSE
 117         JRST    TRUTH
 118
 119 \f
 120
 121 CHKAT:  ENTRY   1
 122         HLLZ    A,(AB)
 123         CAME    A,$TATOM
 124         JRST    NONATM
 125         MOVE    B,1(AB)
 126         JRST    2,(E)
 127
 128 ;EVALUATE A FORM. IF CAR IS AN ATOM USE GLOBAL VALUE OVER LOCAL ONE.
 129
 130 EVFORM: SKIPN   C,1(AB)         ;EMPTY?
 131         JRST    IFALSE
 132         HLLZ    A,(C)           ;GET CAR TYPE
 133         CAME    A, $TATOM       ;ATOMIC?
 134         JRST    EV0             ;NO -- CALCULATE IT
 135         MOVE    B,1(C)          ;GET PTR TO ATOM
 136         PUSHJ   P,IGVAL
 137         CAMN    A,$TUNBOUND
 138         JRST    LFUN
 139         PUSH    TP,A
 140         PUSH    TP,B
 141         JRST    IAPPLY          ;APPLY IT
 142 EV0:    PUSH    TP,A            ;SET UP CAR OF FORM AND
 143         PUSH    TP,1(C)
 144         JSP     E,CHKARG
 145         MCALL   1,EVAL          ;EVALUATE IT
 146         PUSH    TP,A            ;APPLY THE RESULT
 147         PUSH    TP,B            ;AS A FUNCTION
 148         JRST    IAPPLY
 149
 150 LFUN:   MOVE    B,1(AB)
 151         PUSH    TP,$TATOM
 152         PUSH    TP,1(B)
 153         MCALL   1,VALUE
 154         PUSH    TP,A
 155         PUSH    TP,B
 156         JRST    IAPPLY
 157
 158 ;DISPATCH TABLE FOR EVAL
 159 DISTBL EVTYPT,SELF,[[TLIST,EVLIST],[TFORM,EVFORM],[TVEC,EVECT],[TSEG,ILLSEG],[TUVEC,EUVEC]]
 160
 161 \f
 162
 163 ;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR PROCID
 164 AEVAL:
 165         CAIE    A,-4            ;EXACTLY 2 ARGS?
 166         JRST    WNA             ;NO-ERROR
 167         HLRZ    A,2(AB)         ;CHECK THAT WE HAVE A FRAME
 168         CAIN    A,TFRAME
 169         JRST    .+3
 170         CAIE    A,TENV
 171         JRST    WTYP
 172         MOVE    A,3(AB)
 173         HRRZ    D,2(AB)         ;GET POINTER TO PV DOPE WORD
 174         PUSHJ   P,SWAPQ         ;SEE IF SWAP NECESSARY
 175         PUSH    TP,(D)
 176         PUSH    TP,1(D)
 177         MCALL   1,EVAL          ;NOW DO NORMAL EVALUATION
 178 UNSWPQ: MOVE    D,1(TB)         ;GET SAVED PVP
 179         CAMN    D,PVP           ;CHANGED?
 180         JRST    FINIS           ;NO - RETURNî   PUSHJ   P,SPECSTORE     ;CLEAN UP
 181         MOVE    D,1(TB)
 182         JSP     C,SWAP
 183         JRST    FINIS
 184
 185
 186 ; ROUTINE TO CHANGE PROCID AND POSSIBLY SWAP
 187
 188 SWAPQ:  HLRZ    C,(D)           ;GET LENGTH
 189         SUBI    D,-1(C)         ;POINT TO START OF PV
 190         MOVNS   C               ;NEGATE LENGTH
 191         HRLI    D,2(C)          ;MAKE AOBJN POINTER
 192         MOVE    E,PVP           ;COPY CURRENT PROCESS VECTOR
 193         POP     P,B             ;GET RET ADR SO POPJ WINS IF SWAP OCCURS
 194         CAME    D,PVP           ;IS THIS IT?
 195         JSP     C,SWAP          ;NO, SWAP IN NEW PROCESS
 196         PUSH    P,B             ;NOW, PUT IT BACK
 197         PUSH    TP,$TPVP        ;SAVE PROCESS
 198         PUSH    TP,E
 199         HLL     B,OTBSAV(A)     ;GET TIME FROM FRAME POINTED AT
 200         HRR     B,A
 201         HRRZ    C,A
 202         CAIG    C,1(TP)
 203         CAME    B,A             ;CHECK THAT THE FRAME IS LEGIT
 204         JRST    ILLFRA
 205         HLRZ    C,FSAV(C)
 206         CAIE    C,TENTRY
 207         JRST    ILLFRA
 208         CAMN    SP,SPSAV(A)
 209         JRST    AEV1
 210         MOVE    SP,SPSAV(A)     ;LOAD UP OLD ENVIRONMENT
 211         MOVE    A,PVP
 212         ADD     A,[PROCID,,PROCID]      ;GET LOCATIVE TO PROCESS ID
 213         PUSH    TP,BNDV         ;BIND IT TO
 214         PUSH    TP,A
 215         AOSN    A,PTIME         ;A UNIQUE NUMBER
 216         .VALUE  [ASCIZ /TIMEOUT/]
 217         PUSH    TP,$TFIX
 218         PUSH    TP,A
 219         PUSHJ   P,SPECBIND
 220 AEV1:   MOVE    E,1(TB)         ;GET SAVED PROCESS
 221         MOVE    D,AB            ;COPY CURRENT ARG POINTER
 222         CAME    E,PVP           ;HAS PROCESS CHANGED?
 223         MOVE    D,ABSTO+1(E)    ;GET SAV AB
 224         POPJ    P,              ;RETURN TO CALLER
 225
 226 \f
 227 ; STACKFRAME FUNCTION (MUDDLE'S ANSWER TO APPLY)
 228
 229         MQUOTE STACKFORM
 230
 231 STFRM2: JRST    NOENV           ;FAKE OUT ENTRY
 232
 233 MFUNCTION STACKFORM,FSUBR
 234
 235         ENTRY   1
 236
 237         GETYP   A,(AB)          ;CHECK IT IS A LIST
 238         CAIE    A,TLIST
 239         JRST    WTYP            ;NO, LOSE
 240
 241         MOVEI   A,3             ;CHECK ARG HAS AT LEAST 3 ELEMENTS
 242         HRRZ    B,1(AB) ;GET ARG
 243         JUMPE   B,TFA
 244         HRRZ    B,(B)           ;CDR IT
 245         SOJN    A,.-2           ;AND COUNT
 246
 247         JUMPE   B,NOENV         ;ENVIRONMENT NOT SUPPLIED
 248         HRRZ    A,(B)           ;CHECK NOT TOO MANY
 249         JUMPN   A,TMA
 250
 251         GETYP   A,(B)           ;GET TYPE OF LAST ARG
 252         MOVSI   A,(A)           ;TYPE TO LH
 253         PUSH    TP,A
 254         PUSH    TP,1(B)         ;PUSH THE ARG
 255         JSP     E,CHKARG                ;CHECK FOR DEFERRED
 256         MCALL   1,EVAL
 257         HLRZ    C,A             ;ISOLATE TYPE IN C
 258         CAIE    C,TENV          ;ENVIRONEMNT?
 259         CAIN    C,TFRAME        ;OR FRAME?
 260         JRST    .+2
 261         JRST    WTYP
 262
 263
 264         MOVEI   D,(A)           ;IN B AND D
 265         MOVE    A,B             ;AND TIME,,FRAME
 266         PUSHJ   P,SWAPQ         ;AND CHECK FOR CHANGE
 267         PUSH    TP,$TLIST       ;SAVE THE ARG
 268         PUSH    TP,1(D)         ;ON TP
 269         .MCALL  1,STFRM2        ;NOW CALL NON-ENV STACKFORM
 270         JRST    UNSWPQ          ;AND POSSIBLY UNSWAP
 271
 272 NOENV:  HRRZ    D,1(AB)         ;GET POINTER TO FIRST
 273         GETYP   A,(D)           ;GET TYPE
 274         MOVSI   A,(A)
 275         PUSH    TP,A
 276         PUSH    TP,1(D)         ;PUSH THE ARG, (IT SHOULD BE A FUNCTION)
 277         JSP     E,CHKARG        ;CHECK OUT DEFERRED
 278         MCALL   1,EVAL          ;EVAL IT
 279         HRRZ    C,1(AB)         ;RESTORE ARG
 280         HRRZ    D,(C)           ;POINT TO LIST OF FORMS
 281         PUSH    TP,A            ;SAVE FUNCTION
 282         PUSH    TP,B
 283         HLRZS   A               ;NOW DISPATCH ON TYPE
 284         CAIN    A,TSUBR;SUBR?
 285         JRST    STSUBR          ;YES, HACK IT
 286         CAIN    A,TEXPR         ;FUNCTION?
 287         JRST    STEXPR          ;YES DO IT
 288         CAIN    A,TFUNARG               ;FUNARG
 289         JRST    NOTIMP
 290         JRST    NAPT
 291
 292 \f
 293 ; STACK FORM OF A SUBR
 294
 295 STSUBR: PUSH    P,[0]           ;PUSH ARG COUNTER
 296
 297 STLOO:  PUSHJ   P,EVALRG                ;EVAL THE ARGUMENT
 298         JRST    MAKPTR          ;DONE, FALL INTO EVAL CODE
 299         AOS     (P)             ;COUNT
 300         PUSH    TP,A
 301         PUSH    TP,B            ;SAVE THE ARGS
 302         JRST    STLOO
 303
 304 ; STACK FRAME OF EXPR
 305
 306 STEXPR: MOVE    C,(TP)          ;GET FUNCTION
 307         PUSHJ   P,BINDRS                ;BIND THE ARGS
 308         JRST    APEXP1          ;JOIN COMMON CODE
 309
 310 \f
 311
 312 IAPPLY:
 313         HLRZ    A,(TB)          ;GET TYPE OF FUNCTION
 314         CAIN    A,TSUBR         ;SUBR?
 315         JRST    APSUBR          ;YES
 316         CAIN    A,TFSUBR        ;NO -- FSUBR?
 317         JRST    APFSUBR         ;YES
 318         CAIN    A,TEXPR         ;NO -- EXPR?
 319         JRST    APEXPR          ;YES
 320         CAIN    A,TFIX          ;NO -- CALL TO NTH?
 321         JRST    APNUM           ;YES
 322         CAIN    A,TFUNARG       ;NO -- FUNARG?
 323         JRST    APFUNARG        ;YES
 324         CAIN    A,TPVP          ;NO -- PROCESS TO BE RESUMED?
 325         JRST    RESOMER         ;YES
 326         JRST    NAPT            ;NONE OF THE ABOVE
 327
 328
 329 ;APFSUBR CALLS FSUBRS
 330
 331 APFSUBR:
 332         PUSH    TP,$TLIST       ;GET THE
 333         HRRZ    A,@1(AB)
 334         PUSH    TP,A            ;ARGUMENT LIST
 335         MCALL   1,@1(TB)
 336         JRST    FINIS
 337
 338 ;APSUBR CALLS SUBRS
 339
 340 APSUBR:
 341         HRRZ    A,@1(AB)        ;GET CDR OF FORM -- ARGLIST
 342         PUSH    TP,$TLIST       ;SAVE THE ARGLIST ON
 343         PUSH    TP,A            ;THE TP
 344         PUSH    P,[0]           ;MAKE SLOT FOR ARGCNT
 345 TUPLUP:
 346         SKIPN   A,3(TB)         ;IS IT NIL?
 347         JRST    MAKPTR          ;YES -- DONE
 348         PUSH    TP,(A)          ;NO -- GET CAR OF THE
 349         HLLZS   (TP)            ;ARGLIST
 350         PUSH    TP,1(A)
 351         JSP     E,CHKARG
 352         MCALL   1,EVAL          ;AND EVAL IT.
 353         PUSH    TP,A            ;SAVE THE RESULT IN
 354         PUSH    TP,B            ;THE GROWING TUPLE
 355         AOS     (P)             ;BUMP THE ARGCNT
 356         HRRZ    A,@3(TB)        ;SET THE ARGLIST TO
 357         MOVEM   A,3(TB)         ;CDR OF THE ARGLIST
 358         JRST    TUPLUP
 359 MAKPTR:
 360         POP     P,A
 361         ACALL   A,@1(TB)
 362         JRST    FINIS
 363
 364 \f
 365
 366 ;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
 367
 368 APNUM:
 369         HRRZ    A,@1(AB)        ;GET ARGLIST
 370         JUMPE   A,ERRTFA        ;NO ARGUMENT
 371         PUSH    TP,(A)          ;GET CAR OF ARGL
 372         HLLZS   (TP)
 373         PUSH    TP,1(A)
 374         HRRZ    A,(A)           ;MAKE SURE ONLY ONE ARG
 375         JUMPN   A,ERRTMA
 376         JSP     E,CHKARG        ;HACK DEFERRED
 377         MCALL   1,EVAL
 378         PUSH    TP,A
 379         PUSH    TP,B
 380         PUSH    TP,(TB)
 381         PUSH    TP,1(TB)
 382         MCALL   2,NTH
 383         JRST    FINIS
 384
 385 ;APEXPR APPLIES EXPRS
 386 ;EXPRESSION IS IN 0(AB),  FUNCTION IS IN 0(TB)
 387
 388 APEXPR:
 389
 390         SKIPN   C,1(TB)         ;BODY?
 391         JRST    NOBODY          ;NO, ERROR
 392         HRRZ    0,1(AB)         ;GET EXPRESSION INTO 0
 393         HRRZ    D,@0            ;AND ARGLIST INTO D
 394         HLL     0,(AB)          ;TYPE TO LH OF 0
 395
 396         PUSHJ   P,BINDER        ;DO THE BINDINGS
 397
 398 APEXP1: HRRZ    C,@1(TB)        ;GET BODY BACK
 399         JUMPE   A,DOPROG        ;NOW GO RUN IF NO ACTIVIATION
 400         PUSH    TP,$TLIST       ;SAVE ANOTHER COPY FOR REACT
 401         PUSH    TP,C
 402         SKIPL   A               ;SKIP IF NOT NAME ALA HEWITT
 403         HRRZ    C,(C)           ;ELSE CDR AGAIN
 404         JRST    DOPROG
 405
 406 \f
 407
 408 RESOMER:
 409 ; 0,1(TB) IS PROCESS VECTOR POINTER TO PROCESS TO BE RESUMED
 410 ; 0,1(AB) IS A FORM CONTAINING ARGS TO SAVED FUNTION
 411
 412         MOVE    D,1(TB)         ;GET PVP OF PROCESS TO BE RESUMED
 413         GETYP   A,RESFUN(D)     ; GET TYPE OF FUNCTION
 414
 415         CAIN    A,TSUBR         ;SUBR?
 416         JRST    RESSUBR         ;YES
 417         CAIN    A,TFSUBR        ;NO -- FSUBR?
 418         JRST    RESFSUBR                ;YES
 419         CAIN    A,TEXPR         ;NO -- EXPR?
 420         JRST    RESEXPR         ;YES
 421         CAIN    A,TFIX          ;NO -- CALL TO NTH?
 422         JRST    RESNUM          ;YES
 423         CAIN    A,TFUNARG       ;NO -- FUNARG?
 424         JRST    NOTIMP  ;YES
 425         JRST    NAPT            ;NONE OF THE ABOVE
 426
 427
 428 ;RESFSUBR RESUMES FSUBRS
 429
 430 RESFSUBR:
 431         HRRZ    A,@1(AB)        ;GET THE ARG LIST
 432         SUB     TP,[2,,2]       ;CLEAN UP
 433         JSP     C,SWAP          ;SWAP IN NEW PROCESS
 434         PUSH    TP,$TLIST
 435         PUSH    TP,A            ; PUSH THE ARG LIST
 436         MCALL   1,@RESFUN+1(PVP) ; RESUME WITH THE SAVED FUNCTION
 437         JRST    FINIS
 438
 439 ;RESSUBR RESUMES SUBRS
 440
 441 RESSUBR:
 442         HRRZ    A,@1(AB)        ;GET CDR OF FORM -- ARGLIST
 443         PUSH    TP,$TLIST       ;SAVE THE ARGLIST ON
 444         PUSH    TP,A            ;THE TP
 445         PUSH    P,[0]           ;MAKE SLOT FOR ARGCNT
 446 RESTUPLUP:
 447         SKIPN   A,3(TB)         ;IS IT NIL?
 448         JRST    RESMAKPTR               ;YES -- DONE
 449         PUSH    TP,(A)          ;NO -- GET CAR OF THE
 450         HLLZS   (TP)            ;ARGLIST
 451         PUSH    TP,1(A)
 452         JSP     E,CHKARG
 453         MCALL   1,EVAL          ;AND EVAL IT.
 454         MOVE    D,1(TB) ;GET PVP OF P.T.B.R.
 455         MOVE    C,TPSTO+1(D)    ;GET TP OF P.T.B.R.
 456         PUSH    C,A             ;SAVE THE RESULT IN THE GROWING
 457         PUSH    C,B             ;TUPLE OF ARGS IN P.T.B.R.
 458         MOVEM   C,TPSTO+1(D)    ;UPDATE TP OF P.T.B.R.
 459         AOS     (P)             ;BUMP THE ARGCNT
 460         HRRZ    A,@3(TB)        ;SET THE ARGLIST TO
 461         MOVEM   A,3(TB)         ;CDR OF THE ARGLIST
 462         JRST    RESTUPLUP
 463 RESMAKPTR:
 464         POP     P,A             ;GET NUMBER OF ARGS IN A
 465         MOVE    D,1(TB)         ;GET PVP OF P.T.B.R.
 466         SUB     TP,[4,,4]       ;GET RID OF GARBAGE
 467         JSP     C,SWAP          ;SWAP IN THE NEW PROCESS
 468         ACALL   A,RESFUN+1(PVP) ;CALL THE SAVED FUNCTION
 469         JRST    FINIS
 470
 471
 472
 473 ;RESNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
 474
 475 RESNUM:
 476         HRRZ    A,@1(AB)        ;GET ARGLIST
 477         JUMPE   A,ERRTFA        ;NO ARGUMENT
 478         PUSH    TP,(A)          ;GET CAR OF ARGL
 479         HLLZS   (TP)
 480         PUSH    TP,1(A)
 481         HRRZ    A,(A)           ;MAKE SURE ONLY ONE ARG
 482         JUMPN   A,ERRTMA
 483         JSP     E,CHKARG        ;HACK DEFERRED
 484         MCALL   1,EVAL
 485         MOVE    D,1(TB)         ;GET PVP OF P.T.B.R.
 486         MOVE    C,TPSTO+1(D)    ;GET TP OF P.T.B.R.
 487         PUSH    C,A             ;PUSH ARG
 488         PUSH    C,B
 489         SUB     TP,[2,,2]       ;CLEAN UP BEFORE LEAVING
 490         JSP     C,SWAP          ;BRING IN NEW PROCESS
 491         PUSH    TP,RESFUN(PVP)  ;PUSH NUMBER
 492         PUSH    TP,RESFUN+1(PVP)
 493         MCALL   2,NTH
 494         JRST    FINIS
 495
 496 ;RESEXPR RESUMES EXPRS
 497 ;EXPRESSION IS IN 0(AB),  FUNCTION IS IN RESFUN(PVP)
 498 RESEXPR:
 499         SKIPN   C,RESFUN+1(D);BODY?
 500         JRST    NOBODY          ;NO, ERROR
 501
 502         MOVE    C,TPSTO+1(D)    ;GET TP OF P.T.B.R.
 503         PUSH    C,BNDA          ;SPECIAL ATOM CROCK
 504         PUSH    C,MQUOTE [PPROC ]INTERR ;PPROC=PARENT PROCESS
 505         MOVE    B,OTBSAV(TB)
 506         PUSHJ   P,MAKENV        ;MAKE ENVIRONMENT FOR THIS PROCESS
 507         PUSH    C,A
 508         PUSH    C,B
 509         MOVEM   C,TPSTO+1(D)    ;UPDATE TP OF P.T.B.R.
 510         HRRZ    0,1(AB)         ;GET EXPRESSION INTO 0
 511         HRRZ    A,@0            ;AND ARGLIST INTO A
 512         HLL     0,(AB)          ;TYPE TO LH OF  0
 513         SUB     TP,[2,,2]       ;CLEAN UP BEFORE LEAVING
 514         JSP     C,SWAP          ;SWAP IN NEW PROCESS
 515         PUSH    P,0             ;SAVE 0
 516         PUSH    P,A             ;SAVE A=ARGLIST
 517         PUSH    TP,[0]
 518         PUSH    TP,[0]          ;COMPLETE ARGS FOR PPROC BINDING
 519         PUSHJ   P,SPECBIND      ;BIND THE PARENT PROCESS
 520         POP     P,D             ;POP ARGLIST INTO D
 521         POP     P,0             ;POP CALL HACK INTO 0
 522         MOVE    C,RESFUN+1(PVP) ;GET FUNCTION
 523         PUSHJ   P,BINDRR        ;CALL BINDER FOR RESUMED EXPR HACKING
 524
 525         HRRZ    C,@RESFUN+1(PVP) ;GET BODY BACK
 526         JUMPE   A,DOPROG        ;NOW GO RUN IF NO ACTIVIATION
 527         PUSH    TP,$TLIST       ;SAVE ANOTHER COPY FOR REACT
 528         PUSH    TP,C
 529         SKIPL   A               ;SKIP IF NOT NAME ALA HEWITT
 530         HRRZ    C,(C)           ;ELSE CDR AGAIN
 531         JRST    DOPROG
 532
 533 \f
 534 ; EVALUATE LISTS, VECTORS, UNIFROM VECTORS
 535
 536 EVLIST: PUSH    P,[-1]          ;-1 -- THIS IS A LIST
 537         JRST    EVL1            ;GO TO HACKER
 538
 539 EVECT:  PUSH    P,[0]           ;0 -- THIS IS A GENERAL VECTOR
 540         JRST    EVL1
 541
 542 EUVEC:  PUSH    P,[1]           ;1 -- THIS IS A UNIFORM VECTOR
 543
 544 EVL1:   PUSH    P,[0]           ;PUSH A COUNTER
 545         GETYPF  A,(AB)          ;GET FULL TYPE
 546         PUSH    TP,A
 547         PUSH    TP,1(AB)        ;AND VALUE
 548
 549 EVL2:   INTGO                   ;CHECK INTERRUPTS
 550         SKIPN   A,1(TB)         ;ANYMORE
 551         JRST    EVL3            ;NO, QUIT
 552         SKIPL   -1(P)           ;SKIP IF LIST
 553         JUMPG   A,EVL3          ;JUMP IF VECTOR EMPTY
 554         GETYPF  B,(A)           ;GET FULL TYPE
 555         SKIPGE  C,-1(P)         ;SKIP IF NOT LIST
 556         HLLZS   B               ;CLOBBER CDR FIELD
 557         JUMPG   C,EVL7          ;HACK UNIFORM VECS
 558 EVL8:   PUSH    P,B             ;SAVE TYPE WORD ON P
 559         CAMN    B,$TSEG         ;SEGMENT?
 560         MOVSI   B,TFORM         ;FAKE OUT EVAL
 561         PUSH    TP,B            ;PUSH TYPE
 562         PUSH    TP,1(A)         ;AND VALUE
 563         MCALL   1,EVAL          ;AND EVAL IT
 564         POP     P,C             ;AND RESTORE REAL TYPE
 565         CAMN    C,$TSEG         ;SEGMENT?
 566         JRST    DOSEG           ;YES, HACK IT
 567         AOS     (P)             ;COUNT ELEMENT
 568         PUSH    TP,A            ;AND PUSH IT
 569         PUSH    TP,B
 570 EVL6:   SKIPGE  A,-1(P) ;DONT SKIP IF LIST
 571         HRRZ    B,@1(TB)        ;CDR IT
 572         JUMPL   A,ASTOTB        ;AND STORE IT
 573         MOVE    B,1(TB)         ;GET VECTOR POINTER
 574         ADD     B,AMNT(A)       ;INCR BY APPROPRIATE AMOUNT
 575 ASTOTB: MOVEM   B,1(TB)         ;AND STORE BACK
 576         JRST    EVL2            ;AND LOOP BACK
 577
 578 AMNT:   2,,2                    ;INCR FOR GENERAL VECTOR
 579         1,,1                    ;SAME FOR UNIFORM VECTOR
 580
 581 CHKARG: GETYP   A,-1(TP)
 582         CAIE    A,TDEFER
 583         JRST    (E)
 584         HRRZS   (TP)            ;MAKE SURE INDIRECT WINS
 585         MOVE    A,@(TP)
 586         MOVEM   A,-1(TP)                ;CLOBBER IN TYPE SLOT
 587         MOVE    A,(TP)          ;NOW GET POINTER
 588         MOVE    A,1(A)          ;GET VALUE
 589         MOVEM   A,(TP)          ;CLOBBER IN
 590         JRST    (E)
 591
 592 \f
 593
 594 EVL7:   HLRE    C,A             ;FIND TYPE OF UVECTOR
 595         SUBM    A,C             ;C POINTS TO DOPE WORD
 596         GETYP   B,(C)           ;GET TYPE
 597         MOVSI   B,(B)           ;TO LH NOW
 598         SOJA    A,EVL8          ;AND RETURN TO DO EVAL
 599
 600 EVL3:   SKIPL   -1(P)           ;SKIP IF LIST
 601         JRST    EVL4            ;EITHER VECTOR OR UVECTOR
 602
 603         MOVEI   B,0             ;GET A NIL
 604 EVL9:   MOVSI   A,TLIST         ;MAKE TYPE WIN
 605 EVL5:   SOSGE   (P)             ;COUNT DOWN
 606         JRST    FINIS           ;DONE, RETURN
 607         PUSH    TP,$TLIST       ;SET TO CALL CONS
 608         PUSH    TP,B
 609         MCALL   2,CONS
 610         JRST    EVL5            ;LOOP TIL DONE
 611
 612
 613 EVL4:   MOVEI   B,EUVECT        ;UNIFORM CASE
 614         SKIPG   -1(P)           ;SKIP IF UNIFORM CASE
 615         MOVEI   B,EVECTO        ;NO, GENERAL CASE
 616         POP     P,A             ;GET COUNT
 617         .ACALL  A,(B)           ;CALL CREATOR
 618         JRST    FINIS
 619
 620 ; PROCESS SEGMENTS FOR THESE  HACKS
 621
 622 DOSEG:  MOVEM   A,BSTO(PVP)     ;WILL BECOME INTERRUPTABLE WITH GOODIE IN B
 623         HLRZS   A               ;TYPE TO RH
 624         PUSHJ   P,SAT           ;GET STORAGE TYPE
 625
 626         CAIN    A,S2WORD        ;LIST?
 627         JRST    LSTSEG
 628         CAIN    A,S2NWORD       ;GENERAL VECTOR?
 629         JRST    VECSEG
 630         CAIN    A,SNWORD        ;UNIFORM VECTOR?
 631         JRST    UVCSEG
 632         CAIE    A,SARGS         ;ARGS TUPLE?
 633         JRST    ILLSEG          ;NO, ERROR
 634
 635         PUSH    TP,BSTO(PVP)    ;PREPARE TO CHECK ARGS
 636         PUSH    TP,B
 637         SETZM   BSTO(PVP)       ;TYPE NOT SPECIAL
 638         MOVEI   B,-1(TP)        ;POINT TO SAVED COPY
 639         PUSHJ   P,CHARGS        ;CHECK ARG POINTER
 640         POP     TP,B            ;AND RESTORE WINNER
 641         POP     TP,BSTO(PVP)    ;AND TYPE AND FALL INTO VECTOR CODE
 642
 643 VECSEG: PUSH    P,[2,,2]        ;PUSH AMOUNT TO BUMP
 644         JRST    SEG1            ;AND JOIN COMMON CODE
 645
 646 UVCSEG: PUSH    P,[1,,1]        ;AMOUNT FOR UVECTS
 647         JRST    SEG1
 648
 649 \f
 650
 651 LSTSEG: SKIPL   -1(P)           ;SKIP IF IN A LIST
 652         JRST    SEG3            ;ELSE JOIN COMMON CODE
 653         HRRZ    C,@1(TB)        ;CHECK FOR END OF LIST
 654         JUMPN   C,SEG3          ;NO, JOIN COMMON CODE
 655         SETZM   BSTO(PVP)       ;CLOBBER SAVED GOODIES
 656         JRST    EVL9            ;AND FINISH UP
 657 \f
 658
 659
 660
 661 SEG3:   PUSH    P,[0]           ;AMOUNT OF ADDING FOR LIST
 662 SEG1:   INTGO                   ;CHECK OUT INTERRUPTS
 663         JUMPE   B,SEG2          ;DONE?
 664         SKIPE   C,(P)           ;CHECK IF LIST OR VECTOR
 665         JUMPG   B,SEG2          ;END OF VECTOR
 666         CAMN    C,[1,,1]        ;SKIP IF NOT UNIFORM
 667         JRST    SEG5            ;HACK UNIFORM SEGMENT
 668         GETYPF  A,(B)           ;GET NEXT TYPE
 669         SKIPGE  -2(P)           ;SKIP IF NOT LIST
 670         HLLZS   A               ;CLEAR CDR
 671         MOVE    C,1(B)          ;GET VALUE
 672 SEG4:   PUSH    TP,A            ;PUSH TYPE
 673         PUSH    TP,C
 674         PUSH    P,B             ;CAN USE P BECAUSE CHKARG NOT INTERRUPTABLE
 675         JSP     E,CHKARG        ;CHECK OUT TDEFER
 676         POP     P,B             ;RESTORE
 677         SKIPG   (P)             ;SKIP IF NOT LIST
 678         HRRZ    B,(B)           ;CDR THE LIST
 679         ADD     B,(P)           ;AND BUMP IT
 680         AOS     -1(P)           ;BUMP COUNT
 681         JRST    SEG1            ;AND DO IT AGAIN
 682
 683 SEG2:   SETZM   BSTO(PVP)       ;CLOBBER TYPE BACK
 684         SUB     P,[1,,1]        ;POP OFF LOSSAGE
 685         JRST    EVL6
 686
 687 SEG5:   HLRE    C,B             ;FIND TYPE
 688         SUBM    B,C             ;POINT TO DOPE WORD
 689         GETYP   A,(C)           ;GET  TYPE
 690         MOVSI   A,(A)           ;TO LH
 691         MOVE    C,(B)           ;NOW GET VALUE
 692         JRST    SEG4
 693
 694 \f
 695
 696 ;APFUNARG APPLIES OBJECTS OF TYPE FUNARG
 697
 698 APFUNARG:
 699         HRRZ    A,@1(TB)        ;GET CDR OF FUNARG
 700         JUMPE   A,FUNERR        ;NON -- NIL
 701         HLRZ    B,(A)           ;GET TYPE OF CADR
 702         CAIE    B,TLIST         ;BETTR BE LIST
 703         JRST    FUNERR
 704         PUSH    TP,$TLIST       ;SAVE IT UP
 705         PUSH    TP,1(A)
 706 FUNLP:
 707         INTGO
 708         SKIPN   A,3(TB)         ;ANY MORE
 709         JRST    DOF             ;NO -- APPLY IT
 710         HRRZ    B,(A)
 711         MOVEM   B,3(TB)
 712         HLRZ    C,(A)
 713         CAIE    C,TLIST
 714         JRST    FUNERR
 715         HRRZ    A,1(A)
 716         HLRZ    C,(A)           ;GET FIRST VAR
 717         CAIE    C,TATOM         ;MAKE SURE IT IS ATOMIC
 718         JRST    FUNERR
 719         PUSH    TP,BNDA         ;SET IT UP
 720         PUSH    TP,1(A)
 721         HRRZ    A,(A)
 722         PUSH    TP,(A)          ;SET IT UP
 723         PUSH    TP,1(A)
 724         JSP     E,CHKARG
 725 \r       PUSH    TP,[0]
 726         PUSH    TP,[0]
 727         JRST    FUNLP
 728 DOF:
 729         PUSHJ   P,SPECBIND      ;BIND THEM
 730         MOVE    A,1(TB)         ;GET GOODIE
 731         HLLZ    B,(A)
 732         PUSH    TP,B
 733         PUSH    TP,1(A)
 734         HRRZ    A,@1(AB)
 735         PUSH    TP,$TLIST
 736         PUSH    TP,A
 737         MCALL   2,CONS
 738         PUSH    TP,$TFORM
 739         PUSH    TP,B
 740         MCALL   1,EVAL
 741         JRST    FINIS
 742 \f
 743
 744 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT
 745 ;IN A AND B.  IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,
 746 ; IT IS CALLED BY PUSHJ P,ILOC.
 747
 748 ILOC:   MOVSI   A,TLOCI         ;MAKE A LOCATIVE TYPE CELL
 749         HRR     A,PROCID+1(PVP) ;FOR THE CURRENT PROCESS
 750         CAME    A,(B)           ;IS THERE ONE IN THE VALUE CELL?
 751         JRST    SCHSP           ;NO -- SEARCH THE LOCAL BINDINGS
 752         MOVE    B,1(B)          ;YES -- GET LOCATIVE POINTER
 753         POPJ    P,              ;FROM THE VALUE CELL
 754
 755 SCHSP:  MOVE    C,SP            ;GET TOP OF BINDINGS
 756 SCHLP:  JUMPE   C,UNPOPJ        ;IF NO MORE -- LOSE
 757         CAMN    B,1(C)          ;ARE WE POINTING AT THE WINNER?
 758         JRST    SCHFND          ;YES
 759         HRRZ    C,(C)           ;FOLLOW LINK
 760         JRST    SCHLP
 761
 762 SCHFND: EXCH    B,C             ;SAVE THE ATOM PTR IN C
 763         MOVEI   B,2(B)          ;MAKE UP THE LOCATIVE
 764         SUBI    B,(TP)
 765         HRLI    B,-1(B)
 766         ADD     B,TP
 767
 768         MOVEM   A,(C)           ;CLOBBER IT AWAY INTO THE
 769         MOVEM   B,1(C)          ;ATOM'S VALUE CELL
 770         POPJ    P,
 771
 772 UNPOPJ: MOVSI   A,TUNBOUND
 773         MOVEI   B,0
 774         POPJ    P,
 775
 776 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
 777 ;IDENTIFIER PASSED TO IT IN A AND B.  IF THE IDENTIFIER IS GLOBALLY
 778 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
 779
 780 \rIGLOC: MOVSI   A,TLOCI         ;DO WE HAVE A LOCATIVE TO
 781         CAME    A,(B)           ;A PROCESS #0 VALUE?
 782         JRST    SCHGSP          ;NO -- SEARCH
 783         MOVE    B,1(B)          ;YES -- GET VALUE CELL
 784         POPJ    P,
 785
 786 SCHGSP: MOVE    D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR
 787
 788 SCHG1:  JUMPGE  D,UNPOPJ        ;IF NO MORE, LEAVE
 789         CAMN    B,1(D)          ;ARE WE FOUND?
 790         JRST    GLOCFOUND       ;YES
 791         ADD     D,[4,,4]        ;NO -- TRY NEXT
 792         JRST    SCHG1
 793
 794 GLOCFOUND:      EXCH    B,D             ;SAVE ATOM PTR
 795         ADD     B,[2,,2]        ;MAKE LOCATIVE
 796         MOVEM   A,(D)           ;CLOBBER IT AWAY
 797         MOVEM   B,1(D)
 798         POPJ    P,
 799
 800
 801 \f
 802
 803 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
 804 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
 805 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B.  CALL - PUSHJ P,IVAL
 806
 807 ILVAL:
 808         PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
 809 CHVAL:  CAMN    A,$TUNBOUND     ;BOUND
 810         POPJ    P,              ;NO -- RETURN
 811         MOVE    A,(B)           ;GET THE TYPE OF THE VALUE
 812         MOVE    B,1(B)          ;GET DATUM
 813         POPJ    P,
 814
 815 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
 816
 817 IGVAL:  PUSHJ   P,IGLOC
 818         JRST    CHVAL
 819
 820
 821 \f
 822
 823 ;BINDER - THIS SUBROUTINE PROCCESSES FUNCTION DECLARATIONS AND BINDS
 824 ;       ARGUMENTS       AND TEMPORARIES APPROPRIATELY.
 825 ;
 826 ;       CALL:   PUSHJ   P,BINDER OR BINDRS
 827 ;
 828 ;       BINDER - ASSUMES ARGS ARE ON A LIST
 829 ;
 830 ;       BINDRS - ASSUMES FORMS SUPPLIED FOR GETTING ARGS
 831 ;       BINDRR - RESUME HACK - ARGS ON A LIST TO BE
 832 ;               EVALED IN PARENT PROCESS
 833 ;
 834
 835 ;       C/      POINTS TO FUNCTION BEING HACKED
 836 ;       D/      POINTS TO ARG LIST (IF <0, CALLED FROM A PROG)
 837 ;       0/      IF NON-ZERO POINTS TO EXPRESSION GENREATING CALL
 838
 839 BINDER: MOVEI   A,0
 840 TBINDR: PUSH    P,[ARGCDR]      ;PUSH POINTER TO ARG GETTER
 841         JRST    BIND1
 842
 843 BINDRR: MOVEI   A,0
 844 TBNDRR: PUSH    P,[RESARG]      ; ARG GETTER FOR RESUMING FUNCTIONS
 845         JRST    BIND1
 846
 847
 848 BINDRS: MOVEI   A,0             ;NO TOP TEMPS
 849 TBNDRS: PUSH    P,[SETZ EVALRG] ;FOR THE STACKFORM CASE
 850 BIND1:  PUSH    P,[2]           ;PUSH INITIAL STATE (NO DCLS PROCESSED)
 851         PUSH    P,A             ;NUMBER OF TEMPS ON TP STACK
 852
 853         JUMPE   C,NOBODY        ;NO BODY IN FUNCTION, ERROR
 854
 855         GETYP   A,(C)           ;GET FIRST THING IN FUNCTION
 856         CAIE    A,TATOM         ;ATOMIC?
 857         JRST    BIND2           ;NO, NO NAME ALA HEWITT GIVEN
 858         PUSHJ   P,TMPUP         ;COUNT TEMPS ON TP
 859         PUSH    TP,[TATOM,,1]   ;YES SAVE IT
 860         PUSH    TP,1(C)
 861         HRRZ    C,(C)           ;CDR THE FUNCTION TO POINT
 862         JUMPE   C,NOBODY
 863
 864 BIND2:  PUSHJ   P,CARLST        ;MAKE SURE THE CAR IS A LIST
 865         JRST    BNDRET          ;EXIT IMMEDIATELY
 866         MOVEI   A,(C)           ;COPY FOR NXTDCL
 867         JUMPL   D,AUXDO         ;PROG, HANDLE
 868
 869         PUSHJ   P,NXTDCL        ;GET A DECLARATION
 870         JRST    BINDRG          ;NONE THERE, GO BIND ARGS
 871
 872         CAME    B,[ASCII /BIND/]        ;IS A BINDING NEEDED
 873         JRST    BIND3           ;NO MUST BE ANOTHER FLAVOR OF DCL
 874
 875         HRRZ    C,(A)           ;CDR THE LIST
 876         JUMPE   C,MPD           ;LOSER
 877
 878         PUSHJ   P,CARATM        ;GET THE CAR MAKING SURE OF ATOM
 879         JRST    MPD
 880         HRRZ    B,OTBSAV(TB)    ;BUILD AN ENVIRONEMNT  FOR BINDING VAR
 881         PUSHJ   P,MAKENV
 882
 883         PUSHJ   P,PSHBND        ;PUSH THE BINDING ON THE STACK
 884         HRRZ    C,(C)           ;CDR THE DCL LIST
 885         JRST    BINDRG          ;GO BIND AS AN ARG
 886
 887 \f
 888
 889 ; MAIN BINDING LOOP, DISPATCH BASED ON DECLARATION
 890
 891 BIND4:  MOVEI   A,(C)           ;COPY THE LIST POINTER
 892         PUSHJ   P,NXTDCL        ;AND LOOK FOR A DECLARATION
 893         JRST    CHLIST          ;ILLEGAL
 894 BIND3:  TRZ     B,1             ;FOR OPTIONAL TO WIN
 895         MOVSI   A,-DCLS         ;NOW GET SET TO SEARCH TABLE
 896         HRRZ    C,(C)           ;CDR THE DCL LIST
 897         JUMPE   C,MPD           ;NO, CDR, ERROR
 898
 899         CAMN    B,DCLST(A)      ;SKIP IF NOT FOUND
 900         JRST    @DCLGO(A)       ;DISPATCH BASED ON DCL
 901         AOBJN   A,.-2
 902
 903         JRST    MPD
 904
 905 DCLS==0
 906
 907 DCLST:  IRP     A,,[ARGS,TUPLE,CALL,OPTIO,ACT,AUX,NAME,EXTRA]
 908         DCLS==DCLS+1
 909         ASCII /A/
 910         TERMIN
 911
 912 DCLS2==0
 913 \rDCLGO: IRP     A,,[ARGDO,TUPLDO,CALDO,OPTDO,ACTDO,AUXDO,ACTDO,AUXDO]
 914         A
 915         DCLS2==DCLS2+1
 916         TERMIN
 917
 918 IFN <DCLS-DCLS2>,PRINTC /LOSSAGE AT DCLS
 919 /
 920 EXPUNGE DCLS2
 921
 922 ;HERE TO CHECK FOR LISTS WITHIN DECLARATIONS
 923
 924 CHLIST: GETYP   A,(C)           ;GET TYPE
 925         CAIE    A,TLIST         ;LIST?
 926         JRST    MPD             ;NO, LOSER
 927         SKIPN   A,1(C)          ;CHECK NON-NIL
 928         JRST    CALD1           ;IF NIL, IGNORE
 929         PUSH    TP,[TLIST,,1]   ;SPECIAL TYPE
 930         PUSH    TP,C
 931         MOVEI   C,(A)           ;LIST TO C
 932         PUSHJ   P,TMPUP         ;COUNT TEMPS
 933         JRST    BINDRG
 934
 935
 936 \f
 937
 938 ;HANDLER FOR CALL DECLARATION
 939
 940 CALDO:  SKIPL   -2(P)           ;SKIP IF IN STACK-FORM
 941         SOSG    -1(P)           ;SKIP IF FIRST DECLARATION
 942         JRST    MPD             ;OTHERWISE MEANINGLESS
 943
 944         JUMPE   0,MPD           ;ALSO MEANINGLESS IF NO CALLSITE GIVEN
 945         PUSHJ   P,CARATD        ;GOBBLE THE ATOM
 946
 947         HLLZ    A,0             ;SET UP CALL TO PUSH THE BINDING
 948         HRRZ    B,0
 949 CALD2:  PUSHJ   P,PSHBND        ;PUSH THAT BINDING ON TO STACK
 950
 951 CALD1:  PUSH    TP,$TLIST       ;SAVE THE DCL LIST
 952         PUSH    TP,C
 953         MOVEI   E,-2(TP)        ;POINT TO DCLS
 954         SUB     E,(P)           ;SUBTRACT TEMPS
 955 CALD3:  PUSHJ   P,SPCBE         ;DO THE BINDINGS NOW
 956         MOVE    C,(TP)          ;RESTORE DCLS
 957         SUB     TP,[2,,2]       ;AND POP
 958         HRRZ    C,(C)           ;CDR THE LIST
 959 CALD4:  SETZM   -1(P)           ;NEXT MUST BE EITHER AUX OR ACT
 960         JUMPN   C,BIND4         ;LOOP AGAIN
 961
 962 \f
 963
 964 BNDRET: MOVEI   A,0             ;SET SWITCH
 965 BNDRT2: SKIPN   (P)             ;ANY TEMPS LEFT?
 966         JRST    BNDRT1
 967         MOVE    B,-1(TP)        ;GET TYPE
 968         CAMN    B,[TATOM,,1]    ;SPECIAL
 969         JRST    BNDRT3
 970         CAME    B,[TLIST,,1]    ;STACKED LIST
 971         JRST    BNDRT1          ;NO, LEAVE
 972
 973         PUSHJ   P,TMPDWN        ;TEMPS DOWN
 974         HRRZ    C,@(TP) ;CDR THE SAVED LIST
 975         SUB     TP,[2,,2]       ;POP OFF CRAP
 976         JRST    CALD4           ;AND CONTINUE PROCESSING
 977
 978 BNDRT3: PUSHJ   P,TMPDWN
 979         MOVE    E,(TP)          ;GET ATOM
 980         SUB     TP,[2,,2]
 981         MOVEI   C,0             ;FOR ACTDO TO WIN
 982         PUSHJ   P,ACTD1
 983         MOVEI   A,1             ;SAY NAME EXISTS
 984
 985 BNDRT1: SUB     P,[3,,3]
 986         POPJ    P,
 987
 988 \f
 989
 990 ; HERE TO ARGS DECLARATION
 991
 992 ARGDO:  SOSL    -1(P)           ;LOSE IF STATES ARE 0 OR 1
 993         SKIPGE  -2(P)           ;ALSO LOSE IN STACK-FRAME
 994         JRST    MPD
 995
 996         PUSHJ   P,CARATD        ;FIND THE ATOM
 997
 998         MOVSI   A,TLIST
 999         MOVEI   B,(D)           ;COPY ARGL
1000         JRST    CALD2           ;AND FALL INTO CALL CODE
1001
1002 ;HERE TO HANDLE THE TUPLE DCL
1003
1004 TUPLDO: SOSGE   -1(P)           ;CHECK STATE
1005         JRST    MPD
1006
1007         PUSHJ   P,CARATD        ;GET ATOM
1008         PUSH    TP,$TLIST       ;SAVE DCL LIST
1009         PUSH    TP,C
1010         PUSHJ   P,TMPUP         ;COUNT THE TEMPS
1011         SETZB   A,B
1012
1013         PUSHJ   P,PSHBND        ;PUSH THE BINDING FOR THIS CHOMPER
1014         PUSH    P,[0]           ;PUSH   ARG COUNTER
1015
1016 TUPLP:  PUSHJ   P,@-3(P)        ;CALL ARG GOBBLING SUBROUTINE
1017         JRST    TUPDONE         ;LEAVE IF ALL DONE
1018
1019         PUSHJ   P,PSHAB         ;PUSH THE EVALED ARG
1020         SOS     (P)             ;COUNT THE ARG
1021         JRST    TUPLP
1022
1023 TUPDON: MOVSI   A,TTB           ;FENCE POST ARG BLOCK
1024         MOVE    B,TB            ;WITH A FRAME POINTER
1025         PUSHJ   P,PSHAB         ;ONTO THE STACK
1026         POP     P,B             ;GET NUMBER OF ARGS
1027         ASH     B,1             ;TIMES TWO
1028         SKIPE   B               ;WATCH FOR EMPTY TUPLE
1029         HRLI    B,-1(B)         ;FOR ADDING TO TOA TP
1030         ADDI    B,-1(TP)        ;FUDGE POINTER
1031         SUB     B,(P)           ;SUBTRACT TEMPS
1032         MOVEI   E,-1(B)         ;B WIIL GET CLOBBERED, SAVE
1033         MOVSI   A,TARGS         ;GET THE RIGHT TYPE
1034         HLR     A,OTBSAV(TB)    ;WITH THE TIME
1035         MOVEM   A,-4(B)         ;CLOBBER IT AWAY
1036         MOVEM   B,-3(B)         ;AND ARG POINTER
1037
1038         PUSHJ   P,TMPDWN
1039         JRST    CALD3
1040
1041 ; HERE TO HANDLE OPTIONAL DECLARATION
1042
1043 OPTDO:  SKIPG   -1(P)
1044         JRST    MPD             ;NOT ALLOWED
1045         SETZM   -1(P)           ;MUNG STATE
1046         JRST    BNDRGL          ;JOIN BIND LOOP
1047
1048 BINDRG: SKIPG   -1(P)           ;CHECK STATE
1049         JRST    MPD
1050
1051 BNDRGL: JUMPE   C,CHLST         ;CHECK FOR LAST
1052         PUSH    TP,$TLIST       ;SAVE DCLS
1053         PUSH    TP,C
1054         PUSH    TP,$TLIST       ;SAVE SLOT
1055         PUSH    TP,D            ;PUT ARGLIST THERE FOR AN INT CHECK
1056         INTGO
1057         MOVE    D,(TP)          ;INCASE INTERRUPT CLOBBERED IT
1058         SETZM   (TP)            ;NOW CLEAR SLOT
1059
1060
1061 BNDRG3: PUSHJ   P,CARATM        ;CHECK FOR ATOM
1062         JRST    OPTDFL          ;NO, MAY BE LIST OR MAY BE QUOTED
1063
1064         PUSH    TP,$TATOM
1065         PUSH    TP,E            ;AND ATOM
1066
1067         PUSHJ   P,@-2(P)        ;GOBBLE DOWN NEXT ARG
1068         JRST    USEDF           ;CHECK FOR DEFAULT OT ENOUGH
1069
1070 BNDRG2: HRRZ    C,-4(TP)        ;RESTORE DCLS
1071         MOVE    E,(TP)          ;AND ATOM
1072         SUB     TP,[6,,6]       ;FLUSH CRAP
1073
1074         PUSHJ   P,PSHBND        ;PUSH THE BINDING
1075 BNDRG4: HRRZ    C,(C)           ;CDR THE DCL LIST
1076         JUMPN   C,BNDRGL
1077
1078 CHLST:  PUSHJ   P,@-2(P)        ;CHECK FOR LAST
1079         JRST    .+2
1080         JRST    TMA
1081         MOVEI   E,(TP)          ;PREPARE TO BIND
1082         SUB     E,(P)
1083         PUSHJ   P,SPCBE         ;BIND IF STUFF EXISTS
1084         JRST    BNDRET          ;AND RETURN
1085
1086 \f
1087
1088 CHQT:   CAIE    A,TFORM         ;IST THE ARG A FORM?
1089         JRST    OPTDF2          ;NO, END OF ARGS
1090
1091         SKIPN   C,1(C)          ;CHECK FOR NULL BODY
1092         JRST    MPD
1093
1094         GETYP   A,(C)           ;TYPE OF 1ST OF FORM
1095         MOVE    B,1(C)          ;AND VALUE
1096         CAIN    A,TATOM         ;BETTER BE ATOM
1097         CAME    B,MQUOTE QUOTE
1098         JRST    MPD             ;NAMED QUOTE OR LOSSAGE
1099         HRRZ    C,(C)           ;CDR THE FORM
1100         JUMPE   C,MPD           ;NO, ARG LOSE
1101         GETYP   A,(C)
1102         CAIE    A,TATOM         ;ARG MUST BE ATOM
1103         JRST    MPD
1104         HRRZ    A,(C)           ;AND CDR BETTER BE NIL
1105         JUMPN   A,MPD
1106         PUSH    TP,$TATOM       ;AND SAVE SAME
1107         PUSH    TP,1(C)\r
1108         SKIPGE  A,-2(P)         ;CHECK TYPE OF ARGS
1109         JRST    QUOTHK          ;STACK FRAME HACK
1110
1111         JUMPE   D,USEDF         ;IF NO MORE ARGS, QUIT
1112         GETYP   A,(D)           ;GET TYPE
1113         MOVSI   A,(A)           ;TO LH
1114         PUSH    TP,A            ;PUSH IT UP
1115         PUSH    TP,1(D)         ;FOR DEFER CHECK
1116         JSP     E,CHKARG
1117         POP     TP,B            ;GET BACK
1118         POP     TP,A
1119         HRRZ    D,(D)           ;CDR THE ARG LIST
1120         JRST    BNDRG2
1121
1122 QUOTHK: PUSHJ   P,(A)           ;CALL ROUTINE
1123         JRST    USEDF           ;TOO FEW ARGS
1124
1125         PUSH    TP,$TATOM       ;QUOTE THE GOODIE
1126         PUSH    TP,MQUOTE QUOTE
1127         PUSH    TP,A
1128         PUSH    TP,B
1129         MCALL   2,LIST          ;CONS IT UP
1130         MOVSI   A,TFORM
1131         JRST    BNDRG2
1132
1133
1134 \f
1135
1136 OPTDFL: SKIPN   -1(P)           ;SKIP IF CANT BE DEFAULT
1137         CAIE    A,TLIST         ;SHOULD BE A LIST
1138         JRST    CHQT            ;NO MORE OPTIONALS
1139
1140         SKIPE   (TP)            ;AVOID LIST OF LIST
1141         JRST    MPD
1142         MOVE    C,1(C)          ;GET THE CAR
1143         HRRZ    A,(C)           ;CDR THE LIST
1144         JUMPE   A,MPD           ;LOSER
1145         HRRZ    B,(A)           ;CHECK FOR NIL CDR
1146         JUMPN   B,MPD
1147         MOVEM   A,(TP)          ;SAVE
1148         JRST    BNDRG3
1149
1150 OPTDF2: JUMPN   D,OPTDF3        ;IF D NON-ZERO, DONT BIND
1151         MOVEI   E,-4(TP)        ;PREPARE TO BIND
1152         SUBI    E,@(P)          ;SUBTRACT TEMPS
1153         PUSHJ   P,SPCBE         ;DO BINDINGS MAYBE
1154         MOVEI   D,0             ;RESET D TO 0
1155 OPTDF3: MOVE    C,-2(TP)        ;RESTORE DCLS
1156         SUB     TP,[4,,4]       ;POP STACK
1157         MOVEI   A,1             ;CLOBBER IN A NEW STATE
1158         MOVEM   A,-1(P)
1159         JRST    BIND4           ;AND RE-ENTER THE LOOP
1160
1161
1162 USEDF:  SKIPE   -1(P)           ;SKIP IF OPTIONAL
1163         JRST    TFA             ;ELSE TOO FEW ARGS
1164         MOVEI   E,-6(TP)        ;SET TO DO SPECBIND
1165         SUBI    E,@(P)
1166         PUSHJ   P,SPCBE         ;BIND IF THEY EXIST
1167         MOVNI   B,1             ;ASSUME UNASSIGNED AT FIRST
1168         MOVSI   A,TUNBOU
1169         SKIPN   C,-2(TP)        ;IF A FORM TO EVAL
1170         JRST    OPTDF4          ;TREAT NORMALLY
1171         GETYP   A,(C)           ;EVAL IT
1172         MOVSI   A,(A)
1173         PUSH    TP,A
1174         PUSH    TP,1(C)
1175         JSP     E,CHKARG        ;CHECK FOR DEFERRED POINTERS
1176         MCALL   1,EVAL          ;EVAL IT
1177 OPTDF4: MOVE    E,(TP)          ;GET ATOM
1178         MOVE    C,-4(TP)
1179         SUB     TP,[6,,6]       ;FLUSH JUNK
1180         PUSHJ   P,PSHBND        ;PUSH THE BINDING
1181         MOVEI   D,0             ;MUNG ARG LIST
1182         JRST    BNDRG4
1183
1184 \f
1185
1186 AUXDO:  SKIPGE  -1(P)           ;CHECK STATE
1187         JRST    MPD
1188         SETOM   -1(P)           ;NOTHING BUT ACT MAY FOLLOW
1189
1190 AUXBND: JUMPE   C,BNDRET        ;DONE
1191         PUSHJ   P,CARATM        ;LOOK FOR ATOM
1192         JRST    AUXIN           ;COULD BE LIST
1193
1194         MOVSI   A,TUNBOU
1195         MOVNI   B,1
1196 AUXB1:  PUSHJ   P,PSHBND        ;PUSH THE BINDING UP
1197
1198         MOVEI   E,(TP)          ;PREPARE TO BIND
1199         PUSH    TP,$TLIST       ;SAVE DCLS
1200         PUSH    TP,C
1201         SUB     E,(P)           ;FUDGE FOR TEMPS
1202         PUSHJ   P,SPCBE
1203
1204         INTGO
1205         HRRZ    C,@(TP)         ;CDR THE LIST
1206         SUB     TP,[2,,2]       ;AND POP
1207         JRST    AUXBND
1208
1209 AUXIN:  CAIE    A,TLIST         ;IS IT A LIST
1210         JRST    BIND4
1211         PUSH    TP,$TLIST       ;SAVE  DCLS
1212         PUSH    TP,C
1213         SKIPN   C,1(C)          ;NIL?
1214         JRST    MPD             ;YES, LOSE
1215         PUSHJ   P,CARATD        ;MAKE SURE ITS AN ATOM
1216         PUSH    TP,$TATOM
1217         PUSH    TP,E
1218         HRRZ    C,(C)           ;CDR
1219         JUMPE   C,MPD
1220         HRRZ    A,(C)           ;GET NEXT CDR
1221         JUMPN   A,MPD           ;BETTER BE NIL
1222         GETYP   A,(C)
1223         MOVSI   A,(A)           ;TYPE TO LH
1224         PUSH    TP,A
1225         PUSH    TP,1(C)         ;PREPARE TO EVAL
1226         MCALL   1,EVAL
1227         MOVE    E,(TP)          ;RESTORE ATOM
1228         MOVE    C,-2(TP)        ;AND DCLS
1229         SUB     TP,[4,,4]
1230         JRST    AUXB1
1231
1232 \f
1233
1234 ACTDO:  PUSHJ   P,CARATD        ;MUST BE ATOMIC
1235         HRRZ    C,(C)           ;MUST BE END OF DCLS
1236         JUMPN   C,MPD
1237         PUSH    P,CBNDRE        ;PUSH THE RIGHT RETURN
1238
1239 ACTD1:  MOVE    B,TB            ;MAKE ENV
1240         PUSHJ   P,MAKENV
1241         HRLI    A,TACT          ;AND CHANGE TO ACTIVATION
1242         POP     P,D             ;RESTORE RET ADR, BECAUSE PSHBND NEEDS NICE STATE
1243         PUSHJ   P,PSHBND        ;PUSH UP THE BINDING
1244         PUSH    P,D             ;NOW PUT IT BACK
1245         MOVEI   E,(TP)
1246         SUBI    E,@-1(P)        ;NOW READY TO BIND
1247         PUSHJ   P,SPCBE
1248         MOVNI   A,1             ;SET SW
1249 CBNDRE: POPJ    P,BNDRT2
1250
1251
1252 ;INTERNAL ROUTINES FOR THE BINDER
1253
1254 TMPUP:  AOS     -1(P)           ;ADDS 2 TO TOP OF STACK
1255         AOS     -1(P)
1256         POPJ    P,
1257
1258 TMPDWN: SOS     -1(P)           ;SUBTRACTS 2 FROM STACK
1259         SOS     -1(P)
1260         POPJ    P,
1261
1262 CARATD: PUSHJ   P,CARATM        ;LOOK FOR ATOM
1263         JRST    MPD             ;ERROR IF NONE
1264         POPJ    P,
1265
1266 CARATM: GETYP   A,(C)           ;GETS ARG IN C, GET TYPE
1267         CAIE    A,TATOM         ;ATOM?
1268         POPJ    P,              ;NO, DONT SKIP
1269         MOVE    E,1(C)          ;RETRUN ATOM IN E
1270 CPOPJ1: AOS     (P)             ;SKIP RET
1271 CPOPJ:  POPJ    P,
1272
1273 CARLST: GETYP   A,(C)           ;GETS LIST IN CAR, POPS TO 2D ON STACK IF NIL
1274         CAIE    A,TLIST
1275         JRST    MPD             ;NOT A LIST, FATAL
1276         SKIPE   C,1(C)
1277         AOS     (P)
1278         POPJ    P,
1279
1280
1281 MAKENV: PUSH    P,C             ;SAVE AN AC
1282         HLRE    C,PVP           ;GET -LNTH OF PROC VECTOR
1283         MOVEI   A,(PVP)         ;COPY PVP
1284         SUBI    A,-1(C)         ;POINT TO DOPWD WITH A
1285         HRLI    A,TENV          ;MAKE INTO AN ENVIRONMENT
1286         HLL     B,OTBSAV(B)     ;TIME TO B
1287         POP     P,C
1288         POPJ    P,
1289
1290
1291 \f
1292
1293 ; ARGCDR - NORMAL ARG GETTER FOR OTHER THAN STACKFORM
1294
1295 ARGCDR: JUMPE   D,CPOPJ         ;DONT SKIP IF NIL
1296         PUSH    TP,$TLIST
1297         PUSH    TP,D
1298         GETYP   A,(D)           ;GET TYPE OF ARG
1299         MOVSI   A,(A)           ;TO LH OF A
1300         PUSH    TP,A
1301         PUSH    TP,1(D)         ;PUSH TYPE AND VALUE
1302         JSP     E,CHKARG        ;CHECK FOR TDEFER
1303         MCALL   1,EVAL
1304         HRRZ    D,@(TP)         ;CDR THE LIST
1305         SUB     TP,[2,,2]       ;POP STACK
1306         JRST    CPOPJ1          ;SKIP RETURN
1307
1308 ;EVALRG - USED TO EVAL ARGS IN STACKFORM HACK
1309
1310 EVALRG: JUMPE   D,CPOPJ         ;LEAVE IMMEDIATELY
1311         PUSH    TP,$TLIST       ;SAVE ARG LIST
1312         PUSH    TP,D
1313         HRRZ    C,(D)           ;AND CDR IT
1314         GETYP   B,(C)           ;GET TYPE OF CONDITIONAL FORM
1315         MOVSI   B,(B)           ;TO LH
1316         PUSH    TP,B
1317         PUSH    TP,1(C)         ;AND VALUE
1318         JSP     E,CHKARG        ;CHECK DEFERRED
1319         MCALL   1,EVAL          ;AND EVAL IT
1320         CAMN    A,$TFALSE       ;FALSE?
1321         JRST    EVALR2          ;YES, LEAVE
1322         HRRZ    D,(TP)          ;GET ARGS BACK
1323         GETYP   A,(D)           ;GET TYPE
1324         MOVSI   A,(A)           ;TO LH
1325         PUSH    TP,A
1326         PUSH    TP,1(D)         ;PUSH IT
1327         JSP     E,CHKARG        ;CHECK DEFERRED
1328         MCALL   1,EVAL
1329         AOS     (P)             ;CAUSE A SKIP RETURN
1330 EVALR2: MOVE    D,(TP)          ;RESTORE ARGS
1331         SUB     TP,[2,,2]       ;POP STACK
1332         POPJ    P,              ;AND RETURN
1333
1334 ;RESARG - USED TO GET ARGS FOR RESUMING FUNCTIONS
1335
1336
1337 RESARG:
1338         JUMPE   D,CPOPJ ;DONT SKIP IF NIL - NO MORE ARGS
1339         PUSH    TP,$TLIST       ; SAVE ARG LIST
1340         PUSH    TP,D
1341         GETYP   A,(D)           ; GET TYPE OF ARG
1342         MOVSI   A,(A)           ;TO LH
1343         PUSH    TP,A            ;PUSH TYPE
1344         PUSH    TP,1(D)         ;AND VALUE
1345         JSP     E,CHKARG        ;CHECK FOR DEFERED TYPE
1346         MOVE    B,MQUOTE [PPROC ]INTERR
1347         PUSHJ   P,ILVAL         ;GET ENV OF PARENT PROCESS
1348         PUSH    TP,A
1349         PUSH    TP,B            ;SET UP FOR AEVAL CALL
1350         MCALL   2,EVAL          ;CALL EVAL WITH THE ENV
1351         HRRZ    D,@(TP)         ;CDR ARG LIST
1352         SUB     TP,[2,,2]       ;REMOVE SAVED ARG LIST
1353         JRST    CPOPJ1          ;SKIP 1 AND RETURN
1354
1355 \f
1356
1357 ;SUBROUTINE TO PUSH A BINDING ON THE STACK
1358 ;       E/      ATOM
1359 ;       A/      TYPE
1360 ;       B/      VALUE
1361
1362 PSHBND: PUSH    P,D             ;SAVE TEMPS
1363         PUSH    P,E
1364         MOVE    D,-3(P)         ;GOBBLE # OF TEMPS ON STACK
1365         ADD     TP,[6,,6]       ;ALOCATE SPACE
1366         JUMPGE  TP,TPLOSE       ;HACK IF OVERFLOW
1367 PSHBN1: HRROI   E,-6(TP)        ;SET UP E
1368         JUMPE   D,NOBLT         ;IF NO TEMPS, LESS WORK
1369         POP     E,6(E)          ;USE POP TP MOVE THEM UP
1370         SOJN    D,.-1
1371 NOBLT:  MOVSI   D,TATOM         ;SET UP BINDING
1372         HLLOM   D,1(E)          ;CLOBBER
1373         POP     P,2(E)          ;ATOM INTO SLOT
1374         MOVEM   A,3(E)
1375         MOVEM   B,4(E)
1376         SETZM   5(E)            ;CLEAR EXTRA SLOTS
1377         SETZM   6(E)
1378         POP     P,D
1379         POPJ    P,
1380
1381 TPLOSE: PUSHJ   P,TPOVFL        ;GO TO INT HANDLER
1382         JRST    PSHBN1
1383
1384 ; DO A SPECBIND IF NEEDED
1385
1386 SPCBE:  MOVE    A,-5(E)         ;GET TYPE
1387         CAME    A,BNDA
1388         POPJ    P,
1389         MOVEI   A,(TP)          ;COPY POINTER
1390         SUBI    A,(E)           ;FIND DISTANCE TO TOP
1391         MOVSI   A,(A)           ;TO LH
1392         HLL     E,TP
1393         SUB     E,A             ;FIX UP POINTER
1394         JRST    SPECBE          ;YES, GO DO IT
1395
1396 ;ROUTINE TO SQUEEZE A PAIR ON THE STACK
1397
1398 PSHAB:  PUSH    P,D
1399         PUSH    P,E
1400         PUSH    TP,[0]          ;ALLOCATE SPACE
1401         PUSH    TP,[0]
1402         MOVE    D,-4(P)         ;GET TEMPS COUNT
1403         HRROI   E,-2(TP)        ;POINT TO TOP
1404         JUMPE   D,NOBLT1
1405         POP     E,2(E)
1406         SOJN    D,.-1
1407
1408 NOBLT1: MOVEM   A,1(E)          ;CLOBBER
1409         MOVEM   B,2(E)
1410         POP     P,E
1411         POP     P,D
1412         POPJ    P,
1413
1414 \f
1415
1416 ;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
1417 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
1418 ;EACH TRIPLET IS AS FOLLOWS:
1419 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
1420 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
1421 ;AND THE THIRD IS A PAIR OF ZEROES.
1422
1423 BNDA:   TATOM,,-1
1424 BNDV:   TVEC,,-1
1425
1426 SPECBIND:       MOVE    E,TP            ;GET THE POINTER TO TOP
1427 SPECBE: ADD     E,[1,,1]        ;BUMP POINTER ONCE
1428         SETZB   0,D             ;CLEAR TEMPS
1429
1430 BINDLP: MOVE    A,-6(E)         ;GET TYPE
1431         CAME    A,BNDA          ;NORMAL ID BIND?
1432         JRST    NONID           ;NO TRY BNDV
1433
1434         SUB     E,[6,,6]        ;MOVE PTR
1435         SKIPE   D               ;LINK?
1436         HRRM    E,(D)           ;YES --  LOBBER
1437         SKIPN   0               ;UPDATED?
1438         MOVE    0,E             ;NO -- DO IT
1439
1440         MOVE    A,0(E)          ;GET ATOM PTR
1441         MOVE    B,1(E)
1442         PUSHJ   P,ILOC          ;GET LAST BINDING
1443         HLR     A,OTBSAV (TB)   ;GET TIME
1444         MOVEM   A,4(E)          ;CLOBBER IT AWAY
1445         MOVEM   B,5(E)          ;IN RESTORE CELLS
1446
1447         HRRZ    A,PROCID+1(PVP) ;GET PROCESS NUMBER
1448         HRLI    A,TLOCI         ;MAKE LOC PTR
1449         MOVE    B,E             ;TO NEW VALUE
1450         ADD     B,[2,,2]
1451         MOVE    C,1(E)          ;GET ATOM PTR
1452         MOVEM   A,(C)           ;CLOBBER ITS VALUE
1453         MOVEM   B,1(C)          ;CELL
1454         MOVEI   A,TBIND
1455         HRLM    A,(E)           ;IDENTIFY AS BIND BLOCK
1456         MOVE    D,E             ;REMEMBER LINK
1457         JRST    BINDLP          ;DO NEXT
1458
1459 NONID:  MOVE    A,-4(E)         ;TRY TYPE BEFORE
1460         CAME    A,BNDV          ;IS IT A SPECIAL HACK?
1461         JRST    SPECBD          ;NO  -- DONE
1462         SUB      E,[4,,4]
1463         SKIPE   D
1464         HRRM    E,(D)
1465         SKIPN   0
1466         MOVE    0,E
1467
1468         MOVE    D,1(E)          ;GET PTR TO VECTOR
1469         MOVE    C,(D)           ;EXCHANGE TYPES
1470         EXCH    C,2(E)
1471         MOVEM   C,(D)
1472
1473         MOVE    C,1(D)          ;EXCHANGE DATUMS
1474         EXCH    C,3(E)
1475         MOVEM   C,1(D)
1476
1477         MOVEI   A,TBVL
1478         HRLM    A,(E)           ;IDENTIFY BIND BLOCK
1479         MOVE    D,E             ;REMEMBER LINK
1480         JRST    BINDLP
1481
1482 SPECBD: SKIPE   D
1483         HRRM    SP,(D)
1484         MOVE    SP,0
1485         POPJ    P,
1486
1487 \f
1488
1489 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
1490 ;SPSAV (TB).  IT IS CALLED BY PUSHJ P,SPECSTORE.
1491
1492 SPECSTORE:
1493         HRRZ    E,SPSAV (TB)    ;GET TARGET POINTER
1494
1495 STLOOP:
1496         CAIL    E,(SP)          ;ARE WE DONE?
1497         JRST    STPOPJ
1498         HLRZ    C,(SP)          ;GET TYPE OF BIND
1499         CAIE    C,TBIND         ;NORMAL IDENTIFIER?
1500         JRST    ISTORE          ;NO -- SPECIAL HACK
1501
1502
1503         MOVE    C,1(SP)         ;GET TOP ATOM
1504         MOVE    D,4(SP)         ;GET STORED LOCATIVE
1505 \r       HRR     D,PROCID+1(PVP) ;STORE SIGNATURE
1506         MOVEM   D,(C)           ;CLOBBER INTO ATOM
1507         MOVE    D,5(SP)
1508         MOVEM   D,1(C)
1509         SETZM   4(SP)
1510 SPLP:   HRRZ    SP,(SP)         ;FOLOW LINK
1511         JUMPN   SP,STLOOP       ;IF MORE
1512         JUMPE   E,STPOPJ        ;ONLY OK IF E=0
1513         .VALUE  [ASCIZ /SPOVERPOP/]
1514
1515 ISTORE: CAIE    C,TBVL
1516         .VALUE  [ASCIZ /BADSP/]
1517         MOVE    C,1(SP)
1518         MOVE    D,2(SP)
1519         MOVEM   D,(C)
1520         MOVE    D,3(SP)
1521         MOVEM   D,1(C)
1522         JRST    SPLP
1523
1524 STPOPJ:
1525         MOVE    SP,SPSAV(TB)
1526         POPJ    P,
1527
1528
1529 \f
1530
1531 MFUNCTION REP,FSUBR,[REPEAT]
1532         JRST    PROG
1533 MFUNCTION PROG,FSUBR
1534         ENTRY   1
1535         GETYP   A,(AB)          ;GET ARG TYPE
1536         CAIE    A,TLIST         ;IS IT A LIST?
1537         JRST    WTYP            ;WRONG TYPE
1538         SKIPN   C,1(AB)         ;GET AND CHECK ARGUMENT
1539         JRST    ERRTFA          ;TOO FEW ARGS
1540         PUSH    TP,$TLIST       ;PUSH GOODIE
1541         PUSH    TP,C
1542         PUSH    TP,BNDA         ;BIND FUNNY ATOM
1543         PUSH    TP,MQUOTE [LPROG ]INTERR
1544         PUSH    TP,$TTB
1545         PUSH    TP,TB           ;CURRENT TB POINTER
1546         PUSH    TP,[0]
1547         PUSH    TP,[0]
1548         PUSHJ   P,SPECBI        ;BIND THE ATOM
1549         MOVE    C,1(AB)         ;PROG BODY
1550         MOVNI   D,1             ;TELL BINDER WE ARE APROG
1551         PUSHJ   P,BINDER
1552         HRRZ    C,1(AB)         ;RESTORE PROG
1553         SKIPLE  A               ;SKIP IF NO NAME ALA HEWITT
1554         HRRZ    C,(C)
1555         JUMPE   C,NOBODY
1556         PUSH    TP,$TLIST
1557         PUSH    TP,C            ;SAVE FOR REPEAT, AGAIN ETC.
1558         HRRZ    C,(C)           ;SKIP DCLS
1559
1560 ; HERE TO RUN PROGS FUNCTIONS ETC.
1561
1562 DOPROG:
1563         HRRZM   C,1(TB)         ;CLOBBER AWAY BODY
1564         PUSH    TP,(C)          ;EVALUATE THE
1565         HLLZS   (TP)
1566         PUSH    TP,1(C)         ;STATEMENT
1567         JSP     E,CHKARG
1568         MCALL   1,EVAL
1569         HRRZ    C,@1(TB)        ;GET THE REST OF THE BODY
1570         JUMPN   C,DOPROG        ;IF MORE -- DO IT
1571 ENDPROG:
1572         HRRZ    C,FSAV(TB)
1573         MOVE    C,@-1(C)
1574         CAME    C,MQUOTE REP,REPEAT
1575         JRST    FINIS
1576         SKIPN   C,(TP)          ;CHECK IT
1577         JRST    FINIS
1578         MOVEM   C,1(TB)
1579         JRST    CONTINUE
1580
1581 \f
1582
1583 MFUNCTION RETURN,SUBR
1584         ENTRY   1
1585         PUSHJ   P,PROGCH        ;CKECK IN A PROG
1586         HRR     TB,B            ;YES, SET TB
1587         MOVE    A,(AB)
1588         MOVE    B,1(AB)
1589         JRST    FINIS
1590
1591
1592 MFUNCTION AGAIN,SUBR
1593         ENTRY
1594         HLRZ    A,AB            ;GET # OF ARGS
1595         CAIN    A,-2            ;1 ARG?
1596         JRST    NLCLA           ;YES
1597         JUMPN   A,WNA           ;0 ARGS?
1598         PUSHJ   P,PROGCH        ;CHECK FOR IN A PROG
1599         JRST    AGAD
1600 NLCLA:  HLRZ    A,(AB)
1601         CAIE    A,TACT
1602         JRST    WTYP
1603         MOVE    A,1(AB)
1604         HRR     B,A
1605         HLL     B,OTBSAV (B)
1606         HRRZ    C,A
1607         CAIG    C,1(TP)
1608         CAME    A,B
1609         JRST    ILLFRA
1610         HLRZ    C,FSAV (C)
1611         CAIE    C,TENTRY
1612         JRST    ILLFRA
1613 AGAD:   HRR     TB,B
1614         MOVE    B,TPSAV(B)      ;POINT TO TOP OF STACK
1615         MOVE    B,(B)
1616         MOVEM   B,1(TB)
1617         JRST    CONTIN
1618
1619 MFUNCTION GO,SUBR
1620         ENTRY   1
1621         PUSHJ   P,PROGCH        ;CHECK FOR A PROG
1622         PUSH    TP,A            ;SAVE
1623         PUSH    TP,B
1624         MOVE    A,(AB)
1625         CAME    A,$TATOM
1626         JRST    NLCLGO
1627         PUSH    TP,A
1628         PUSH    TP,1(AB)
1629         MOVE    B,TPSAV(B)      ;GET SAVED TOP OF STACK
1630         PUSH    TP,-1(B)
1631         PUSH    TP,(B)
1632         MCALL   2,MEMQ          ;DOES IT HAVE THIS TAG?
1633         JUMPE   B,NXTAG         ;NO -- ERROR
1634 FNDGO:  MOVE    TB,(TP)         ;RE-GOBBLE
1635         SUB     TP,[2,,2]       ;POP TP
1636         MOVEM   B,1(TB)
1637         JRST    GODON
1638
1639 NLCLGO: CAME    A,$TTAG         ;CHECK TYPE
1640         JRST    WTYP
1641         MOVE    A,1(AB)         ;GET ARG
1642         HRR     B,3(A)
1643         HLL     B,OTBSAV(B)
1644         HRRZ    C,B
1645         CAIG    C,1(TP)
1646         CAME    B,3(A)          ;CHECK TIME
1647         JRST    ILLFRA
1648         HLRZ    C,FSAV(C)
1649         CAIE    C,TENTRY
1650         JRST    ILLFRA
1651         HRR     TB,3(A)         ;GET NEW FRAME PTR
1652         MOVE    A,1(A)          ;GET PLACE TO START
1653         MOVEM   A,1(TB)         ;CLOBBER IT AWAY
1654 GODON:  MOVE    A,(AB)
1655         MOVE    B,1(AB)
1656         JRST    CONTIN
1657
1658 \f
1659
1660
1661 MFUNCTION TAG,SUBR
1662         ENTRY   1
1663         HLRZ    A,(AB)          ;GET TYPE OF ARGUMENT
1664         CAIE    A,TATOM         ;CHECK THAT IT IS AN ATOM
1665         JRST    WTYP
1666         PUSHJ   P,PROGCH        ;CHECK PROG
1667         PUSH    TP,A            ;SAVE VAL
1668         PUSH    TP,B
1669         MOVE    A,TPSAV(B)      ;GET STACK TOP
1670         PUSH    TP,0(AB)
1671         PUSH    TP,1(AB)
1672         PUSH    TP,-1(A)
1673         PUSH    TP,(A)
1674         MCALL   2,MEMQ
1675         JUMPE   B,NXTAG         ;IF NOT FOUND -- ERROR
1676         MOVEM   A,-1(TP)        ;SAVE PLACE
1677         EXCH    B,(TP)
1678         MOVEI   A,1(PVP)
1679         HLRE    C,PVP
1680         SUB     A,C
1681         HRLI    A,TFRAME
1682         PUSH    TP,A
1683         HLL     B,OTBSAV (B)
1684         PUSH    TP,B
1685         MCALL   2,EVECTOR
1686         MOVSI   A,TTAG
1687         JRST    FINIS
1688
1689 PROGCH: MOVE    B,MQUOTE [LPROG ]INTERR
1690         PUSHJ   P,ILVAL         ;GET VALUE
1691         CAME    A,$TTB          ;CHECK TYPE
1692         JRST    NXPRG
1693         POPJ    P,
1694
1695 MFUNCTION EXIT,SUBR
1696         ENTRY   2
1697         HLRZ    A,(AB)
1698         CAIE    A,TACT
1699         JRST    WTYP
1700         MOVE    A,1(AB)
1701         HRR     B,A
1702         HLL     B,OTBSAV(B)
1703         HRRZ    C,A
1704         CAIG    C,1(TP)
1705         CAME    A,B
1706         JRST    ILLFRA
1707         HLRZ    C,FSAV(C)
1708         CAIE    C,TENTRY
1709         JRST    ILLFRA
1710         HRR     TB,A
1711         MOVE    A,2(AB)
1712         MOVE    B,3(AB)
1713         JRST    FINIS
1714
1715 MFUNCTION COND,FSUBR
1716         ENTRY   1
1717         HLRZ    A,(AB)
1718         CAIE    A,TLIST
1719         JRST    WTYP
1720 CLSLUP: SKIPN   B,1(AB)         ;IS THE CLAUSELIST NIL?
1721         JRST    IFALSE          ;YES -- RETURN NIL
1722         HLRZ    A,(B)           ;NO -- GET TYPE OF CAR
1723         CAIE    A,TLIST         ;IS IT A LIST?
1724         JRST    BADCLS          ;
1725         MOVE    A,1(B)          ;YES -- GET CLAUSE
1726         JUMPE   A,BADCLS
1727         PUSH    TP,(A)          ;EVALUATION OF
1728         HLLZS   (TP)
1729         PUSH    TP,1(A)         ;THE PREDICATE
1730         JSP     E,CHKARG
1731         MCALL   1,EVAL
1732         CAMN    A,$TFALSE       ;IF THE RESULT IS
1733         JRST    NXTCLS          ;FALSE TRY NEXT CLAUSE
1734         MOVE    C,1(AB)         ;IF NOT, GET
1735         MOVE    C,1(C)          ;THE CLAUSE
1736         HRRZ    C,(C)           ;GET ITS REST
1737         JUMPE   C,FINIS         ;IF ONLY A PREDICATE --- RETURN ITS VALUE
1738         PUSH    TP,$TLIST
1739         PUSH    TP,C            ;EVALUATE THE REST OF THE CLAUSE
1740         JRST    DOPROG
1741 NXTCLS: HRRZ    A,@1(AB)        ;SET THE CLAUSLIST
1742         HRRZM   A,1(AB)         ;TO CDR OF THE CLAUSLIST
1743         JRST    CLSLUP
1744
1745 IFALSE:
1746         MOVSI   A,TFALSE        ;RETURN FALSE
1747         MOVEI   B,0
1748         JRST    FINIS
1749
1750
1751 \f
1752
1753 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
1754 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT.  ITS VALUE IS
1755 ; ITS SECOND ARGUMENT.
1756
1757 MFUNCTION SETG,SUBR
1758         ENTRY   2
1759         HLLZ    A,(AB)          ;GET TYPE OF FIRST ARGUMENT
1760         CAME    A,$TATOM        ;CHECK THAT IT IS AN ATOM
1761         JRST    NONATM          ;IF NOT -- ERROR
1762         MOVE    B,1(AB)         ;GET POINTER TO ATOM
1763         PUSHJ   P,IGLOC         ;GET LOCATIVE TO VALUE
1764         CAMN    A,$TUNBOUND     ;IF BOUND
1765         PUSHJ   P,BSETG         ;IF NOT -- BIND IT
1766         MOVE    C,B             ;SAVE PTR
1767         MOVE    A,2(AB)         ;GET SECOND ARGUMENT
1768         MOVE    B,3(AB)         ;INTO THE RETURN POSITION
1769         MOVEM   A,(C)           ;DEPOSIT INTO THE
1770         MOVEM   B,1(C)          ;INDICATED VALUE CELL
1771         JRST    FINIS
1772
1773 BSETG:  HRRZ    A,GLOBASE+1(TVP)
1774         HRRZ    B,GLOBSP+1(TVP)
1775         SUB     B,A
1776         CAIL    B,6
1777         JRST    SETGIT
1778         PUSH    TP,GLOBASE(TVP)
1779         PUSH    TP,GLOBASE+1 (TVP)
1780         PUSH    TP,$TFIX
1781         PUSH    TP,[0]
1782         PUSH    TP,$TFIX
1783         PUSH    TP,[100]
1784         MCALL   3,GROW
1785         MOVEM   A,GLOBASE(TVP)
1786         MOVEM   B,GLOBASE+1(TVP)
1787 SETGIT:
1788         MOVE    B,GLOBSP+1(TVP)
1789         SUB     B,[4,,4]
1790         MOVE    C,(AB)
1791         MOVEM   C,(B)
1792         MOVE    C,1(AB)
1793         MOVEM   C,1(B)
1794         MOVEM   B,GLOBSP+1(TVP)
1795         ADD     B,[2,,2]
1796         MOVSI   A,TLOCI
1797         POPJ    P,
1798
1799 \f
1800
1801
1802 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
1803 ;FIRST ARGUMENT TO THE SECOND ARG.  ITS VALUE IS ITS SECOND ARGUMENT.
1804
1805 MFUNCTION SET,SUBR
1806         ENTRY   2
1807         HLLZ    A,(AB)          ;GET TYPE OF FIRST
1808         CAME    A,$TATOM        ;ARGUMENT --
1809         JRST    WTYP            ;BETTER BE AN ATOM
1810         MOVE    B,1(AB)         ;GET PTR TO IT
1811         PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
1812         CAMN    A,$TUNBOUND     ;BOUND?
1813         PUSHJ   P, BSET         ;BIND IT
1814         MOVE    C,B             ;SAVE PTR
1815         MOVE    A,2(AB)         ;GET SECOND ARG
1816         MOVE    B,3(AB)         ;INTO RETURN VALUE
1817         MOVEM   A,(C)           ;CLOBBER IDENTIFIER
1818         MOVEM   B,1(C)
1819         JRST    FINIS
1820 BSET:
1821         HRRZ    A,TPBASE+1(PVP) ;GET ACTUAL STACK BASE
1822         HRRZ    B,SPBASE+1(PVP) ;AND FIRST BINDING
1823         SUB     B,A             ;ARE THERE 6
1824         CAIL    B,6             ;CELLS AVAILABLE?
1825         JRST    SETIT           ;YES
1826         PUSH    TP,TPBASE(PVP)  ;NO -- GROW THE TP
1827         PUSH    TP,TPBASE+1(PVP)        ;AT THE BASE END
1828         PUSH    TP,$TFIX
1829         PUSH    TP,[0]
1830         PUSH    TP,$TFIX
1831         PUSH    TP,[100]
1832         MCALL   3,GROW
1833         MOVEM   A,TPBASE(PVP)   ;SAVE RESULT
1834         MOVEM   B,TPBASE+1(PVP)
1835 SETIT:  MOVE    B,SPBASE+1(PVP)
1836         MOVEI   A,-6(B)         ;MAKE UP BINDING
1837         HRRM    A,(B)           ;LINK PREVIOUS BIND BLOCK
1838         MOVSI   A,TBIND
1839         MOVEM   A,-6(B)
1840         MOVE    A,1(AB)
1841         MOVEM   A,-5(B)
1842         MOVSI   A,TLOCI
1843         HRR     A,PROCID+1(PVP)
1844         SUB     B,[6,,6]
1845         MOVEM   B,SPBASE+1(PVP)
1846         ADD     B,[2,,2]
1847         POPJ    P,
1848
1849 \f
1850
1851 MFUNCTION NOT,SUBR
1852         ENTRY   1
1853         HLRZ    A,(AB)          ; GET TYPE
1854         CAIE    A,TFALSE        ;IS IT FALSE?
1855         JRST    IFALSE          ;NO -- RETURN FALSE
1856
1857 TRUTH:
1858         MOVSI   A,TATOM         ;RETURN T (VERITAS)
1859         MOVE    B,MQUOTE T
1860         JRST    FINIS
1861
1862 MFUNCTION ANDA,FSUBR,AND
1863         ENTRY   1
1864         HLRZ    A,(AB)
1865         CAIE    A,TLIST
1866         JRST    WTYP            ;IF ARG DOESN'T CHECK OUT
1867         SKIPN   C,1(AB)         ;IF NIL
1868         JRST    TRUTH           ;RETURN TRUTH
1869 ANDLP:
1870         JUMPE   C,FINIS         ;ANY MORE ARGS?
1871         MOVEM   C,1(AB)         ;STORE CRUFT
1872         PUSH    TP,(C)          ;EVALUATE THE
1873         HLLZS   (TP)            ;FIRST REMAINING
1874         PUSH    TP,1(C)         ;ARGUMENT
1875         JSP     E,CHKARG
1876         MCALL   1,EVAL
1877         CAMN    A,$TFALSE
1878         JRST    FINIS           ;IF FALSE -- RETURN
1879         HRRZ    C,@1(AB)        ;GET CDR OF ARGLIST
1880         JRST    ANDLP
1881
1882 MFUNCTION OR,FSUBR
1883         ENTRY   1
1884         HLRZ    A,(AB)
1885         CAIE    A,TLIST         ;CHECK OUT ARGUMENT
1886         JRST    WTYP
1887         MOVE    C,1(AB)         ;PICK IT UP TO ENTER LOOP
1888 ORLP:
1889         JUMPE   C,IFALSE        ;IF NO MORE OPTIONS -- FALSE
1890         MOVEM   C,1(AB)         ;CLOBBER IT AWAY
1891         PUSH    TP,(C)
1892         HLLZS   (TP)
1893         PUSH    TP,1(C)         ;EVALUATE THE FIRST REMAINING
1894         JSP     E,CHKARG
1895         MCALL   1,EVAL          ;ARGUMENT
1896         CAME    A,$TFALSE       ;IF NON-FALSE RETURN
1897         JRST    FINIS
1898         HRRZ    C,@1(AB)        ;IF FALSE -- TRY AGAIN
1899         JRST    ORLP
1900
1901 MFUNCTION FUNCTION,FSUBR
1902         PUSH    TP,(AB)
1903         PUSH    TP,1(AB)
1904         PUSH    TP,$TATOM
1905         PUSH    TP,MQUOTE FUNCTION
1906         MCALL   2,CHTYPE
1907         JRST    FINIS
1908
1909 \f
1910
1911 MFUNCTION CLOSURE,SUBR
1912         ENTRY
1913         SKIPL   A,AB            ;ANY ARGS
1914         JRST    ERRTFA          ;NO -- LOSE
1915         ADD     A,[2,,2]        ;POINT AT IDS
1916         PUSH    TP,$TAB
1917         PUSH    TP,A
1918         PUSH    P,[0]           ;MAKE COUNTER
1919
1920 CLOLP:  SKIPL   A,1(TB)         ;ANY MORE IDS?
1921         JRST    CLODON          ;NO -- LOSE
1922         PUSH    TP,(A)          ;SAVE ID
1923         PUSH    TP,1(A)
1924         PUSH    TP,(A)          ;GET ITS VALUE
1925         PUSH    TP,1(A)
1926         ADD     A,[2,,2]        ;BUMP POINTER
1927         MOVEM   A,1(TB)
1928         AOS     (P)
1929         MCALL   1,VALUE
1930         PUSH    TP,A
1931         PUSH    TP,B
1932         MCALL   2,LIST          ;MAKE PAIR
1933         PUSH    TP,A
1934         PUSH    TP,B
1935         JRST    CLOLP
1936
1937 CLODON: POP     P,A
1938         ACALL   A,LIST          ;MAKE UP LIST
1939         PUSH    TP,(AB)         ;GET FUNCTION
1940         PUSH    TP,1(AB)
1941         PUSH    TP,A
1942         PUSH    TP,B
1943         MCALL   2,LIST          ;MAKE LIST
1944         MOVSI   A,TFUNARG
1945         JRST    FINIS
1946
1947
1948 MFUNCTION FALSE,SUBR
1949         ENTRY
1950         JUMPGE  AB,IFALSE
1951         HLRZ    A,(AB)
1952         CAIE    A,TLIST
1953         JRST    WTYP
1954         MOVSI   A,TFALSE
1955         MOVE    B,1(AB)
1956         JRST    FINIS
1957 \f
1958
1959 ;ERROR COMMENTS FOR EVAL
1960
1961 UNBOU:  PUSH    TP,$TATOM
1962         PUSH    TP,MQUOTE UNBOUND-VARIABLE
1963         JRST    ER1ARG
1964
1965 UNAS:   PUSH    TP,$TATOM
1966         PUSH    TP,MQUOTE UNASSIGNED-VARIABLE
1967         JRST    ER1ARG
1968
1969 TFA:
1970 ERRTFA: PUSH    TP,$TATOM
1971         PUSH    TP,MQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
1972         JRST    CALER1
1973
1974 TMA:
1975 ERRTMA: PUSH    TP,$TATOM
1976         PUSH    TP,MQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
1977         JRST    CALER1
1978
1979 BADENV:
1980         PUSH    TP,$TATOM
1981         PUSH    TP,MQUOTE BAD-ENVIRONMENT
1982         JRST    CALER1
1983
1984 FUNERR:
1985         PUSH    TP,$TATOM
1986         PUSH    TP,MQUOTE BAD-FUNARG
1987         JRST    CALER1
1988
1989 WRONGT:
1990 WTYP:   PUSH    TP,$TATOM
1991         PUSH    TP,MQUOTE WRONG-TYPE
1992         JRST    CALER1
1993
1994 MPD:    PUSH    TP,$TATOM
1995         PUSH    TP,MQUOTE MEANINGLESS-PARAMETER-DECLARATION
1996         JRST    CALER1
1997
1998 NOBODY: PUSH    TP,$TATOM
1999         PUSH    TP,MQUOTE HAS-EMPTY-BODY
2000         JRST    CALER1
2001
2002 BADCLS: PUSH    TP,$TATOM
2003         PUSH    TP,MQUOTE BAD-CLAUSE
2004         JRST    CALER1
2005
2006 NXTAG:  PUSH    TP,$TATOM
2007         PUSH    TP,MQUOTE NON-EXISTENT-TAG
2008         JRST    CALER1
2009
2010 NXPRG:  PUSH    TP,$TATOM
2011         PUSH    TP,MQUOTE NOT-IN-PROG
2012         JRST    CALER1
2013
2014 NAPT:   PUSH    TP,$TATOM
2015         PUSH    TP,MQUOTE NON-APPLICABLE-TYPE
2016         JRST    CALER1
2017
2018 NONEVT: PUSH    TP,$TATOM
2019         PUSH    TP,MQUOTE NON-EVALUATEABLE-TYPE
2020         JRST    CALER1
2021
2022
2023 NONATM: PUSH    TP,$TATOM
2024         PUSH    TP,MQUOTE NON-ATOMIC-ARGUMENT
2025         JRST    CALER1
2026
2027
2028 ILLFRA: PUSH    TP,$TATOM
2029         PUSH    TP,MQUOTE FRAME-NO-LONGER-EXISTS
2030         JRST    CALER1
2031
2032 NOTIMP: PUSH    TP,$TATOM
2033         PUSH    TP,MQUOTE NOT-YEST-IMPLEMENTED
2034         JRST    CALER1
2035
2036 ILLSEG: PUSH    TP,$TATOM
2037         PUSH    TP,MQUOTE ILLEGAL-SEGMENT
2038         JRST    CALER1
2039
2040 ER1ARG: PUSH    TP,(AB)
2041         PUSH    TP,1(AB)
2042         MOVEI   A,2
2043         JRST    CALER
2044 CALER1: MOVEI   A,1
2045 CALER:
2046         HRRZ    C,FSAV(TB)
2047         PUSH    TP,$TATOM
2048         PUSH    TP,@-1(C)
2049         ADDI    A,1
2050         ACALL   A,ERROR
2051         JRST    FINIS
2052
2053 END
2054 ***\f\f\f\ 3\f