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

; 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,
	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

;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)
;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
	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

;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	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
	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;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 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;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.

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,



;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

	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,




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

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




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,

;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
	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)

	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)

	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,[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

;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
***