\ algebraic functions

vocabulary algebra

algebra also definitions	\ defined in portability layer

create op_stack 20 cells allot	\ operator stack for algebraic
				\ equation compilation

\ col_id function assigns n to id at compile time  ( n --)
\ expects row # on tos at run time.
\ subsequent usage of id fetches double value of cell to stack

\ 32-bit
: col_id				\ column_id high-level defining word.
	create	,			\ creates col ids a-z
	does>	@ spcells cell+ @ ;	\ expect a # on the tos and
					\ pushes the cell value onto 
                                        \ the parameter stack
                    
: assign_id
	col_max 0			\ loop used to assign values to
	do  i col_id  loop ;		\ the alphabetic columns

assign_id    a b c d e f g h i j k l m n o p
                 q r s t u v w x y z

\ 
\ for example:  1 a  returns the double-int value of cell  1 a
\ 
\ column ids A-Z return values of 0-25 respectively

: opp@		( -- addr )	\ return oprnd stack position
	op_stack dup @ + ;	\ 1st location is stack ptr

: >op		\ ( cfa prec -- )
	2 cells op_stack +!
	opp@ 2! ;		\ store cfa and precedence top of oprnd stack
                    
: op>
	opp@ 2@	( cfa prec )
	2 cells negate op_stack +!	\ pop cfa and prec off oprnd
	drop compile, ;			\ stack and compile into dict.

: prec?		\ ( -- prec )
	opp@ @ ;		\ return precedence from top of oprnd stack

: ]a				\ end algebraic compilation
	begin	prec?        
	while	op>		\ pop remaining oprnds off stk
	repeat			\ and compile then select forth
	forth ; immediate	\ vocabulary again 

\ create high-level definition that performs algebraic
\ compilation.  see text for details of operation

: infix
	' create			\ create new algebraic operator
		swap , , immediate	\ compile cfa of forth operator
	does>   2@			\ and assigned precedence
		begin dup prec? > not	\ at compile time execute if
					\ prec is lower than oprnd on
		while	>r >r  op>  r> r>
		repeat
		>op ;			\ top of oprnd stack

7 infix * *
7 infix / /
6 infix + +
6 infix - -
5 infix mod mod

: )missing				\ missing ) message
	true abort" missing )" ;	\ if missing then abort

: (					\ left paren
	['] )missing  1 >op ;		\ prec=1 cfa= )missing message
	immediate			\ push on oprnd stack

\ Forth needs to be before algebra in the search order

only forth spread also algebra also  forth also
algebra definitions

: )
	[ forth ]			\ right paren
	begin	1 prec? <		\ causes all items on oprnd
	while	op>			\ stack to be compiled until
	repeat
	1 prec? =			\ left paren found
	if	2 cells negate op_stack +!	\ left paren should have prec.
	else	true abort" missing ("		\ of 1 else error msg output
	then ;  immediate

spread definitions

: a[					\ start algebraic compilation
	op_stack off			\ reset oprnd stack and
	algebra ; immediate		\ select algebra vocabulary
