X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=blobdiff_plain;f=MUDDLE%2Fneval.222;fp=MUDDLE%2Fneval.222;h=b59a860f2535049c72d2e4771736d5eb19af7c96;hp=0000000000000000000000000000000000000000;hb=39c5769144e7f2a58076bdb973d2c80fa603345c;hpb=bab072f950a643ac109660a223b57e635492ac25

diff --git a/MUDDLE/neval.222 b/MUDDLE/neval.222
new file mode 100644
index 0000000..b59a860
--- /dev/null
+++ b/MUDDLE/neval.222
@@ -0,0 +1,2966 @@
+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,SPCSTE,CNTIN2
+
+.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
+
+; 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
+
+
+
+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]]
+
+;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MFUNCTION 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,MFUNCTION 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,
+	MOVEI	B,ARGNEV	;ARGS NOT EVALED
+	JRST	IAPPL1
+
+IAPPLY:	MOVSI	A,TLIST
+	PUSH	TP,A
+	HRRZ	B,@1(AB)
+	PUSH	TP,B
+	HRRZ	0,1(AB)		;0 _ CALL
+	MOVEI	B,ARGEV		;ARGS TO BE EVALED
+IAPPL1:	GETYP	A,(TB)
+	CAIN	A,TEXPR		;EXPR?
+	JRST	APEXPR		;YES
+	CAIN	A,TFSUBR	;NO -- FSUBR?
+	JRST	APFSUBR		;YES
+	CAIN	A,TFUNARG	;NO -- FUNARG?
+	JRST	APFUNARG	;YES
+	CAIN	A,TPVP		;NO -- PROCESS TO BE RESUMED?
+	JRST	NOTIMP		;YES
+	SUBI	B,ARGNEV	;B _ 0 IFF NO EVALUATION
+	PUSH	P,B		;PUSH SWITCH
+	CAIN	A,TSUBR		;NO -- SUBR?
+	JRST	APSUBR		;YES
+	CAIN	A,TFIX		;NO -- CALL TO NTH?
+	JRST	APNUM		;YES
+	CAIN	A,TACT		;NO -- ACTIVATION?
+	JRST	APACT		;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
+
+;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)
+
+APEXPR:
+
+	SKIPN	C,1(TB)		;BODY?
+	JRST	NOBODY		;NO, ERROR
+	MOVE	D,(TP)		;D _ ARG LIST
+	SETZM	(TP)		;ZERO (TP) FOR BODY
+	PUSH	P,[0]		;SWITCHES OFF
+	PUSH	P,B		;ARGS EVALER OR NON-EVALER
+	PUSHJ	P,BINDER	;DO THE BINDINGS
+
+	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)
+;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
+;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,;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,;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
+
+;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
+
	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
+
+
+;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.
+
+
IGLOC:	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,
+
+
+
+
+;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
+
+
+MFUNCTION 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
+	MOVEI	D,		;ASSUME AUX
+	PUSH	P,[AUX]
+	GETYP	A,A
+	CAIN	A,TFALSE	;CAN BE #FALSE OR LIST
+	JRST	DOBI		;IF <>, AUXILIARY BINDINGS
+	PUSHJ	P,SAT		;OTHERWISE, TAKE SECOND ARG AS ARGLIST
+	CAIE	A,S2WORD
+	JRST	WTYP
+	MOVEI	D,(B)		;D _ DECLARATIONS
+	SETZM	(P)		;CLEAR SWITCHES
+DOBI:	POP	TP,C		;RESTORE C _ FIRST ARG
+	SUB	TP,[1,,1]
+	MOVEI	0,		;NO CALL
+	PUSHJ	P,BINDEV
+	HRRZ	C,1(AB)
+	HRRZ	C,(C)
+	HRRZ	C,(C)		;C _ <REST <REST .ARG>>
+	JRST	BIPROG		;NOW EXECUTE BODY AS PROG;BINDER - THIS SUBROUTINE PROCESSES FUNCTION DECLARATIONS AND BINDS
+;	ARGUMENTS	AND TEMPORARIES APPROPRIATELY.
+;	
+;	CALL:	PUSHJ	P,BINDER OR BINDRR
+;
+;	BINDER - TAKES SWITCHES AND EVALER AS ARGS ON P
+;
+;	BINDEV - 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
+;	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==-2
+
+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
+STC==40		;ON IFF "STACK" APPEARS IN DECLARATIONS
+BINDEV:	POP	P,A		;A _ RETURN ADDRESS
+	PUSH	P,[ARGEV]
+	JRST	BIND1
+BINDRR:	POP	P,A
+	PUSH	P,[NOTIMP]
+BIND1:	PUSH	P,A		;REPUSH ADDRESS
+BINDER:	PUSH	TP,$TLIST
+	PUSH	TP,0		;SAVE CALL, IF ANY
+	PUSHJ	P,BNDVEC	;E _ TOP OF BINDING STACK
+	GETYP	A,(C)
+	CAIE	A,TATOM		;HEWITT ATOM?
+	JRST	BIND2
+	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	TP,0		;0 _ CALLING EXPRESSION
+	SUB	TP,[1,,1]
+	PUSHJ	P,CARLST	;C _ DECLS LIST
+	JRST	BINDC		;IF (), QUIT
+	MOVE	B,SWTCHS(P)
+	TRNE	B,STC		;CDR PAST "STACK" IF IT APPEARS
+	HRRZ	C,(C)
+	TRNE	B,AUX
+	JRST	AUXDO		;IN CASE OF PROG, GO TO AUXDO
+	MOVEI	A,(C)
+	JUMPE	A,BINDC		;IF NO DECLS, TRY QUITTING
+	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	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;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;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
+;"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
+	ADD	E,[2,,2]	;E _ POINTER TO SECOND WORD OF NEXT BLOCK
+	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:	SUB	P,[2,,2]	;FLUSH EVALER
+	POP	P,A		;A _ SWITCHES
+	JRST	@3(P)		;RETURN FROM BINDER;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;THIS ROUTINE CREATES THE BIND BLOCK 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.
+
+;THE BLOCK IS ALLOCATED AS A TUPLE IF "STACK" APPEARS
+;FIRST IN THE DECLARATIONS, AS A VECTOR OTHERWISE
+
+
+;BNDVEC SETS E TO THE CURRENT TOP OF THE BLOCK; IT FILLS IN
+;ACCESS SLOT WITH SP, AND SETS SP TO POINT TO
+;THE START OF THIS BLOCK.  IT SETS B TO POINT TO THE DOPE CELL 
+;OF THE TUPLE OR VECTOR.  IT MAY SET SWITCHES H OR STC TO ON,
+;IFF IT FINDS A HEWITT ATOM OR A "STACK".  IT CLOBBERS A,
+;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-1(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
+	PUSHJ	P,NXTDCL	;LOOK FOR "STACK"
+	JRST	DINC		;NO STRING
+	TRZ	B,1
+	CAMN	B,[ASCII /STACK/]
+	TRO	0,STC		;TURN ON STACK SWITCH
+
+;HERE IS THE QUICK LOOP THROUGH THE DECLARATIONS
+
+DCNTLP:	HRRZ	A,(A)		;CDR DECLS
+	JUMPE	A,CNTRET	;IF NO MORE, DONE
+	PUSHJ	P,NXTDCL	;SKIP IF NEXT ONE IS A STRING
+DINC:	ADDI	D,3		;3 SLOTS FOR AN ATOM
+	JRST	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-1(P)	;SAVE SWITCHES
+	TRNE	0,STC		;FOUND "STACK"?
+	JRST	TUPBND
+	PUSH	TP,$TFIX
+	PUSH	TP,D
+	MCALL	1,VECTOR	;B _ <VECTOR .D>
+	MOVE	E,B		;FROM NOW ON, E _ BIND VECTOR TOP
+	HLRE	C,B
+	SUB	B,C		;B _ VECTOR DOPE CELL ADDRESS
+SETSP:	MOVE	A,E
+	MOVSI	0,TSP
+	MOVEM	0,(E)		;FILL ACCESS SLOT
+	PUSH	E,SP
+	MOVE	SP,A		;SP NOW POINTS THROUGH THIS VECTOR
+	MOVE	D,(TP)		;RESTORE C & D
+	MOVE	C,-2(TP)
+	SUB	TP,[4,,4]
+	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,[6,,6]
+	SUB	P,[1,,1]	;PITCH RETURN ADDRESS
+	JRST	BNDRET;HERE TO BIND BUGGERS ON STACK
+
+TUPBND:	LSH	D,1		;D _ 2*NUMBER OF CELLS
+	MOVN	C,D		;SAVE -D ON P
+	PUSH	P,C
+	ADDI	D,2		;2 MORE FOR TTB MARKER
+	HRLI	D,(D)
+	MOVE	C,TP
+	ADD	TP,D		;TP _ ADDRESS OF LAST TUPLE WORD
+	ADD	C,[1,,1]	;C _ ADDRESS OF FIRST WORD OF TUPLE
+	MOVSI	0,TTP
+	MOVEM	0,CSTO(PVP)	;IN CASE OF GC
+	SETZM	(C)		;ZERO IT
+	MOVE	D,C
+	HRLI	D,(D)
+	ADDI	D,1		;ZERO ENTIRE TUPLE SPACE
+	HRRZI	E,(TP)		;BUT--
+	HLRE	B,TP		;   IF TP BLOWN,
+	SKIPLE	B		;    ZERO ONLY UP TO END OF PDL
+	SUBI	E,1(B)
+	BLT	D,(E)
+	SKIPL	TP		;IF BLOWN,
+	PUSHJ	P,NBLOTP	;NOW SAFE TO UNBLOW IT
+	SETZM	CSTO(PVP)
+	MOVEI	D,-5(TP)
+	HRLI	D,-6(C)
+	BLT	D,(TP)		;MOVE SAVED 0, C & D TO TOP OF STACK
+	POP	P,D
+	HRLI	D,TTB		;D _ [TTB,,-LENGTH]
+	MOVEI	B,-7(TP)	;B _ POINTER TO TUPLE DOPE CELL
+	MOVEM	D,(B)
+	MOVEM	TB,1(B)	;FENCEPOST TUPLE
+	MOVE	E,C		;E _ POINTER TO TUPLE START
+	SUB	E,[6,,6]	;     ON TP STACK
+	HLRE	D,C
+	SUB	C,D		;C = DOPE WORD POINTER?
+	CAME	C,TPGROW"
+	ADD	E,[-PDLBUF,,0]	;MAKE E TRUE VECTOR POINTER
+	JRST	SETSP;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,;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
+;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,
+
+
+
+;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,;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.
+;FOR ENTRY SPECB1, REGISTER 0 CONTAINS SWITCHES.  ONLY RELEVANT ONE
+;IS STC.
+
+
+BNDA:	TATOM,,-1
+
+SPECBIND:	MOVEI	0,		;DEFAULT IS STC _ OFF
+SPECB1:	MOVE	E,TP		;GET THE POINTER TO TOP
+	ADD	E,[1,,1]	;BUMP POINTER ONCE
+	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]	;D _ ADDRESS OF BOTTOM BLOCK
+	ADDI	B,3
+	JRST	SZLOOP
+GETVEC:	JUMPE	B,DEGEN
+	TRNE	0,STC		;IF STC IS ON,
+	JRST	TPSPCB		;    LEAVE BLOCKS ON TP
+	PUSH	P,B
+	AOJ	B,
+	PUSH	TP,$TTP
+	PUSH	TP,E
+	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
+	HRRI	C,-2(B)		;C = LINK _ ADR OF FIRST OF VECTOR
+	PUSH	P,[POPOFF]
+LNKBLK:	HRLI	C,TBIND
+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
+	POPJ	P,
+
+;CLEAN UP TP
+
+POPOFF:	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]
+	JRST	SPCBE2
+
+;HERE TO JUST BIND THE LOSERS ON THIS STACK
+
+TPSPCB:	AOJ	B,
+	PUSH	TP,$TSP		;PUSH ACCESS POINTER
+	MOVE	E,TP
+	PUSH	TP,SP
+	LSH	B,1
+	MOVN	B,B		;B _ -2B
+	HRLI	B,TTB
+	PUSH	TP,B		;FENCEPOST BIND TRIPLES AS TUPLE
+	PUSH	TP,TB
+	HRRZ	B,D
+	HRRI	C,-3(TP)
+	PUSHJ	P,LNKBLK	;LINK BIND BLOCKS TOGETHER
+	HLRE	C,D		;MAKE E A REAL VECTOR POINTER
+	SUB	D,C
+	CAME	C,TPGROW"	;BY FINDING REAL DOPE WORD
+	ADD	E,[-PDLBUF,,0]
+
+;HERE TO BIND EVERYTHING IN BLOCK 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,
+
+
+
+;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN 
+;SPSAV (TB).  IT IS CALLED BY PUSHJ P,SPECSTORE.
+
+SPECSTORE:
+	MOVE	E,SPSAV (TB)	;GET TARGET POINTER
+SPCSTE:	HRRZ	SP,SP		;CLEAR LEFT HALF OF SP
+STLOOP:
+	CAIN	SP,(E)		;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
+
	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:	HRRZ	SP,1(SP)
+	JUMPN	SP,STLOOP
+	JUMPE	E,STPOPJ	;UNLESS THAT'S AS FAR AS WE WANTED TO GO
+	.VALUE	[ASCIZ /SPOVERPOP/]
+
+STPOPJ:
+	MOVE	SP,E
+	POPJ	P,
+
+
+
+
+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
+	MOVE	C,3(TB)		;PROG BODY
+	MOVEI	D,
+	PUSH	P,[AUX]		;TELL BINDER WE ARE APROG
+	PUSHJ	P,BINDEV
+	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.
+	MOVE	0,A		;SWITCHES TO 0
+BLPROG:	PUSHJ	P,PROGAT	;BIND OBSCURE ATOM
+	MOVE	C,3(TB)
+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	CNTIN2
+
+;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	SPECB1
+
+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	CNTIN2
+
+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	CNTIN2
+
+
+
+
+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:	MOVE	E,SPSAV(B)
+	PUSHJ	P,SPCSTE	;RESTORE BINDINGS IF NECESSARY
+	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,
+
+;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,
+
+
+
+
+;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,
+
+
+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
+
+
+
+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
+;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
+MFUNCTION 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
+	SKIPA	D,-5(C)		;FIND REBIND POINTER
+BLOOP5:	HRRZ	D,(D)		;D _ NEXT BIND BLOCK
+	GETYP	0,(D)
+	CAIE	0,TSP		;LOOK FOR REBINDER
+	JRST	BLOOP5
+	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)
+
	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,
+	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)
+
	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
+MFUNCTION 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MFUNCTION 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,TP		;SAVE SLOT FOR PRE-(MESS ACT) ENV
+	MOVE	C,1(AB)		;GET SET TO CALL BINDER
+	MOVEI	D,0
+	PUSH	P,[AUX]		;---AS A PROG
+	PUSHJ	P,BINDEV	;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,3(TB)
+	MOVE	A,5(TB)
+	SUB	A,[4,,4]
+	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,3(TB)		;A _ ((MESS ACT) -BODY-)
+	GETYP	C,(A)
+	CAIE	C,TLIST
+	JRST	MPD
+	MOVEI	0,
+	HRRZ	A,1(A)		;C _ (MESS ACT)
+	JUMPE	A,TFMESS	;IF (), THINGS MUST BE <>
+	PUSHJ	P,NXTDCL	;CHECK FOR "STACK"
+	JRST	NOSTAC
+	TRZ	B,1
+	CAME	B,[ASCII /STACK/]
+	JRST	MPD
+	TRO	0,STC		;FOUND,  TURN ON STC SWITCH
+	HRRZ	C,(A)
+	JUMPE	C,TFMESS	;IF ONLY "STACK", MUST HAVE FALSE MESSAGE
+NOSTAC:	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]
+	JRST BLPROG
+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,TB
+	HRLS	E
+	MOVE	C,TPSAV(E)
+	HLRE	B,C
+	SUBI	B,(C)
+	HRLZS	B
+	ADD	E,B		;CONVERSION TO TTP
+	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
+
+;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
+***
\ No newline at end of file