.TITLE EXPRESS
	.IDENT /V03.00/
	.PAGE
;*****************************************************************************
; 
;    UNIT NAME:  EXPRESS
; 
;    PURPOSE:  PARSE AND EVALUATE AN ARITHMETIC EXPRESSION
; 
;    INVOCATION METHOD:
; 	CALL EXPRESS(INLINE, ACTION, HANDLER)
; 
;    ARGUMENT LIST:
NARGS   =	0	;   I   I     NUMBER OF ARGUMENTS
INLINE	=	4	; C*(*) I     LINE CONTAINING TEXT OF EXPRESSION
ACTION  =	8	;   EP  C     ENTRY POINT OF ACTION ROUTINE TO BE
;					CALLED AT END OF EXPRESSION EVALUATION
HANDLER =      12 	;   EP  C     ENTRY POINT FOR CONDITION HANDLER
; 
;    DEVELOPMENT HISTORY:
;      AUTHOR	            DATE  	COMMENTS
;    D. FITZGERALD         4/14/83        
; 
; *****************************************************************************
	.PAGE
	.SBTTL	CONSTANT DEFINITIONS
;
;			MISC. CONSTANTS
;
MAX_SYM_LEN = 32		;MAXIMUM SYMBOL NAME LENGTH
;
;			INTERP ACTION FLAGS
;
CALL_GETOP1 = 1
CALL_GETOP2 = 2
CALL_PUTOP  = 4
FORCE_REAL  = 8
FORCE_INT   = 16
;
UNARY	=	CALL_GETOP1 ! CALL_PUTOP
BINARY  =	CALL_GETOP2 ! CALL_PUTOP
;
;
;
	_STDEF		;DEFINE OFFSETS IN SYMBOL TABLE
	$SSDEF		;DEFINE SS EQUATES
	$CHFDEF		;DEFINE CONDITION HANDLING FACILITY EQUATES
	$STSDEF		;DEFINE CONDITION VALUE FIELDS
	$TPADEF		;DEFINE TPARSE SYMBOLS
	_TPDEF		;DEFINE LOCAL EXTENSION TO TPA PARAMETER BLOCK
;
	.PAGE
	.SBTTL	OPERATOR DEFINITIONS
;
	.PSECT	_PRECTAB  PIC,CON,REL,LCL,SHR,NOEXE,RD,NOWRT,LONG
PRECTAB:
	.PSECT	_RCALLTAB PIC,CON,REL,LCL,SHR,NOEXE,RD,NOWRT,LONG
RCALLTAB:
	.PSECT	_ICALLTAB PIC,CON,REL,LCL,SHR,NOEXE,RD,NOWRT,LONG
ICALLTAB:
	.PSECT	_FLAGSTAB PIC,CON,REL,LCL,SHR,NOEXE,RD,NOWRT,LONG
FLAGSTAB:
__IOP	=	1
;
;
;
	OPDEF	UNMINUS,30,RNEG,INEG,UNARY
	OPDEF	ACOS,30,MTH$ACOS_R4,0,UNARY!FORCE_REAL
	OPDEF	ASIN,30,MTH$ASIN_R4,0,UNARY!FORCE_REAL
	OPDEF	ATAN,30,MTH$ATAN_R4,0,UNARY!FORCE_REAL
	OPDEF	COS,30,MTH$COS_R4,0,UNARY!FORCE_REAL
	OPDEF	SIN,30,MTH$SIN_R4,0,UNARY!FORCE_REAL
	OPDEF	TAN,30,MTH$TAN_R4,0,UNARY!FORCE_REAL
	OPDEF	ACOSD,30,MTH$ACOSD_R4,0,UNARY!FORCE_REAL
	OPDEF	ASIND,30,MTH$ASIND_R4,0,UNARY!FORCE_REAL
	OPDEF	ATAND,30,MTH$ATAND_R4,0,UNARY!FORCE_REAL
	OPDEF	COSD,30,MTH$COSD_R4,0,UNARY!FORCE_REAL
	OPDEF	SIND,30,MTH$SIND_R4,0,UNARY!FORCE_REAL
	OPDEF	TAND,30,MTH$TAND_R4,0,UNARY!FORCE_REAL
	OPDEF	SQRT,30,MTH$SQRT_R3,0,UNARY!FORCE_REAL
	OPDEF	EXP,30,MTH$EXP_R4,0,UNARY!FORCE_REAL
	OPDEF	ALOG,30,MTH$ALOG_R5,0,UNARY!FORCE_REAL
	OPDEF	ALOG10,30,MTH$ALOG10_R5,0,UNARY!FORCE_REAL
	OPDEF	ABS,30,RABS,IABS,UNARY
	OPDEF	INT,30,0,0,UNARY!FORCE_INT
	OPDEF	NINT,30,RNINT,0,CALL_GETOP1
	OPDEF	REAL,30,0,0,UNARY!FORCE_REAL
	OPDEF	PLUS,15,RADD,IADD,BINARY
	OPDEF	MINUS,15,RSUB,ISUB,BINARY
	OPDEF	MULT,20,RMULT,IMULT,BINARY
	OPDEF	DIVIDE,20,RDIVIDE,IDIVIDE,BINARY
	OPDEF	EXPON,25,DO_EXPON,DO_EXPON,0
	OPDEF	ASSIGN,5,DO_ASSIGN,DO_ASSIGN,0
	OPDEF	LEFTP,10,MISMATCH,MISMATCH,0
	OPDEF	RIGHTP,10,MISMATCH,MISMATCH,0
	OPDEF	BOS,0,MISMATCH,MISMATCH,0
	OPDEF	EOS,0,MISMATCH,MISMATCH,0
;
	.PAGE
	.SBTTL  TPARSE STATE TABLES
;
;
	$INIT_STATE START,KEYS
;
	$STATE
	$TRAN	TPA$_LAMBDA,,PUSHOP,,,OP_BOS
;
;		LOOKING FOR AN ARITHMETIC EXPRESSION 
;
	$STATE  EXP
	$TRAN	'+',EXP
	$TRAN	'-',EXP,PUSHOP,,,OP_UNMINUS
	$tran	'ACOS',EXP,PUSHOP,,,OP_ACOS
	$tran	'ASIN',EXP,PUSHOP,,,OP_ASIN
	$tran	'ATAN',EXP,PUSHOP,,,OP_ATAN
	$tran	'COS',EXP,PUSHOP,,,OP_COS
	$tran	'SIN',EXP,PUSHOP,,,OP_SIN
	$tran	'TAN',EXP,PUSHOP,,,OP_TAN
	$tran	'ACOSD',EXP,PUSHOP,,,OP_ACOSD
	$tran	'ASIND',EXP,PUSHOP,,,OP_ASIND
	$tran	'ATAND',EXP,PUSHOP,,,OP_ATAND
	$tran	'COSD',EXP,PUSHOP,,,OP_COSD
	$tran	'SIND',EXP,PUSHOP,,,OP_SIND
	$tran	'TAND',EXP,PUSHOP,,,OP_TAND
	$tran	'SQRT',EXP,PUSHOP,,,OP_SQRT
	$tran	'EXP',EXP,PUSHOP,,,OP_EXP
	$tran	'ALOG',EXP,PUSHOP,,,OP_ALOG
	$tran	'LOG',EXP,PUSHOP,,,OP_ALOG
	$tran	'ALOG10',EXP,PUSHOP,,,OP_ALOG10
	$tran	'LOG10',EXP,PUSHOP,,,OP_ALOG10
	$tran	'ABS',EXP,PUSHOP,,,OP_ABS
	$tran	'INT',EXP,PUSHOP,,,OP_INT
	$tran	'NINT',EXP,PUSHOP,,,OP_NINT
	$tran	'REAL',EXP,PUSHOP,,,OP_REAL
	$TRAN	'(',EXP,PUSHOP,,,OP_LEFTP
	$TRAN	!NUMBER,GETOP,PUSHV
	$TRAN	!SYMBOL,GETOP,LOOKUP
;
;		LOOKING FOR AN OPERATOR
;
	$STATE GETOP
	$TRAN	'+',EXP,OPER,,,OP_PLUS
	$TRAN	'-',EXP,OPER,,,OP_MINUS
	$TRAN	!EXPON,EXP,OPER,,,OP_EXPON
	$TRAN	'*',EXP,OPER,,,OP_MULT
	$TRAN	'/',EXP,OPER,,,OP_DIVIDE
	$TRAN	'=',EXP,OPER,,,OP_ASSIGN
	$TRAN	')',GETOP,RIGHTP
	$TRAN	TPA$_EOS,TPA$_EXIT,EOS,,,OP_EOS
;
;		STATE TABLES FOR EXPONENTIATION OPERATOR '**'
;
	$STATE	EXPON
	$TRAN	'*'
;
	$STATE
	$TRAN	'*',TPA$_EXIT
;
;		STATE TABLE FOR A SYMBOL
;
	$STATE	SYMBOL
	$TRAN	TPA$_DIGIT,TPA$_FAIL
	$TRAN	TPA$_SYMBOL,TPA$_EXIT
;
;		STATE TABLES FOR PARSING A FLOATING POINT NUMBER
;
	$STATE	NUMBER
	$TRAN	TPA$_LAMBDA,,NUM_SETUP
;
	$STATE
	$TRAN	!DECIMAL,TPA$_EXIT,NUM_CLEANUP
	$TRAN	!OCTAL,TPA$_EXIT,NUM_CLEANUP
	$TRAN	!HEX,TPA$_EXIT,NUM_CLEANUP
;
;		STATE TABLES FOR PARSING A FLOATING POINT NUMBER
;
	$STATE	DECIMAL
	$TRAN	TPA$_DECIMAL
	$TRAN	'.',GOT_DOT,SET_REAL
;
	$STATE
	$TRAN	'.',,SET_REAL
	$TRAN	'E',GOT_EXP,SET_REAL
	$TRAN	TPA$_LAMBDA,TPA$_EXIT,
;
	$STATE	GOT_DOT
	$TRAN	TPA$_DECIMAL
	$TRAN	TPA$_LAMBDA
;
	$STATE
	$TRAN	'E'
	$TRAN	TPA$_LAMBDA,TPA$_EXIT
;
	$STATE	GOT_EXP
	$TRAN	'+'
	$TRAN	'-'
	$TRAN	TPA$_LAMBDA
;
	$STATE
	$TRAN	TPA$_DECIMAL,TPA$_EXIT
;
;		STATE TABLES FOR PARSING AN OCTAL NUMBER
;
APOSTROPHE=39
;
	$STATE	OCTAL
	$TRAN	APOSTROPHE
;
	$STATE
	$TRAN	TPA$_OCTAL
;
	$STATE
	$TRAN	APOSTROPHE
;
	$STATE
	$TRAN	'O',TPA$_EXIT
;
;		STATE TABLES FOR PARSING A HEXADECIMAL NUMBER
;
	$STATE	HEX
	$TRAN	APOSTROPHE
;
	$STATE
	$TRAN	TPA$_HEX
;
	$STATE
	$TRAN	APOSTROPHE
;
	$STATE
	$TRAN	'X',TPA$_EXIT
;
	$END_STATE
	.PAGE
;
	.PSECT $CODE PIC,CON,REL,LCL,SHR,EXE,RD,NOWRT,LONG
;
	.SBTTL	EXPRESS ENTRY POINT
	.ENTRY	EXPRESS,^M<R2,R3,R4,R5,R6>
;		
;			INITIALIZE STACKS
;
	SUBL2	#FRAME_LEN,SP			;ALLOCATE STACK FRAME
	MOVL	SP,R6
	MOVC3	#FRAME_LEN,P_BLOCK,(R6)		;INITIALIZE STACK FRAME
	CMPL	NARGS(AP),#2			;IF ACTRTN SPECIFIED
	BLSS	5$				;THEN
	MOVL	ACTION(AP),ACTRTN(R6)		    ;SAVE ADDRESS OF ACTION ROUTINE	
	CMPL	NARGS(AP),#3			    ;IF HANDLER SPECIFIED
	BLSS    3$				    ;THEN
	MOVAB	@HANDLER(AP),(FP)			;ESTABLISH CONDITION HANDLER
3$:						    ;ENDIF
	BRB	7$
5$:						;ELSE
	CLRL	ACTRTN(R6)			    ;INDICATE NO ACTRTN
7$:						;ENDIF
	MOVQ	@INLINE(AP),TPA$L_STRINGCNT(R6)	;PUT INPUT STRING DESC. IN P_BLOCK
	MOVAL	STK_LEN(R6),STK_ARG1(R6)	;SET UP ARGUMENT LIST FOR GET_VM
	MOVAL	STK_ADDR(R6),STK_ARG2(R6)
	CALLG	STK_ARGS(R6),G^LIB$GET_VM	;ALLOCATE STACKS
	ADDL3	#STACK_LEN,STK_ADDR(R6),IS0(R6) ;INITIALIZE STACK POINTERS
	ADDL3	#STACK_LEN,IS0(R6),IS1(R6)
	MOVL	IS0(R6),S0_PTR(R6)
	MOVL	IS1(R6),S1_PTR(R6)
;
	PUSHAL	KEYS				;CALL LIB$TPARSE
	PUSHAL	START
	PUSHAL	(R6)
	CALLS	#3,G^LIB$TPARSE
	BLBC	R0,10$				;IF NO ERROR THEN
	PUSHAL	(R6)
	CALLS	#1,EXPR_CLEANUP			    ;CLEANUP STACK
	BRB	20$				
10$:						;ELSE
	PUSHL   R0				    ;CALL LIB$SIGNAL WITH ERROR
	CALLS 	#1,G^LIB$SIGNAL
20$:						;ENDIF
	RET					;RETURN
;
;
;
	.SBTTL	EXPR_CLEANUP  --  CLEANUP OPERAND STACK
;
	.ENTRY	EXPR_CLEANUP,^M<R2,R3,R4>
	MOVL	4(AP),AP			;GET TPARSE BLOCK AS AP
	MOVL	S0_PTR(AP),R3			;GET BASE OF STACK ADDRESS
	MOVL	IS0(AP),R2			;GET CURRENT TOP OF STACK
10$:						;FOR EACH ITEM IN STACK LOOP
	CMPL	R2,R3				;UNTIL BASE IS REACHED
	BEQLU	30$
	MOVL	(R2)+,R4			    ;POP NEXT ITEM
	BITW	#ST_M_TEMP,ST_W_FLAGS(R4)	    ;IF TEMPORARY
	BEQLU	20$				    ;THEN
	PUSHL	R4					;DELETE IT
	PUSHAL	(SP)
	CALLS	#1,G^DELSYM
20$:						    ;ENDIF
	BRB	10$				;REPEAT
30$:
	CALLG	STK_ARGS(AP),G^LIB$FREE_VM	;FREE STACK SPACE
	RET
	.PAGE
	.SBTTL	TPARSE ACTION ROUTINES
;
	.SBTTL	LOOKUP  --  GET SYMBOL TABLE ENTRY FOR VARIABLE
;
;
	.ENTRY	LOOKUP,^M<>
;
;		CHECK FOR EXCESSIVE LENGTH
;
	PUSHL	TPA$L_TOKENCNT(AP)		;SAVE ACTUAL LENGTH
	CMPL	TPA$L_TOKENCNT(AP),#MAX_SYM_LEN ;IF LENGTH IS TOO LONG
	BLEQ	5$				;THEN
	MOVL	#MAX_SYM_LEN,TPA$L_TOKENCNT(AP)     ;USE MAX_SYM_LEN
	PUSHAL	TPA$L_TOKENCNT(AP)		    ;SIGNAL ERROR
	PUSHL	#^X10001
	PUSHL	#CALC_TRUNC
	CALLS	#3,G^LIB$SIGNAL
5$:						;ENDIF
	PUSHAL	TPA$L_TOKENCNT(AP)		;CALL GETSYM TO GET ENTRY
	CALLS	#1,G^GETSYM
	TSTL	R0				;IF NO ENTRY FOUND 
	BNEQU	10$				;THEN
	PUSHAL	TPA$L_TOKENCNT(AP)		    ;CALL GETSYM TO GET ENTRY
	CALLS	#1,G^ADDSYM
10$:						;ENDIF
	MOVL	IS0(AP),R1			;PUSH ENTRY ADDR ON OPERAND
	MOVL	R0,-(R1)			 ;STACK
	MOVL	R1,IS0(AP)
	POPL	TPA$L_TOKENCNT(AP)		;RESTORE ACTUAL NAME LENGTH
	MOVL	#SS$_NORMAL,R0			;INDICATE SUCCESS
	RET					;RETURN
;
;
	.SBTTL	PUSHOP  --  PUSH AN OPERATOR ONTO THE OPERATOR STACK
;
;
	.ENTRY	PUSHOP,^M<>
	MOVL	IS1(AP),R1
	MOVL	TPA$L_PARAM(AP),-(R1)
	MOVL	R1,IS1(AP)
	RET
;
;
	.SBTTL	PUSHV  --  PUSH A NUMBER ONTO OPERAND STACK
;
;
	.ENTRY	PUSHV,^M<>
	CALLS	#0,G^ADDCON
	MOVW	NUM_TYPE(AP),ST_W_TYPE(R0)	;COPY TYPE
	MOVW	NUM_FLAGS(AP),ST_W_FLAGS(R0)	;COPY FLAGS
	BISW	#ST_M_TEMP,ST_W_FLAGS(R0)	;MARK ENTRY AS TEMPORARY
	MOVQ	NUM_VALUE(AP),ST_L_VALUE(R0) 	;COPY VALUE
	MOVL	IS0(AP),R1			;PUSH POINTER ON OPERAND STACK
	MOVL	R0,-(R1)
	MOVL	R1,IS0(AP)
	MOVL	#SS$_NORMAL,R0			;INDICATE SUCCESS
	RET					;RETURN
	.PAGE
;
;
	.SBTTL	OPER  --  EXECUTE OPERATORS IN PRECEDENCE ORDER
;
;
	.ENTRY	OPER,^M<R2,R3,R4,R5>	
;
	MOVL	IS1(AP),R4		;GET OPERATOR STACK POINTER
;
	MOVL	TPA$L_PARAM(AP),R3	;GET CURRENT OPERATOR
	MOVL	PRECTAB-4[R3],R2	;GET PRECEDENCE OF OPERATOR
10$:					;LOOP UNTIL ALL HIGHER PREC OPS DONE
	MOVL	(R4),R5			    ;GET TOP OF OPERATOR STACK
	CMPL	R2,PRECTAB-4[R5]	;WHILE STACK NEEDS TO BE DONE FIRST
	BGTR	20$
	MOVL	(R4)+,OPERATOR(AP)	    ;CALL INTERP TO EXECUTE OPERATOR
	CALLG	(AP),INTERP
	BLBC	R0,20$			;UNTIL ERROR FROM INTERP
	BRB	10$			;REPEAT
20$:
	MOVL	R3,-(R4)		;PUSH OPERATOR ONTO OPERATOR STACK
	MOVL	R4,IS1(AP)
	RET
	.PAGE
;
;
	.SBTTL	EOS  --  PROCESS END OF STRING CONDITION
;
;
	.ENTRY	EOS,^M<R2,R3,R4,R5>
	MOVL	IS1(AP),R4		;GET OPERATOR STACK POINTER
;
10$:					;LOOP 
	MOVL	(R4)+,R5		    ;GET TOP OF OPERAND STACK
	CMPL	R5,#OP_BOS		;UNTIL MATCHING BEGINNING OF STRING
	BEQL	20$
	MOVL	R5,OPERATOR(AP)		;CALL INTERP TO EXECUTE OPERATOR
	CALLG	(AP),INTERP
	BLBC	R0,20$			;UNTIL ERROR FROM INTERP
	BRB	10$			;REPEAT
20$:
	MOVL	R4,IS1(AP)		;RESTORE OPERATOR STACK POINTER
	MOVL	IS0(AP),R2		;GET OPERAND STACK
	MOVL	(R2)+,R4		;GET SYMBOL TABLE ENTRY
	MOVL	R2,IS0(AP)		;RESTORE OPERAND STACK
	BBC	#ST_V_VALID,-		;IF VALID
		  ST_W_FLAGS(R4),40$    ;THEN
	TSTL	ACTRTN(AP)		    ;IF ACTRTN SPECIFIED
	BEQL	30$			    ;THEN
	PUSHL	R4			        ;CALL ACTION ROUTINE
	CALLS	#2,@ACTRTN(AP)
30$:					    ;ENDIF
	BBC	#ST_V_TEMP,-		    ;IF TEMPORARY
		   ST_W_FLAGS(R4),35$	    ;THEN
	PUSHL	R4				;CALL DELSYM
	PUSHAL	(SP)
	CALLS	#1,G^DELSYM
35$:					    ;ENDIF
	BRB	60$
40$:					;ELSE
	PUSHAL	ST_Q_NAME(R4)		    ;SIGNAL ERROR
	MOVW	#1,-(SP)
	MOVW	#1,-(SP)
	PUSHL	#CALC_NONINIT
	CALLS	#3,G^LIB$SIGNAL
60$:					;ENDIF
	MOVL	#SS$_NORMAL,R0		;INDICATE SUCCESS
	RET				;RETURN
	.PAGE
;
;
	.SBTTL	RIGHTP  --  PROCESS RIGHT PAREN
;
;
	.ENTRY	RIGHTP,^M<R3,R4,R5>
	MOVL	IS1(AP),R4		;GET OPERATOR STACK POINTER
;
10$:					;LOOP 
	MOVL	(R4)+,R5		    ;GET TOP OF OPERAND STACK
	CMPL	R5,#OP_LEFTP		;UNTIL MATCHING LEFT PAREN FOUND
	BEQL	20$
	MOVL	R5,OPERATOR(AP)		;CALL INTERP TO EXECUTE OPERATOR
	CALLG	(AP),INTERP
	BLBC	R0,20$			;UNTIL ERROR FROM INTERP
	BRB	10$			;REPEAT
20$:
	MOVL	R4,IS1(AP)		;RESTORE OPERATOR STACK POINTER
	RET				;RETURN
	.PAGE
	.SBTTL	INTERP  --  EXECUTE AN OPERATOR
;
	.ENTRY	INTERP,^M<R2,R3,R4,R5,R6,R7>
;
;
	MOVL	OPERATOR(AP),R5		;GET OPERATOR
	CMPL	R5,#__IOP		;IF LEGITIMATE OPERATOR
	BLSSU	5$			;THEN
	BRW	100$
5$:
	MOVL	FLAGSTAB-4[R5],R7	    ;GET FLAGS
	BITL	#CALL_GETOP1,R7             ;IF CALL_GETOP1
	BEQLU	20$			    ;THEN
	JSB	GETOP1				;GET OPERAND
	CMPL	R2,#ST_K_REAL			;IF REAL
	BNEQU	15$				;THEN
	BITL	#FORCE_INT,R7			    ;IF FORCE_INT
	BEQLU	10$				    ;THEN
	CVTFL	R0,R0					;CONVERT TO INTEGER
	MOVL	#ST_K_INT,R2				;FLAG AS INTEGER
10$:						    ;ENDIF
	BRB	19$
15$:						;ELSE
	BITL	#FORCE_REAL,R7			    ;IF FORCE_REAL
	BEQLU	17$				    ;THEN
	CVTLF	R0,R0					;CONVERT TO REAL
	MOVL	#ST_K_REAL,R2				;FLAG AS REAL
17$:						    ;ENDIF
19$:						;ENDIF
20$:					    ;ENDIF	
	BITL	#CALL_GETOP2,R7		    ;IF CALL_GETOP2
	BEQLU	40$
	JSB	GETOP2				;GET OPERAND
	CMPL	R2,#ST_K_REAL			;IF REAL
	BNEQU	35$				;THEN
	BITL	#FORCE_INT,R7			    ;IF FORCE_INT
	BEQLU	30$				    ;THEN
	CVTLF	R0,R0					;CONVERT TO INTEGER
	CVTLF	R1,R1
	MOVL	#ST_K_INT,R2				;FLAG AS INTEGER
30$:						    ;ENDIF
	BRB	39$
35$:						;ELSE
	BITL	#FORCE_REAL,R7			    ;IF FORCE_REAL
	BEQLU	37$				    ;THEN
	CVTFL	R0,R0					;CONVERT TO REAL
	CVTFL	R1,R1
	MOVL	#ST_K_REAL,R2				;FLAG AS REAL
37$:						    ;ENDIF
39$:						;ENDIF
40$:					    ;ENDIF	
	PUSHL	R2		            ;SAVE TYPE
	CMPL	R2,#ST_K_REAL		    ;IF REAL
	BNEQU	60$			    ;THEN
	MOVL	RCALLTAB-4[R5],R3		;GET ADDRESS OF ROUTINE
	BEQLU	50$				;IF ANY SPECIFIED
	JSB	(R3)				    ;CALL PROCESSING ROUTINE
50$:						;ENDIF
	BRB	80$
60$:					    ;ELSE
	MOVL	ICALLTAB-4[R5],R3		;GET ADDRESS OF ROUTINE
	BEQLU	70$				;IF ANY SPECIFIED
	JSB	(R3)				    ;CALL PROCESSING ROUTINE
70$:						;ENDIF
80$:					    ;ENDIF
	POPL	R2			    ;RESTORE TYPE
	BITL	#CALL_PUTOP,R7		    ;IF CALL_PUTOP
	BEQLU	90$			    ;THEN
	JSB	PUTOP				;CALL PUTOP
90$:					    ;ENDIF
	MOVL	#SS$_NORMAL,R0		    ;SHOW NORMAL RETURN
	BRB	110$
100$:					;ELSE
	JSB	MISMATCH		    ;CALL ERROR ROUTINE
110$:					;ENDIF
	RET				;RETURN
	.PAGE
	.SBTTL	PROCESSING ROUTINES FOR INTERP
;
RNEG:
	MNEGF	R0,R0			;NEGATE REAL R0
	RSB				;RETURN
;
INEG:
	MNEGL	R0,R0			;NEGATE INTEGER R0
	RSB				;RETURN
;
;
;
RSUB:
	SUBF2	R1,R0			;SUBTRACT TWO REAL NUMBERS
	RSB				;RETURN
;
ISUB:
	SUBL2	R1,R0			;SUBTRACT TWO INTEGERS
	RSB				;RETURN
;
;
;
RADD:
	ADDF2	R1,R0			;ADD TWO REAL NUMBERS
	RSB				;RETURN
;
IADD:
	ADDL2	R1,R0			;ADD TWO INTEGER NUMBERS
	RSB				;RETURN
;
;
;
RMULT:
	MULF2	R1,R0			;MULTIPLY TWO REAL NUMBERS
	RSB				;RETURN
;
IMULT:
	MULL2	R1,R0			;MULTIPLY TWO INTEGER NUMBERS
	RSB				;RETURN
;
;
;
RDIVIDE:
	DIVF2	R1,R0			;DIVIDE TWO REAL NUMBERS
	RSB				;RETURN
;
IDIVIDE:
	DIVL2	R1,R0			;DIVIDE TWO INTEGER NUMBERS
	RSB				;RETURN
;
;
;
RABS:
	TSTF	R0			;IF R0 IS NEGATIVE
	BGTR	10$			;THEN
	MNEGF	R0,R0			    ;MAKE IT POSITIVE
10$:					;ENDIF
	RSB
;
IABS:
	TSTL	R0			;IF R0 IS NEGATIVE
	BGTR	10$			;THEN
	MNEGL	R0,R0			    ;MAKE IT POSITIVE
10$:					;ENDIF
	RSB				;RETURN
;
;
;
RNINT:
	CVTRFL	R0,R0			;ROUND REAL TO INTEGER
	MOVL	#ST_K_INT,R2		;FLAG AS INTEGER
	JSB	PUTOP			;CALL PUTOP TO STORE IT AWAY
	RSB				;RETURN
;
;
;
DO_EXPON:
	JSB	GETOP1			;GET EXPONENT
	MOVL	R2,R5			;SAVE TYPE AND VALUE
	MOVL	R0,R4
	JSB	GETOP1			;GET BASE
	CMPL	R5,#ST_K_REAL		;IF EXP IS REAL
	BNEQU	63$			;THEN
	CMPL	R2,#ST_K_INT		    ;IF BASE IS INT
	BNEQU	62$			    ;THEN
	CVTLF	R0,R0				;CVT BASE TO REAL
	MOVL	R5,R2				;MARK RESULT REAL
62$:					    ;ENDIF
	PUSHL	R4			    ;CALL OTS$POWRR
	PUSHL	R0
	CALLS	#2,G^OTS$POWRR
	BRB	66$
63$:					;ELSE (EXP IS INT)
	PUSHL	R4			    ;SET UP ARGS
	PUSHL	R0
	CMPL	R2,#ST_K_INT		    ;IF BASE IS INT
	BNEQU	64$
	CALLS	#2,G^OTS$POWJJ			;CALL POWJJ
	BRB	65$
64$:					    ;ELSE
	CALLS	#2,G^OTS$POWRJ			;CALL POWRJ
65$:					    ;ENDIF
66$:					;ENDIF
	JSB	PUTOP			;PUT RESULT ON OPERAND STACK
	RSB
;
;
;
DO_ASSIGN:
	JSB	GETOP1			;GET CURRENT VALUE
	MOVL	@IS0(AP),R3		;GET DEST. POINTER
	BITW	#ST_M_TEMP,ST_W_FLAGS(R3)  ;IF NOT A SYMBOL 
	BEQL	10$			;THEN
	MOVW	#0,-(SP)		    ;SIGNAL ERROR
	MOVW	#1,-(SP)
	PUSHL	#CALC_NOVAR
	CALLS	#2,G^LIB$SIGNAL
	BRB	20$
10$:					;ELSE
	MOVW	R2,ST_W_TYPE(R3)	    ;SAVE TYPE
	MOVL	R0,ST_L_VALUE(R3)	    ;SAVE VALUE
	BISW	#ST_M_VALID,ST_W_FLAGS(R3)  ;MARK AS VALID
	MOVL	#SS$_NORMAL,R0		    ;RETURN NORMAL STATUS
20$:					;ENDIF
	RSB					
;
;
;
MISMATCH:
	MOVW	#0,-(SP)
	MOVW	#1,-(SP)
	PUSHL	#CALC_MISMATCH
	CALLS	#2,G^LIB$SIGNAL
	RSB					    ;RETURN
	.PAGE
;
;
	.SBTTL	GETOP2  --  GET TWO OPERANDS
;
;  CALLING SEQUENCE:
;	JSB	GETOP2
;
;  REGISTER USAGE:
;	R0		OUTPUT	VALUE OF FIRST OPERAND FROM STACK
;	R1		OUTPUT  VALUE OF SECOND OPERAND FROM STACK
;	R2		OUTPUT  TYPE OF RESULTS
;
GETOP2:
;
	PUSHR	#^M<R3,R4>		;SAVE R3,R4
	JSB	GETOP1			;GET FIRST OPERAND
	PUSHL	R2			;SAVE TYPE AND VALUE
	MOVL	R0,R4
	JSB	GETOP1			;GET SECOND OPERAND
	POPL	R3			;GET FIRST OPERAND TYPE
	CMPL	R3,R2			;IF TYPES ARE DIFFERENT
	BEQLU	30$			;THEN
	CMPL	R3,#ST_K_INT		    ;IF FIRST OPERAND IS INT
	BNEQU	10$			    ;THEN
	CVTLF	R4,R4				;CONVERT IT TO REAL
	BRB	20$
10$:					    ;ELSE
	CVTLF	R0,R0				;CONVERT SECOND TO REAL
	MOVL	R3,R2				;MARK BOTH AS REAL
20$:					    ;ENDIF
30$:					;ENDIF
	MOVL	R4,R1			;PUT SECOND OPERAND IN R1
	POPR	#^M<R3,R4>		;RESTORE R3,R4
	RSB				;RETURN
	.PAGE
;
;
	.SBTTL	GETOP1  --  GET A SINGLE OPERAND
;
;  CALLING SEQUENCE:
;	JSB	GETOP1
;
;  REGISTER USAGE:
;	R0		OUTPUT	VALUE OF OPERAND
;	R1		USED
;	R2		OUTPUT	TYPE OF OPERAND
;
;
GETOP1:
	PUSHL	R3				;SAVE R3
	MOVL	IS0(AP),R2			;GET OPERAND STACK
	MOVL	(R2)+,R1			;GET SYMBOL TABLE ENTRY
	MOVL	R2,IS0(AP)			;RESTORE OPERAND STACK
	BBC	#ST_V_VALID,ST_W_FLAGS(R1),40$  ;IF VALID THEN
	MOVZWL	ST_W_TYPE(R1),R2		    ;RETURN TYPE IN R2
	MOVL	ST_L_VALUE(R1),R3		    ;RETURN VALUE IN R3
	BBC	#ST_V_TEMP,ST_W_FLAGS(R1),20$	    ;IF TEMPORARY ENTRY THEN
	PUSHL	R1					;CALL DELSYM
	PUSHAL	(SP)
	CALLS	#1,G^DELSYM
	ADDL	#4,SP					;CLEAN UP STACK
20$:						    ;ENDIF
	MOVL	R3,R0				    ;PUT VALUE IN R0
	BRB	60$
40$:						;ELSE
	PUSHAL	ST_Q_NAME(R1)			    ;SIGNAL ERROR
	MOVW	#1,-(SP)
	MOVW	#1,-(SP)
	PUSHL	#CALC_NONINIT
	CALLS	#3,G^LIB$SIGNAL
60$:						;ENDIF
	POPL	R3				;RESTORE R3
	RSB					;RETURN
	.PAGE
;
;
	.SBTTL	PUTOP  --  SAVE VALUE ON OPERAND STACK
;
;  CALLING SEQUENCE:
;	JSB	PUTOP
;
;  REGISTER USAGE:
;	R0		INPUT	VALUE OF OPERAND TO BE STORED
;	R1		USED
;	R2		INPUT	TYPE OF OPERAND TO BE STORED
;
;
PUTOP:
	PUSHL	R0				;SAVE VALUE
	CALLS	#0,G^ADDCON			;CALL ADDCON TO GET ENTRY
	MOVL	IS0(AP),R1			;SAVE ADDRESS ON OPERAND STACK
	MOVL	R0,-(R1)
	MOVL	R1,IS0(AP)
	POPL	ST_L_VALUE(R0)			;SAVE VALUE IN ENTRY
	MOVW	R2,ST_W_TYPE(R0)		;SAVE TYPE IN ENTRY
	MOVW	#ST_M_VALID ! ST_M_TEMP,-
			ST_W_FLAGS(R0)		;MARK AS VALID AND TEMPORARY
	RSB					;RETURN
	.PAGE
;
;
	.SBTTL  NUM_SETUP  --  SETUP FOR NUMBER PARSING
;
;
	.ENTRY	NUM_SETUP,^M<>
	MOVL	TPA$L_STRINGPTR(AP),NUM_START(AP)  ;SAVE CURRENT ADDRESS
	CLRW	NUM_TYPE(AP)			   ;CLEAR TYPE
	CLRW	NUM_FLAGS(AP)			   ;CLEAR FLAGS
	CLRQ	NUM_VALUE(AP)			   ;CLEAR RESULT
	RET
;
;
	.SBTTL	SET_REAL  --  SET TYPE TO REAL
;
;
	.ENTRY	SET_REAL,^M<>
	MOVW	#ST_K_REAL,NUM_TYPE(AP)		;SET TYPE TO REAL
	RET
;
;
	.SBTTL	NUM_CLEANUP  --  DETERMINE VALUE OF NUMBER
;
;
	.ENTRY	NUM_CLEANUP,^M<>
	MOVL	TPA$L_NUMBER(AP),NUM_VALUE(AP)  ;COPY LAST NUMBER PARSED
	CMPW	#ST_K_REAL,NUM_TYPE(AP)		;IF DECIMAL POINT FOUND
	BNEQU	100$
	SUBL3	NUM_START(AP),TPA$L_STRINGPTR(AP),-     ;BUILD DESCR
		 NUM_DESCR(AP)
	MOVAQ	NUM_DESCR(AP),NUM_ARG1(AP)	    ;BUILD ARGUMENT LIST
	MOVAD	NUM_VALUE(AP),NUM_ARG2(AP)
	CALLG	NUM_ARGS(AP),G^OTS$CVT_T_D		    ;CALL OTS TO CONVERT
	BRB	105$
100$:   					;ELSE
	MOVW	#ST_K_INT,NUM_TYPE(AP)		    ;MARK IT AS AN INTEGER
105$:						;ENDIF
	BLBC	R0,110$				;IF NO ERROR
	BISW	#ST_M_VALID,NUM_FLAGS(AP)	    ;MARK ITEM AS VALID
	BRB	120$
110$:						;ELSE
	PUSHAL	NUM_DESCR(AP)			    ;SIGNAL ERROR
	MOVW	#1,-(SP)
	MOVW	#1,-(SP)
	PUSHL	#CALC_BADNUMBER
	CALLS	#3,G^LIB$SIGNAL
120$:						;ENDIF
	RET					;RETURN
;
	.PAGE
	.SBTTL	P_BLOCK	 --  INITIAL STACK FRAME
;
	.PSECT	P_BLOCK PIC,CON,REL,LCL,SHR,NOEXE,RD,NOWRT,LONG
;
P_BLOCK:
	.LONG	TPA$K_LENGTH0		;TPA$L_COUNT 
	.LONG	0			;TPA$L_OPTIONS
	.LONG	0			;TPA$L_STRINGCNT
	.LONG	0			;TPA$L_STRINGPTR
	.LONG	0			;TPA$L_TOKENCNT
	.LONG	0			;TPA$L_TOKENPTR
	.LONG	0			;TPA$L_CHAR
	.LONG	0			;TPA$L_NUMBER
	.LONG	0			;TPA$L_PARAM
;
;		    DUMMY SYMBOL TABLE ENTRY FOR NUMBERS
;
	.WORD	0			;NUM_TYPE
	.WORD	0			;NUM_FLAGS
	.LONG	0,0			;NUM_VALUE
	.LONG	0			;NUM_DESCR
	.LONG	0			;NUM_START
;
;		    ARGUMENT LIST FOR OTS$CVT_T_D
;
	.LONG	5			;NUM_ARGS
	.LONG	0			;NUM_ARG1  --  STRING DESCR.
	.LONG	0			;NUM_ARG2  --  RESULT ADDR.
	.LONG	0			;DIGITS IN FRACTION
	.LONG	0			;SCALE FACTOR
	.LONG	1 ! 2 ! 32		;FLAGS
;
;		    ARGUMENT LIST FOR LIB$GET_VM AND FREE_VM
;
	.LONG	2			;STK_ARGS
	.LONG	0			;STK_ARG1
	.LONG	0			;STK_ARG2
STACK_LEN	=	400		    ;NUMBER OF BYTES IN LOCAL STACKS
	.LONG	STACK_LEN*2		;STK_LEN
	.LONG	0			;STK_ADDR
;
;		    LOCAL VARIABLES
;
	.LONG	0			;IS0
	.LONG	0			;IS1
	.LONG	0			;S0_PTR
	.LONG	0			;S1_PTR
	.LONG	0			;ACTRTN
	.LONG	0			;OPERATOR
;
EXPR_FRAME_LEN	==	FRAME_LEN	;PASS FRAME_LEN OUT TO CONDITION HANDLER
;
	.END