; Altirra BASIC - Expression evaluator module
; Copyright (C) 2014 Avery Lee, All Rights Reserved.
;
; Copying and distribution of this file, with or without modification,
; are permitted in any medium without royalty provided the copyright
; notice and this notice are preserved.  This file is offered as-is,
; without any warranty.

;===========================================================================
; The stack handling is conceptually similar to that of Atari BASIC, but
; has diverged quite a bit for efficiency. It now looks like this:
;
; +----------------------+  LOMEM + $100
; |    operator stack    |
; +----------------------+
; .          |           .
; .          v           .
; .                      .
; .          ^           .
; .          |           .
; +----------------------+
; |   argument stack 2   |
; +----------------------+  LOMEM + $6C
; .                      .
; .                      .
; .          ^           .
; .          |           .
; +----------------------+
; |   argument stack 1   |
; +----------------------+  LOMEM
;
; The argument stacks together contain the values pushed onto the stack
; and grow upward, while the operator stack grows downward from the top.
; opsp points to the last valid location. There is enough room for 36
; levels of nesting.
;
; The paired argument stack is very different from Atari BASIC. First,
; it only contains six bytes per entry instead of eight, omitting the
; type and variable bytes. This is because most of the time keeping
; these on the stack is unnecessary -- the argument types for each token
; type are already known and enforced by the parser. A couple of statements
; do take both types, including LIST, INPUT, and PRINT, and for those we
; maintain a type byte for the top of stack. Variable information is
; available from LVARPTR for the leftmost variable and VARPTR for the
; rightmost variable.
;
; The six bytes of the argument stack are split between the two argument
; stacks, with even bytes in stack 1 and odd bytes in stack 2. This serves
; two purposes, one being to reduce the amount of stack pointer futzing
; we have to do, and also to provide easy access to 16-bit quantities.
; argsp points to the next available location. It would be faster to
; store the stack as SoA like Turbo Basic XL does, but since we are running
; from ROM and have neither a suitable absolute addressed writable area
; nor enough zero page to burn on 6 pointers, we sacrifice a little
; speed here.
;
; There is one other trick that we do, which is to cache the top of stack
; in FR0. Each argument stack is actually shifted up one entry, with the
; first entry not used. This is a substantial performance and size
; optimization as it eliminates a lot of paired pushes and pops. For
; instance, instead of doing pop(fr1)/pop(fr0)/fadd/push(fr0) for an add
; token, we simply just do pop(fr1)/fadd. Unary operators are even
; simpler -- ABS() just has to clear FR0 bit 7!
;
; The bottom of the stack, argsp=0, has special significance when in an
; assignment context (expAsnCtx bit 7 = 1). Two differences in execution
; occur in this situation. First, a pointer to the variable's value is
; stashed in LVARPTR for later use. Second, the string indexing function
; allows selecting a range beyond the current length of a string.

;===========================================================================
ExprSkipCommaAndEvalPopInt:
		inc		exLineOffset
.proc	evaluateInt
		jsr		evaluate
		jmp		ExprConvFR0Int
.endp

;===========================================================================
.proc evaluateHashIOCBOpt
		;default to IOCB #0
		lda		#0
		sta		iocbidx
		
		;check if we have an IOCB
		ldy		exLineOffset
		lda		(stmcur),y
		cmp		#TOK_EXP_HASH
		bne		valid_iocb

.def :evaluateHashIOCB = *
		jsr		evaluateHashIOCBNoCheckOpen

		;okay, now we need to check if this IOCB is actually open
		tax
		ldy		ichid,x
		bpl		valid_iocb_2
		
		;force an IOCB not open error
		lda		#$85
		sta		errno
		jmp		errorDispatch
		
valid_iocb_2:
		lda		#0		;set Z=1 to indicate #iocb found
valid_iocb:
		rts
.endp

;===========================================================================
.proc	evaluateHashIOCBNoCheckOpen
		jsr		ExprSkipCommaAndEvalPopIntPos
		bne		invalid_iocb

		;IOCB #0 is never allowed
		txa
		beq		invalid_iocb

		;IOCB #8+ is invalid
		cmp		#8
		bcc		plausible_iocb
invalid_iocb:
		jmp		errorBadDeviceNo
		
plausible_iocb:
		asl
		asl
		asl
		asl
		sta		iocbidx
		rts
.endp

;===========================================================================
.proc	evaluateAssignment
		lda		#$80
		jmp		evaluate._assign_entry
.endp

;===========================================================================
ExprSkipCommaAndEvalVar = ExprSkipCommaAndEval
evaluateVar = evaluate

;===========================================================================
.proc ExprPushLiteralConst
		jsr		ExprPushExtFR0
		ldy		exLineOffset
		:6 mva (stmcur),y+ fr0+#
		ldx		#0
		stx		expType
		sty		exLineOffset
		jmp		evaluate.loop
.endp

;===========================================================================
.proc ExprPushLiteralStr
		;build argument stack entry
		jsr		ExprPushExtFR0
		lda		#$83
		sta		expType
		
		;address
		lda		stmcur
		sec								;+1 to skip length
		adc		exLineOffset
		sta		fr0
		lda		#0
		sta		fr0+3
		sta		fr0+5
		adc		stmcur+1
		sta		fr0+1
		
		;length
		;dimensioned length	
		;load and stash string literal length (so we don't have to thrash Y)
		ldy		exLineOffset
		lda		(stmcur),y
		sta		fr0+2
		sta		fr0+4
		
		;skip past length and string in statement text
		sec
		adc		exLineOffset
		sta		exLineOffset		
		;all done
		jmp		evaluate.loop
.endp


;===========================================================================
; Main expression evaluator.
;
; _assign_entry:
;	Special entry point that takes custom evaluation flags in the A
;	register:
;
;	bit 7 = assignment context - allow string bounds beyond current
;	        length for first lvalue
;
;	bit 6 = DIM context - allow references to undimensioned array/string
;	        variables
;
ExprSkipCommaAndEval:
		inc		exLineOffset
.proc	evaluate
_tmpadr = fr0+1

		;set up rvalue context
		lda		#0
_assign_entry = *
		sta		expAsnCtx
		
		;;##TRACE "Beginning evaluation at $%04x+$%02x = $%04x" dw(stmcur) db(exLineOffset) dw(stmcur)+db(exLineOffset)

		;reset stack pointers
		ldy		#0
		sty		opsp
		sty		argsp
		sty		expCommas
loop:
		;get next token
		ldy		exLineOffset
		inc		exLineOffset
		lda		(stmcur),y
		;;##TRACE "Processing token: $%02x ($%04x+$%02x=$%04x)" (a) dw(stmcur) y dw(stmcur)+y
		
		;check if this token needs to be reduced immediately
		bmi		is_variable
		cmp		#$0f
		bcc		ExprPushLiteralConst
		beq		ExprPushLiteralStr
not_imm:
			
		;==== reduce loop ====
				
		;reduce while precedence of new operator is equal or lower than
		;precedence of last operator on stack
		
		;get push-on / shift precedence
		;
		;We know that function tokens never immediately reduce, so we can jump directly
		;to shift in that case.
		cmp		#$3d
		bcs		shift_a
		sta		expCurOp
		tax
		lda		precon_table-$10,x

		sta		expCurPrec
		;;##TRACE "Current operator get-on precedence = $%02x" a

reduce_loop:		
		ldy		opsp
		beq		reduce_done
		lda		(argstk),y
		
		;get pull-off/reduce precendence
		tax
		cpx		#$3d
		bcs		check_fntoken
		ldy		precoff_table-$10,x
		
		;stop reducing if the current operator has higher precedence
		;;##TRACE "Checking precedence: tos $%02x vs. cur $%02x" a db(expCurPrec)
		cpy		expCurPrec
		bcc		reduce_done
		
reduce_go:
		inc		opsp
		jsr		dispatch
		;##ASSERT (db(argsp)%3)=0
		jmp		reduce_loop

check_fntoken:
		ldy		#13
		cpy		expCurPrec
		bcs		reduce_go

reduce_done:
		;exit if this is not an expression token
		lda		expCurPrec
		beq		done

		;push current operator on stack
		lda		expCurOp		
shift_a:
		dec		opsp	
		ldy		opsp
		;;##TRACE "Shift: $%02x" (a)
		sta		(argstk),y
		bne		loop
done:	
		;;##TRACE "Exiting evaluator"
		dec		exLineOffset
		rts
				
is_variable:
		;get value address of variable
		jsr		VarGetAddr0
		
		;check if this is the first var at the base -- if so, set the
		;lvalue ptr for possible assignment
		ldy		argsp
		bne		not_lvalue
		
		clc
		lda		varptr
		adc		#2
		sta		lvarptr
		lda		varptr+1
		adc		#0
		sta		lvarptr+1
		
		;since we know the stack is empty, we know we don't need to push, either
		ldy		#3
		sty		argsp
		bne		skip_push_fr0

not_lvalue:

		;push variable entry from VNTP onto argument stack
		jsr		ExprPushFR0NonEmpty

skip_push_fr0:
		;load variable
		jsr		VarLoadFR0

		;fetch type and set expression type
		ldy		#0
		lda		(varptr),y
		sta		expType
		
		;check if we had an array or string		
		;;##TRACE "arg %02x %02x %02x %02x" db(dw(argstk)+0) db(dw(argstk)+1) db(dw(argstk)+2) db(dw(argstk)+3)
		cmp		#$40
		bcc		loop

		;check if it is dimensioned
		lsr
		bcc		not_dimmed
		
undim_ok:
		;check if we have a relative pointer
		lsr
		bcs		loop
		
		;it's relative -- convert relative pointer to absolute
		;;##TRACE "Converting to absolute"
		lda		fr0
		adc		starp
		sta		fr0
		lda		fr0+1
		adc		starp+1
		sta		fr0+1

		;push variable onto argument stack and exit
		jmp		loop

not_dimmed:
		;check if we allow unDIM'd vars (i.e. we're in DIM)
		bit		expAsnCtx
		bvs		undim_ok
		jmp		errorDimError

dispatch:
		;;##TRACE "Reduce: $%02x (%y) - %u values on stack (%g %g)" (a) db(functionDispatchTableLo-14+a)+256*db(functionDispatchTableLo-14+a)+1 db(argsp)/3 dw(argstk)+db(argsp)-6 fr0
		tax
		lda		functionDispatchTableHi-$10,x
		pha
		lda		functionDispatchTableLo-$10,x
		pha
		rts
.endp

;===========================================================================
; Precedence tables
;
; There are two precedences for each operator, a go-on and come-off
; precedence. A reduce happens if prec_on(cur) <= prec_off(tos); a
; shift happens otherwise. A prec_on of zero also terminates evaluation
; after the entire stack is reduced.
;
; For values, prec_on and prec_off are always the same high value, always
; forcing a shift and an immediate reduce.
;
; For arithmetic operators, prec_on <= prec_off for left associativity and
; prec_on > prec_off for right associativity.
;
; Parens and commas deserve special attention here. For the open parens
; operators, prec_on is high in order to force a shift and prec_off is
; low in order to stall reduction. For the close parens operators, prec_on
; is low to force a reduce immediately and prec_off is low so that nothing
; causes it to reduce except an open parens. In order to prevent a close
; parens from consuming more than one open parens, the close parens routine
; short-circuits the reduce loop, preventing any further reduction and
; preventing the close parens from being shifted onto the stack.
;

.macro	_PREC
		dta [:1&8]*16+[:1&4]*8+[:1&2]*4+[:1&1]*2+[:2&8]*8+[:2&4]*4+[:2&2]*2+[:2&1]*1
.endm

.proc	precon_table
		dta		 0				;$10
		dta		 0				;$11
		dta		 0				;$12	,
		dta		 0				;$13	$
		dta		 0				;$14	: (statement end)
		dta		 0				;$15	;
		dta		 0				;$16	EOL
		dta		 0				;$17	goto
		dta		 0				;$18	gosub
		dta		 0				;$19	to
		dta		 0				;$1A	step
		dta		 0				;$1B	then
		dta		 0				;$1C	#
		dta		 7				;$1D	<=
		dta		 7				;$1E	<>
		dta		 7				;$1F	>=
		dta		 7				;$20	<
		dta		 7				;$21	>
		dta		 7				;$22	=
		dta		10				;$23	^
		dta		 9				;$24	*
		dta		 8				;$25	+
		dta		 8				;$26	-
		dta		 9				;$27	/
		dta		 6				;$28	not
		dta		 4				;$29	or
		dta		 5				;$2A	and
		dta		13				;$2B	(
		dta		 1				;$2C	)
		dta		 3				;$2D	= (numeric assignment)
		dta		 3				;$2E	= (string assignment)
		dta		12				;$2F	<= (strings)
		dta		12				;$30	<>
		dta		12				;$31	>=
		dta		12				;$32	<
		dta		12				;$33	>
		dta		12				;$34	=
		dta		11				;$35	+ (unary)
		dta		11				;$36	-
		dta		14				;$37	( (string left paren)
		dta		14				;$38	( (array left paren)
		dta		14				;$39	( (dim array left paren)
		dta		14				;$3A	( (fun left paren)
		dta		14				;$3B	( (dim str left paren)
		dta		 3				;$3C	, (array/argument comma)
		
		;$3D and on are functions - no need for an entry as we force shift
.endp

.proc	precoff_table
		dta		0				;$10
		dta		0				;$11
		dta		0				;$12	,
		dta		0				;$13	$
		dta		0				;$14	: (statement end)
		dta		0				;$15	;
		dta		0				;$16	EOL
		dta		0				;$17	goto
		dta		0				;$18	gosub
		dta		0				;$19	to
		dta		0				;$1A	step
		dta		0				;$1B	then
		dta		0				;$1C	#
		dta		7				;$1D	<=
		dta		7				;$1E	<>
		dta		7				;$1F	>=
		dta		7				;$20	<
		dta		7				;$21	>
		dta		7				;$22	=
		dta		10				;$23	^
		dta		9				;$24	*
		dta		8				;$25	+
		dta		8				;$26	-
		dta		9				;$27	/
		dta		6				;$28	not
		dta		4				;$29	or
		dta		5				;$2A	and
		dta		2				;$2B	(
		dta		1				;$2C	)
		dta		3				;$2D	= (numeric assignment)
		dta		3				;$2E	= (string assignment)
		dta		12				;$2F	<= (strings)
		dta		12				;$30	<>
		dta		12				;$31	>=
		dta		12				;$32	<
		dta		12				;$33	>
		dta		12				;$34	=
		dta		10				;$35	+ (unary)
		dta		10				;$36	-
		dta		2				;$37	( (string left paren)
		dta		2				;$38	( (array left paren)
		dta		2				;$39	( (dim array left paren)
		dta		2				;$3A	( (fun left paren)
		dta		2				;$3B	( (dim str left paren)
		dta		2				;$3C	, (array/argument comma)
		
		;$3D and on are functions - special cased in code
		;dta		13
.endp

;===========================================================================
ExprPopExtFR0 = expPopFR0

;===========================================================================
.proc	expPopFR0
		ldy		argsp
		;##ASSERT (y%3)=0 and y
		dey
		mva		(argstk2),y fr0+5
		mva		(argstk),y fr0+4
		dey
		mva		(argstk2),y fr0+3
		mva		(argstk),y fr0+2
		dey
		mva		(argstk2),y fr0+1
		mva		(argstk),y fr0
		sty		argsp
		rts
.endp

;===========================================================================
; Output:
;	A:X = integer value
;	P.N,Z = set from A
;
.proc	expPopFR0Int
		jsr		expPopFR0
.def :ExprConvFR0Int = *
		jsr		fpi
		bcs		fail
		ldx		fr0
		lda		fr0+1
		rts
fail:
		jmp		errorValueErr
.endp

;===========================================================================
; Output:
;	A:X = integer value
;	P.N,Z = set from A
;
ExprSkipCommaAndEvalPopIntPos:
		inc		exLineOffset
ExprEvalPopIntPos:
		jsr		evaluate
.proc	ExprConvFR0IntPos
		jsr		ExprConvFR0Int
		bmi		is_neg
		rts
is_neg:
		jmp		errorValue32K
.endp

;===========================================================================
.proc	expPopFR1
		ldy		argsp
		;##ASSERT (y%3)=0 and y
		dey
		mva (argstk2),y fr1+5
		mva (argstk),y fr1+4
		dey
		mva (argstk2),y fr1+3
		mva (argstk),y fr1+2
		dey
		mva (argstk2),y fr1+1
		mva (argstk),y fr1
		sty		argsp
		rts
.endp

;===========================================================================
.proc	ExprPushExtFR0
		ldy		argsp
		beq		stack_empty
.def :ExprPushFR0NonEmpty = *
		mva		fr0 (argstk),y
		mva		fr0+1 (argstk2),y+
		mva		fr0+2 (argstk),y
		mva		fr0+3 (argstk2),y+
		mva		fr0+4 (argstk),y
		mva		fr0+5 (argstk2),y+
		sty		argsp
		rts
stack_empty:
		ldy		#3
		sty		argsp
		rts
.endp

;===========================================================================
; Inputs:
;	X = zero page location to store FR0+1,FR0 to
;
.proc ExprStoreFR0Int
		mwa		fr0 0,x
		rts
.endp

;===========================================================================
.proc functionDispatchTableLo
		;$10
		dta		<[0]
		dta		<[0]
		dta		<[expComma-1]
		dta		<[0]
		dta		<[0]
		dta		<[0]
		dta		<[0]
		dta		<[0]
		dta		<[0]
		dta		<[0]
		dta		<[0]
		dta		<[0]
		dta		<[0]
		dta		<[funCompare-1]
		dta		<[funCompare-1]
		dta		<[funCompare-1]

		;$20
		dta		<[funCompare-1]
		dta		<[funCompare-1]
		dta		<[funCompare-1]
		dta		<[funPower-1]
		dta		<[funMultiply-1]
		dta		<[funAdd-1]
		dta		<[funSubtract-1]
		dta		<[funDivide-1]
		dta		<[funNot-1]
		dta		<[funOr-1]
		dta		<[funAnd-1]
		dta		<[funOpenParens-1]
		dta		<[0]
		dta		<[funAssignNum-1]
		dta		<[funAssignStr-1]
		dta		<[funStringCompare-1]

		;$30
		dta		<[funStringCompare-1]
		dta		<[funStringCompare-1]
		dta		<[funStringCompare-1]
		dta		<[funStringCompare-1]
		dta		<[funStringCompare-1]
		dta		<[funUnaryPlus-1]
		dta		<[funUnaryMinus-1]
		dta		<[funArrayStr-1]
		dta		<[funArrayNum-1]
		dta		<[funDimArray-1]
		dta		<[funOpenParens-1]
		dta		<[funDimStr-1]
		dta		<[funArrayComma-1]
		
		;$3D
		dta		<[funStr-1]
		dta		<[funChr-1]
		dta		<[funUsr-1]

		;$40
		dta		<[funAsc-1]
		dta		<[funVal-1]
		dta		<[funLen-1]
		dta		<[funAdr-1]
		dta		<[funAtn-1]
		dta		<[funCos-1]
		dta		<[funPeek-1]
		dta		<[funSin-1]
		dta		<[funRnd-1]
		dta		<[funFre-1]
		dta		<[funExp-1]
		dta		<[funLog-1]
		dta		<[funClog-1]
		dta		<[funSqr-1]
		dta		<[funSgn-1]
		dta		<[funAbs-1]
		
		;$50
		dta		<[funInt-1]
		dta		<[funPaddleStick-1]		;PADDLE
		dta		<[funPaddleStick-1]		;STICK
		dta		<[funPaddleStick-1]		;PTRIG
		dta		<[funPaddleStick-1]		;STRIG
		dta		0
		dta		0
		dta		0
		dta		0
		dta		0
		dta		0
		dta		0
		dta		<[funHex-1]
		dta		0
		dta		<[funDpeek-1]
.endp

.proc functionDispatchTableHi
		;$10
		dta		>[0]
		dta		>[0]
		dta		>[expComma-1]
		dta		>[0]
		dta		>[0]
		dta		>[0]
		dta		>[0]
		dta		>[0]
		dta		>[0]
		dta		>[0]
		dta		>[0]
		dta		>[0]
		dta		>[0]
		dta		>[funCompare-1]
		dta		>[funCompare-1]
		dta		>[funCompare-1]

		;$20
		dta		>[funCompare-1]
		dta		>[funCompare-1]
		dta		>[funCompare-1]
		dta		>[funPower-1]
		dta		>[funMultiply-1]
		dta		>[funAdd-1]
		dta		>[funSubtract-1]
		dta		>[funDivide-1]
		dta		>[funNot-1]
		dta		>[funOr-1]
		dta		>[funAnd-1]
		dta		>[funOpenParens-1]
		dta		>[0]
		dta		>[funAssignNum-1]
		dta		>[funAssignStr-1]
		dta		>[funStringCompare-1]

		;$30
		dta		>[funStringCompare-1]
		dta		>[funStringCompare-1]
		dta		>[funStringCompare-1]
		dta		>[funStringCompare-1]
		dta		>[funStringCompare-1]
		dta		>[funUnaryPlus-1]
		dta		>[funUnaryMinus-1]
		dta		>[funArrayStr-1]
		dta		>[funArrayNum-1]
		dta		>[funDimArray-1]
		dta		>[funOpenParens-1]
		dta		>[funDimStr-1]
		dta		>[funArrayComma-1]
		
		;$3D
		dta		>[funStr-1]
		dta		>[funChr-1]
		dta		>[funUsr-1]

		;$40
		dta		>[funAsc-1]
		dta		>[funVal-1]
		dta		>[funLen-1]
		dta		>[funAdr-1]
		dta		>[funAtn-1]
		dta		>[funCos-1]
		dta		>[funPeek-1]
		dta		>[funSin-1]
		dta		>[funRnd-1]
		dta		>[funFre-1]
		dta		>[funExp-1]
		dta		>[funLog-1]
		dta		>[funClog-1]
		dta		>[funSqr-1]
		dta		>[funSgn-1]
		dta		>[funAbs-1]
		
		;$50
		dta		>[funInt-1]
		dta		>[funPaddleStick-1]		;PADDLE
		dta		>[funPaddleStick-1]		;STICK
		dta		>[funPaddleStick-1]		;PTRIG
		dta		>[funPaddleStick-1]		;STRIG
		dta		0
		dta		0
		dta		0
		dta		0
		dta		0
		dta		0
		dta		0
		dta		>[funHex-1]
		dta		0
		dta		>[funDpeek-1]
.endp
