path: root/libraries/embryo/src/bin/embryo_cc_sc3.c

/*  Small compiler - Recursive descend expresion parser
 *
 *  Copyright (c) ITB CompuPhase, 1997-2003
 *
 *  This software is provided "as-is", without any express or implied warranty.
 *  In no event will the authors be held liable for any damages arising from
 *  the use of this software.
 *
 *  Permission is granted to anyone to use this software for any purpose,
 *  including commercial applications, and to alter it and redistribute it
 *  freely, subject to the following restrictions:
 *
 *  1.  The origin of this software must not be misrepresented; you must not
 *      claim that you wrote the original software. If you use this software in
 *      a product, an acknowledgment in the product documentation would be
 *      appreciated but is not required.
 *  2.  Altered source versions must be plainly marked as such, and must not be
 *      misrepresented as being the original software.
 *  3.  This notice may not be removed or altered from any source distribution.
 *
 *  Version: $Id: embryo_cc_sc3.c 52451 2010-09-19 03:00:12Z raster $
 */


#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <assert.h>
#include <stdio.h>
#include <limits.h>		/* for PATH_MAX */
#include <string.h>

#include "embryo_cc_sc.h"

static int          skim(int *opstr, void (*testfunc) (int), int dropval,
			 int endval, int (*hier) (value *), value * lval);
static void         dropout(int lvalue, void (*testfunc) (int val), int exit1,
			    value * lval);
static int          plnge(int *opstr, int opoff, int (*hier) (value * lval),
			  value * lval, char *forcetag, int chkbitwise);
static int          plnge1(int (*hier) (value * lval), value * lval);
static void         plnge2(void (*oper) (void),
			   int (*hier) (value * lval),
			   value * lval1, value * lval2);
static cell         calc(cell left, void (*oper) (), cell right,
			 char *boolresult);
static int          hier13(value * lval);
static int          hier12(value * lval);
static int          hier11(value * lval);
static int          hier10(value * lval);
static int          hier9(value * lval);
static int          hier8(value * lval);
static int          hier7(value * lval);
static int          hier6(value * lval);
static int          hier5(value * lval);
static int          hier4(value * lval);
static int          hier3(value * lval);
static int          hier2(value * lval);
static int          hier1(value * lval1);
static int          primary(value * lval);
static void         clear_value(value * lval);
static void         callfunction(symbol * sym);
static int          dbltest(void (*oper) (), value * lval1, value * lval2);
static int          commutative(void (*oper) ());
static int          constant(value * lval);

static char         lastsymbol[sNAMEMAX + 1];	/* name of last function/variable */
static int          bitwise_opercount;	/* count of bitwise operators in an expression */

/* Function addresses of binary operators for signed operations */
static void         (*op1[17]) (void) =
{
   os_mult, os_div, os_mod,	/* hier3, index 0 */
      ob_add, ob_sub,		/* hier4, index 3 */
      ob_sal, os_sar, ou_sar,	/* hier5, index 5 */
      ob_and,			/* hier6, index 8 */
      ob_xor,			/* hier7, index 9 */
      ob_or,			/* hier8, index 10 */
      os_le, os_ge, os_lt, os_gt,	/* hier9, index 11 */
      ob_eq, ob_ne,		/* hier10, index 15 */
};
/* These two functions are defined because the functions inc() and dec() in
 * SC4.C have a different prototype than the other code generation functions.
 * The arrays for user-defined functions use the function pointers for
 * identifying what kind of operation is requested; these functions must all
 * have the same prototype. As inc() and dec() are special cases already, it
 * is simplest to add two "do-nothing" functions.
 */
static void
user_inc(void)
{
}
static void
user_dec(void)
{
}

/*
 *  Searches for a binary operator a list of operators. The list is stored in
 *  the array "list". The last entry in the list should be set to 0.
 *
 *  The index of an operator in "list" (if found) is returned in "opidx". If
 *  no operator is found, nextop() returns 0.
 */
static int
nextop(int *opidx, int *list)
{
   *opidx = 0;
   while (*list)
     {
	if (matchtoken(*list))
	  {
	     return TRUE;	/* found! */
	  }
	else
	  {
	     list += 1;
	     *opidx += 1;
	  }			/* if */
     }				/* while */
   return FALSE;		/* entire list scanned, nothing found */
}

int
check_userop(void   (*oper) (void), int tag1, int tag2, int numparam,
	     value * lval, int *resulttag)
{
   static char        *binoperstr[] = { "*", "/", "%", "+", "-", "", "", "",
      "", "", "", "<=", ">=", "<", ">", "==", "!="
   };
   static int          binoper_savepri[] =
      { FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
      FALSE, FALSE, FALSE, FALSE, FALSE,
      TRUE, TRUE, TRUE, TRUE, FALSE, FALSE
   };
   static char        *unoperstr[] = { "!", "-", "++", "--" };
   static void         (*unopers[]) (void) =
   {
   lneg, neg, user_inc, user_dec};
   char                opername[4] = "", symbolname[sNAMEMAX + 1];
   int                 i, swapparams, savepri, savealt;
   int                 paramspassed;
   symbol             *sym;

   /* since user-defined operators on untagged operands are forbidden, we have
    * a quick exit.
    */
   assert(numparam == 1 || numparam == 2);
   if (tag1 == 0 && (numparam == 1 || tag2 == 0))
      return FALSE;

   savepri = savealt = FALSE;
   /* find the name with the operator */
   if (numparam == 2)
     {
	if (!oper)
	  {
	     /* assignment operator: a special case */
	     strcpy(opername, "=");
	     if (lval
		 && (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR))
		savealt = TRUE;
	  }
	else
	  {
	     assert((sizeof binoperstr / sizeof binoperstr[0]) ==
		    (sizeof op1 / sizeof op1[0]));
	     for (i = 0; i < (int)(sizeof op1 / sizeof op1[0]); i++)
	       {
		  if (oper == op1[i])
		    {
		       strcpy(opername, binoperstr[i]);
		       savepri = binoper_savepri[i];
		       break;
		    }		/* if */
	       }		/* for */
	  }			/* if */
     }
   else
     {
	assert(oper != NULL);
	assert(numparam == 1);
	/* try a select group of unary operators */
	assert((sizeof unoperstr / sizeof unoperstr[0]) ==
	       (sizeof unopers / sizeof unopers[0]));
	if (opername[0] == '\0')
	  {
	     for (i = 0; i < (int)(sizeof unopers / sizeof unopers[0]); i++)
	       {
		  if (oper == unopers[i])
		    {
		       strcpy(opername, unoperstr[i]);
		       break;
		    }		/* if */
	       }		/* for */
	  }			/* if */
     }				/* if */
   /* if not found, quit */
   if (opername[0] == '\0')
      return FALSE;

   /* create a symbol name from the tags and the operator name */
   assert(numparam == 1 || numparam == 2);
   operator_symname(symbolname, opername, tag1, tag2, numparam, tag2);
   swapparams = FALSE;
   sym = findglb(symbolname);
   if (!sym /*|| (sym->usage & uDEFINE)==0 */ )
     {				/* ??? should not check uDEFINE; first pass clears these bits */
	/* check for commutative operators */
	if (tag1 == tag2 || !oper || !commutative(oper))
	   return FALSE;	/* not commutative, cannot swap operands */
	/* if arrived here, the operator is commutative and the tags are different,
	 * swap tags and try again
	 */
	assert(numparam == 2);	/* commutative operator must be a binary operator */
	operator_symname(symbolname, opername, tag2, tag1, numparam, tag1);
	swapparams = TRUE;
	sym = findglb(symbolname);
	if (!sym /*|| (sym->usage & uDEFINE)==0 */ )
	   return FALSE;
     }				/* if */

   /* check existence and the proper declaration of this function */
   if ((sym->usage & uMISSING) != 0 || (sym->usage & uPROTOTYPED) == 0)
     {
	char                symname[2 * sNAMEMAX + 16];	/* allow space for user defined operators */

	funcdisplayname(symname, sym->name);
	if ((sym->usage & uMISSING) != 0)
	   error(4, symname);	/* function not defined */
	if ((sym->usage & uPROTOTYPED) == 0)
	   error(71, symname);	/* operator must be declared before use */
     }				/* if */

   /* we don't want to use the redefined operator in the function that
    * redefines the operator itself, otherwise the snippet below gives
    * an unexpected recursion:
    *    fixed:operator+(fixed:a, fixed:b)
    *        return a + b
    */
   if (sym == curfunc)
      return FALSE;

   /* for increment and decrement operators, the symbol must first be loaded
    * (and stored back afterwards)
    */
   if (oper == user_inc || oper == user_dec)
     {
	assert(!savepri);
	assert(lval != NULL);
	if (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR)
	   push1();		/* save current address in PRI */
	rvalue(lval);		/* get the symbol's value in PRI */
     }				/* if */

   assert(!savepri || !savealt);	/* either one MAY be set, but not both */
   if (savepri)
     {
	/* the chained comparison operators require that the ALT register is
	 * unmodified, so we save it here; actually, we save PRI because the normal
	 * instruction sequence (without user operator) swaps PRI and ALT
	 */
	push1();		/* right-hand operand is in PRI */
     }
   else if (savealt)
     {
	/* for the assignment operator, ALT may contain an address at which the
	 * result must be stored; this address must be preserved across the
	 * call
	 */
	assert(lval != NULL);	/* this was checked earlier */
	assert(lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR);	/* checked earlier */
	push2();
     }				/* if */

   /* push parameters, call the function */
   paramspassed = (!oper) ? 1 : numparam;
   switch (paramspassed)
     {
     case 1:
	push1();
	break;
     case 2:
	/* note that 1) a function expects that the parameters are pushed
	 * in reversed order, and 2) the left operand is in the secondary register
	 * and the right operand is in the primary register */
	if (swapparams)
	  {
	     push2();
	     push1();
	  }
	else
	  {
	     push1();
	     push2();
	  }			/* if */
	break;
     default:
	assert(0);
     }				/* switch */
   endexpr(FALSE);		/* mark the end of a sub-expression */
   pushval((cell) paramspassed * sizeof(cell));
   assert(sym->ident == iFUNCTN);
   ffcall(sym, paramspassed);
   if (sc_status != statSKIP)
      markusage(sym, uREAD);	/* do not mark as "used" when this call itself is skipped */
   if (sym->x.lib)
      sym->x.lib->value += 1;	/* increment "usage count" of the library */
   sideeffect = TRUE;		/* assume functions carry out a side-effect */
   assert(resulttag != NULL);
   *resulttag = sym->tag;	/* save tag of the called function */

   if (savepri || savealt)
      pop2();			/* restore the saved PRI/ALT that into ALT */
   if (oper == user_inc || oper == user_dec)
     {
	assert(lval != NULL);
	if (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR)
	   pop2();		/* restore address (in ALT) */
	store(lval);		/* store PRI in the symbol */
	moveto1();		/* make sure PRI is restored on exit */
     }				/* if */
   return TRUE;
}

int
matchtag(int formaltag, int actualtag, int allowcoerce)
{
   if (formaltag != actualtag)
     {
	/* if the formal tag is zero and the actual tag is not "fixed", the actual
	 * tag is "coerced" to zero
	 */
	if (!allowcoerce || formaltag != 0 || (actualtag & FIXEDTAG) != 0)
	   return FALSE;
     }				/* if */
   return TRUE;
}

/*
 *  The AMX pseudo-processor has no direct support for logical (boolean)
 *  operations. These have to be done via comparing and jumping. Since we are
 *  already jumping through the code, we might as well implement an "early
 *  drop-out" evaluation (also called "short-circuit"). This conforms to
 *  standard C:
 *
 *  expr1 || expr2           expr2 will only be evaluated if expr1 is false.
 *  expr1 && expr2           expr2 will only be evaluated if expr1 is true.
 *
 *  expr1 || expr2 && expr3  expr2 will only be evaluated if expr1 is false
 *                           and expr3 will only be evaluated if expr1 is
 *                           false and expr2 is true.
 *
 *  Code generation for the last example proceeds thus:
 *
 *      evaluate expr1
 *      operator || found
 *      jump to "l1" if result of expr1 not equal to 0
 *      evaluate expr2
 *      ->  operator && found; skip to higher level in hierarchy diagram
 *          jump to "l2" if result of expr2 equal to 0
 *          evaluate expr3
 *          jump to "l2" if result of expr3 equal to 0
 *          set expression result to 1 (true)
 *          jump to "l3"
 *      l2: set expression result to 0 (false)
 *      l3:
 *      <-  drop back to previous hierarchy level
 *      jump to "l1" if result of expr2 && expr3 not equal to 0
 *      set expression result to 0 (false)
 *      jump to "l4"
 *  l1: set expression result to 1 (true)
 *  l4:
 *
 */

/*  Skim over terms adjoining || and && operators
 *  dropval   The value of the expression after "dropping out". An "or" drops
 *            out when the left hand is TRUE, so dropval must be 1 on "or"
 *            expressions.
 *  endval    The value of the expression when no expression drops out. In an
 *            "or" expression, this happens when both the left hand and the
 *            right hand are FALSE, so endval must be 0 for "or" expressions.
 */
static int
skim(int *opstr, void (*testfunc) (int), int dropval, int endval,
     int (*hier) (value *), value * lval)
{
   int                 lvalue, hits, droplab, endlab, opidx;
   int                 allconst;
   cell                constval;
   int                 index;
   cell                cidx;

   stgget(&index, &cidx);	/* mark position in code generator */
   hits = FALSE;		/* no logical operators "hit" yet */
   allconst = TRUE;		/* assume all values "const" */
   constval = 0;
   droplab = 0;			/* to avoid a compiler warning */
   for (;;)
     {
	lvalue = plnge1(hier, lval);	/* evaluate left expression */

	allconst = allconst && (lval->ident == iCONSTEXPR);
	if (allconst)
	  {
	     if (hits)
	       {
		  /* one operator was already found */
		  if (testfunc == jmp_ne0)
		     lval->constval = lval->constval || constval;
		  else
		     lval->constval = lval->constval && constval;
	       }		/* if */
	     constval = lval->constval;	/* save result accumulated so far */
	  }			/* if */

	if (nextop(&opidx, opstr))
	  {
	     if (!hits)
	       {
		  /* this is the first operator in the list */
		  hits = TRUE;
		  droplab = getlabel();
	       }		/* if */
	     dropout(lvalue, testfunc, droplab, lval);
	  }
	else if (hits)
	  {			/* no (more) identical operators */
	     dropout(lvalue, testfunc, droplab, lval);	/* found at least one operator! */
	     const1(endval);
	     jumplabel(endlab = getlabel());
	     setlabel(droplab);
	     const1(dropval);
	     setlabel(endlab);
	     lval->sym = NULL;
	     lval->tag = 0;
	     if (allconst)
	       {
		  lval->ident = iCONSTEXPR;
		  lval->constval = constval;
		  stgdel(index, cidx);	/* scratch generated code and calculate */
	       }
	     else
	       {
		  lval->ident = iEXPRESSION;
		  lval->constval = 0;
	       }		/* if */
	     return FALSE;
	  }
	else
	  {
	     return lvalue;	/* none of the operators in "opstr" were found */
	  }			/* if */

     }				/* while */
}

/*
 *  Reads into the primary register the variable pointed to by lval if
 *  plunging through the hierarchy levels detected an lvalue. Otherwise
 *  if a constant was detected, it is loaded. If there is no constant and
 *  no lvalue, the primary register must already contain the expression
 *  result.
 *
 *  After that, the compare routines "jmp_ne0" or "jmp_eq0" are called, which
 *  compare the primary register against 0, and jump to the "early drop-out"
 *  label "exit1" if the condition is true.
 */
static void
dropout(int lvalue, void (*testfunc) (int val), int exit1, value * lval)
{
   if (lvalue)
      rvalue(lval);
   else if (lval->ident == iCONSTEXPR)
      const1(lval->constval);
   (*testfunc) (exit1);
}

static void
checkfunction(value * lval)
{
   symbol             *sym = lval->sym;

   if (!sym || (sym->ident != iFUNCTN && sym->ident != iREFFUNC))
      return;			/* no known symbol, or not a function result */

   if ((sym->usage & uDEFINE) != 0)
     {
	/* function is defined, can now check the return value (but make an
	 * exception for directly recursive functions)
	 */
	if (sym != curfunc && (sym->usage & uRETVALUE) == 0)
	  {
	     char                symname[2 * sNAMEMAX + 16];	/* allow space for user defined operators */

	     funcdisplayname(symname, sym->name);
	     error(209, symname);	/* function should return a value */
	  }			/* if */
     }
   else
     {
	/* function not yet defined, set */
	sym->usage |= uRETVALUE;	/* make sure that a future implementation of
					 * the function uses "return <value>" */
     }				/* if */
}

/*
 *  Plunge to a lower level
 */
static int
plnge(int *opstr, int opoff, int (*hier) (value * lval), value * lval,
      char *forcetag, int chkbitwise)
{
   int                 lvalue, opidx;
   int                 count;
   value               lval2 = { NULL, 0, 0, 0, 0, NULL };

   lvalue = plnge1(hier, lval);
   if (nextop(&opidx, opstr) == 0)
      return lvalue;		/* no operator in "opstr" found */
   if (lvalue)
      rvalue(lval);
   count = 0;
   do
     {
	if (chkbitwise && count++ > 0 && bitwise_opercount != 0)
	   error(212);
	opidx += opoff;		/* add offset to index returned by nextop() */
	plnge2(op1[opidx], hier, lval, &lval2);
	if (op1[opidx] == ob_and || op1[opidx] == ob_or)
	   bitwise_opercount++;
	if (forcetag)
	   lval->tag = sc_addtag(forcetag);
     }
   while (nextop(&opidx, opstr));	/* do */
   return FALSE;		/* result of expression is not an lvalue */
}

/*  plnge_rel
 *
 *  Binary plunge to lower level; this is very simular to plnge, but
 *  it has special code generation sequences for chained operations.
 */
static int
plnge_rel(int *opstr, int opoff, int (*hier) (value * lval), value * lval)
{
   int                 lvalue, opidx;
   value               lval2 = { NULL, 0, 0, 0, 0, NULL };
   int                 count;

   /* this function should only be called for relational operators */
   assert(op1[opoff] == os_le);
   lvalue = plnge1(hier, lval);
   if (nextop(&opidx, opstr) == 0)
      return lvalue;		/* no operator in "opstr" found */
   if (lvalue)
      rvalue(lval);
   count = 0;
   lval->boolresult = TRUE;
   do
     {
	/* same check as in plnge(), but "chkbitwise" is always TRUE */
	if (count > 0 && bitwise_opercount != 0)
	   error(212);
	if (count > 0)
	  {
	     relop_prefix();
	     *lval = lval2;	/* copy right hand expression of the previous iteration */
	  }			/* if */
	opidx += opoff;
	plnge2(op1[opidx], hier, lval, &lval2);
	if (count++ > 0)
	   relop_suffix();
     }
   while (nextop(&opidx, opstr));	/* enddo */
   lval->constval = lval->boolresult;
   lval->tag = sc_addtag("bool");	/* force tag to be "bool" */
   return FALSE;		/* result of expression is not an lvalue */
}

/*  plnge1
 *
 *  Unary plunge to lower level
 *  Called by: skim(), plnge(), plnge2(), plnge_rel(), hier14() and hier13()
 */
static int
plnge1(int          (*hier) (value * lval), value * lval)
{
   int                 lvalue, index;
   cell                cidx;

   stgget(&index, &cidx);	/* mark position in code generator */
   lvalue = (*hier) (lval);
   if (lval->ident == iCONSTEXPR)
      stgdel(index, cidx);	/* load constant later */
   return lvalue;
}

/*  plnge2
 *
 *  Binary plunge to lower level
 *  Called by: plnge(), plnge_rel(), hier14() and hier1()
 */
static void
plnge2(void         (*oper) (void),
       int (*hier) (value * lval), value * lval1, value * lval2)
{
   int                 index;
   cell                cidx;

   stgget(&index, &cidx);	/* mark position in code generator */
   if (lval1->ident == iCONSTEXPR)
     {				/* constant on left side; it is not yet loaded */
	if (plnge1(hier, lval2))
	   rvalue(lval2);	/* load lvalue now */
	else if (lval2->ident == iCONSTEXPR)
	   const1(lval2->constval << dbltest(oper, lval2, lval1));
	const2(lval1->constval << dbltest(oper, lval2, lval1));
	/* ^ doubling of constants operating on integer addresses */
	/*   is restricted to "add" and "subtract" operators */
     }
   else
     {				/* non-constant on left side */
	push1();
	if (plnge1(hier, lval2))
	   rvalue(lval2);
	if (lval2->ident == iCONSTEXPR)
	  {			/* constant on right side */
	     if (commutative(oper))
	       {		/* test for commutative operators */
		  value               lvaltmp = { NULL, 0, 0, 0, 0, NULL };
		  stgdel(index, cidx);	/* scratch push1() and constant fetch (then
					 * fetch the constant again */
		  const2(lval2->constval << dbltest(oper, lval1, lval2));
		  /* now, the primary register has the left operand and the secondary
		   * register the right operand; swap the "lval" variables so that lval1
		   * is associated with the secondary register and lval2 with the
		   * primary register, as is the "normal" case.
		   */
		  lvaltmp = *lval1;
		  *lval1 = *lval2;
		  *lval2 = lvaltmp;
	       }
	     else
	       {
		  const1(lval2->constval << dbltest(oper, lval1, lval2));
		  pop2();	/* pop result of left operand into secondary register */
	       }		/* if */
	  }
	else
	  {			/* non-constants on both sides */
	     pop2();
	     if (dbltest(oper, lval1, lval2))
		cell2addr();	/* double primary register */
	     if (dbltest(oper, lval2, lval1))
		cell2addr_alt();	/* double secondary register */
	  }			/* if */
     }				/* if */
   if (oper)
     {
	/* If used in an expression, a function should return a value.
	 * If the function has been defined, we can check this. If the
	 * function was not defined, we can set this requirement (so that
	 * a future function definition can check this bit.
	 */
	checkfunction(lval1);
	checkfunction(lval2);
	if (lval1->ident == iARRAY || lval1->ident == iREFARRAY)
	  {
	     char               *ptr =
		(lval1->sym) ? lval1->sym->name : "-unknown-";
	     error(33, ptr);	/* array must be indexed */
	  }
	else if (lval2->ident == iARRAY || lval2->ident == iREFARRAY)
	  {
	     char               *ptr =
		(lval2->sym) ? lval2->sym->name : "-unknown-";
	     error(33, ptr);	/* array must be indexed */
	  }			/* if */
	/* ??? ^^^ should do same kind of error checking with functions */

	/* check whether an "operator" function is defined for the tag names
	 * (a constant expression cannot be optimized in that case)
	 */
	if (check_userop(oper, lval1->tag, lval2->tag, 2, NULL, &lval1->tag))
	  {
	     lval1->ident = iEXPRESSION;
	     lval1->constval = 0;
	  }
	else if (lval1->ident == iCONSTEXPR && lval2->ident == iCONSTEXPR)
	  {
	     /* only constant expression if both constant */
	     stgdel(index, cidx);	/* scratch generated code and calculate */
	     if (!matchtag(lval1->tag, lval2->tag, FALSE))
		error(213);	/* tagname mismatch */
	     lval1->constval =
		calc(lval1->constval, oper, lval2->constval,
		     &lval1->boolresult);
	  }
	else
	  {
	     if (!matchtag(lval1->tag, lval2->tag, FALSE))
		error(213);	/* tagname mismatch */
	     (*oper) ();	/* do the (signed) operation */
	     lval1->ident = iEXPRESSION;
	  }			/* if */
     }				/* if */
}

static cell
truemodulus(cell a, cell b)
{
   return (a % b + b) % b;
}

static cell
calc(cell left, void (*oper) (), cell right, char *boolresult)
{
   if (oper == ob_or)
      return (left | right);
   else if (oper == ob_xor)
      return (left ^ right);
   else if (oper == ob_and)
      return (left & right);
   else if (oper == ob_eq)
      return (left == right);
   else if (oper == ob_ne)
      return (left != right);
   else if (oper == os_le)
      return *boolresult &= (char)(left <= right), right;
   else if (oper == os_ge)
      return *boolresult &= (char)(left >= right), right;
   else if (oper == os_lt)
      return *boolresult &= (char)(left < right), right;
   else if (oper == os_gt)
      return *boolresult &= (char)(left > right), right;
   else if (oper == os_sar)
      return (left >> (int)right);
   else if (oper == ou_sar)
      return ((ucell) left >> (ucell) right);
   else if (oper == ob_sal)
      return ((ucell) left << (int)right);
   else if (oper == ob_add)
      return (left + right);
   else if (oper == ob_sub)
      return (left - right);
   else if (oper == os_mult)
      return (left * right);
   else if (oper == os_div)
      return (left - truemodulus(left, right)) / right;
   else if (oper == os_mod)
      return truemodulus(left, right);
   else
      error(29);		/* invalid expression, assumed 0 (this should never occur) */
   return 0;
}

int
expression(int *constant, cell * val, int *tag, int chkfuncresult)
{
   value               lval = { NULL, 0, 0, 0, 0, NULL };

   if (hier14(&lval))
      rvalue(&lval);
   if (lval.ident == iCONSTEXPR)
     {				/* constant expression */
	*constant = TRUE;
	*val = lval.constval;
     }
   else
     {
	*constant = FALSE;
	*val = 0;
     }				/* if */
   if (tag)
      *tag = lval.tag;
   if (chkfuncresult)
      checkfunction(&lval);
   return lval.ident;
}

static cell
array_totalsize(symbol * sym)
{
   cell                length;

   assert(sym != NULL);
   assert(sym->ident == iARRAY || sym->ident == iREFARRAY);
   length = sym->dim.array.length;
   if (sym->dim.array.level > 0)
     {
	cell                sublength = array_totalsize(finddepend(sym));

	if (sublength > 0)
	   length = length + length * sublength;
	else
	   length = 0;
     }				/* if */
   return length;
}

static cell
array_levelsize(symbol * sym, int level)
{
   assert(sym != NULL);
   assert(sym->ident == iARRAY || sym->ident == iREFARRAY);
   assert(level <= sym->dim.array.level);
   while (level-- > 0)
     {
	sym = finddepend(sym);
	assert(sym != NULL);
     }				/* if */
   return sym->dim.array.length;
}

/*  hier14
 *
 *  Lowest hierarchy level (except for the , operator).
 *
 *  Global references: intest   (referred to only)
 */
int
hier14(value * lval1)
{
   int                 lvalue;
   value               lval2 = { NULL, 0, 0, 0, 0, NULL };
   value               lval3 = { NULL, 0, 0, 0, 0, NULL };
   void                (*oper) (void);
   int                 tok, level, i;
   cell                val;
   char               *st;
   int                 bwcount;
   cell                arrayidx1[sDIMEN_MAX], arrayidx2[sDIMEN_MAX];	/* last used array indices */
   cell               *org_arrayidx;

   bwcount = bitwise_opercount;
   bitwise_opercount = 0;
   for (i = 0; i < sDIMEN_MAX; i++)
      arrayidx1[i] = arrayidx2[i] = 0;
   org_arrayidx = lval1->arrayidx;	/* save current pointer, to reset later */
   if (!lval1->arrayidx)
      lval1->arrayidx = arrayidx1;
   lvalue = plnge1(hier13, lval1);
   if (lval1->ident != iARRAYCELL && lval1->ident != iARRAYCHAR)
      lval1->arrayidx = NULL;
   if (lval1->ident == iCONSTEXPR)	/* load constant here */
      const1(lval1->constval);
   tok = lex(&val, &st);
   switch (tok)
     {
     case taOR:
	oper = ob_or;
	break;
     case taXOR:
	oper = ob_xor;
	break;
     case taAND:
	oper = ob_and;
	break;
     case taADD:
	oper = ob_add;
	break;
     case taSUB:
	oper = ob_sub;
	break;
     case taMULT:
	oper = os_mult;
	break;
     case taDIV:
	oper = os_div;
	break;
     case taMOD:
	oper = os_mod;
	break;
     case taSHRU:
	oper = ou_sar;
	break;
     case taSHR:
	oper = os_sar;
	break;
     case taSHL:
	oper = ob_sal;
	break;
     case '=':			/* simple assignment */
	oper = NULL;
	if (intest)
	   error(211);		/* possibly unintended assignment */
	break;
     default:
	lexpush();
	bitwise_opercount = bwcount;
	lval1->arrayidx = org_arrayidx;	/* restore array index pointer */
	return lvalue;
     }				/* switch */

   /* if we get here, it was an assignment; first check a few special cases
    * and then the general */
   if (lval1->ident == iARRAYCHAR)
     {
	/* special case, assignment to packed character in a cell is permitted */
	lvalue = TRUE;
     }
   else if (lval1->ident == iARRAY || lval1->ident == iREFARRAY)
     {
	/* array assignment is permitted too (with restrictions) */
	if (oper)
	   return error(23);	/* array assignment must be simple assigment */
	assert(lval1->sym != NULL);
	if (array_totalsize(lval1->sym) == 0)
	   return error(46, lval1->sym->name);	/* unknown array size */
	lvalue = TRUE;
     }				/* if */

   /* operand on left side of assignment must be lvalue */
   if (!lvalue)
      return error(22);		/* must be lvalue */
   /* may not change "constant" parameters */
   assert(lval1->sym != NULL);
   if ((lval1->sym->usage & uCONST) != 0)
      return error(22);		/* assignment to const argument */
   lval3 = *lval1;		/* save symbol to enable storage of expresion result */
   lval1->arrayidx = org_arrayidx;	/* restore array index pointer */
   if (lval1->ident == iARRAYCELL || lval1->ident == iARRAYCHAR
       || lval1->ident == iARRAY || lval1->ident == iREFARRAY)
     {
	/* if indirect fetch: save PRI (cell address) */
	if (oper)
	  {
	     push1();
	     rvalue(lval1);
	  }			/* if */
	lval2.arrayidx = arrayidx2;
	plnge2(oper, hier14, lval1, &lval2);
	if (lval2.ident != iARRAYCELL && lval2.ident != iARRAYCHAR)
	   lval2.arrayidx = NULL;
	if (oper)
	   pop2();
	if (!oper && lval3.arrayidx && lval2.arrayidx
	    && lval3.ident == lval2.ident && lval3.sym == lval2.sym)
	  {
	     int                 same = TRUE;

	     assert(lval3.arrayidx == arrayidx1);
	     assert(lval2.arrayidx == arrayidx2);
	     for (i = 0; i < sDIMEN_MAX; i++)
		same = same && (lval3.arrayidx[i] == lval2.arrayidx[i]);
	     if (same)
		error(226, lval3.sym->name);	/* self-assignment */
	  }			/* if */
     }
   else
     {
	if (oper)
	  {
	     rvalue(lval1);
	     plnge2(oper, hier14, lval1, &lval2);
	  }
	else
	  {
	     /* if direct fetch and simple assignment: no "push"
	      * and "pop" needed -> call hier14() directly, */
	     if (hier14(&lval2))
		rvalue(&lval2);	/* instead of plnge2(). */
	     checkfunction(&lval2);
	     /* check whether lval2 and lval3 (old lval1) refer to the same variable */
	     if (lval2.ident == iVARIABLE && lval3.ident == lval2.ident
		 && lval3.sym == lval2.sym)
	       {
		  assert(lval3.sym != NULL);
		  error(226, lval3.sym->name);	/* self-assignment */
	       }		/* if */
	  }			/* if */
     }				/* if */
   if (lval3.ident == iARRAY || lval3.ident == iREFARRAY)
     {
	/* left operand is an array, right operand should be an array variable
	 * of the same size and the same dimension, an array literal (of the
	 * same size) or a literal string.
	 */
	int                 exactmatch = TRUE;

	if (lval2.ident != iARRAY && lval2.ident != iREFARRAY)
	   error(33, lval3.sym->name);	/* array must be indexed */
	if (lval2.sym)
	  {
	     val = lval2.sym->dim.array.length;	/* array variable */
	     level = lval2.sym->dim.array.level;
	  }
	else
	  {
	     val = lval2.constval;	/* literal array */
	     level = 0;
	     /* If val is negative, it means that lval2 is a
	      * literal string. The string array size may be
	      * smaller than the destination array.
	      */
	     if (val < 0)
	       {
		  val = -val;
		  exactmatch = FALSE;
	       }		/* if */
	  }			/* if */
	if (lval3.sym->dim.array.level != level)
	   return error(48);	/* array dimensions must match */
	else if (lval3.sym->dim.array.length < val
		 || (exactmatch && lval3.sym->dim.array.length > val))
	   return error(47);	/* array sizes must match */
	if (level > 0)
	  {
	     /* check the sizes of all sublevels too */
	     symbol             *sym1 = lval3.sym;
	     symbol             *sym2 = lval2.sym;
	     int                 i;

	     assert(sym1 != NULL && sym2 != NULL);
	     /* ^^^ sym2 must be valid, because only variables can be
	      *     multi-dimensional (there are no multi-dimensional arrays),
	      *     sym1 must be valid because it must be an lvalue
	      */
	     assert(exactmatch);
	     for (i = 0; i < level; i++)
	       {
		  sym1 = finddepend(sym1);
		  sym2 = finddepend(sym2);
		  assert(sym1 != NULL && sym2 != NULL);
		  /* ^^^ both arrays have the same dimensions (this was checked
		   *     earlier) so the dependend should always be found
		   */
		  if (sym1->dim.array.length != sym2->dim.array.length)
		     error(47);	/* array sizes must match */
	       }		/* for */
	     /* get the total size in cells of the multi-dimensional array */
	     val = array_totalsize(lval3.sym);
	     assert(val > 0);	/* already checked */
	  }			/* if */
     }
   else
     {
	/* left operand is not an array, right operand should then not be either */
	if (lval2.ident == iARRAY || lval2.ident == iREFARRAY)
	   error(6);		/* must be assigned to an array */
     }				/* if */
   if (lval3.ident == iARRAY || lval3.ident == iREFARRAY)
     {
	memcopy(val * sizeof(cell));
     }
   else
     {
	check_userop(NULL, lval2.tag, lval3.tag, 2, &lval3, &lval2.tag);
	store(&lval3);		/* now, store the expression result */
     }				/* if */
   if (!oper && !matchtag(lval3.tag, lval2.tag, TRUE))
      error(213);		/* tagname mismatch (if "oper", warning already given in plunge2()) */
   if (lval3.sym)
      markusage(lval3.sym, uWRITTEN);
   sideeffect = TRUE;
   bitwise_opercount = bwcount;
   return FALSE;		/* expression result is never an lvalue */
}

static int
hier13(value * lval)
{
   int                 lvalue, flab1, flab2;
   value               lval2 = { NULL, 0, 0, 0, 0, NULL };
   int                 array1, array2;

   lvalue = plnge1(hier12, lval);
   if (matchtoken('?'))
     {
	flab1 = getlabel();
	flab2 = getlabel();
	if (lvalue)
	  {
	     rvalue(lval);
	  }
	else if (lval->ident == iCONSTEXPR)
	  {
	     const1(lval->constval);
	     error(lval->constval ? 206 : 205);	/* redundant test */
	  }			/* if */
	jmp_eq0(flab1);		/* go to second expression if primary register==0 */
	if (hier14(lval))
	   rvalue(lval);
	jumplabel(flab2);
	setlabel(flab1);
	needtoken(':');
	if (hier14(&lval2))
	   rvalue(&lval2);
	array1 = (lval->ident == iARRAY || lval->ident == iREFARRAY);
	array2 = (lval2.ident == iARRAY || lval2.ident == iREFARRAY);
	if (array1 && !array2)
	  {
	     char               *ptr =
		(lval->sym->name) ? lval->sym->name : "-unknown-";
	     error(33, ptr);	/* array must be indexed */
	  }
	else if (!array1 && array2)
	  {
	     char               *ptr =
		(lval2.sym->name) ? lval2.sym->name : "-unknown-";
	     error(33, ptr);	/* array must be indexed */
	  }			/* if */
	/* ??? if both are arrays, should check dimensions */
	if (!matchtag(lval->tag, lval2.tag, FALSE))
	   error(213);		/* tagname mismatch ('true' and 'false' expressions) */
	setlabel(flab2);
	if (lval->ident == iARRAY)
	   lval->ident = iREFARRAY;	/* iARRAY becomes iREFARRAY */
	else if (lval->ident != iREFARRAY)
	   lval->ident = iEXPRESSION;	/* iREFARRAY stays iREFARRAY, rest becomes iEXPRESSION */
	return FALSE;		/* conditional expression is no lvalue */
     }
   else
     {
	return lvalue;
     }				/* endif */
}

/* the order of the operators in these lists is important and must cohere */
/* with the order of the operators in the array "op1" */
static int          list3[] = { '*', '/', '%', 0 };
static int          list4[] = { '+', '-', 0 };
static int          list5[] = { tSHL, tSHR, tSHRU, 0 };
static int          list6[] = { '&', 0 };
static int          list7[] = { '^', 0 };
static int          list8[] = { '|', 0 };
static int          list9[] = { tlLE, tlGE, '<', '>', 0 };
static int          list10[] = { tlEQ, tlNE, 0 };
static int          list11[] = { tlAND, 0 };
static int          list12[] = { tlOR, 0 };

static int
hier12(value * lval)
{
   return skim(list12, jmp_ne0, 1, 0, hier11, lval);
}

static int
hier11(value * lval)
{
   return skim(list11, jmp_eq0, 0, 1, hier10, lval);
}

static int
hier10(value * lval)
{				/* ==, != */
   return plnge(list10, 15, hier9, lval, "bool", TRUE);
}				/* ^ this variable is the starting index in the op1[]
				 *   array of the operators of this hierarchy level */

static int
hier9(value * lval)
{				/* <=, >=, <, > */
   return plnge_rel(list9, 11, hier8, lval);
}

static int
hier8(value * lval)
{				/* | */
   return plnge(list8, 10, hier7, lval, NULL, FALSE);
}

static int
hier7(value * lval)
{				/* ^ */
   return plnge(list7, 9, hier6, lval, NULL, FALSE);
}

static int
hier6(value * lval)
{				/* & */
   return plnge(list6, 8, hier5, lval, NULL, FALSE);
}

static int
hier5(value * lval)
{				/* <<, >>, >>> */
   return plnge(list5, 5, hier4, lval, NULL, FALSE);
}

static int
hier4(value * lval)
{				/* +, - */
   return plnge(list4, 3, hier3, lval, NULL, FALSE);
}

static int
hier3(value * lval)
{				/* *, /, % */
   return plnge(list3, 0, hier2, lval, NULL, FALSE);
}

static int
hier2(value * lval)
{
   int                 lvalue, tok;
   int                 tag, paranthese;
   cell                val;
   char               *st;
   symbol             *sym;
   int                 saveresult;

   tok = lex(&val, &st);
   switch (tok)
     {
     case tINC:		/* ++lval */
	if (!hier2(lval))
	   return error(22);	/* must be lvalue */
	assert(lval->sym != NULL);
	if ((lval->sym->usage & uCONST) != 0)
	   return error(22);	/* assignment to const argument */
	if (!check_userop(user_inc, lval->tag, 0, 1, lval, &lval->tag))
	   inc(lval);		/* increase variable first */
	rvalue(lval);		/* and read the result into PRI */
	sideeffect = TRUE;
	return FALSE;		/* result is no longer lvalue */
     case tDEC:		/* --lval */
	if (!hier2(lval))
	   return error(22);	/* must be lvalue */
	assert(lval->sym != NULL);
	if ((lval->sym->usage & uCONST) != 0)
	   return error(22);	/* assignment to const argument */
	if (!check_userop(user_dec, lval->tag, 0, 1, lval, &lval->tag))
	   dec(lval);		/* decrease variable first */
	rvalue(lval);		/* and read the result into PRI */
	sideeffect = TRUE;
	return FALSE;		/* result is no longer lvalue */
     case '~':			/* ~ (one's complement) */
	if (hier2(lval))
	   rvalue(lval);
	invert();		/* bitwise NOT */
	lval->constval = ~lval->constval;
	return FALSE;
     case '!':			/* ! (logical negate) */
	if (hier2(lval))
	   rvalue(lval);
	if (check_userop(lneg, lval->tag, 0, 1, NULL, &lval->tag))
	  {
	     lval->ident = iEXPRESSION;
	     lval->constval = 0;
	  }
	else
	  {
	     lneg();		/* 0 -> 1,  !0 -> 0 */
	     lval->constval = !lval->constval;
	     lval->tag = sc_addtag("bool");
	  }			/* if */
	return FALSE;
     case '-':			/* unary - (two's complement) */
	if (hier2(lval))
	   rvalue(lval);
	/* make a special check for a constant expression with the tag of a
	 * rational number, so that we can simple swap the sign of that constant.
	 */
	if (lval->ident == iCONSTEXPR && lval->tag == sc_rationaltag
	    && sc_rationaltag != 0)
	  {
	     if (rational_digits == 0)
	       {
		  float              *f = (float *)&lval->constval;

		  *f = -*f;	/* this modifies lval->constval */
	       }
	     else
	       {
		  /* the negation of a fixed point number is just an integer negation */
		  lval->constval = -lval->constval;
	       }		/* if */
	  }
	else if (check_userop(neg, lval->tag, 0, 1, NULL, &lval->tag))
	  {
	     lval->ident = iEXPRESSION;
	     lval->constval = 0;
	  }
	else
	  {
	     neg();		/* arithmic negation */
	     lval->constval = -lval->constval;
	  }			/* if */
	return FALSE;
     case tLABEL:		/* tagname override */
	tag = sc_addtag(st);
	lvalue = hier2(lval);
	lval->tag = tag;
	return lvalue;
     case tDEFINED:
	paranthese = 0;
	while (matchtoken('('))
	   paranthese++;
	tok = lex(&val, &st);
	if (tok != tSYMBOL)
	   return error(20, st);	/* illegal symbol name */
	sym = findloc(st);
	if (!sym)
	   sym = findglb(st);
	if (sym && sym->ident != iFUNCTN && sym->ident != iREFFUNC
	    && (sym->usage & uDEFINE) == 0)
	   sym = NULL;		/* symbol is not a function, it is in the table, but not "defined" */
	val = !!sym;
	if (!val && find_subst(st, strlen(st)))
	   val = 1;
	clear_value(lval);
	lval->ident = iCONSTEXPR;
	lval->constval = val;
	const1(lval->constval);
	while (paranthese--)
	   needtoken(')');
	return FALSE;
     case tSIZEOF:
	paranthese = 0;
	while (matchtoken('('))
	   paranthese++;
	tok = lex(&val, &st);
	if (tok != tSYMBOL)
	   return error(20, st);	/* illegal symbol name */
	sym = findloc(st);
	if (!sym)
	   sym = findglb(st);
	if (!sym)
	   return error(17, st);	/* undefined symbol */
	if (sym->ident == iCONSTEXPR)
	   error(39);		/* constant symbol has no size */
	else if (sym->ident == iFUNCTN || sym->ident == iREFFUNC)
	   error(72);		/* "function" symbol has no size */
	else if ((sym->usage & uDEFINE) == 0)
	   return error(17, st);	/* undefined symbol (symbol is in the table, but it is "used" only) */
	clear_value(lval);
	lval->ident = iCONSTEXPR;
	lval->constval = 1;	/* preset */
	if (sym->ident == iARRAY || sym->ident == iREFARRAY)
	  {
	     int                 level;

	     for (level = 0; matchtoken('['); level++)
		needtoken(']');
	     if (level > sym->dim.array.level)
		error(28);	/* invalid subscript */
	     else
		lval->constval = array_levelsize(sym, level);
	     if (lval->constval == 0 && !strchr(lptr, PREPROC_TERM))
		error(224, st);	/* indeterminate array size in "sizeof" expression */
	  }			/* if */
	const1(lval->constval);
	while (paranthese--)
	   needtoken(')');
	return FALSE;
     case tTAGOF:
	paranthese = 0;
	while (matchtoken('('))
	   paranthese++;
	tok = lex(&val, &st);
	if (tok != tSYMBOL && tok != tLABEL)
	   return error(20, st);	/* illegal symbol name */
	if (tok == tLABEL)
	  {
	     tag = sc_addtag(st);
	  }
	else
	  {
	     sym = findloc(st);
	     if (!sym)
		sym = findglb(st);
	     if (!sym)
		return error(17, st);	/* undefined symbol */
	     if ((sym->usage & uDEFINE) == 0)
		return error(17, st);	/* undefined symbol (symbol is in the table, but it is "used" only) */
	     tag = sym->tag;
	  }			/* if */
	exporttag(tag);
	clear_value(lval);
	lval->ident = iCONSTEXPR;
	lval->constval = tag;
	const1(lval->constval);
	while (paranthese--)
	   needtoken(')');
	return FALSE;
     default:
	lexpush();
	lvalue = hier1(lval);
	/* check for postfix operators */
	if (matchtoken(';'))
	  {
	     /* Found a ';', do not look further for postfix operators */
	     lexpush();		/* push ';' back after successful match */
	     return lvalue;
	  }
	else if (matchtoken(tTERM))
	  {
	     /* Found a newline that ends a statement (this is the case when
	      * semicolons are optional). Note that an explicit semicolon was
	      * handled above. This case is similar, except that the token must
	      * not be pushed back.
	      */
	     return lvalue;
	  }
	else
	  {
	     tok = lex(&val, &st);
	     switch (tok)
	       {
	       case tINC:	/* lval++ */
		  if (!lvalue)
		     return error(22);	/* must be lvalue */
		  assert(lval->sym != NULL);
		  if ((lval->sym->usage & uCONST) != 0)
		     return error(22);	/* assignment to const argument */
		  /* on incrementing array cells, the address in PRI must be saved for
		   * incremening the value, whereas the current value must be in PRI
		   * on exit.
		   */
		  saveresult = (lval->ident == iARRAYCELL
				|| lval->ident == iARRAYCHAR);
		  if (saveresult)
		     push1();	/* save address in PRI */
		  rvalue(lval);	/* read current value into PRI */
		  if (saveresult)
		     swap1();	/* save PRI on the stack, restore address in PRI */
		  if (!check_userop
		      (user_inc, lval->tag, 0, 1, lval, &lval->tag))
		     inc(lval);	/* increase variable afterwards */
		  if (saveresult)
		     pop1();	/* restore PRI (result of rvalue()) */
		  sideeffect = TRUE;
		  return FALSE;	/* result is no longer lvalue */
	       case tDEC:	/* lval-- */
		  if (!lvalue)
		     return error(22);	/* must be lvalue */
		  assert(lval->sym != NULL);
		  if ((lval->sym->usage & uCONST) != 0)
		     return error(22);	/* assignment to const argument */
		  saveresult = (lval->ident == iARRAYCELL
				|| lval->ident == iARRAYCHAR);
		  if (saveresult)
		     push1();	/* save address in PRI */
		  rvalue(lval);	/* read current value into PRI */
		  if (saveresult)
		     swap1();	/* save PRI on the stack, restore address in PRI */
		  if (!check_userop
		      (user_dec, lval->tag, 0, 1, lval, &lval->tag))
		     dec(lval);	/* decrease variable afterwards */
		  if (saveresult)
		     pop1();	/* restore PRI (result of rvalue()) */
		  sideeffect = TRUE;
		  return FALSE;
	       case tCHAR:	/* char (compute required # of cells */
		  if (lval->ident == iCONSTEXPR)
		    {
		       lval->constval *= charbits / 8;	/* from char to bytes */
		       lval->constval =
			  (lval->constval + sizeof(cell) - 1) / sizeof(cell);
		    }
		  else
		    {
		       if (lvalue)
			  rvalue(lval);	/* fetch value if not already in PRI */
		       char2addr();	/* from characters to bytes */
		       addconst(sizeof(cell) - 1);	/* make sure the value is rounded up */
		       addr2cell();	/* truncate to number of cells */
		    }		/* if */
		  return FALSE;
	       default:
		  lexpush();
		  return lvalue;
	       }		/* switch */
	  }			/* if */
     }				/* switch */
}

/*  hier1
 *
 *  The highest hierarchy level: it looks for pointer and array indices
 *  and function calls.
 *  Generates code to fetch a pointer value if it is indexed and code to
 *  add to the pointer value or the array address (the address is already
 *  read at primary()). It also generates code to fetch a function address
 *  if that hasn't already been done at primary() (check lval[4]) and calls
 *  callfunction() to call the function.
 */
static int
hier1(value * lval1)
{
   int                 lvalue, index, tok, symtok;
   cell                val, cidx;
   value               lval2 = { NULL, 0, 0, 0, 0, NULL };
   char               *st;
   char                close;
   symbol             *sym;

   lvalue = primary(lval1);
   symtok = tokeninfo(&val, &st);	/* get token read by primary() */
 restart:
   sym = lval1->sym;
   if (matchtoken('[') || matchtoken('{') || matchtoken('('))
     {
	tok = tokeninfo(&val, &st);	/* get token read by matchtoken() */
	if (!sym && symtok != tSYMBOL)
	  {
	     /* we do not have a valid symbol and we appear not to have read a valid
	      * symbol name (so it is unlikely that we would have read a name of an
	      * undefined symbol) */
	     error(29);		/* expression error, assumed 0 */
	     lexpush();		/* analyse '(', '{' or '[' again later */
	     return FALSE;
	  }			/* if */
	if (tok == '[' || tok == '{')
	  {			/* subscript */
	     close = (char)((tok == '[') ? ']' : '}');
	     if (!sym)
	       {		/* sym==NULL if lval is a constant or a literal */
		  error(28);	/* cannot subscript */
		  needtoken(close);
		  return FALSE;
	       }
	     else if (sym->ident != iARRAY && sym->ident != iREFARRAY)
	       {
		  error(28);	/* cannot subscript, variable is not an array */
		  needtoken(close);
		  return FALSE;
	       }
	     else if (sym->dim.array.level > 0 && close != ']')
	       {
		  error(51);	/* invalid subscript, must use [ ] */
		  needtoken(close);
		  return FALSE;
	       }		/* if */
	     stgget(&index, &cidx);	/* mark position in code generator */
	     push1();		/* save base address of the array */
	     if (hier14(&lval2))	/* create expression for the array index */
		rvalue(&lval2);
	     if (lval2.ident == iARRAY || lval2.ident == iREFARRAY)
		error(33, lval2.sym->name);	/* array must be indexed */
	     needtoken(close);
	     if (!matchtag(sym->x.idxtag, lval2.tag, TRUE))
		error(213);
	     if (lval2.ident == iCONSTEXPR)
	       {		/* constant expression */
		  stgdel(index, cidx);	/* scratch generated code */
		  if (lval1->arrayidx)
		    {		/* keep constant index, for checking */
		       assert(sym->dim.array.level >= 0
			      && sym->dim.array.level < sDIMEN_MAX);
		       lval1->arrayidx[sym->dim.array.level] = lval2.constval;
		    }		/* if */
		  if (close == ']')
		    {
		       /* normal array index */
		       if (lval2.constval < 0 || (sym->dim.array.length != 0
			   && sym->dim.array.length <= lval2.constval))
			  error(32, sym->name);	/* array index out of bounds */
		       if (lval2.constval != 0)
			 {
			    /* don't add offsets for zero subscripts */
#if defined(BIT16)
			    const2(lval2.constval << 1);
#else
			    const2(lval2.constval << 2);
#endif
			    ob_add();
			 }	/* if */
		    }
		  else
		    {
		       /* character index */
		       if (lval2.constval < 0 || (sym->dim.array.length != 0
			   && sym->dim.array.length * ((8 * sizeof(cell)) /
						       charbits) <=
			   (ucell) lval2.constval))
			  error(32, sym->name);	/* array index out of bounds */
		       if (lval2.constval != 0)
			 {
			    /* don't add offsets for zero subscripts */
			    if (charbits == 16)
			       const2(lval2.constval << 1);	/* 16-bit character */
			    else
			       const2(lval2.constval);	/* 8-bit character */
			    ob_add();
			 }	/* if */
		       charalign();	/* align character index into array */
		    }		/* if */
	       }
	     else
	       {
		  /* array index is not constant */
		  lval1->arrayidx = NULL;	/* reset, so won't be checked */
		  if (close == ']')
		    {
		       if (sym->dim.array.length != 0)
			  ffbounds(sym->dim.array.length - 1);	/* run time check for array bounds */
		       cell2addr();	/* normal array index */
		    }
		  else
		    {
		       if (sym->dim.array.length != 0)
			  ffbounds(sym->dim.array.length * (32 / charbits) - 1);
		       char2addr();	/* character array index */
		    }		/* if */
		  pop2();
		  ob_add();	/* base address was popped into secondary register */
		  if (close != ']')
		     charalign();	/* align character index into array */
	       }		/* if */
	     /* the indexed item may be another array (multi-dimensional arrays) */
	     assert(lval1->sym == sym && sym != NULL);	/* should still be set */
	     if (sym->dim.array.level > 0)
	       {
		  assert(close == ']');	/* checked earlier */
		  /* read the offset to the subarray and add it to the current address */
		  lval1->ident = iARRAYCELL;
		  push1();	/* the optimizer makes this to a MOVE.alt */
		  rvalue(lval1);
		  pop2();
		  ob_add();
		  /* adjust the "value" structure and find the referenced array */
		  lval1->ident = iREFARRAY;
		  lval1->sym = finddepend(sym);
		  assert(lval1->sym != NULL);
		  assert(lval1->sym->dim.array.level ==
			 sym->dim.array.level - 1);
		  /* try to parse subsequent array indices */
		  lvalue = FALSE;	/* for now, a iREFARRAY is no lvalue */
		  goto restart;
	       }		/* if */
	     assert(sym->dim.array.level == 0);
	     /* set type to fetch... INDIRECTLY */
	     lval1->ident = (char)((close == ']') ? iARRAYCELL : iARRAYCHAR);
	     lval1->tag = sym->tag;
	     /* a cell in an array is an lvalue, a character in an array is not
	      * always a *valid* lvalue */
	     return TRUE;
	  }
	else
	  {			/* tok=='(' -> function(...) */
	     if (!sym
		 || (sym->ident != iFUNCTN && sym->ident != iREFFUNC))
	       {
		  if (!sym && sc_status == statFIRST)
		    {
		       /* could be a "use before declaration"; in that case, create a stub
		        * function so that the usage can be marked.
		        */
		       sym = fetchfunc(lastsymbol, 0);
		       if (sym)
			  markusage(sym, uREAD);
		    }		/* if */
		  return error(12);	/* invalid function call */
	       }
	     else if ((sym->usage & uMISSING) != 0)
	       {
		  char                symname[2 * sNAMEMAX + 16];	/* allow space for user defined operators */

		  funcdisplayname(symname, sym->name);
		  error(4, symname);	/* function not defined */
	       }		/* if */
	     callfunction(sym);
	     lval1->ident = iEXPRESSION;
	     lval1->constval = 0;
	     lval1->tag = sym->tag;
	     return FALSE;	/* result of function call is no lvalue */
	  }			/* if */
     }				/* if */
   if (sym && lval1->ident == iFUNCTN)
     {
	assert(sym->ident == iFUNCTN);
	address(sym);
	lval1->sym = NULL;
	lval1->ident = iREFFUNC;
	/* ??? however... function pointers (or function references are not (yet) allowed */
	error(29);		/* expression error, assumed 0 */
	return FALSE;
     }				/* if */
   return lvalue;
}

/*  primary
 *
 *  Returns 1 if the operand is an lvalue (everything except arrays, functions
 *  constants and -of course- errors).
 *  Generates code to fetch the address of arrays. Code for constants is
 *  already generated by constant().
 *  This routine first clears the entire lval array (all fields are set to 0).
 *
 *  Global references: intest  (may be altered, but restored upon termination)
 */
static int
primary(value * lval)
{
   char               *st;
   int                 lvalue, tok;
   cell                val;
   symbol             *sym;

   if (matchtoken('('))
     {				/* sub-expression - (expression,...) */
	pushstk((stkitem) intest);
	pushstk((stkitem) sc_allowtags);

	intest = 0;		/* no longer in "test" expression */
	sc_allowtags = TRUE;	/* allow tagnames to be used in parenthised expressions */
	do
	   lvalue = hier14(lval);
	while (matchtoken(','));
	needtoken(')');
	lexclr(FALSE);		/* clear lex() push-back, it should have been
				 * cleared already by needtoken() */
	sc_allowtags = (int)(long)popstk();
	intest = (int)(long)popstk();
	return lvalue;
     }				/* if */

   clear_value(lval);		/* clear lval */
   tok = lex(&val, &st);
   if (tok == tSYMBOL)
     {
	/* lastsymbol is char[sNAMEMAX+1], lex() should have truncated any symbol
	 * to sNAMEMAX significant characters */
	assert(strlen(st) < sizeof lastsymbol);
	strcpy(lastsymbol, st);
     }				/* if */
   if (tok == tSYMBOL && !findconst(st))
     {
	/* first look for a local variable */
	if ((sym = findloc(st)))
	  {
	     if (sym->ident == iLABEL)
	       {
		  error(29);	/* expression error, assumed 0 */
		  const1(0);	/* load 0 */
		  return FALSE;	/* return 0 for labels (expression error) */
	       }		/* if */
	     lval->sym = sym;
	     lval->ident = sym->ident;
	     lval->tag = sym->tag;
	     if (sym->ident == iARRAY || sym->ident == iREFARRAY)
	       {
		  address(sym);	/* get starting address in primary register */
		  return FALSE;	/* return 0 for array (not lvalue) */
	       }
	     else
	       {
		  return TRUE;	/* return 1 if lvalue (not label or array) */
	       }		/* if */
	  }			/* if */
	/* now try a global variable */
	if ((sym = findglb(st)))
	  {
	     if (sym->ident == iFUNCTN || sym->ident == iREFFUNC)
	       {
		  /* if the function is only in the table because it was inserted as a
		   * stub in the first pass (i.e. it was "used" but never declared or
		   * implemented, issue an error
		   */
		  if ((sym->usage & uPROTOTYPED) == 0)
		     error(17, st);
	       }
	     else
	       {
		  if ((sym->usage & uDEFINE) == 0)
		     error(17, st);
		  lval->sym = sym;
		  lval->ident = sym->ident;
		  lval->tag = sym->tag;
		  if (sym->ident == iARRAY || sym->ident == iREFARRAY)
		    {
		       address(sym);	/* get starting address in primary register */
		       return FALSE;	/* return 0 for array (not lvalue) */
		    }
		  else
		    {
		       return TRUE;	/* return 1 if lvalue (not function or array) */
		    }		/* if */
	       }		/* if */
	  }
	else
	  {
	     return error(17, st);	/* undefined symbol */
	  }			/* endif */
	assert(sym != NULL);
	assert(sym->ident == iFUNCTN || sym->ident != iREFFUNC);
	lval->sym = sym;
	lval->ident = sym->ident;
	lval->tag = sym->tag;
	return FALSE;		/* return 0 for function (not an lvalue) */
     }				/* if */
   lexpush();			/* push the token, it is analyzed by constant() */
   if (constant(lval) == 0)
     {
	error(29);		/* expression error, assumed 0 */
	const1(0);		/* load 0 */
     }				/* if */
   return FALSE;		/* return 0 for constants (or errors) */
}

static void
clear_value(value * lval)
{
   lval->sym = NULL;
   lval->constval = 0L;
   lval->tag = 0;
   lval->ident = 0;
   lval->boolresult = FALSE;
   /* do not clear lval->arrayidx, it is preset in hier14() */
}

static void
setdefarray(cell * string, cell size, cell array_sz, cell * dataaddr,
	    int fconst)
{
   /* The routine must copy the default array data onto the heap, as to avoid
    * that a function can change the default value. An optimization is that
    * the default array data is "dumped" into the data segment only once (on the
    * first use).
    */
   assert(string != NULL);
   assert(size > 0);
   /* check whether to dump the default array */
   assert(dataaddr != NULL);
   if (sc_status == statWRITE && *dataaddr < 0)
     {
	int                 i;

	*dataaddr = (litidx + glb_declared) * sizeof(cell);
	for (i = 0; i < size; i++)
	   stowlit(*string++);
     }				/* if */

   /* if the function is known not to modify the array (meaning that it also
    * does not modify the default value), directly pass the address of the
    * array in the data segment.
    */
   if (fconst)
     {
	const1(*dataaddr);
     }
   else
     {
	/* Generate the code:
	 *  CONST.pri dataaddr                ;address of the default array data
	 *  HEAP      array_sz*sizeof(cell)   ;heap address in ALT
	 *  MOVS      size*sizeof(cell)       ;copy data from PRI to ALT
	 *  MOVE.PRI                          ;PRI = address on the heap
	 */
	const1(*dataaddr);
	/* "array_sz" is the size of the argument (the value between the brackets
	 * in the declaration), "size" is the size of the default array data.
	 */
	assert(array_sz >= size);
	modheap((int)array_sz * sizeof(cell));
	/* ??? should perhaps fill with zeros first */
	memcopy(size * sizeof(cell));
	moveto1();
     }				/* if */
}

static int
findnamedarg(arginfo * arg, char *name)
{
   int                 i;

   for (i = 0; arg[i].ident != 0 && arg[i].ident != iVARARGS; i++)
      if (strcmp(arg[i].name, name) == 0)
	 return i;
   return -1;
}

static int
checktag(int tags[], int numtags, int exprtag)
{
   int                 i;

   assert(tags != 0);
   assert(numtags > 0);
   for (i = 0; i < numtags; i++)
      if (matchtag(tags[i], exprtag, TRUE))
	 return TRUE;		/* matching tag */
   return FALSE;		/* no tag matched */
}

enum
{
   ARG_UNHANDLED,
   ARG_IGNORED,
   ARG_DONE,
};

/*  callfunction
 *
 *  Generates code to call a function. This routine handles default arguments
 *  and positional as well as named parameters.
 */
static void
callfunction(symbol * sym)
{
   int                 close, lvalue;
   int                 argpos;	/* index in the output stream (argpos==nargs if positional parameters) */
   int                 argidx = 0;	/* index in "arginfo" list */
   int                 nargs = 0;	/* number of arguments */
   int                 heapalloc = 0;
   int                 namedparams = FALSE;
   value               lval = { NULL, 0, 0, 0, 0, NULL };
   arginfo            *arg;
   char                arglist[sMAXARGS];
   constvalue          arrayszlst = { NULL, "", 0, 0 };	/* array size list starts empty */
   cell                lexval;
   char               *lexstr;

   assert(sym != NULL);
   arg = sym->dim.arglist;
   assert(arg != NULL);
   stgmark(sSTARTREORDER);
   for (argpos = 0; argpos < sMAXARGS; argpos++)
      arglist[argpos] = ARG_UNHANDLED;
   if (!matchtoken(')'))
     {
	do
	  {
	     if (matchtoken('.'))
	       {
		  namedparams = TRUE;
		  if (needtoken(tSYMBOL))
		     tokeninfo(&lexval, &lexstr);
		  else
		     lexstr = "";
		  argpos = findnamedarg(arg, lexstr);
		  if (argpos < 0)
		    {
		       error(17, lexstr);	/* undefined symbol */
		       break;	/* exit loop, argpos is invalid */
		    }		/* if */
		  needtoken('=');
		  argidx = argpos;
	       }
	     else
	       {
		  if (namedparams)
		     error(44);	/* positional parameters must precede named parameters */
		  argpos = nargs;
	       }		/* if */
	     stgmark((char)(sEXPRSTART + argpos));	/* mark beginning of new expression in stage */
	     if (arglist[argpos] != ARG_UNHANDLED)
		error(58);	/* argument already set */
	     if (matchtoken('_'))
	       {
		  arglist[argpos] = ARG_IGNORED;	/* flag argument as "present, but ignored" */
		  if (arg[argidx].ident == 0 || arg[argidx].ident == iVARARGS)
		    {
		       error(202);	/* argument count mismatch */
		    }
		  else if (!arg[argidx].hasdefault)
		    {
		       error(34, nargs + 1);	/* argument has no default value */
		    }		/* if */
		  if (arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS)
		     argidx++;
		  /* The rest of the code to handle default values is at the bottom
		   * of this routine where default values for unspecified parameters
		   * are (also) handled. Note that above, the argument is flagged as
		   * ARG_IGNORED.
		   */
	       }
	     else
	       {
		  arglist[argpos] = ARG_DONE;	/* flag argument as "present" */
		  lvalue = hier14(&lval);
		  switch (arg[argidx].ident)
		    {
		    case 0:
		       error(202);	/* argument count mismatch */
		       break;
		    case iVARARGS:
		       /* always pass by reference */
		       if (lval.ident == iVARIABLE || lval.ident == iREFERENCE)
			 {
			    assert(lval.sym != NULL);
			    if ((lval.sym->usage & uCONST) != 0
				&& (arg[argidx].usage & uCONST) == 0)
			      {
				 /* treat a "const" variable passed to a function with a non-const
				  * "variable argument list" as a constant here */
				 assert(lvalue);
				 rvalue(&lval);	/* get value in PRI */
				 setheap_pri();	/* address of the value on the heap in PRI */
				 heapalloc++;
			      }
			    else if (lvalue)
			      {
				 address(lval.sym);
			      }
			    else
			      {
				 setheap_pri();	/* address of the value on the heap in PRI */
				 heapalloc++;
			      }	/* if */
			 }
		       else if (lval.ident == iCONSTEXPR
				|| lval.ident == iEXPRESSION
				|| lval.ident == iARRAYCHAR)
			 {
			    /* fetch value if needed */
			    if (lval.ident == iARRAYCHAR)
			       rvalue(&lval);
			    /* allocate a cell on the heap and store the
			     * value (already in PRI) there */
			    setheap_pri();	/* address of the value on the heap in PRI */
			    heapalloc++;
			 }	/* if */
		       /* ??? handle const array passed by reference */
		       /* otherwise, the address is already in PRI */
		       if (lval.sym)
			  markusage(lval.sym, uWRITTEN);
/*
 * Dont need this warning - its varargs. there is no way of knowing the
 * required tag/type...
 *
          if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
            error(213);
 */
		       break;
		    case iVARIABLE:
		       if (lval.ident == iLABEL || lval.ident == iFUNCTN
			   || lval.ident == iREFFUNC || lval.ident == iARRAY
			   || lval.ident == iREFARRAY)
			  error(35, argidx + 1);	/* argument type mismatch */
		       if (lvalue)
			  rvalue(&lval);	/* get value (direct or indirect) */
		       /* otherwise, the expression result is already in PRI */
		       assert(arg[argidx].numtags > 0);
		       check_userop(NULL, lval.tag, arg[argidx].tags[0], 2,
				    NULL, &lval.tag);
		       if (!checktag
			   (arg[argidx].tags, arg[argidx].numtags, lval.tag))
			  error(213);
		       argidx++;	/* argument done */
		       break;
		    case iREFERENCE:
		       if (!lvalue || lval.ident == iARRAYCHAR)
			  error(35, argidx + 1);	/* argument type mismatch */
		       if (lval.sym && (lval.sym->usage & uCONST) != 0
			   && (arg[argidx].usage & uCONST) == 0)
			  error(35, argidx + 1);	/* argument type mismatch */
		       if (lval.ident == iVARIABLE || lval.ident == iREFERENCE)
			 {
			    if (lvalue)
			      {
				 assert(lval.sym != NULL);
				 address(lval.sym);
			      }
			    else
			      {
				 setheap_pri();	/* address of the value on the heap in PRI */
				 heapalloc++;
			      }	/* if */
			 }	/* if */
		       /* otherwise, the address is already in PRI */
		       if (!checktag
			   (arg[argidx].tags, arg[argidx].numtags, lval.tag))
			  error(213);
		       argidx++;	/* argument done */
		       if (lval.sym)
			  markusage(lval.sym, uWRITTEN);
		       break;
		    case iREFARRAY:
		       if (lval.ident != iARRAY && lval.ident != iREFARRAY
			   && lval.ident != iARRAYCELL)
			 {
			    error(35, argidx + 1);	/* argument type mismatch */
			    break;
			 }	/* if */
		       if (lval.sym && (lval.sym->usage & uCONST) != 0
			   && (arg[argidx].usage & uCONST) == 0)
			  error(35, argidx + 1);	/* argument type mismatch */
		       /* Verify that the dimensions match with those in arg[argidx].
		        * A literal array always has a single dimension.
		        * An iARRAYCELL parameter is also assumed to have a single dimension.
		        */
		       if (!lval.sym || lval.ident == iARRAYCELL)
			 {
			    if (arg[argidx].numdim != 1)
			      {
				 error(48);	/* array dimensions must match */
			      }
			    else if (arg[argidx].dim[0] != 0)
			      {
				 assert(arg[argidx].dim[0] > 0);
				 if (lval.ident == iARRAYCELL)
				   {
				      error(47);	/* array sizes must match */
				   }
				 else
				   {
				      assert(lval.constval != 0);	/* literal array must have a size */
				      /* A literal array must have exactly the same size as the
				       * function argument; a literal string may be smaller than
				       * the function argument.
				       */
				      if ((lval.constval > 0
					  && arg[argidx].dim[0] != lval.constval)
					  || (lval.constval < 0
					  && arg[argidx].dim[0] <
					  -lval.constval))
					 error(47);	/* array sizes must match */
				   }	/* if */
			      }	/* if */
			    if (lval.ident != iARRAYCELL)
			      {
				 /* save array size, for default values with uSIZEOF flag */
				 cell                array_sz = lval.constval;

				 assert(array_sz != 0);	/* literal array must have a size */
				 if (array_sz < 0)
				    array_sz = -array_sz;
				 append_constval(&arrayszlst, arg[argidx].name,
						 array_sz, 0);
			      }	/* if */
			 }
		       else
			 {
			    symbol             *sym = lval.sym;
			    short               level = 0;

			    assert(sym != NULL);
			    if (sym->dim.array.level + 1 != arg[argidx].numdim)
			       error(48);	/* array dimensions must match */
			    /* the lengths for all dimensions must match, unless the dimension
			     * length was defined at zero (which means "undefined")
			     */
			    while (sym->dim.array.level > 0)
			      {
				 assert(level < sDIMEN_MAX);
				 if (arg[argidx].dim[level] != 0
				     && sym->dim.array.length !=
				     arg[argidx].dim[level])
				    error(47);	/* array sizes must match */
				 append_constval(&arrayszlst, arg[argidx].name,
						 sym->dim.array.length, level);
				 sym = finddepend(sym);
				 assert(sym != NULL);
				 level++;
			      }	/* if */
			    /* the last dimension is checked too, again, unless it is zero */
			    assert(level < sDIMEN_MAX);
			    assert(sym != NULL);
			    if (arg[argidx].dim[level] != 0
				&& sym->dim.array.length !=
				arg[argidx].dim[level])
			       error(47);	/* array sizes must match */
			    append_constval(&arrayszlst, arg[argidx].name,
					    sym->dim.array.length, level);
			 }	/* if */
		       /* address already in PRI */
		       if (!checktag
			   (arg[argidx].tags, arg[argidx].numtags, lval.tag))
			  error(213);
		       // ??? set uWRITTEN?
		       argidx++;	/* argument done */
		       break;
		    }		/* switch */
		  push1();	/* store the function argument on the stack */
		  endexpr(FALSE);	/* mark the end of a sub-expression */
	       }		/* if */
	     assert(arglist[argpos] != ARG_UNHANDLED);
	     nargs++;
	     close = matchtoken(')');
	     if (!close)	/* if not paranthese... */
		if (!needtoken(','))	/* ...should be comma... */
		   break;	/* ...but abort loop if neither */
	  }
	while (!close && freading && !matchtoken(tENDEXPR));	/* do */
     }				/* if */
   /* check remaining function arguments (they may have default values) */
   for (argidx = 0; arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS;
	argidx++)
     {
	if (arglist[argidx] == ARG_DONE)
	   continue;		/* already seen and handled this argument */
	/* in this first stage, we also skip the arguments with uSIZEOF and uTAGOF;
	 * these are handled last
	 */
	if ((arg[argidx].hasdefault & uSIZEOF) != 0
	    || (arg[argidx].hasdefault & uTAGOF) != 0)
	  {
	     assert(arg[argidx].ident == iVARIABLE);
	     continue;
	  }			/* if */
	stgmark((char)(sEXPRSTART + argidx));	/* mark beginning of new expression in stage */
	if (arg[argidx].hasdefault)
	  {
	     if (arg[argidx].ident == iREFARRAY)
	       {
		  short               level;

		  setdefarray(arg[argidx].defvalue.array.data,
			      arg[argidx].defvalue.array.size,
			      arg[argidx].defvalue.array.arraysize,
			      &arg[argidx].defvalue.array.addr,
			      (arg[argidx].usage & uCONST) != 0);
		  if ((arg[argidx].usage & uCONST) == 0)
		     heapalloc += arg[argidx].defvalue.array.arraysize;
		  /* keep the lengths of all dimensions of a multi-dimensional default array */
		  assert(arg[argidx].numdim > 0);
		  if (arg[argidx].numdim == 1)
		    {
		       append_constval(&arrayszlst, arg[argidx].name,
				       arg[argidx].defvalue.array.arraysize, 0);
		    }
		  else
		    {
		       for (level = 0; level < arg[argidx].numdim; level++)
			 {
			    assert(level < sDIMEN_MAX);
			    append_constval(&arrayszlst, arg[argidx].name,
					    arg[argidx].dim[level], level);
			 }	/* for */
		    }		/* if */
	       }
	     else if (arg[argidx].ident == iREFERENCE)
	       {
		  setheap(arg[argidx].defvalue.val);
		  /* address of the value on the heap in PRI */
		  heapalloc++;
	       }
	     else
	       {
		  int                 dummytag = arg[argidx].tags[0];

		  const1(arg[argidx].defvalue.val);
		  assert(arg[argidx].numtags > 0);
		  check_userop(NULL, arg[argidx].defvalue_tag,
			       arg[argidx].tags[0], 2, NULL, &dummytag);
		  assert(dummytag == arg[argidx].tags[0]);
	       }		/* if */
	     push1();		/* store the function argument on the stack */
	     endexpr(FALSE);	/* mark the end of a sub-expression */
	  }
	else
	  {
	     error(202, argidx);	/* argument count mismatch */
	  }			/* if */
	if (arglist[argidx] == ARG_UNHANDLED)
	   nargs++;
	arglist[argidx] = ARG_DONE;
     }				/* for */
   /* now a second loop to catch the arguments with default values that are
    * the "sizeof" or "tagof" of other arguments
    */
   for (argidx = 0; arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS;
	argidx++)
     {
	constvalue         *asz;
	cell                array_sz;

	if (arglist[argidx] == ARG_DONE)
	   continue;		/* already seen and handled this argument */
	stgmark((char)(sEXPRSTART + argidx));	/* mark beginning of new expression in stage */
	assert(arg[argidx].ident == iVARIABLE);	/* if "sizeof", must be single cell */
	/* if unseen, must be "sizeof" or "tagof" */
	assert((arg[argidx].hasdefault & uSIZEOF) != 0
	       || (arg[argidx].hasdefault & uTAGOF) != 0);
	if ((arg[argidx].hasdefault & uSIZEOF) != 0)
	  {
	     /* find the argument; if it isn't found, the argument's default value
	      * was a "sizeof" of a non-array (a warning for this was already given
	      * when declaring the function)
	      */
	     asz = find_constval(&arrayszlst, arg[argidx].defvalue.size.symname,
				 arg[argidx].defvalue.size.level);
	     if (asz)
	       {
		  array_sz = asz->value;
		  if (array_sz == 0)
		     error(224, arg[argidx].name);	/* indeterminate array size in "sizeof" expression */
	       }
	     else
	       {
		  array_sz = 1;
	       }		/* if */
	  }
	else
	  {
	     symbol             *sym;

	     assert((arg[argidx].hasdefault & uTAGOF) != 0);
	     sym = findloc(arg[argidx].defvalue.size.symname);
	     if (!sym)
		sym = findglb(arg[argidx].defvalue.size.symname);
	     array_sz = (sym) ? sym->tag : 0;
	     exporttag(array_sz);
	  }			/* if */
	const1(array_sz);
	push1();		/* store the function argument on the stack */
	endexpr(FALSE);
	if (arglist[argidx] == ARG_UNHANDLED)
	   nargs++;
	arglist[argidx] = ARG_DONE;
     }				/* for */
   stgmark(sENDREORDER);	/* mark end of reversed evaluation */
   pushval((cell) nargs * sizeof(cell));
   ffcall(sym, nargs);
   if (sc_status != statSKIP)
      markusage(sym, uREAD);	/* do not mark as "used" when this call itself is skipped */
   if (sym->x.lib)
      sym->x.lib->value += 1;	/* increment "usage count" of the library */
   modheap(-heapalloc * sizeof(cell));
   sideeffect = TRUE;		/* assume functions carry out a side-effect */
   delete_consttable(&arrayszlst);	/* clear list of array sizes */
}

/*  dbltest
 *
 *  Returns a non-zero value if lval1 an array and lval2 is not an array and
 *  the operation is addition or subtraction.
 *
 *  Returns the "shift" count (1 for 16-bit, 2 for 32-bit) to align a cell
 *  to an array offset.
 */
static int
dbltest(void        (*oper) (), value * lval1, value * lval2)
{
   if ((oper != ob_add) && (oper != ob_sub))
      return 0;
   if (lval1->ident != iARRAY)
      return 0;
   if (lval2->ident == iARRAY)
      return 0;
   return sizeof(cell) / 2;	/* 1 for 16-bit, 2 for 32-bit */
}

/*  commutative
 *
 *  Test whether an operator is commutative, i.e. x oper y == y oper x.
 *  Commutative operators are: +  (addition)
 *                             *  (multiplication)
 *                             == (equality)
 *                             != (inequality)
 *                             &  (bitwise and)
 *                             ^  (bitwise xor)
 *                             |  (bitwise or)
 *
 *  If in an expression, code for the left operand has been generated and
 *  the right operand is a constant and the operator is commutative, the
 *  precautionary "push" of the primary register is scrapped and the constant
 *  is read into the secondary register immediately.
 */
static int
commutative(void    (*oper) ())
{
   return oper == ob_add || oper == os_mult
      || oper == ob_eq || oper == ob_ne
      || oper == ob_and || oper == ob_xor || oper == ob_or;
}

/*  constant
 *
 *  Generates code to fetch a number, a literal character (which is returned
 *  by lex() as a number as well) or a literal string (lex() stores the
 *  strings in the literal queue). If the operand was a number, it is stored
 *  in lval->constval.
 *
 *  The function returns 1 if the token was a constant or a string, 0
 *  otherwise.
 */
static int
constant(value * lval)
{
   int                 tok, index, constant;
   cell                val, item, cidx;
   char               *st;
   symbol             *sym;

   tok = lex(&val, &st);
   if (tok == tSYMBOL && (sym = findconst(st)))
     {
	lval->constval = sym->addr;
	const1(lval->constval);
	lval->ident = iCONSTEXPR;
	lval->tag = sym->tag;
	markusage(sym, uREAD);
     }
   else if (tok == tNUMBER)
     {
	lval->constval = val;
	const1(lval->constval);
	lval->ident = iCONSTEXPR;
     }
   else if (tok == tRATIONAL)
     {
	lval->constval = val;
	const1(lval->constval);
	lval->ident = iCONSTEXPR;
	lval->tag = sc_rationaltag;
     }
   else if (tok == tSTRING)
     {
	/* lex() stores starting index of string in the literal table in 'val' */
	const1((val + glb_declared) * sizeof(cell));
	lval->ident = iARRAY;	/* pretend this is a global array */
	lval->constval = val - litidx;	/* constval == the negative value of the
					 * size of the literal array; using a negative
					 * value distinguishes between literal arrays
					 * and literal strings (this was done for
					 * array assignment). */
     }
   else if (tok == '{')
     {
	int                 tag, lasttag = -1;

	val = litidx;
	do
	  {
	     /* cannot call constexpr() here, because "staging" is already turned
	      * on at this point */
	     assert(staging);
	     stgget(&index, &cidx);	/* mark position in code generator */
	     expression(&constant, &item, &tag, FALSE);
	     stgdel(index, cidx);	/* scratch generated code */
	     if (constant == 0)
		error(8);	/* must be constant expression */
	     if (lasttag < 0)
		lasttag = tag;
	     else if (!matchtag(lasttag, tag, FALSE))
		error(213);	/* tagname mismatch */
	     stowlit(item);	/* store expression result in literal table */
	  }
	while (matchtoken(','));
	needtoken('}');
	const1((val + glb_declared) * sizeof(cell));
	lval->ident = iARRAY;	/* pretend this is a global array */
	lval->constval = litidx - val;	/* constval == the size of the literal array */
     }
   else
     {
	return FALSE;		/* no, it cannot be interpreted as a constant */
     }				/* if */
   return TRUE;			/* yes, it was a constant value */
}