%{

include	<lexnum.h>
include	<ctype.h>
include <fset.h>
include	"vex.h"

define	YYMAXDEPTH	64
define	YYOPLEN		1
define	yyparse		vex_parse

# Tokens generated by xyacc have been moved to vex.h

%L

%}

%token		Y_WRONG Y_LPAR Y_RPAR Y_COMMA 
%token		Y_VAR Y_INT Y_REAL Y_DOUBLE
%token		Y_FN1 Y_FN2 Y_IF Y_THEN Y_ELSE Y_DONE 

%left		Y_OR
%left		Y_AND
%right		Y_NOT
%nonassoc	Y_EQ Y_NE
%nonassoc	Y_LT Y_GT Y_LE Y_GE
%left		Y_ADD Y_SUB
%left		Y_MUL Y_DIV
%right		Y_NEG
%right		Y_POW

%%

stmt	:	ifexpr Y_DONE {
			# Normal exit. Code a stop instruction
			call vex_addcode (Y_DONE)
			return (OK)
		}
	|	error {
			return (ERR)
		}
	;

ifexpr	:	Y_IF expr Y_THEN expr Y_ELSE ifexpr {
			# Code an if instruction
			call vex_addcode (Y_IF)
		}
	|	expr {
			# Null action
		}
	;

expr	:	Y_VAR {
			# Code a push variable instruction
			call vex_addcode (Y_VAR)
			call vex_addstr (Memi[$1])
		}
	|	Y_INT {
			# Code a push variable instruction
			call vex_addcode (Y_INT)
			call vex_addstr (Memi[$1])
		}
	|	Y_REAL {
			# Code a push variable instruction
			call vex_addcode (Y_REAL)
			call vex_addstr (Memi[$1])
		}
	|	Y_DOUBLE {
			# Code a push variable instruction
			call vex_addcode (Y_DOUBLE)
			call vex_addstr (Memi[$1])
		}
	|	Y_FN1 Y_LPAR expr Y_RPAR {
			# Code a single argument function call
			call vex_addcode (Y_FN1)
			call vex_addstr (Memi[$1])
		}
	|	Y_FN2 Y_LPAR expr Y_COMMA expr Y_RPAR {
			# Code a double argument function call
			call vex_addcode (Y_FN2)
			call vex_addstr (Memi[$1])
		}
	|	Y_SUB expr %prec Y_NEG {
			# Code a negation instruction
			call vex_addcode (Y_NEG)
		}
	|	Y_NOT expr {
			# Code a logical not
			call vex_addcode (Y_NOT)
		}
	|	expr Y_POW expr {
			# Code an exponentiation instruction
			call vex_addcode (Y_POW)
		}
	|	expr Y_MUL expr {
			# Code a multiply instruction
			call vex_addcode (Y_MUL)
		}
	|	expr Y_DIV expr {
			# Code a divide instruction
			call vex_addcode (Y_DIV)
		}
	|	expr Y_ADD expr {
			# Code an addition instruction
			call vex_addcode (Y_ADD)
		}
	|	expr Y_SUB expr {
			# Code a subtraction instruction
			call vex_addcode (Y_SUB)
		}
	|	expr Y_LT expr {
			# Code a less than instruction
			call vex_addcode (Y_LT)
		}
	|	expr Y_GT expr {
			# Code a greater than instruction
			call vex_addcode (Y_GT)
		}
	|	expr Y_LE expr {
			# Code a less than or equal instruction
			call vex_addcode (Y_LE)
		}
	|	expr Y_GE expr {
			# Code a greater than instruction
			call vex_addcode (Y_GE)
		}
	|	expr Y_EQ expr {
			# Code a logical equality instruction
			call vex_addcode (Y_EQ)
		}
	|	expr Y_NE expr {
			# Code a logical inequality instruction
			call vex_addcode (Y_NE)
		}
	|	expr Y_AND expr {
			# Code a logical and instruction
			call vex_addcode (Y_AND)
		}
	|	expr Y_OR expr {
			# Code a logical or instruction
			call vex_addcode (Y_OR)
		}
	|	Y_LPAR expr Y_RPAR {
			# Null action
		}
	;

%%

# VEX_COMPILE -- Compile an expression, producing pseudocode
#
# This procedure takes a string containing a fortran expression and produces
# pseudocode that can be evaluated by vex_eval(). The pseudocode is stored in
# structure adressed by the pointer returned as the function value. This 
# structure is freed by calling vex_free(). If the string begins with an @ 
# symbol, the rest of the string is treated as a the name of a file which
# contains the expression. The expression can contain all the fortran 
# operators, including logical and relational operators and supports all the
# fortran intrinsic functions which can take real arguments. It also supports
# conditional expressions of the form: if <expr> then <expr> else <expr>
# Variables must follow the fortran rules, and may be up to 31 characters long.
# All variables and constants are treated as real numbers. A variable may
# contain non-alphanumeric characters if it is preceded by a dollar sign, in
# which case all characters until the next blank are part of the variable name.
#
# B.Simon	21-May-90	Original
# B.Simon	19-Apr-91	Revised to handle multiple types
# B.Simon	31-Mar-94	Better syntax error message
# B.Simon	15-Oct-98	Embed strings in pseudocode

pointer procedure vex_compile (expr)

char	expr[ARB]	# i: Expression to be parsed
#--
include	"vex.com"

int	ic, fd, len
bool	debug
pointer	sp, pcode

data	debug	/ false /

int	open(), stropen(), strlen(), fstati(), yyparse()

int	vex_gettok ()
extern	vex_gettok

begin
	# Open the expression as a file

	for (ic = 1; IS_WHITE(expr[ic]); ic = ic + 1)
	    ;

	if (expr[ic] == '@') {
	    fd = open (expr[ic+1], READ_ONLY, TEXT_FILE)
	    len = fstati (fd, F_FILESIZE) + 1

	} else {
	    len = strlen (expr[ic]) + 1
	    fd = stropen (expr[ic], len, READ_ONLY)
	}

	# Create pseudocode structure

	call malloc (pcode, SZ_VEXSTRUCT, TY_STRUCT)

	call malloc (VEX_CODE(pcode), 2 * len, TY_INT)
	call stk_init (VEX_STACK(pcode))

	# Initialize parsing common block

	call smark (sp)
	call salloc (line, SZ_LINE, TY_CHAR)

	ch = line
	Memc[line] = EOS

	ncode = 0
	maxcode = 2 * len
	code = VEX_CODE(pcode)
	stack = VEX_STACK(pcode)

	# Parse expression to produce reverse polish code

	if (yyparse (fd, debug, vex_gettok) == ERR) {
	    call eprintf ("%s\n%*t^\n")
	    call pargstr (Memc[line])
	    call pargi (ch-line)

	    call error (1, "Syntax error in expression")
	}

	# Clean up and return pseudocode structure

	call stk_clear (VEX_STACK(pcode))

	call close (fd)
	call sfree (sp)
	return (pcode)
end

# VEX_GETTOK -- Get the next token from the input

int procedure vex_gettok (fd, value)

int	fd		# i: File containing expression to be lexed
pointer	value		# o: Address on parse stack to store token
#--
include	"vex.com"

double	constant
int	ic, jc, nc, type, index
int	idftype[4], keytype[3], btype[9]
pointer	sp, errmsg, token

string  fn1tok	FN1STR
string	fn2tok	FN2STR

string	idftok	"indefi indefr indefd indef"
data	idftype	/ Y_INT, Y_REAL, Y_DOUBLE, Y_REAL /

string	keytok	"if then else"
data	keytype	/ Y_IF, Y_THEN, Y_ELSE /

string	btoken  ".or. .and. .eq. .ne. .lt. .gt. .le. .ge. .not."
data	btype   / Y_OR, Y_AND, Y_EQ, Y_NE, Y_LT, Y_GT, Y_LE, Y_GE, Y_NOT /

string	badsymb "Operator not recognized (%s)"

int	getline(), lexnum(), ctod(), stridxs(), word_match()

begin
	# Allocate dynamic memory for strings

	call smark (sp)
	call salloc (errmsg, SZ_LINE, TY_CHAR)
	call malloc (token, MAX_TOKEN, TY_CHAR)

	# Skip over leading white space and comments

	while (Memc[ch] <= BLANK || Memc[ch] == CMTCHAR) {

	    # If all characters have been read from the current line 
	    # or a comment character was found, get the next line

	    if (Memc[ch] == EOS || Memc[ch] == CMTCHAR) {
		ch = line
		if (getline (fd, Memc[line]) == EOF) {
		    Memc[ch] = EOS
		    break
		}
	    } else {
		ch = ch + 1
	    }
	}

	# The token type is determined from the first character in the token

	Memc[token] = EOS

	# End of expression token

	if (Memc[ch] == EOS) {
	    type = Y_DONE

	# Numeric constant is too difficult to parse,
	# Pass the job to lexnum and ctod

	} else if (IS_DIGIT(Memc[ch])) {

	    ic = 1
	    index = lexnum (Memc[ch], ic, nc)
	    if (index != LEX_REAL) {
		type = Y_INT
	    } else if (nc > 8) {
		type = Y_DOUBLE
	    } else {
		jc = stridxs ("dD", Memc[ch])
		if (jc == 0 || jc > nc) {
		    type = Y_REAL
		} else {
		    type = Y_DOUBLE
		}
	    }

	    ic = 1
	    nc = ctod (Memc[ch], ic, constant)
	    nc = min (nc, MAX_TOKEN)

	    call strcpy (Memc[ch], Memc[token], nc)
	    ch = ch + ic - 1

	# Token is alphanumeric. Determine what type of token

	} else if (IS_ALPHA (Memc[ch])) {

	    # Gather characters in token

	    for (ic = 1; ic <= MAX_TOKEN; ic = ic + 1) {
		if (Memc[ch] != '_' && ! IS_ALNUM(Memc[ch]))
		    break

		if (IS_UPPER(Memc[ch]))	
		    Memc[token+ic-1] = TO_LOWER(Memc[ch])
		else
		    Memc[token+ic-1] = Memc[ch]
		ch = ch + 1
	    }
	    Memc[token+ic-1] = EOS

	    # Check to see if token is string "INDEF"

	    index = word_match (Memc[token], idftok)

	    if (index > 0) {
		type = idftype[index]
		call strupr (Memc[token])

	    } else {

		# Check to see if token is function or keyword name
		# If not, add it as a new variable

		index = word_match (Memc[token], fn1tok)
		if (index > 0) {
		    type = Y_FN1

		} else {
		    index = word_match (Memc[token], fn2tok)
		    if (index > 0) {
			type = Y_FN2

		    } else {
			index = word_match (Memc[token], keytok)
			if (index > 0) {
			    type = keytype[index]
			    Memc[token] = EOS
			} else {
			    type = Y_VAR
			}
		    }
		}
	    }

	# Tokens beginning with a dot are numbers or boolean operators

	} else if (Memc[ch] == DOT) {

	    if (IS_DIGIT (Memc[ch+1])) {
		ic = 1
		index = lexnum (Memc[ch], ic, nc)

		if (index != LEX_REAL) {
		    type = Y_INT
		} else if (nc < 9) {
		    type = Y_REAL
		} else {
		    type = Y_DOUBLE
		}

		ic = 1
		nc = ctod (Memc[ch], ic, constant)
		nc = min (nc, MAX_TOKEN)

		call strcpy (Memc[ch], Memc[token], nc)
		ch = ch + ic - 1

	    } else {

		# Gather characters in token

		ch = ch + 1
		Memc[token] = DOT
		for (ic = 2; ic < MAX_TOKEN && Memc[ch] != DOT; ic = ic + 1) {
		    if (Memc[ch] == EOS)
			break
		    if (IS_UPPER(Memc[ch]))	
			Memc[token+ic-1] = TO_LOWER(Memc[ch])
		    else
			Memc[token+ic-1] = Memc[ch]
		    ch = ch + 1
		}

		Memc[token+ic-1] = Memc[ch]
		Memc[token+ic] = EOS
		ch = ch + 1

		index = word_match (Memc[token], btoken)
		if (type > 0) {
		    type = btype[index]
		} else {
		    call sprintf (Memc[errmsg], SZ_LINE, badsymb)
		    call pargstr (Memc[token])
		    call error (1, Memc[errmsg])
		}
	    }

	# Characters preceded by a dollar sign are identifiers

	} else if (Memc[ch] == DOLLAR) {

	    ch = ch + 1
	    for (ic = 1; ic <= MAX_TOKEN && Memc[ch] > BLANK; ic = ic + 1) {
		if (IS_UPPER(Memc[ch]))	
		    Memc[token+ic-1] = TO_LOWER(Memc[ch])
		else
		    Memc[token+ic-1] = Memc[ch]
		ch = ch + 1
	    }
	    Memc[token+ic-1] = EOS

	    type = Y_VAR

	# Anything else is a symbol
	
	} else {
	    switch (Memc[ch]) {
	    case '*':
		if (Memc[ch+1] != '*') {
		    type = Y_MUL
		} else {
		    type = Y_POW
		    ch = ch + 1
		}
	    case '/':
		type = Y_DIV
	    case '+':
		type = Y_ADD
	    case '-':
		type = Y_SUB
	    case '(':
		type = Y_LPAR
	    case ')':
		type = Y_RPAR
	    case ',':
		type = Y_COMMA
	    case '<':
		if (Memc[ch+1] != '=') {
		   type = Y_LT
		} else {
		   type = Y_LE
		   ch = ch + 1
		}
	    case '>':
		if (Memc[ch+1] != '=') {
		   type = Y_GT
		} else {
		   type = Y_GE
		   ch = ch + 1
		}
	    case '|':
		if (Memc[ch+1] != '|') {
		   type = Y_WRONG
		} else {
		   type = Y_OR
		   ch = ch + 1
		}
	    case '&':
		if (Memc[ch+1] != '&') {
		   type = Y_WRONG
		} else {
		   type = Y_AND
		   ch = ch + 1
		}
	    case '=':
		if (Memc[ch+1] != '=') {
		   type = Y_WRONG
		} else {
		   type = Y_EQ
		   ch = ch + 1
		}
	    case '!':
		if (Memc[ch+1] != '=') {
		   type = Y_NOT
		} else {
		   type = Y_NE
		   ch = ch + 1
		}
	    default:
		Memc[ch+1] = EOS
		call sprintf (Memc[errmsg], SZ_LINE, badsymb)
		    call pargstr (Memc[ch])
		call error (1, Memc[errmsg])
	    }

	    ch = ch + 1
	}

	# 
	if (Memc[token] == EOS) {
	    call mfree (token, TY_CHAR)
	    token = NULL
	}

	Memi[value] = token
	return (type)
end

# VEX_ADDCODE -- Add an instruction to the code array

procedure vex_addcode (type)

int	type		# i: Instruction type
#--
include	"vex.com"

begin

	if (ncode == maxcode)
	    call error (1, "Expression too complex")
	else {
	    Memi[code] = type
	    code = code + 1
	    ncode = ncode + 1
	}

end

# VEX_ADDSTR -- Embed a string constant in the pseudo-code

procedure vex_addstr (token)

pointer	token		# u: Pointer to token string
#--
include "vex.com"

int	ic

begin
	if (token == NULL)
	    call error (1, "Expression token missing")

	if (Memc[token] == EOS)
	    call error (1, "Expression token blank")

	ic = 0
	repeat {
	    ic = ic + 1

	    if (ncode == maxcode)
		call error (1, "Expression too complex")
	    else {
		Memi[code] = Memc[token+ic-1]
		code = code + 1
		ncode = ncode + 1
	    }

	} until (Memc[token+ic-1] == EOS)

	call mfree (token, TY_CHAR)
end

# VEX_GETSTR -- Retrieve a token string from the pseudocode array

procedure vex_getstr (op, token, maxch)

pointer	op		# u: Location of token string in pseudocode
char	token[ARB]	# o: Token string
int	maxch		# i: Maximum length of token
#--
int	ic

begin
	# The token begins one position after op and is 
	# termminated by an EOS

	ic = 0
	repeat {
	    ic = ic + 1
	    op = op + 1
	    if (ic <= maxch)
		token[ic] = Memi[op]

	} until (Memi[op] == EOS)

end