--- /dev/null
+TITLE EVAL -- MUDDLE EVALUATOR
+
+RELOCATABLE
+
+; GERALD JAY SUSSMAN, 1971
+; DREW MCDERMOTT, 1972
+
+.GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP
+.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM
+.GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL
+.GLOBAL PDLBUF,MESS,FACTI,ITRUTH,FLFLG,PDLOSS,AGC
+.GLOBAL PGROW,TPGROW,PDLGRO
+
+.INSRT MUDDLE >
+
+ MFUNCTION EVAL,SUBR
+ INTGO
+ HLRZ A,AB ;GET NUMBER OF ARGS
+ CAIE A,-2 ;EXACTLY 1?
+ JRST AEVAL ;EVAL WITH AN ALIST
+NORMEV: HLRZ A,(AB) ;GET TYPE OF ARG
+ CAILE A,NUMPRI ;PRIMITIVE?
+ JRST NONEVT ;NO
+ JRST @EVTYPT(A) ;YES-DISPATCH
+
+SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE
+ MOVE B,1(AB)
+ JRST FINIS ;TO SELF-EG NUMBERS
+
+;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
+
+MFUNCTION VALUE,SUBR
+ JSP E,CHKAT
+ PUSHJ P,IDVAL
+ JRST FINIS
+
+IDVAL: PUSH TP,A
+ PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
+ PUSHJ P,ILVAL ;LOCAL VALUE FINDER
+ CAMN A,$TUNAS
+ JRST UNAS
+ CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED
+ JRST RIDVAL ;DONE - CLEAN UP AND RETURN
+ POP TP,B ;GET ARG BACK
+ POP TP,A
+ PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST UNBOU
+ POPJ P,
+RIDVAL: SUB TP,[2,,2]
+ POPJ P,
+
+;GETS THE LOCAL VALUE OF AN IDENTIFIER
+
+MFUNCTION LVAL,SUBR
+ JSP E,CHKAT
+LVAL2: PUSHJ P,ILVAL
+ CAMN A,$TUNBO
+ JRST UNBOU ;UNBOUND
+ CAMN A,$TUNAS
+ JRST UNAS ;UNASSIGNED
+ JRST FINIS ;OTHER
+
+
+MFUNCTION RLVAL,SUBR
+ JSP E,CHKAT
+ PUSHJ P,ILVAL
+ CAME A,$TUNBO
+ JRST FINIS
+ PUSH TP,(AB) ;IF UNBOUND,
+ PUSH TP,1(AB) ;BIND IT GLOBALLY TO ?()
+ PUSH TP,$TUNAS
+ PUSH TP,[0]
+ MCALL 2,SET
+ JRST FINIS
+
+
+MFUNCTION UNASSP,SUBR,[UNASSIGNED?]
+ JSP E,CHKAT
+ PUSHJ P,ILVAL
+ CAMN A,$TUNBO
+ JRST UNBOU
+ CAME A,$TUNAS
+ JRST IFALSE
+ JRST FINIS
+\f
+; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
+
+MFUNCTION LLOC,SUBR
+ JSP E,CHKAT
+ PUSHJ P,ILOC
+ CAMN A,$TUNBOUND
+ JRST UNBOU
+ MOVSI A,TLOCD
+ HRR A,2(B)
+ JRST FINIS
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
+
+MFUNCTION BOUND,SUBR,[BOUND?]
+ JSP E,CHKAT
+ PUSHJ P,ILVAL
+ CAMN A,$TUNBOUND
+ JUMPE B,IFALSE
+ JRST TRUTH
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
+
+MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
+ JSP E,CHKAT
+ PUSHJ P,ILVAL
+ CAMN A,$TUNBOU
+ JRST UNBOU
+ CAMN A,$TUNAS
+ JRST IFALSE
+ JRST TRUTH
+
+;GETS THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION GVAL,SUBR
+ JSP E,CHKAT
+ PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST UNAS
+ JRST FINIS
+
+;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION GLOC,SUBR
+ JSP E,CHKAT
+ PUSHJ P,IGLOC
+ CAMN A,$TUNBOUND
+ JRST UNAS
+ MOVSI A,TLOCD
+ JRST FINIS
+
+;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
+
+MFUNCTION GASSIG,SUBR,[GASSIGNED?]
+ JSP E,CHKAT
+ PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST IFALSE
+ JRST TRUTH
+
+\f
+
+CHKAT: ENTRY 1
+ HLLZ A,(AB)
+ CAME A,$TATOM
+ JRST NONATM
+ MOVE B,1(AB)
+ JRST 2,(E)
+
+;EVALUATE A FORM. IF CAR IS AN ATOM USE GLOBAL VALUE OVER LOCAL ONE.
+
+EVFORM: SKIPN C,1(AB) ;EMPTY?
+ JRST IFALSE
+ HLLZ A,(C) ;GET CAR TYPE
+ CAME A, $TATOM ;ATOMIC?
+ JRST EV0 ;NO -- CALCULATE IT
+ MOVE B,1(C) ;GET PTR TO ATOM
+ CAMN B,MQUOTE LVAL
+ JRST EVATOM ;".X" EVALUATED QUICKLY
+EVFRM1: PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST LFUN
+ PUSH TP,A
+ PUSH TP,B
+ JRST IAPPLY ;APPLY IT
+EV0: PUSH TP,A ;SET UP CAR OF FORM AND
+ PUSH TP,1(C)
+ JSP E,CHKARG
+ MCALL 1,EVAL ;EVALUATE IT
+ PUSH TP,A ;APPLY THE RESULT
+ PUSH TP,B ;AS A FUNCTION
+ JRST IAPPLY
+
+LFUN: MOVE B,1(AB)
+ PUSH TP,$TATOM
+ PUSH TP,1(B)
+ MCALL 1,VALUE
+ PUSH TP,A
+ PUSH TP,B
+ JRST IAPPLY
+
+;HERE TO EVALUATE AN ATOM
+
+EVATOM: HRRZ D,(C) ;D _ REST OF FORM
+ MOVE A,(D) ;A _ TYPE OF ARG
+ CAME A,$TATOM
+ JRST EVFRM1
+ MOVE B,1(D) ;B _ ATOM POINTER
+ JRST LVAL2 ;SIMULATE .MCALL TO LVAL
+
+;DISPATCH TABLE FOR EVAL
+DISTBL EVTYPT,SELF,[[TLIST,EVLIST],[TFORM,EVFORM],[TVEC,EVECT],[TSEG,ILLSEG],[TUVEC,EUVEC]]
+
+\f;AEVAL DOES RELATIVE EVALUATIONS WITH RESPECT TO
+;AN ENVIRONMENT OR FRAME. A FALSE ENVIRONMENT IS EQUIVALENT TO THE
+;CURRENT ONE.
+
+AEVAL: CAIE A,-4 ;EXACTLY 2 ARGS?
+ JRST WNA ;NO-ERROR
+ HLRZ A,2(AB) ;CHECK THAT WE HAVE AN ENV OR FRAME
+ CAIN A,TENV
+ JRST EWRTNV
+ CAIN A,TFALSE
+ JRST NORMEV ;OR <>
+ CAIE A,TFRAME
+ JRST WTYP
+
+ MOVE A,3(AB) ;A _ FRAME POINTER
+ HRR B,A
+ HLL B,OTBSAV(A) ;CHECK ITS TIME...
+ CAME A,B
+ JRST ILLFRA
+ GETYP C,FSAV(A)
+ CAIE C,TENTRY ;...AND CONTENTS
+ JRST ILLFRA
+
+EWRTFM: MOVE B,SPSAV(A) ;NOW USE THE NITTY-GRITTY
+ CAMN SP,B ;NAMELY, THE FRAME'S ACCESS ENVIRONMENT
+ JRST NORMEV ;UNLESS IT ISN'T NEW
+ PUSH TP,2(AB) ;NOW SIMULATE AN EWRTNV ON A TENV
+ PUSH TP,A
+ MOVSI A,TENV
+ MOVEM A,2(AB)
+ MOVEM B,3(AB)
+ MOVEI C,
+ PUSHJ P,ISPLIC
+ POP TP,3(AB) ;RESTORE WITH FRAME
+ POP TP,2(AB)
+ JRST NORMEV\fMFUNCTION SPLICE,SUBR
+ ENTRY 2 ;<SPLICE CURRENT NEW>
+ GETYP A,2(AB)
+ CAIN A,TFALSE
+ JRST ITRUTH ;IF .NEW = <>, EASY;
+ CAIE A,TENV
+ JRST WTYP ;OTHERWISE,
+ GETYP A,(AB) ;TWO ENVIRONMENTS NEEDED
+ CAIE A,TENV
+ JRST WTYP
+ MOVE A,1(AB) ;.CURRENT = .NEW?
+ CAMN A,3(AB)
+ JRST ITRUTH ;HOPEFULLY
+ PUSH TP,$TSP
+ PUSH TP,SP ;SAVE CURRENT SP
+ AOSN E,PTIME
+ .VALUE [ASCIZ /TIMEOUT/]
+ PUSHJ P,FINDSP ;SP _ A, AMONG OTHER THINGS
+ PUSHJ P,ISPLIC ;SPLICE IT
+ EXCH SP,1(TB) ;RESTORE SP,
+ SKIPN C
+ MOVE SP,1(TB) ;UNLESS SPLICE DONE TO TOP OF SP
+ MOVEM SP,SPSAV(TB) ;SPSAV SLOT CLOBBERED BY FINDSP
+ PUSH TP,$TFIX ;SAVE OLD PROCID
+ PUSH TP,E
+ FPOINT UNSPLI,4 ;SET FAILPOINT
+ JRST IFALSE
+
+;FAIL BACK TO HERE
+
+UNSPLI: MOVE A,1(TB) ;A _ SPLICE VECTOR ADDRESS
+ MOVEM SP,1(TB) ;SAVE SP
+ MOVE E,3(TB) ;E _ OLD PROCID
+ PUSHJ P,FINDSP ;SP _ SPLICE VECTOR
+ MOVEM E,PROCID+1(PVP) ;RESET OLD PROCID
+ MOVE SP,3(SP) ;SP _ REBIND ENVIRONMENT
+ JUMPE C,IFAIL ;IF C = 0, KEEP FAILING
+ MOVEM SP,1(C) ;RECLOBBER ACCESS TO REBIND
+ MOVE SP,1(TB) ;IF NOTHING LOWER, SP _ SAME AS BEFORE
+ JRST IFAIL
+
+
+;SPECIAL CASE FOR EVAL WITH ENVIRONMENT
+
+EWRTNV: CAMN SP,3(AB) ;ALREADY GOT?
+ JRST NORMEV
+ AOSN E,PTIME
+ .VALUE [ASCIZ /TIMEOUT/]
+ MOVEI C,
+ PUSHJ P,ISPLICE
+ JRST NORMEV
+
+;SEARCH FOR A THROUGH ENVIRONMENTS, SETTING SP AS YOU GO
+;CLOBBER ALL PROCID'S OF BOUND ATOMS TO E, AND CLOBBER
+;LOCATIVES IN ALL BIND BLOCKS EXCEPT FOR LAST VECTOR
+
+FINDSP: MOVEI C,
+ SKIPA
+SPLOOP: MOVE SP,1(C)
+ CAMN SP,A ;DONE?
+ POPJ P,
+ SKIPN SP
+ .VALUE [ASCIZ /SPOVERPOP/]
+ JUMPE C,JBVEC2
+
+;CLOBBER ALL LOCATIVES IN LAST BIND VECTOR
+
+BLOOP3: GETYP C,(B)
+ CAIE C,TBIND
+ JRST JBVEC2
+ MOVEI C,TFALSE ;MAKE FALSE LOCATIVE
+ HRLM C,4(B)
+ SETZM 5(B)
+ HRRZ B,(B)
+ JRST BLOOP3
+JBVEC2: HRRZ B,SP ;B _ SP
+ MOVE C,SP ;C _ BIND BLOCK ADDRESS = SP
+BLOOP4: GETYP D,(C) ;SEARCH THROUGH BLOCKS ON THIS VECTOR
+ CAIE D,TBIND
+ JRST SPLOOP ;GOT TO END
+ MOVE D,1(C) ;ALTER PROCID OF BOUND ATOM
+ HRRM E,(D)
+ HRRZ C,(C) ;NEXT BLOCK
+ JRST BLOOP4
+
+;SPLICE 3(AB) INTO SP
+
+ISPLIC: PUSH TP,$TVEC ;SAVE C
+ PUSH TP,C
+ PUSH TP,$TFIX
+ PUSH TP,E ;AND E
+ PUSH TP,$TFIX
+ PUSH TP,[3]
+ MCALL 1,VECTOR ;B _ <VECTOR 3>
+ MOVSI D,TSP
+ MOVEM D,(B)
+ MOVEM D,2(B)
+ MOVE D,3(AB)
+ MOVEM D,1(B) ;<PUT .B 1 <3 .AB>>
+ MOVEM SP,3(B) ;<PUT .B 2 .SP>
+ MOVE SP,B ;SP _ B
+ MOVSI D,TFIX
+ MOVEM D,4(SP) ;GET SET TO STORE NEW PROCID
+ MOVE E,(TP) ;E _ NEW PROCID
+ EXCH E,PROCID+1(PVP) ;E _ OLD PROCID
+ MOVEM E,5(SP) ;SAVE OLD PROCID IN BIND VECTOR
+ SUB TP,[4,,4]
+ SKIPE C,2(TP) ;RECOVER C
+ MOVEM SP,1(C) ;COMPLETE SPLICE
+ POPJ P,\fMFUNCTION APPLY,SUBR
+ ENTRY 2
+ MOVE A,(AB) ;SAVE FUNCTION
+ PUSH TP,A
+ MOVE B,1(AB)
+ PUSH TP,B
+ GETYP A,2(AB) ;AND ARG LIST
+ CAIE A,TLIST
+ JRST WTYP ;WHICH SHOULD BE LIST
+ PUSH TP,$TLIST
+ MOVE B,3(AB)
+ PUSH TP,B
+ MOVEI 0,
+ PUSH P,[0] ;"UNEVAL" MARKER
+ JRST IAPPL1
+
+IAPPLY: MOVSI A,TLIST
+ PUSH TP,A
+ HRRZ B,@1(AB)
+ PUSH TP,B
+ HRRZ 0,1(AB) ;0 _ CALL
+ PUSH P,[-1] ;"EVAL" MARKER
+IAPPL1: GETYP A,(TB)
+ CAIN A,TEXPR ;EXPR?
+ JRST APEXPR ;YES
+ CAIN A,TSUBR ;NO -- SUBR?
+ JRST APSUBR ;YES
+ CAIN A,TFSUBR ;NO -- FSUBR?
+ JRST APFSUBR ;YES
+ CAIN A,TFIX ;NO -- CALL TO NTH?
+ JRST APNUM ;YES
+ CAIN A,TACT ;NO -- ACTIVATION?
+ JRST APACT ;YES
+ CAIN A,TFUNARG ;NO -- FUNARG?
+ JRST APFUNARG ;YES
+ CAIN A,TPVP ;NO -- PROCESS TO BE RESUMED?
+ JRST NOTIMP ;YES
+ JRST NAPT ;NONE OF THE ABOVE
+
+
+;APFSUBR CALLS FSUBRS
+
+APFSUBR:
+ MCALL 1,@1(TB)
+ JRST FINIS
+
+;APSUBR CALLS SUBRS
+
+APSUBR:
+ PUSH P,[0] ;MAKE SLOT FOR ARGCNT
+TUPLUP:
+ SKIPN A,3(TB) ;IS IT NIL?
+ JRST MAKPTR ;YES -- DONE
+ PUSH TP,(A) ;NO -- GET CAR OF THE
+ HLLZS (TP) ;ARGLIST
+ PUSH TP,1(A)
+ JSP E,CHKARG
+ SKIPN -1(P) ;EVAL?
+ JRST BUMP ;NO
+ MCALL 1,EVAL ;AND EVAL IT.
+ PUSH TP,A ;SAVE THE RESULT IN
+ PUSH TP,B ;THE GROWING TUPLE
+BUMP: AOS (P) ;BUMP THE ARGCNT
+ HRRZ A,@3(TB) ;SET THE ARGLIST TO
+ MOVEM A,3(TB) ;CDR OF THE ARGLIST
+ JRST TUPLUP
+MAKPTR:
+ POP P,A
+ ACALL A,@1(TB)
+ JRST FINIS
+
+;APACT INTERPRETS ACTIVATIONS AS CALLS TO FUNCTION EXIT
+
+APACT: MOVE A,(TP) ;A _ ARGLIST
+ JUMPE A,TFA
+ GETYP B,(A) ;SETUP SECOND ARGUMENT
+ HRLZM B,-1(TP)
+ MOVE B,1(A)
+ MOVEM B,(TP)
+ HRRZ A,(A) ;MAKE SURE ONLY ONE
+ JUMPN A,TMA
+ JSP E,CHKARG
+ SKIPN (P) ;IF ARGUMENT AS YET UNEVALED,
+ MCALL 2,EXIT
+ MCALL 1,EVAL ;EVAL IT
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,EXIT ;AND EXIT GIVEN ACTIVATION\f
+
+;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
+
+APNUM:
+ MOVE A,(TP) ;GET ARLIST
+ JUMPE A,ERRTFA ;NO ARGUMENT
+ PUSH TP,(A) ;GET CAR OF ARGL
+ HLLZS (TP)
+ PUSH TP,1(A)
+ HRRZ A,(A) ;MAKE SURE ONLY ONE ARG
+ JUMPN A,ERRTMA
+ JSP E,CHKARG ;HACK DEFERRED
+ SKIPN (P) ;EVAL?
+ JRST DONTH
+ MCALL 1,EVAL ;YES
+ PUSH TP,A
+ PUSH TP,B
+DONTH: PUSH TP,(TB)
+ PUSH TP,1(TB)
+ MCALL 2,NTH
+ JRST FINIS
+
+;APEXPR APPLIES EXPRS
+;EXPRESSION IS IN 0(AB), FUNCTION IS IN 0(TB)
+
+APEXP2: HRRZ 0,1(AB)
+ PUSH P,[ARGEV]
+
+APEXPR:
+
+ SKIPN C,1(TB) ;BODY?
+ JRST NOBODY ;NO, ERROR
+ MOVE D,(TP) ;D _ ARG LIST
+ SETZM (TP) ;ZERO (TP) FOR BODY
+ PUSHJ P,BINDAP ;DO THE BINDINGS
+
+APEXP1: HRRZ C,1(TB) ;GET BODY BACK
+ TRNE A,H ;SKIP IF NO HEWITT ATOM
+ HRRZ C,(C) ;ELSE CDR AGAIN
+ MOVEM C,3(TB)
+ JRST STPROG
+
+;MAKE SURE ARGUMENT PUSHED ON STACK IS NOT OF TYPE DEFER
+;(CLOBBERS A AND E)
+
+CHKARG: GETYP A,-1(TP)
+ CAIE A,TDEFER
+ JRST (E)
+ HRRZS (TP) ;MAKE SURE INDIRECT WINS
+ MOVE A,@(TP)
+ MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT
+ MOVE A,(TP) ;NOW GET POINTER
+ MOVE A,1(A) ;GET VALUE
+ MOVEM A,(TP) ;CLOBBER IN
+ JRST (E)
+\f;LIST EVALUATOR
+
+EVLIST: PUSHJ P,PSHRG1 ;EVALUATE EVERYTHING
+ PUSH P,C ;SAVE COUNTER
+EVLIS1: JUMPE C,EVLDON ;IF C=0, DONE
+ PUSH TP,A ;ELSE, CONS
+ PUSH TP,B
+ MCALL 2,CONS ;(A,B) _ ((TP) !(A,B))
+ SOS C,(P) ;DECREMENT COUNTER
+ JRST EVLIS1
+EVLDON: SUB P,[1,,1]
+ JRST FINIS
+
+
+;VECTOR EVALUATOR
+
+EVECT: PUSH P,[0] ;COUNTER
+ GETYPF A,(AB) ;COPY INPUT VECTOR POINTER
+ PUSH TP,A
+ PUSH TP,1(AB)
+
+EVCT2: INTGO
+ SKIPL A,1(TB) ;IF VECTOR EMPTY,
+ JRST MAKVEC ;GO MAKE ITS VALUE
+ GETYPF C,(A) ;C _ TYPE OF NEXT ELEMENT
+ PUSH P,C
+ CAMN C,$TSEG
+ MOVSI C,TFORM ;EVALUATE SEGMENTS LIKE FORMS
+ PUSH TP,C
+ PUSH TP,1(A)
+ ADD A,[2,,2] ;TO NEXT VALUE
+ MOVEM A,1(TB)
+ MCALL 1,EVAL ;(A,B) _ VALUE OF NEXT ELEMENT
+ POP P,C
+ CAME C,$TSEG ;IF SEGMENT,
+ JRST EVCT1
+ PUSHJ P,PSHSEG ;PUSH ITS ELEMENTS
+ JRST EVCT2
+EVCT1: PUSH TP,A ;ELSE PUSH IT
+ PUSH TP,B
+ AOS (P) ;BUMP COUNTER
+ JRST EVCT2
+
+MAKVEC: POP P,A ;A _ COUNTER
+ .ACALL A,EVECTOR ;CALL VECTOR CONSTRUCTOR
+ JRST FINIS ;QUIT
+
+
+;UNIFORM VECTOR EVALUATOR
+
+EUVEC: GETYPF A,(AB) ;COPY INPUT VECTOR POINTER
+ PUSH TP,A
+ PUSH TP,1(AB)
+ HLRE C,1(TB) ;C _ - NO. OF WORDS: TO DOPE WORD
+ HRRZ A,1(TB)
+ SUBM A,C ;C _ ADDRESS OF DOPE WORD
+ GETYPF A,(C)
+ PUSH P,A ;-1(P) _ TYPE OF UVECTOR
+ PUSH P,[0] ;0(P) _ COUNTER
+EUVCT2: INTGO
+ SKIPL A,1(TB) ;IF VECTOR EMPTY,
+ JRST MAKUVC ;GO MAKE ITS VALUE
+ MOVE C,-1(P) ;C _ TYPE
+ CAMN C,$TSEG
+ MOVSI C,TFORM ;EVALUATE SEGMENTS LIKE FORMS
+ PUSH TP,C
+ PUSH TP,(A)
+ ADD A,[1,,1] ;TO NEXT VALUE
+ MOVEM A,1(TB)
+ MCALL 1,EVAL ;(A,B) _ VALUE OF NEXT ELEMENT
+ MOVE C,-1(P)
+ CAME C,$TSEG ;IF SEGMENT,
+ JRST EUVCT1
+ PUSHJ P,PSHSEG ;PUSH ITS ELEMENTS
+ JRST EUVCT2
+EUVCT1: PUSH TP,A ;ELSE PUSH IT
+ PUSH TP,B
+ AOS (P) ;BUMP COUNTER
+ JRST EUVCT2
+
+MAKUVC: POP P,A ;A _ COUNTER
+ .ACALL A,EUVECT ;CALL VECTOR CONSTRUCTOR
+ SUB P,[1,,1] ;FLUSH TYPE
+ JRST FINIS ;QUIT
+\f;ENTRY POINT FOR PUSHING ALL BUT LAST SEGMENT, IF ANY,
+;WHICH IS IN (A,B) INSTEAD OF ON STACK. IF NO LAST SEGMENT
+;(OR IT IS NOT A LIST), (A,B) = () INSTEAD.
+
+PSHSW=-1 ;SWITCH BENEATH COUNTER ON STACK
+CPYLST==1 ;SWITCH ON IFF LAST SEGMENT TO BE COPIED LIKE OTHERS
+
+PSHRG1: PUSH P,[0] ;DON'T COPY LAST SEGMENT
+ JRST PSHRG2
+
+;INTERNAL ARG LIST PUSHER-- ACCEPTS SEGMENTS, LEAVES COUNTER OF
+;THINGS PUSHED IN C
+
+PSHRGL: PUSH P,[1] ;COPY FINAL SEGMENT
+PSHRG2: PUSH P,[0] ;(P) IS A COUNTER
+ GETYPF A,(AB) ;COPY ARGLIST POINTER
+ PUSH TP,A
+ PUSH TP,1(AB)
+
+IEVL2: INTGO
+ SKIPN A,1(TB) ;A _ NEXT LIST CELL ADDRESS
+ JRST ARGSDN ;IF 0, DONE
+ HRRZ B,(A) ;CDR THE ARGS
+ MOVEM B,1(TB)
+ GETYP C,(A) ;C _ TRUE TYPE OF CELL ELEMENT
+ MOVSI C,(C)
+ CAME C,$TDEFER ;DON'T ACCEPT DEFERREDS
+ JRST IEVL3
+ MOVE A,1(A)
+ MOVE C,(A)
+IEVL3: PUSH P,C ;SAVE TYPE
+ CAMN C,$TSEG ;IF SEGMENT
+ MOVSI C,TFORM ;EVALUATE IT LIKE A FORM
+ PUSH TP,C
+ PUSH TP,1(A)
+ MCALL 1,EVAL ;(A,B) _ VALUE OF NEXT ELEMENT
+ POP P,C
+ CAME C,$TSEG ;IF SEGMENT,
+ JRST IEVL4
+ CAMN A,$TLIST ;THAT TURNED OUT TO BE A LIST,
+ SKIPE 1(TB) ;CHECK IF LAST
+ JRST IEVL1 ;IF NOT, COPY IT
+ MOVE 0,PSHSW(P) ;IF SO, AND "COPY LAST"
+ TRNN 0,CPYLST ; SWITCH IS OFF
+ JRST IEVL5 ;DON'T COPY
+IEVL1: PUSHJ P,PSHSEG ;PUSH SEGMENT'S ELEMENTS
+ JRST IEVL2
+IEVL4: PUSH TP,A ;ELSE PUSH IT
+ PUSH TP,B
+ AOS (P) ;BUMP COUNTER
+ JRST IEVL2
+
+ARGSDN: MOVE B,PSHSW(P) ;B _ SWITCH WORD
+ TRNN B,CPYLST ;IF COPY LAST SWITCH OFF,
+ MOVSI A,TLIST ; (A,B) _ ()
+IEVL5: POP P,C ;C _ FINAL COUNT
+ SUB P,[1,,1] ;PITCH SWITCH WORD
+ POPJ P,\f;THIS FUNCTION PUSHES THE ELEMENTS OF THE STRUCTURE (A,B) ONTO
+;TP; (P) = RETURN ADDRESS; -1(P) = COUNTER (SET UP BY CALLER)
+
+PSHSEG: MOVEM A,BSTO(PVP) ;TYPE FOR AGC
+ GETYP A,A
+ PUSHJ P,SAT ;A _ PRIMITIVE TYPE OF (A,B)
+ CAIN A,S2WORD ;LIST?
+ JRST PSHLST ;YES-- DO IT!
+ HLRE C,B ;MUST BE SOME KIND OF VECTOR OR TUPLE
+ MOVNS C ;C _ NUMBER OF WORDS TO DOPE WORD
+ CAIN A,SNWORD ;UVECTOR?
+ JRST PSHUVC ;YES-- DO IT!!
+ ASH C,-1 ;NO-- C _ C/2 = NUMBER OF ELEMENTS
+ ADDM C,-1(P) ;BUMP COUNTER
+ CAIN A,S2NWORD ;VECTOR?
+ JRST PSHVEC ;YES-- DO IT!!!
+ CAIE A,SARGS ;ARGS TUPLE?
+ JRST ILLSEG ;NO-- DO IT!!!!
+ PUSH TP,BSTO(PVP) ;YES-- CHECK FOR LEGALITY
+ PUSH TP,B
+ SETZM BSTO(PVP)
+ MOVEI B,-1(TP) ;B _ ARGS POINTER ADDRESS
+ PUSHJ P,CHARGS ;CHECK IT OUT
+ POP TP,B ;RESTORE WORLD
+ POP TP,BSTO(PVP)
+
+PSHVEC: INTGO
+ JUMPGE B,SEGDON ;IF B = [], QUIT
+ PUSH TP,(B) ;PUSH NEXT ELEMENT
+ PUSH TP,1(B)
+ ADD B,[2,,2] ;B _ <REST .B>
+ JRST PSHVEC
+
+PSHUVC: ADDM C,-1(P) ;BUMP COUNTER
+ ADDM B,C ;C _ DOPE WORD ADDRESS
+ GETYP A,(C) ;A _ UVECTOR ELEMENTS TYPE
+ MOVSI A,(A)
+PSHUV1: INTGO
+ JUMPGE B,SEGDON ;IF B = ![], QUIT
+ PUSH TP,A ;PUSH NEXT ELEMENT WITH TYPE
+ PUSH TP,(B)
+ ADD B,[1,,1] ;B _ <REST .B>
+ JRST PSHUV1
+
+PSHLST: INTGO
+ JUMPE B,SEGDON ;IF B = (), QUIT
+ GETYP A,(B)
+ MOVSI A,(A) ;PUSH NEXT ELEMENT
+ PUSH TP,A
+ PUSH TP,1(B)
+ JSP E,CHKARG ;KILL TDEFERS
+ AOS -1(P) ;COUNT ELEMENT
+ HRRZ B,(B) ;CDR LIST
+ JRST PSHLST
+
+SEGDON: SETZM BSTO(PVP) ;FIX TYPE
+ POPJ P,\f;THESE THREE CONSTRUCTOR FUNCTIONS ARE USED
+;TO SIMULATE "VARIABLE BRACKETS"; FOR EXAMPLE, <CONSV ...>
+;MEANS [...].
+
+;LIST CONSTRUCTOR
+
+MFUNCTION CONSL,FSUBR
+ JRST EVLIST ;DEGENERATE CASE
+
+;VECTOR CONSTRUCTOR
+
+MFUNCTION CONSV,FSUBR
+ PUSHJ P,PSHRGL ;EVALUATE ARGS
+ .ACALL C,EVECTOR ;AND CALL EVECTOR ON THEM
+ JRST FINIS
+
+;UVECTOR CONSTRUCTOR
+
+MFUNCTION CONSU,FSUBR
+ PUSHJ P,PSHRGL ;VERY SIMILAR
+ .ACALL C,EUVECT ;BUT CALL EUVECT INSTEAD
+ JRST FINIS\f
+
+;APFUNARG APPLIES OBJECTS OF TYPE FUNARG
+
+APFUNARG:
+ HRRZ A,@1(TB) ;GET CDR OF FUNARG
+ JUMPE A,FUNERR ;NON -- NIL
+ HLRZ B,(A) ;GET TYPE OF CADR
+ CAIE B,TLIST ;BETTR BE LIST
+ JRST FUNERR
+ PUSH TP,$TLIST ;SAVE IT UP
+ PUSH TP,1(A)
+FUNLP:
+ INTGO
+ SKIPN A,3(TB) ;ANY MORE
+ JRST DOF ;NO -- APPLY IT
+ HRRZ B,(A)
+ MOVEM B,3(TB)
+ HLRZ C,(A)
+ CAIE C,TLIST
+ JRST FUNERR
+ HRRZ A,1(A)
+ HLRZ C,(A) ;GET FIRST VAR
+ CAIE C,TATOM ;MAKE SURE IT IS ATOMIC
+ JRST FUNERR
+ PUSH TP,BNDA ;SET IT UP
+ PUSH TP,1(A)
+ HRRZ A,(A)
+ PUSH TP,(A) ;SET IT UP
+ PUSH TP,1(A)
+ JSP E,CHKARG
+\r PUSH TP,[0]
+ PUSH TP,[0]
+ JRST FUNLP
+DOF:
+ PUSHJ P,SPECBIND ;BIND THEM
+ MOVE A,1(TB) ;GET GOODIE
+ HLLZ B,(A)
+ PUSH TP,B
+ PUSH TP,1(A)
+ HRRZ A,3(TB) ;A _ ARG LIST
+ PUSH TP,$TLIST
+ PUSH TP,A
+ MCALL 2,CONS
+ PUSH TP,$TFORM
+ PUSH TP,B
+ MCALL 1,EVAL
+ JRST FINIS
+\f
+
+;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT
+;IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,
+; IT IS CALLED BY PUSHJ P,ILOC. IT CLOBBERS A, B, C, & 0
+
+ILOC: MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
+ HRR A,PROCID+1(PVP) ;FOR THE CURRENT PROCESS
+ CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
+ JRST SCHSP ;NO -- SEARCH THE LOCAL BINDINGS
+ MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
+ POPJ P, ;FROM THE VALUE CELL
+
+SCHSP: PUSH P,0 ;SAVE 0
+ MOVE C,SP ;GET TOP OF BINDINGS
+SCHLP: JUMPE C,NPOPJ ;IF NO MORE, LOSE
+SCHLP1: GETYP 0,(C)
+ CAIN 0,TSP ;INDIRECT LINK TO NEXT BIND BLOCK?
+ JRST NXVEC2
+ CAMN B,1(C) ;FOUND ATOM?
+ JRST SCHFND
+ HRR C,(C) ;FOLLOW CHAIN
+ SUB C,[6,,0]
+ JRST SCHLP
+NXVEC2: MOVE C,1(C) ;GET NEXT BLOCK
+ JRST SCHLP
+
+SCHFND: EXCH B,C ;SAVE THE ATOM PTR IN C
+ ADD B,[2,,2] ;MAKE UP THE LOCATIVE
+
+ MOVEM A,(C) ;CLOBBER IT AWAY INTO THE
+ MOVEM B,1(C) ;ATOM'S VALUE CELL
+SCHPOP: POP P,0 ;RESTORE 0
+ POPJ P,
+
+NPOPJ: POP P,0 ;RESTORE 0
+UNPOPJ: MOVSI A,TUNBOUND
+ MOVEI B,0
+ POPJ P,0
+
+;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
+;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY
+;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
+
+\rIGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO
+ CAME A,(B) ;A PROCESS #0 VALUE?
+ JRST SCHGSP ;NO -- SEARCH
+ MOVE B,1(B) ;YES -- GET VALUE CELL
+ POPJ P,
+
+SCHGSP: MOVE D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR
+
+SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE
+ CAMN B,1(D) ;ARE WE FOUND?
+ JRST GLOCFOUND ;YES
+ ADD D,[4,,4] ;NO -- TRY NEXT
+ JRST SCHG1
+
+GLOCFOUND: EXCH B,D ;SAVE ATOM PTR
+ ADD B,[2,,2] ;MAKE LOCATIVE
+ MOVEM A,(D) ;CLOBBER IT AWAY
+ MOVEM B,1(D)
+ POPJ P,
+
+
+\f
+
+;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
+;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
+;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL
+
+ILVAL:
+ PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
+CHVAL: CAMN A,$TUNBOUND ;BOUND
+ POPJ P, ;NO -- RETURN
+ MOVE A,(B) ;GET THE TYPE OF THE VALUE
+ MOVE B,1(B) ;GET DATUM
+ POPJ P,
+
+;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
+
+IGVAL: PUSHJ P,IGLOC
+ JRST CHVAL
+
+
+\fMFUNCTION BIND,FSUBR
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TLIST ;ARG MUST BE LIST
+ JRST WTYP
+ SKIPN C,1(AB) ;C _ BODY
+ JRST TFA ;NON-EMPTY
+ PUSH TP,$TLIST
+ PUSH TP,C
+ PUSH TP,(C) ;EVAL FIRST ELEMENT
+ HLLZS (TP)
+ PUSH TP,1(C)
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ PUSH TP,A
+ PUSH TP,B ;SAVE VALUE
+ GETYP A,A ;WHICH MUST BE LIST
+ PUSHJ P,SAT
+ CAIE A,S2WORD
+ JRST WTYP
+ HRRZ C,-2(TP) ;C _ <REST .C>
+ HRRZ C,(C)
+ JUMPE C,NOBODY ;MUST NOT BE EMPTY
+ PUSH TP,(C) ;EVALUATE FIRST ELEMENT
+ HLLZS (TP)
+ PUSH TP,1(C)
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ SETO D,
+ GETYP A,A
+ CAIN A,TFALSE ;CAN BE #FALSE OR LIST
+ JRST DOBI ;IF <>, AUXILIARY BINDINGS
+ PUSHJ P,SAT
+ CAIE A,S2WORD
+ JRST WTYP
+ MOVEI D,(B) ;D _ DECLARATIONS
+DOBI: POP TP,C ;RESTORE C _ FIRST ARG
+ SUB TP,[1,,1]
+ MOVEI 0, ;NO CALL
+ PUSHJ P,BINDER
+ HRRZ C,1(AB)
+ HRRZ C,(C)
+ HRRZ C,(C) ;C _ <REST <REST .ARG>>
+ JRST BIPROG ;NOW EXECUTE BODY AS PROG\f
+
+;BINDER - THIS SUBROUTINE PROCESSES FUNCTION DECLARATIONS AND BINDS
+; ARGUMENTS AND TEMPORARIES APPROPRIATELY.
+;
+; CALL: PUSHJ P,BINDER OR BINDRR
+;
+; BINDAP - ARGS ARE ON A LIST, EVALED IFF (P) NOT = 0
+;
+; BINDER - ASSUMES ARGS ARE TO BE EVALED
+;
+; BINDRR - RESUME HACK - ARGS ON A LIST TO BE
+; EVALED IN PARENT PROCESS
+;
+
+; C/ POINTS TO FUNCTION BEING HACKED
+; D/ POINTS TO ARG LIST (IF <0, CALLED FROM A PROG)
+; 0/ IF NON-ZERO POINTS TO EXPRESSION GENREATING CALL
+;
+;EVALER IS STORED ON THE STACK P AND USED TO EVALUATE ARGS WHEN NEEDED
+EVALER==-1
+
+;SWTCHS,STORED ON THE STACK, HOLDS MANY SWITCHES:
+SWTCHS==0
+
+OPT==1 ;ON IFF ARGUMENTS MAY BE OMITTED
+QUO==2 ;ON IFF ARGUMENT IS TO BE QUOTED
+AUX==4 ;ON IFF BINDING "AUX" VARS
+H==10 ;ON IFF THERE EXISTS A HEWITT ATOM
+DEF==20 ;ON IFF DEFAULT VALUE OF AN ARG HAS BEEN TAKEN
+
+
+BINDAP: MOVE A,[ARGNEV]
+ SKIPE -1(P)
+ MOVE A,[ARGEV]
+ POP P,-1(P) ;FLUSH EVAL MARKER
+ PUSH P,A
+ JRST BIND1
+BINDER: PUSH P,[ARGEV]
+ JRST BIND1
+BINDRR: PUSH P,[NOTIMP]
+BIND1: PUSH P,[0] ;OPT _ QUO _ AUX _ H _ OFF
+ PUSH P,0 ;SAVE CALL, IF ANY
+ PUSHJ P,BNDVEC ;E _ TOP OF BINDING STACK
+ GETYP A,(C)
+ CAIE A,TATOM ;HEWITT ATOM?
+ JRST BIND2
+ HLRE A,E
+ HRRZ B,E
+ SUB B,A ;B _ FIRST DOPE WORD OF E
+ MOVSI A,TBIND
+ MOVEM A,-6(B) ;BUILD BIND BLOCK FOR ATOM
+ MOVE A,1(C) ;A _ HEWITT ATOM
+ MOVEM A,-5(B)
+ MOVE A,TB
+ HLL A,OTBSAV(TB) ;A _ POINTER TO THIS ACTIVATION
+ MOVEM A,-3(B)
+ MOVEI 0,(PVP)
+ HLRE A,PVP
+ SUBI 0,-1(A) ;0 _ PROCESS VEC DOPE WORD
+ HRLI 0,TACT ;0 IS FIRST WORD OF ACT VALUE
+ MOVEM 0,-4(B) ;STORED IN BIND BLOCK
+ HRRZ C,(C) ;CDR THE FUNCTION
+BIND2: POP P,0 ;0 _ CALLING EXPRESSION
+ PUSHJ P,CARLST ;C _ DECLS LIST
+ JRST BINDC ;IF (), QUIT
+ JUMPL D,AUXDO ;IN CASE OF PROG
+ MOVEI A,(C)
+ PUSHJ P,NXTDCL ;B _ NEXT STRING
+ JRST BINDRG ;ATOM INSTEAD
+ HRRZ C,(C) ;CDR DECLS
+
+
+;CHECK FOR "BIND"
+
+ CAME B,[ASCII /BIND/ ]
+ JRST CHCALL
+ JUMPE C,MPD ;GOT "BIND", NOW...
+ PUSHJ P,CARATE ;GET ATOM & START BIND BLOCK
+ HRLZI A,TENV
+ MOVE B,1(SP) ;B _ ENV BEFORE BNDVEC
+ PUSHJ P,PSHBND ;FINISH BIND BLOCK
+ HRRZ C,(C)
+ JUMPE C,BINDC ;MAY BE DONE
+ MOVEI A,(C)
+ PUSHJ P,NXTDCL ;NEXT ONE
+ JRST BINDRG ;ATOM INSTEAD
+ HRRZ C,(C) ;CDR DECLS
+
+;CHECK FOR "CALL"
+
+CHCALL: CAME B,[ASCII /CALL/ ]
+ JRST CHOPTI ;GO INTO MAIN BINDING LOOP
+ JUMPE 0,MPD ;GOT "CALL", SO 0 MUST BE CALL
+ JUMPE C,MPD
+ PUSHJ P,CARATE ;GET ATOM & START BIND BLOCK\f MOVE B,0 ;B _ CALL
+ MOVSI A,TLIST
+ PUSHJ P,PSHBND ;MAKE BIND BLOCK
+ HRRZ C,(C) ;CDR PAST "CALL" ATOM
+ JUMPE C,BINDC ;IF DONE, QUIT
+
+;DECLLP IS THE MAIN BINDING LOOP FOR HANDLING FUNCTIONAL ARGUMENTS AND
+;THE STRINGS SCATTERED THEREIN
+
+DECLLP: MOVEI A,(C)
+ PUSHJ P,NXTDCL ;NEXT STRING...
+ JRST BINDRG ;...UNLESS SOMETHING ELSE
+ HRRZ C,(C) ;CDR DECLARATIONS
+CHOPTI: TRZ B,1 ;GOD KNOWS WHY TRZ B,1 (SOMETHING TO DO WITH OPTIO)
+
+;CHECK FOR "OPTIONAL"
+
+ CAME B,[ASCII /OPTIO/]
+ JRST CHREST
+ MOVE 0,SWTCHS(P) ;OPT _ ON
+ TRO 0,OPT
+ MOVEM 0,SWTCHS(P)
+ JUMPE C,BINDC
+ PUSHJ P,EBINDS ;BIND ALL PREVIOUS ARGUMENTS
+ JRST DECLLP
+
+;CHECK FOR "REST"
+
+CHREST: MOVE 0,SWTCHS(P) ;0 _ SWITCHES
+ TRZ 0,OPT ;OPT _ OFF
+ MOVEM 0,SWTCHS(P)
+ MOVEI A,(C)
+ CAME B,[ASCII /REST/]
+ JRST CHTUPL
+ PUSHJ P,NXTDCL ;GOT "REST"-- LOOK AT NEXT THING
+ SKIPN C
+ JRST MPD ;WHICH CAN'T BE STRING
+ PUSHJ P,BINDB ;GET NEXT ATOM
+ TRNE 0,QUO ;QUOTED?
+ JRST ARGSDO ;YES-- JUST USE ARGS
+ JRST TUPLDO
+
+;CHECK FOR "TUPLE"
+
+CHTUPL: CAME B,[ASCII /TUPLE/]
+ JRST CHARG
+ PUSHJ P,NXTDCL ;GOT "TUPLE"-- LOOK AT NEXT THING
+ SKIPN C
+ JRST MPD
+ PUSHJ P,CARATE ;WHICH BETTER BE ATOM
+
+TUPLDO: PUSH TP,$TLIST ;SAVE STUFF
+ PUSH TP,C
+ PUSH TP,$TVEC
+ PUSH TP,E
+ PUSH P,[0] ;ARG COUNTER\f;THIS LOOP BUILDS A TUPLE ON THE STACK, ON THE TOP OF THE ENTITIES
+;JUST SAVED-- DON'T WORRY; THEY'RE SAFE
+
+TUPLP: JUMPE D,TUPDON ;IF NO MORE ARGS, DONE
+ INTGO ;WATCH OUT FOR BIG TUPLES AND SMALL STACKS
+ PUSH TP,$TLIST ;SAVE D
+ PUSH TP,D
+ GETYP A,(D) ;GET NEXT ARG
+ MOVSI A,(A)
+ PUSH TP,A ;EVAL IT
+ PUSH TP,1(D)
+ TRZ 0,DEF ;OFF DEFAULT
+ PUSHJ P,@EVALER-1(P)
+ POP TP,D ;RESTORE D
+ SUB TP,[1,,1]
+ PUSH TP,A ;BUILD TUPLE
+ PUSH TP,B
+ SOS (P) ;COUNT ELEMENTS
+ HRRZ D,(D) ;CDR THE ARGS
+ JRST TUPLP
+TUPDON: PUSHJ P,MRKTUP ;MAKE A TUPLE OF (P) ENTRIES
+ SUB P,[1,,1] ;FLUSH COUNTER
+ JRST BNDRST\f;CHECK FOR "ARGS"
+
+CHARG: CAME B,[ASCII /ARGS/]
+ JRST CHAUX
+ PUSHJ P,NXTDCL ;GOT "ARGS"-- CHECK NEXT THING
+ SKIPN C
+ JRST MPD
+ PUSHJ P,CARATE ;WHICH MUST BE ATOM
+
+;HERE TO BIND AN ATOM TO THE REMAINING ARGS, UNEVALUATED
+
+ARGSDO: MOVSI A,TLIST ;(A,B) _ CURRENT ARGS LEFT
+ MOVE B,D
+ MOVEI D,
+
+;BNDRST COMPLETES THE BIND BLOCK FOR BOTH TUPLES AND ARGS
+
+BNDRST: PUSHJ P,PSHBND
+ HRRZ C,(C) ;CDR THE DECLS
+ JUMPE C,BINDC
+ MOVEI A,(C)
+ PUSHJ P,NXTDCL ;WHAT NEXT?
+ JRST MPD ;MUST BE A STRING OR ELSE
+ HRRZ C,(C) ;CDR DECLS
+
+;CHECK FOR "AUX"
+
+CHAUX: CAME B,[ASCII /AUX/]
+ JRST CHACT
+ JUMPG D,TMA ;ARGS MUST BE USED UP BY NOW
+ PUSH P,C ;SAVE C ON P (NO GC POSSIBLE)
+ PUSHJ P,EBIND ;BIND ALL ARG ATOMS
+ POP P,C ;RESTORE C
+
+;HERE FOR AUXIES OF "AUX" OR PROG VARIETY
+
+AUXDO: MOVE 0,SWTCHS(P)
+ TRO 0,AUX\OPT\DEF ;OPTIONALS OBVIOUSLY ALLOWED
+ MOVEM 0,SWTCHS(P)
+AUXLP: JUMPE C,BNDHAT ;IF NO MORE, QUIT
+ MOVEI A,(C)
+ PUSHJ P,NXTDCL ;GET NEXT DECLARATION STRING
+ JRST AUXIE ;INSTEAD, ANOTHER AUXIE-- DO IT
+ HRRZ C,(C) ;CDR PAST STRING
+ JRST CHACT1 ;...WHICH MUST BE "ACT"
+
+;NORMAL AUXILIARY DECLARATION HANDLER
+
+AUXIE: MOVE 0,SWTCHS(P)
+ PUSH TP,$TLIST ;SAVE C
+ PUSH TP,C
+ PUSHJ P,BINDB ;PUSH NEXT ATOM ONTO E
+ MOVE A,$TVEC ;SAVE E UNDER DEFAULT VALUE
+ EXCH A,-1(TP)
+ EXCH E,(TP)
+ PUSH TP,A ;(DEFAULT VALUE MUST BE REPUSHED)
+ PUSH TP,E
+ PUSHJ P,@EVALER(P) ;EVAL THE VALUE IT IS TO RECEIVE
+ POP TP,E ;RESTORE E
+ SUB TP,[1,,1]
+ PUSHJ P,PSHBND ;COMPLETE BINDING BLOCK WITH VALUE
+ PUSHJ P,EBIND ;BIND THE ATOM
+ POP TP,C ;RESTORE C
+ SUB TP,[1,,1]
+ HRRZ C,(C) ;CDR THE DECLARATIONS
+ JRST AUXLP
+\f;"ACT" CAN OCCUR ONLY AT THE END, HEWITT ATOMS NOTWITHSTANDING
+
+CHACT1: MOVEI D, ;MAKE IT CLEAR THAT THERE ARE NO ARGS
+CHACT: CAME B,[ASCII /ACT/] ;ONLY THING POSSIBLE
+ JRST MPD
+ JUMPE C,MPD ;BETTER HAVE AN ATOM TO BIND TO ACT
+ PUSHJ P,CARATE ;START BIND BLOCK WITH IT
+ MOVEI A,(PVP)
+ HLRE B,PVP
+ SUBI A,-1(B) ;A _ PROCESS VEC DOPE WORD
+ HRLI A,TACT
+ MOVE B,TB
+ HLL B,OTBSAV(TB) ;(A,B) _ ACTIVATION POINTER
+ PUSHJ P,PSHBND
+ HRRZ C,(C) ;"ACT" MUST HAVE BEEN LAST
+ JUMPN C,MPD
+
+;AT THIS POINT, ALL ENTRIES ARE FINAL AND ALL THINGS LOOSED
+;IN E SHALL BE BOUND IN E, EVENTUALLY
+
+BINDC: JUMPG D,TMA ;ARGS SHOULD BE USED UP BY NOW
+ PUSHJ P,EBIND ;BIND EVERYTHING NOT BOUND
+BNDHAT: MOVE 0,SWTCHS(P) ;EVEN THE HEWITT ATOM
+ TRNN 0,H ;IF THERE IS ONE
+ JRST BNDRET
+ HLRE B,E
+ HRRZI E,(E)
+ SUB E,B ;E _ DOPE WORD OF BINDING VECTOR
+ SUB E,[5,,5] ;E _ POINTER TO HEWITT ATOM SLOT
+ PUSHJ P,COMBLK ;CHAIN THIS BLOCK TO PREVIOUS THING IN VECTOR
+ ADD E,[4,,4] ;E _ LAST WORD OF BINDING VECTOR
+ PUSHJ P,EBIND ;BIND THE HEWITT ATOM
+
+;THIS IS THE WAY OUT OF THE BINDER
+
+BNDRET: POP P,A ;A _ SWITCHES
+ SUB P,[1,,1] ;FLUSH EVALER
+ POPJ P, ;RETURN FROM BINDER\f;TO BIND A PERFECTLY ORDINARY ARGUMENT SPECIFICATION
+;FOUND IN A DECLS LIST, JUMP HERE
+
+BINDRG: MOVE 0,SWTCHS(P)
+ PUSHJ P,BINDB ;GET ATOM IN THE NEXT DECL
+ JUMPE D,CHOPT3 ;IF ARG EXISTS,
+ TRNE 0,OPT
+ SUB TP,[2,,2] ;PITCH ANY DEFAULT THAT MAY EXIST
+ GETYP A,(D) ;(A,B) _ NEXT ARG
+ MOVSI A,(A)
+ MOVE B,1(D)
+ HRRZ D,(D) ;CDR THE ARGS
+ TRZN 0,QUO ;ARG QUOTED?
+ JRST BNDRG1 ;NO-- GO EVAL
+CHDEFR: MOVEM 0,SWTCHS(P)
+ CAME A,$TDEFER ;QUOTED-- PUNT ANY TDEFER'S YOU FIND
+ JRST DCLCDR
+ GETYP A,(B) ;(A,B) _ REAL POINTER, NOT DEFERRED
+ MOVE B,1(B)
+ JRST DCLCDR ;AND FINISH BIND BLOCK
+
+;OPTIONAL ARGUMENT?
+
+CHOPT3: TRNN 0,OPT ;IF NO ARG, BETTER BE OPTIONAL
+ JRST TFA
+ POP TP,B ;(A,B) _ DEFAULT VALUE
+ POP TP,A
+ TRZE 0,QUO ;IF QUOTED,
+ JRST CHDEFR ;JUST PUSH
+ TRO 0,DEF ;ON DEFAULT
+
+;EVALUATE WHATEVER YOU HAVE AT THIS POINT
+
+BNDRG1: PUSH TP,$TLIST ;SAVE STUFF
+ PUSH TP,D
+ PUSH TP,$TLIST
+ PUSH TP,C
+ PUSH TP,$TVEC
+ PUSH TP,E
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,@EVALER(P) ;(A,B) _ <EVAL (A,B)>
+ MOVE E,(TP) ;RESTORE C, D, & E
+ MOVE C,-2(TP)
+ MOVE D,-4(TP)
+ SUB TP,[6,,6]
+ MOVE 0,SWTCHS(P) ;RESTORE 0
+
+
+;FINISH THE BIND BLOCK WITH (A,B) AND GO ON
+
+DCLCDR: PUSHJ P,PSHBND
+ TRNE 0,OPT ;IF OPTIONAL,
+ PUSHJ P,EBINDS ;BIND IT
+ HRRZ C,(C)
+ JUMPE C,BINDC ;IF NO MORE DECLS, QUIT
+ JRST DECLLP\f;THIS ROUTINE CREATES THE BIND VECTOR BINDER USES; IT ALLOCATES
+;THREE SLOTS PER NON-STRING DECLARATION (I.E., ATOM TO BE BOUND),
+;THREE FOR A HEWITT ATOM IF IT FINDS ONE, AND ONE FOR THE ACCESS
+;TYPE-TSP POINTER TO SP.
+
+;IT SETS E TO THE CURRENT TOP OF THE VECTOR; IT FILLS IN
+;ACCESS SLOT WITH SP, AND SETS SP TO POINT TO
+;THE START OF THIS VECTOR. IT MAY SET SWITCH H TO ON, IFF IT FINDS
+;A HEWITT ATOM. IT CLOBBERS A & B, RESTORES C & D, AND LEAVES THE
+;SWITCHES IN 0
+
+;IF BNDVEC FINDS NO DECLARATIONS, IT TAKES THE LIBERTY OF EXITING
+;FROM THE BINDER WITHOUT DISTURBING SP. BNDVEC DOES SOME ERROR
+;CHECKING, BUT NOT ALL, AS IT DOES NOT LOOK AT THE ARGS IN D.
+;THIS EXPLAINS WHY BINDER OMITS SOME.
+
+BNDVEC: PUSH TP,$TLIST ;SAVE C & D
+ PUSH TP,C
+ PUSH TP,$TLIST
+ PUSH TP,D
+ JUMPE C,NOBODY
+ MOVE 0,SWTCHS-2(P) ;UNBURY THE SWITCHES
+ MOVEI D, ;D = COUNTER _ 0
+ GETYP A,(C) ;A _ FIRST THING
+ CAIE A,TATOM ;HEWITT ATOM?
+ JRST NOHATM
+ TRO 0,H ;TURN SWITCH H ON
+ ADDI D,3 ;YES-- SAVE 3 SLOTS FOR IT
+ HRRZ C,(C) ;CDR THE FUNCTION
+ JUMPE C,NOBODY
+NOHATM: PUSHJ P,CARLST ;C _ <1 .C>
+ JRST CNTRET ;IF (), ALL COUNTED
+ MOVEI A,(C) ;A _ DECLS
+
+;HERE IS THE QUICK LOOP THROUGH THE DECLARATIONS
+
+DCNTLP: PUSHJ P,NXTDCL ;SKIP IF NEXT ONE IS A STRING
+DINC: ADDI D,3 ;3 SLOTS FOR AN ATOM
+ HRRZ A,(A) ;GO AROUND AGAIN
+ JUMPN A,DCNTLP
+
+;IF ANYTHING WAS FOUND, INITIALIZE THE VECTOR
+
+CNTRET: JUMPE D,NODCLS ;OTHERWISE, BIND NOTHING
+ AOJ D, ;DON'T FORGET ACCESS SLOT
+ MOVEM 0,SWTCHS-2(P) ;SAVE SWITCHES
+ PUSH TP,$TFIX
+ PUSH TP,D
+ MCALL 1,VECTOR ;B _ <VECTOR .D>
+ MOVE D,(TP) ;RESTORE C & D
+ MOVE C,-2(TP)
+ SUB TP,[4,,4]
+ MOVE E,B ;FROM NOW ON, E _ BIND VECTOR TOP
+ MOVE A,B
+ MOVSI B,TSP
+ MOVEM B,(E) ;FILL ACCESS SLOT
+ PUSH E,SP
+ MOVE SP,A ;SP NOW POINTS THROUGH THIS VECTOR
+ POPJ P,
+
+;IF THERE ARE NO DECLS (E.G. <FUNCTION ()...>), JUST QUIT
+
+NODCLS: MOVE D,(TP) ;RESTORE C & D
+ MOVE C,-2(TP)
+ SUB TP,[4,,4]
+ SUB P,[2,,2] ;PITCH RETURN ADDRESS AND CALL
+ JRST BNDRET\f;THIS ROUTINE CREATES A POINTER TO THE TUPLE RESTING ON TOP OF
+;TP. IT TAKES ITS NEGATIVE LENGTH (IN CELLS) IN (P). IT ASSUMES
+;THERE ARE TWO TEMPORARY CELLS BENEATH IT, AND RESTORES
+;THEM INTO C AND E, MOVING THE TUPLE OVER THE TEMPORARY
+;SLOTS. IT RETURNS A CORRECT TARGS POINTER TO THE TUPLE IN A AND B
+
+MRKTUP: MOVSI A,TTB ;FENCE-POST TUPLE
+ PUSH TP,A
+ PUSH TP,TB
+ MOVEI A,2 ;B_ADDRESS OF INFO CELL
+ PUSHJ P,CELL" ;MAY CALL AGC
+ MOVSI A,TINFO
+ MOVEM A,(B)
+ MOVEI A,(TP) ;GENERATE DOPE WORD POINTER
+ HLRE C,TP
+ SUBI A,-1(C)
+ CAME A,TPGROW" ;ALLOWING FOR BLOWN PDL
+ ADDI A,PDLBUF
+ HRLZI A,-1(A) ;A HAS 1ST DW PTR IN LEFT HALF
+ HLR A,OTBSAV(TB) ;TIME TO RIGHT
+ MOVEM A,1(B) ;TO SECOND WORD OF CELL
+ EXCH B,-1(P) ;B _ - ARG COUNT
+ ASH B,1 ;B _ 2*B
+ HRRM B,-1(TP) ;STORE IN TTB FENCEPOST
+ HRRZI A,-5(TP)
+ ADD A,B ;A _ ADR OF TUPLE
+ HRLI A,(B) ;A _ TUPLE POINTER
+ MOVE B,A ;B, TOO
+ HRLI A,4(A) ;LH A _ CURRENT PLACE OF TUPLE
+ MOVE C,1(A) ;RESTORE C AND E
+ MOVE E,3(A)
+ BLT A,-4(TP) ;MOVE TUPLE OVER OLD C, E COPIES
+ SUB TP,[4,,4]
+ MOVE A,-1(P)
+ HRLI A,TARGS ;A _ FIRST WORD OF ARGS TUPLE VALUE
+ POPJ P,\f;THIS ROUTINE, GIVEN SWTCHS IN 0 AND DECLARATIONS LIST POINTER
+;IN C, PUSHES ATOM IN THE FIRST DECLARATION ONTO E. IT MAY SET
+;SWITCHES OPT AND QUO, AND LEAVES SWITCHES IN 0. IFF OPT = ON,
+;BINDB PUSHES A DEFAULT VALUE (EVEN IF ?()) ONTO TP. A & B ARE
+;CLOBBERED. C IS NOT ALTERED.
+
+BINDB: MOVE A,C ;A _ C
+ GETYP B,(A)
+ CAIE B,TLIST ;A = ((...)...) ?
+ JRST CHOPT1
+ TRNN 0,OPT ;YES-- OPT MUST BE ON
+ JRST MPD
+ MOVEM 0,SWTCHS-1(P) ;SAVE SWITCHES
+ MOVE A,1(A) ;A _ <1 .A> = (...)
+ JUMPE A,MPD ;A = () NOT ALLOWED
+ HRRZ B,(A) ;B _ <REST .A>
+ JUMPE B,MPD ;B = () NOT ALLOWED
+ PUSH TP,(B) ;SAVE <1 .B> AS DEFAULT
+ PUSH TP,1(B) ;VALUE OF ATOM IN A
+ HRRZ B,(B)
+ JUMPN B,MPD ;<REST .B> MUST = ()
+ GETYP B,(A)
+ JRST CHFORM ;GO SEE WHAT <1 .A> IS
+
+CHOPT1: TRNN 0,OPT ;IF OPT = ON
+ JRST CHFORM
+ PUSH TP,$TUNAS ;DEFAULT VALUE IS ?()
+ PUSH TP,[0]
+
+;AT THIS POINT, <1 .A> MUST BE ATOM OR <QUOTE ATOM>
+
+CHFORM: TRNE 0,AUX ;NO QUOTES ALLOWED IN AUXIES
+ JRST CHATOM
+ CAIE B,TFORM
+ JRST CHATOM
+ MOVE A,1(A) ;A _ <1 .A> = <...>
+ JUMPE A,MPD ;A = <> NOT ALLOWED
+ MOVE B,1(A) ;B _ <1 .A>
+ CAME B,MQUOTE QUOTE
+ JRST MPD ;ONLY A = <QUOTE...> ALLOWED
+ TRO 0,QUO ;QUO _ ON
+ MOVEM 0,SWTCHS-1(P)
+ HRRZ A,(A) ;A _ <REST .A>
+ JUMPE A,MPD ;<QUOTE> NOT ALLOWED
+ GETYP B,(A)
+
+;AT THIS POINT WE HAVE THE ATOM OR AN ERROR
+
+CHATOM: CAIE B,TATOM ;<1 .A> MUST BE ATOM
+ JRST MPD
+ MOVE A,1(A) ;A _ THE ATOM!!!
+ JRST PSHATM ;WHICH MUST BE PUSHED ONTO E
+
+
+
+;THE FOLLOWING LITTLE ROUTINE ACCEPTS THE NEXT DECLARATION ONLY
+;IF IT IS ATOMIC, AND PUSHES IT ONTO E
+
+CARATE: GETYP A,(C)
+ CAIE A,TATOM
+ JRST MPD
+ MOVE A,1(C) ;A _ ATOM
+ MOVE 0,SWTCHS-1(P)
+PSHATM: PUSH E,$TBIND ;FILL FIRST TWO SLOTS OF BIND BLOCK
+ PUSH E,A
+
+;EACH BIND BLOCK MUST POINT TO THE PREVIOUS ONE OR TO AN ACCESS
+;POINTER TO ANOTHER VECTOR ALTOGETHER. COMBLK MAKES SURE IT DOES.
+
+COMBLK: GETYP B,-7(E) ;LOOK FOR PREVIOUS BIND
+ CAIE B,TBIND ;IF FOUND, MAKE NORMAL LINK
+ JRST ABNORM
+ MOVEI B,-7(E) ;IN MOST CASES, SEVEN
+MAKLNK: HRRM B,-1(E) ;MAKE THE LINK
+ POPJ P,
+ABNORM: MOVEI B,-3(E)
+ JRST MAKLNK
+\f;THIS ROUTINE COMPLETES A BIND BLOCK BEGUN BY CARATE OR BINDB
+;WITH THE VALUE (A,B)
+
+PSHBND: PUSH E,A
+ PUSH E,B
+ ADD E,[2,,2] ;ASSUME BIND VECTOR IS FULL OF 0'S
+ POPJ P,
+
+;THIS ONE DOES AN EBIND, SAVING C & D:
+
+EBINDS: PUSH P,C ;SAVE C & D (NO DANGER OF GC)
+ PUSH P,D
+ PUSHJ P,EBIND ;BIND ALL NON-OPTIONAL ARGUMENTS
+ POP P,D
+ POP P,C ;RESTORE C & D
+ POPJ P,
+
+
+;THE FOLLOWING RETURNS THE CAR OF C IN C, SKIPPING IF
+;<EMPTY? <1 .C>>, AND ERRING IF <NOT <==? <TYPE <1 .C>> LIST>>
+
+CARLST: GETYP A,(C)
+ CAIE A,TLIST
+ JRST MPD ;NOT A LIST, FATAL
+ SKIPE C,1(C)
+ AOS (P)
+ POPJ P,
+
+
+;...AND THERE ARE A FEW PEOPLE STILL CALLING THE FOLLOWING:
+
+MAKENV: PUSH P,C ;SAVE AN AC
+ HLRE C,PVP ;GET -LNTH OF PROC VECTOR
+ MOVEI A,(PVP) ;COPY PVP
+ SUBI A,-1(C) ;POINT TO DOPWD WITH A
+ HRLI A,TFRAME ;MAKE INTO A FRAME
+ HLL B,OTBSAV(B) ;TIME TO B
+ POP P,C
+ POPJ P,
+
+
+
+\f;THESE ROUTINES ARE CALLED TO EVALUATE THE VALUE PUSHED
+;ON TP ****THEY ARE ASSUMED TO CLOBBER EVERYTHING****
+
+ARGEV: JSP E,CHKARG
+ MCALL 1,EVAL
+ POPJ P,
+
+
+
+
+;WHEN APPLY-ING, ARGS ARE ALREADY EVALUATED
+
+ARGNEV: JSP E,CHKARG ;PITCH ANY TDEFERS
+ TRNN 0,DEF ;DEFAULT VALUES...
+ JRST NOEV
+ MCALL 1,EVAL ;...ARE ALWAYS EVALUATED
+ POPJ P,
+NOEV: POP TP,B ;OTHERWISE,
+ POP TP,A ;JUST RESTORE A&B
+ POPJ P,\f
+
+;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
+;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
+;EACH TRIPLET IS AS FOLLOWS:
+;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
+;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
+;AND THE THIRD IS A PAIR OF ZEROES.
+
+BNDA: TATOM,,-1
+
+SPECBIND: MOVE E,TP ;GET THE POINTER TO TOP
+ ADD E,[1,,1] ;BUMP POINTER ONCE
+ PUSH TP,$TTP
+ PUSH TP,E
+ MOVEI B, ;ZERO COUNTER
+ MOVE D,E
+SZLOOP: MOVE A,-6(D) ;COUNT ATOM BLOCKS AS 3
+ CAME A,BNDA
+ JRST GETVEC
+ SUB D,[6,,6]
+ ADDI B,3
+ JRST SZLOOP
+GETVEC: JUMPE B,DEGEN
+ PUSH P,B
+ AOJ B,
+ PUSH TP,$TTP
+ PUSH TP,D
+ PUSH TP,$TFIX
+ PUSH TP,B
+ MCALL 1,VECTOR ;<VECTOR .B>
+ POP TP,D ;RESTORE D = POINTER TO BOTTOM TRIPLE
+ SUB TP,[1,,1]
+ MOVE A,$TSP ;MAKE THIS BLOCK POINT TO PREVIOUS
+ MOVEM A,(B)
+ MOVEM SP,1(B)
+ ADDI B,2
+
+;MOVE TRIPLES TO VECTOR
+
+ POP P,E ;E _ LENGTH - 1
+ ASH E,1 ;TIMES 2
+ ADDI E,(B) ;E _ POINTER TO VECTOR DOPE WORD
+ HRLI A,(D)
+ HRRI A,(B)
+ BLT A,-1(E) ;MOVE BIND TRIPLES TO VECTOR
+
+;CHANGE ALL [TATOM,,-1]'S TO [TBIND,,LINK TO PREVIOUS BLOCK]
+
+ HRRZI B,(B) ;ZERO LEFT HALF OF B
+ MOVSI C,TBIND
+ HRRI C,-2(B) ;C = LINK _ ADR OF FIRST OF VECTOR
+FIXLP: MOVEM C,(B) ;STORE LINK TO PREVIOUS BLOCK IN BLOCK B
+ HRRI C,(B) ;C _ LINK TO THIS BLOCK
+ ADDI B,6
+ CAIE B,(E) ;GOT TO DOPE WORD?
+ JRST FIXLP
+
+;CLEAN UP TP
+
+ POP TP,C
+ SUB TP,[1,,1]
+ CAMLE C,TP ;ANYTHING ABOVE TRIPLES?
+ JRST NOBLT2
+ SUBI TP,(C) ;TP _ NUMBER THERE
+ HRLS TP ;IN BOTH HALVES
+ ADD TP,D ;NEW TP
+ HRLI D,(C)
+ BLT D,(TP) ;BLLLLLLLLT!
+ JRST SPCBE2
+DEGEN: SUB TP,[2,,2]
+ POPJ,
+NOBLT2: MOVE TP,D ;OR JUST RESTORE IT
+ SUB TP,[1,,1]
+
+;HERE TO BIND EVERYTHING IN VECTOR WITH DOPE WORD (E)
+
+SPCBE2: SUB E,[1,,1] ;E _ LAST WORD OF LAST BLOCK
+
+;EBIND BINDS THE ATOMS SPECIFIED BY THE BLOCK WHOSE LAST WORD
+;E POINTS TO, THEN THE BLOCK LINKED TO IT, ETC., UNTIL
+;IT FINDS ONE ALREADY BOUND, WHEN IT RESTORES E AND EXITS.
+;IT RESETS SP TO POINT TO THE FIRST ONE BOUND. IT CLOBBERS
+;ALL OTHER REGISTERS
+
+EBIND: HLRZ A,-1(E)
+ SKIPE A ;ALREADY BOUND?
+ POPJ P, ;YES-- EBIND IS A NO-OP
+ MOVEI D, ;D WILL BE THE NEW SP
+ PUSH P,E ;SAVE E
+ JRST DOBIND
+
+BINDLP: HLRZ A,-1(E)
+ SKIPE A ;HAS THIS BLOCK BEEN BOUND ALREADY?
+ JRST SPECBD ;YES, RESTORE AND QUIT
+DOBIND: SUB E,[6,,6]
+ SKIPN D ;HAS NEW SP ALREADY BEEN SET?
+ MOVE D,E ;NO, SET TO THIS BLOCK FOR NOW
+ MOVE A,1(E)
+ MOVE B,2(E)
+ PUSHJ P,ILOC ;(A,B) _ LOCATIVE OF (A,B)
+ HLR A,OTBSAV(TB)
+ MOVEM A,5(E) ;CLOBBER IT AWAY
+ MOVEM B,6(E) ;IN RESTORE CELLS
+
+ HRRZ A,PROCID+1(PVP) ;GET PROCESS NUMBER
+ HRLI A,TLOCI ;MAKE LOC PTR
+ MOVE B,E ;TO NEW VALUE
+ ADD B,[3,,3]
+ MOVE C,2(E) ;GET ATOM PTR
+ MOVEM A,(C) ;CLOBBER ITS VALUE
+ MOVEM B,1(C) ;CELL
+ JRST BINDLP
+
+SPECBD: MOVE SP,D ;SP _ D
+ ADD SP,[1,,1] ;FIX SP
+ POP P,E ;RESTORE E TO TOP OF BIND VECTOR
+ POPJ P,
+
+\f
+
+;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
+;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
+
+SPECSTORE:
+ HRRZ E,SPSAV (TB) ;GET TARGET POINTER
+
+STLOOP:
+ CAIN E,(SP) ;ARE WE DONE?
+ JRST STPOPJ
+ HLRZ C,(SP) ;GET TYPE OF BIND
+ CAIE C,TBIND ;NORMAL IDENTIFIER?
+ JRST JBVEC ;NO-- FIND & FOLLOW REBIND POINTER
+
+
+ MOVE C,1(SP) ;GET TOP ATOM
+ MOVE D,4(SP) ;GET STORED LOCATIVE
+\r HRR D,PROCID+1(PVP) ;STORE SIGNATURE
+ MOVEM D,(C) ;CLOBBER INTO ATOM
+ MOVE D,5(SP)
+ MOVEM D,1(C)
+ HRRZS 4(SP) ;NOW LOOKS LIKE A VIRGIN BLOCK
+ SETZM 5(SP)
+ HRRZ SP,(SP) ;GET NEXT BLOCK
+ JRST STLOOP
+
+;IN JUMPING TO A NEW BIND VECTOR, FOLLOW
+;REBIND POINTER IF IT DIFFERS FROM ACCESS POINTER
+
+JBVEC: CAIE C,TSP ;THIS JUST BETTER BE TRUE, THAT'S ALL
+ .VALUE [ASCIZ /BADSP/]
+ GETYP D,2(SP) ;REBIND POINTER?
+ CAIE D,TSP
+ JRST XCHVEC ;NO-- USE ACCESS
+ MOVE D,5(SP) ;YES-- RESTORE PROCID
+ EXCH D,PROCID+1(PVP)
+ MOVEM D,5(SP) ;SAVING CURRENT ONE FOR LATER FAILURES
+ ADD SP,[2,,2]
+
+;IF WE JUST RAN OFF THE END OF THE ENVIRONMENT CHAIN, BARF
+
+XCHVEC: SKIPE SP,1(SP)
+ JRST STLOOP
+ JUMPE E,STPOPJ ;UNLESS THAT'S AS FAR AS WE WANTED TO GO
+ .VALUE [ASCIZ /SPOVERPOP/]
+
+STPOPJ:
+ MOVE SP,SPSAV(TB)
+ POPJ P,
+
+
+\f
+
+MFUNCTION REP,FSUBR,[REPEAT]
+ JRST PROG
+MFUNCTION PROG,FSUBR
+ ENTRY 1
+ GETYP A,(AB) ;GET ARG TYPE
+ CAIE A,TLIST ;IS IT A LIST?
+ JRST WTYP ;WRONG TYPE
+ SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
+ JRST ERRTFA ;TOO FEW ARGS
+ PUSH TP,$TLIST ;PUSH GOODIE
+ PUSH TP,C
+BIPROG: PUSH TP,$TLIST
+ PUSH TP,C ;SLOT FOR WHOLE BODY
+ PUSHJ P,PROGAT ;BIND FUNNY PROG MARKER
+ MOVE C,3(TB) ;PROG BODY
+ MOVNI D,1 ;TELL BINDER WE ARE APROG
+ PUSHJ P,BINDER
+ HRRZ C,3(TB) ;RESTORE PROG
+ TRNE A,H ;SKIP IF NO NAME ALA HEWITT
+ HRRZ C,(C)
+ JUMPE C,NOBODY
+ MOVEM C,3(TB) ;SAVE FOR AGAIN, ETC.
+STPROG: HRRZ C,(C) ;SKIP DCLS
+ JUMPE C,NOBODY
+
+; HERE TO RUN PROGS FUNCTIONS ETC.
+
+DOPROG:
+ HRRZM C,1(TB) ;CLOBBER AWAY BODY
+ PUSH TP,(C) ;EVALUATE THE
+ HLLZS (TP)
+ PUSH TP,1(C) ;STATEMENT
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ HRRZ C,@1(TB) ;GET THE REST OF THE BODY
+ JUMPN C,DOPROG ;IF MORE -- DO IT
+ENDPROG:
+ HRRZ C,FSAV(TB)
+ MOVE C,@-1(C)
+ CAME C,MQUOTE REP,REPEAT
+ JRST FINIS
+ SKIPN C,3(TB) ;CHECK IT
+ JRST FINIS
+ MOVEM C,1(TB)
+ JRST CONTINUE
+
+;HERE TO BIND PROG ATOM (AND ANYTHING ELSE ON STACK)
+
+PROGAT: PUSH TP,BNDA
+ PUSH TP,MQUOTE [LPROG ],INTRUP
+ MOVE B,TB
+ PUSHJ P,MAKENV ;B _ POINTER TO CURRENT FRAME
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,[0]
+ PUSH TP,[0]
+ JRST SPECBI\f
+
+MFUNCTION RETURN,SUBR
+ ENTRY 1
+ PUSHJ P,PROGCH ;CKECK IN A PROG
+ PUSHJ P,SAVE ;RESTORE PROG'S FRAME, BCKTRKING IF NECESSARY
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST FINIS
+
+
+MFUNCTION AGAIN,SUBR
+ ENTRY
+ HLRZ A,AB ;GET # OF ARGS
+ CAIN A,-2 ;1 ARG?
+ JRST NLCLA ;YES
+ JUMPN A,WNA ;0 ARGS?
+ PUSHJ P,PROGCH ;CHECK FOR IN A PROG
+ JRST AGAD
+NLCLA: HLRZ A,(AB)
+ CAIE A,TACT
+ JRST WTYP
+ MOVE A,1(AB)
+ HRR B,A
+ HLL B,OTBSAV (B)
+ HRRZ C,A
+ CAIG C,1(TP)
+ CAME A,B
+ JRST ILLFRA
+ HLRZ C,FSAV (C)
+ CAIE C,TENTRY
+ JRST ILLFRA
+AGAD: PUSHJ P,SAVE ;RESTORE FRAME TO REPEAT
+ MOVE B,3(TB)
+ MOVEM B,1(TB)
+ JRST CONTIN
+
+MFUNCTION GO,SUBR
+ ENTRY 1
+ PUSHJ P,PROGCH ;CHECK FOR A PROG
+ PUSH TP,A ;SAVE
+ PUSH TP,B
+ MOVE A,(AB)
+ CAME A,$TATOM
+ JRST NLCLGO
+ PUSH TP,A
+ PUSH TP,1(AB)
+ PUSH TP,2(B)
+ PUSH TP,3(B)
+ MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
+ JUMPE B,NXTAG ;NO -- ERROR
+FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO
+ MOVSI D,TLIST
+ MOVEM D,-1(TP)
+ JRST GODON
+
+NLCLGO: CAME A,$TTAG ;CHECK TYPE
+ JRST WTYP
+ MOVE A,1(AB) ;GET ARG
+ HRR B,3(A)
+ HLL B,OTBSAV(B)
+ HRRZ C,B
+ CAIG C,1(TP)
+ CAME B,3(A) ;CHECK TIME
+ JRST ILLFRA
+ HLRZ C,FSAV(C)
+ CAIE C,TENTRY
+ JRST ILLFRA
+ PUSH TP,(A) ;SAVE BODY
+ PUSH TP,1(A)
+GODON: PUSHJ P,SAVE ;GO BACK TO CORRECT FRAME
+ MOVE B,(TP) ;RESTORE ITERATION MARKER
+ MOVEM B,1(TB)
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST CONTIN
+
+\f
+
+
+MFUNCTION TAG,SUBR
+ ENTRY 1
+ HLRZ A,(AB) ;GET TYPE OF ARGUMENT
+ CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
+ JRST WTYP
+ PUSHJ P,PROGCH ;CHECK PROG
+ PUSH TP,A ;SAVE VAL
+ PUSH TP,B
+ PUSH TP,0(AB)
+ PUSH TP,1(AB)
+ PUSH TP,2(B)
+ PUSH TP,3(B)
+ MCALL 2,MEMQ
+ JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
+ EXCH A,-1(TP) ;SAVE PLACE
+ EXCH B,(TP)
+ PUSH TP,A ;UNDER PROG FRAME
+ PUSH TP,B
+ MCALL 2,EVECTOR
+ MOVSI A,TTAG
+ JRST FINIS
+
+PROGCH: MOVE B,MQUOTE [LPROG ],INTRUP
+ PUSHJ P,ILVAL ;GET VALUE
+ GETYP C,A
+ CAIE C,TFRAME
+ JRST NXPRG
+ MOVE C,B ;CHECK TIME
+ HLL C,OTBSAV(B)
+ CAME C,B
+ JRST ILLFRA
+ HRRZI C,(B) ;PLACE
+ CAILE C,1(TP)
+ JRST ILLFRA
+ GETYP C,FSAV(C)
+ CAIE C,TENTRY
+ JRST ILLFRA
+ POPJ P,
+
+MFUNCTION EXIT,SUBR
+ ENTRY 2
+ PUSHJ P,TILLFM ;TEST FRAME
+ PUSHJ P,SAVE ;RESTORE FRAME
+ JRST EXIT2
+
+;IF GIVEN, RETURN SECOND ARGUMENT
+
+RETRG2: MOVE A,2(AB)
+ MOVE B,3(AB)
+ MOVE AB,ABSAV(TB) ;IN CASE OF GC
+ JRST FINIS
+
+MFUNCTION COND,FSUBR
+ ENTRY 1
+ HLRZ A,(AB)
+ CAIE A,TLIST
+ JRST WTYP
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ;CREATE UNNAMED TEMP
+CLSLUP: SKIPN B,1(TB) ;IS THE CLAUSELIST NIL?
+ JRST IFALSE ;YES -- RETURN NIL
+ HLRZ A,(B) ;NO -- GET TYPE OF CAR
+ CAIE A,TLIST ;IS IT A LIST?
+ JRST BADCLS ;
+ MOVE A,1(B) ;YES -- GET CLAUSE
+ JUMPE A,BADCLS
+ PUSH TP,(A) ;EVALUATION OF
+ HLLZS (TP)
+ PUSH TP,1(A) ;THE PREDICATE
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ CAMN A,$TFALSE ;IF THE RESULT IS
+ JRST NXTCLS ;FALSE TRY NEXT CLAUSE
+ MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE
+ MOVE C,1(C)
+ HRRZ C,(C)
+ JUMPE C,FINIS ;(UNLESS DONE WITH IT)
+ JRST DOPROG ;AS THOUGH IT WERE A PROG
+NXTCLS: HRRZ A,@1(TB) ;SET THE CLAUSLIST
+ HRRZM A,1(TB) ;TO CDR OF THE CLAUSLIST
+ JRST CLSLUP
+
+IFALSE:
+ MOVSI A,TFALSE ;RETURN FALSE
+ MOVEI B,0
+ JRST FINIS
+
+
+
+
+;RESTORE TB TO STACK FRAME POINTED TO BY B, SAVING INTERMEDIATE FRAMES ON THE PLANNER PDL
+;IF NECESSARY; CLOBBERS EVERYTHING BUT B
+SAVE: SKIPN C,OTBSAV(B) ;PREVIOUS FRAME?
+ JRST QWKRET
+ CAMN PP,PPSAV(C) ;ANYTHING HAPPEN TO PP BETWEEN B AND HERE?
+ JRST QWKRET ;NO-- JUST RETURN
+ PUSH TP,$TTB
+ PUSH TP,B
+SVLP: HRRZ B,(TP)
+ CAIN B,(TB) ;DONE?
+ JRST SVRET
+ HRRZ C,OTBSAV(TB) ;ANYTHING TO SAVE YET?
+ CAME PP,PPSAV(C)
+ PUSHJ P,BCKTRK ;DO IT
+ HRR TB,OTBSAV(TB) ;AND POP UP
+ JRST SVLP
+QWKRET: HRR TB,B ;SKIP OVER EVERYTHING
+ POPJ P,
+SVRET: SUB TP,[2,,2] ;POP CRAP OFF TP
+ POPJ P,\f
+
+;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
+;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
+; ITS SECOND ARGUMENT.
+
+MFUNCTION SETG,SUBR
+ ENTRY 2
+ HLLZ A,(AB) ;GET TYPE OF FIRST ARGUMENT
+ CAME A,$TATOM ;CHECK THAT IT IS AN ATOM
+ JRST NONATM ;IF NOT -- ERROR
+ MOVE B,1(AB) ;GET POINTER TO ATOM
+ PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
+ CAMN A,$TUNBOUND ;IF BOUND
+ PUSHJ P,BSETG ;IF NOT -- BIND IT
+ MOVE C,B ;SAVE PTR
+ MOVE A,2(AB) ;GET SECOND ARGUMENT
+ MOVE B,3(AB) ;INTO THE RETURN POSITION
+ MOVEM A,(C) ;DEPOSIT INTO THE
+ MOVEM B,1(C) ;INDICATED VALUE CELL
+ JRST FINIS
+
+BSETG: HRRZ A,GLOBASE+1(TVP)
+ HRRZ B,GLOBSP+1(TVP)
+ SUB B,A
+ CAIL B,6
+ JRST SETGIT
+ PUSH TP,GLOBASE(TVP)
+ PUSH TP,GLOBASE+1 (TVP)
+ PUSH TP,$TFIX
+ PUSH TP,[0]
+ PUSH TP,$TFIX
+ PUSH TP,[100]
+ MCALL 3,GROW
+ MOVEM A,GLOBASE(TVP)
+ MOVEM B,GLOBASE+1(TVP)
+SETGIT:
+ MOVE B,GLOBSP+1(TVP)
+ SUB B,[4,,4]
+ MOVE C,(AB)
+ MOVEM C,(B)
+ MOVE C,1(AB)
+ MOVEM C,1(B)
+ MOVEM B,GLOBSP+1(TVP)
+ ADD B,[2,,2]
+ MOVSI A,TLOCI
+ POPJ P,
+
+\f
+
+
+;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
+;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
+
+MFUNCTION SET,SUBR
+ ENTRY 2
+ HLLZ A,(AB) ;GET TYPE OF FIRST
+ CAME A,$TATOM ;ARGUMENT --
+ JRST WTYP ;BETTER BE AN ATOM
+ MOVE B,1(AB) ;GET PTR TO IT
+ PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
+ CAMN A,$TUNBOUND ;BOUND?
+ PUSHJ P, BSET ;BIND IT
+ MOVE C,B ;SAVE PTR
+ MOVE A,2(AB) ;GET SECOND ARG
+ MOVE B,3(AB) ;INTO RETURN VALUE
+ MOVEM A,(C) ;CLOBBER IDENTIFIER
+ MOVEM B,1(C)
+ JRST FINIS
+BSET: PUSH TP,$TFIX
+ PUSH TP,[4]
+ MCALL 1,VECTOR ;GET NEW BIND VECTOR
+ MOVE A,$TSP
+ MOVEM A,(B) ;MARK IT
+ SETZM A,1(B)
+ MOVSI A,TBIND
+ HRRI A,(B)
+ MOVEM A,2(B) ;CHAIN FIRST BLOCK
+ MOVE A,1(AB) ;A _ ATOM
+ MOVEM A,3(B)
+ MOVE C,SPBASE+1(PVP) ;CHAIN TO PREVIOUS BIND VECTOR
+ MOVEM B,SPBASE+1(PVP) ;SET NEW TOP
+ ADD B,[2,,2]
+ MOVEM B,1(C)
+ ADD B,[2,,2] ;POINT TO LOCATIVE
+ MOVSI A,TLOCI
+ HRR A,PROCID+1(PVP) ;WHICH MAKE
+ MOVE C,1(AB) ;C _ ATOM _ VALUE CELL ADDRESS
+ MOVEM A,(C)
+ MOVEM B,1(C) ;CLOBBER LOCATIVE SLOT
+ POPJ P,
+\f
+
+MFUNCTION NOT,SUBR
+ ENTRY 1
+ HLRZ A,(AB) ; GET TYPE
+ CAIE A,TFALSE ;IS IT FALSE?
+ JRST IFALSE ;NO -- RETURN FALSE
+
+TRUTH:
+ MOVSI A,TATOM ;RETURN T (VERITAS)
+ MOVE B,MQUOTE T
+ JRST FINIS
+
+MFUNCTION ANDA,FSUBR,AND
+ ENTRY 1
+ HLRZ A,(AB)
+ CAIE A,TLIST
+ JRST WTYP ;IF ARG DOESN'T CHECK OUT
+ SKIPN C,1(AB) ;IF NIL
+ JRST TRUTH ;RETURN TRUTH
+ PUSH TP,$TLIST ;CREATE UNNAMED TEMP
+ PUSH TP,C
+ANDLP:
+ JUMPE C,FINIS ;ANY MORE ARGS?
+ MOVEM C,1(TB) ;STORE CRUFT
+ PUSH TP,(C) ;EVALUATE THE
+ HLLZS (TP) ;FIRST REMAINING
+ PUSH TP,1(C) ;ARGUMENT
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ CAMN A,$TFALSE
+ JRST FINIS ;IF FALSE -- RETURN
+ HRRZ C,@1(TB) ;GET CDR OF ARGLIST
+ JRST ANDLP
+
+MFUNCTION OR,FSUBR
+ ENTRY 1
+ HLRZ A,(AB)
+ CAIE A,TLIST ;CHECK OUT ARGUMENT
+ JRST WTYP
+ MOVE C,1(AB) ;PICK IT UP TO ENTER LOOP
+ PUSH TP,$TLIST ;CREATE UNNAMED TEMP
+ PUSH TP,C
+ORLP:
+ JUMPE C,IFALSE ;IF NO MORE OPTIONS -- FALSE
+ MOVEM C,1(TB) ;CLOBBER IT AWAY
+ PUSH TP,(C)
+ HLLZS (TP)
+ PUSH TP,1(C) ;EVALUATE THE FIRST REMAINING
+ JSP E,CHKARG
+ MCALL 1,EVAL ;ARGUMENT
+ CAME A,$TFALSE ;IF NON-FALSE RETURN
+ JRST FINIS
+ HRRZ C,@1(TB) ;IF FALSE -- TRY AGAIN
+ JRST ORLP
+
+MFUNCTION FUNCTION,FSUBR
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE FUNCTION
+ MCALL 2,CHTYPE
+ JRST FINIS
+
+\f
+
+MFUNCTION CLOSURE,SUBR
+ ENTRY
+ SKIPL A,AB ;ANY ARGS
+ JRST ERRTFA ;NO -- LOSE
+ ADD A,[2,,2] ;POINT AT IDS
+ PUSH TP,$TAB
+ PUSH TP,A
+ PUSH P,[0] ;MAKE COUNTER
+
+CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
+ JRST CLODON ;NO -- LOSE
+ PUSH TP,(A) ;SAVE ID
+ PUSH TP,1(A)
+ PUSH TP,(A) ;GET ITS VALUE
+ PUSH TP,1(A)
+ ADD A,[2,,2] ;BUMP POINTER
+ MOVEM A,1(TB)
+ AOS (P)
+ MCALL 1,VALUE
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,LIST ;MAKE PAIR
+ PUSH TP,A
+ PUSH TP,B
+ JRST CLOLP
+
+CLODON: POP P,A
+ ACALL A,LIST ;MAKE UP LIST
+ PUSH TP,(AB) ;GET FUNCTION
+ PUSH TP,1(AB)
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,LIST ;MAKE LIST
+ MOVSI A,TFUNARG
+ JRST FINIS
+
+
+MFUNCTION FALSE,SUBR
+ ENTRY
+ JUMPGE AB,IFALSE
+ HLRZ A,(AB)
+ CAIE A,TLIST
+ JRST WTYP
+ MOVSI A,TFALSE
+ MOVE B,1(AB)
+ JRST FINIS
+\f;BCKTRK SAVES THINGS ON PP
+
+;IT AND ITS FRIENDS FLAG PP "FRAMES" WITH MARKERS OF FORM "TTP,,SWITCHES", WHERE SWITCHES INCLUDES
+
+COP==1 ;ON IFF CALL TO BCKTRK IS TO COPY FRAME (TB) AS WELL
+ ;AS OTBSAV(TB)
+SAV==2 ;ON IFF TUPLES OF (TB) ARE TO BE SAVED; COP IMPLIES
+ ;SAV
+TUP==4 ;ON IFF (TB) CONTAINS ANY TUPLES BESIDES ARGS
+ON==10 ;ON IFF THIS FRAME OR FAILPOINT "RESTS ON TOP OF"
+ ;FRAME DESIGNATED BY TTP POINTER, OR IS INTENDED TO
+ ;TAKE ITS PLACE
+
+;BELOW THE TTP POINTER IS ONE OR TWO BLOCKS FLAGGED BY A TFIX
+;VALUE. IF ON=ON AND TUP=ON IN THE RIGHT HALF OF THE TFIX,
+;THE TFIX BEGINS A BLOCK OF TUPLE DEBRIS; OTHERWISE,
+;IT BEGINS A SAVED TP FRAME.
+
+
+BCKTRK: HRRZ A,-1(PP) ;SLOT LEFT BY FAILPOINT?
+ TRNN A,COP ;(I.E., TO BE COPIED?)
+ JRST NBCK
+ MOVE E,TB ;YES-- FIRST SAVE THIS FRAME
+ PUSHJ P,BCKTRE
+ HRRZ A,-1(PP)
+ JRST NBCK1
+NBCK: TRNN A,SAV
+ JRST RMARK
+
+;SAVE TUPLES OF FRAME ON TOP OF PP
+
+NBCK1: MOVSI B,TTP ;FAKE OUT GC
+ MOVEM B,BSTO(PVP)
+ MOVSI C,TPP
+ MOVEM C,CSTO(PVP)
+ MOVEM C,ESTO(PVP)
+ MOVE B,(PP) ;B _ TPIFIED TB POINTER
+ SUB PP,[2,,2] ;CLEAN OFF POINTER TO MAKE ROOM FOR ARGS
+ MOVE E,PP
+ MOVE C,PP ;C _ E _ PP
+ SUB C,(PP) ;C _ ADDRESS OF SAVED OTB
+ HLRE D,1(C) ;D _ NO. OF ARGS
+ JUMPE D,NOARGS
+ SUB B,[FRAMLN,,FRAMLN] ;B _ FIRST OF SAVE BLOCK
+ MOVNS D
+ HRLS D
+ SUB B,D ;B _ FIRST OF ARGS
+MVARGS: INTGO
+ PUSH PP,(B) ;MOVE NEXT
+ PUSH PP,1(B)
+ ADD B,[2,,2]
+ SUB D,[2,,2]
+ JUMPG D,MVARGS
+ ADD B,[FRAMLN,,FRAMLN] ;B _ TB ADDRESS
+ JRST MVTUPS
+NOARGS: TRNN A,TUP ;ANY OTHER TUPLES?
+ JRST RMARK
+MVTUPS: ADD C,[FRAMLN-1,,FRAMLN-1] ;C _ PP TB SLOT
+ SUB E,[1,,1] ;E _ TFIX SLOT ADDRESS
+MTOLP: CAML C,E ;C REACHED E?
+ JRST MTDON ;YES-- ALL TUPLES FOUND
+ INTGO
+ GETYP A,(C) ;ELSE
+ CAIE A,TTBS ;LOOK FOR TUPLE
+ JRST ARND22
+ HRRE D,(C) ;D _ NO. OF ELEMENTS
+MTILP: JUMPGE D,ARND22
+ INTGO
+ PUSH PP,(B)
+ PUSH PP,1(B)
+ ADD B,[2,,2]
+ ADDI D,2
+ JRST MTILP
+ARND22: ADD B,[2,,2] ;ADVANCE IN STEP
+ ADD C,[2,,2]
+ JRST MTOLP
+;ALL TUPLES MOVED
+MTDON: HRRZ C,PP
+ SUBI C,1(E) ;C _ NO. OF THINGS MOVED
+ HRLS C
+ PUSH PP,[TFIX,,TUP] ;MARK AS TUPLE CRUFT
+ PUSH PP,C
+;NEW TTP MARKER
+RMARK: MOVE E,OTBSAV(TB) ;SAVE PREVIOUS FRAME
+ HRRZ D,E
+ HRLS D
+ HLRE C,B
+ SUBI C,(B)
+ HRLZS C
+ ADD D,C
+ PUSH PP,[TTP,,ON]
+ PUSH PP,D
+ MOVSI B,TFIX ;RESTORE B TYPE
+ MOVEM B,BSTO(PVP)
+
+;BCKTRE SAVE CONTENTS OF FRAME E OF TP ON PLANNER PDL
+
+BCKTRE: MOVSI A,TPDL ;FOR AGC
+ MOVEM A,ASTO(PVP)
+ MOVSI C,TTP
+ MOVEM C,CSTO(PVP)
+ MOVSI A,TTB
+ MOVEM A,ESTO(PVP)
+
+;MOVE P BLOCK OF PREVIOUS FRAME TO PP
+
+ MOVE C,PSAV(E) ;C _ LAST OF P "FRAME"
+ HRRZ A,OTBSAV(E)
+ MOVE A,PSAV(A) ;A _ LAST OF PREVIOUS P "FRAME"
+ ADD A,[1,,1]
+MVPB: CAMLE A,C ;IF BLOCK EMPTY,
+ JRST MVTPB ;DO NOTHING
+ HRRZ D,C
+ SUBI D,-1(A) ;ELSE, SET COUNTER
+ PUSH PP,$TPDLS ;MARK BLOCK
+ HRRM D,(PP)
+ HRLS D
+ PUSH P,D
+PSHLP1: PUSH PP,(A)
+ INTGO ;MOVE BLOCK
+ ADD A,[1,,1]
+ CAMG A,C
+ JRST PSHLP1
+ PUSH PP,$TFIX
+ PUSH PP,[0] ;PUSH BLOCK COUNTER
+ POP P,(PP)
+;NOW DO SIMILAR THING FOR TP
+MVTPB: MOVSI A,TTP ;FOR AGC
+ MOVEM A,ASTO(PVP)
+ MOVE C,TPSAV(E) ;C POINT TO LAST OF BLOCK
+ PUSH TP,$TPP ;SAVE INITIAL PP
+ PUSH TP,PP ;FOR SUBTRACTION
+ HRRZ A,E ;A _ TPIFIED E
+ HLRE B,C
+ SUBI B,(C)
+ HRLZS B
+ HRLS A
+ ADD A,B
+ GETYP D,FSAV(A)
+ CAIE D,TENTRY
+ .VALUE [ASCIZ /TPFUCKED/]
+;MOVE THE SAVE BLOCK
+
+MSVBLK: MOVSI D,TENTS ;MAKE TYPE TENTS
+ HRR D,FSAV(A)
+ PUSH PP,D
+ HLLZ D,OTBSAV(E) ;RELATIVIZE OTB AND AB POINTERS
+ PUSH PP,D
+ HLLZ D,ABSAV(E)
+ PUSH PP,D
+ PUSH PP,SPSAV(E)
+ PUSH PP,PSAV(E)
+ PUSH PP,TPSAV(E)
+ PUSH PP,PPSAV(E)
+ PUSH PP,PCSAV(E)
+ MOVEI 0, ;0 _ 0 (NO TUPLES)
+PSHLP2: INTGO
+ CAMLE A,C ;DONE?
+ JRST MRKFIX
+ GETYP D,(A)
+ CAIN D,TTB ;TUPLE?
+ JRST MVTB
+ PUSH PP,(A) ;NO, JUST MOVE IT
+ PUSH PP,1(A)
+ARND4: ADD A,[2,,2]
+ JRST PSHLP2
+MRKFIX: HRRZ C,(TP) ;C _ PREVIOUS PP POINTER
+ SUB TP,[2,,2]
+ HRRZ D,PP ;D _ CURRENT PP TOP
+ SUBI D,(C) ;D _ DIFFERENCE
+ HRLS D
+ PUSH PP,$TFIX ;PUSH BLOCK COUNTER
+ PUSH PP,D
+
+
+;NOW SAVE LOCATION OF THIS FRAME
+
+ HRLS E
+ MOVE C,TPSAV(E)
+ HLRE B,C
+ SUBI B,(C)
+ HRLZS B
+ ADD E,B ;CONVERSION TO TTP
+ HRLI 0,TTP
+ TRO 0,SAV ;PUSH A TTP MARKER WITH SAV & MAYBE TUP ON
+ PUSH PP,0
+ PUSH PP,E
+
+;RETURN
+
+ MOVSI A,TFIX
+ MOVEM A,ASTO(PVP)
+ MOVEM A,CSTO(PVP)
+ MOVEM A,ESTO(PVP)
+ POPJ P,
+
+;RELATIVIZE A TB POINTER
+
+MVTB: HRRE D,(A) ;D _ - LENGTH OF TUPLE
+ MOVNS D
+ HRLS D ;D _ LENGTH,,LENGTH
+ SUB PP,D ;THROW TUPLE AWAY!!!
+ TRO 0,TUP
+ MOVNS D
+ HRLI D,TTBS
+ PUSH PP,D
+ MOVE D,1(A)
+ SUBI D,(E)
+ PUSH PP,D
+ JRST ARND4
+\fMFUNCTION FAIL,SUBR
+
+;SINCE FAILURES ARE NOT INTERRUPTIBLE FOR ANYTHING BUT GARBAGE
+;COLLECTIONS, THE FOLLOWING MACRO REPLACES INTGO FOR STACK-BUILDING
+;LOOPS
+
+DEFINE UNBLOW STK
+ SKIPL STK
+ PUSHJ P,NBLO!STK
+TERMIN
+
+
+ ENTRY
+ HLRE A,AB
+ MOVNS A
+ CAILE A,4 ;AT MOST 2 ARGS
+ JRST WNA
+ CAIGE A,2 ;IF FIRST ARG NOT GIVEN,
+ JRST MFALS ;ASSUME <>
+ MOVE B,(AB) ;OTHERWISE, FIRST ARG IS MESSAGE
+ MOVEM B,MESS(PVP)
+ MOVE B,1(AB)
+ MOVEM B,MESS+1(PVP)
+
+ CAIE A,4 ;PLACE TO FAIL TO GIVEN?
+ JRST AFALS1
+ HLRZ A,2(AB)
+ CAIE A,TACT ;CAN ONLY FAIL TO AN ACTIVATION
+ JRST TAFALS
+SAVACT: MOVE B,2(AB) ;TRANSMIT ACTIVATION TO FAILPOINT
+ MOVEM B,FACTI(PVP) ;VIA PVP
+ MOVE B,3(AB)
+ MOVEM B,FACTI+1(PVP)
+;NOW REBUILD TP FROM PP
+IFAIL: SETOM FLFLG ;FLFLG _ ON
+ HRRZ A,(PP) ;GET FRAME TO NESTLE IN
+ JUMPE A,BDFAIL
+ HRRZ 0,-1(PP) ;0 _ SWITCHES FOR FRAME
+ CAIN A,(TB)
+ JRST RSTFRM
+ GETYP B,FACTI(PVP) ;IF FALSE ACTIVATION,
+ CAIN B,TFALSE ;JUST GO TO FRAME
+ JRST POPFS
+ HRRZI B,(TB) ;OTHERWISE, CHECK TO SEE IF WE ARE LEAVING
+ HRRZ D,FACTI+1(PVP)
+ALOOP: CAIN B,(A) ; FRAME FACTI(PVP)
+ JRST POPFS ;NO-- IT'S ABOVE FAILPOINT (A)
+ CAIN B,(D) ;FOUND FACTI?
+ JRST AFALS2 ;YES-- CLOBBER FACTI TO #FALSE()
+ HRRZ B,OTBSAV(B) ;NO-- KEEP LOOKING
+ JRST ALOOP
+AFALS2: MOVSI B,TFALSE ;SET IT TO FALSE FROM HERE ON
+ MOVEM B,FACTI(PVP)
+ SETZB D,FACTI+1(PVP)
+POPFS: HRR TB,A ;MAY TAKE MORE WORK
+RSTFRM: MOVE P,PSAV(TB)
+ MOVE TP,TPSAV(TB)
+ SUB PP,[2,,2]
+ GETYP A,-1(PP)
+ CAIN A,TPC
+ JRST MHFRAM
+ CAIE A,TFIX
+ JRST BADPP
+
+;MOVE A TP BLOCK FROM PP TO TP
+ MOVSI A,TPP
+ MOVEM A,ASTO(PVP)
+ MOVEM A,CSTO(PVP)
+ MOVE A,PP
+ SUB A,(PP) ;A POINTS TO BOTTOM OF BLOCK
+ TRNN 0,ON ;"ON" BLOCK?
+ JRST INBLK
+ONBLK: CAME SP,SPSAV(TB) ;YES-- FIX UP ENVIRONMENT
+ PUSHJ P,SPECST
+ MOVE C,A
+ HRRZ 0,-1(PP) ;ANY TUPLES?
+ TRNN 0,TUP
+ JRST USVBLK ;NO-- GO MOVE SAVE BLOCK
+ SUB A,[2,,2] ;A _ BLOCK UNDER THIS ONE
+ SUB A,(A)
+;FILL IN ARGS TUPLE
+ GETYP B,-1(A)
+ CAIE B,TENTS ;LOOK IN SAVE BLOCK
+ JRST BADPP
+ HLRE D,FRAMLN+ABSAV-1(A)
+ PUSHJ P,USVTUP
+
+;MOVE SAVE BLOCK BACK TO TP
+
+USVBLK: ADD A,[FRAMLN,,FRAMLN]
+ MOVSI D,TENTRY
+ HRR D,FSAV-1(A)
+ PUSH TP,D
+ MOVEI AB,(TP) ;REGENERATE AB & OTBSAV
+ HLRE D,ABSAV-1(A)
+ MOVNS D
+ HRLS D
+ SUB AB,D
+ MOVEI D,(TB)
+ HLL D,OTBSAV-1(A)
+ PUSH TP,D
+ PUSH TP,AB
+ PUSH TP,SPSAV-1(A)
+ PUSH TP,PSAV-1(A)
+ PUSH TP,TPSAV-1(A)
+ PUSH TP,PPSAV-1(A)
+ PUSH TP,PCSAV-1(A)
+ HRRI TB,1(TP)
+
+PSHLP4: CAML TP,TPSAV(TB)
+ JRST USTPDN
+ UNBLOW TP
+ GETYP B,-1(A)
+ CAIN B,TTBS ;FOUND A TUPLE?
+ JRST USVTB
+ PUSH TP,-1(A) ;NO-- JUST MOVE IT
+ PUSH TP,(A)
+ARND12: ADD A,[2,,2] ;BUMP POINTER
+ JRST PSHLP4
+USVTB: HRRE D,-1(A)
+ PUSHJ P,USVTUP
+ MOVE D,-1(A) ;UNRELATIVIZE A TTB
+ HRLI D,TTB
+ PUSH TP,D
+ MOVE D,(A)
+ ADDI D,(TB)
+ PUSH TP,D
+ JRST ARND12
+USTPDN: MOVE 0,-1(PP) ;IF TUPLES,
+ TRNN 0,TUP
+ JRST USTPD3
+ SUB PP,(PP) ;SKIP OVER TUPLE DEBRIS
+ SUB PP,[2,,2]
+USTPD3: CAME TP,TPSAV(TB) ;BETTER HAVE WORKED
+ JRST BADPP
+ CAMN SP,SPSAV(TB) ;PLEASE GOD, NO MORE BINDINGS
+ JRST USV2 ;PRAYER CAN MOVE MOUNTAINS
+ MOVEI E, ;E _ 0 = INITIAL LOWER BIND BLOCK
+ MOVE C,SPSAV(TB) ;C _ SPSAV = INITIAL UPPER BLOCK
+
+;REBIND EVERYTHING IN THIS FRAME-- FIRST, FIND THE TOPMOST BLOCK,
+;SINCE THEY MUST BE REBOUND IN THE ORDER BOUND
+
+BLOOP1: GETYP D,(C)
+ CAIE D,TBIND ;C POINTS TO BIND BLOCK?
+ JRST SPLBLK
+ ADD C,[5,,5] ;YES-- C _ ADDRESS OF ITS LAST WORD
+ MOVEM E,(C) ;(C) _ E = LOWER BIND POINTER
+ MOVE E,C ;E _ C
+ HLRE D,C
+ SUB C,D ;C _ ADDRESS OF DOPE WORD
+ HLRZ D,1(C)
+ SUB D,[2,,2]
+ SUBM C,D ;D _ FIRST WORD ADDRESS
+ MOVE C,1(D) ;C _ REBIND BLOCK
+ JRST JBVEC3
+SPLBLK: GETYP D,2(C)
+ CAIN D,TSP
+ ADD C,[2,,2]
+ ADD C,[1,,1] ;C _ REBIND POINTER ADDRESS
+ MOVE D,(C) ;D _ HIGHER BLOCK
+ MOVEM E,(C) ;(C) _ E
+ MOVE E,C ;E _ C
+ MOVE C,D ;C _ D = HIGHER BIND BLOCK
+JBVEC3: CAME SP,C ;GOT TO SP YET?
+ JRST BLOOP1
+
+
+;NOW REBIND EVERYTHING, RESET PROCID'S PROPERLY, ETC.;
+;THIS MUST BE DONE IN PROPER ORDER, FROM TOPMOST BLOCK DOWN
+
+BLOOP2: HLRZ D,-1(E) ;WHAT DOES E POINT TO?
+ PUSH P,(E)
+ JUMPN D,TUGSP ;IF NON-ZERO, MUST BE REBIND SLOT
+ PUSHJ P,EBIND ;OTHERWISE, BIND BLOCK TO BE REBOUND
+ JRST DOWNBL
+TUGSP: MOVEM SP,(E) ;RECONNECT UPPER BLOCK
+ GETYP 0,1(E)
+ CAIE 0,TBIND
+ SUB E,[2,,2]
+ MOVE SP,E
+ SUB SP,[1,,1] ;TUG SP DOWN
+ CAIE 0,TSP ;ID SWAP?
+ JRST DOWNBL
+ MOVE 0,PROCID+1(PVP)
+ EXCH 0,5(SP)
+ MOVEM 0,PROCID+1(PVP)
+DOWNBL: POP P,E ;E _ LOWER BLOCK
+ JUMPN E,BLOOP2
+
+RBDON: CAME SP,SPSAV(TB) ;ALL THAT BETTER HAVE WORKED
+ JRST BADPP
+ JRST USV2
+
+;RESTORE A BLOCK "INTO" TB
+
+INBLK: ADD A,[FRAMLN,,FRAMLN]
+ MOVSI C,TTP
+ MOVEM C,CSTO(PVP)
+ MOVSI C,SPSAV-1(A)
+ HRRI C,SPSAV(TB)
+ BLT C,-1(TB) ;RESTORE ALL OF SAVE BLOCK BUT FSAV,
+ MOVEI C,-1(TB) ; OTBSAV, AND ABSAV
+ HRLS C
+ MOVE B,TPSAV(TB)
+ HLRE D,B
+ SUBI D,(B)
+ HRLZS D
+ ADD C,D ;C _ "-1(TB)"TPIFIED
+PSHLP6: CAML A,PP
+ JRST TPDON
+ GETYP B,-1(A) ;GOT TUPLE?
+ CAIN B,TTBS
+ JRST SKTUPL ;YES-- SKIP IT
+ PUSH C,-1(A)
+ PUSH C,(A)
+ARND2: CAMLE C,TP
+ MOVE TP,C ;PROTECT STACK FROM GARBAGE COLLECTION
+ UNBLOW TP
+ ADD A,[2,,2]
+ JRST PSHLP6
+SKTUPL: HRRE D,-1(A) ;D _ - LENGTH OF TUPLE
+ MOVNS D
+ HRLS D
+ ADD C,D ;SKIP!
+ ADD C,[2,,2] ;AND DON'T FORGET TTB
+ JRST ARND2
+TPDON: MOVE TP,C ;IN CASE TP TOO BIG
+ CAME TP,TPSAV(TB) ;CHECK THAT INBLK WORKED
+ JRST BADPP
+ MOVE C,OTBSAV(TB) ;RESTORE P STARTING FROM PREVIOUS
+ MOVE P,PSAV(C) ;FRAME
+
+;MOVE A P BLOCK BACK TO P
+
+USV2: MOVSI C,TFIX
+ MOVEM C,CSTO(PVP)
+\r SUB PP,(PP)
+ SUB PP,[2,,2] ;NOW BACK BEYOND TP BLOCK
+ GETYP A,-1(PP)
+ CAIE A,TFIX ;GET P BLOCK...
+ JRST CHPC2 ;...IF ANY
+ MOVE A,PP
+ SUB A,(PP) ;A POINTS TO FIRST
+PSHLP5: PUSH P,-1(A) ;MOVE BLOCK
+ ADD A,[1,,1]
+ UNBLOW P
+ CAMGE A,PP
+ JRST PSHLP5
+ SUB PP,(PP)
+ SUB PP,[3,,3] ;NOW AT NEXT PP "FRAME"
+ GETYP A,-1(PP)
+CHPC2: CAME P,PSAV(TB) ;MAKE SURE P RESTORED OKAY
+ JRST BADPP
+ CAIN A,TTP
+ JRST IFAIL
+ JRST BADPP
+
+;FRAME IS ALREADY ON THE STACK--- BINDINGS ONLY HASSLE
+
+MHFRAM: MOVE AB,ABSAV(TB) ;RESTORE ARGS POINTER
+ CAME SP,SPSAV(TB) ;AND ENVIRONMENT
+ PUSHJ P,SPECSTO
+ MOVSI A,TFIX
+ MOVEM A,ASTO(PVP)
+ SETZM FLFLG ;FLFLG _ OFF
+ INTGO ;HANDLE POSTPONED INTERRUPTS
+ SUB PP,[2,,2]
+ JRST @2(PP)
+
+;HERE TO PUSH TUPLE STARTING AT (C), OF LENGTH -D
+
+USVTUP: SKIPL D
+ POPJ P,
+ INTGO
+ PUSH TP,-1(C)
+ PUSH TP,(C)
+ UNBLOW TP
+ ADD C,[2,,2]
+ ADDI D,2
+ JRST USVTUP
+
+;DEFAULT MESSAGE IS <>
+
+MFALS: MOVSI B,TFALSE ;TYPE FALSE
+ MOVEM B,MESS(PVP)
+ SETZM MESS+1(PVP)
+
+
+;DEFAULT ACTIVATION IS <>, ALSO
+AFALS1: MOVSI B,TFALSE
+ MOVEM B,FACTI(PVP)
+\r SETZM FACTI+1(PVP)
+ JRST IFAIL
+
+;FALSE IS ALLOWED EXPLICITLY
+
+TAFALS: CAIE A,TFALSE
+ JRST WTYP
+ JRST SAVACT
+
+
+;FLAG FOR INTERRUPT SYSTEM
+
+FLFLG: 0
+
+;HERE TO UNBLOW P
+
+NBLOP: HRRZ E,P
+ HLRE B,P
+ SUBI E,-PDLBUF-1(P) ;E _ ADR OF REAL 2ND DOPE WORD
+ SKIPE PGROW
+ JRST PDLOSS ;SORRY, ONLY ONE GROWTH PER FAMILY
+ HRRM E,PGROW ;SET PGROW
+ JRST NBLO2
+
+;HERE TO UNBLOW TP
+
+NBLOTP: HRRZ E,TP ;MORE OR LESS THE SAME
+ HLRE B,TP
+ SUBI E,-PDLBUF-1(TP)
+ SKIPE TPGROW
+ JRST PDLOSS
+ HRRM E,TPGROW
+NBLO2: MOVEI B,PDLGRO_-6
+ DPB B,[111100,,-1(E)]
+ JRST AGC
+\fMFUNCTION FINALIZE,SUBR,[FINALIZE]
+ ENTRY
+ SKIPL AB ;IF NOARGS;
+ JRST GETTOP ;FINALIZE ALL FAILPOINTS
+ HLRE A,AB ;AT MOST ONE ARG
+ CAME A,[-2]
+ JRST WNA
+ PUSHJ P,TILLFM ;MAKE SURE ARG IS LEGAL
+ HRR B,OTBSAV(B) ;B _ FRAME BEFORE ACTIVATION
+RESTPP: MOVE PP,PPSAV(B) ;RESTORE PP
+ HRRZ A,TB ;IN EVERY FRAME
+FLOOP: CAIN A,(B) ;FOR EACH ONE,
+ JRST FDONE
+ MOVEM PP,PPSAV(A)
+ HRR A,OTBSAV(A)
+ JRST FLOOP
+FDONE: MOVE A,$TFALSE
+ MOVEI B,
+ JRST FINIS
+
+;TILLFM SETS B _ FIRST ARGUMENT IFF IT IS A LEGAL ACTIVATION
+
+TILLFM: HLRZ A,(AB) ;FIRST ARG MUST BE ACTIVATION
+ CAIE A,TACT
+ JRST WTYP
+ MOVE A,1(AB) ;WITH RIGHT TIME
+ HRR B,A
+ HLL B,OTBSAV(B)
+ HRRZ C,A ;AND PLACE
+ CAIG C,1(TP)
+ CAME A,B
+ JRST ILLFRA
+ GETYP C,FSAV(C) ;AND STRUCTURE
+ CAIE C,TENTRY
+ JRST ILLFRA
+ POPJ P,
+
+
+;LET B BE TOP LEVEL FRAME
+
+GETTOP: MOVE B,TPBASE+1(PVP) ;B _ BOTTOM OF TP
+ MOVEI B,FRAMLN+1(B) ;B _ TOP LEVEL FRAME
+ JRST RESTPP\fMFUNCTION FAILPOINT,FSUBR,[FAILPOINT]
+ ENTRY 1
+ GETYP A,(AB) ;ARGUMENT MUST BE LIST
+ CAIE A,TLIST
+ JRST WTYP
+ SKIPN C,1(AB) ;NON-NIL
+ JRST ERRTFA
+ PUSH TP,$TLIST ;SLOT FOR BODY
+ PUSH TP,[0]
+ PUSH TP,$TLIST
+ PUSH TP,[0]
+ PUSH TP,$TSP
+ PUSH TP,[0] ;SAVE SLOT FOR PRE-(MESS ACT) ENV
+ MOVE C,1(AB) ;GET SET TO CALL BINDER
+ MOVNI D,1 ;---AS A PROG
+ PUSHJ P,BINDER ;AND GO
+ HRRZ C,1(AB) ;SKIP OVER THINGS BOUND
+ TRNE A,H ;INCLUDING HEWITT ATOM IF THERE
+ HRRZ C,(C)
+ JUMPE C,NOBODY
+ HRRZ C,(C) ;C _ (EXPR (MESS ACT) -FAIL-BODY-)
+ JUMPE C,NOBODY
+ HRRZ A,(C) ;A _ ((MESS ACT) -FAIL-BODY-)
+ MOVEM A,1(AB) ;SAVE FOR FAILURE
+ MOVEM A,3(TB)
+ MOVE A,TP
+ SUB A,[5,,5]
+ PUSH PP,$TPC ;ESTABLISH FAIL POINT
+ PUSH PP,[FP]
+ PUSH PP,[TTP,,COP\ON]
+ PUSH PP,A ;SAVE LOCATION OF THIS FRAME
+ PUSH TP,(C)
+ HLLZS (TP)
+ PUSH TP,1(C)
+ JSP E,CHKARG
+ MCALL 1,EVAL ;EVALUATE EXPR
+ JRST FINIS ;IF SUCCESSFUL, DO NORMAL FINIS
+
+;FAIL TO HERE--BIND MESSAGE AND ACTIVATION
+
+FP: MOVEM SP,5(TB) ;SAVE SP BEFORE MESS AND ACT BOUND
+ HRRZ A,1(AB) ;A _ ((MESS ACT) -BODY-)
+ GETYP C,(A)
+ CAIE C,TLIST
+ JRST MPD
+ HRRZ C,1(A) ;C _ (MESS ACT)
+ JUMPE C,TFMESS ;IF (), THINGS MUST BE <>
+ PUSHJ P,CARATM ;E _ MESS
+ JRST MPD
+ PUSH TP,BNDA ;ELSE BIND IT
+ PUSH TP,E
+ PUSH TP,MESS(PVP)
+ PUSH TP,MESS+1(PVP)
+ PUSH TP,[0]
+ PUSH TP,[0]
+ HRRZ C,(C) ;C _ (ACT)
+ JUMPE C,TFACT ;IF (), ACT MUST BE <>
+ PUSHJ P,CARATM ;E _ ACT
+ JRST MPD
+ PUSH TP,BNDA ;BIND IT
+ PUSH TP,E
+ PUSH TP,FACTI(PVP)
+ PUSH TP,FACTI+1(PVP)
+ PUSH TP,[0]
+ PUSH TP,[0]
+BLPROG: PUSHJ P,PROGAT
+ HRRZ C,1(AB)
+ JRST STPROG
+TFMESS: GETYP A,MESS(PVP)
+ CAIE A,TFALSE
+ JRST IFAIL
+TFACT: GETYP A,FACTI(PVP)
+ CAIE A,TFALSE
+ JRST IFAIL
+ JRST BLPROG
+
+;THIS ROUTINE SETS E TO THE NEXT THING IN THE LIST C POINTS TO,
+;SKIPPING IFF IT IS AN ATOM
+
+CARATM: GETYP E,(C)
+ CAIE E,TATOM
+ POPJ P,
+ MOVE E,1(C)
+ AOS (P)
+ POPJ P,
+
+
+MFUNCTION RESTORE,SUBR,[RESTORE]
+
+ ENTRY
+ HLRE A,AB
+ MOVNS A
+ CAIG A,4 ;1 OR 2 ARGUMENTS
+ CAIGE A,2
+ JRST WNA
+ PUSHJ P,TILLFM ;B _ FRAME TO RESTORE (IF LEGAL)
+ HRRZ C,FSAV(B)
+ CAIE C,FAILPO ;ONLY FAILPOINTS RESTORABLE
+ JRST ILLFRA
+ PUSHJ P,SAVE ;RESTORE IT
+ SKIPN D,5(TB) ;ARE WE IN EXPR INSTEAD OF BODY?
+ JRST EXIT2 ;YES-- EXIT
+ MOVEM D,SPSAV(TB)
+ PUSHJ P,SPECSTO ;UNBIND MESS AND ACT
+ MOVE TP,TPSAV(TB)
+ MOVE P,PSAV(TB)
+ PUSH PP,$TPC
+ PUSH PP,[FP]
+ MOVE E,TP
+ SUB E,[5,,5]
+ PUSH PP,[TTP,,COP\ON] ;REESTABLISH FAILPOINT
+ PUSH PP,E
+EXIT2: HLRE C,AB
+ MOVNS C
+ CAIN C,4 ;VALUE GIVEN?
+ JRST RETRG2 ;YES-- RETURN IT
+ MOVE AB,ABSAV(TB) ;IN CASE OF GARBAGE COLLECTION
+ JRST IFALSE\f
+
+;ERROR COMMENTS FOR EVAL
+
+UNBOU: PUSH TP,$TATOM
+ PUSH TP,MQUOTE UNBOUND-VARIABLE
+ JRST ER1ARG
+
+UNAS: PUSH TP,$TATOM
+ PUSH TP,MQUOTE UNASSIGNED-VARIABLE
+ JRST ER1ARG
+
+TFA:
+ERRTFA: PUSH TP,$TATOM
+ PUSH TP,MQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
+ JRST CALER1
+
+TMA:
+ERRTMA: PUSH TP,$TATOM
+ PUSH TP,MQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
+ JRST CALER1
+
+BADENV:
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE BAD-ENVIRONMENT
+ JRST CALER1
+
+FUNERR:
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE BAD-FUNARG
+ JRST CALER1
+
+WRONGT:
+WTYP: PUSH TP,$TATOM
+ PUSH TP,MQUOTE WRONG-TYPE
+ JRST CALER1
+
+MPD: PUSH TP,$TATOM
+ PUSH TP,MQUOTE MEANINGLESS-PARAMETER-DECLARATION
+ JRST CALER1
+
+NOBODY: PUSH TP,$TATOM
+ PUSH TP,MQUOTE HAS-EMPTY-BODY
+ JRST CALER1
+
+BADCLS: PUSH TP,$TATOM
+ PUSH TP,MQUOTE BAD-CLAUSE
+ JRST CALER1
+
+NXTAG: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NON-EXISTENT-TAG
+ JRST CALER1
+
+NXPRG: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NOT-IN-PROG
+ JRST CALER1
+
+NAPT: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NON-APPLICABLE-TYPE
+ JRST CALER1
+
+NONEVT: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NON-EVALUATEABLE-TYPE
+ JRST CALER1
+
+
+NONATM: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NON-ATOMIC-ARGUMENT
+ JRST CALER1
+
+
+ILLFRA: PUSH TP,$TATOM
+ PUSH TP,MQUOTE FRAME-NO-LONGER-EXISTS
+ JRST CALER1
+
+NOTIMP: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NOT-YET-IMPLEMENTED
+ JRST CALER1
+
+ILLSEG: PUSH TP,$TATOM
+ PUSH TP,MQUOTE ILLEGAL-SEGMENT
+ JRST CALER1
+
+BADPP: PUSH TP,$TATOM
+ PUSH TP,MQUOTE PP-IN-ILLEGAL-CONFIGURATION
+ JRST CALER1
+
+
+BDFAIL: PUSH TP,$TATOM
+ PUSH TP,MQUOTE OVERPOP--FAIL
+ JRST CALER1
+
+
+ER1ARG: PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MOVEI A,2
+ JRST CALER
+CALER1: MOVEI A,1
+CALER:
+ HRRZ C,FSAV(TB)
+ PUSH TP,$TATOM
+ PUSH TP,@-1(C)
+ ADDI A,1
+ ACALL A,ERROR
+ JRST FINIS
+
+END
+***\f\ 3\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff