TITLE EVAL -- MUDDLE EVALUATOR

RELOCATABLE

; GERALD JAY SUSSMAN, 1971

.GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME
.GLOBAL IGVAL,CHKARG,SWAP,NXTDCL,TPOVFL,CHFRM
.GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA
.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS

.INSRT MUDDLE >

	MFUNCTION	EVAL,SUBR
	INTGO
	HLRZ	A,AB		;GET NUMBER OF ARGS
	CAIE	A,-2		;EXACTLY 1?
	JRST	AEVAL		;EVAL WITH AN ALIST
	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
	CAME	A,$TUNBOUND	;IF NOT UNBOUND OR UNASSIGNED
	JRST	RIDVAL		;DONE - CLEAN UP AND RETURN
	JUMPN	B,UNAS		;IF UNASSIGNED - ERROR
	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
	PUSHJ	P,ILVAL
	CAME	A,$TUNBOUND
	JRST	FINIS
	JUMPN	B,UNAS
	JRST	UNBOU


; 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
	CAME	A,$TUNBOUND
	JRST	TRUTH
	JUMPE	B,UNBOU
	JRST	IFALSE

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

;DISPATCH TABLE FOR EVAL
DISTBL EVTYPT,SELF,[[TLIST,EVLIST],[TFORM,EVFORM],[TVEC,EVECT],[TSEG,ILLSEG],[TUVEC,EUVEC]]



;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR PROCID
AEVAL:
	CAIE	A,-4		;EXACTLY 2 ARGS?
	JRST	WNA		;NO-ERROR
	HLRZ	A,2(AB)		;CHECK THAT WE HAVE A FRAME
	CAIN	A,TFRAME
	JRST	.+3
	CAIE	A,TENV
	JRST	WTYP
	MOVE	A,3(AB)
	HRRZ	D,2(AB)		;GET POINTER TO PV DOPE WORD
	PUSHJ	P,SWAPQ		;SEE IF SWAP NECESSARY
	PUSH	TP,(D)
	PUSH	TP,1(D)
	MCALL	1,EVAL		;NOW DO NORMAL EVALUATION
UNSWPQ:	MOVE	D,1(TB)		;GET SAVED PVP
	CAMN	D,PVP		;CHANGED?
	JRST	FINIS		;NO - RETURNî	PUSHJ	P,SPECSTORE	;CLEAN UP
	MOVE	D,1(TB)
	JSP	C,SWAP
	JRST	FINIS


; ROUTINE TO CHANGE PROCID AND POSSIBLY SWAP

SWAPQ:	HLRZ	C,(D)		;GET LENGTH
	SUBI	D,-1(C)		;POINT TO START OF PV
	MOVNS	C		;NEGATE LENGTH
	HRLI	D,2(C)		;MAKE AOBJN POINTER
	MOVE	E,PVP		;COPY CURRENT PROCESS VECTOR
	POP	P,B		;GET RET ADR SO POPJ WINS IF SWAP OCCURS
	CAME	D,PVP		;IS THIS IT?
	JSP	C,SWAP		;NO, SWAP IN NEW PROCESS
	PUSH	P,B		;NOW, PUT IT BACK
	PUSH	TP,$TPVP	;SAVE PROCESS
	PUSH	TP,E
	HLL	B,OTBSAV(A)	;GET TIME FROM FRAME POINTED AT
	HRR	B,A
	HRRZ	C,A
	CAIG	C,1(TP)
	CAME	B,A		;CHECK THAT THE FRAME IS LEGIT
	JRST	ILLFRA
	HLRZ	C,FSAV(C)
	CAIE	C,TENTRY
	JRST	ILLFRA
	CAMN	SP,SPSAV(A)
	JRST	AEV1
	MOVE	SP,SPSAV(A)	;LOAD UP OLD ENVIRONMENT
	MOVE	A,PVP
	ADD	A,[PROCID,,PROCID]	;GET LOCATIVE TO PROCESS ID
	PUSH	TP,BNDV		;BIND IT TO
	PUSH	TP,A
	AOSN	A,PTIME		;A UNIQUE NUMBER
	.VALUE	[ASCIZ /TIMEOUT/]
	PUSH	TP,$TFIX
	PUSH	TP,A
	PUSHJ	P,SPECBIND
AEV1:	MOVE	E,1(TB)		;GET SAVED PROCESS
	MOVE	D,AB		;COPY CURRENT ARG POINTER
	CAME	E,PVP		;HAS PROCESS CHANGED?
	MOVE	D,ABSTO+1(E)	;GET SAV AB
	POPJ	P,		;RETURN TO CALLER


; STACKFRAME FUNCTION (MUDDLE'S ANSWER TO APPLY)

	MQUOTE STACKFORM

STFRM2:	JRST	NOENV		;FAKE OUT ENTRY

MFUNCTION STACKFORM,FSUBR

	ENTRY	1

	GETYP	A,(AB)		;CHECK IT IS A LIST
	CAIE	A,TLIST
	JRST	WTYP		;NO, LOSE

	MOVEI	A,3		;CHECK ARG HAS AT LEAST 3 ELEMENTS
	HRRZ	B,1(AB)	;GET ARG
	JUMPE	B,TFA
	HRRZ	B,(B)		;CDR IT
	SOJN	A,.-2		;AND COUNT

	JUMPE	B,NOENV		;ENVIRONMENT NOT SUPPLIED
	HRRZ	A,(B)		;CHECK NOT TOO MANY
	JUMPN	A,TMA

	GETYP	A,(B)		;GET TYPE OF LAST ARG
	MOVSI	A,(A)		;TYPE TO LH
	PUSH	TP,A
	PUSH	TP,1(B)		;PUSH THE ARG
	JSP	E,CHKARG		;CHECK FOR DEFERRED
	MCALL	1,EVAL
	HLRZ	C,A		;ISOLATE TYPE IN C
	CAIE	C,TENV		;ENVIRONEMNT?
	CAIN	C,TFRAME	;OR FRAME?
	JRST	.+2
	JRST	WTYP


	MOVEI	D,(A)		;IN B AND D
	MOVE	A,B		;AND TIME,,FRAME
	PUSHJ	P,SWAPQ		;AND CHECK FOR CHANGE
	PUSH	TP,$TLIST	;SAVE THE ARG
	PUSH	TP,1(D)		;ON TP
	.MCALL	1,STFRM2	;NOW CALL NON-ENV STACKFORM
	JRST	UNSWPQ		;AND POSSIBLY UNSWAP

NOENV:	HRRZ	D,1(AB)		;GET POINTER TO FIRST
	GETYP	A,(D)		;GET TYPE
	MOVSI	A,(A)
	PUSH	TP,A
	PUSH	TP,1(D)		;PUSH THE ARG, (IT SHOULD BE A FUNCTION)
	JSP	E,CHKARG	;CHECK OUT DEFERRED
	MCALL	1,EVAL		;EVAL IT
	HRRZ	C,1(AB)		;RESTORE ARG
	HRRZ	D,(C)		;POINT TO LIST OF FORMS
	PUSH	TP,A		;SAVE FUNCTION
	PUSH	TP,B
	HLRZS	A		;NOW DISPATCH ON TYPE
	CAIN	A,TSUBR;SUBR?
	JRST	STSUBR		;YES, HACK IT
	CAIN	A,TEXPR		;FUNCTION?
	JRST	STEXPR		;YES DO IT
	CAIN	A,TFUNARG		;FUNARG
	JRST	NOTIMP
	JRST	NAPT


; STACK FORM OF A SUBR

STSUBR:	PUSH	P,[0]		;PUSH ARG COUNTER

STLOO:	PUSHJ	P,EVALRG		;EVAL THE ARGUMENT
	JRST	MAKPTR		;DONE, FALL INTO EVAL CODE
	AOS	(P)		;COUNT
	PUSH	TP,A
	PUSH	TP,B		;SAVE THE ARGS
	JRST	STLOO

; STACK FRAME OF EXPR

STEXPR:	MOVE	C,(TP)		;GET FUNCTION
	PUSHJ	P,BINDRS		;BIND THE ARGS
	JRST	APEXP1		;JOIN COMMON CODE



IAPPLY:
	HLRZ	A,(TB)		;GET TYPE OF FUNCTION
	CAIN	A,TSUBR		;SUBR?
	JRST	APSUBR		;YES
	CAIN	A,TFSUBR	;NO -- FSUBR?
	JRST	APFSUBR		;YES
	CAIN	A,TEXPR		;NO -- EXPR?
	JRST	APEXPR		;YES
	CAIN	A,TFIX		;NO -- CALL TO NTH?
	JRST	APNUM		;YES
	CAIN	A,TFUNARG	;NO -- FUNARG?
	JRST	APFUNARG	;YES
	CAIN	A,TPVP		;NO -- PROCESS TO BE RESUMED?
	JRST	RESOMER		;YES
	JRST	NAPT		;NONE OF THE ABOVE


;APFSUBR CALLS FSUBRS

APFSUBR:
	PUSH	TP,$TLIST	;GET THE
	HRRZ	A,@1(AB)
	PUSH	TP,A		;ARGUMENT LIST
	MCALL	1,@1(TB)
	JRST	FINIS

;APSUBR CALLS SUBRS

APSUBR:	
	HRRZ	A,@1(AB)	;GET CDR OF FORM -- ARGLIST
	PUSH	TP,$TLIST	;SAVE THE ARGLIST ON
	PUSH	TP,A		;THE TP
	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
	MCALL	1,EVAL		;AND EVAL IT.
	PUSH	TP,A		;SAVE THE RESULT IN
	PUSH	TP,B		;THE GROWING TUPLE
	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



;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET

APNUM:
	HRRZ	A,@1(AB)	;GET ARGLIST
	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
	MCALL	1,EVAL
	PUSH	TP,A
	PUSH	TP,B
	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
	HRRZ	0,1(AB)		;GET EXPRESSION INTO 0
	HRRZ	D,@0		;AND ARGLIST INTO D
	HLL	0,(AB)		;TYPE TO LH OF 0

	PUSHJ	P,BINDER	;DO THE BINDINGS

APEXP1:	HRRZ	C,@1(TB)	;GET BODY BACK
	JUMPE	A,DOPROG	;NOW GO RUN IF NO ACTIVIATION
	PUSH	TP,$TLIST	;SAVE ANOTHER COPY FOR REACT
	PUSH	TP,C
	SKIPL	A		;SKIP IF NOT NAME ALA HEWITT
	HRRZ	C,(C)		;ELSE CDR AGAIN
	JRST	DOPROG



RESOMER:
; 0,1(TB) IS PROCESS VECTOR POINTER TO PROCESS TO BE RESUMED
; 0,1(AB) IS A FORM CONTAINING ARGS TO SAVED FUNTION

	MOVE	D,1(TB)		;GET PVP OF PROCESS TO BE RESUMED
	GETYP	A,RESFUN(D)	; GET TYPE OF FUNCTION

	CAIN	A,TSUBR		;SUBR?
	JRST	RESSUBR		;YES
	CAIN	A,TFSUBR	;NO -- FSUBR?
	JRST	RESFSUBR		;YES
	CAIN	A,TEXPR		;NO -- EXPR?
	JRST	RESEXPR		;YES
	CAIN	A,TFIX		;NO -- CALL TO NTH?
	JRST	RESNUM		;YES
	CAIN	A,TFUNARG	;NO -- FUNARG?
	JRST	NOTIMP	;YES
	JRST	NAPT		;NONE OF THE ABOVE


;RESFSUBR RESUMES FSUBRS

RESFSUBR:
	HRRZ	A,@1(AB)	;GET THE ARG LIST
	SUB	TP,[2,,2]	;CLEAN UP
	JSP	C,SWAP		;SWAP IN NEW PROCESS
	PUSH	TP,$TLIST
	PUSH	TP,A		; PUSH THE ARG LIST
	MCALL	1,@RESFUN+1(PVP) ; RESUME WITH THE SAVED FUNCTION
	JRST	FINIS

;RESSUBR RESUMES SUBRS

RESSUBR:	
	HRRZ	A,@1(AB)	;GET CDR OF FORM -- ARGLIST
	PUSH	TP,$TLIST	;SAVE THE ARGLIST ON
	PUSH	TP,A		;THE TP
	PUSH	P,[0]		;MAKE SLOT FOR ARGCNT
RESTUPLUP:
	SKIPN	A,3(TB)		;IS IT NIL?
	JRST	RESMAKPTR		;YES -- DONE
	PUSH	TP,(A)		;NO -- GET CAR OF THE
	HLLZS	(TP)		;ARGLIST
	PUSH	TP,1(A)
	JSP	E,CHKARG
	MCALL	1,EVAL		;AND EVAL IT.
	MOVE	D,1(TB)	;GET PVP OF P.T.B.R.
	MOVE	C,TPSTO+1(D)	;GET TP OF P.T.B.R.
	PUSH	C,A		;SAVE THE RESULT IN THE GROWING
	PUSH	C,B		;TUPLE OF ARGS IN P.T.B.R.
	MOVEM	C,TPSTO+1(D)	;UPDATE TP OF P.T.B.R.
	AOS	(P)		;BUMP THE ARGCNT
	HRRZ	A,@3(TB)	;SET THE ARGLIST TO 
	MOVEM	A,3(TB)		;CDR OF THE ARGLIST
	JRST	RESTUPLUP
RESMAKPTR:
	POP	P,A		;GET NUMBER OF ARGS IN A	
	MOVE	D,1(TB)		;GET PVP OF P.T.B.R.
	SUB	TP,[4,,4]	;GET RID OF GARBAGE
	JSP	C,SWAP		;SWAP IN THE NEW PROCESS
	ACALL	A,RESFUN+1(PVP) ;CALL THE SAVED FUNCTION
	JRST	FINIS



;RESNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET

RESNUM:
	HRRZ	A,@1(AB)	;GET ARGLIST
	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
	MCALL	1,EVAL
	MOVE	D,1(TB)		;GET PVP OF P.T.B.R.
	MOVE	C,TPSTO+1(D)	;GET TP OF P.T.B.R.
	PUSH	C,A		;PUSH ARG
	PUSH	C,B
	SUB	TP,[2,,2]	;CLEAN UP BEFORE LEAVING
	JSP	C,SWAP		;BRING IN NEW PROCESS
	PUSH	TP,RESFUN(PVP)	;PUSH NUMBER
	PUSH	TP,RESFUN+1(PVP)
	MCALL	2,NTH
	JRST	FINIS

;RESEXPR RESUMES EXPRS
;EXPRESSION IS IN 0(AB),  FUNCTION IS IN RESFUN(PVP)
RESEXPR:
	SKIPN	C,RESFUN+1(D);BODY?
	JRST	NOBODY		;NO, ERROR

	MOVE	C,TPSTO+1(D)	;GET TP OF P.T.B.R.
	PUSH	C,BNDA		;SPECIAL ATOM CROCK
	PUSH	C,MQUOTE [PPROC ]INTERR ;PPROC=PARENT PROCESS
	MOVE	B,OTBSAV(TB)
	PUSHJ	P,MAKENV	;MAKE ENVIRONMENT FOR THIS PROCESS
	PUSH	C,A
	PUSH	C,B
	MOVEM	C,TPSTO+1(D)	;UPDATE TP OF P.T.B.R.
	HRRZ	0,1(AB)		;GET EXPRESSION INTO 0
	HRRZ	A,@0		;AND ARGLIST INTO A
	HLL	0,(AB)		;TYPE TO LH OF  0
	SUB	TP,[2,,2]	;CLEAN UP BEFORE LEAVING
	JSP	C,SWAP		;SWAP IN NEW PROCESS
	PUSH	P,0		;SAVE 0
	PUSH	P,A		;SAVE A=ARGLIST
	PUSH	TP,[0]
	PUSH	TP,[0]		;COMPLETE ARGS FOR PPROC BINDING
	PUSHJ	P,SPECBIND	;BIND THE PARENT PROCESS
	POP	P,D		;POP ARGLIST INTO D
	POP	P,0		;POP CALL HACK INTO 0
	MOVE	C,RESFUN+1(PVP)	;GET FUNCTION
	PUSHJ	P,BINDRR	;CALL BINDER FOR RESUMED EXPR HACKING

	HRRZ	C,@RESFUN+1(PVP) ;GET BODY BACK
	JUMPE	A,DOPROG	;NOW GO RUN IF NO ACTIVIATION
	PUSH	TP,$TLIST	;SAVE ANOTHER COPY FOR REACT
	PUSH	TP,C
	SKIPL	A		;SKIP IF NOT NAME ALA HEWITT
	HRRZ	C,(C)		;ELSE CDR AGAIN
	JRST	DOPROG


; EVALUATE LISTS, VECTORS, UNIFROM VECTORS

EVLIST:	PUSH	P,[-1]		;-1 -- THIS IS A LIST
	JRST	EVL1		;GO TO HACKER

EVECT:	PUSH	P,[0]		;0 -- THIS IS A GENERAL VECTOR
	JRST	EVL1

EUVEC:	PUSH	P,[1]		;1 -- THIS IS A UNIFORM VECTOR

EVL1:	PUSH	P,[0]		;PUSH A COUNTER
	GETYPF	A,(AB)		;GET FULL TYPE
	PUSH	TP,A
	PUSH	TP,1(AB)	;AND VALUE

EVL2:	INTGO			;CHECK INTERRUPTS
	SKIPN	A,1(TB)		;ANYMORE
	JRST	EVL3		;NO, QUIT
	SKIPL	-1(P)		;SKIP IF LIST
	JUMPG	A,EVL3		;JUMP IF VECTOR EMPTY
	GETYPF	B,(A)		;GET FULL TYPE
	SKIPGE	C,-1(P)		;SKIP IF NOT LIST
	HLLZS	B		;CLOBBER CDR FIELD
	JUMPG	C,EVL7		;HACK UNIFORM VECS
EVL8:	PUSH	P,B		;SAVE TYPE WORD ON P
	CAMN	B,$TSEG		;SEGMENT?
	MOVSI	B,TFORM		;FAKE OUT EVAL
	PUSH	TP,B		;PUSH TYPE
	PUSH	TP,1(A)		;AND VALUE
	MCALL	1,EVAL		;AND EVAL IT
	POP	P,C		;AND RESTORE REAL TYPE
	CAMN	C,$TSEG		;SEGMENT?
	JRST	DOSEG		;YES, HACK IT
	AOS	(P)		;COUNT ELEMENT
	PUSH	TP,A		;AND PUSH IT
	PUSH	TP,B
EVL6:	SKIPGE	A,-1(P)	;DONT SKIP IF LIST
	HRRZ	B,@1(TB)	;CDR IT
	JUMPL	A,ASTOTB	;AND STORE IT
	MOVE	B,1(TB)		;GET VECTOR POINTER
	ADD	B,AMNT(A)	;INCR BY APPROPRIATE AMOUNT
ASTOTB:	MOVEM	B,1(TB)		;AND STORE BACK
	JRST	EVL2		;AND LOOP BACK

AMNT:	2,,2			;INCR FOR GENERAL VECTOR
	1,,1			;SAME FOR UNIFORM VECTOR

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)



EVL7:	HLRE	C,A		;FIND TYPE OF UVECTOR
	SUBM	A,C		;C POINTS TO DOPE WORD
	GETYP	B,(C)		;GET TYPE
	MOVSI	B,(B)		;TO LH NOW
	SOJA	A,EVL8		;AND RETURN TO DO EVAL

EVL3:	SKIPL	-1(P)		;SKIP IF LIST
	JRST	EVL4		;EITHER VECTOR OR UVECTOR

	MOVEI	B,0		;GET A NIL
EVL9:	MOVSI	A,TLIST		;MAKE TYPE WIN
EVL5:	SOSGE	(P)		;COUNT DOWN
	JRST	FINIS		;DONE, RETURN
	PUSH	TP,$TLIST	;SET TO CALL CONS
	PUSH	TP,B
	MCALL	2,CONS
	JRST	EVL5		;LOOP TIL DONE


EVL4:	MOVEI	B,EUVECT	;UNIFORM CASE
	SKIPG	-1(P)		;SKIP IF UNIFORM CASE
	MOVEI	B,EVECTO	;NO, GENERAL CASE
	POP	P,A		;GET COUNT
	.ACALL	A,(B)		;CALL CREATOR
	JRST	FINIS

; PROCESS SEGMENTS FOR THESE  HACKS

DOSEG:	MOVEM	A,BSTO(PVP)	;WILL BECOME INTERRUPTABLE WITH GOODIE IN B
	HLRZS	A		;TYPE TO RH
	PUSHJ	P,SAT		;GET STORAGE TYPE

	CAIN	A,S2WORD	;LIST?
	JRST	LSTSEG
	CAIN	A,S2NWORD	;GENERAL VECTOR?
	JRST	VECSEG
	CAIN	A,SNWORD	;UNIFORM VECTOR?
	JRST	UVCSEG
	CAIE	A,SARGS		;ARGS TUPLE?
	JRST	ILLSEG		;NO, ERROR

	PUSH	TP,BSTO(PVP)	;PREPARE TO CHECK ARGS
	PUSH	TP,B
	SETZM	BSTO(PVP)	;TYPE NOT SPECIAL
	MOVEI	B,-1(TP)	;POINT TO SAVED COPY
	PUSHJ	P,CHARGS	;CHECK ARG POINTER
	POP	TP,B		;AND RESTORE WINNER
	POP	TP,BSTO(PVP)	;AND TYPE AND FALL INTO VECTOR CODE

VECSEG:	PUSH	P,[2,,2]	;PUSH AMOUNT TO BUMP
	JRST	SEG1		;AND JOIN COMMON CODE

UVCSEG:	PUSH	P,[1,,1]	;AMOUNT FOR UVECTS
	JRST	SEG1



LSTSEG:	SKIPL	-1(P)		;SKIP IF IN A LIST
	JRST	SEG3		;ELSE JOIN COMMON CODE
	HRRZ	C,@1(TB)	;CHECK FOR END OF LIST
	JUMPN	C,SEG3		;NO, JOIN COMMON CODE
	SETZM	BSTO(PVP)	;CLOBBER SAVED GOODIES
	JRST	EVL9		;AND FINISH UP




SEG3:	PUSH	P,[0]		;AMOUNT OF ADDING FOR LIST
SEG1:	INTGO			;CHECK OUT INTERRUPTS
	JUMPE	B,SEG2		;DONE?
	SKIPE	C,(P)		;CHECK IF LIST OR VECTOR
	JUMPG	B,SEG2		;END OF VECTOR
	CAMN	C,[1,,1]	;SKIP IF NOT UNIFORM
	JRST	SEG5		;HACK UNIFORM SEGMENT
	GETYPF	A,(B)		;GET NEXT TYPE
	SKIPGE	-2(P)		;SKIP IF NOT LIST
	HLLZS	A		;CLEAR CDR
	MOVE	C,1(B)		;GET VALUE
SEG4:	PUSH	TP,A		;PUSH TYPE
	PUSH	TP,C
	PUSH	P,B		;CAN USE P BECAUSE CHKARG NOT INTERRUPTABLE
	JSP	E,CHKARG	;CHECK OUT TDEFER
	POP	P,B		;RESTORE
	SKIPG	(P)		;SKIP IF NOT LIST
	HRRZ	B,(B)		;CDR THE LIST
	ADD	B,(P)		;AND BUMP IT
	AOS	-1(P)		;BUMP COUNT
	JRST	SEG1		;AND DO IT AGAIN

SEG2:	SETZM	BSTO(PVP)	;CLOBBER TYPE BACK
	SUB	P,[1,,1]	;POP OFF LOSSAGE
	JRST	EVL6

SEG5:	HLRE	C,B		;FIND TYPE
	SUBM	B,C		;POINT TO DOPE WORD
	GETYP	A,(C)		;GET  TYPE 
	MOVSI	A,(A)		;TO LH
	MOVE	C,(B)		;NOW GET VALUE
	JRST	SEG4



;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,@1(AB)
	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.

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:	MOVE	C,SP		;GET TOP OF BINDINGS
SCHLP:	JUMPE	C,UNPOPJ	;IF NO MORE -- LOSE
	CAMN	B,1(C)		;ARE WE POINTING AT THE WINNER?
	JRST	SCHFND		;YES
	HRRZ	C,(C)		;FOLLOW LINK
	JRST	SCHLP

SCHFND:	EXCH	B,C		;SAVE THE ATOM PTR IN C
	MOVEI	B,2(B)		;MAKE UP THE LOCATIVE
	SUBI	B,(TP)
	HRLI	B,-1(B)
	ADD	B,TP

	MOVEM	A,(C)		;CLOBBER IT AWAY INTO THE
	MOVEM	B,1(C)		;ATOM'S VALUE CELL
	POPJ	P,

UNPOPJ:	MOVSI	A,TUNBOUND
	MOVEI	B,0
	POPJ	P,

;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




;BINDER - THIS SUBROUTINE PROCCESSES FUNCTION DECLARATIONS AND BINDS
;	ARGUMENTS	AND TEMPORARIES APPROPRIATELY.
;	
;	CALL:	PUSHJ	P,BINDER OR BINDRS
;
;	BINDER - ASSUMES ARGS ARE ON A LIST
;
;	BINDRS - ASSUMES FORMS SUPPLIED FOR GETTING ARGS
;	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

BINDER:	MOVEI	A,0	
TBINDR:	PUSH	P,[ARGCDR]	;PUSH POINTER TO ARG GETTER
	JRST	BIND1

BINDRR:	MOVEI	A,0	
TBNDRR: PUSH	P,[RESARG]	; ARG GETTER FOR RESUMING FUNCTIONS
	JRST	BIND1


BINDRS:	MOVEI	A,0		;NO TOP TEMPS
TBNDRS:	PUSH	P,[SETZ EVALRG]	;FOR THE STACKFORM CASE
BIND1:	PUSH	P,[2]		;PUSH INITIAL STATE (NO DCLS PROCESSED)
	PUSH	P,A		;NUMBER OF TEMPS ON TP STACK

	JUMPE	C,NOBODY	;NO BODY IN FUNCTION, ERROR

	GETYP	A,(C)		;GET FIRST THING IN FUNCTION
	CAIE	A,TATOM		;ATOMIC?
	JRST	BIND2		;NO, NO NAME ALA HEWITT GIVEN
	PUSHJ	P,TMPUP		;COUNT TEMPS ON TP
	PUSH	TP,[TATOM,,1]	;YES SAVE IT
	PUSH	TP,1(C)
	HRRZ	C,(C)		;CDR THE FUNCTION TO POINT
	JUMPE	C,NOBODY

BIND2:	PUSHJ	P,CARLST	;MAKE SURE THE CAR IS A LIST
	JRST	BNDRET		;EXIT IMMEDIATELY
	MOVEI	A,(C)		;COPY FOR NXTDCL
	JUMPL	D,AUXDO		;PROG, HANDLE

	PUSHJ	P,NXTDCL	;GET A DECLARATION
	JRST	BINDRG		;NONE THERE, GO BIND ARGS

	CAME	B,[ASCII /BIND/]	;IS A BINDING NEEDED
	JRST	BIND3		;NO MUST BE ANOTHER FLAVOR OF DCL

	HRRZ	C,(A)		;CDR THE LIST
	JUMPE	C,MPD		;LOSER

	PUSHJ	P,CARATM	;GET THE CAR MAKING SURE OF ATOM
	JRST	MPD
	HRRZ	B,OTBSAV(TB)	;BUILD AN ENVIRONEMNT  FOR BINDING VAR
	PUSHJ	P,MAKENV

	PUSHJ	P,PSHBND	;PUSH THE BINDING ON THE STACK
	HRRZ	C,(C)		;CDR THE DCL LIST
	JRST	BINDRG		;GO BIND AS AN ARG



; MAIN BINDING LOOP, DISPATCH BASED ON DECLARATION

BIND4:	MOVEI	A,(C)		;COPY THE LIST POINTER
	PUSHJ	P,NXTDCL	;AND LOOK FOR A DECLARATION
	JRST	CHLIST		;ILLEGAL
BIND3:	TRZ	B,1		;FOR OPTIONAL TO WIN
	MOVSI	A,-DCLS		;NOW GET SET TO SEARCH TABLE
	HRRZ	C,(C)		;CDR THE DCL LIST
	JUMPE	C,MPD		;NO, CDR, ERROR

	CAMN	B,DCLST(A)	;SKIP IF NOT FOUND
	JRST	@DCLGO(A)	;DISPATCH BASED ON DCL
	AOBJN	A,.-2

	JRST	MPD

DCLS==0

DCLST:	IRP	A,,[ARGS,TUPLE,CALL,OPTIO,ACT,AUX,NAME,EXTRA]
	DCLS==DCLS+1
	ASCII /A/
	TERMIN

DCLS2==0

DCLGO:	IRP	A,,[ARGDO,TUPLDO,CALDO,OPTDO,ACTDO,AUXDO,ACTDO,AUXDO]
	A
	DCLS2==DCLS2+1
	TERMIN

IFN <DCLS-DCLS2>,PRINTC /LOSSAGE AT DCLS
/
EXPUNGE DCLS2

;HERE TO CHECK FOR LISTS WITHIN DECLARATIONS

CHLIST:	GETYP	A,(C)		;GET TYPE
	CAIE	A,TLIST		;LIST?
	JRST	MPD		;NO, LOSER
	SKIPN	A,1(C)		;CHECK NON-NIL
	JRST	CALD1		;IF NIL, IGNORE
	PUSH	TP,[TLIST,,1]	;SPECIAL TYPE
	PUSH	TP,C
	MOVEI	C,(A)		;LIST TO C
	PUSHJ	P,TMPUP		;COUNT TEMPS
	JRST	BINDRG




;HANDLER FOR CALL DECLARATION

CALDO:	SKIPL	-2(P)		;SKIP IF IN STACK-FORM
	SOSG	-1(P)		;SKIP IF FIRST DECLARATION
	JRST	MPD		;OTHERWISE MEANINGLESS

	JUMPE	0,MPD		;ALSO MEANINGLESS IF NO CALLSITE GIVEN
	PUSHJ	P,CARATD	;GOBBLE THE ATOM

	HLLZ	A,0		;SET UP CALL TO PUSH THE BINDING
	HRRZ	B,0
CALD2:	PUSHJ	P,PSHBND	;PUSH THAT BINDING ON TO STACK

CALD1:	PUSH	TP,$TLIST	;SAVE THE DCL LIST
	PUSH	TP,C
	MOVEI	E,-2(TP)	;POINT TO DCLS
	SUB	E,(P)		;SUBTRACT TEMPS
CALD3:	PUSHJ	P,SPCBE		;DO THE BINDINGS NOW
	MOVE	C,(TP)		;RESTORE DCLS
	SUB	TP,[2,,2]	;AND POP
	HRRZ	C,(C)		;CDR THE LIST
CALD4:	SETZM	-1(P)		;NEXT MUST BE EITHER AUX OR ACT
	JUMPN	C,BIND4		;LOOP AGAIN



BNDRET:	MOVEI	A,0		;SET SWITCH
BNDRT2:	SKIPN	(P)		;ANY TEMPS LEFT?
	JRST	BNDRT1
	MOVE	B,-1(TP)	;GET TYPE
	CAMN	B,[TATOM,,1]	;SPECIAL
	JRST	BNDRT3
	CAME	B,[TLIST,,1]	;STACKED LIST
	JRST	BNDRT1		;NO, LEAVE

	PUSHJ	P,TMPDWN	;TEMPS DOWN
	HRRZ	C,@(TP)	;CDR THE SAVED LIST
	SUB	TP,[2,,2]	;POP OFF CRAP
	JRST	CALD4		;AND CONTINUE PROCESSING

BNDRT3:	PUSHJ	P,TMPDWN
	MOVE	E,(TP)		;GET ATOM
	SUB	TP,[2,,2]
	MOVEI	C,0		;FOR ACTDO TO WIN
	PUSHJ	P,ACTD1
	MOVEI	A,1		;SAY NAME EXISTS

BNDRT1:	SUB	P,[3,,3]
	POPJ	P,



; HERE TO ARGS DECLARATION

ARGDO:	SOSL	-1(P)		;LOSE IF STATES ARE 0 OR 1
	SKIPGE	-2(P)		;ALSO LOSE IN STACK-FRAME
	JRST	MPD

	PUSHJ	P,CARATD	;FIND THE ATOM

	MOVSI	A,TLIST
	MOVEI	B,(D)		;COPY ARGL
	JRST	CALD2		;AND FALL INTO CALL CODE

;HERE TO HANDLE THE TUPLE DCL

TUPLDO:	SOSGE	-1(P)		;CHECK STATE
	JRST	MPD

	PUSHJ	P,CARATD	;GET ATOM
	PUSH	TP,$TLIST	;SAVE DCL LIST
	PUSH	TP,C
	PUSHJ	P,TMPUP		;COUNT THE TEMPS
	SETZB	A,B

	PUSHJ	P,PSHBND	;PUSH THE BINDING FOR THIS CHOMPER
	PUSH	P,[0]		;PUSH	ARG COUNTER

TUPLP:	PUSHJ	P,@-3(P)	;CALL ARG GOBBLING SUBROUTINE
	JRST	TUPDONE		;LEAVE IF ALL DONE

	PUSHJ	P,PSHAB		;PUSH THE EVALED ARG
	SOS	(P)		;COUNT THE ARG
	JRST	TUPLP

TUPDON:	MOVSI	A,TTB		;FENCE POST ARG BLOCK
	MOVE	B,TB		;WITH A FRAME POINTER
	PUSHJ	P,PSHAB		;ONTO THE STACK
	POP	P,B		;GET NUMBER OF ARGS
	ASH	B,1		;TIMES TWO
	SKIPE	B		;WATCH FOR EMPTY TUPLE
	HRLI	B,-1(B)		;FOR ADDING TO TOA TP
	ADDI	B,-1(TP)	;FUDGE POINTER
	SUB	B,(P)		;SUBTRACT TEMPS
	MOVEI	E,-1(B)		;B WIIL GET CLOBBERED, SAVE
	MOVSI	A,TARGS		;GET THE RIGHT TYPE
	HLR	A,OTBSAV(TB)	;WITH THE TIME
	MOVEM	A,-4(B)		;CLOBBER IT AWAY
	MOVEM	B,-3(B)		;AND ARG POINTER

	PUSHJ	P,TMPDWN
	JRST	CALD3

; HERE TO HANDLE OPTIONAL DECLARATION

OPTDO:	SKIPG	-1(P)
	JRST	MPD		;NOT ALLOWED
	SETZM	-1(P)		;MUNG STATE
	JRST	BNDRGL		;JOIN BIND LOOP

BINDRG:	SKIPG	-1(P)		;CHECK STATE
	JRST	MPD

BNDRGL:	JUMPE	C,CHLST		;CHECK FOR LAST
	PUSH	TP,$TLIST	;SAVE DCLS
	PUSH	TP,C
	PUSH	TP,$TLIST	;SAVE SLOT
	PUSH	TP,D		;PUT ARGLIST THERE FOR AN INT CHECK
	INTGO
	MOVE	D,(TP)		;INCASE INTERRUPT CLOBBERED IT
	SETZM	(TP)		;NOW CLEAR SLOT


BNDRG3:	PUSHJ	P,CARATM	;CHECK FOR ATOM
	JRST	OPTDFL		;NO, MAY BE LIST OR MAY BE QUOTED

	PUSH	TP,$TATOM
	PUSH	TP,E		;AND ATOM

	PUSHJ	P,@-2(P)	;GOBBLE DOWN NEXT ARG
	JRST	USEDF		;CHECK FOR DEFAULT OT ENOUGH

BNDRG2:	HRRZ	C,-4(TP)	;RESTORE DCLS
	MOVE	E,(TP)		;AND ATOM
	SUB	TP,[6,,6]	;FLUSH CRAP

	PUSHJ	P,PSHBND	;PUSH THE BINDING
BNDRG4:	HRRZ	C,(C)		;CDR THE DCL LIST
	JUMPN	C,BNDRGL

CHLST:	PUSHJ	P,@-2(P)	;CHECK FOR LAST
	JRST	.+2
	JRST	TMA
	MOVEI	E,(TP)		;PREPARE TO BIND
	SUB	E,(P)
	PUSHJ	P,SPCBE		;BIND IF STUFF EXISTS
	JRST	BNDRET		;AND RETURN



CHQT:	CAIE	A,TFORM		;IST THE ARG A FORM?
	JRST	OPTDF2		;NO, END OF ARGS

	SKIPN	C,1(C)		;CHECK FOR NULL BODY
	JRST	MPD

	GETYP	A,(C)		;TYPE OF 1ST OF FORM
	MOVE	B,1(C)		;AND VALUE
	CAIN	A,TATOM		;BETTER BE ATOM
	CAME	B,MQUOTE QUOTE
	JRST	MPD		;NAMED QUOTE OR LOSSAGE
	HRRZ	C,(C)		;CDR THE FORM
	JUMPE	C,MPD		;NO, ARG LOSE
	GETYP	A,(C)
	CAIE	A,TATOM		;ARG MUST BE ATOM
	JRST	MPD
	HRRZ	A,(C)		;AND CDR BETTER BE NIL
	JUMPN	A,MPD
	PUSH	TP,$TATOM	;AND SAVE SAME
	PUSH	TP,1(C)
	SKIPGE	A,-2(P)		;CHECK TYPE OF ARGS
	JRST	QUOTHK		;STACK FRAME HACK

	JUMPE	D,USEDF		;IF NO MORE ARGS, QUIT
	GETYP	A,(D)		;GET TYPE
	MOVSI	A,(A)		;TO LH
	PUSH	TP,A		;PUSH IT UP
	PUSH	TP,1(D)		;FOR DEFER CHECK
	JSP	E,CHKARG
	POP	TP,B		;GET BACK
	POP	TP,A
	HRRZ	D,(D)		;CDR THE ARG LIST
	JRST	BNDRG2

QUOTHK:	PUSHJ	P,(A)		;CALL ROUTINE
	JRST	USEDF		;TOO FEW ARGS

	PUSH	TP,$TATOM	;QUOTE THE GOODIE
	PUSH	TP,MQUOTE QUOTE
	PUSH	TP,A
	PUSH	TP,B
	MCALL	2,LIST		;CONS IT UP
	MOVSI	A,TFORM
	JRST	BNDRG2




OPTDFL:	SKIPN	-1(P)		;SKIP IF CANT BE DEFAULT
	CAIE	A,TLIST		;SHOULD BE A LIST
	JRST	CHQT		;NO MORE OPTIONALS

	SKIPE	(TP)		;AVOID LIST OF LIST
	JRST	MPD
	MOVE	C,1(C)		;GET THE CAR
	HRRZ	A,(C)		;CDR THE LIST
	JUMPE	A,MPD		;LOSER
	HRRZ	B,(A)		;CHECK FOR NIL CDR
	JUMPN	B,MPD
	MOVEM	A,(TP)		;SAVE
	JRST	BNDRG3

OPTDF2:	JUMPN	D,OPTDF3	;IF D NON-ZERO, DONT BIND
	MOVEI	E,-4(TP)	;PREPARE TO BIND
	SUBI	E,@(P)		;SUBTRACT TEMPS
	PUSHJ	P,SPCBE		;DO BINDINGS MAYBE
	MOVEI	D,0		;RESET D TO 0
OPTDF3:	MOVE	C,-2(TP)	;RESTORE DCLS
	SUB	TP,[4,,4]	;POP STACK
	MOVEI	A,1		;CLOBBER IN A NEW STATE
	MOVEM	A,-1(P)
	JRST	BIND4		;AND RE-ENTER THE LOOP


USEDF:	SKIPE	-1(P)		;SKIP IF OPTIONAL
	JRST	TFA		;ELSE TOO FEW ARGS
	MOVEI	E,-6(TP)	;SET TO DO SPECBIND
	SUBI	E,@(P)
	PUSHJ	P,SPCBE		;BIND IF THEY EXIST
	MOVNI	B,1		;ASSUME UNASSIGNED AT FIRST
	MOVSI	A,TUNBOU
	SKIPN	C,-2(TP)	;IF A FORM TO EVAL
	JRST	OPTDF4		;TREAT NORMALLY
	GETYP	A,(C)		;EVAL IT
	MOVSI	A,(A)
	PUSH	TP,A
	PUSH	TP,1(C)
	JSP	E,CHKARG	;CHECK FOR DEFERRED POINTERS
	MCALL	1,EVAL		;EVAL IT
OPTDF4:	MOVE	E,(TP)		;GET ATOM
	MOVE	C,-4(TP)
	SUB	TP,[6,,6]	;FLUSH JUNK
	PUSHJ	P,PSHBND	;PUSH THE BINDING
	MOVEI	D,0		;MUNG ARG LIST
	JRST	BNDRG4



AUXDO:	SKIPGE	-1(P)		;CHECK STATE
	JRST	MPD
	SETOM	-1(P)		;NOTHING BUT ACT MAY FOLLOW

AUXBND:	JUMPE	C,BNDRET	;DONE
	PUSHJ	P,CARATM	;LOOK FOR ATOM
	JRST	AUXIN		;COULD BE LIST

	MOVSI	A,TUNBOU
	MOVNI	B,1
AUXB1:	PUSHJ	P,PSHBND	;PUSH THE BINDING UP

	MOVEI	E,(TP)		;PREPARE TO BIND
	PUSH	TP,$TLIST	;SAVE DCLS
	PUSH	TP,C
	SUB	E,(P)		;FUDGE FOR TEMPS
	PUSHJ	P,SPCBE

	INTGO
	HRRZ	C,@(TP)		;CDR THE LIST
	SUB	TP,[2,,2]	;AND POP
	JRST	AUXBND

AUXIN:	CAIE	A,TLIST		;IS IT A LIST
	JRST	BIND4
	PUSH	TP,$TLIST	;SAVE  DCLS
	PUSH	TP,C
	SKIPN	C,1(C)		;NIL?
	JRST	MPD		;YES, LOSE
	PUSHJ	P,CARATD	;MAKE SURE ITS AN ATOM
	PUSH	TP,$TATOM
	PUSH	TP,E
	HRRZ	C,(C)		;CDR
	JUMPE	C,MPD
	HRRZ	A,(C)		;GET NEXT CDR
	JUMPN	A,MPD		;BETTER BE NIL
	GETYP	A,(C)
	MOVSI	A,(A)		;TYPE TO LH
	PUSH	TP,A
	PUSH	TP,1(C)		;PREPARE TO EVAL
	MCALL	1,EVAL
	MOVE	E,(TP)		;RESTORE ATOM
	MOVE	C,-2(TP)	;AND DCLS
	SUB	TP,[4,,4]
	JRST	AUXB1



ACTDO:	PUSHJ	P,CARATD	;MUST BE ATOMIC
	HRRZ	C,(C)		;MUST BE END OF DCLS
	JUMPN	C,MPD
	PUSH	P,CBNDRE	;PUSH THE RIGHT RETURN

ACTD1:	MOVE	B,TB		;MAKE ENV
	PUSHJ	P,MAKENV
	HRLI	A,TACT		;AND CHANGE TO ACTIVATION
	POP	P,D		;RESTORE RET ADR, BECAUSE PSHBND NEEDS NICE STATE
	PUSHJ	P,PSHBND	;PUSH UP THE BINDING
	PUSH	P,D		;NOW PUT IT BACK
	MOVEI	E,(TP)
	SUBI	E,@-1(P)	;NOW READY TO BIND
	PUSHJ	P,SPCBE
	MOVNI	A,1		;SET SW
CBNDRE:	POPJ	P,BNDRT2


;INTERNAL ROUTINES FOR THE BINDER

TMPUP:	AOS	-1(P)		;ADDS 2 TO TOP OF STACK
	AOS	-1(P)
	POPJ	P,

TMPDWN:	SOS	-1(P)		;SUBTRACTS 2 FROM STACK
	SOS	-1(P)
	POPJ	P,

CARATD:	PUSHJ	P,CARATM	;LOOK FOR ATOM
	JRST	MPD		;ERROR IF NONE
	POPJ	P,

CARATM:	GETYP	A,(C)		;GETS ARG IN C, GET TYPE
	CAIE	A,TATOM		;ATOM?
	POPJ	P,		;NO, DONT SKIP
	MOVE	E,1(C)		;RETRUN ATOM IN E
CPOPJ1:	AOS	(P)		;SKIP RET
CPOPJ:	POPJ	P,

CARLST:	GETYP	A,(C)		;GETS LIST IN CAR, POPS TO 2D ON STACK IF NIL
	CAIE	A,TLIST
	JRST	MPD		;NOT A LIST, FATAL
	SKIPE	C,1(C)
	AOS	(P)
	POPJ	P,


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,TENV		;MAKE INTO AN ENVIRONMENT
	HLL	B,OTBSAV(B)	;TIME TO B
	POP	P,C
	POPJ	P,




; ARGCDR - NORMAL ARG GETTER FOR OTHER THAN STACKFORM

ARGCDR:	JUMPE	D,CPOPJ		;DONT SKIP IF NIL
	PUSH	TP,$TLIST
	PUSH	TP,D
	GETYP	A,(D)		;GET TYPE OF ARG
	MOVSI	A,(A)		;TO LH OF A
	PUSH	TP,A
	PUSH	TP,1(D)		;PUSH TYPE AND VALUE
	JSP	E,CHKARG	;CHECK FOR TDEFER
	MCALL	1,EVAL
	HRRZ	D,@(TP)		;CDR THE LIST
	SUB	TP,[2,,2]	;POP STACK
	JRST	CPOPJ1		;SKIP RETURN

;EVALRG - USED TO EVAL ARGS IN STACKFORM HACK

EVALRG:	JUMPE	D,CPOPJ		;LEAVE IMMEDIATELY
	PUSH	TP,$TLIST	;SAVE ARG LIST
	PUSH	TP,D
	HRRZ	C,(D)		;AND CDR IT
	GETYP	B,(C)		;GET TYPE OF CONDITIONAL FORM
	MOVSI	B,(B)		;TO LH
	PUSH	TP,B
	PUSH	TP,1(C)		;AND VALUE
	JSP	E,CHKARG	;CHECK DEFERRED
	MCALL	1,EVAL		;AND EVAL IT
	CAMN	A,$TFALSE	;FALSE?
	JRST	EVALR2		;YES, LEAVE
	HRRZ	D,(TP)		;GET ARGS BACK
	GETYP	A,(D)		;GET TYPE
	MOVSI	A,(A)		;TO LH
	PUSH	TP,A
	PUSH	TP,1(D)		;PUSH IT
	JSP	E,CHKARG	;CHECK DEFERRED
	MCALL	1,EVAL
	AOS	(P)		;CAUSE A SKIP RETURN
EVALR2:	MOVE	D,(TP)		;RESTORE ARGS
	SUB	TP,[2,,2]	;POP STACK
	POPJ	P,		;AND RETURN

;RESARG - USED TO GET ARGS FOR RESUMING FUNCTIONS


RESARG:
	JUMPE	D,CPOPJ	;DONT SKIP IF NIL - NO MORE ARGS
	PUSH	TP,$TLIST	; SAVE ARG LIST
	PUSH	TP,D
	GETYP	A,(D)		; GET TYPE OF ARG
	MOVSI	A,(A)		;TO LH
	PUSH	TP,A		;PUSH TYPE
	PUSH	TP,1(D)		;AND VALUE
	JSP	E,CHKARG	;CHECK FOR DEFERED TYPE
	MOVE	B,MQUOTE [PPROC ]INTERR
	PUSHJ	P,ILVAL		;GET ENV OF PARENT PROCESS	
	PUSH	TP,A
	PUSH	TP,B		;SET UP FOR AEVAL CALL
	MCALL	2,EVAL		;CALL EVAL WITH THE ENV
	HRRZ	D,@(TP)		;CDR ARG LIST
	SUB	TP,[2,,2]	;REMOVE SAVED ARG LIST
	JRST	CPOPJ1		;SKIP 1 AND RETURN



;SUBROUTINE TO PUSH A BINDING ON THE STACK
;	E/	ATOM
;	A/	TYPE
;	B/	VALUE

PSHBND:	PUSH	P,D		;SAVE TEMPS
	PUSH	P,E
	MOVE	D,-3(P)		;GOBBLE # OF TEMPS ON STACK
	ADD	TP,[6,,6]	;ALOCATE SPACE
	JUMPGE	TP,TPLOSE	;HACK IF OVERFLOW
PSHBN1:	HRROI	E,-6(TP)	;SET UP E
	JUMPE	D,NOBLT		;IF NO TEMPS, LESS WORK
	POP	E,6(E)		;USE POP TP MOVE THEM UP
	SOJN	D,.-1
NOBLT:	MOVSI	D,TATOM		;SET UP BINDING
	HLLOM	D,1(E)		;CLOBBER
	POP	P,2(E)		;ATOM INTO SLOT
	MOVEM	A,3(E)
	MOVEM	B,4(E)
	SETZM	5(E)		;CLEAR EXTRA SLOTS
	SETZM	6(E)
	POP	P,D
	POPJ	P,

TPLOSE:	PUSHJ	P,TPOVFL	;GO TO INT HANDLER
	JRST	PSHBN1

; DO A SPECBIND IF NEEDED

SPCBE:	MOVE	A,-5(E)		;GET TYPE
	CAME	A,BNDA
	POPJ	P,
	MOVEI	A,(TP)		;COPY POINTER
	SUBI	A,(E)		;FIND DISTANCE TO TOP
	MOVSI	A,(A)		;TO LH
	HLL	E,TP
	SUB	E,A		;FIX UP POINTER
	JRST	SPECBE		;YES, GO DO IT

;ROUTINE TO SQUEEZE A PAIR ON THE STACK

PSHAB:	PUSH	P,D
	PUSH	P,E
	PUSH	TP,[0]		;ALLOCATE SPACE
	PUSH	TP,[0]
	MOVE	D,-4(P)		;GET TEMPS COUNT
	HRROI	E,-2(TP)	;POINT TO TOP
	JUMPE	D,NOBLT1
	POP	E,2(E)
	SOJN	D,.-1

NOBLT1:	MOVEM	A,1(E)		;CLOBBER
	MOVEM	B,2(E)
	POP	P,E
	POP	P,D
	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
BNDV:	TVEC,,-1

SPECBIND:	MOVE	E,TP		;GET THE POINTER TO TOP
SPECBE:	ADD	E,[1,,1]	;BUMP POINTER ONCE
	SETZB	0,D		;CLEAR TEMPS

BINDLP:	MOVE	A,-6(E)		;GET TYPE
	CAME	A,BNDA		;NORMAL ID BIND?
	JRST	NONID		;NO TRY BNDV

	SUB	E,[6,,6]	;MOVE PTR
	SKIPE	D		;LINK?
	HRRM	E,(D)		;YES --  LOBBER
	SKIPN	0		;UPDATED?
	MOVE	0,E		;NO -- DO IT

	MOVE	A,0(E)		;GET ATOM PTR
	MOVE	B,1(E)	
	PUSHJ	P,ILOC		;GET LAST BINDING
	HLR	A,OTBSAV (TB)	;GET TIME
	MOVEM	A,4(E)		;CLOBBER IT AWAY
	MOVEM	B,5(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,[2,,2]
	MOVE	C,1(E)		;GET ATOM PTR
	MOVEM	A,(C)		;CLOBBER ITS VALUE
	MOVEM	B,1(C)		;CELL
	MOVEI	A,TBIND
	HRLM	A,(E)		;IDENTIFY AS BIND BLOCK
	MOVE	D,E		;REMEMBER LINK
	JRST	BINDLP		;DO NEXT

NONID:	MOVE	A,-4(E)		;TRY TYPE BEFORE
	CAME	A,BNDV		;IS IT A SPECIAL HACK?
	JRST	SPECBD		;NO  -- DONE
	SUB	 E,[4,,4]
	SKIPE	D
	HRRM	E,(D)
	SKIPN	0
	MOVE	0,E

	MOVE	D,1(E)		;GET PTR TO VECTOR
	MOVE	C,(D)		;EXCHANGE TYPES
	EXCH	C,2(E)
	MOVEM	C,(D)

	MOVE	C,1(D)		;EXCHANGE DATUMS
	EXCH	C,3(E)
	MOVEM	C,1(D)

	MOVEI	A,TBVL	
	HRLM	A,(E)		;IDENTIFY BIND BLOCK
	MOVE	D,E		;REMEMBER LINK
	JRST	BINDLP

SPECBD:	SKIPE	D
	HRRM	SP,(D)
	MOVE	SP,0
	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:
	CAIL	E,(SP)		;ARE WE DONE?
	JRST	STPOPJ
	HLRZ	C,(SP)		;GET TYPE OF BIND
	CAIE	C,TBIND		;NORMAL IDENTIFIER?
	JRST	ISTORE		;NO -- SPECIAL HACK


	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)
	SETZM	4(SP)
SPLP:	HRRZ	SP,(SP)		;FOLOW LINK
	JUMPN	SP,STLOOP	;IF MORE
	JUMPE	E,STPOPJ	;ONLY OK IF E=0
	.VALUE	[ASCIZ /SPOVERPOP/]

ISTORE:	CAIE	C,TBVL
	.VALUE	[ASCIZ /BADSP/]
	MOVE	C,1(SP)
	MOVE	D,2(SP)
	MOVEM	D,(C)
	MOVE	D,3(SP)
	MOVEM	D,1(C)
	JRST	SPLP

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
	PUSH	TP,BNDA		;BIND FUNNY ATOM
	PUSH	TP,MQUOTE [LPROG ]INTERR
	PUSH	TP,$TTB
	PUSH	TP,TB		;CURRENT TB POINTER
	PUSH	TP,[0]
	PUSH	TP,[0]
	PUSHJ	P,SPECBI	;BIND THE ATOM
	MOVE	C,1(AB)		;PROG BODY
	MOVNI	D,1		;TELL BINDER WE ARE APROG
	PUSHJ	P,BINDER
	HRRZ	C,1(AB)		;RESTORE PROG
	SKIPLE	A		;SKIP IF NO NAME ALA HEWITT
	HRRZ	C,(C)
	JUMPE	C,NOBODY
	PUSH	TP,$TLIST
	PUSH	TP,C		;SAVE FOR REPEAT, AGAIN ETC.
	HRRZ	C,(C)		;SKIP DCLS

; 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,(TP)		;CHECK IT
	JRST	FINIS
	MOVEM	C,1(TB)
	JRST	CONTINUE



MFUNCTION RETURN,SUBR
	ENTRY	1
	PUSHJ	P,PROGCH	;CKECK IN A PROG
	HRR	TB,B		;YES, SET TB
	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:	HRR	TB,B
	MOVE	B,TPSAV(B)	;POINT TO TOP OF STACK
	MOVE	B,(B)
	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)
	MOVE	B,TPSAV(B)	;GET SAVED TOP OF STACK
	PUSH	TP,-1(B)
	PUSH	TP,(B)
	MCALL	2,MEMQ		;DOES IT HAVE THIS TAG?
	JUMPE	B,NXTAG		;NO -- ERROR
FNDGO:	MOVE	TB,(TP)		;RE-GOBBLE
	SUB	TP,[2,,2]	;POP TP
	MOVEM	B,1(TB)
	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
	HRR	TB,3(A)		;GET NEW FRAME PTR
	MOVE	A,1(A)		;GET PLACE TO START
	MOVEM	A,1(TB)		;CLOBBER IT AWAY
GODON:	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
	MOVE	A,TPSAV(B)	;GET STACK TOP
	PUSH	TP,0(AB)
	PUSH	TP,1(AB)
	PUSH	TP,-1(A)
	PUSH	TP,(A)
	MCALL	2,MEMQ
	JUMPE	B,NXTAG		;IF NOT FOUND -- ERROR
	MOVEM	A,-1(TP)	;SAVE PLACE
	EXCH	B,(TP)	
	MOVEI	A,1(PVP)
	HLRE	C,PVP
	SUB	A,C
	HRLI	A,TFRAME
	PUSH	TP,A
	HLL	B,OTBSAV (B)
	PUSH	TP,B
	MCALL	2,EVECTOR
	MOVSI	A,TTAG
	JRST	FINIS

PROGCH:	MOVE	B,MQUOTE [LPROG ]INTERR
	PUSHJ	P,ILVAL		;GET VALUE
	CAME	A,$TTB		;CHECK TYPE
	JRST	NXPRG
	POPJ	P,

MFUNCTION EXIT,SUBR
	ENTRY	2
	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
	HRR	TB,A
	MOVE	A,2(AB)
	MOVE	B,3(AB)
	JRST	FINIS

MFUNCTION COND,FSUBR
	ENTRY	1
	HLRZ	A,(AB)
	CAIE	A,TLIST
	JRST	WTYP
CLSLUP:	SKIPN	B,1(AB)		;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(AB)		;IF NOT, GET
	MOVE	C,1(C)		;THE CLAUSE
	HRRZ	C,(C)		;GET ITS REST
	JUMPE	C,FINIS		;IF ONLY A PREDICATE --- RETURN ITS VALUE
	PUSH	TP,$TLIST	
	PUSH	TP,C		;EVALUATE THE REST OF THE CLAUSE
	JRST	DOPROG
NXTCLS:	HRRZ	A,@1(AB)	;SET THE CLAUSLIST
	HRRZM	A,1(AB)		;TO CDR OF THE CLAUSLIST
	JRST	CLSLUP
	
IFALSE:
	MOVSI	A,TFALSE	;RETURN FALSE
	MOVEI	B,0
	JRST	FINIS




;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:
	HRRZ	A,TPBASE+1(PVP)	;GET ACTUAL STACK BASE
	HRRZ	B,SPBASE+1(PVP)	;AND FIRST BINDING
	SUB	B,A		;ARE THERE 6
	CAIL	B,6		;CELLS AVAILABLE?
	JRST	SETIT		;YES
	PUSH	TP,TPBASE(PVP)	;NO -- GROW THE TP
	PUSH	TP,TPBASE+1(PVP)	;AT THE BASE END
	PUSH	TP,$TFIX
	PUSH	TP,[0]
	PUSH	TP,$TFIX
	PUSH	TP,[100]
	MCALL	3,GROW
	MOVEM	A,TPBASE(PVP)	;SAVE RESULT
	MOVEM	B,TPBASE+1(PVP)
SETIT:	MOVE	B,SPBASE+1(PVP)
	MOVEI	A,-6(B)		;MAKE UP BINDING
	HRRM	A,(B)		;LINK PREVIOUS BIND BLOCK
	MOVSI	A,TBIND
	MOVEM	A,-6(B)
	MOVE	A,1(AB)
	MOVEM	A,-5(B)
	MOVSI	A,TLOCI
	HRR	A,PROCID+1(PVP)
	SUB	B,[6,,6]
	MOVEM	B,SPBASE+1(PVP)
	ADD	B,[2,,2]
	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
ANDLP:
	JUMPE	C,FINIS		;ANY MORE ARGS?
	MOVEM	C,1(AB)		;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(AB)	;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
ORLP:
	JUMPE	C,IFALSE	;IF NO MORE OPTIONS -- FALSE
	MOVEM	C,1(AB)		;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(AB)	;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


;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-YEST-IMPLEMENTED
	JRST	CALER1

ILLSEG:	PUSH	TP,$TATOM
	PUSH	TP,MQUOTE ILLEGAL-SEGMENT
	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
***