efl/legacy/embryo/src/bin/embryo_cc_sc2.c

/*  Small compiler - File input, preprocessing and lexical analysis functions
 *
 *  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$
 */
#include <assert.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <math.h>
#include "embryo_cc_osdefs.h"
#include "embryo_cc_sc.h"

static int          match(char *st, int end);
static cell         litchar(char **lptr, int rawmode);
static int          alpha(char c);

static int          icomment;	/* currently in multiline comment? */
static int          iflevel;	/* nesting level if #if/#else/#endif */
static int          skiplevel;	/* level at which we started skipping */
static int          elsedone;	/* level at which we have seen an #else */
static char         term_expr[] = "";
static int          listline = -1;	/* "current line" for the list file */

/*  pushstk & popstk
 *
 *  Uses a LIFO stack to store information. The stack is used by doinclude(),
 *  doswitch() (to hold the state of "swactive") and some other routines.
 *
 *  Porting note: I made the bold assumption that an integer will not be
 *  larger than a pointer (it may be smaller). That is, the stack element
 *  is typedef'ed as a pointer type, but I also store integers on it. See
 *  SC.H for "stkitem"
 *
 *  Global references: stack,stkidx (private to pushstk() and popstk())
 */
static stkitem      stack[sSTKMAX];
static int          stkidx;
SC_FUNC void
pushstk(stkitem val)
{
   if (stkidx >= sSTKMAX)
      error(102, "parser stack");	/* stack overflow (recursive include?) */
   stack[stkidx] = val;
   stkidx += 1;
}

SC_FUNC stkitem
popstk(void)
{
   if (stkidx == 0)
      return (stkitem) - 1;	/* stack is empty */
   stkidx -= 1;
   return stack[stkidx];
}

SC_FUNC int
plungequalifiedfile(char *name)
{
   static char        *extensions[] = { ".inc", ".sma", ".small" };
   FILE               *fp;
   char               *ext;
   int                 ext_idx;

   ext_idx = 0;
   do
     {
	fp = (FILE *) sc_opensrc(name);
	ext = strchr(name, '\0');	/* save position */
	if (fp == NULL)
	  {
	     /* try to append an extension */
	     strcpy(ext, extensions[ext_idx]);
	     fp = (FILE *) sc_opensrc(name);
	     if (fp == NULL)
		*ext = '\0';	/* on failure, restore filename */
	  }			/* if */
	ext_idx++;
     }
   while (fp == NULL && ext_idx < (sizeof extensions / sizeof extensions[0]));
   if (fp == NULL)
     {
	*ext = '\0';		/* restore filename */
	return FALSE;
     }				/* if */
   pushstk((stkitem) inpf);
   pushstk((stkitem) inpfname);	/* pointer to current file name */
   pushstk((stkitem) curlibrary);
   /* FIXME: 64bit unsafe */
   pushstk((stkitem) iflevel);
   assert(skiplevel == 0);
   /* FIXME: 64bit unsafe */
   pushstk((stkitem) icomment);
   /* FIXME: 64bit unsafe */
   pushstk((stkitem) fcurrent);
   /* FIXME: 64bit unsafe */
   pushstk((stkitem) fline);
   inpfname = duplicatestring(name);	/* set name of include file */
   if (inpfname == NULL)
      error(103);		/* insufficient memory */
   inpf = fp;			/* set input file pointer to include file */
   fnumber++;
   fline = 0;			/* set current line number to 0 */
   fcurrent = fnumber;
   icomment = FALSE;
   setfile(inpfname, fcurrent);
   setfiledirect(inpfname);
   listline = -1;		/* force a #line directive when changing the file */
   setactivefile(fcurrent);
   return TRUE;
}

SC_FUNC int
plungefile(char *name, int try_currentpath, int try_includepaths)
{
   int                 result = FALSE;
   int                 i;
   char               *ptr;

   if (try_currentpath)
      result = plungequalifiedfile(name);

   if (try_includepaths && name[0] != DIRSEP_CHAR)
     {
	for (i = 0; !result && (ptr = get_path(i)) != NULL; i++)
	  {
	     char                path[_MAX_PATH];

	     strncpy(path, ptr, sizeof path);
	     path[sizeof path - 1] = '\0';	/* force '\0' termination */
	     strncat(path, name, sizeof(path) - strlen(path));
	     path[sizeof path - 1] = '\0';
	     result = plungequalifiedfile(path);
	  }			/* while */
     }				/* if */
   return result;
}

static void
check_empty(char *lptr)
{
   /* verifies that the string contains only whitespace */
   while (*lptr <= ' ' && *lptr != '\0')
      lptr++;
   if (*lptr != '\0')
      error(38);		/* extra characters on line */
}

/*  doinclude
 *
 *  Gets the name of an include file, pushes the old file on the stack and
 *  sets some options. This routine doesn't use lex(), since lex() doesn't
 *  recognize file names (and directories).
 *
 *  Global references: inpf     (altered)
 *                     inpfname (altered)
 *                     fline    (altered)
 *                     lptr     (altered)
 */
static void
doinclude(void)
{
   char                name[_MAX_PATH], c;
   int                 i, result;

   while (*lptr <= ' ' && *lptr != 0)	/* skip leading whitespace */
      lptr++;
   if (*lptr == '<' || *lptr == '\"')
     {
	c = (char)((*lptr == '\"') ? '\"' : '>');	/* termination character */
	lptr++;
	while (*lptr <= ' ' && *lptr != 0)	/* skip whitespace after quote */
	   lptr++;
     }
   else
     {
	c = '\0';
     }				/* if */

   i = 0;
   while (*lptr != c && *lptr != '\0' && i < sizeof name - 1)	/* find the end of the string */
      name[i++] = *lptr++;
   while (i > 0 && name[i - 1] <= ' ')
      i--;			/* strip trailing whitespace */
   assert(i >= 0 && i < sizeof name);
   name[i] = '\0';		/* zero-terminate the string */

   if (*lptr != c)
     {				/* verify correct string termination */
	error(37);		/* invalid string */
	return;
     }				/* if */
   if (c != '\0')
      check_empty(lptr + 1);	/* verify that the rest of the line is whitespace */

   /* Include files between "..." or without quotes are read from the current
    * directory, or from a list of "include directories". Include files
    * between <...> are only read from the list of include directories.
    */
   result = plungefile(name, (c != '>'), TRUE);
   if (!result)
      error(100, name);		/* cannot read from ... (fatal error) */
}

/*  readline
 *
 *  Reads in a new line from the input file pointed to by "inpf". readline()
 *  concatenates lines that end with a \ with the next line. If no more data
 *  can be read from the file, readline() attempts to pop off the previous file
 *  from the stack. If that fails too, it sets "freading" to 0.
 *
 *  Global references: inpf,fline,inpfname,freading,icomment (altered)
 */
static void
readline(char *line)
{
   int                 i, num, cont;
   char               *ptr;

   if (lptr == term_expr)
      return;
   num = sLINEMAX;
   cont = FALSE;
   do
     {
	if (inpf == NULL || sc_eofsrc(inpf))
	  {
	     if (cont)
		error(49);	/* invalid line continuation */
	     if (inpf != NULL && inpf != inpf_org)
		sc_closesrc(inpf);
	     i = (int)(long)popstk();
	     if (i == -1)
	       {		/* All's done; popstk() returns "stack is empty" */
		  freading = FALSE;
		  *line = '\0';
		  /* when there is nothing more to read, the #if/#else stack should
		   * be empty and we should not be in a comment
		   */
		  assert(iflevel >= 0);
		  if (iflevel > 0)
		     error(1, "#endif", "-end of file-");
		  else if (icomment)
		     error(1, "*/", "-end of file-");
		  return;
	       }		/* if */
	     fline = i;
	     fcurrent = (int)(long)popstk();
	     icomment = (int)(long)popstk();
	     assert(skiplevel == 0);	/* skiplevel was not stored on stack, because it should always be zero at this point */
	     iflevel = (int)(long)popstk();
	     curlibrary = (constvalue *) popstk();
	     free(inpfname);	/* return memory allocated for the include file name */
	     inpfname = (char *)popstk();
	     inpf = (FILE *) popstk();
	     setactivefile(fcurrent);
	     setfiledirect(inpfname);
	     listline = -1;	/* force a #line directive when changing the file */
	     elsedone = 0;
	  }			/* if */

	if (sc_readsrc(inpf, line, num) == NULL)
	  {
	     *line = '\0';	/* delete line */
	     cont = FALSE;
	  }
	else
	  {
	     /* check whether to erase leading spaces */
	     if (cont)
	       {
		  char               *ptr = line;

		  while (*ptr == ' ' || *ptr == '\t')
		     ptr++;
		  if (ptr != line)
		     memmove(line, ptr, strlen(ptr) + 1);
	       }		/* if */
	     cont = FALSE;
	     /* check whether a full line was read */
	     if (strchr(line, '\n') == NULL && !sc_eofsrc(inpf))
		error(75);	/* line too long */
	     /* check if the next line must be concatenated to this line */
	     if ((ptr = strchr(line, '\n')) != NULL && ptr > line)
	       {
		  assert(*(ptr + 1) == '\0');	/* '\n' should be last in the string */
		  while (ptr > line
			 && (*ptr == '\n' || *ptr == ' ' || *ptr == '\t'))
		     ptr--;	/* skip trailing whitespace */
		  if (*ptr == '\\')
		    {
		       cont = TRUE;
		       /* set '\a' at the position of '\\' to make it possible to check
		        * for a line continuation in a single line comment (error 49)
		        */
		       *ptr++ = '\a';
		       *ptr = '\0';	/* erase '\n' (and any trailing whitespace) */
		    }		/* if */
	       }		/* if */
	     num -= strlen(line);
	     line += strlen(line);
	  }			/* if */
	fline += 1;
     }
   while (num >= 0 && cont);
}

/*  stripcom
 *
 *  Replaces all comments from the line by space characters. It updates
 *  a global variable ("icomment") for multiline comments.
 *
 *  This routine also supports the C++ extension for single line comments.
 *  These comments are started with "//" and end at the end of the line.
 *
 *  Global references: icomment  (private to "stripcom")
 */
static void
stripcom(char *line)
{
   char                c;

   while (*line)
     {
	if (icomment)
	  {
	     if (*line == '*' && *(line + 1) == '/')
	       {
		  icomment = FALSE;	/* comment has ended */
		  *line = ' ';	/* replace '*' and '/' characters by spaces */
		  *(line + 1) = ' ';
		  line += 2;
	       }
	     else
	       {
		  if (*line == '/' && *(line + 1) == '*')
		     error(216);	/* nested comment */
		  *line = ' ';	/* replace comments by spaces */
		  line += 1;
	       }		/* if */
	  }
	else
	  {
	     if (*line == '/' && *(line + 1) == '*')
	       {
		  icomment = TRUE;	/* start comment */
		  *line = ' ';	/* replace '/' and '*' characters by spaces */
		  *(line + 1) = ' ';
		  line += 2;
	       }
	     else if (*line == '/' && *(line + 1) == '/')
	       {		/* comment to end of line */
		  if (strchr(line, '\a') != NULL)
		     error(49);	/* invalid line continuation */
		  *line++ = '\n';	/* put "newline" at first slash */
		  *line = '\0';	/* put "zero-terminator" at second slash */
	       }
	     else
	       {
		  if (*line == '\"' || *line == '\'')
		    {		/* leave literals unaltered */
		       c = *line;	/* ending quote, single or double */
		       line += 1;
		       while ((*line != c || *(line - 1) == '\\')
			      && *line != '\0')
			  line += 1;
		       line += 1;	/* skip final quote */
		    }
		  else
		    {
		       line += 1;
		    }		/* if */
	       }		/* if */
	  }			/* if */
     }				/* while */
}

/*  btoi
 *
 *  Attempts to interpret a numeric symbol as a boolean value. On success
 *  it returns the number of characters processed (so the line pointer can be
 *  adjusted) and the value is stored in "val". Otherwise it returns 0 and
 *  "val" is garbage.
 *
 *  A boolean value must start with "0b"
 */
static int
btoi(cell * val, char *curptr)
{
   char               *ptr;

   *val = 0;
   ptr = curptr;
   if (*ptr == '0' && *(ptr + 1) == 'b')
     {
	ptr += 2;
	while (*ptr == '0' || *ptr == '1' || *ptr == '_')
	  {
	     if (*ptr != '_')
		*val = (*val << 1) | (*ptr - '0');
	     ptr++;
	  }			/* while */
     }
   else
     {
	return 0;
     }				/* if */
   if (alphanum(*ptr))		/* number must be delimited by non-alphanumeric char */
      return 0;
   else
      return (int)(ptr - curptr);
}

/*  dtoi
 *
 *  Attempts to interpret a numeric symbol as a decimal value. On success
 *  it returns the number of characters processed and the value is stored in
 *  "val". Otherwise it returns 0 and "val" is garbage.
 */
static int
dtoi(cell * val, char *curptr)
{
   char               *ptr;

   *val = 0;
   ptr = curptr;
   if (!isdigit(*ptr))		/* should start with digit */
      return 0;
   while (isdigit(*ptr) || *ptr == '_')
     {
	if (*ptr != '_')
	   *val = (*val * 10) + (*ptr - '0');
	ptr++;
     }				/* while */
   if (alphanum(*ptr))		/* number must be delimited by non-alphanumerical */
      return 0;
   if (*ptr == '.' && isdigit(*(ptr + 1)))
      return 0;			/* but a fractional part must not be present */
   return (int)(ptr - curptr);
}

/*  htoi
 *
 *  Attempts to interpret a numeric symbol as a hexadecimal value. On
 *  success it returns the number of characters processed and the value is
 *  stored in "val". Otherwise it return 0 and "val" is garbage.
 */
static int
htoi(cell * val, char *curptr)
{
   char               *ptr;

   *val = 0;
   ptr = curptr;
   if (!isdigit(*ptr))		/* should start with digit */
      return 0;
   if (*ptr == '0' && *(ptr + 1) == 'x')
     {				/* C style hexadecimal notation */
	ptr += 2;
	while (ishex(*ptr) || *ptr == '_')
	  {
	     if (*ptr != '_')
	       {
		  assert(ishex(*ptr));
		  *val = *val << 4;
		  if (isdigit(*ptr))
		     *val += (*ptr - '0');
		  else
		     *val += (tolower(*ptr) - 'a' + 10);
	       }		/* if */
	     ptr++;
	  }			/* while */
     }
   else
     {
	return 0;
     }				/* if */
   if (alphanum(*ptr))
      return 0;
   else
      return (int)(ptr - curptr);
}

#if defined LINUX
static double
pow10(int value)
{
   double              res = 1.0;

   while (value >= 4)
     {
	res *= 10000.0;
	value -= 5;
     }				/* while */
   while (value >= 2)
     {
	res *= 100.0;
	value -= 2;
     }				/* while */
   while (value >= 1)
     {
	res *= 10.0;
	value -= 1;
     }				/* while */
   return res;
}
#endif

/*  ftoi
 *
 *  Attempts to interpret a numeric symbol as a rational number, either as
 *  IEEE 754 single precision floating point or as a fixed point integer.
 *  On success it returns the number of characters processed and the value is
 *  stored in "val". Otherwise it returns 0 and "val" is unchanged.
 *
 *  Small has stricter definition for floating point numbers than most:
 *  o  the value must start with a digit; ".5" is not a valid number, you
 *     should write "0.5"
 *  o  a period must appear in the value, even if an exponent is given; "2e3"
 *     is not a valid number, you should write "2.0e3"
 *  o  at least one digit must follow the period; "6." is not a valid number,
 *     you should write "6.0"
 */
static int
ftoi(cell * val, char *curptr)
{
   char               *ptr;
   double              fnum, ffrac, fmult;
   unsigned long       dnum, dbase;
   int                 i, ignore;

   assert(rational_digits >= 0 && rational_digits < 9);
   for (i = 0, dbase = 1; i < rational_digits; i++)
      dbase *= 10;
   fnum = 0.0;
   dnum = 0L;
   ptr = curptr;
   if (!isdigit(*ptr))		/* should start with digit */
      return 0;
   while (isdigit(*ptr) || *ptr == '_')
     {
	if (*ptr != '_')
	  {
	     fnum = (fnum * 10.0) + (*ptr - '0');
	     dnum = (dnum * 10L) + (*ptr - '0') * dbase;
	  }			/* if */
	ptr++;
     }				/* while */
   if (*ptr != '.')
      return 0;			/* there must be a period */
   ptr++;
   if (!isdigit(*ptr))		/* there must be at least one digit after the dot */
      return 0;
   ffrac = 0.0;
   fmult = 1.0;
   ignore = FALSE;
   while (isdigit(*ptr) || *ptr == '_')
     {
	if (*ptr != '_')
	  {
	     ffrac = (ffrac * 10.0) + (*ptr - '0');
	     fmult = fmult / 10.0;
	     dbase /= 10L;
	     dnum += (*ptr - '0') * dbase;
	     if (dbase == 0L && sc_rationaltag && rational_digits > 0
		 && !ignore)
	       {
		  error(222);	/* number of digits exceeds rational number precision */
		  ignore = TRUE;
	       }		/* if */
	  }			/* if */
	ptr++;
     }				/* while */
   fnum += ffrac * fmult;	/* form the number so far */
   if (*ptr == 'e')
     {				/* optional fractional part */
	int                 exp, sign;

	ptr++;
	if (*ptr == '-')
	  {
	     sign = -1;
	     ptr++;
	  }
	else
	  {
	     sign = 1;
	  }			/* if */
	if (!isdigit(*ptr))	/* 'e' should be followed by a digit */
	   return 0;
	exp = 0;
	while (isdigit(*ptr))
	  {
	     exp = (exp * 10) + (*ptr - '0');
	     ptr++;
	  }			/* while */
#if defined LINUX
	fmult = pow10(exp * sign);
#else
	fmult = pow(10, exp * sign);
#endif
	fnum *= fmult;
	dnum *= (unsigned long)(fmult + 0.5);
     }				/* if */

   /* decide how to store the number */
   if (sc_rationaltag == 0)
     {
	error(70);		/* rational number support was not enabled */
	*val = 0;
     }
   else if (rational_digits == 0)
     {
	/* floating point */
	float               value = (float)fnum;

	*val = *((cell *) & value);
#if !defined NDEBUG
	/* I assume that the C/C++ compiler stores "float" values in IEEE 754
	 * format (as mandated in the ANSI standard). Test this assumption anyway.
	 */
	{
	   float               test1 = 0.0, test2 = 50.0;

	   assert(*(int *)&test1 == 0x00000000L
		  && *(int *)&test2 == 0x42480000L);
	}
#endif
     }
   else
     {
	/* fixed point */
	*val = (cell) dnum;
     }				/* if */

   return (int)(ptr - curptr);
}

/*  number
 *
 *  Reads in a number (binary, decimal or hexadecimal). It returns the number
 *  of characters processed or 0 if the symbol couldn't be interpreted as a
 *  number (in this case the argument "val" remains unchanged). This routine
 *  relies on the 'early dropout' implementation of the logical or (||)
 *  operator.
 *
 *  Note: the routine doesn't check for a sign (+ or -). The - is checked
 *        for at "hier2()" (in fact, it is viewed as an operator, not as a
 *        sign) and the + is invalid (as in K&R C, and unlike ANSI C).
 */
static int
number(cell * val, char *curptr)
{
   int                 i;
   cell                value;

   if ((i = btoi(&value, curptr)) != 0	/* binary? */
       || (i = htoi(&value, curptr)) != 0	/* hexadecimal? */
       || (i = dtoi(&value, curptr)) != 0)	/* decimal? */
     {
	*val = value;
	return i;
     }
   else
     {
	return 0;		/* else not a number */
     }				/* if */
}

static void
chrcat(char *str, char chr)
{
   str = strchr(str, '\0');
   *str++ = chr;
   *str = '\0';
}

static int
preproc_expr(cell * val, int *tag)
{
   int                 result;
   int                 index;
   cell                code_index;
   char               *term;

   /* Disable staging; it should be disabled already because
    * expressions may not be cut off half-way between conditional
    * compilations. Reset the staging index, but keep the code
    * index.
    */
   if (stgget(&index, &code_index))
     {
	error(57);		/* unfinished expression */
	stgdel(0, code_index);
	stgset(FALSE);
     }				/* if */
   /* append a special symbol to the string, so the expression
    * analyzer won't try to read a next line when it encounters
    * an end-of-line
    */
   assert(strlen(pline) < sLINEMAX);
   term = strchr(pline, '\0');
   assert(term != NULL);
   chrcat(pline, PREPROC_TERM);	/* the "DEL" code (see SC.H) */
   result = constexpr(val, tag);	/* get value (or 0 on error) */
   *term = '\0';		/* erase the token (if still present) */
   lexclr(FALSE);		/* clear any "pushed" tokens */
   return result;
}

/* getstring
 * Returns returns a pointer behind the closing quote or to the other
 * character that caused the input to be ended.
 */
static char        *
getstring(char *dest, int max, char *line)
{
   assert(dest != NULL && line != NULL);
   *dest = '\0';
   while (*line <= ' ' && *line != '\0')
      line++;			/* skip whitespace */
   if (*line != '"')
     {
	error(37);		/* invalid string */
     }
   else if (*line == '\0')
     {
	int                 len = 0;

	line++;			/* skip " */
	while (*line != '"' && *line != '\0')
	  {
	     if (len < max - 1)
		dest[len++] = *line;
	     line++;
	  }			/* if */
	dest[len] = '\0';
	if (*line == '"')
	   lptr++;		/* skip closing " */
	else
	   error(37);		/* invalid string */
     }				/* if */
   return lptr;
}

enum
{
   CMD_NONE,
   CMD_TERM,
   CMD_EMPTYLINE,
   CMD_CONDFALSE,
   CMD_INCLUDE,
   CMD_DEFINE,
   CMD_IF,
   CMD_DIRECTIVE,
};

/*  command
 *
 *  Recognizes the compiler directives. The function returns:
 *     CMD_NONE         the line must be processed
 *     CMD_TERM         a pending expression must be completed before processing further lines
 *     Other value: the line must be skipped, because:
 *     CMD_CONDFALSE    false "#if.." code
 *     CMD_EMPTYLINE    line is empty
 *     CMD_INCLUDE      the line contains a #include directive
 *     CMD_DEFINE       the line contains a #subst directive
 *     CMD_IF           the line contains a #if/#else/#endif directive
 *     CMD_DIRECTIVE    the line contains some other compiler directive
 *
 *  Global variables: iflevel, skiplevel, elsedone (altered)
 *                    lptr      (altered)
 */
static int
command(void)
{
   int                 tok, ret;
   cell                val;
   char               *str;
   int                 index;
   cell                code_index;

   while (*lptr <= ' ' && *lptr != '\0')
      lptr += 1;
   if (*lptr == '\0')
      return CMD_EMPTYLINE;	/* empty line */
   if (*lptr != '#')
      return skiplevel > 0 ? CMD_CONDFALSE : CMD_NONE;	/* it is not a compiler directive */
   /* compiler directive found */
   indent_nowarn = TRUE;	/* allow loose indentation" */
   lexclr(FALSE);		/* clear any "pushed" tokens */
   /* on a pending expression, force to return a silent ';' token and force to
    * re-read the line
    */
   if (!sc_needsemicolon && stgget(&index, &code_index))
     {
	lptr = term_expr;
	return CMD_TERM;
     }				/* if */
   tok = lex(&val, &str);
   ret = skiplevel > 0 ? CMD_CONDFALSE : CMD_DIRECTIVE;	/* preset 'ret' to CMD_DIRECTIVE (most common case) */
   switch (tok)
     {
     case tpIF:		/* conditional compilation */
	ret = CMD_IF;
	iflevel += 1;
	if (skiplevel)
	   break;		/* break out of switch */
	preproc_expr(&val, NULL);	/* get value (or 0 on error) */
	if (!val)
	   skiplevel = iflevel;
	check_empty(lptr);
	break;
     case tpELSE:
	ret = CMD_IF;
	if (iflevel == 0 && skiplevel == 0)
	  {
	     error(26);		/* no matching #if */
	     errorset(sRESET);
	  }
	else
	  {
	     if (elsedone == iflevel)
		error(60);	/* multiple #else directives between #if ... #endif */
	     elsedone = iflevel;
	     if (skiplevel == iflevel)
		skiplevel = 0;
	     else if (skiplevel == 0)
		skiplevel = iflevel;
	  }			/* if */
	check_empty(lptr);
	break;
#if 0				/* ??? *really* need to use a stack here */
     case tpELSEIF:
	ret = CMD_IF;
	if (iflevel == 0 && skiplevel == 0)
	  {
	     error(26);		/* no matching #if */
	     errorset(sRESET);
	  }
	else if (elsedone == iflevel)
	  {
	     error(61);		/* #elseif directive may not follow an #else */
	     errorset(sRESET);
	  }
	else
	  {
	     preproc_expr(&val, NULL);	/* get value (or 0 on error) */
	     if (skiplevel == 0)
		skiplevel = iflevel;	/* we weren't skipping, start skipping now */
	     else if (val)
		skiplevel = 0;	/* we were skipping, condition is valid -> stop skipping */
	     /* else: we were skipping and condition is invalid -> keep skipping */
	     check_empty(lptr);
	  }			/* if */
	break;
#endif
     case tpENDIF:
	ret = CMD_IF;
	if (iflevel == 0 && skiplevel == 0)
	  {
	     error(26);
	     errorset(sRESET);
	  }
	else
	  {
	     if (skiplevel == iflevel)
		skiplevel = 0;
	     if (elsedone == iflevel)
		elsedone = 0;	/* ??? actually, should build a stack of #if/#endif and keep
				 * the state whether an #else was seen per nesting level */
	     iflevel -= 1;
	  }			/* if */
	check_empty(lptr);
	break;
     case tINCLUDE:		/* #include directive */
	ret = CMD_INCLUDE;
	if (skiplevel == 0)
	   doinclude();
	break;
     case tpFILE:
	if (skiplevel == 0)
	  {
	     char                pathname[_MAX_PATH];

	     lptr = getstring(pathname, sizeof pathname, lptr);
	     if (strlen(pathname) > 0)
	       {
		  free(inpfname);
		  inpfname = duplicatestring(pathname);
		  if (inpfname == NULL)
		     error(103);	/* insufficient memory */
	       }		/* if */
	  }			/* if */
	check_empty(lptr);
	break;
     case tpLINE:
	if (skiplevel == 0)
	  {
	     if (lex(&val, &str) != tNUMBER)
		error(8);	/* invalid/non-constant expression */
	     fline = (int)val;
	  }			/* if */
	check_empty(lptr);
	break;
     case tpASSERT:
	if (skiplevel == 0 && (sc_debug & sCHKBOUNDS) != 0)
	  {
	     preproc_expr(&val, NULL);	/* get constant expression (or 0 on error) */
	     if (!val)
		error(7);	/* assertion failed */
	     check_empty(lptr);
	  }			/* if */
	break;
     case tpPRAGMA:
	if (skiplevel == 0)
	  {
	     if (lex(&val, &str) == tSYMBOL)
	       {
		  if (strcmp(str, "ctrlchar") == 0)
		    {
		       if (lex(&val, &str) != tNUMBER)
			  error(27);	/* invalid character constant */
		       sc_ctrlchar = (char)val;
		    }
		  else if (strcmp(str, "compress") == 0)
		    {
		       cell                val;

		       preproc_expr(&val, NULL);
		       sc_compress = (int)val;	/* switch code packing on/off */
		    }
		  else if (strcmp(str, "dynamic") == 0)
		    {
		       preproc_expr(&sc_stksize, NULL);
		    }
		  else if (strcmp(str, "library") == 0)
		    {
		       char                name[sNAMEMAX + 1];

		       while (*lptr <= ' ' && *lptr != '\0')
			  lptr++;
		       if (*lptr == '"')
			 {
			    lptr = getstring(name, sizeof name, lptr);
			 }
		       else
			 {
			    int                 i;

			    for (i = 0; i < sizeof name && alphanum(*lptr);
				 i++, lptr++)
			       name[i] = *lptr;
			    name[i] = '\0';
			 }	/* if */
		       if (strlen(name) == 0)
			 {
			    curlibrary = NULL;
			 }
		       else
			 {
			    if (strlen(name) > sEXPMAX)
			       error(220, name, sEXPMAX);	/* exported symbol is truncated */
			    /* add the name if it does not yet exist in the table */
			    if (find_constval(&libname_tab, name, 0) == NULL)
			       curlibrary =
				  append_constval(&libname_tab, name, 0, 0);
			 }	/* if */
		    }
		  else if (strcmp(str, "pack") == 0)
		    {
		       cell                val;

		       preproc_expr(&val, NULL);	/* default = packed/unpacked */
		       sc_packstr = (int)val;
		    }
		  else if (strcmp(str, "rational") == 0)
		    {
		       char                name[sNAMEMAX + 1];
		       cell                digits = 0;
		       int                 i;

		       /* first gather all information, start with the tag name */
		       while (*lptr <= ' ' && *lptr != '\0')
			  lptr++;
		       for (i = 0; i < sizeof name && alphanum(*lptr);
			    i++, lptr++)
			  name[i] = *lptr;
		       name[i] = '\0';
		       /* then the precision (for fixed point arithmetic) */
		       while (*lptr <= ' ' && *lptr != '\0')
			  lptr++;
		       if (*lptr == '(')
			 {
			    preproc_expr(&digits, NULL);
			    if (digits <= 0 || digits > 9)
			      {
				 error(68);	/* invalid rational number precision */
				 digits = 0;
			      }	/* if */
			    if (*lptr == ')')
			       lptr++;
			 }	/* if */
		       /* add the tag (make it public) and check the values */
		       i = sc_addtag(name);
		       exporttag(i);
		       if (sc_rationaltag == 0
			   || (sc_rationaltag == i
			       && rational_digits == (int)digits))
			 {
			    sc_rationaltag = i;
			    rational_digits = (int)digits;
			 }
		       else
			 {
			    error(69);	/* rational number format already set, can only be set once */
			 }	/* if */
		    }
		  else if (strcmp(str, "semicolon") == 0)
		    {
		       cell                val;

		       preproc_expr(&val, NULL);
		       sc_needsemicolon = (int)val;
		    }
		  else if (strcmp(str, "tabsize") == 0)
		    {
		       cell                val;

		       preproc_expr(&val, NULL);
		       sc_tabsize = (int)val;
		    }
		  else if (strcmp(str, "align") == 0)
		    {
		       sc_alignnext = TRUE;
		    }
		  else if (strcmp(str, "unused") == 0)
		    {
		       char                name[sNAMEMAX + 1];
		       int                 i, comma;
		       symbol             *sym;

		       do
			 {
			    /* get the name */
			    while (*lptr <= ' ' && *lptr != '\0')
			       lptr++;
			    for (i = 0; i < sizeof name && isalpha(*lptr);
				 i++, lptr++)
			       name[i] = *lptr;
			    name[i] = '\0';
			    /* get the symbol */
			    sym = findloc(name);
			    if (sym == NULL)
			       sym = findglb(name);
			    if (sym != NULL)
			      {
				 sym->usage |= uREAD;
				 if (sym->ident == iVARIABLE
				     || sym->ident == iREFERENCE
				     || sym->ident == iARRAY
				     || sym->ident == iREFARRAY)
				    sym->usage |= uWRITTEN;
			      }
			    else
			      {
				 error(17, name);	/* undefined symbol */
			      }	/* if */
			    /* see if a comma follows the name */
			    while (*lptr <= ' ' && *lptr != '\0')
			       lptr++;
			    comma = (*lptr == ',');
			    if (comma)
			       lptr++;
			 }
		       while (comma);
		    }
		  else
		    {
		       error(207);	/* unknown #pragma */
		    }		/* if */
	       }
	     else
	       {
		  error(207);	/* unknown #pragma */
	       }		/* if */
	     check_empty(lptr);
	  }			/* if */
	break;
     case tpENDINPUT:
     case tpENDSCRPT:
	if (skiplevel == 0)
	  {
	     check_empty(lptr);
	     assert(inpf != NULL);
	     if (inpf != inpf_org)
		sc_closesrc(inpf);
	     inpf = NULL;
	  }			/* if */
	break;
#if !defined NOEMIT
     case tpEMIT:
	{
	   /* write opcode to output file */
	   char                name[40];
	   int                 i;

	   while (*lptr <= ' ' && *lptr != '\0')
	      lptr++;
	   for (i = 0; i < 40 && (isalpha(*lptr) || *lptr == '.'); i++, lptr++)
	      name[i] = (char)tolower(*lptr);
	   name[i] = '\0';
	   stgwrite("\t");
	   stgwrite(name);
	   stgwrite(" ");
	   code_idx += opcodes(1);
	   /* write parameter (if any) */
	   while (*lptr <= ' ' && *lptr != '\0')
	      lptr++;
	   if (*lptr != '\0')
	     {
		symbol             *sym;

		tok = lex(&val, &str);
		switch (tok)
		  {
		  case tNUMBER:
		  case tRATIONAL:
		     outval(val, FALSE);
		     code_idx += opargs(1);
		     break;
		  case tSYMBOL:
		     sym = findloc(str);
		     if (sym == NULL)
			sym = findglb(str);
		     if (sym == NULL || sym->ident != iFUNCTN
			 && sym->ident != iREFFUNC
			 && (sym->usage & uDEFINE) == 0)
		       {
			  error(17, str);	/* undefined symbol */
		       }
		     else
		       {
			  outval(sym->addr, FALSE);
			  /* mark symbol as "used", unknown whether for read or write */
			  markusage(sym, uREAD | uWRITTEN);
			  code_idx += opargs(1);
		       }	/* if */
		     break;
		  default:
		     {
			char                s2[20];
			extern char        *sc_tokens[];	/* forward declaration */

			if (tok < 256)
			   sprintf(s2, "%c", (char)tok);
			else
			   strcpy(s2, sc_tokens[tok - tFIRST]);
			error(1, sc_tokens[tSYMBOL - tFIRST], s2);
			break;
		     }		/* case */
		  }		/* switch */
	     }			/* if */
	   stgwrite("\n");
	   check_empty(lptr);
	   break;
	}			/* case */
#endif
#if !defined NO_DEFINE
     case tpDEFINE:
	{
	   ret = CMD_DEFINE;
	   if (skiplevel == 0)
	     {
		char               *pattern, *substitution;
		char               *start, *end;
		int                 count, prefixlen;
		stringpair         *def;

		/* find the pattern to match */
		while (*lptr <= ' ' && *lptr != '\0')
		   lptr++;
		start = lptr;	/* save starting point of the match pattern */
		count = 0;
		while (*lptr > ' ' && *lptr != '\0')
		  {
		     litchar(&lptr, FALSE);	/* litchar() advances "lptr" and handles escape characters */
		     count++;
		  }		/* while */
		end = lptr;
		/* check pattern to match */
		if (!isalpha(*start) && *start != '_')
		  {
		     error(74);	/* pattern must start with an alphabetic character */
		     break;
		  }		/* if */
		/* store matched pattern */
		pattern = malloc(count + 1);
		if (pattern == NULL)
		   error(103);	/* insufficient memory */
		lptr = start;
		count = 0;
		while (lptr != end)
		  {
		     assert(lptr < end);
		     assert(*lptr != '\0');
		     pattern[count++] = (char)litchar(&lptr, FALSE);
		  }		/* while */
		pattern[count] = '\0';
		/* special case, erase trailing variable, because it could match anything */
		if (count >= 2 && isdigit(pattern[count - 1])
		    && pattern[count - 2] == '%')
		   pattern[count - 2] = '\0';
		/* find substitution string */
		while (*lptr <= ' ' && *lptr != '\0')
		   lptr++;
		start = lptr;	/* save starting point of the match pattern */
		count = 0;
		end = NULL;
		while (*lptr != '\0')
		  {
		     /* keep position of the start of trailing whitespace */
		     if (*lptr <= ' ')
		       {
			  if (end == NULL)
			     end = lptr;
		       }
		     else
		       {
			  end = NULL;
		       }	/* if */
		     count++;
		     lptr++;
		  }		/* while */
		if (end == NULL)
		   end = lptr;
		/* store matched substitution */
		substitution = malloc(count + 1);	/* +1 for '\0' */
		if (substitution == NULL)
		   error(103);	/* insufficient memory */
		lptr = start;
		count = 0;
		while (lptr != end)
		  {
		     assert(lptr < end);
		     assert(*lptr != '\0');
		     substitution[count++] = *lptr++;
		  }		/* while */
		substitution[count] = '\0';
		/* check whether the definition already exists */
		for (prefixlen = 0, start = pattern;
		     isalpha(*start) || isdigit(*start) || *start == '_';
		     prefixlen++, start++)
		   /* nothing */ ;
		assert(prefixlen > 0);
		if ((def = find_subst(pattern, prefixlen)) != NULL)
		  {
		     if (strcmp(def->first, pattern) != 0
			 || strcmp(def->second, substitution) != 0)
			error(201, pattern);	/* redefinition of macro (non-identical) */
		     delete_subst(pattern, prefixlen);
		  }		/* if */
		/* add the pattern/substitution pair to the list */
		assert(strlen(pattern) > 0);
		insert_subst(pattern, substitution, prefixlen);
		free(pattern);
		free(substitution);
	     }			/* if */
	   break;
	}			/* case */
     case tpUNDEF:
	if (skiplevel == 0)
	  {
	     if (lex(&val, &str) == tSYMBOL)
	       {
		  if (!delete_subst(str, strlen(str)))
		     error(17, str);	/* undefined symbol */
	       }
	     else
	       {
		  error(20, str);	/* invalid symbol name */
	       }		/* if */
	     check_empty(lptr);
	  }			/* if */
	break;
#endif
     default:
	error(31);		/* unknown compiler directive */
	ret = skiplevel > 0 ? CMD_DIRECTIVE : CMD_NONE;	/* line must be processed (if skiplevel==0) */
     }				/* switch */
   return ret;
}

#if !defined NO_DEFINE
static int
is_startstring(char *string)
{
   if (*string == '\"' || *string == '\'')
      return TRUE;		/* "..." */

   if (*string == '!')
     {
	string++;
	if (*string == '\"' || *string == '\'')
	   return TRUE;		/* !"..." */
	if (*string == sc_ctrlchar)
	  {
	     string++;
	     if (*string == '\"' || *string == '\'')
		return TRUE;	/* !\"..." */
	  }			/* if */
     }
   else if (*string == sc_ctrlchar)
     {
	string++;
	if (*string == '\"' || *string == '\'')
	   return TRUE;		/* \"..." */
	if (*string == '!')
	  {
	     string++;
	     if (*string == '\"' || *string == '\'')
		return TRUE;	/* \!"..." */
	  }			/* if */
     }				/* if */

   return FALSE;
}

static char        *
skipstring(char *string)
{
   char                endquote;
   int                 rawstring = FALSE;

   while (*string == '!' || *string == sc_ctrlchar)
     {
	rawstring = (*string == sc_ctrlchar);
	string++;
     }				/* while */

   endquote = *string;
   assert(endquote == '\"' || endquote == '\'');
   string++;			/* skip open quote */
   while (*string != endquote && *string != '\0')
      litchar(&string, rawstring);
   return string;
}

static char        *
skippgroup(char *string)
{
   int                 nest = 0;
   char                open = *string;
   char                close;

   switch (open)
     {
     case '(':
	close = ')';
	break;
     case '{':
	close = '}';
	break;
     case '[':
	close = ']';
	break;
     case '<':
	close = '>';
	break;
     default:
	assert(0);
	close = '\0';		/* only to avoid a compiler warning */
     }				/* switch */

   string++;
   while (*string != close || nest > 0)
     {
	if (*string == open)
	   nest++;
	else if (*string == close)
	   nest--;
	else if (is_startstring(string))
	   string = skipstring(string);
	if (*string == '\0')
	   break;
	string++;
     }				/* while */
   return string;
}

static char        *
strdel(char *str, size_t len)
{
   size_t              length = strlen(str);

   if (len > length)
      len = length;
   memmove(str, str + len, length - len + 1);	/* include EOS byte */
   return str;
}

static char        *
strins(char *dest, char *src, size_t srclen)
{
   size_t              destlen = strlen(dest);

   assert(srclen <= strlen(src));
   memmove(dest + srclen, dest, destlen + 1);	/* include EOS byte */
   memcpy(dest, src, srclen);
   return dest;
}

static int
substpattern(char *line, size_t buffersize, char *pattern, char *substitution)
{
   int                 prefixlen;
   char               *p, *s, *e, *args[10];
   int                 match, arg, len;

   memset(args, 0, sizeof args);

   /* check the length of the prefix */
   for (prefixlen = 0, s = pattern; isalpha(*s) || isdigit(*s) || *s == '_';
	prefixlen++, s++)
      /* nothing */ ;
   assert(prefixlen > 0);
   assert(strncmp(line, pattern, prefixlen) == 0);

   /* pattern prefix matches; match the rest of the pattern, gather
    * the parameters
    */
   s = line + prefixlen;
   p = pattern + prefixlen;
   match = TRUE;		/* so far, pattern matches */
   while (match && *s != '\0' && *p != '\0')
     {
	if (*p == '%')
	  {
	     p++;		/* skip '%' */
	     if (isdigit(*p))
	       {
		  arg = *p - '0';
		  assert(arg >= 0 && arg <= 9);
		  p++;		/* skip parameter id */
		  assert(*p != '\0');
		  /* match the source string up to the character after the digit
		   * (skipping strings in the process
		   */
		  e = s;
		  while (*e != *p && *e != '\0' && *e != '\n')
		    {
		       if (is_startstring(e))	/* skip strings */
			  e = skipstring(e);
		       else if (strchr("({[", *e) != NULL)	/* skip parenthized groups */
			  e = skippgroup(e);
		       if (*e != '\0')
			  e++;	/* skip non-alphapetic character (or closing quote of
				 * a string, or the closing paranthese of a group) */
		    }		/* while */
		  /* store the parameter (overrule any earlier) */
		  if (args[arg] != NULL)
		     free(args[arg]);
		  len = (int)(e - s);
		  args[arg] = malloc(len + 1);
		  if (args[arg] == NULL)
		     error(103);	/* insufficient memory */
		  strncpy(args[arg], s, len);
		  args[arg][len] = '\0';
		  /* character behind the pattern was matched too */
		  if (*e == *p)
		    {
		       s = e + 1;
		    }
		  else if (*e == '\n' && *p == ';' && *(p + 1) == '\0'
			   && !sc_needsemicolon)
		    {
		       s = e;	/* allow a trailing ; in the pattern match to end of line */
		    }
		  else
		    {
		       assert(*e == '\0' || *e == '\n');
		       match = FALSE;
		       s = e;
		    }		/* if */
		  p++;
	       }
	     else
	       {
		  match = FALSE;
	       }		/* if */
	  }
	else if (*p == ';' && *(p + 1) == '\0' && !sc_needsemicolon)
	  {
	     /* source may be ';' or end of the line */
	     while (*s <= ' ' && *s != '\0')
		s++;		/* skip white space */
	     if (*s != ';' && *s != '\0')
		match = FALSE;
	     p++;		/* skip the semicolon in the pattern */
	  }
	else
	  {
	     cell                ch;

	     /* skip whitespace between two non-alphanumeric characters, except
	      * for two identical symbols
	      */
	     assert(p > pattern);
	     if (!alphanum(*p) && *(p - 1) != *p)
		while (*s <= ' ' && *s != '\0')
		   s++;		/* skip white space */
	     ch = litchar(&p, FALSE);	/* this increments "p" */
	     if (*s != ch)
		match = FALSE;
	     else
		s++;		/* this character matches */
	  }			/* if */
     }				/* while */

   if (match && *p == '\0')
     {
	/* if the last character to match is an alphanumeric character, the
	 * current character in the source may not be alphanumeric
	 */
	assert(p > pattern);
	if (alphanum(*(p - 1)) && alphanum(*s))
	   match = FALSE;
     }				/* if */

   if (match)
     {
	/* calculate the length of the substituted string */
	for (e = substitution, len = 0; *e != '\0'; e++)
	  {
	     if (*e == '%' && isdigit(*(e + 1)))
	       {
		  arg = *(e + 1) - '0';
		  assert(arg >= 0 && arg <= 9);
		  if (args[arg] != NULL)
		     len += strlen(args[arg]);
		  e++;		/* skip %, digit is skipped later */
	       }
	     else
	       {
		  len++;
	       }		/* if */
	  }			/* for */
	/* check length of the string after substitution */
	if (strlen(line) + len - (int)(s - line) > buffersize)
	  {
	     error(75);		/* line too long */
	  }
	else
	  {
	     /* substitute pattern */
	     strdel(line, (int)(s - line));
	     for (e = substitution, s = line; *e != '\0'; e++)
	       {
		  if (*e == '%' && isdigit(*(e + 1)))
		    {
		       arg = *(e + 1) - '0';
		       assert(arg >= 0 && arg <= 9);
		       if (args[arg] != NULL)
			 {
			    strins(s, args[arg], strlen(args[arg]));
			    s += strlen(args[arg]);
			 }	/* if */
		       e++;	/* skip %, digit is skipped later */
		    }
		  else
		    {
		       strins(s, e, 1);
		       s++;
		    }		/* if */
	       }		/* for */
	  }			/* if */
     }				/* if */

   for (arg = 0; arg < 10; arg++)
      if (args[arg] != NULL)
	 free(args[arg]);

   return match;
}

static void
substallpatterns(char *line, int buffersize)
{
   char               *start, *end;
   int                 prefixlen;
   stringpair         *subst;

   start = line;
   while (*start != '\0')
     {
	/* find the start of a prefix (skip all non-alphabetic characters),
	 * also skip strings
	 */
	while (!isalpha(*start) && *start != '_' && *start != '\0')
	  {
	     /* skip strings */
	     if (is_startstring(start))
	       {
		  start = skipstring(start);
		  if (*start == '\0')
		     break;	/* abort loop on error */
	       }		/* if */
	     start++;		/* skip non-alphapetic character (or closing quote of a string) */
	  }			/* while */
	if (*start == '\0')
	   break;		/* abort loop on error */
	/* get the prefix (length), look for a matching definition */
	prefixlen = 0;
	end = start;
	while (isalpha(*end) || isdigit(*end) || *end == '_')
	  {
	     prefixlen++;
	     end++;
	  }			/* while */
	assert(prefixlen > 0);
	subst = find_subst(start, prefixlen);
	if (subst != NULL)
	  {
	     /* properly match the pattern and substitute */
	     if (!substpattern
		 (start, buffersize - (start - line), subst->first,
		  subst->second))
		start = end;	/* match failed, skip this prefix */
	     /* match succeeded: do not update "start", because the substitution text
	      * may be matched by other macros
	      */
	  }
	else
	  {
	     start = end;	/* no macro with this prefix, skip this prefix */
	  }			/* if */
     }				/* while */
}
#endif

/*  preprocess
 *
 *  Reads a line by readline() into "pline" and performs basic preprocessing:
 *  deleting comments, skipping lines with false "#if.." code and recognizing
 *  other compiler directives. There is an indirect recursion: lex() calls
 *  preprocess() if a new line must be read, preprocess() calls command(),
 *  which at his turn calls lex() to identify the token.
 *
 *  Global references: lptr     (altered)
 *                     pline    (altered)
 *                     freading (referred to only)
 */
SC_FUNC void
preprocess(void)
{
   int                 iscommand;

   if (!freading)
      return;
   do
     {
	readline(pline);
	stripcom(pline);	/* ??? no need for this when reading back from list file (in the second pass) */
	lptr = pline;		/* set "line pointer" to start of the parsing buffer */
	iscommand = command();
	if (iscommand != CMD_NONE)
	   errorset(sRESET);	/* reset error flag ("panic mode") on empty line or directive */
#if !defined NO_DEFINE
	if (iscommand == CMD_NONE)
	  {
	     assert(lptr != term_expr);
	     substallpatterns(pline, sLINEMAX);
	     lptr = pline;	/* reset "line pointer" to start of the parsing buffer */
	  }			/* if */
#endif
	if (sc_status == statFIRST && sc_listing && freading
	    && (iscommand == CMD_NONE || iscommand == CMD_EMPTYLINE
		|| iscommand == CMD_DIRECTIVE))
	  {
	     listline++;
	     if (fline != listline)
	       {
		  listline = fline;
		  setlinedirect(fline);
	       }		/* if */
	     if (iscommand == CMD_EMPTYLINE)
		fputs("\n", outf);
	     else
		fputs(pline, outf);
	  }			/* if */
     }
   while (iscommand != CMD_NONE && iscommand != CMD_TERM && freading);	/* enddo */
}

static char        *
unpackedstring(char *lptr, int rawstring)
{
   while (*lptr != '\"' && *lptr != '\0')
     {
	if (*lptr == '\a')
	  {			/* ignore '\a' (which was inserted at a line concatenation) */
	     lptr++;
	     continue;
	  }			/* if */
	stowlit(litchar(&lptr, rawstring));	/* litchar() alters "lptr" */
     }				/* while */
   stowlit(0);			/* terminate string */
   return lptr;
}

static char        *
packedstring(char *lptr, int rawstring)
{
   int                 i;
   ucell               val, c;

   i = sizeof(ucell) - (charbits / 8);	/* start at most significant byte */
   val = 0;
   while (*lptr != '\"' && *lptr != '\0')
     {
	if (*lptr == '\a')
	  {			/* ignore '\a' (which was inserted at a line concatenation) */
	     lptr++;
	     continue;
	  }			/* if */
	c = litchar(&lptr, rawstring);	/* litchar() alters "lptr" */
	if (c >= (ucell) (1 << charbits))
	   error(43);		/* character constant exceeds range */
	val |= (c << 8 * i);
	if (i == 0)
	  {
	     stowlit(val);
	     val = 0;
	  }			/* if */
	i = (i + sizeof(ucell) - (charbits / 8)) % sizeof(ucell);
     }				/* if */
   /* save last code; make sure there is at least one terminating zero character */
   if (i != (int)(sizeof(ucell) - (charbits / 8)))
      stowlit(val);		/* at least one zero character in "val" */
   else
      stowlit(0);		/* add full cell of zeros */
   return lptr;
}

/*  lex(lexvalue,lexsym)        Lexical Analysis
 *
 *  lex() first deletes leading white space, then checks for multi-character
 *  operators, keywords (including most compiler directives), numbers,
 *  labels, symbols and literals (literal characters are converted to a number
 *  and are returned as such). If every check fails, the line must contain
 *  a single-character operator. So, lex() returns this character. In the other
 *  case (something did match), lex() returns the number of the token. All
 *  these tokens have been assigned numbers above 255.
 *
 *  Some tokens have "attributes":
 *     tNUMBER        the value of the number is return in "lexvalue".
 *     tRATIONAL      the value is in IEEE 754 encoding or in fixed point
 *                    encoding in "lexvalue".
 *     tSYMBOL        the first sNAMEMAX characters of the symbol are
 *                    stored in a buffer, a pointer to this buffer is
 *                    returned in "lexsym".
 *     tLABEL         the first sNAMEMAX characters of the label are
 *                    stored in a buffer, a pointer to this buffer is
 *                    returned in "lexsym".
 *     tSTRING        the string is stored in the literal pool, the index
 *                    in the literal pool to this string is stored in
 *                    "lexvalue".
 *
 *  lex() stores all information (the token found and possibly its attribute)
 *  in global variables. This allows a token to be examined twice. If "_pushed"
 *  is true, this information is returned.
 *
 *  Global references: lptr          (altered)
 *                     fline         (referred to only)
 *                     litidx        (referred to only)
 *                     _lextok, _lexval, _lexstr
 *                     _pushed
 */

static int          _pushed;
static int          _lextok;
static cell         _lexval;
static char         _lexstr[sLINEMAX + 1];
static int          _lexnewline;

SC_FUNC void
lexinit(void)
{
   stkidx = 0;			/* index for pushstk() and popstk() */
   iflevel = 0;			/* preprocessor: nesting of "#if" */
   skiplevel = 0;		/* preprocessor: skipping lines or compiling lines */
   icomment = FALSE;		/* currently not in a multiline comment */
   _pushed = FALSE;		/* no token pushed back into lex */
   _lexnewline = FALSE;
}

char               *sc_tokens[] = {
   "*=", "/=", "%=", "+=", "-=", "<<=", ">>>=", ">>=", "&=", "^=", "|=",
   "||", "&&", "==", "!=", "<=", ">=", "<<", ">>>", ">>", "++", "--",
   "...", "..",
   "assert", "break", "case", "char", "const", "continue", "default",
   "defined", "do", "else", "enum", "exit", "for", "forward", "goto",
   "if", "native", "new", "operator", "public", "return", "sizeof",
   "sleep", "static", "stock", "switch", "tagof", "while",
   "#assert", "#define", "#else", "#emit", "#endif", "#endinput",
   "#endscript", "#file", "#if", "#include", "#line", "#pragma", "#undef",
   ";", ";", "-integer value-", "-rational value-", "-identifier-",
   "-label-", "-string-"
};

SC_FUNC int
lex(cell * lexvalue, char **lexsym)
{
   int                 i, toolong, newline, rawstring;
   char              **tokptr;

   if (_pushed)
     {
	_pushed = FALSE;	/* reset "_pushed" flag */
	*lexvalue = _lexval;
	*lexsym = _lexstr;
	return _lextok;
     }				/* if */

   _lextok = 0;			/* preset all values */
   _lexval = 0;
   _lexstr[0] = '\0';
   *lexvalue = _lexval;
   *lexsym = _lexstr;
   _lexnewline = FALSE;
   if (!freading)
      return 0;

   newline = (lptr == pline);	/* does lptr point to start of line buffer */
   while (*lptr <= ' ')
     {				/* delete leading white space */
	if (*lptr == '\0')
	  {
	     preprocess();	/* preprocess resets "lptr" */
	     if (!freading)
		return 0;
	     if (lptr == term_expr)	/* special sequence to terminate a pending expression */
		return (_lextok = tENDEXPR);
	     _lexnewline = TRUE;	/* set this after preprocess(), because
					 * preprocess() calls lex() recursively */
	     newline = TRUE;
	  }
	else
	  {
	     lptr += 1;
	  }			/* if */
     }				/* while */
   if (newline)
     {
	stmtindent = 0;
	for (i = 0; i < (int)(lptr - pline); i++)
	   if (pline[i] == '\t' && sc_tabsize > 0)
	      stmtindent +=
		 (int)(sc_tabsize - (stmtindent + sc_tabsize) % sc_tabsize);
	   else
	      stmtindent++;
     }				/* if */

   i = tFIRST;
   tokptr = sc_tokens;
   while (i <= tMIDDLE)
     {				/* match multi-character operators */
	if (match(*tokptr, FALSE))
	  {
	     _lextok = i;
	     return _lextok;
	  }			/* if */
	i += 1;
	tokptr += 1;
     }				/* while */
   while (i <= tLAST)
     {				/* match reserved words and compiler directives */
	if (match(*tokptr, TRUE))
	  {
	     _lextok = i;
	     errorset(sRESET);	/* reset error flag (clear the "panic mode") */
	     return _lextok;
	  }			/* if */
	i += 1;
	tokptr += 1;
     }				/* while */

   if ((i = number(&_lexval, lptr)) != 0)
     {				/* number */
	_lextok = tNUMBER;
	*lexvalue = _lexval;
	lptr += i;
     }
   else if ((i = ftoi(&_lexval, lptr)) != 0)
     {
	_lextok = tRATIONAL;
	*lexvalue = _lexval;
	lptr += i;
     }
   else if (alpha(*lptr))
     {				/* symbol or label */
	/*  Note: only sNAMEMAX characters are significant. The compiler
	 *        generates a warning if a symbol exceeds this length.
	 */
	_lextok = tSYMBOL;
	i = 0;
	toolong = 0;
	while (alphanum(*lptr))
	  {
	     _lexstr[i] = *lptr;
	     lptr += 1;
	     if (i < sNAMEMAX)
		i += 1;
	     else
		toolong = 1;
	  }			/* while */
	_lexstr[i] = '\0';
	if (toolong)
	   error(200, _lexstr, sNAMEMAX);	/* symbol too long, truncated to sNAMEMAX chars */
	if (_lexstr[0] == PUBLIC_CHAR && _lexstr[1] == '\0')
	  {
	     _lextok = PUBLIC_CHAR;	/* '@' all alone is not a symbol, it is an operator */
	  }
	else if (_lexstr[0] == '_' && _lexstr[1] == '\0')
	  {
	     _lextok = '_';	/* '_' by itself is not a symbol, it is a placeholder */
	  }			/* if */
	if (*lptr == ':' && sc_allowtags && _lextok != PUBLIC_CHAR)
	  {
	     _lextok = tLABEL;	/* it wasn't a normal symbol, it was a label/tagname */
	     lptr += 1;		/* skip colon */
	  }			/* if */
     }
   else if (*lptr == '\"' || *lptr == sc_ctrlchar && *(lptr + 1) == '\"')
     {				/* unpacked string literal */
	_lextok = tSTRING;
	rawstring = (*lptr == sc_ctrlchar);
	*lexvalue = _lexval = litidx;
	lptr += 1;		/* skip double quote */
	if (rawstring)
	   lptr += 1;		/* skip "escape" character too */
	lptr =
	   sc_packstr ? packedstring(lptr, rawstring) : unpackedstring(lptr,
								       rawstring);
	if (*lptr == '\"')
	   lptr += 1;		/* skip final quote */
	else
	   error(37);		/* invalid (non-terminated) string */
     }
   else if (*lptr == '!' && *(lptr + 1) == '\"'
	    || *lptr == '!' && *(lptr + 1) == sc_ctrlchar && *(lptr + 2) == '\"'
	    || *lptr == sc_ctrlchar && *(lptr + 1) == '!'
	    && *(lptr + 2) == '\"')
     {				/* packed string literal */
	_lextok = tSTRING;
	rawstring = (*lptr == sc_ctrlchar || *(lptr + 1) == sc_ctrlchar);
	*lexvalue = _lexval = litidx;
	lptr += 2;		/* skip exclamation point and double quote */
	if (rawstring)
	   lptr += 1;		/* skip "escape" character too */
	lptr =
	   sc_packstr ? unpackedstring(lptr, rawstring) : packedstring(lptr,
								       rawstring);
	if (*lptr == '\"')
	   lptr += 1;		/* skip final quote */
	else
	   error(37);		/* invalid (non-terminated) string */
     }
   else if (*lptr == '\'')
     {				/* character literal */
	lptr += 1;		/* skip quote */
	_lextok = tNUMBER;
	*lexvalue = _lexval = litchar(&lptr, FALSE);
	if (*lptr == '\'')
	   lptr += 1;		/* skip final quote */
	else
	   error(27);		/* invalid character constant (must be one character) */
     }
   else if (*lptr == ';')
     {				/* semicolumn resets "error" flag */
	_lextok = ';';
	lptr += 1;
	errorset(sRESET);	/* reset error flag (clear the "panic mode") */
     }
   else
     {
	_lextok = *lptr;	/* if every match fails, return the character */
	lptr += 1;		/* increase the "lptr" pointer */
     }				/* if */
   return _lextok;
}

/*  lexpush
 *
 *  Pushes a token back, so the next call to lex() will return the token
 *  last examined, instead of a new token.
 *
 *  Only one token can be pushed back.
 *
 *  In fact, lex() already stores the information it finds into global
 *  variables, so all that is to be done is set a flag that informs lex()
 *  to read and return the information from these variables, rather than
 *  to read in a new token from the input file.
 */
SC_FUNC void
lexpush(void)
{
   assert(_pushed == FALSE);
   _pushed = TRUE;
}

/*  lexclr
 *
 *  Sets the variable "_pushed" to 0 to make sure lex() will read in a new
 *  symbol (a not continue with some old one). This is required upon return
 *  from Assembler mode.
 */
SC_FUNC void
lexclr(int clreol)
{
   _pushed = FALSE;
   if (clreol)
     {
	lptr = strchr(pline, '\0');
	assert(lptr != NULL);
     }				/* if */
}

/*  matchtoken
 *
 *  This routine is useful if only a simple check is needed. If the token
 *  differs from the one expected, it is pushed back.
 */
SC_FUNC int
matchtoken(int token)
{
   cell                val;
   char               *str;
   int                 tok;

   tok = lex(&val, &str);
   if (tok == token || token == tTERM && (tok == ';' || tok == tENDEXPR))
     {
	return 1;
     }
   else if (!sc_needsemicolon && token == tTERM && (_lexnewline || !freading))
     {
	lexpush();		/* push "tok" back, we use the "hidden" newline token */
	return 1;
     }
   else
     {
	lexpush();
	return 0;
     }				/* if */
}

/*  tokeninfo
 *
 *  Returns additional information of a token after using "matchtoken()"
 *  or needtoken(). It does no harm using this routine after a call to
 *  "lex()", but lex() already returns the same information.
 *
 *  The token itself is the return value. Normally, this one is already known.
 */
SC_FUNC int
tokeninfo(cell * val, char **str)
{
   /* if the token was pushed back, tokeninfo() returns the token and
    * parameters of the *next* token, not of the *current* token.
    */
   assert(!_pushed);
   *val = _lexval;
   *str = _lexstr;
   return _lextok;
}

/*  needtoken
 *
 *  This routine checks for a required token and gives an error message if
 *  it isn't there (and returns FALSE in that case).
 *
 *  Global references: _lextok;
 */
SC_FUNC int
needtoken(int token)
{
   char                s1[20], s2[20];

   if (matchtoken(token))
     {
	return TRUE;
     }
   else
     {
	/* token already pushed back */
	assert(_pushed);
	if (token < 256)
	   sprintf(s1, "%c", (char)token);	/* single character token */
	else
	   strcpy(s1, sc_tokens[token - tFIRST]);	/* multi-character symbol */
	if (!freading)
	   strcpy(s2, "-end of file-");
	else if (_lextok < 256)
	   sprintf(s2, "%c", (char)_lextok);
	else
	   strcpy(s2, sc_tokens[_lextok - tFIRST]);
	error(1, s1, s2);	/* expected ..., but found ... */
	return FALSE;
     }				/* if */
}

/*  match
 *
 *  Compares a series of characters from the input file with the characters
 *  in "st" (that contains a token). If the token on the input file matches
 *  "st", the input file pointer "lptr" is adjusted to point to the next
 *  token, otherwise "lptr" remains unaltered.
 *
 *  If the parameter "end: is true, match() requires that the first character
 *  behind the recognized token is non-alphanumeric.
 *
 *  Global references: lptr   (altered)
 */
static int
match(char *st, int end)
{
   int                 k;
   char               *ptr;

   k = 0;
   ptr = lptr;
   while (st[k])
     {
	if (st[k] != *ptr)
	   return 0;
	k += 1;
	ptr += 1;
     }				/* while */
   if (end)
     {				/* symbol must terminate with non-alphanumeric char */
	if (alphanum(*ptr))
	   return 0;
     }				/* if */
   lptr = ptr;			/* match found, skip symbol */
   return 1;
}

/*  stowlit
 *
 *  Stores a value into the literal queue. The literal queue is used for
 *  literal strings used in functions and for initializing array variables.
 *
 *  Global references: litidx  (altered)
 *                     litq    (altered)
 */
SC_FUNC void
stowlit(cell value)
{
   if (litidx >= litmax)
     {
	cell               *p;

	litmax += sDEF_LITMAX;
	p = (cell *) realloc(litq, litmax * sizeof(cell));
	if (p == NULL)
	   error(102, "literal table");	/* literal table overflow (fatal error) */
	litq = p;
     }				/* if */
   assert(litidx < litmax);
   litq[litidx++] = value;
}

/*  litchar
 *
 *  Return current literal character and increase the pointer to point
 *  just behind this literal character.
 *
 *  Note: standard "escape sequences" are suported, but the backslash may be
 *        replaced by another character; the syntax '\ddd' is supported,
 *        but ddd must be decimal!
 */
static cell
litchar(char **lptr, int rawmode)
{
   cell                c = 0;
   unsigned char      *cptr;

   cptr = (unsigned char *)*lptr;
   if (rawmode || *cptr != sc_ctrlchar)
     {				/* no escape character */
	c = *cptr;
	cptr += 1;
     }
   else
     {
	cptr += 1;
	if (*cptr == sc_ctrlchar)
	  {
	     c = *cptr;		/* \\ == \ (the escape character itself) */
	     cptr += 1;
	  }
	else
	  {
	     switch (*cptr)
	       {
	       case 'a':	/* \a == audible alarm */
		  c = 7;
		  cptr += 1;
		  break;
	       case 'b':	/* \b == backspace */
		  c = 8;
		  cptr += 1;
		  break;
	       case 'e':	/* \e == escape */
		  c = 27;
		  cptr += 1;
		  break;
	       case 'f':	/* \f == form feed */
		  c = 12;
		  cptr += 1;
		  break;
	       case 'n':	/* \n == NewLine character */
		  c = 10;
		  cptr += 1;
		  break;
	       case 'r':	/* \r == carriage return */
		  c = 13;
		  cptr += 1;
		  break;
	       case 't':	/* \t == horizontal TAB */
		  c = 9;
		  cptr += 1;
		  break;
	       case 'v':	/* \v == vertical TAB */
		  c = 11;
		  cptr += 1;
		  break;
	       case '\'':	/* \' == ' (single quote) */
	       case '"':	/* \" == " (single quote) */
	       case '%':	/* \% == % (percent) */
		  c = *cptr;
		  cptr += 1;
		  break;
	       default:
		  if (isdigit(*cptr))
		    {		/* \ddd */
		       c = 0;
		       while (*cptr >= '0' && *cptr <= '9')	/* decimal! */
			  c = c * 10 + *cptr++ - '0';
		       if (*cptr == ';')
			  cptr++;	/* swallow a trailing ';' */
		    }
		  else
		    {
		       error(27);	/* invalid character constant */
		    }		/* if */
	       }		/* switch */
	  }			/* if */
     }				/* if */
   *lptr = (char *)cptr;
   assert(c >= 0 && c < 256);
   return c;
}

/*  alpha
 *
 *  Test if character "c" is alphabetic ("a".."z"), an underscore ("_")
 *  or an "at" sign ("@"). The "@" is an extension to standard C.
 */
static int
alpha(char c)
{
   return (isalpha(c) || c == '_' || c == PUBLIC_CHAR);
}

/*  alphanum
 *
 *  Test if character "c" is alphanumeric ("a".."z", "0".."9", "_" or "@")
 */
SC_FUNC int
alphanum(char c)
{
   return (alpha(c) || isdigit(c));
}

/*  ishex
 *
 *  Test if character "c" is a hexadecimal digit ("0".."9" or "a".."f").
 */
SC_FUNC int
ishex(char c)
{
   return (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A'
							       && c <= 'F');
}

/* The local variable table must be searched backwards, so that the deepest
 * nesting of local variables is searched first. The simplest way to do
 * this is to insert all new items at the head of the list.
 * In the global list, the symbols are kept in sorted order, so that the
 * public functions are written in sorted order.
 */
static symbol      *
add_symbol(symbol * root, symbol * entry, int sort)
{
   symbol             *newsym;

   if (sort)
      while (root->next != NULL && strcmp(entry->name, root->next->name) > 0)
	 root = root->next;

   if ((newsym = (symbol *) malloc(sizeof(symbol))) == NULL)
     {
	error(103);
	return NULL;
     }				/* if */
   memcpy(newsym, entry, sizeof(symbol));
   newsym->next = root->next;
   root->next = newsym;
   return newsym;
}

static void
free_symbol(symbol * sym)
{
   arginfo            *arg;

   /* free all sub-symbol allocated memory blocks, depending on the
    * kind of the symbol
    */
   assert(sym != NULL);
   if (sym->ident == iFUNCTN)
     {
	/* run through the argument list; "default array" arguments
	 * must be freed explicitly; the tag list must also be freed */
	assert(sym->dim.arglist != NULL);
	for (arg = sym->dim.arglist; arg->ident != 0; arg++)
	  {
	     if (arg->ident == iREFARRAY && arg->hasdefault)
		free(arg->defvalue.array.data);
	     else if (arg->ident == iVARIABLE
		      && ((arg->hasdefault & uSIZEOF) != 0
			  || (arg->hasdefault & uTAGOF) != 0))
		free(arg->defvalue.size.symname);
	     assert(arg->tags != NULL);
	     free(arg->tags);
	  }			/* for */
	free(sym->dim.arglist);
     }				/* if */
   assert(sym->refer != NULL);
   free(sym->refer);
   free(sym);
}

SC_FUNC void
delete_symbol(symbol * root, symbol * sym)
{
   /* find the symbol and its predecessor
    * (this function assumes that you will never delete a symbol that is not
    * in the table pointed at by "root")
    */
   assert(root != sym);
   while (root->next != sym)
     {
	root = root->next;
	assert(root != NULL);
     }				/* while */

   /* unlink it, then free it */
   root->next = sym->next;
   free_symbol(sym);
}

SC_FUNC void
delete_symbols(symbol * root, int level, int delete_labels,
	       int delete_functions)
{
   symbol             *sym;

   /* erase only the symbols with a deeper nesting level than the
    * specified nesting level */
   while (root->next != NULL)
     {
	sym = root->next;
	if (sym->compound < level)
	   break;
	if ((delete_labels || sym->ident != iLABEL)
	    && (delete_functions || sym->ident != iFUNCTN
		|| (sym->usage & uNATIVE) != 0) && (delete_functions
						    || sym->ident != iCONSTEXPR
						    || (sym->usage & uPREDEF) ==
						    0) && (delete_functions
							   || (sym->ident !=
							       iVARIABLE
							       && sym->ident !=
							       iARRAY)))
	  {
	     root->next = sym->next;
	     free_symbol(sym);
	  }
	else
	  {
	     /* if the function was prototyped, but not implemented in this source,
	      * mark it as such, so that its use can be flagged
	      */
	     if (sym->ident == iFUNCTN && (sym->usage & uDEFINE) == 0)
		sym->usage |= uMISSING;
	     if (sym->ident == iFUNCTN || sym->ident == iVARIABLE
		 || sym->ident == iARRAY)
		sym->usage &= ~uDEFINE;	/* clear "defined" flag */
	     /* for user defined operators, also remove the "prototyped" flag, as
	      * user-defined operators *must* be declared before use
	      */
	     if (sym->ident == iFUNCTN && !isalpha(*sym->name)
		 && *sym->name != '_' && *sym->name != PUBLIC_CHAR)
		sym->usage &= ~uPROTOTYPED;
	     root = sym;	/* skip the symbol */
	  }			/* if */
     }				/* if */
}

/* The purpose of the hash is to reduce the frequency of a "name"
 * comparison (which is costly). There is little interest in avoiding
 * clusters in similar names, which is why this function is plain simple.
 */
SC_FUNC uint32_t
namehash(char *name)
{
   unsigned char      *ptr = (unsigned char *)name;
   int                 len = strlen(name);

   if (len == 0)
      return 0L;
   assert(len < 256);
   return (len << 24Lu) + (ptr[0] << 16Lu) + (ptr[len - 1] << 8Lu) +
      (ptr[len >> 1Lu]);
}

static symbol      *
find_symbol(symbol * root, char *name, int fnumber)
{
   symbol             *ptr = root->next;
   unsigned long       hash = namehash(name);

   while (ptr != NULL)
     {
	if (hash == ptr->hash && strcmp(name, ptr->name) == 0
	    && ptr->parent == NULL && (ptr->fnumber < 0
				       || ptr->fnumber == fnumber))
	   return ptr;
	ptr = ptr->next;
     }				/* while */
   return NULL;
}

static symbol      *
find_symbol_child(symbol * root, symbol * sym)
{
   symbol             *ptr = root->next;

   while (ptr != NULL)
     {
	if (ptr->parent == sym)
	   return ptr;
	ptr = ptr->next;
     }				/* while */
   return NULL;
}

/* Adds "bywhom" to the list of referrers of "entry". Typically,
 * bywhom will be the function that uses a variable or that calls
 * the function.
 */
SC_FUNC int
refer_symbol(symbol * entry, symbol * bywhom)
{
   int                 count;

   assert(bywhom != NULL);	/* it makes no sense to add a "void" referrer */
   assert(entry != NULL);
   assert(entry->refer != NULL);

   /* see if it is already there */
   for (count = 0; count < entry->numrefers && entry->refer[count] != bywhom;
	count++)
      /* nothing */ ;
   if (count < entry->numrefers)
     {
	assert(entry->refer[count] == bywhom);
	return TRUE;
     }				/* if */

   /* see if there is an empty spot in the referrer list */
   for (count = 0; count < entry->numrefers && entry->refer[count] != NULL;
	count++)
      /* nothing */ ;
   assert(count <= entry->numrefers);
   if (count == entry->numrefers)
     {
	symbol            **refer;
	int                 newsize = 2 * entry->numrefers;

	assert(newsize > 0);
	/* grow the referrer list */
	refer = (symbol **) realloc(entry->refer, newsize * sizeof(symbol *));
	if (refer == NULL)
	   return FALSE;	/* insufficient memory */
	/* initialize the new entries */
	entry->refer = refer;
	for (count = entry->numrefers; count < newsize; count++)
	   entry->refer[count] = NULL;
	count = entry->numrefers;	/* first empty spot */
	entry->numrefers = newsize;
     }				/* if */

   /* add the referrer */
   assert(entry->refer[count] == NULL);
   entry->refer[count] = bywhom;
   return TRUE;
}

SC_FUNC void
markusage(symbol * sym, int usage)
{
   sym->usage |= (char)usage;
   /* check if (global) reference must be added to the symbol */
   if ((usage & (uREAD | uWRITTEN)) != 0)
     {
	/* only do this for global symbols */
	if (sym->vclass == sGLOBAL)
	  {
	     /* "curfunc" should always be valid, since statements may not occurs
	      * outside functions; in the case of syntax errors, however, the
	      * compiler may arrive through this function
	      */
	     if (curfunc != NULL)
		refer_symbol(sym, curfunc);
	  }			/* if */
     }				/* if */
}

/*  findglb
 *
 *  Returns a pointer to the global symbol (if found) or NULL (if not found)
 */
SC_FUNC symbol     *
findglb(char *name)
{
   return find_symbol(&glbtab, name, fcurrent);
}

/*  findloc
 *
 *  Returns a pointer to the local symbol (if found) or NULL (if not found).
 *  See add_symbol() how the deepest nesting level is searched first.
 */
SC_FUNC symbol     *
findloc(char *name)
{
   return find_symbol(&loctab, name, -1);
}

SC_FUNC symbol     *
findconst(char *name)
{
   symbol             *sym;

   sym = find_symbol(&loctab, name, -1);	/* try local symbols first */
   if (sym == NULL || sym->ident != iCONSTEXPR)	/* not found, or not a constant */
      sym = find_symbol(&glbtab, name, fcurrent);
   if (sym == NULL || sym->ident != iCONSTEXPR)
      return NULL;
   assert(sym->parent == NULL);	/* constants have no hierarchy */
   return sym;
}

SC_FUNC symbol     *
finddepend(symbol * parent)
{
   symbol             *sym;

   sym = find_symbol_child(&loctab, parent);	/* try local symbols first */
   if (sym == NULL)		/* not found */
      sym = find_symbol_child(&glbtab, parent);
   return sym;
}

/*  addsym
 *
 *  Adds a symbol to the symbol table (either global or local variables,
 *  or global and local constants).
 */
SC_FUNC symbol     *
addsym(char *name, cell addr, int ident, int vclass, int tag, int usage)
{
   symbol              entry, **refer;

   /* global variables/constants/functions may only be defined once */
   assert(!(ident == iFUNCTN || ident == iCONSTEXPR) || vclass != sGLOBAL
	  || findglb(name) == NULL);
   /* labels may only be defined once */
   assert(ident != iLABEL || findloc(name) == NULL);

   /* create an empty referrer list */
   if ((refer = (symbol **) malloc(sizeof(symbol *))) == NULL)
     {
	error(103);		/* insufficient memory */
	return NULL;
     }				/* if */
   *refer = NULL;

   /* first fill in the entry */
   strcpy(entry.name, name);
   entry.hash = namehash(name);
   entry.addr = addr;
   entry.vclass = (char)vclass;
   entry.ident = (char)ident;
   entry.tag = tag;
   entry.usage = (char)usage;
   entry.compound = 0;		/* may be overridden later */
   entry.fnumber = -1;		/* assume global visibility (ignored for local symbols) */
   entry.numrefers = 1;
   entry.refer = refer;
   entry.parent = NULL;

   /* then insert it in the list */
   if (vclass == sGLOBAL)
      return add_symbol(&glbtab, &entry, TRUE);
   else
      return add_symbol(&loctab, &entry, FALSE);
}

SC_FUNC symbol     *
addvariable(char *name, cell addr, int ident, int vclass, int tag,
	    int dim[], int numdim, int idxtag[])
{
   symbol             *sym, *parent, *top;
   int                 level;

   /* global variables may only be defined once */
   assert(vclass != sGLOBAL || (sym = findglb(name)) == NULL
	  || (sym->usage & uDEFINE) == 0);

   if (ident == iARRAY || ident == iREFARRAY)
     {
	parent = NULL;
	sym = NULL;		/* to avoid a compiler warning */
	for (level = 0; level < numdim; level++)
	  {
	     top = addsym(name, addr, ident, vclass, tag, uDEFINE);
	     top->dim.array.length = dim[level];
	     top->dim.array.level = (short)(numdim - level - 1);
	     top->x.idxtag = idxtag[level];
	     top->parent = parent;
	     parent = top;
	     if (level == 0)
		sym = top;
	  }			/* for */
     }
   else
     {
	sym = addsym(name, addr, ident, vclass, tag, uDEFINE);
     }				/* if */
   return sym;
}

/*  getlabel
 *
 *  Return next available internal label number.
 */
SC_FUNC int
getlabel(void)
{
   return labnum++;
}

/*  itoh
 *
 *  Converts a number to a hexadecimal string and returns a pointer to that
 *  string.
 */
SC_FUNC char       *
itoh(ucell val)
{
   static char         itohstr[15];	/* hex number is 10 characters long at most */
   char               *ptr;
   int                 i, nibble[8];	/* a 32-bit hexadecimal cell has 8 nibbles */
   int                 max;

#if defined(BIT16)
   max = 4;
#else
   max = 8;
#endif
   ptr = itohstr;
   for (i = 0; i < max; i += 1)
     {
	nibble[i] = (int)(val & 0x0f);	/* nibble 0 is lowest nibble */
	val >>= 4;
     }				/* endfor */
   i = max - 1;
   while (nibble[i] == 0 && i > 0)	/* search for highest non-zero nibble */
      i -= 1;
   while (i >= 0)
     {
	if (nibble[i] >= 10)
	   *ptr++ = (char)('a' + (nibble[i] - 10));
	else
	   *ptr++ = (char)('0' + nibble[i]);
	i -= 1;
     }				/* while */
   *ptr = '\0';			/* and a zero-terminator */
   return itohstr;
}