.TITLE	EVAL		
; JEFFREY KODOSKY	ARL	NOV75
;
; SUBR
; ENTRY:	1 ARG		<FORM>
; EXIT:		1 ARG		EVAL[<FORM>]
; ERRORS:	A8, UNBOUND VARIABLE--EVAL
;		A9, FUNCTION OBJECT HAS NO DEFINITION--EVAL
;		F1, IMPROPER NUMBER OF SUBR ARGS
;		T1, ILLEGAL TRAP CODE
; CALLS:	GET
;		SASSOC
;		CAR
;		CDR
;		CONS
;		EVLIS
;		APPLY
;		COND
;		PROG
;		GETC
;		PRNT
;		PRINT
;		PRIN1
;		ATM2N
;		INDEX
	.GLOBL	EVAL,ZEVAL,APVAL,QUOTE,FUNCTION,FUNARG,YCOND
	.GLOBL	YPROG,YTRSET,YTRACE,EXPR,SUBR,FEXPR,FSUBR
	.GLOBL	QA8ERR,QA9ERR,QT1ERR,QF1ERR,QCOND,QPROG,QEVLIS
	.GLOBL	QAPPLY,QGETC,QCAR,QCDR,QSASSOC,QGET,QPRINT
	.GLOBL	QPRIN1,QPRNT,$ALIST,TSRETN,SUBEXP,QCONS,QATM2N
	.GLOBL	TTABLE,YCARCDR,QINDEX,YARRAY,LASTPR
EVAL:	MOV	@R5,R0
	BEQ	EVAL00	;NULL[<FORM>]--->NIL
	BIT	#2,(R0)+
	BNE	EVAL00	;NUMBERP[<FORM>]---><FORM>
	BIT	#2,@R0
	BNE	EVAL00	;STRINGP[<FORM>]---><FORM>
	BIT	#1,@R0
	BEQ	EVAL10	;JUMP IF NON-ATOMIC
	ROOM	4
	MOV	APVAL,-(R5)	;ATOM[<FORM>]--->
	MOV	2(R5),-(R5)
	QGET
	BCS	EVAL01
	MOV	(R5)+,@R5	;GET[<FORM>;APVAL]--->GET[..]
EVAL00:	JMP	@-(R4)
EVAL01:	MOV	$ALIST,-(R5)	;T--->
	MOV	4(R5),-(R5)
	QSASSOC		;SASSOC[<FORM>;ALIST;ERROR[A8]]
	MOV	(R5)+,R0
	BEQ	EVAL02	;JUMP IF NO BINDING
	MOV	R0,@R5	;OTHERWISE RETURN BOUND VALUE
	QCDR		;DIRECTLY
	.WORD	0
EVAL02:	QA8ERR		;UNBOUND VARIABLE
; NON-ATOMIC <FORM> :
EVAL10:	CMP	-(R0),QUOTE	;EQ[CAR[<FORM>];QUOTE]--->
	BNE	EVAL11
	MOV	2(R0),@R5	;CADR[<FORM>]
	QCAR
	.WORD	0
EVAL11:	CMP	@R0,FUNCTION	;EQ[CAR[<FORM>];FUNCTION]--->
	BNE	EVAL12
	MOV	2(R0),@R5	;LIST[FUNARG;CADR[<FORM>];ALIST]
	QCAR
	QGETC
	MOV	(R5)+,R3
	QGETC
	MOV	(R5)+,R2
	QGETC
	MOV	(R5)+,R1
	MOV	FUNARG,(R1)+
	MOV	R2,@R1
	MOV	@R5,(R2)+
	MOV	R3,@R2
	MOV	$ALIST,@R3
	TST	-(R1)
	MOV	R1,@R5
	JMP	@-(R4)
EVAL12:	CMP	@R0,YCOND	;EQ[CAR[<FORM>];COND]--->
	BNE	EVAL13
	MOV	2(R0),@R5	;COND[CDR[<FORM>]]
	QCOND
	.WORD	0
EVAL13:	CMP	@R0,YPROG	;EQ[CAR[<FORM>];PROG]--->
	BNE	EVAL14
	MOV	2(R0),@R5	;PROG[CDR[<FORM>]]
	QPROG
	.WORD	0
EVAL14:	MOV	@R0,R0	;R0:=CAR[<FORM>]
	ROOM	7
	BIT	#2,(R0)+;NUMBERP[CAR[<FORM>]] OR
	BNE	EVAL40
	BIT	#2,@R0
	BNE	EVAL40	;STRINGP[CAR[<FORM>]] THEN JUMP
	BIT	#1,@R0
	BEQ	EVAL50	;ATOM[CAR[<FORM>]]--->
	MOV	EXPR,-(R5)	;GET[CAR[<FORM>];EXPR]--->
	MOV	@2(R5),-(R5)
	QGET
	BCS	EVAL20
	CLR	FLAG	;APPLY[<EXPRVAL>;EVLIS[CDR[<FORM>]]]
	BR	EVAL26
EVAL20:	MOV	FEXPR,@R5	;GET[CAR[<FORM>];FEXPR]--->
	MOV	@2(R5),-(R5)
	QGET
	BCS	EVAL25
	QGETC		;APPLY[<FEXPRVAL>;LIST[CDR[<FORM>];
	MOV	(R5)+,R3	;ALIST]]
	QGETC
	MOV	(R5)+,R2
	MOV	2(R5),R0
	MOV	2(R0),(R2)+
	MOV	R3,@R2
	MOV	$ALIST,@R3
	TST	-(R2)
	MOV	R2,-(R5)
	MOV	#2,FLAG
	BR	EVAL27
EVAL25:	MOV	SUBR,@R5	;GET[CAR[<FORM>];SUBR]--->
	MOV	@2(R5),-(R5)
	QGET
	BCS	EVAL30
	MOV	#2,FLAG	;(2*FLAG OF 1)
EVAL26:	MOV	$ALIST,-(R5)	;SPREAD[EVLIS[CDR[<FORM>]]]
	MOV	4(R5),R0
	MOV	FLAG,-(R5)	;(SAVE 2*FLAG [0 OR 2] ACROSS EVLIS)
	MOV	2(R0),-(R5)
	QEVLIS
	MOV	(R5)+,R0
	ASR	@R5	;(RESTORE FLAG)
	MOV	(R5)+,FLAG
	MOV	@R5,$ALIST
	MOV	R0,@R5
EVAL27:	MOV	@4(R5),4(R5)	;FNATM:=CAR[<FORM>]
	BR	TSTRACE
; APPLY ENTRY TO CHECK TRACE AND SPREAD ARGS
SUBEXP:	MOV	(SP)+,FLAG
	BR	TSTRACE
EVAL30:	MOV	FSUBR,@R5	;GET[CAR[<FORM>];FSUBR]--->
	MOV	@2(R5),-(R5)
	QGET
	BCS	EVAL36
	MOV	2(R5),R0	;<FSUBRVAL>[CDR[<FORM>]]
	MOV	2(R0),-(R5)
	MOV	#3,FLAG
	BR	EVAL27
EVAL36:	MOV	YARRAY,@R5	;GET[CAR[<FORM>;ARRAY]--->
	MOV	@2(R5),-(R5)
	QGET
	MOV	@R5,R3
	BEQ	EVAL39
	MOV	2(R5),R0	;<ARRAY>[EVLIS[CDR[<FORM>]]]
	MOV	2(R0),-(R5)
	QEVLIS
	MOV	@4(R5),-(R5)
	QCONS
	QINDEX
	MOV	@R0,@R5	;RETURN VALUE OF ELEMENT
	JMP	@-(R4)
EVAL39:	TST	(R5)+	;POP A NIL
EVAL40:	CLR	-(R5)	;T--->EVAL[CONS[CDR[SASSOC[
	MOV	$ALIST,-(R5)	;CAR[<FORM>];ALIST;ERROR[A9]]];
	MOV	@4(R5),-(R5)	;CDR[<FORM>]]]
	QSASSOC
	MOV	(R5)+,R0
	BNE	EVAL41
	MOV	@(R5)+,-(R5)
	QA9ERR
EVAL41:	MOV	@R5,R1
	MOV	2(R1),@R5
	MOV	R0,-(R5)
	QCDR
	QCONS
	JMP	EVAL
EVAL50:	MOV	@R5,R0	;T--->APPLY[CAR[<FORM>];EVLIS[CDR[<FORM>]]]
	MOV	$ALIST,@R5
	MOV	(R0)+,-(R5)
	MOV	@R0,-(R5)
	QEVLIS
	MOV	4(R5),$ALIST
	MOV	(R5)+,2(R5)	;INSERT ARGLIST
EVAL51:	QAPPLY
	.WORD	0
; TRACE TESTING AND ARG SPREADING
TSTRACE:MOV	4(R5),YCARCDR	;SAVE FN ATOM IN CASE C....R FN
	MOV	YTRACE,-(R5)
	MOV	6(R5),-(R5)
	QGET
	BCS	TR02	;JUMP IF NO TRACE THIS FCTN
	MOV	@R5,R0
	CMP	#2,(R0)+;TRACE INDICATOR MUST BE AN INTEGER
	BNE	TR02	;ELSE IGNORE IT
	INC	@R0	;INCREMENT LEVEL NUMBER
	MOV	#B1,R3	;PRINT TRACE MSG
	QPRNT
	MOV	#1,LASTPR	;(DON'T ALLOW DELIMITER)
	QPRIN1		;PRINT [ AND LEVEL NUMBER
	TST	(R5)+
	MOV	#B2,R3
	QPRNT		;PRINT: ] LEVEL ARGS OF
	MOV	4(R5),-(R5)
	QPRINT		;PRINT FUNCTION ATOM NAME
	TST	(R5)+
	MOV	@R5,-(R5)
	BIT	#2,FLAG
	BEQ	EVAL63	;JUMP TO PRINT EXPR OR SUBR ARGS
	BIT	#1,FLAG
	BNE	EVAL60	;JUMP IF FSUBR
	QCAR
EVAL60:	QPRINT		;PRINT FEXPR OR FSUBR ARGLIST
	BR	EVAL69
EVAL63:	MOV	@R5,R0	;PRINT EACH ARG OF EXPR OR SUBR
	BEQ	EVAL69
	MOV	(R0)+,-(R5)
	MOV	@R0,2(R5)
	QPRINT
	TST	(R5)+
	BR	EVAL63
EVAL69:	TST	(R5)+
	MOV	(R5)+,R0;LEAVE FNATM ON STACK FOR LATER PRINTING
	MOV	@R5,-(R5)
	MOV	R0,2(R5)
	MOV	#TRETN,(R4)+	;LOAD SPECIAL TRACE PRINT RETURN
	MOV	4(R5),R0
	BR	TR03
TR02:	TST	(R5)+
	MOV	4(R5),R0
	MOV	(R5)+,2(R5)	;INSERT FCTN ARGS
TR03:	ASR	FLAG	;CAN ONLY TRACESET EXPR OR FEXPR
	BCS	TR05
	MOV	YTRSET,-(R5)
	MOV	R0,-(R5)
	QGET
	BCS	TR04
	MOV	#TSRETN,(R4)+	;LOAD TRSET FLAG IF TRACESETTING
TR04:	TST	(R5)+
	BR	EVAL51	;APPLY[<EXPR OR FEXPR>;<ARGS>]
TR05:	QATM2N		;GET TRAP CODE
	BCC	.+4
	QT1ERR
	MOV	(SP)+,R0
	ASR	FLAG
	BCS	EVAL70	;JUMP IF FSUBR
	MOV	R0,R1	;SUBR: SPREAD ARGS
	MOV	(R5)+,R3
	BIC	#177400,R1
	ASL	R1	;ARG COUNT * 2
	SUB	R1,R5	;SPACE FOR ARGS
	CMP	R4,R5
	BLO	SPRD1
	ADD	R1,R5	;NO ROOM, RESTORE R5 POINTER
	QG2ERR
SPRD1:	MOV	R5,R2
	ASR	R1	;ARGCNT
	BEQ	SPRD4	;JUMP IF DONE
SPRD3:	TST	R3
	BEQ	SPRD5	;JUMP IF NOT ENOUGH ARGS
	MOV	(R3)+,(R2)+	;LOAD NEXT ARG
	MOV	@R3,R3	;CDR OF ARGLIST
	DEC	R1
	BGT	SPRD3
SPRD4:	TST	R3
	BEQ	EVAL70	;JUMP IF CORRECT NUMBER OF ARGS
SPRD5:	CLRB	R0	;PUT PC OF IMPROPERLY CALLED SUBR
	SWAB	R0	;ON SUBR STACK FOR TRACEBACK
	ASL	R0
	MOV	TTABLE(R0),(R4)+
	QF1ERR
	.WORD	0	;(DON'T SHOW EVAL PC)
EVAL70:	SWAB	R0
	MOVB	R0,@PC
	TRAP+0
	.WORD	0
; TRACE RETURN PRINTING
TRETN:	MOV	YTRACE,-(R5)	;GET LEVEL NUMBER
	MOV	4(R5),-(R5)
	QGET
	BCS	TRET1	;JUMP IF NO LONGER BEING TRACED
	MOV	#B1,R3
	QPRNT		;PRINT [
	MOV	#1,LASTPR	;(DON'T ALLOW DELIMITER)
	QPRIN1		;PRINT LEVEL NUMBER
	MOV	#B3,R3
	QPRNT		;PRINT:  ] RESULT OF
	MOV	4(R5),-(R5)
	QPRINT		;PRINT ATOM NAME
	MOV	4(R5),@R5
	QPRINT		;PRINT RESULT
	TST	(R5)+
	MOV	@R5,R0	;DECREMENT LEVEL NUMBER
	CMP	#2,(R0)+
	BNE	TRET1
	DEC	@R0
TRET1:	TST	(R5)+
	MOV	(R5)+,@R5	;MOVE UP RESULT
TSRETN:	JMP	@-(R4)
;
	.NLIST	BEX
FLAG:	.WORD	0
B1:	.BYTE	15,12,'[,0
B2:	.ASCIZ	/]  LEVEL ARGUMENTS OF/
B3:	.ASCIZ	/]  RESULT OF/
	.EVEN
	.LIST	BEX
ZEVAL=.-EVAL
	.END