include	<ctype.h>

define	YYMAXDEPTH	32
define	YYOPLEN		1
define	yyparse		unit_parse

define	SZ_SHORTSTR	31

define	Y_WRONG		257
define	Y_DONE		258
define	Y_LPAR		259
define	Y_RPAR		260
define	Y_CU		261
define	Y_SQ		262
define	Y_ID		263
define	Y_NUM		264
define	Y_DIV		265
define	Y_MUL		266
define	Y_POW		267
define	yyclearin	yychar = -1
define	yyerrok		yyerrflag = 0
define	YYMOVE		call amovi (Memi[$1], Memi[$2], YYOPLEN)
define	YYERRCODE	256

# line 159 "parseunits.y"


# PARSE_UNITS -- Parse a units string into the internal format

pointer procedure parse_units (ab, units)

pointer	ab		# i: abbreviation hash table
char	units[ARB]	# i: expression to be parsed
#--
include "parseunits.com"

int	len, fd
pointer	sp

string	syntax	"Syntax error in units"

int	strlen(), stropen(), yyparse()
extern	get_token

begin
	len = strlen (units) + 1
	fd = stropen (units, len, READ_ONLY)

	call smark (sp)
	call salloc (tokbuf, SZ_FNAME, TY_CHAR)

	debug = NO
	nxttok = 0
	abrev = ab
	tun = NULL	

	if (yyparse (fd, debug, get_token) == ERR)
	    call tuniterr (syntax, units)

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

# GET_TOKEN -- Retrieve next token from units string

int procedure get_token (fd, value)

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

char	ch
int	type, index, powers[4]
pointer	sp, typename, token

string	pownames  "sq,square,cu,cubic"
data	powers    / Y_SQ, Y_SQ, Y_CU, Y_CU /

bool	streq()
int	getc(), word_match()

begin
	call smark (sp)
	call salloc (typename, SZ_FNAME, TY_CHAR)

	token = tokbuf + nxttok
	Memi[value] = token

	repeat {
	    ch = getc (fd, ch)
	} until (ch != ' ' && ch != '\t')

	if (ch == EOF) {
	    type = Y_DONE
	    call strcpy ("END", Memc[typename], SZ_FNAME)

	} else if (IS_ALPHA (ch)) {
	    type = Y_ID
	    call strcpy ("IDENT", Memc[typename], SZ_FNAME)

	    while (IS_ALPHA (ch)) {
		Memc[tokbuf+nxttok] = ch
		nxttok = nxttok + 1
		ch = getc (fd, ch)
	    }
	    call ungetc (fd, ch)

	    Memc[tokbuf+nxttok] = EOS
	    index = word_match (Memc[token], pownames)

	    if (index > 0) {
		type = powers[index]
		call strcpy ("POWER", Memc[typename], SZ_FNAME)

	    } else if (streq (Memc[token], "per")) {
		type = Y_DIV
		call strcpy ("DIV", Memc[typename], SZ_FNAME)
	    }

	} else if (ch == '-' || IS_DIGIT (ch)) {
	    type = Y_NUM
	    call strcpy ("NUMBER", Memc[typename], SZ_FNAME)

	    Memc[tokbuf+nxttok] = ch
	    nxttok = nxttok + 1
	    ch = getc (fd, ch)

	    while (IS_DIGIT (ch)) {
		Memc[tokbuf+nxttok] = ch
		nxttok = nxttok + 1
		ch = getc (fd, ch)
	    }
	    call ungetc (fd, ch)

	} else {
	    Memc[tokbuf+nxttok] = ch
	    nxttok = nxttok + 1

	    switch (ch) {
	    case '*':
		ch = getc (fd, ch)
		if (ch == '*') {
		    type = Y_POW
		    call strcpy ("EXPON", Memc[typename], SZ_FNAME)

		    Memc[tokbuf+nxttok] = ch
		    nxttok = nxttok + 1
		} else {
		    type = Y_MUL
		    call strcpy ("MUL", Memc[typename], SZ_FNAME)

		    call ungetc (fd, ch)
		}

	    case '/':
		type = Y_DIV
		call strcpy ("DIV", Memc[typename], SZ_FNAME)

	    case '^':
		type = Y_POW
		call strcpy ("EXPON", Memc[typename], SZ_FNAME)

	    default:
		type = Y_WRONG
		call strcpy ("ERROR", Memc[typename], SZ_FNAME)
	    }
	}

	Memc[tokbuf+nxttok] = EOS
	nxttok = nxttok + 1

	if (debug == YES) {
	    call eprintf ("Token is %s [%s]\n")
	    if (Memc[token] == EOS)  {
		call pargstr ("EOS")
	    } else {
		call pargstr (Memc[token])
	    }
	    call pargstr (Memc[typename])
	}

	call sfree (sp)
	return (type)
end
define	YYNPROD		15
define	YYLAST		43
# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.

# Parser for yacc output, translated to the IRAF SPP language.  The contents
# of this file form the bulk of the source of the parser produced by Yacc.
# Yacc recognizes several macros in the yaccpar input source and replaces
# them as follows:
#	A	user suppled "global" definitions and declarations
# 	B	parser tables
# 	C	user supplied actions (reductions)
# The remainder of the yaccpar code is not changed.

define	yystack_	10		# statement labels for gotos
define	yynewstate_	20
define	yydefault_	30
define	yyerrlab_	40
define	yyabort_	50

define	YYFLAG		(-1000)		# defs used in user actions
define	YYERROR		goto yyerrlab_
define	YYACCEPT	return (OK)
define	YYABORT		return (ERR)


# YYPARSE -- Parse the input stream, returning OK if the source is
# syntactically acceptable (i.e., if compilation is successful),
# otherwise ERR.  The parameters YYMAXDEPTH and YYOPLEN must be
# supplied by the caller in the %{ ... %} section of the Yacc source.
# The token value stack is a dynamically allocated array of operand
# structures, with the length and makeup of the operand structure being
# application dependent.

int procedure yyparse (fd, yydebug, yylex)

int	fd			# stream to be parsed
bool	yydebug			# print debugging information?
int	yylex()			# user-supplied lexical input function
extern	yylex()

short	yys[YYMAXDEPTH]		# parser stack -- stacks tokens
pointer	yyv			# pointer to token value stack
pointer	yyval			# value returned by action
pointer	yylval			# value of token
int	yyps			# token stack pointer
pointer	yypv			# value stack pointer
int	yychar			# current input token number
int	yyerrflag		# error recovery flag
int	yynerrs			# number of errors

short	yyj, yym		# internal variables
pointer	yysp, yypvt
short	yystate, yyn
int	yyxi, i
errchk	salloc, yylex


include	"parseunits.com"

char		units[SZ_FNAME]

int		num_unstr()
pointer		mul_unstr(), div_unstr(), pow_unstr(), set_unstr()

short	yyexca[6]
data	(yyexca(i),i=  1,  6)	/  -1,   1,   0,  -1,  -2,   0/
short	yyact[43]
data	(yyact(i),i=  1,  8)	/  23,  10,  11,  13,  13,  12,  11,  13/
data	(yyact(i),i=  9, 16)	/  12,  11,  13,  17,   3,  24,  16,   4/
data	(yyact(i),i= 17, 24)	/  22,   8,   9,   7,   4,  19,   8,   9/
data	(yyact(i),i= 25, 32)	/   7,   8,   9,   7,  18,   2,   6,   5/
data	(yyact(i),i= 33, 40)	/   1,   0,  14,   0,  15,   0,   0,   0/
data	(yyact(i),i= 41, 43)	/   0,  20,  21/
short	yypact[25]
data	(yypact(i),i=  1,  8)	/-244,-1000,-257,-1000,-239,-236,-1000,-253/
data	(yypact(i),i=  9, 16)	/-235,-242,-1000,-239,-239,-248,-260,-1000/
data	(yypact(i),i= 17, 24)	/-251,-1000,-1000,-1000,-263,-264,-1000,-1000/
data	(yypact(i),i= 25, 25)	/-1000/
short	yypgo[5]
data	(yypgo(i),i=  1,  5)	/   0,  32,  29,  31,  30/
short	yyr1[15]
data	(yyr1(i),i=  1,  8)	/   0,   1,   1,   2,   2,   2,   2,   2/
data	(yyr1(i),i=  9, 15)	/   3,   3,   4,   4,   4,   4,   4/
short	yyr2[15]
data	(yyr2(i),i=  1,  8)	/   0,   2,   1,   3,   3,   3,   3,   1/
data	(yyr2(i),i=  9, 15)	/   2,   1,   3,   2,   2,   2,   1/
short	yychk[25]
data	(yychk(i),i=  1,  8)	/-1000,  -1,  -2, 256, 259,  -3,  -4, 263/
data	(yychk(i),i=  9, 16)	/ 261, 262, 258, 266, 265, 267,  -2,  -4/
data	(yychk(i),i= 17, 24)	/ 267, 264, 263, 263,  -2,  -2, 264, 260/
data	(yychk(i),i= 25, 25)	/ 264/
short	yydef[25]
data	(yydef(i),i=  1,  8)	/   0,  -2,   0,   2,   0,   7,   9,  14/
data	(yydef(i),i=  9, 16)	/   0,   0,   1,   0,   0,   0,   0,   8/
data	(yydef(i),i= 17, 24)	/   0,  11,  12,  13,   4,   5,   6,   3/
data	(yydef(i),i= 25, 25)	/  10/

begin
	call smark (yysp)
	call salloc (yyv, (YYMAXDEPTH+2) * YYOPLEN, TY_STRUCT)

	# Initialization.  The first element of the dynamically allocated
	# token value stack (yyv) is used for yyval, the second for yylval,
	# and the actual stack starts with the third element.

	yystate = 0
	yychar = -1
	yynerrs = 0
	yyerrflag = 0
	yyps = 0
	yyval = yyv
	yylval = yyv + YYOPLEN
	yypv = yylval

yystack_
	# SHIFT -- Put a state and value onto the stack.  The token and
	# value stacks are logically the same stack, implemented as two
	# separate arrays.

	if (yydebug) {
	    call printf ("state %d, char 0%o\n")
		call pargs (yystate)
		call pargi (yychar)
	}
	yyps = yyps + 1
	yypv = yypv + YYOPLEN
	if (yyps > YYMAXDEPTH) {
	    call sfree (yysp)
	    call eprintf ("yacc stack overflow\n")
	    return (ERR)
	}
	yys[yyps] = yystate
	YYMOVE (yyval, yypv)

yynewstate_
	# Process the new state.
	yyn = yypact[yystate+1]

	if (yyn <= YYFLAG)
	    goto yydefault_			# simple state

	# The variable "yychar" is the lookahead token.
	if (yychar < 0) {
	    yychar = yylex (fd, yylval)
	    if (yychar < 0)
		yychar = 0
	}
	yyn = yyn + yychar
	if (yyn < 0 || yyn >= YYLAST)
	    goto yydefault_

	yyn = yyact[yyn+1]
	if (yychk[yyn+1] == yychar) {		# valid shift
	    yychar = -1
	    YYMOVE (yylval, yyval)
	    yystate = yyn
	    if (yyerrflag > 0)
		yyerrflag = yyerrflag - 1
	    goto yystack_
	}

yydefault_
	# Default state action.

	yyn = yydef[yystate+1]
	if (yyn == -2) {
	    if (yychar < 0) {
		yychar = yylex (fd, yylval)
		if (yychar < 0)
		    yychar = 0
	    }

	    # Look through exception table.
	    yyxi = 1
	    while ((yyexca[yyxi] != (-1)) || (yyexca[yyxi+1] != yystate))
		yyxi = yyxi + 2
	    for (yyxi=yyxi+2;  yyexca[yyxi] >= 0;  yyxi=yyxi+2) {
		if (yyexca[yyxi] == yychar)
		    break
	    }

	    yyn = yyexca[yyxi+1]
	    if (yyn < 0) {
		call sfree (yysp)
		return (OK)			# ACCEPT -- all done
	    }
	}


	# SYNTAX ERROR -- resume parsing if possible.

	if (yyn == 0) {
	    switch (yyerrflag) {
	    case 0, 1, 2:
		if (yyerrflag == 0) {		# brand new error
		    call eprintf ("syntax error\n")
yyerrlab_
		    yynerrs = yynerrs + 1
		    # fall through...
		}

	    # case 1:
	    # case 2: incompletely recovered error ... try again
		yyerrflag = 3

		# Find a state where "error" is a legal shift action.
		while (yyps >= 1) {
		    yyn = yypact[yys[yyps]+1] + YYERRCODE
		    if ((yyn >= 0) && (yyn < YYLAST) &&
			(yychk[yyact[yyn+1]+1] == YYERRCODE)) {
			    # Simulate a shift of "error".
			    yystate = yyact[yyn+1]
			    goto yystack_
		    }
		    yyn = yypact[yys[yyps]+1]

		    # The current yyps has no shift on "error", pop stack.
		    if (yydebug) {
			call printf ("error recovery pops state %d, ")
			    call pargs (yys[yyps])
			call printf ("uncovers %d\n")
			    call pargs (yys[yyps-1])
		    }
		    yyps = yyps - 1
		    yypv = yypv - YYOPLEN
		}

		# ABORT -- There is no state on the stack with an error shift.
yyabort_
		call sfree (yysp)
		return (ERR)


	    case 3: # No shift yet; clobber input char.

		if (yydebug) {
		    call printf ("error recovery discards char %d\n")
			call pargi (yychar)
		}

		if (yychar == 0)
		    goto yyabort_		# don't discard EOF, quit
		yychar = -1
		goto yynewstate_		# try again in the same state
	    }
	}


	# REDUCE -- Reduction by production yyn.

	if (yydebug) {
	    call printf ("reduce %d\n")
		call pargs (yyn)
	}
	yyps  = yyps - yyr2[yyn+1]
	yypvt = yypv
	yypv  = yypv - yyr2[yyn+1] * YYOPLEN
	YYMOVE (yypv + YYOPLEN, yyval)
	yym   = yyn

	# Consult goto table to find next state.
	yyn = yyr1[yyn+1]
	yyj = yypgo[yyn+1] + yys[yyps] + 1
	if (yyj >= YYLAST)
	    yystate = yyact[yypgo[yyn+1]+1]
	else {
	    yystate = yyact[yyj+1]
	    if (yychk[yystate+1] != -yyn)
		yystate = yyact[yypgo[yyn+1]+1]
	}

	# Perform action associated with the grammar rule, if any.
	switch (yym) {
	    
case 1:
# line 28 "parseunits.y"
{
		    # Normal exit. Return pointer to units structure
		    if (debug == YES)
			call eprintf ("\n")

		    tun = Memi[yypvt-YYOPLEN]
		    return (OK)
		}
case 2:
# line 36 "parseunits.y"
{
		    # Syntax error
		    if (debug == YES)
			call eprintf ("\n")

		    return (ERR)
		}
case 3:
# line 45 "parseunits.y"
{
		    # Parenthesized expression
		    Memi[yyval] = Memi[yypvt-2*YYOPLEN]
		}
case 4:
# line 49 "parseunits.y"
{
		    # Multiply two units expressions
		    Memi[yyval] = mul_unstr (Memi[yypvt-2*YYOPLEN], Memi[yypvt])
		    call free_unstr (Memi[yypvt-2*YYOPLEN])
		    call free_unstr (Memi[yypvt])

		    if (debug == YES) {
			call str_unstr (Memi[yyval], units, SZ_FNAME)
			call eprintf ("Units are %s\n")
			call pargstr (units)
		    }
		}
case 5:
# line 61 "parseunits.y"
{
		    # Divide two units expressions
		    Memi[yyval] = div_unstr (Memi[yypvt-2*YYOPLEN], Memi[yypvt])
		    call free_unstr (Memi[yypvt-2*YYOPLEN])
		    call free_unstr (Memi[yypvt])

		    if (debug == YES) {
			call str_unstr (Memi[yyval], units, SZ_FNAME)
			call eprintf ("Units are %s\n")
			call pargstr (units)
		    }
		}
case 6:
# line 73 "parseunits.y"
{
		    # Raise expression to a power
		    Memi[yyval] = pow_unstr (Memi[yypvt-2*YYOPLEN], num_unstr (Memc[Memi[yypvt]]))
		    call free_unstr (Memi[yypvt-2*YYOPLEN])

		    if (debug == YES) {
			call str_unstr (Memi[yyval], units, SZ_FNAME)
			call eprintf ("Units are %s\n")
			call pargstr (units)
		    }
		}
case 7:
# line 84 "parseunits.y"
{
		    # List of terms
		    Memi[yyval] = Memi[yypvt]
		}
case 8:
# line 89 "parseunits.y"
{
		    # Implicit multiplication
		    Memi[yyval] = mul_unstr (Memi[yypvt-YYOPLEN], Memi[yypvt])
		    call free_unstr (Memi[yypvt-YYOPLEN])
		    call free_unstr (Memi[yypvt])

		    if (debug == YES) {
			call str_unstr (Memi[yyval], units, SZ_FNAME)
			call eprintf ("Units are %s\n")
			call pargstr (units)
		    }
		}
case 9:
# line 101 "parseunits.y"
{
		    # Simple term
		    Memi[yyval] = Memi[yypvt]
		}
case 10:
# line 106 "parseunits.y"
{
		    # Raise units to a power
		    Memi[yyval] = set_unstr (abrev, Memc[Memi[yypvt-2*YYOPLEN]], 
				    	num_unstr (Memc[Memi[yypvt]]))

		    if (debug == YES) {
			call str_unstr (Memi[yyval], units, SZ_FNAME)
			call eprintf ("Units are %s\n")
			call pargstr (units)
		    }
		}
case 11:
# line 117 "parseunits.y"
{
		    # Implicitly raise to a power
		    Memi[yyval] = set_unstr (abrev, Memc[Memi[yypvt-YYOPLEN]], 
				    num_unstr (Memc[Memi[yypvt]]))

		    if (debug == YES) {
			call str_unstr (Memi[yyval], units, SZ_FNAME)
			call eprintf ("Units are %s\n")
			call pargstr (units)
		    }
		}
case 12:
# line 128 "parseunits.y"
{
		    # Cubic prefix
		    Memi[yyval] = set_unstr (abrev, Memc[Memi[yypvt]], 3)

		    if (debug == YES) {
			call str_unstr (Memi[yyval], units, SZ_FNAME)
			call eprintf ("Units are %s\n")
			call pargstr (units)
		    }
		}
case 13:
# line 138 "parseunits.y"
{
		    # Square prefix
		    Memi[yyval] = set_unstr (abrev, Memc[Memi[yypvt]], 2)

		    if (debug == YES) {
			call str_unstr (Memi[yyval], units, SZ_FNAME)
			call eprintf ("Units are %s\n")
			call pargstr (units)
		    }
		}
case 14:
# line 148 "parseunits.y"
{
		    # Simple name
		    Memi[yyval] = set_unstr (abrev, Memc[Memi[yypvt]], 1)

		    if (debug == YES) {
			call str_unstr (Memi[yyval], units, SZ_FNAME)
			call eprintf ("Units are %s\n")
			call pargstr (units)
		    }
		}	}

	goto yystack_				# stack new state and value
end