path: root/src/bin/embryo/embryo_cc_sc1.c

/*  Small compiler
 *  Function and variable definition and declaration, statement 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$
 */


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

#include <assert.h>
#include <ctype.h>
#include <limits.h>
#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <sys/stat.h>

#ifdef HAVE_EVIL
# include <Evil.h>
#endif

#include <Eina.h>

#include "embryo_cc_sc.h"
#include "embryo_cc_prefix.h"

#define VERSION_STR "2.4"
#define VERSION_INT 240

static void         resetglobals(void);
static void         initglobals(void);
static void         setopt(int argc, char **argv,
                           char *iname, char *oname,
                           char *pname, char *rname);
static void         setconfig(char *root);
static void         about(void);
static void         setconstants(void);
static void         parse(void);
static void         dumplits(void);
static void         dumpzero(int count);
static void         declfuncvar(int tok, char *symname,
				int tag, int fpublic,
				int fstatic, int fstock, int fconst);
static void         declglb(char *firstname, int firsttag,
			    int fpublic, int fstatic, int stock, int fconst);
static int          declloc(int fstatic);
static void         decl_const(int table);
static void         decl_enum(int table);
static cell         needsub(int *tag);
static void         initials(int ident, int tag,
			     cell * size, int dim[], int numdim);
static cell         initvector(int ident, int tag, cell size, int fillzero);
static cell         init(int ident, int *tag);
static void         funcstub(int native);
static int          newfunc(char *firstname, int firsttag,
			    int fpublic, int fstatic, int stock);
static int          declargs(symbol * sym);
static void         doarg(char *name, int ident, int offset,
			  int tags[], int numtags,
			  int fpublic, int fconst, arginfo * arg);
static void         reduce_referrers(symbol * root);
static int          testsymbols(symbol * root, int level,
				int testlabs, int testconst);
static void         destructsymbols(symbol * root, int level);
static constvalue  *find_constval_byval(constvalue * table, cell val);
static void         statement(int *lastindent, int allow_decl);
static void         compound(void);
static void         doexpr(int comma, int chkeffect,
			   int allowarray, int mark_endexpr,
			   int *tag, int chkfuncresult);
static void         doassert(void);
static void         doexit(void);
static void         test(int label, int parens, int invert);
static void         doif(void);
static void         dowhile(void);
static void         dodo(void);
static void         dofor(void);
static void         doswitch(void);
static void         dogoto(void);
static void         dolabel(void);
static symbol      *fetchlab(char *name);
static void         doreturn(void);
static void         dobreak(void);
static void         docont(void);
static void         dosleep(void);
static void         addwhile(int *ptr);
static void         delwhile(void);
static int         *readwhile(void);

static int          lastst = 0;	/* last executed statement type */
static int          nestlevel = 0;	/* number of active (open) compound statements */
static int          rettype = 0;	/* the type that a "return" expression should have */
static int          skipinput = 0;	/* number of lines to skip from the first input file */
static int          wq[wqTABSZ];	/* "while queue", internal stack for nested loops */
static int         *wqptr;	/* pointer to next entry */
static char         binfname[PATH_MAX];	/* binary file name */

int
main(int argc, char *argv[], char *env[] EINA_UNUSED)
{
   e_prefix_determine(argv[0]);
   return sc_compile(argc, argv);
}

int
sc_error(int number, char *message, char *filename, int firstline,
	 int lastline, va_list argptr)
{
   static char        *prefix[3] = { "error", "fatal error", "warning" };

   if (number != 0)
     {
	char               *pre;

	pre = prefix[number / 100];
	if (firstline >= 0)
	   fprintf(stderr, "%s(%d -- %d) : %s %03d: ", filename, firstline,
		   lastline, pre, number);
	else
	   fprintf(stderr, "%s(%d) : %s %03d: ", filename, lastline, pre,
		   number);
     }				/* if */
   vfprintf(stderr, message, argptr);
   fflush(stderr);
   return 0;
}

void               *
sc_opensrc(char *filename)
{
   return fopen(filename, "rb");
}

void
sc_closesrc(void *handle)
{
   assert(handle != NULL);
   fclose((FILE *) handle);
}

void
sc_resetsrc(void *handle, void *position)
{
   assert(handle != NULL);
   if (fsetpos((FILE *) handle, (fpos_t *) position) != 0)
     fprintf(stderr, "embryo_xx - ERR - fsetpos()\n");
}

char               *
sc_readsrc(void *handle, char *target, int maxchars)
{
   return fgets(target, maxchars, (FILE *) handle);
}

void               *
sc_getpossrc(void *handle)
{
   static fpos_t       lastpos;	/* may need to have a LIFO stack of
				 * such positions */

   if (fgetpos((FILE *) handle, &lastpos) != 0)
     fprintf(stderr, "embryo_xx - ERR - fgetpos()\n");
   return &lastpos;
}

int
sc_eofsrc(void *handle)
{
   return feof((FILE *) handle);
}

void               *
sc_openasm(int fd)
{
   return fdopen(fd, "wb+");
}

void
sc_closeasm(void *handle)
{
   if (handle)
      fclose((FILE *) handle);
}

void
sc_resetasm(void *handle)
{
   fflush((FILE *) handle);
   fseek((FILE *) handle, 0, SEEK_SET);
}

int
sc_writeasm(void *handle, char *st)
{
   return fputs(st, (FILE *) handle) >= 0;
}

char               *
sc_readasm(void *handle, char *target, int maxchars)
{
   return fgets(target, maxchars, (FILE *) handle);
}

void               *
sc_openbin(char *filename)
{
   return fopen(filename, "wb");
}

void
sc_closebin(void *handle, int deletefile)
{
   fclose((FILE *) handle);
   if (deletefile)
      unlink(binfname);
}

void
sc_resetbin(void *handle)
{
   fflush((FILE *) handle);
   fseek((FILE *) handle, 0, SEEK_SET);
}

int
sc_writebin(void *handle, void *buffer, int size)
{
   return (int)fwrite(buffer, 1, size, (FILE *) handle) == size;
}

long
sc_lengthbin(void *handle)
{
   return ftell((FILE *) handle);
}

/*  "main" of the compiler
 */
int
sc_compile(int argc, char *argv[])
{
   int                 entry, i, jmpcode, fd_out;
   int                 retcode;
   char                incfname[PATH_MAX];
   char                reportname[PATH_MAX];
   FILE               *binf;
   void               *inpfmark;
   char                lcl_ctrlchar;
   int                 lcl_packstr, lcl_needsemicolon, lcl_tabsize;
   Eina_Tmpstr        *outfname;

   /* set global variables to their initial value */
   binf = NULL;
   initglobals();
   errorset(sRESET);
   errorset(sEXPRRELEASE);
   lexinit();

   /* make sure that we clean up on a fatal error; do this before the
    * first call to error(). */
   if ((jmpcode = setjmp(errbuf)) != 0)
      goto cleanup;

   /* allocate memory for fixed tables */
   inpfname = (char *)malloc(PATH_MAX);
   litq = (cell *) malloc(litmax * sizeof(cell));
   if (!litq)
      error(103);		/* insufficient memory */
   if (!phopt_init())
      error(103);		/* insufficient memory */

   setopt(argc, argv, inpfname, binfname, incfname, reportname);

   /* open the output file */
   fd_out = eina_file_mkstemp("embryo_cc.asm-tmp-XXXXXX", &outfname);
   if (fd_out < 0)
     error(101, outfname);

   setconfig(argv[0]);		/* the path to the include files */
   lcl_ctrlchar = sc_ctrlchar;
   lcl_packstr = sc_packstr;
   lcl_needsemicolon = sc_needsemicolon;
   lcl_tabsize = sc_tabsize;
   inpf = inpf_org = (FILE *) sc_opensrc(inpfname);
   if (!inpf)
      error(100, inpfname);
   freading = TRUE;
   outf = (FILE *) sc_openasm(fd_out);	/* first write to assembler
						 * file (may be temporary) */
   if (!outf)
      error(101, outfname);
   /* immediately open the binary file, for other programs to check */
   binf = (FILE *) sc_openbin(binfname);
   if (!binf)
     error(101, binfname);
   setconstants();		/* set predefined constants and tagnames */
   for (i = 0; i < skipinput; i++)	/* skip lines in the input file */
      if (sc_readsrc(inpf, pline, sLINEMAX))
	 fline++;		/* keep line number up to date */
   skipinput = fline;
   sc_status = statFIRST;
   /* do the first pass through the file */
   inpfmark = sc_getpossrc(inpf);
   if (incfname[0] != '\0')
     {
	if (strcmp(incfname, sDEF_PREFIX) == 0)
	  {
	     plungefile(incfname, FALSE, TRUE);	/* parse "default.inc" */
	  }
	else
	  {
	     if (!plungequalifiedfile(incfname))	/* parse "prefix" include
							 * file */
		error(100, incfname);	/* cannot read from ... (fatal error) */
	  }			/* if */
     }				/* if */
   preprocess();		/* fetch first line */
   parse();			/* process all input */

   /* second pass */
   sc_status = statWRITE;	/* set, to enable warnings */

   /* ??? for re-parsing the listing file instead of the original source
    * file (and doing preprocessing twice):
    * - close input file, close listing file
    * - re-open listing file for reading (inpf)
    * - open assembler file (outf)
    */

   /* reset "defined" flag of all functions and global variables */
   reduce_referrers(&glbtab);
   delete_symbols(&glbtab, 0, TRUE, FALSE);
#if !defined NO_DEFINE
   delete_substtable();
#endif
   resetglobals();
   sc_ctrlchar = lcl_ctrlchar;
   sc_packstr = lcl_packstr;
   sc_needsemicolon = lcl_needsemicolon;
   sc_tabsize = lcl_tabsize;
   errorset(sRESET);
   /* reset the source file */
   inpf = inpf_org;
   freading = TRUE;
   sc_resetsrc(inpf, inpfmark);	/* reset file position */
   fline = skipinput;		/* reset line number */
   lexinit();			/* clear internal flags of lex() */
   sc_status = statWRITE;	/* allow to write --this variable was reset
				 * by resetglobals() */
   writeleader();
   setfile(inpfname, fnumber);
   if (incfname[0] != '\0')
     {
	if (strcmp(incfname, sDEF_PREFIX) == 0)
	   plungefile(incfname, FALSE, TRUE);	/* parse "default.inc" (again) */
	else
	   plungequalifiedfile(incfname);	/* parse implicit include
						 * file (again) */
     }				/* if */
   preprocess();		/* fetch first line */
   parse();			/* process all input */
   /* inpf is already closed when readline() attempts to pop of a file */
   writetrailer();		/* write remaining stuff */

   entry = testsymbols(&glbtab, 0, TRUE, FALSE);	/* test for unused
							 * or undefined functions and variables */
   if (!entry)
      error(13);		/* no entry point (no public functions) */

 cleanup:
   if (inpf)		/* main source file is not closed, do it now */
      sc_closesrc(inpf);
   /* write the binary file (the file is already open) */
   if (errnum == 0 && jmpcode == 0)
     {
	assert(binf != NULL);
	sc_resetasm(outf);	/* flush and loop back, for reading */
	assemble(binf, outf);	/* assembler file is now input */
     }				/* if */
   if (outf)
      sc_closeasm(outf);
   unlink(outfname);
   eina_tmpstr_del(outfname);
   if (binf)
      sc_closebin(binf, errnum != 0);

   if (inpfname)
      free(inpfname);
   if (litq)
      free(litq);
   phopt_cleanup();
   stgbuffer_cleanup();
   assert(jmpcode != 0 || loctab.next == NULL);	/* on normal flow,
						 * local symbols
						 * should already have been deleted */
   delete_symbols(&loctab, 0, TRUE, TRUE);	/* delete local variables
						 * if not yet  done (i.e.
						 * on a fatal error) */
   delete_symbols(&glbtab, 0, TRUE, TRUE);
   delete_consttable(&tagname_tab);
   delete_consttable(&libname_tab);
   delete_aliastable();
   delete_pathtable();
#if !defined NO_DEFINE
   delete_substtable();
#endif
   if (errnum != 0)
     {
	printf("\n%d Error%s.\n", errnum, (errnum > 1) ? "s" : "");
	retcode = 2;
     }
   else if (warnnum != 0)
     {
	printf("\n%d Warning%s.\n", warnnum, (warnnum > 1) ? "s" : "");
	retcode = 1;
     }
   else
     {
	retcode = jmpcode;
     }				/* if */
   return retcode;
}

int
sc_addconstant(char *name, cell val, int tag)
{
   errorset(sFORCESET);		/* make sure error engine is silenced */
   sc_status = statIDLE;
   add_constant(name, val, sGLOBAL, tag);
   return 1;
}

int
sc_addtag(char *name)
{
   cell                val;
   constvalue         *ptr;
   int                 last, tag;

   if (!name)
     {
	/* no tagname was given, check for one */
	if (lex(&val, &name) != tLABEL)
	  {
	     lexpush();
	     return 0;		/* untagged */
	  }			/* if */
     }				/* if */

   last = 0;
   ptr = tagname_tab.next;
   while (ptr)
     {
	tag = (int)(ptr->value & TAGMASK);
	if (strcmp(name, ptr->name) == 0)
	   return tag;		/* tagname is known, return its sequence number */
	tag &= (int)~FIXEDTAG;
	if (tag > last)
	   last = tag;
	ptr = ptr->next;
     }				/* while */

   /* tagname currently unknown, add it */
   tag = last + 1;		/* guaranteed not to exist already */
   if (sc_isupper(*name))
      tag |= (int)FIXEDTAG;
   append_constval(&tagname_tab, name, (cell) tag, 0);
   return tag;
}

static void
resetglobals(void)
{
   /* reset the subset of global variables that is modified by the
    * first pass */
   curfunc = NULL;		/* pointer to current function */
   lastst = 0;			/* last executed statement type */
   nestlevel = 0;		/* number of active (open) compound statements */
   rettype = 0;			/* the type that a "return" expression should have */
   litidx = 0;			/* index to literal table */
   stgidx = 0;			/* index to the staging buffer */
   labnum = 0;			/* number of (internal) labels */
   staging = 0;			/* true if staging output */
   declared = 0;		/* number of local cells declared */
   glb_declared = 0;		/* number of global cells declared */
   code_idx = 0;		/* number of bytes with generated code */
   ntv_funcid = 0;		/* incremental number of native function */
   curseg = 0;			/* 1 if currently parsing CODE, 2 if parsing DATA */
   freading = FALSE;		/* no input file ready yet */
   fline = 0;			/* the line number in the current file */
   fnumber = 0;			/* the file number in the file table (debugging) */
   fcurrent = 0;		/* current file being processed (debugging) */
   intest = 0;			/* true if inside a test */
   sideeffect = 0;		/* true if an expression causes a side-effect */
   stmtindent = 0;		/* current indent of the statement */
   indent_nowarn = TRUE;	/* do not skip warning "217 loose indentation" */
   sc_allowtags = TRUE;		/* allow/detect tagnames */
   sc_status = statIDLE;
}

static void
initglobals(void)
{
   resetglobals();

   skipinput = 0;		/* number of lines to skip from the first
				 * input file */
   sc_ctrlchar = CTRL_CHAR;	/* the escape character */
   litmax = sDEF_LITMAX;	/* current size of the literal table */
   errnum = 0;			/* number of errors */
   warnnum = 0;			/* number of warnings */
/* sc_debug=sCHKBOUNDS; by default: bounds checking+assertions */
   sc_debug = 0;		/* by default: no debug */
   charbits = 8;		/* a "char" is 8 bits */
   sc_packstr = FALSE;		/* strings are unpacked by default */
/* sc_compress=TRUE;     compress output bytecodes */
   sc_compress = FALSE;		/* compress output bytecodes */
   sc_needsemicolon = FALSE;	/* semicolon required to terminate
				 * expressions? */
   sc_dataalign = 4;
   sc_stksize = sDEF_AMXSTACK;	/* default stack size */
   sc_tabsize = 8;		/* assume a TAB is 8 spaces */
   sc_rationaltag = 0;		/* assume no support for rational numbers */
   rational_digits = 0;		/* number of fractional digits */

   inpf = NULL;			/* file read from */
   inpfname = NULL;		/* pointer to name of the file currently
				 * read from */
   outf = NULL;			/* file written to */
   litq = NULL;			/* the literal queue */
   glbtab.next = NULL;		/* clear global variables/constants table */
   loctab.next = NULL;		/*   "   local      "    /    "       "   */
   tagname_tab.next = NULL;	/* tagname table */
   libname_tab.next = NULL;	/* library table (#pragma library "..."
				 * syntax) */

   pline[0] = '\0';		/* the line read from the input file */
   lptr = NULL;			/* points to the current position in "pline" */
   curlibrary = NULL;		/* current library */
   inpf_org = NULL;		/* main source file */

   wqptr = wq;			/* initialize while queue pointer */

}

static void
parseoptions(int argc, char **argv, char *iname, char *oname,
             char *pname EINA_UNUSED, char *rname EINA_UNUSED)
{
   char str[PATH_MAX];
   int i, stack_size;
   size_t len;

#ifdef NEED_RUN_IN_TREE
   str[0] = '\0';
   if (getenv("EFL_RUN_IN_TREE"))
     {
        struct stat st;
        snprintf(str, sizeof(str), "%s/data/embryo", PACKAGE_SRC_DIR);
        if (stat(str, &st) != 0)
          str[0] = '\0';
     }

   if (str[0] == '\0')
#endif
     snprintf(str, sizeof(str), "%s/include/", e_prefix_data_get());

   /* use embryo include dir always */
   insert_path(str);
   insert_path("./");

   for (i = 1; i < argc; i++)
   {
      if (!strcmp (argv[i], "-i") && (i + 1 < argc) && *argv[i + 1])
      {
	 /* include directory */
	 i++;
	 strncpy(str, argv[i], sizeof(str) - 1);
         str[sizeof(str) - 1] = '\0';

	 len = strlen(str);
	 if (str[len - 1] != DIRSEP_CHAR)
	 {
	    str[len] = DIRSEP_CHAR;
	    str[len + 1] = '\0';
	 }

	 insert_path(str);
      }
      else if (!strcmp (argv[i], "-o") && (i + 1 < argc) && *argv[i + 1])
      {
	 /* output file */
	 i++;
	 strcpy(oname, argv[i]); /* FIXME */
      }
      else if (!strcmp (argv[i], "-S") && (i + 1 < argc) && *argv[i + 1])
      {
	 /* stack size */
	 i++;
	 stack_size = atoi(argv[i]);

	 if (stack_size > 64)
	    sc_stksize = (cell) stack_size;
	 else
	    about();
      }
      else if (!*iname)
      {
	 /* input file */
	 strcpy(iname, argv[i]); /* FIXME */
      }
      else
      {
	 /* only allow one input filename */
	 about();
      }
   }
}

static void
setopt(int argc, char **argv, char *iname, char *oname,
       char *pname, char *rname)
{
   *iname = '\0';
   *oname = '\0';
   *pname = '\0';
   *rname = '\0';
   strcpy(pname, sDEF_PREFIX);

   parseoptions(argc, argv, iname, oname, pname, rname);
   if (iname[0] == '\0')
      about();
}

static void
setconfig(char *root)
{
   char                path[PATH_MAX];
   char               *ptr;
   int                 len;

   path[sizeof(path) - 1] = 0;

   /* add the default "include" directory */
   if (root)
     {
	/* path + filename (hopefully) */
	strncpy(path, root, sizeof(path) - 1);
	path[sizeof(path) - 1] = 0;
     }
/* terminate just behind last \ or : */
   if ((ptr = strrchr(path, DIRSEP_CHAR))
       || (ptr = strchr(path, ':')))
     {
	/* If there was no terminating "\" or ":",
	 * the filename probably does not
	 * contain the path; so we just don't add it
	 * to the list in that case
	 */
	*(ptr + 1) = '\0';
        /* Need room for 'include' and DIRSEP_CHAR - so 8 chars - and \0 */
	if (strlen(path) < (sizeof(path) - 1 - 8))
	  {
	     strcat(path, "include");
	  }

        /* Make sure we have enough space for the trailing DIRSEP_CHAR */
        if (strlen(path) == (sizeof(path) - 1 -1))
          {
             len = strlen(path);
             path[len] = DIRSEP_CHAR;
             path[len + 1] = '\0';
             insert_path(path);
          }
     }				/* if */
}

static void
about(void)
{
   printf("Usage:   embryo_cc <filename> [options]\n\n");
   printf("Options:\n");
#if 0
	printf
	   ("         -A<num>  alignment in bytes of the data segment and the\
     stack\n");

	printf
	   ("         -a       output assembler code (skip code generation\
    pass)\n");

	printf
	   ("         -C[+/-]  compact encoding for output file (default=%c)\n",
	    sc_compress ? '+' : '-');
	printf("         -c8      [default] a character is 8-bits\
     (ASCII/ISO Latin-1)\n");

	printf("         -c16     a character is 16-bits (Unicode)\n");
#if defined dos_setdrive
	printf("         -Dpath   active directory path\n");
#endif
	printf
	   ("         -d0      no symbolic information, no run-time checks\n");
	printf("         -d1      [default] run-time checks, no symbolic\
     information\n");
	printf
	   ("         -d2      full debug information and dynamic checking\n");
	printf("         -d3      full debug information, dynamic checking,\
     no optimization\n");
#endif
	printf("         -i <name> path for include files\n");
#if 0
	printf("         -l       create list file (preprocess only)\n");
#endif
	printf("         -o <name> set base name of output file\n");
#if 0
	printf
	   ("         -P[+/-]  strings are \"packed\" by default (default=%c)\n",
	    sc_packstr ? '+' : '-');
	printf("         -p<name> set name of \"prefix\" file\n");
	if (!waitkey())
	   longjmp(errbuf, 3);
#endif
	printf
	   ("         -S <num>  stack/heap size in cells (default=%d, min=65)\n",
	    (int)sc_stksize);
#if 0
	printf("         -s<num>  skip lines from the input file\n");
	printf
	   ("         -t<num>  TAB indent size (in character positions)\n");
	printf("         -\\       use '\\' for escape characters\n");
	printf("         -^       use '^' for escape characters\n");
	printf("         -;[+/-]  require a semicolon to end each statement\
     (default=%c)\n", sc_needsemicolon ? '+' : '-');

	printf
	   ("         sym=val  define constant \"sym\" with value \"val\"\n");
	printf("         sym=     define constant \"sym\" with value 0\n");
#endif
	longjmp(errbuf, 3);		/* user abort */
}

static void
setconstants(void)
{
   int                 debug;

   assert(sc_status == statIDLE);
   append_constval(&tagname_tab, "_", 0, 0);	/* "untagged" */
   append_constval(&tagname_tab, "bool", 1, 0);

   add_constant("true", 1, sGLOBAL, 1);	/* boolean flags */
   add_constant("false", 0, sGLOBAL, 1);
   add_constant("EOS", 0, sGLOBAL, 0);	/* End Of String, or '\0' */
   add_constant("cellbits", 32, sGLOBAL, 0);
   add_constant("cellmax", INT_MAX, sGLOBAL, 0);
   add_constant("cellmin", INT_MIN, sGLOBAL, 0);
   add_constant("charbits", charbits, sGLOBAL, 0);
   add_constant("charmin", 0, sGLOBAL, 0);
   add_constant("charmax", (charbits == 16) ? 0xffff : 0xff, sGLOBAL, 0);

   add_constant("__Small", VERSION_INT, sGLOBAL, 0);

   debug = 0;
   if ((sc_debug & (sCHKBOUNDS | sSYMBOLIC)) == (sCHKBOUNDS | sSYMBOLIC))
      debug = 2;
   else if ((sc_debug & sCHKBOUNDS) == sCHKBOUNDS)
      debug = 1;
   add_constant("debug", debug, sGLOBAL, 0);
}

/*  parse       - process all input text
 *
 *  At this level, only static declarations and function definitions
 *  are legal.
 */
static void
parse(void)
{
   int                 tok, tag, fconst, fstock, fstatic;
   cell                val;
   char               *str;

   while (freading)
     {
	/* first try whether a declaration possibly is native or public */
	tok = lex(&val, &str);	/* read in (new) token */
	switch (tok)
	  {
	  case 0:
	     /* ignore zero's */
	     break;
	  case tNEW:
	     fconst = matchtoken(tCONST);
	     declglb(NULL, 0, FALSE, FALSE, FALSE, fconst);
	     break;
	  case tSTATIC:
	     /* This can be a static function or a static global variable;
	      * we know which of the two as soon as we have parsed up to the
	      * point where an opening parenthesis of a function would be
	      * expected. To back out after deciding it was a declaration of
	      * a static variable after all, we have to store the symbol name
	      * and tag.
	      */
	     fstock = matchtoken(tSTOCK);
	     fconst = matchtoken(tCONST);
	     tag = sc_addtag(NULL);
	     tok = lex(&val, &str);
	     if (tok == tNATIVE || tok == tPUBLIC)
	       {
		  error(42);	/* invalid combination of class specifiers */
		  break;
	       }		/* if */
	     declfuncvar(tok, str, tag, FALSE, TRUE, fstock, fconst);
	     break;
	  case tCONST:
	     decl_const(sGLOBAL);
	     break;
	  case tENUM:
	     decl_enum(sGLOBAL);
	     break;
	  case tPUBLIC:
	     /* This can be a public function or a public variable;
	      * see the comment above (for static functions/variables)
	      * for details.
	      */
	     fconst = matchtoken(tCONST);
	     tag = sc_addtag(NULL);
	     tok = lex(&val, &str);
	     if (tok == tNATIVE || tok == tSTOCK || tok == tSTATIC)
	       {
		  error(42);	/* invalid combination of class specifiers */
		  break;
	       }		/* if */
	     declfuncvar(tok, str, tag, TRUE, FALSE, FALSE, fconst);
	     break;
	  case tSTOCK:
	     /* This can be a stock function or a stock *global) variable;
	      * see the comment above (for static functions/variables) for
	      * details.
	      */
	     fstatic = matchtoken(tSTATIC);
	     fconst = matchtoken(tCONST);
	     tag = sc_addtag(NULL);
	     tok = lex(&val, &str);
	     if (tok == tNATIVE || tok == tPUBLIC)
	       {
		  error(42);	/* invalid combination of class specifiers */
		  break;
	       }		/* if */
	     declfuncvar(tok, str, tag, FALSE, fstatic, TRUE, fconst);
	     break;
	  case tLABEL:
	  case tSYMBOL:
	  case tOPERATOR:
	     lexpush();
	     if (!newfunc(NULL, -1, FALSE, FALSE, FALSE))
	       {
		  error(10);	/* illegal function or declaration */
		  lexclr(TRUE);	/* drop the rest of the line */
	       }		/* if */
	     break;
	  case tNATIVE:
	     funcstub(TRUE);	/* create a dummy function */
	     break;
	  case tFORWARD:
	     funcstub(FALSE);
	     break;
	  case '}':
	     error(54);		/* unmatched closing brace */
	     break;
	  case '{':
	     error(55);		/* start of function body without function header */
	     break;
	  default:
	     if (freading)
	       {
		  error(10);	/* illegal function or declaration */
		  lexclr(TRUE);	/* drop the rest of the line */
	       }		/* if */
	  }			/* switch */
     }				/* while */
}

/*  dumplits
 *
 *  Dump the literal pool (strings etc.)
 *
 *  Global references: litidx (referred to only)
 */
static void
dumplits(void)
{
   int                 j, k;

   k = 0;
   while (k < litidx)
     {
	/* should be in the data segment */
	assert(curseg == 2);
	defstorage();
	j = 16;			/* 16 values per line */
	while (j && k < litidx)
	  {
	     outval(litq[k], FALSE);
	     stgwrite(" ");
	     k++;
	     j--;
	     if (j == 0 || k >= litidx)
		stgwrite("\n");	/* force a newline after 10 dumps */
	     /* Note: stgwrite() buffers a line until it is complete. It recognizes
	      * the end of line as a sequence of "\n\0", so something like "\n\t"
	      * so should not be passed to stgwrite().
	      */
	  }			/* while */
     }				/* while */
}

/*  dumpzero
 *
 *  Dump zero's for default initial values
 */
static void
dumpzero(int count)
{
   int                 i;

   if (count <= 0)
      return;
   assert(curseg == 2);
   defstorage();
   i = 0;
   while (count-- > 0)
     {
	outval(0, FALSE);
	i = (i + 1) % 16;
	stgwrite((i == 0 || count == 0) ? "\n" : " ");
	if (i == 0 && count > 0)
	   defstorage();
     }				/* while */
}

static void
aligndata(int numbytes)
{
   if ((((glb_declared + litidx) * sizeof(cell)) % numbytes) != 0)
     {
	while ((((glb_declared + litidx) * sizeof(cell)) % numbytes) != 0)
	   stowlit(0);
     }				/* if */

}

static void
declfuncvar(int tok, char *symname, int tag, int fpublic, int fstatic,
	    int fstock, int fconst)
{
   char                name[sNAMEMAX + 1];

   if (tok != tSYMBOL && tok != tOPERATOR)
     {
	if (freading)
	   error(20, symname);	/* invalid symbol name */
	return;
     }				/* if */
   if (tok == tOPERATOR)
     {
	lexpush();
	if (!newfunc(NULL, tag, fpublic, fstatic, fstock))
	   error(10);		/* illegal function or declaration */
     }
   else
     {
	assert(strlen(symname) <= sNAMEMAX);
	strcpy(name, symname);
	if (fconst || !newfunc(name, tag, fpublic, fstatic, fstock))
	   declglb(name, tag, fpublic, fstatic, fstock, fconst);
	/* if not a static function, try a static variable */
     }				/* if */
}

/*  declglb     - declare global symbols
 *
 *  Declare a static (global) variable. Global variables are stored in
 *  the DATA segment.
 *
 *  global references: glb_declared     (altered)
 */
static void
declglb(char *firstname, int firsttag, int fpublic, int fstatic,
	int stock, int fconst)
{
   int                 ident, tag, ispublic;
   int                 idxtag[sDIMEN_MAX];
   char                name[sNAMEMAX + 1];
   cell                val, size, cidx;
   char               *str;
   int                 dim[sDIMEN_MAX];
   int                 numdim, level;
   int                 filenum;
   symbol             *sym;

#if !defined NDEBUG
   cell                glbdecl = 0;
#endif

   filenum = fcurrent;		/* save file number at the start of the
				 * declaration */
   do
     {
	size = 1;		/* single size (no array) */
	numdim = 0;		/* no dimensions */
	ident = iVARIABLE;
	if (firstname)
	  {
	     assert(strlen(firstname) <= sNAMEMAX);
	     strncpy(name, firstname, sNAMEMAX);	/* save symbol name */
	     name[sNAMEMAX] = 0;
	     tag = firsttag;
	     firstname = NULL;
	  }
	else
	  {
	     tag = sc_addtag(NULL);
	     if (lex(&val, &str) != tSYMBOL)	/* read in (new) token */
		error(20, str);	/* invalid symbol name */
	     assert(strlen(str) <= sNAMEMAX);
	     strncpy(name, str, sNAMEMAX);	/* save symbol name */
	     name[sNAMEMAX] = 0;
	  }			/* if */
	sym = findglb(name);
	if (!sym)
	   sym = findconst(name);
	if (sym && (sym->usage & uDEFINE) != 0)
	   error(21, name);	/* symbol already defined */
	ispublic = fpublic;
	if (name[0] == PUBLIC_CHAR)
	  {
	     ispublic = TRUE;	/* implicitly public variable */
	     if (stock || fstatic)
		error(42);	/* invalid combination of class specifiers */
	  }			/* if */
	while (matchtoken('['))
	  {
	     ident = iARRAY;
	     if (numdim == sDIMEN_MAX)
	       {
		  error(53);	/* exceeding maximum number of dimensions */
		  return;
	       }		/* if */
	     if (numdim > 0 && dim[numdim - 1] == 0)
		error(52);	/* only last dimension may be variable length */
	     size = needsub(&idxtag[numdim]);	/* get size; size==0 for
						 * "var[]" */
#if INT_MAX < CELL_MAX
	     if (size > INT_MAX)
		error(105);	/* overflow, exceeding capacity */
#endif
	     if (ispublic)
		error(56, name);	/* arrays cannot be public */
	     dim[numdim++] = (int)size;
	  }			/* while */
	/* if this variable is never used (which can be detected only in
	 * the second stage), shut off code generation; make an exception
	 * for public variables
	 */
	cidx = 0;		/* only to avoid a compiler warning */
	if (sc_status == statWRITE && sym
	    && (sym->usage & (uREAD | uWRITTEN | uPUBLIC)) == 0)
	  {
	     sc_status = statSKIP;
	     cidx = code_idx;
#if !defined NDEBUG
	     glbdecl = glb_declared;
#endif
	  }			/* if */
	defsymbol(name, ident, sGLOBAL, sizeof(cell) * glb_declared, tag);
	begdseg();		/* real (initialized) data in data segment */
	assert(litidx == 0);	/* literal queue should be empty */
	if (sc_alignnext)
	  {
	     litidx = 0;
	     aligndata(sc_dataalign);
	     dumplits();	/* dump the literal queue */
	     sc_alignnext = FALSE;
	     litidx = 0;	/* global initial data is dumped, so restart at zero */
	  }			/* if */
	initials(ident, tag, &size, dim, numdim);	/* stores values in
							 * the literal queue */
	if (numdim == 1)
	   dim[0] = (int)size;
	dumplits();		/* dump the literal queue */
	dumpzero((int)size - litidx);
	litidx = 0;
	if (!sym)
	  {			/* define only if not yet defined */
	     sym =
		addvariable(name, sizeof(cell) * glb_declared, ident, sGLOBAL,
			    tag, dim, numdim, idxtag);
	  }
	else
	  {			/* if declared but not yet defined, adjust the
				 * variable's address */
	     sym->addr = sizeof(cell) * glb_declared;
	     sym->usage |= uDEFINE;
	  }			/* if */
	if (ispublic)
	   sym->usage |= uPUBLIC;
	if (fconst)
	   sym->usage |= uCONST;
	if (stock)
	   sym->usage |= uSTOCK;
	if (fstatic)
	   sym->fnumber = filenum;
	if (ident == iARRAY)
	   for (level = 0; level < numdim; level++)
	      symbolrange(level, dim[level]);
	if (sc_status == statSKIP)
	  {
	     sc_status = statWRITE;
	     code_idx = cidx;
	     assert(glb_declared == glbdecl);
	  }
	else
	  {
	     glb_declared += (int)size;	/* add total number of cells */
	  }			/* if */
     }
   while (matchtoken(','));	/* enddo *//* more? */
   needtoken(tTERM);		/* if not comma, must be semicolumn */
}

/*  declloc     - declare local symbols
 *
 *  Declare local (automatic) variables. Since these variables are
 *  relative to the STACK, there is no switch to the DATA segment.
 *  These variables cannot be initialized either.
 *
 *  global references: declared   (altered)
 *                     funcstatus (referred to only)
 */
static int
declloc(int fstatic)
{
   int                 ident, tag;
   int                 idxtag[sDIMEN_MAX];
   char                name[sNAMEMAX + 1];
   symbol             *sym;
   cell                val, size;
   char               *str;
   value               lval = { NULL, 0, 0, 0, 0, NULL };
   int                 cur_lit = 0;
   int                 dim[sDIMEN_MAX];
   int                 numdim, level;
   int                 fconst;

   fconst = matchtoken(tCONST);
   do
     {
	ident = iVARIABLE;
	size = 1;
	numdim = 0;		/* no dimensions */
	tag = sc_addtag(NULL);
	if (lex(&val, &str) != tSYMBOL)	/* read in (new) token */
	   error(20, str);	/* invalid symbol name */
	assert(strlen(str) <= sNAMEMAX);
	strncpy(name, str, sNAMEMAX);	/* save symbol name */
	name[sNAMEMAX] = 0;
	if (name[0] == PUBLIC_CHAR)
	   error(56, name);	/* local variables cannot be public */
	/* Note: block locals may be named identical to locals at higher
	 * compound blocks (as with standard C); so we must check (and add)
	 * the "nesting level" of local variables to verify the
	 * multi-definition of symbols.
	 */
	if ((sym = findloc(name)) && sym->compound == nestlevel)
	   error(21, name);	/* symbol already defined */
	/* Although valid, a local variable whose name is equal to that
	 * of a global variable or to that of a local variable at a lower
	 * level might indicate a bug.
	 */
	if (((sym = findloc(name)) && sym->compound != nestlevel)
	    || findglb(name))
	   error(219, name);	/* variable shadows another symbol */
	while (matchtoken('['))
	  {
	     ident = iARRAY;
	     if (numdim == sDIMEN_MAX)
	       {
		  error(53);	/* exceeding maximum number of dimensions */
		  return ident;
	       }		/* if */
	     if (numdim > 0 && dim[numdim - 1] == 0)
		error(52);	/* only last dimension may be variable length */
	     size = needsub(&idxtag[numdim]);	/* get size; size==0 for "var[]" */
#if INT_MAX < CELL_MAX
	     if (size > INT_MAX)
		error(105);	/* overflow, exceeding capacity */
#endif
	     dim[numdim++] = (int)size;
	  }			/* while */
	if (ident == iARRAY || fstatic)
	  {
	     if (sc_alignnext)
	       {
		  aligndata(sc_dataalign);
		  sc_alignnext = FALSE;
	       }		/* if */
	     cur_lit = litidx;	/* save current index in the literal table */
	     initials(ident, tag, &size, dim, numdim);
	     if (size == 0)
		return ident;	/* error message already given */
	     if (numdim == 1)
		dim[0] = (int)size;
	  }			/* if */
	/* reserve memory (on the stack) for the variable */
	if (fstatic)
	  {
	     /* write zeros for uninitialized fields */
	     while (litidx < cur_lit + size)
		stowlit(0);
	     sym =
		addvariable(name, (cur_lit + glb_declared) * sizeof(cell),
			    ident, sSTATIC, tag, dim, numdim, idxtag);
	     defsymbol(name, ident, sSTATIC,
		       (cur_lit + glb_declared) * sizeof(cell), tag);
	  }
	else
	  {
	     declared += (int)size;	/* variables are put on stack,
					 * adjust "declared" */
	     sym =
		addvariable(name, -declared * sizeof(cell), ident, sLOCAL, tag,
			    dim, numdim, idxtag);
	     defsymbol(name, ident, sLOCAL, -declared * sizeof(cell), tag);
	     modstk(-(int)size * sizeof(cell));
	  }			/* if */
	/* now that we have reserved memory for the variable, we can
	 * proceed to initialize it */
	sym->compound = nestlevel;	/* for multiple declaration/shadowing */
	if (fconst)
	   sym->usage |= uCONST;
	if (ident == iARRAY)
	   for (level = 0; level < numdim; level++)
	      symbolrange(level, dim[level]);
	if (!fstatic)
	  {			/* static variables already initialized */
	     if (ident == iVARIABLE)
	       {
		  /* simple variable, also supports initialization */
		  int                 ctag = tag;	/* set to "tag" by default */
		  int                 explicit_init = FALSE;	/* is the variable explicitly
								 * initialized? */
		  if (matchtoken('='))
		    {
		       doexpr(FALSE, FALSE, FALSE, FALSE, &ctag, TRUE);
		       explicit_init = TRUE;
		    }
		  else
		    {
		       const1(0);	/* uninitialized variable, set to zero */
		    }		/* if */
		  /* now try to save the value (still in PRI) in the variable */
		  lval.sym = sym;
		  lval.ident = iVARIABLE;
		  lval.constval = 0;
		  lval.tag = tag;
		  check_userop(NULL, ctag, lval.tag, 2, NULL, &ctag);
		  store(&lval);
		  endexpr(TRUE);	/* full expression ends after the store */
		  if (!matchtag(tag, ctag, TRUE))
		     error(213);	/* tag mismatch */
		  /* if the variable was not explicitly initialized, reset the
		   * "uWRITTEN" flag that store() set */
		  if (!explicit_init)
		     sym->usage &= ~uWRITTEN;
	       }
	     else
	       {
		  /* an array */
		  if (litidx - cur_lit < size)
		     fillarray(sym, size * sizeof(cell), 0);
		  if (cur_lit < litidx)
		    {
		       /* check whether the complete array is set to a single value;
		        * if it is, more compact code can be generated */
		       cell                first = litq[cur_lit];
		       int                 i;

		       for (i = cur_lit; i < litidx && litq[i] == first; i++)
			  /* nothing */ ;
		       if (i == litidx)
			 {
			    /* all values are the same */
			    fillarray(sym, (litidx - cur_lit) * sizeof(cell),
				      first);
			    litidx = cur_lit;	/* reset literal table */
			 }
		       else
			 {
			    /* copy the literals to the array */
			    const1((cur_lit + glb_declared) * sizeof(cell));
			    copyarray(sym, (litidx - cur_lit) * sizeof(cell));
			 }	/* if */
		    }		/* if */
	       }		/* if */
	  }			/* if */
     }
   while (matchtoken(','));	/* enddo *//* more? */
   needtoken(tTERM);		/* if not comma, must be semicolumn */
   return ident;
}

static              cell
calc_arraysize(int dim[], int numdim, int cur)
{
   if (cur == numdim)
      return 0;
   return dim[cur] + (dim[cur] * calc_arraysize(dim, numdim, cur + 1));
}

/*  initials
 *
 *  Initialize global objects and local arrays.
 *    size==array cells (count), if 0 on input, the routine counts
 *    the number of elements
 *    tag==required tagname id (not the returned tag)
 *
 *  Global references: litidx (altered)
 */
static void
initials(int ident, int tag, cell * size, int dim[], int numdim)
{
   int                 ctag;
   int                 curlit = litidx;
   int                 d;

   if (!matchtoken('='))
     {
	if (ident == iARRAY && dim[numdim - 1] == 0)
	  {
	     /* declared as "myvar[];" which is senseless (note: this *does* make
	      * sense in the case of a iREFARRAY, which is a function parameter)
	      */
	     error(9);		/* array has zero length -> invalid size */
	  }			/* if */
	if (numdim > 1)
	  {
	     /* initialize the indirection tables */
#if sDIMEN_MAX>2
#error Array algorithms for more than 2 dimensions are not implemented
#endif
	     assert(numdim == 2);
	     *size = calc_arraysize(dim, numdim, 0);
	     for (d = 0; d < dim[0]; d++)
		stowlit((dim[0] + d * (dim[1] - 1)) * sizeof(cell));
	  }			/* if */
	return;
     }				/* if */

   if (ident == iVARIABLE)
     {
	assert(*size == 1);
	init(ident, &ctag);
	if (!matchtag(tag, ctag, TRUE))
	   error(213);		/* tag mismatch */
     }
   else
     {
	assert(numdim > 0);
	if (numdim == 1)
	  {
	     *size = initvector(ident, tag, dim[0], FALSE);
	  }
	else
	  {
	     cell                offs, dsize;

	     /* The simple algorithm below only works for arrays with one or
	      * two dimensions. This should be some recursive algorithm.
	      */
	     if (dim[numdim - 1] != 0)
		/* set size to (known) full size */
		*size = calc_arraysize(dim, numdim, 0);
	     /* dump indirection tables */
	     for (d = 0; d < dim[0]; d++)
		stowlit(0);
	     /* now dump individual vectors */
	     needtoken('{');
	     offs = dim[0];
	     for (d = 0; d < dim[0]; d++)
	       {
		  litq[curlit + d] = offs * sizeof(cell);
		  dsize = initvector(ident, tag, dim[1], TRUE);
		  offs += dsize - 1;
		  if (d + 1 < dim[0])
		     needtoken(',');
		  if (matchtoken('{') || matchtoken(tSTRING))
		     /* expect a '{' or a string */
		     lexpush();
		  else
		     break;
	       }		/* for */
	     matchtoken(',');
	     needtoken('}');
	  }			/* if */
     }				/* if */

   if (*size == 0)
      *size = litidx - curlit;	/* number of elements defined */
}

/*  initvector
 *  Initialize a single dimensional array
 */
static              cell
initvector(int ident, int tag, cell size, int fillzero)
{
   cell                prev1 = 0, prev2 = 0;
   int                 ctag;
   int                 ellips = FALSE;
   int                 curlit = litidx;

   assert(ident == iARRAY || ident == iREFARRAY);
   if (matchtoken('{'))
     {
	do
	  {
	     if (matchtoken('}'))
	       {		/* to allow for trailing ',' after the initialization */
		  lexpush();
		  break;
	       }		/* if */
	     if ((ellips = matchtoken(tELLIPS)) != 0)
		break;
	     prev2 = prev1;
	     prev1 = init(ident, &ctag);
	     if (!matchtag(tag, ctag, TRUE))
		error(213);	/* tag mismatch */
	  }
	while (matchtoken(','));	/* do */
	needtoken('}');
     }
   else
     {
	init(ident, &ctag);
	if (!matchtag(tag, ctag, TRUE))
	   error(213);		/* tagname mismatch */
     }				/* if */
   /* fill up the literal queue with a series */
   if (ellips)
     {
	cell                step =
	   ((litidx - curlit) == 1) ? (cell) 0 : prev1 - prev2;
	if (size == 0 || (litidx - curlit) == 0)
	   error(41);		/* invalid ellipsis, array size unknown */
	else if ((litidx - curlit) == (int)size)
	   error(18);		/* initialisation data exceeds declared size */
	while ((litidx - curlit) < (int)size)
	  {
	     prev1 += step;
	     stowlit(prev1);
	  }			/* while */
     }				/* if */
   if (fillzero && size > 0)
     {
	while ((litidx - curlit) < (int)size)
	   stowlit(0);
     }				/* if */
   if (size == 0)
     {
	size = litidx - curlit;	/* number of elements defined */
     }
   else if (litidx - curlit > (int)size)
     {				/* e.g. "myvar[3]={1,2,3,4};" */
	error(18);		/* initialisation data exceeds declared size */
	litidx = (int)size + curlit;	/* avoid overflow in memory moves */
     }				/* if */
   return size;
}

/*  init
 *
 *  Evaluate one initializer.
 */
static              cell
init(int ident, int *tag)
{
   cell                i = 0;

   if (matchtoken(tSTRING))
     {
	/* lex() automatically stores strings in the literal table (and
	 * increases "litidx") */
	if (ident == iVARIABLE)
	  {
	     error(6);		/* must be assigned to an array */
	     litidx = 1;	/* reset literal queue */
	  }			/* if */
	*tag = 0;
     }
   else if (constexpr(&i, tag))
     {
	stowlit(i);		/* store expression result in literal table */
     }				/* if */
   return i;
}

/*  needsub
 *
 *  Get required array size
 */
static              cell
needsub(int *tag)
{
   cell                val;

   *tag = 0;
   if (matchtoken(']'))		/* we've already seen "[" */
      return 0;			/* null size (like "char msg[]") */
   constexpr(&val, tag);	/* get value (must be constant expression) */
   if (val < 0)
     {
	error(9);		/* negative array size is invalid; assumed zero */
	val = 0;
     }				/* if */
   needtoken(']');
   return val;			/* return array size */
}

/*  decl_const  - declare a single constant
 *
 */
static void
decl_const(int vclass)
{
   char                constname[sNAMEMAX + 1];
   cell                val;
   char               *str;
   int                 tag, exprtag;
   int                 symbolline;

   tag = sc_addtag(NULL);
   if (lex(&val, &str) != tSYMBOL)	/* read in (new) token */
      error(20, str);		/* invalid symbol name */
   symbolline = fline;		/* save line where symbol was found */
   strncpy(constname, str, sizeof(constname) - 1);	/* save symbol name */
   constname[sizeof(constname) - 1] = 0;
   needtoken('=');
   constexpr(&val, &exprtag);	/* get value */
   needtoken(tTERM);
   /* add_constant() checks for duplicate definitions */
   if (!matchtag(tag, exprtag, FALSE))
     {
	/* temporarily reset the line number to where the symbol was
	 * defined */
	int                 orgfline = fline;

	fline = symbolline;
	error(213);		/* tagname mismatch */
	fline = orgfline;
     }				/* if */
   add_constant(constname, val, vclass, tag);
}

/*  decl_enum   - declare enumerated constants
 *
 */
static void
decl_enum(int vclass)
{
   char                enumname[sNAMEMAX + 1], constname[sNAMEMAX + 1];
   cell                lexval, enumvalue, size;
   char               *str;
   int                 tok, tag, explicittag;
   cell                increment, multiplier;

   /* get an explicit tag, if any (we need to remember whether an
    * explicit tag was passed, even if that explicit tag was "_:", so we
    * cannot call sc_addtag() here
    */
   if (lex(&lexval, &str) == tLABEL)
     {
	tag = sc_addtag(str);
	explicittag = TRUE;
     }
   else
     {
	lexpush();
	tag = 0;
	explicittag = FALSE;
     }				/* if */

   /* get optional enum name (also serves as a tag if no explicit
    * tag was set) */
   if (lex(&lexval, &str) == tSYMBOL)
     {				/* read in (new) token */
	strncpy(enumname, str, sizeof(enumname) - 1);	/* save enum name (last constant) */
        enumname[sizeof(enumname) - 1] = 0;
	if (!explicittag)
	   tag = sc_addtag(enumname);
     }
   else
     {
	lexpush();		/* analyze again */
	enumname[0] = '\0';
     }				/* if */

   /* get increment and multiplier */
   increment = 1;
   multiplier = 1;
   if (matchtoken('('))
     {
	if (matchtoken(taADD))
	  {
	     constexpr(&increment, NULL);
	  }
	else if (matchtoken(taMULT))
	  {
	     constexpr(&multiplier, NULL);
	  }
	else if (matchtoken(taSHL))
	  {
	     constexpr(&lexval, NULL);
	     while (lexval-- > 0)
		multiplier *= 2;
	  }			/* if */
	needtoken(')');
     }				/* if */

   needtoken('{');
   /* go through all constants */
   enumvalue = 0;			/* default starting value */
   do
     {
	if (matchtoken('}'))
	  {			/* quick exit if '}' follows ',' */
	     lexpush();
	     break;
	  }			/* if */
	tok = lex(&lexval, &str);	/* read in (new) token */
	if (tok != tSYMBOL && tok != tLABEL)
	   error(20, str);	/* invalid symbol name */
	strncpy(constname, str, sNAMEMAX); /* save symbol name */
	constname[sNAMEMAX] = 0;
	size = increment;	/* default increment of 'val' */
	if (tok == tLABEL || matchtoken(':'))
	   constexpr(&size, NULL);	/* get size */
	if (matchtoken('='))
	   constexpr(&enumvalue, NULL);	/* get value */
	/* add_constant() checks whether a variable (global or local) or
	 * a constant with the same name already exists */
	add_constant(constname, enumvalue, vclass, tag);
	if (multiplier == 1)
	   enumvalue += size;
	else
	   enumvalue *= size * multiplier;
     }
   while (matchtoken(','));
   needtoken('}');		/* terminates the constant list */
   matchtoken(';');		/* eat an optional ; */

   /* set the enum name to the last value plus one */
   if (enumname[0] != '\0')
      add_constant(enumname, enumvalue, vclass, tag);
}

/*
 *  Finds a function in the global symbol table or creates a new entry.
 *  It does some basic processing and error checking.
 */
symbol     *
fetchfunc(char *name, int tag)
{
   symbol             *sym;
   cell                offset;

   offset = code_idx;
   if ((sc_debug & sSYMBOLIC) != 0)
     {
	offset += opcodes(1) + opargs(3) + nameincells(name);
	/* ^^^ The address for the symbol is the code address. But the
	 * "symbol" instruction itself generates code. Therefore the
	 * offset is pre-adjusted to the value it will have after the
	 * symbol instruction.
	 */
     }				/* if */
   if ((sym = findglb(name)))
     {				/* already in symbol table? */
	if (sym->ident != iFUNCTN)
	  {
	     error(21, name);	/* yes, but not as a function */
	     return NULL;	/* make sure the old symbol is not damaged */
	  }
	else if ((sym->usage & uDEFINE) != 0)
	  {
	     error(21, name);	/* yes, and it's already defined */
	  }
	else if ((sym->usage & uNATIVE) != 0)
	  {
	     error(21, name);	/* yes, and it is an native */
	  }			/* if */
	assert(sym->vclass == sGLOBAL);
	if ((sym->usage & uDEFINE) == 0)
	  {
	     /* as long as the function stays undefined, update the address
	      * and the tag */
	     sym->addr = offset;
	     sym->tag = tag;
	  }			/* if */
     }
   else
     {
	/* don't set the "uDEFINE" flag; it may be a prototype */
	sym = addsym(name, offset, iFUNCTN, sGLOBAL, tag, 0);
	/* assume no arguments */
	sym->dim.arglist = (arginfo *) malloc(1 * sizeof(arginfo));
	sym->dim.arglist[0].ident = 0;
	/* set library ID to NULL (only for native functions) */
	sym->x.lib = NULL;
     }				/* if */
   return sym;
}

/* This routine adds symbolic information for each argument.
 */
static void
define_args(void)
{
   symbol             *sym;

   /* At this point, no local variables have been declared. All
    * local symbols are function arguments.
    */
   sym = loctab.next;
   while (sym)
     {
	assert(sym->ident != iLABEL);
	assert(sym->vclass == sLOCAL);
	defsymbol(sym->name, sym->ident, sLOCAL, sym->addr, sym->tag);
	if (sym->ident == iREFARRAY)
	  {
	     symbol             *sub = sym;

	     while (sub)
	       {
		  symbolrange(sub->dim.array.level, sub->dim.array.length);
		  sub = finddepend(sub);
	       }		/* while */
	  }			/* if */
	sym = sym->next;
     }				/* while */
}

static int
operatorname(char *name)
{
   int                 opertok;
   char               *str;
   cell                val;

   assert(name != NULL);

   /* check the operator */
   opertok = lex(&val, &str);
   switch (opertok)
     {
     case '+':
     case '-':
     case '*':
     case '/':
     case '%':
     case '>':
     case '<':
     case '!':
     case '~':
     case '=':
	name[0] = (char)opertok;
	name[1] = '\0';
	break;
     case tINC:
	strcpy(name, "++");
	break;
     case tDEC:
	strcpy(name, "--");
	break;
     case tlEQ:
	strcpy(name, "==");
	break;
     case tlNE:
	strcpy(name, "!=");
	break;
     case tlLE:
	strcpy(name, "<=");
	break;
     case tlGE:
	strcpy(name, ">=");
	break;
     default:
	name[0] = '\0';
	error(61);		/* operator cannot be redefined
				 * (or bad operator name) */
	return 0;
     }				/* switch */

   return opertok;
}

static int
operatoradjust(int opertok, symbol * sym, char *opername, int resulttag)
{
   int                 tags[2] = { 0, 0 };
   int                 count = 0;
   arginfo            *arg;
   char                tmpname[sNAMEMAX + 1];
   symbol             *oldsym;

   if (opertok == 0)
      return TRUE;

   /* count arguments and save (first two) tags */
   while (arg = &sym->dim.arglist[count], arg->ident != 0)
     {
	if (count < 2)
	  {
	     if (arg->numtags > 1)
		error(65, count + 1);	/* function argument may only have
					 * a single tag */
	     else if (arg->numtags == 1)
		tags[count] = arg->tags[0];
	  }			/* if */
	if (opertok == '~' && count == 0)
	  {
	     if (arg->ident != iREFARRAY)
		error(73, arg->name);	/* must be an array argument */
	  }
	else
	  {
	     if (arg->ident != iVARIABLE)
		error(66, arg->name);	/* must be non-reference argument */
	  }			/* if */
	if (arg->hasdefault)
	   error(59, arg->name);	/* arguments of an operator may not
					 * have a default value */
	count++;
     }				/* while */

   /* for '!', '++' and '--', count must be 1
    * for '-', count may be 1 or 2
    * for '=', count must be 1, and the resulttag is also important
    * for all other (binary) operators and the special '~'
    * operator, count must be 2
    */
   switch (opertok)
     {
     case '!':
     case '=':
     case tINC:
     case tDEC:
	if (count != 1)
	   error(62);		/* number or placement of the operands does
				 * not fit the operator */
	break;
     case '-':
	if (count != 1 && count != 2)
	   error(62);		/* number or placement of the operands does
				 * not fit the operator */
	break;
     default:
	if (count != 2)
	   error(62);		/* number or placement of the operands does
				 * not fit the operator */
     }				/* switch */

   if (tags[0] == 0
       && ((opertok != '=' && tags[1] == 0) || (opertok == '=' && resulttag == 0)))
      error(64);		/* cannot change predefined operators */

   /* change the operator name */
   assert(opername[0] != '\0');
   operator_symname(tmpname, opername, tags[0], tags[1], count, resulttag);
   if ((oldsym = findglb(tmpname)))
     {
	int                 i;

	if ((oldsym->usage & uDEFINE) != 0)
	  {
	     char                errname[2 * sNAMEMAX + 16];

	     funcdisplayname(errname, tmpname);
	     error(21, errname);	/* symbol already defined */
	  }			/* if */
	sym->usage |= oldsym->usage;	/* copy flags from the previous
					 * definition */
	for (i = 0; i < oldsym->numrefers; i++)
	   if (oldsym->refer[i])
	      refer_symbol(sym, oldsym->refer[i]);
	delete_symbol(&glbtab, oldsym);
     }				/* if */
   if ((sc_debug & sSYMBOLIC) != 0)
      sym->addr += nameincells(tmpname) - nameincells(sym->name);
   strcpy(sym->name, tmpname);
   sym->hash = namehash(sym->name);	/* calculate new hash */

   /* operators should return a value, except the '~' operator */
   if (opertok != '~')
      sym->usage |= uRETVALUE;

   return TRUE;
}

static int
check_operatortag(int opertok, int resulttag, char *opername)
{
   assert(opername != NULL && opername[0] != '\0');
   switch (opertok)
     {
     case '!':
     case '<':
     case '>':
     case tlEQ:
     case tlNE:
     case tlLE:
     case tlGE:
	if (resulttag != sc_addtag("bool"))
	  {
	     error(63, opername, "bool:");	/* operator X requires
						 * a "bool:" result tag */
	     return FALSE;
	  }			/* if */
	break;
     case '~':
	if (resulttag != 0)
	  {
	     error(63, opername, "_:");	/* operator "~" requires
					 * a "_:" result tag */
	     return FALSE;
	  }			/* if */
	break;
     }				/* switch */
   return TRUE;
}

static char        *
tag2str(char *dest, int tag)
{
   tag &= TAGMASK;
   assert(tag >= 0);
   sprintf(dest, "0%x", tag);
   return sc_isdigit(dest[1]) ? &dest[1] : dest;
}

char       *
operator_symname(char *symname, char *opername, int tag1, int tag2,
		 int numtags, int resulttag)
{
   char                tagstr1[10], tagstr2[10];
   int                 opertok;

   assert(numtags >= 1 && numtags <= 2);
   opertok = (opername[1] == '\0') ? opername[0] : 0;
   if (opertok == '=')
      sprintf(symname, "%s%s%s", tag2str(tagstr1, resulttag), opername,
	      tag2str(tagstr2, tag1));
   else if (numtags == 1 || opertok == '~')
      sprintf(symname, "%s%s", opername, tag2str(tagstr1, tag1));
   else
      sprintf(symname, "%s%s%s", tag2str(tagstr1, tag1), opername,
	      tag2str(tagstr2, tag2));
   return symname;
}

static int
parse_funcname(char *fname, int *tag1, int *tag2, char *opname)
{
   char               *ptr, *name;
   int                 unary;

   /* tags are only positive, so if the function name starts with a '-',
    * the operator is an unary '-' or '--' operator.
    */
   if (*fname == '-')
     {
	*tag1 = 0;
	unary = TRUE;
	ptr = fname;
     }
   else
     {
	*tag1 = (int)strtol(fname, &ptr, 16);
	unary = ptr == fname;	/* unary operator if it doesn't start
				 * with a tag name */
     }				/* if */
   assert(!unary || *tag1 == 0);
   assert(*ptr != '\0');
   for (name = opname; !sc_isdigit(*ptr);)
      *name++ = *ptr++;
   *name = '\0';
   *tag2 = (int)strtol(ptr, NULL, 16);
   return unary;
}

char       *
funcdisplayname(char *dest, char *funcname)
{
   int                 tags[2];
   char                opname[10];
   constvalue         *tagsym[2];
   int                 unary;

   if (sc_isalpha(*funcname) || *funcname == '_' || *funcname == PUBLIC_CHAR
       || *funcname == '\0')
     {
	if (dest != funcname)
	   strcpy(dest, funcname);
	return dest;
     }				/* if */

   unary = parse_funcname(funcname, &tags[0], &tags[1], opname);
   tagsym[1] = find_constval_byval(&tagname_tab, tags[1]);
   assert(tagsym[1] != NULL);
   if (unary)
     {
	sprintf(dest, "operator%s(%s:)", opname, tagsym[1]->name);
     }
   else
     {
	tagsym[0] = find_constval_byval(&tagname_tab, tags[0]);
	/* special case: the assignment operator has the return value
	 * as the 2nd tag */
	if (opname[0] == '=' && opname[1] == '\0')
	   sprintf(dest, "%s:operator%s(%s:)", tagsym[0]->name, opname,
		   tagsym[1]->name);
	else
	   sprintf(dest, "operator%s(%s:,%s:)", opname, tagsym[0]->name,
		   tagsym[1]->name);
     }				/* if */
   return dest;
}

static void
funcstub(int native)
{
   int                 tok, tag;
   char               *str;
   cell                val;
   char                symbolname[sNAMEMAX + 1];
   symbol             *sym;
   int                 opertok;

   opertok = 0;
   lastst = 0;
   litidx = 0;			/* clear the literal pool */

   tag = sc_addtag(NULL);
   tok = lex(&val, &str);
   if (native)
     {
	if (tok == tPUBLIC || tok == tSTOCK || tok == tSTATIC ||
	    (tok == tSYMBOL && *str == PUBLIC_CHAR))
	   error(42);		/* invalid combination of class specifiers */
     }
   else
     {
	if (tok == tPUBLIC || tok == tSTATIC)
	   tok = lex(&val, &str);
     }				/* if */
   if (tok == tOPERATOR)
     {
	opertok = operatorname(symbolname);
	if (opertok == 0)
	   return;		/* error message already given */
	check_operatortag(opertok, tag, symbolname);
     }
   else
     {
	if (tok != tSYMBOL && freading)
	  {
	     error(10);		/* illegal function or declaration */
	     return;
	  }			/* if */
        assert(sizeof(str) <= sNAMEMAX);
	strcpy(symbolname, str);
     }				/* if */
   needtoken('(');		/* only functions may be native/forward */

   sym = fetchfunc(symbolname, tag);	/* get a pointer to the
					 * function entry */
   if (!sym)
      return;
   if (native)
     {
	sym->usage = uNATIVE | uRETVALUE | uDEFINE;
	sym->x.lib = curlibrary;
     }				/* if */

   declargs(sym);
   /* "declargs()" found the ")" */
   if (!operatoradjust(opertok, sym, symbolname, tag))
      sym->usage &= ~uDEFINE;
   /* for a native operator, also need to specify an "exported"
    * function name; for a native function, this is optional
    */
   if (native)
     {
	if (opertok != 0)
	  {
	     needtoken('=');
	     lexpush();		/* push back, for matchtoken() to retrieve again */
	  }			/* if */
	if (matchtoken('='))
	  {
	     /* allow number or symbol */
	     if (matchtoken(tSYMBOL))
	       {
		  tokeninfo(&val, &str);
		  if (strlen(str) > sEXPMAX)
		    {
		       error(220, str, sEXPMAX);
		       str[sEXPMAX] = '\0';
		    }		/* if */
		  insert_alias(sym->name, str);
	       }
	     else
	       {
		  constexpr(&val, NULL);
		  sym->addr = val;
		  /*
		   * ?? Must mark this address, so that it won't be generated again
		   * and it won't be written to the output file. At the moment,
		   * I have assumed that this syntax is only valid if val < 0.
		   * To properly mix "normal" native functions and indexed native
		   * functions, one should use negative indices anyway.
		   * Special code for a negative index in sym->addr exists in
		   * SC4.C (ffcall()) and in SC6.C (the loops for counting the
		   * number of native variables and for writing them).
		   */
	       }		/* if */
	  }			/* if */
     }				/* if */
   needtoken(tTERM);

   litidx = 0;			/* clear the literal pool */
   /* clear local variables queue */
   delete_symbols(&loctab, 0, TRUE, TRUE);
}

/*  newfunc    - begin a function
 *
 *  This routine is called from "parse" and tries to make a function
 *  out of the following text
 *
 *  Global references: funcstatus,lastst,litidx
 *                     rettype  (altered)
 *                     curfunc  (altered)
 *                     declared (altered)
 *                     glb_declared (altered)
 *                     sc_alignnext (altered)
 */
static int
newfunc(char *firstname, int firsttag, int fpublic, int fstatic, int stock)
{
   symbol             *sym;
   int                 argcnt, tok, tag, funcline;
   int                 opertok, opererror;
   char                symbolname[sNAMEMAX + 1];
   char               *str;
   cell                val, cidx, glbdecl;
   int                 filenum;

   litidx = 0;			/* clear the literal pool ??? */
   opertok = 0;
   lastst = 0;			/* no statement yet */
   cidx = 0;			/* just to avoid compiler warnings */
   glbdecl = 0;
   filenum = fcurrent;		/* save file number at start of declaration */

   if (firstname)
     {
	assert(strlen(firstname) <= sNAMEMAX);
	strcpy(symbolname, firstname);	/* save symbol name */
	tag = firsttag;
     }
   else
     {
	tag = (firsttag >= 0) ? firsttag : sc_addtag(NULL);
	tok = lex(&val, &str);
	assert(!fpublic);
	if (tok == tNATIVE || (tok == tPUBLIC && stock))
	   error(42);		/* invalid combination of class specifiers */
	if (tok == tOPERATOR)
	  {
	     opertok = operatorname(symbolname);
	     if (opertok == 0)
		return TRUE;	/* error message already given */
	     check_operatortag(opertok, tag, symbolname);
	  }
	else
	  {
	     if (tok != tSYMBOL && freading)
	       {
		  error(20, str);	/* invalid symbol name */
		  return FALSE;
	       }		/* if */
	     assert(strlen(str) <= sNAMEMAX);
	     strcpy(symbolname, str);
	  }			/* if */
     }				/* if */
   /* check whether this is a function or a variable declaration */
   if (!matchtoken('('))
      return FALSE;
   /* so it is a function, proceed */
   funcline = fline;		/* save line at which the function is defined */
   if (symbolname[0] == PUBLIC_CHAR)
     {
	fpublic = TRUE;		/* implicitly public function */
	if (stock)
	   error(42);		/* invalid combination of class specifiers */
     }				/* if */
   sym = fetchfunc(symbolname, tag);	/* get a pointer to the
					 * function entry */
   if (!sym)
      return TRUE;
   if (fpublic)
      sym->usage |= uPUBLIC;
   if (fstatic)
      sym->fnumber = filenum;
   /* declare all arguments */
   argcnt = declargs(sym);
   opererror = !operatoradjust(opertok, sym, symbolname, tag);
   if (strcmp(symbolname, uMAINFUNC) == 0)
     {
	if (argcnt > 0)
	   error(5);		/* "main()" function may not have any arguments */
	sym->usage |= uREAD;	/* "main()" is the program's entry point:
				 * always used */
     }				/* if */
   /* "declargs()" found the ")"; if a ";" appears after this, it was a
    * prototype */
   if (matchtoken(';'))
     {
	if (!sc_needsemicolon)
	   error(218);		/* old style prototypes used with optional
				 * semicolumns */
	delete_symbols(&loctab, 0, TRUE, TRUE);	/* prototype is done;
						 * forget everything */
	return TRUE;
     }				/* if */
   /* so it is not a prototype, proceed */
   /* if this is a function that is not referred to (this can only be
    * detected in the second stage), shut code generation off */
   if (sc_status == statWRITE && (sym->usage & uREAD) == 0)
     {
	sc_status = statSKIP;
	cidx = code_idx;
	glbdecl = glb_declared;
     }				/* if */
   begcseg();
   sym->usage |= uDEFINE;	/* set the definition flag */
   if (fpublic)
      sym->usage |= uREAD;	/* public functions are always "used" */
   if (stock)
      sym->usage |= uSTOCK;
   if (opertok != 0 && opererror)
      sym->usage &= ~uDEFINE;
   defsymbol(sym->name, iFUNCTN, sGLOBAL,
	     code_idx + opcodes(1) + opargs(3) + nameincells(sym->name), tag);
   /* ^^^ The address for the symbol is the code address. But the
    * "symbol" instruction itself generates code. Therefore the
    * offset is pre-adjusted to the value it will have after the
    * symbol instruction.
    */
   startfunc(sym->name);	/* creates stack frame */
   if ((sc_debug & sSYMBOLIC) != 0)
      setline(funcline, fcurrent);
   if (sc_alignnext)
     {
	alignframe(sc_dataalign);
	sc_alignnext = FALSE;
     }				/* if */
   declared = 0;		/* number of local cells */
   rettype = (sym->usage & uRETVALUE);	/* set "return type" variable */
   curfunc = sym;
   define_args();		/* add the symbolic info for the function arguments */
   statement(NULL, FALSE);
   if ((rettype & uRETVALUE) != 0)
      sym->usage |= uRETVALUE;
   if (declared != 0)
     {
	/* This happens only in a very special (and useless) case, where a
	 * function has only a single statement in its body (no compound
	 * block) and that statement declares a new variable
	 */
	modstk((int)declared * sizeof(cell));	/* remove all local
						 * variables */
	declared = 0;
     }				/* if */
   if ((lastst != tRETURN) && (lastst != tGOTO))
     {
	const1(0);
	ffret();
	if ((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 */
     }				/* if */
   endfunc();
   if (litidx)
     {				/* if there are literals defined */
	glb_declared += litidx;
	begdseg();		/* flip to DATA segment */
	dumplits();		/* dump literal strings */
	litidx = 0;
     }				/* if */
   testsymbols(&loctab, 0, TRUE, TRUE);	/* test for unused arguments
					 * and labels */
   delete_symbols(&loctab, 0, TRUE, TRUE);	/* clear local variables
						 * queue */
   assert(loctab.next == NULL);
   curfunc = NULL;
   if (sc_status == statSKIP)
     {
	sc_status = statWRITE;
	code_idx = cidx;
	glb_declared = glbdecl;
     }				/* if */
   return TRUE;
}

static int
argcompare(arginfo * a1, arginfo * a2)
{
   int                 result, level;

   result = strcmp(a1->name, a2->name) == 0;
   if (result)
      result = a1->ident == a2->ident;
   if (result)
      result = a1->usage == a2->usage;
   if (result)
      result = a1->numtags == a2->numtags;
   if (result)
     {
	int                 i;

	for (i = 0; i < a1->numtags && result; i++)
	   result = a1->tags[i] == a2->tags[i];
     }				/* if */
   if (result)
      result = a1->hasdefault == a2->hasdefault;
   if (a1->hasdefault)
     {
	if (a1->ident == iREFARRAY)
	  {
	     if (result)
		result = a1->defvalue.array.size == a2->defvalue.array.size;
	     if (result)
		result =
		   a1->defvalue.array.arraysize == a2->defvalue.array.arraysize;
	     /* also check the dimensions of both arrays */
	     if (result)
		result = a1->numdim == a2->numdim;
	     for (level = 0; result && level < a1->numdim; level++)
		result = a1->dim[level] == a2->dim[level];
	     /* ??? should also check contents of the default array
	      * (these troubles go away in a 2-pass compiler that forbids
	      * double declarations, but Small currently does not forbid them)
	      */
	  }
	else
	  {
	     if (result)
	       {
		  if ((a1->hasdefault & uSIZEOF) != 0
		      || (a1->hasdefault & uTAGOF) != 0)
		     result = a1->hasdefault == a2->hasdefault
			&& strcmp(a1->defvalue.size.symname,
				  a2->defvalue.size.symname) == 0
			&& a1->defvalue.size.level == a2->defvalue.size.level;
		  else
		     result = a1->defvalue.val == a2->defvalue.val;
	       }		/* if */
	  }			/* if */
	if (result)
	   result = a1->defvalue_tag == a2->defvalue_tag;
     }				/* if */
   return result;
}

/*  declargs()
 *
 *  This routine adds an entry in the local symbol table for each
 *  argument found in the argument list.
 *  It returns the number of arguments.
 */
static int
declargs(symbol * sym)
{
#define MAXTAGS 16
   char               *ptr;
   int                 argcnt, oldargcnt, tok, tags[MAXTAGS], numtags;
   cell                val;
   arginfo             arg, *arglist;
   char                name[sNAMEMAX + 1];
   int                 ident, fpublic, fconst;
   int                 idx;

   /* if the function is already defined earlier, get the number of
    * arguments of the existing definition
    */
   oldargcnt = 0;
   if ((sym->usage & uPROTOTYPED) != 0)
      while (sym->dim.arglist[oldargcnt].ident != 0)
	 oldargcnt++;
   argcnt = 0;			/* zero aruments up to now */
   ident = iVARIABLE;
   numtags = 0;
   fconst = FALSE;
   fpublic = (sym->usage & uPUBLIC) != 0;
   /* the '(' parantheses has already been parsed */
   if (!matchtoken(')'))
     {
	do
	  {			/* there are arguments; process them */
	     /* any legal name increases argument count (and stack offset) */
	     tok = lex(&val, &ptr);
	     switch (tok)
	       {
	       case 0:
		  /* nothing */
		  break;
	       case '&':
		  if (ident != iVARIABLE || numtags > 0)
		     error(1, "-identifier-", "&");
		  ident = iREFERENCE;
		  break;
	       case tCONST:
		  if (ident != iVARIABLE || numtags > 0)
		     error(1, "-identifier-", "const");
		  fconst = TRUE;
		  break;
	       case tLABEL:
		  if (numtags > 0)
		     error(1, "-identifier-", "-tagname-");
		  tags[0] = sc_addtag(ptr);
		  numtags = 1;
		  break;
	       case '{':
		  if (numtags > 0)
		     error(1, "-identifier-", "-tagname-");
		  numtags = 0;
		  while (numtags < MAXTAGS)
		    {
		       if (!matchtoken('_') && !needtoken(tSYMBOL))
			  break;
		       tokeninfo(&val, &ptr);
		       tags[numtags++] = sc_addtag(ptr);
		       if (matchtoken('}'))
			  break;
		       needtoken(',');
		    }		/* for */
		  needtoken(':');
		  tok = tLABEL;	/* for outer loop:
				 * flag that we have seen a tagname */
		  break;
	       case tSYMBOL:
		  if (argcnt >= sMAXARGS)
		     error(45);	/* too many function arguments */
		  strncpy(name, ptr, sizeof(name) - 1);	/* save symbol name */
                  name[sizeof(name) - 1] = 0;
		  if (name[0] == PUBLIC_CHAR)
		     error(56, name);	/* function arguments cannot be public */
		  if (numtags == 0)
		     tags[numtags++] = 0;	/* default tag */
		  /* Stack layout:
		   *   base + 0*sizeof(cell)  == previous "base"
		   *   base + 1*sizeof(cell)  == function return address
		   *   base + 2*sizeof(cell)  == number of arguments
		   *   base + 3*sizeof(cell)  == first argument of the function
		   * So the offset of each argument is:
		   * "(argcnt+3) * sizeof(cell)".
		   */
		  doarg(name, ident, (argcnt + 3) * sizeof(cell), tags, numtags,
			fpublic, fconst, &arg);
		  if (fpublic && arg.hasdefault)
		     error(59, name);	/* arguments of a public function may not
					 * have a default value */
		  if ((sym->usage & uPROTOTYPED) == 0)
		    {
		       /* redimension the argument list, add the entry */
		       sym->dim.arglist =
			  (arginfo *) realloc(sym->dim.arglist,
					      (argcnt + 2) * sizeof(arginfo));
		       if (!sym->dim.arglist)
			  error(103);	/* insufficient memory */
		       sym->dim.arglist[argcnt] = arg;
		       sym->dim.arglist[argcnt + 1].ident = 0;	/* keep the list
								 * terminated */
		    }
		  else
		    {
		       /* check the argument with the earlier definition */
		       if (argcnt > oldargcnt
			   || !argcompare(&sym->dim.arglist[argcnt], &arg))
			  error(25);	/* function definition does not match prototype */
		       /* may need to free default array argument and the tag list */
		       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);
		       free(arg.tags);
		    }		/* if */
		  argcnt++;
		  ident = iVARIABLE;
		  numtags = 0;
		  fconst = FALSE;
		  break;
	       case tELLIPS:
		  if (ident != iVARIABLE)
		     error(10);	/* illegal function or declaration */
		  if (numtags == 0)
		     tags[numtags++] = 0;	/* default tag */
		  if ((sym->usage & uPROTOTYPED) == 0)
		    {
		       /* redimension the argument list, add the entry iVARARGS */
		       sym->dim.arglist =
			  (arginfo *) realloc(sym->dim.arglist,
					      (argcnt + 2) * sizeof(arginfo));
		       if (!sym->dim.arglist)
			  error(103);	/* insufficient memory */
		       sym->dim.arglist[argcnt + 1].ident = 0;	/* keep the list
								 * terminated */
		       sym->dim.arglist[argcnt].ident = iVARARGS;
		       sym->dim.arglist[argcnt].hasdefault = FALSE;
		       sym->dim.arglist[argcnt].defvalue.val = 0;
		       sym->dim.arglist[argcnt].defvalue_tag = 0;
		       sym->dim.arglist[argcnt].numtags = numtags;
		       sym->dim.arglist[argcnt].tags =
			  (int *)malloc(numtags * sizeof tags[0]);
		       if (!sym->dim.arglist[argcnt].tags)
			  error(103);	/* insufficient memory */
		       memcpy(sym->dim.arglist[argcnt].tags, tags,
			      numtags * sizeof tags[0]);
		    }
		  else
		    {
		       if (argcnt > oldargcnt
			   || sym->dim.arglist[argcnt].ident != iVARARGS)
			  error(25);	/* function definition does not match prototype */
		    }		/* if */
		  argcnt++;
		  break;
	       default:
		  error(10);	/* illegal function or declaration */
	       }		/* switch */
	  }
	while (tok == '&' || tok == tLABEL || tok == tCONST || (tok != tELLIPS && matchtoken(',')));	/* more? */
	/* if the next token is not ",", it should be ")" */
	needtoken(')');
     }				/* if */
   /* resolve any "sizeof" arguments (now that all arguments are known) */
   assert(sym->dim.arglist != NULL);
   arglist = sym->dim.arglist;
   for (idx = 0; idx < argcnt && arglist[idx].ident != 0; idx++)
     {
	if ((arglist[idx].hasdefault & uSIZEOF) != 0
	    || (arglist[idx].hasdefault & uTAGOF) != 0)
	  {
	     int                 altidx;

	     /* Find the argument with the name mentioned after the "sizeof".
	      * Note that we cannot use findloc here because we need the
	      * arginfo struct, not the symbol.
	      */
	     ptr = arglist[idx].defvalue.size.symname;
	     for (altidx = 0;
		  altidx < argcnt && strcmp(ptr, arglist[altidx].name) != 0;
		  altidx++)
		/* nothing */ ;
	     if (altidx >= argcnt)
	       {
		  error(17, ptr);	/* undefined symbol */
	       }
	     else
	       {
		  /* check the level against the number of dimensions */
		  /* the level must be zero for "tagof" values */
		  assert(arglist[idx].defvalue.size.level == 0
			 || (arglist[idx].hasdefault & uSIZEOF) != 0);
		  if (arglist[idx].defvalue.size.level > 0
		      && arglist[idx].defvalue.size.level >=
		      arglist[altidx].numdim)
		     error(28);	/* invalid subscript */
		  if (arglist[altidx].ident != iREFARRAY)
		    {
		       assert(arglist[altidx].ident == iVARIABLE
			      || arglist[altidx].ident == iREFERENCE);
		       error(223, ptr);	/* redundant sizeof */
		    }		/* if */
	       }		/* if */
	  }			/* if */
     }				/* for */

   sym->usage |= uPROTOTYPED;
   errorset(sRESET);		/* reset error flag (clear the "panic mode") */
   return argcnt;
}

/*  doarg       - declare one argument type
 *
 * this routine is called from "declargs()" and adds an entry in the
 * local  symbol table for one argument. "fpublic" indicates whether
 * the function for this argument list is public.
 * The arguments themselves are never public.
 */
static void
doarg(char *name, int ident, int offset, int tags[], int numtags,
      int fpublic, int fconst, arginfo * arg)
{
   symbol             *argsym;
   cell                size;
   int                 idxtag[sDIMEN_MAX];

   strncpy(arg->name, name, sizeof(arg->name) - 1);
   arg->name[sizeof(arg->name) - 1] = 0;
   arg->hasdefault = FALSE;	/* preset (most common case) */
   arg->defvalue.val = 0;	/* clear */
   arg->defvalue_tag = 0;
   arg->numdim = 0;
   if (matchtoken('['))
     {
	if (ident == iREFERENCE)
	   error(67, name);	/*illegal declaration ("&name[]" is unsupported) */
	do
	  {
	     if (arg->numdim == sDIMEN_MAX)
	       {
		  error(53);	/* exceeding maximum number of dimensions */
		  return;
	       }		/* if */
	     /* there is no check for non-zero major dimensions here, only if
	      * the array parameter has a default value, we enforce that all
	      * array dimensions, except the last, are non-zero
	      */
	     size = needsub(&idxtag[arg->numdim]);	/* may be zero here,
							 *it is a pointer anyway */
#if INT_MAX < CELL_MAX
	     if (size > INT_MAX)
		error(105);	/* overflow, exceeding capacity */
#endif
	     arg->dim[arg->numdim] = (int)size;
	     arg->numdim += 1;
	  }
	while (matchtoken('['));
	ident = iREFARRAY;	/* "reference to array" (is a pointer) */
	if (matchtoken('='))
	  {
	     int                 level;

	     lexpush();		/* initials() needs the "=" token again */
	     assert(numtags > 0);
	     /* for the moment, when a default value is given for the array,
	      * all dimension sizes, except the last, must be non-zero
	      * (function initials() requires to know the major dimensions)
	      */
	     for (level = 0; level < arg->numdim - 1; level++)
		if (arg->dim[level] == 0)
		   error(52);	/* only last dimension may be variable length */
	     initials(ident, tags[0], &size, arg->dim, arg->numdim);
	     assert(size >= litidx);
	     /* allocate memory to hold the initial values */
	     arg->defvalue.array.data = (cell *) malloc(litidx * sizeof(cell));
	     if (arg->defvalue.array.data)
	       {
		  int                 i;

		  memcpy(arg->defvalue.array.data, litq, litidx * sizeof(cell));
		  arg->hasdefault = TRUE;	/* argument has default value */
		  arg->defvalue.array.size = litidx;
		  arg->defvalue.array.addr = -1;
		  /* calculate size to reserve on the heap */
		  arg->defvalue.array.arraysize = 1;
		  for (i = 0; i < arg->numdim; i++)
		     arg->defvalue.array.arraysize *= arg->dim[i];
		  if (arg->defvalue.array.arraysize < arg->defvalue.array.size)
		     arg->defvalue.array.arraysize = arg->defvalue.array.size;
	       }		/* if */
	     litidx = 0;	/* reset */
	  }			/* if */
     }
   else
     {
	if (matchtoken('='))
	  {
	     unsigned char       size_tag_token;

	     assert(ident == iVARIABLE || ident == iREFERENCE);
	     arg->hasdefault = TRUE;	/* argument has a default value */
	     size_tag_token =
		(unsigned char)(matchtoken(tSIZEOF) ? uSIZEOF : 0);
	     if (size_tag_token == 0)
		size_tag_token =
		   (unsigned char)(matchtoken(tTAGOF) ? uTAGOF : 0);
	     if (size_tag_token != 0)
	       {
		  int                 paranthese;

		  if (ident == iREFERENCE)
		     error(66, name);	/* argument may not be a reference */
		  paranthese = 0;
		  while (matchtoken('('))
		     paranthese++;
		  if (needtoken(tSYMBOL))
		    {
		       /* save the name of the argument whose size id to take */
		       char               *argname;
		       cell                val;

		       tokeninfo(&val, &argname);
		       if (!(arg->defvalue.size.symname = strdup(argname)))
			  error(103);	/* insufficient memory */
		       arg->defvalue.size.level = 0;
		       if (size_tag_token == uSIZEOF)
			 {
			    while (matchtoken('['))
			      {
				 arg->defvalue.size.level += (short)1;
				 needtoken(']');
			      }	/* while */
			 }	/* if */
		       if (ident == iVARIABLE)	/* make sure we set this only if
						 * not a reference */
			  arg->hasdefault |= size_tag_token;	/* uSIZEOF or uTAGOF */
		    }		/* if */
		  while (paranthese--)
		     needtoken(')');
	       }
	     else
	       {
		  constexpr(&arg->defvalue.val, &arg->defvalue_tag);
		  assert(numtags > 0);
		  if (!matchtag(tags[0], arg->defvalue_tag, TRUE))
		     error(213);	/* tagname mismatch */
	       }		/* if */
	  }			/* if */
     }				/* if */
   arg->ident = (char)ident;
   arg->usage = (char)(fconst ? uCONST : 0);
   arg->numtags = numtags;
   arg->tags = (int *)malloc(numtags * sizeof tags[0]);
   if (!arg->tags)
      error(103);		/* insufficient memory */
   memcpy(arg->tags, tags, numtags * sizeof tags[0]);
   argsym = findloc(name);
   if (argsym)
     {
	error(21, name);	/* symbol already defined */
     }
   else
     {
	if ((argsym = findglb(name)) && argsym->ident != iFUNCTN)
	   error(219, name);	/* variable shadows another symbol */
	/* add details of type and address */
	assert(numtags > 0);
	argsym = addvariable(name, offset, ident, sLOCAL, tags[0],
			     arg->dim, arg->numdim, idxtag);
	argsym->compound = 0;
	if (ident == iREFERENCE)
	   argsym->usage |= uREAD;	/* because references are passed back */
	if (fpublic)
	   argsym->usage |= uREAD;	/* arguments of public functions
					 * are always "used" */
	if (fconst)
	   argsym->usage |= uCONST;
     }				/* if */
}

static int
count_referrers(symbol * entry)
{
   int                 i, count;

   count = 0;
   for (i = 0; i < entry->numrefers; i++)
      if (entry->refer[i])
	 count++;
   return count;
}

/* Every symbol has a referrer list, that contains the functions that
 * use the symbol. Now, if function "apple" is accessed by functions
 * "banana" and "citron", but neither function "banana" nor "citron" are
 * used by anyone else, then, by inference, function "apple" is not used
 * either.  */
static void
reduce_referrers(symbol * root)
{
   int                 i, restart;
   symbol             *sym, *ref;

   do
     {
	restart = 0;
	for (sym = root->next; sym; sym = sym->next)
	  {
	     if (sym->parent)
		continue;	/* hierarchical data type */
	     if (sym->ident == iFUNCTN
		 && (sym->usage & uNATIVE) == 0
		 && (sym->usage & uPUBLIC) == 0
		 && strcmp(sym->name, uMAINFUNC) != 0
		 && count_referrers(sym) == 0)
	       {
		  sym->usage &= ~(uREAD | uWRITTEN);	/* erase usage bits if
							 * there is no referrer */
		  /* find all symbols that are referred by this symbol */
		  for (ref = root->next; ref; ref = ref->next)
		    {
		       if (ref->parent)
			  continue;	/* hierarchical data type */
		       assert(ref->refer != NULL);
		       for (i = 0; i < ref->numrefers && ref->refer[i] != sym;
			    i++)
			  /* nothing */ ;
		       if (i < ref->numrefers)
			 {
			    assert(ref->refer[i] == sym);
			    ref->refer[i] = NULL;
			    restart++;
			 }	/* if */
		    }		/* for */
	       }
	     else if ((sym->ident == iVARIABLE || sym->ident == iARRAY)
		      && (sym->usage & uPUBLIC) == 0
		      && !sym->parent && count_referrers(sym) == 0)
	       {
		  sym->usage &= ~(uREAD | uWRITTEN);	/* erase usage bits if
							 * there is no referrer */
	       }		/* if */
	  }			/* for */
	/* after removing a symbol, check whether more can be removed */
     }
   while (restart > 0);
}

/*  testsymbols - test for unused local or global variables
 *
 *  "Public" functions are excluded from the check, since these
 *  may be exported to other object modules.
 *  Labels are excluded from the check if the argument 'testlabs'
 *  is 0. Thus, labels are not tested until the end of the function.
 *  Constants may also be excluded (convenient for global constants).
 *
 *  When the nesting level drops below "level", the check stops.
 *
 *  The function returns whether there is an "entry" point for the file.
 *  This flag will only be 1 when browsing the global symbol table.
 */
static int
testsymbols(symbol * root, int level, int testlabs, int testconst)
{
   char                symname[2 * sNAMEMAX + 16];
   int                 entry = FALSE;

   symbol             *sym = root->next;

   while (sym && sym->compound >= level)
     {
	switch (sym->ident)
	  {
	  case iLABEL:
	     if (testlabs)
	       {
		  if ((sym->usage & uDEFINE) == 0)
		     error(19, sym->name);	/* not a label: ... */
		  else if ((sym->usage & uREAD) == 0)
		     error(203, sym->name);	/* symbol isn't used: ... */
	       }		/* if */
	     break;
	  case iFUNCTN:
	     if ((sym->usage & (uDEFINE | uREAD | uNATIVE | uSTOCK)) == uDEFINE)
	       {
		  funcdisplayname(symname, sym->name);
		  if (symname[0] != '\0')
		     error(203, symname);	/* symbol isn't used ...
						 * (and not native/stock) */
	       }		/* if */
	     if ((sym->usage & uPUBLIC) != 0
		 || strcmp(sym->name, uMAINFUNC) == 0)
		entry = TRUE;	/* there is an entry point */
	     break;
	  case iCONSTEXPR:
	     if (testconst && (sym->usage & uREAD) == 0)
		error(203, sym->name);	/* symbol isn't used: ... */
	     break;
	  default:
	     /* a variable */
	     if (sym->parent)
		break;		/* hierarchical data type */
	     if ((sym->usage & (uWRITTEN | uREAD | uSTOCK | uPUBLIC)) == 0)
		error(203, sym->name);	/* symbol isn't used (and not stock
					 * or public) */
	     else if ((sym->usage & (uREAD | uSTOCK | uPUBLIC)) == 0)
		error(204, sym->name);	/* value assigned to symbol is
					 * never used */
#if 0				/*// ??? not sure whether it is a good idea to
				 * force people use "const" */
	     else if ((sym->usage & (uWRITTEN | uPUBLIC | uCONST)) == 0
		      && sym->ident == iREFARRAY)
		error(214, sym->name);	/* make array argument "const" */
#endif
	  }			/* if */
	sym = sym->next;
     }				/* while */

   return entry;
}

static              cell
calc_array_datasize(symbol * sym, cell * offset)
{
   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 =
	   calc_array_datasize(finddepend(sym), offset);
	if (offset)
	   *offset = length * (*offset + sizeof(cell));
	if (sublength > 0)
	   length *= length * sublength;
	else
	   length = 0;
     }
   else
     {
	if (offset)
	   *offset = 0;
     }				/* if */
   return length;
}

static void
destructsymbols(symbol * root, int level)
{
   cell                offset = 0;
   int                 savepri = FALSE;
   symbol             *sym = root->next;

   while (sym && sym->compound >= level)
     {
	if (sym->ident == iVARIABLE || sym->ident == iARRAY)
	  {
	     char                symbolname[16];
	     symbol             *opsym;
	     cell                elements;

	     /* check that the '~' operator is defined for this tag */
	     operator_symname(symbolname, "~", sym->tag, 0, 1, 0);
	     if ((opsym = findglb(symbolname)))
	       {
		  /* save PRI, in case of a return statement */
		  if (!savepri)
		    {
		       push1();	/* right-hand operand is in PRI */
		       savepri = TRUE;
		    }		/* if */
		  /* if the variable is an array, get the number of elements */
		  if (sym->ident == iARRAY)
		    {
		       elements = calc_array_datasize(sym, &offset);
		       /* "elements" can be zero when the variable is declared like
		        *    new mytag: myvar[2][] = { {1, 2}, {3, 4} }
		        * one should declare all dimensions!
		        */
		       if (elements == 0)
			  error(46, sym->name);	/* array size is unknown */
		    }
		  else
		    {
		       elements = 1;
		       offset = 0;
		    }		/* if */
		  pushval(elements);
		  /* call the '~' operator */
		  address(sym);
		  addconst(offset);	/*add offset to array data to the address */
		  push1();
		  pushval(2 * sizeof(cell));	/* 2 parameters */
		  ffcall(opsym, 1);
		  if (sc_status != statSKIP)
		     markusage(opsym, uREAD);	/* do not mark as "used" when this
						 * call itself is skipped */
		  if (opsym->x.lib)
		     opsym->x.lib->value += 1;	/* increment "usage count"
						 * of the library */
	       }		/* if */
	  }			/* if */
	sym = sym->next;
     }				/* while */
   /* restore PRI, if it was saved */
   if (savepri)
      pop1();
}

static constvalue  *
insert_constval(constvalue * prev, constvalue * next, char *name,
		cell val, short idx)
{
   constvalue         *cur;

   if (!(cur = (constvalue *)malloc(sizeof(constvalue))))
      error(103);		/* insufficient memory (fatal error) */
   memset(cur, 0, sizeof(constvalue));
   strncpy(cur->name, name, sizeof(cur->name) - 1);
   cur->name[sizeof(cur->name) - 1] = 0;
   cur->value = val;
   cur->index = idx;
   cur->next = next;
   prev->next = cur;
   return cur;
}

constvalue *
append_constval(constvalue * table, char *name, cell val, short idx)
{
   constvalue         *cur, *prev;

   /* find the end of the constant table */
   for (prev = table, cur = table->next; cur;
	prev = cur, cur = cur->next)
      /* nothing */ ;
   return insert_constval(prev, NULL, name, val, idx);
}

constvalue *
find_constval(constvalue * table, char *name, short idx)
{
   constvalue         *ptr = table->next;

   while (ptr)
     {
	if (strcmp(name, ptr->name) == 0 && ptr->index == idx)
	   return ptr;
	ptr = ptr->next;
     }				/* while */
   return NULL;
}

static constvalue  *
find_constval_byval(constvalue * table, cell val)
{
   constvalue         *ptr = table->next;

   while (ptr)
     {
	if (ptr->value == val)
	   return ptr;
	ptr = ptr->next;
     }				/* while */
   return NULL;
}

#if 0				/* never used */
static int
delete_constval(constvalue * table, char *name)
{
   constvalue         *prev = table;
   constvalue         *cur = prev->next;

   while (cur != NULL)
     {
	if (strcmp(name, cur->name) == 0)
	  {
	     prev->next = cur->next;
	     free(cur);
	     return TRUE;
	  }			/* if */
	prev = cur;
	cur = cur->next;
     }				/* while */
   return FALSE;
}
#endif

void
delete_consttable(constvalue * table)
{
   constvalue         *cur = table->next, *next;

   while (cur)
     {
	next = cur->next;
	free(cur);
	cur = next;
     }				/* while */
   memset(table, 0, sizeof(constvalue));
}

/*  add_constant
 *
 *  Adds a symbol to the #define symbol table.
 */
void
add_constant(char *name, cell val, int vclass, int tag)
{
   symbol             *sym;

   /* Test whether a global or local symbol with the same name exists. Since
    * constants are stored in the symbols table, this also finds previously
    * defind constants. */
   sym = findglb(name);
   if (!sym)
      sym = findloc(name);
   if (sym)
     {
	/* silently ignore redefinitions of constants with the same value */
	if (sym->ident == iCONSTEXPR)
	  {
	     if (sym->addr != val)
		error(201, name);	/* redefinition of constant (different value) */
	  }
	else
	  {
	     error(21, name);	/* symbol already defined */
	  }			/* if */
	return;
     }				/* if */

   /* constant doesn't exist yet, an entry must be created */
   sym = addsym(name, val, iCONSTEXPR, vclass, tag, uDEFINE);
   if (sc_status == statIDLE)
      sym->usage |= uPREDEF;
}

/*  statement           - The Statement Parser
 *
 *  This routine is called whenever the parser needs to know what
 *  statement it encounters (i.e. whenever program syntax requires a
 *  statement).
 */
static void
statement(int *lastindent, int allow_decl)
{
   int                 tok;
   cell                val;
   char               *st;

   if (!freading)
     {
	error(36);		/* empty statement */
	return;
     }				/* if */
   errorset(sRESET);

   tok = lex(&val, &st);
   if (tok != '{')
      setline(fline, fcurrent);
   /* lex() has set stmtindent */
   if (lastindent && tok != tLABEL)
     {
#if 0
	if (*lastindent >= 0 && *lastindent != stmtindent &&
	    !indent_nowarn && sc_tabsize > 0)
	   error(217);		/* loose indentation */
#endif
	*lastindent = stmtindent;
	indent_nowarn = TRUE;	/* if warning was blocked, re-enable it */
     }				/* if */
   switch (tok)
     {
     case 0:
	/* nothing */
	break;
     case tNEW:
	if (allow_decl)
	  {
	     declloc(FALSE);
	     lastst = tNEW;
	  }
	else
	  {
	     error(3);		/* declaration only valid in a block */
	  }			/* if */
	break;
     case tSTATIC:
	if (allow_decl)
	  {
	     declloc(TRUE);
	     lastst = tNEW;
	  }
	else
	  {
	     error(3);		/* declaration only valid in a block */
	  }			/* if */
	break;
     case '{':
	if (!matchtoken('}'))	/* {} is the empty statement */
	   compound();
	/* lastst (for "last statement") does not change */
	break;
     case ';':
	error(36);		/* empty statement */
	break;
     case tIF:
	doif();
	lastst = tIF;
	break;
     case tWHILE:
	dowhile();
	lastst = tWHILE;
	break;
     case tDO:
	dodo();
	lastst = tDO;
	break;
     case tFOR:
	dofor();
	lastst = tFOR;
	break;
     case tSWITCH:
	doswitch();
	lastst = tSWITCH;
	break;
     case tCASE:
     case tDEFAULT:
	error(14);		/* not in switch */
	break;
     case tGOTO:
	dogoto();
	lastst = tGOTO;
	break;
     case tLABEL:
	dolabel();
	lastst = tLABEL;
	break;
     case tRETURN:
	doreturn();
	lastst = tRETURN;
	break;
     case tBREAK:
	dobreak();
	lastst = tBREAK;
	break;
     case tCONTINUE:
	docont();
	lastst = tCONTINUE;
	break;
     case tEXIT:
	doexit();
	lastst = tEXIT;
	break;
     case tASSERT:
	doassert();
	lastst = tASSERT;
	break;
     case tSLEEP:
	dosleep();
	lastst = tSLEEP;
	break;
     case tCONST:
	decl_const(sLOCAL);
	break;
     case tENUM:
	decl_enum(sLOCAL);
	break;
     default:			/* non-empty expression */
	lexpush();		/* analyze token later */
	doexpr(TRUE, TRUE, TRUE, TRUE, NULL, FALSE);
	needtoken(tTERM);
	lastst = tEXPR;
     }				/* switch */
}

static void
compound(void)
{
   int                 indent = -1;
   cell                save_decl = declared;
   int                 count_stmt = 0;

   nestlevel += 1;		/* increase compound statement level */
   while (matchtoken('}') == 0)
     {				/* repeat until compound statement is closed */
	if (!freading)
	  {
	     needtoken('}');	/* gives error: "expected token }" */
	     break;
	  }
	else
	  {
	     if (count_stmt > 0
		 && (lastst == tRETURN || lastst == tBREAK
		     || lastst == tCONTINUE))
		error(225);	/* unreachable code */
	     statement(&indent, TRUE);	/* do a statement */
	     count_stmt++;
	  }			/* if */
     }				/* while */
   if (lastst != tRETURN)
      destructsymbols(&loctab, nestlevel);
   if (lastst != tRETURN && lastst != tGOTO)
      /* delete local variable space */
      modstk((int)(declared - save_decl) * sizeof(cell));

   testsymbols(&loctab, nestlevel, FALSE, TRUE);	/* look for unused
							 * block locals */
   declared = save_decl;
   delete_symbols(&loctab, nestlevel, FALSE, TRUE);
   /* erase local symbols, but
    * retain block local labels
    * (within the function) */

   nestlevel -= 1;		/* decrease compound statement level */
}

/*  doexpr
 *
 *  Global references: stgidx   (referred to only)
 */
static void
doexpr(int comma, int chkeffect, int allowarray, int mark_endexpr,
       int *tag, int chkfuncresult)
{
   int                 constant, idx, ident;
   int                 localstaging = FALSE;
   cell                val;

   if (!staging)
     {
	stgset(TRUE);		/* start stage-buffering */
	localstaging = TRUE;
	assert(stgidx == 0);
     }				/* if */
   idx = stgidx;
   errorset(sEXPRMARK);
   do
     {
	/* on second round through, mark the end of the previous expression */
	if (idx != stgidx)
	   endexpr(TRUE);
	sideeffect = FALSE;
	ident = expression(&constant, &val, tag, chkfuncresult);
	if (!allowarray && (ident == iARRAY || ident == iREFARRAY))
	   error(33, "-unknown-");	/* array must be indexed */
	if (chkeffect && !sideeffect)
	   error(215);		/* expression has no effect */
     }
   while (comma && matchtoken(','));	/* more? */
   if (mark_endexpr)
      endexpr(TRUE);		/* optionally, mark the end of the expression */
   errorset(sEXPRRELEASE);
   if (localstaging)
     {
	stgout(idx);
	stgset(FALSE);		/* stop staging */
     }				/* if */
}

/*  constexpr
 */
int
constexpr(cell * val, int *tag)
{
   int                 constant, idx;
   cell                cidx;

   stgset(TRUE);		/* start stage-buffering */
   stgget(&idx, &cidx);	/* mark position in code generator */
   errorset(sEXPRMARK);
   expression(&constant, val, tag, FALSE);
   stgdel(idx, cidx);		/* scratch generated code */
   stgset(FALSE);		/* stop stage-buffering */
   if (constant == 0)
      error(8);			/* must be constant expression */
   errorset(sEXPRRELEASE);
   return constant;
}

/*  test
 *
 *  In the case a "simple assignment" operator ("=") is used within a
 *  test, *  the warning "possibly unintended assignment" is displayed.
 *  This routine sets the global variable "intest" to true, it is
 *  restored upon termination. In the case the assignment was intended,
 *  use parantheses around the expression to avoid the warning;
 *  primary() sets "intest" to 0.
 *
 *  Global references: intest   (altered, but restored upon termination)
 */
static void
test(int label, int parens, int inv)
{
   int                 idx, tok;
   cell                cidx;
   value               lval = { NULL, 0, 0, 0, 0, NULL };
   int                 localstaging = FALSE;

   if (!staging)
     {
	stgset(TRUE);		/* start staging */
	localstaging = TRUE;
#if !defined NDEBUG
	stgget(&idx, &cidx);	/* should start at zero if started
				 * locally */
	assert(idx == 0);
#endif
     }				/* if */

   pushstk((stkitem) intest);
   intest = 1;
   if (parens)
      needtoken('(');
   do
     {
	stgget(&idx, &cidx);	/* mark position (of last expression) in
				 * code generator */
	if (hier14(&lval))
	   rvalue(&lval);
	tok = matchtoken(',');
	if (tok)
	   endexpr(TRUE);
     }
   while (tok);			/* do */
   if (parens)
      needtoken(')');
   if (lval.ident == iARRAY || lval.ident == iREFARRAY)
     {
	char               *ptr = lval.sym->name;
	error(33, ptr);		/* array must be indexed */
     }				/* if */
   if (lval.ident == iCONSTEXPR)
     {				/* constant expression */
	intest = (int)(long)popstk();	/* restore stack */
	stgdel(idx, cidx);
	if (lval.constval)
	  {			/* code always executed */
	     error(206);	/* redundant test: always non-zero */
	  }
	else
	  {
	     error(205);	/* redundant code: never executed */
	     jumplabel(label);
	  }			/* if */
	if (localstaging)
	  {
	     stgout(0);		/* write "jumplabel" code */
	     stgset(FALSE);	/* stop staging */
	  }			/* if */
	return;
     }				/* if */
   if (lval.tag != 0 && lval.tag != sc_addtag("bool"))
      if (check_userop(lneg, lval.tag, 0, 1, NULL, &lval.tag))
	 inv = !inv;	/* user-defined ! operator inverted result */
   if (inv)
      jmp_ne0(label);		/* jump to label if true (different from 0) */
   else
      jmp_eq0(label);		/* jump to label if false (equal to 0) */
   endexpr(TRUE);		/* end expression (give optimizer a chance) */
   intest = (int)(long)popstk();	/* double typecast to avoid warning
					 * with Microsoft C */
   if (localstaging)
     {
	stgout(0);		/* output queue from the very beginning (see
				 * assert() when localstaging is set to TRUE) */
	stgset(FALSE);		/* stop staging */
     }				/* if */
}

static void
doif(void)
{
   int                 flab1, flab2;
#if 0   
   int                 ifindent;

   ifindent = stmtindent;	/* save the indent of the "if" instruction */
#endif   
   flab1 = getlabel();		/* get label number for false branch */
   test(flab1, TRUE, FALSE);	/*get expression, branch to flab1 if false */
   statement(NULL, FALSE);	/* if true, do a statement */
   if (matchtoken(tELSE) == 0)
     {				/* if...else ? */
	setlabel(flab1);	/* no, simple if..., print false label */
     }
   else
     {
	/* to avoid the "dangling else" error, we want a warning if the "else"
	 * has a lower indent than the matching "if" */
#if 0
	if (stmtindent < ifindent && sc_tabsize > 0)
	   error(217);		/* loose indentation */
#endif
	flab2 = getlabel();
	if ((lastst != tRETURN) && (lastst != tGOTO))
	   jumplabel(flab2);
	setlabel(flab1);	/* print false label */
	statement(NULL, FALSE);	/* do "else" clause */
	setlabel(flab2);	/* print true label */
     }				/* endif */
}

static void
dowhile(void)
{
   int                 lwq[wqSIZE];	/* allocate local queue */

   addwhile(lwq);		/* add entry to queue for "break" */
   setlabel(lwq[wqLOOP]);	/* loop label */
   /* The debugger uses the "line" opcode to be able to "break" out of
    * a loop. To make sure that each loop has a line opcode, even for the
    * tiniest loop, set it below the top of the loop */
   setline(fline, fcurrent);
   test(lwq[wqEXIT], TRUE, FALSE);	/* branch to lwq[wqEXIT] if false */
   statement(NULL, FALSE);	/* if so, do a statement */
   jumplabel(lwq[wqLOOP]);	/* and loop to "while" start */
   setlabel(lwq[wqEXIT]);	/* exit label */
   delwhile();			/* delete queue entry */
}

/*
 *  Note that "continue" will in this case not jump to the top of the
 *  loop, but  to the end: just before the TRUE-or-FALSE testing code.
 */
static void
dodo(void)
{
   int                 lwq[wqSIZE], top;

   addwhile(lwq);		/* see "dowhile" for more info */
   top = getlabel();		/* make a label first */
   setlabel(top);		/* loop label */
   statement(NULL, FALSE);
   needtoken(tWHILE);
   setlabel(lwq[wqLOOP]);	/* "continue" always jumps to WQLOOP. */
   setline(fline, fcurrent);
   test(lwq[wqEXIT], TRUE, FALSE);
   jumplabel(top);
   setlabel(lwq[wqEXIT]);
   delwhile();
   needtoken(tTERM);
}

static void
dofor(void)
{
   int                 lwq[wqSIZE], skiplab;
   cell                save_decl;
   int                 save_nestlevel, idx;
   int                *ptr;

   save_decl = declared;
   save_nestlevel = nestlevel;

   addwhile(lwq);
   skiplab = getlabel();
   needtoken('(');
   if (matchtoken(';') == 0)
     {
	/* new variable declarations are allowed here */
	if (matchtoken(tNEW))
	  {
	     /* The variable in expr1 of the for loop is at a
	      * 'compound statement' level of it own.
	      */
	     nestlevel++;
	     declloc(FALSE);	/* declare local variable */
	  }
	else
	  {
	     doexpr(TRUE, TRUE, TRUE, TRUE, NULL, FALSE);	/* expression 1 */
	     needtoken(';');
	  }			/* if */
     }				/* if */
   /* Adjust the "declared" field in the "while queue", in case that
    * local variables were declared in the first expression of the
    * "for" loop. These are deleted in separately, so a "break" or a
    * "continue" must ignore these fields.
    */
   ptr = readwhile();
   assert(ptr != NULL);
   ptr[wqBRK] = (int)declared;
   ptr[wqCONT] = (int)declared;
   jumplabel(skiplab);		/* skip expression 3 1st time */
   setlabel(lwq[wqLOOP]);	/* "continue" goes to this label: expr3 */
   setline(fline, fcurrent);
   /* Expressions 2 and 3 are reversed in the generated code:
    * expression 3 precedes expression 2.
    * When parsing, the code is buffered and marks for
    * the start of each expression are insterted in the buffer.
    */
   assert(!staging);
   stgset(TRUE);		/* start staging */
   assert(stgidx == 0);
   idx = stgidx;
   stgmark(sSTARTREORDER);
   stgmark((char)(sEXPRSTART + 0));	/* mark start of 2nd expression
					 * in stage */
   setlabel(skiplab);		/*jump to this point after 1st expression */
   if (matchtoken(';') == 0)
     {
	test(lwq[wqEXIT], FALSE, FALSE);	/* expression 2
					 *(jump to wq[wqEXIT] if false) */
	needtoken(';');
     }				/* if */
   stgmark((char)(sEXPRSTART + 1));	/* mark start of 3th expression
					 * in stage */
   if (matchtoken(')') == 0)
     {
	doexpr(TRUE, TRUE, TRUE, TRUE, NULL, FALSE);	/* expression 3 */
	needtoken(')');
     }				/* if */
   stgmark(sENDREORDER);	/* mark end of reversed evaluation */
   stgout(idx);
   stgset(FALSE);		/* stop staging */
   statement(NULL, FALSE);
   jumplabel(lwq[wqLOOP]);
   setlabel(lwq[wqEXIT]);
   delwhile();

   assert(nestlevel >= save_nestlevel);
   if (nestlevel > save_nestlevel)
     {
	/* Clean up the space and the symbol table for the local
	 * variable in "expr1".
	 */
	destructsymbols(&loctab, nestlevel);
	modstk((int)(declared - save_decl) * sizeof(cell));
	declared = save_decl;
	delete_symbols(&loctab, nestlevel, FALSE, TRUE);
	nestlevel = save_nestlevel;	/* reset 'compound statement'
					 * nesting level */
     }				/* if */
}

/* The switch statement is incompatible with its C sibling:
 * 1. the cases are not drop through
 * 2. only one instruction may appear below each case, use a compound
 *    instruction to execute multiple instructions
 * 3. the "case" keyword accepts a comma separated list of values to
 *    match, it also accepts a range using the syntax "1 .. 4"
 *
 * SWITCH param
 *   PRI = expression result
 *   param = table offset (code segment)
 *
 */
static void
doswitch(void)
{
   int                 lbl_table, lbl_exit, lbl_case;
   int                 tok, swdefault, casecount;
   cell                val;
   char               *str;
   constvalue          caselist = { NULL, "", 0, 0 };	/*case list starts empty */
   constvalue         *cse, *csp;
   char                labelname[sNAMEMAX + 1];

   needtoken('(');
   doexpr(TRUE, FALSE, FALSE, TRUE, NULL, FALSE);	/* evaluate
							 * switch expression */
   needtoken(')');
   /* generate the code for the switch statement, the label is the
    * address of the case table (to be generated later).
    */
   lbl_table = getlabel();
   lbl_case = 0;		/* just to avoid a compiler warning */
   ffswitch(lbl_table);

   needtoken('{');
   lbl_exit = getlabel();	/*get label number for jumping out of switch */
   swdefault = FALSE;
   casecount = 0;
   do
     {
	tok = lex(&val, &str);	/* read in (new) token */
	switch (tok)
	  {
	  case tCASE:
	     if (swdefault != FALSE)
		error(15);	/* "default" case must be last in switch
				 * statement */
	     lbl_case = getlabel();
	     sc_allowtags = FALSE;	/* do not allow tagnames here */
	     do
	       {
		  casecount++;

		  /* ??? enforce/document that, in a switch, a statement cannot
		   * start an opening brace (marks the start of a compound
		   * statement) and search for the right-most colon before that
		   * statement.
		   * Now, by replacing the ':' by a special COLON token, you can
		   * parse all expressions until that special token.
		   */

		  constexpr(&val, NULL);
		  /* Search the insertion point (the table is kept in sorted
		   * order, so that advanced abstract machines can sift the
		   * case table with a binary search). Check for duplicate
		   * case values at the same time.
		   */
		  for (csp = &caselist, cse = caselist.next;
		       cse && cse->value < val;
		       csp = cse, cse = cse->next)
		     /* nothing */ ;
		  if (cse && cse->value == val)
		     error(40, val);	/* duplicate "case" label */
		  /* Since the label is stored as a string in the
		   * "constvalue", the size of an identifier must
		   * be at least 8, as there are 8
		   * hexadecimal digits in a 32-bit number.
		   */
#if sNAMEMAX < 8
#error Length of identifier (sNAMEMAX) too small.
#endif
		  insert_constval(csp, cse, itoh(lbl_case), val, 0);
		  if (matchtoken(tDBLDOT))
		    {
		       cell                end;

		       constexpr(&end, NULL);
		       if (end <= val)
			  error(50);	/* invalid range */
		       while (++val <= end)
			 {
			    casecount++;
			    /* find the new insertion point */
			    for (csp = &caselist, cse = caselist.next;
				 cse && cse->value < val;
				 csp = cse, cse = cse->next)
			       /* nothing */ ;
			    if (cse && cse->value == val)
			       error(40, val);	/* duplicate "case" label */
			    insert_constval(csp, cse, itoh(lbl_case), val, 0);
			 }	/* if */
		    }		/* if */
	       }
	     while (matchtoken(','));
	     needtoken(':');	/* ':' ends the case */
	     sc_allowtags = TRUE;	/* reset */
	     setlabel(lbl_case);
	     statement(NULL, FALSE);
	     jumplabel(lbl_exit);
	     break;
	  case tDEFAULT:
	     if (swdefault != FALSE)
		error(16);	/* multiple defaults in switch */
	     lbl_case = getlabel();
	     setlabel(lbl_case);
	     needtoken(':');
	     swdefault = TRUE;
	     statement(NULL, FALSE);
	     /* Jump to lbl_exit, even thouh this is the last clause in the
	      *switch, because the jump table is generated between the last
	      * clause of the switch and the exit label.
	      */
	     jumplabel(lbl_exit);
	     break;
	  case '}':
	     /* nothing, but avoid dropping into "default" */
	     break;
	  default:
	     error(2);
	     indent_nowarn = TRUE;	/* disable this check */
	     tok = '}';		/* break out of the loop after an error */
	  }			/* switch */
     }
   while (tok != '}');

#if !defined NDEBUG
   /* verify that the case table is sorted (unfortunately, duplicates can
    * occur; there really shouldn't be duplicate cases, but the compiler
    * may not crash or drop into an assertion for a user error). */
   for (cse = caselist.next; cse && cse->next; cse = cse->next)
     ; /* empty. no idea whether this is correct, but we MUST NOT do
        * the setlabel(lbl_table) call in the loop body. doing so breaks
        * switch statements that only have one case statement following.
        */
#endif

   /* generate the table here, before lbl_exit (general jump target) */
   setlabel(lbl_table);

   if (swdefault == FALSE)
     {
	/* store lbl_exit as the "none-matched" label in the switch table */
	strncpy(labelname, itoh(lbl_exit), sizeof(labelname) - 1);
        labelname[sizeof(labelname) - 1] = 0;
     }
   else
     {
	/* lbl_case holds the label of the "default" clause */
	strncpy(labelname, itoh(lbl_case), sizeof(labelname) - 1);
        labelname[sizeof(labelname) - 1] = 0;
     }				/* if */
   ffcase(casecount, labelname, TRUE);
   /* generate the rest of the table */
   for (cse = caselist.next; cse; cse = cse->next)
      ffcase(cse->value, cse->name, FALSE);

   setlabel(lbl_exit);
   delete_consttable(&caselist);	/* clear list of case labels */
}

static void
doassert(void)
{
   int                 flab1, idx;
   cell                cidx;
   value               lval = { NULL, 0, 0, 0, 0, NULL };

   if ((sc_debug & sCHKBOUNDS) != 0)
     {
	flab1 = getlabel();	/* get label number for "OK" branch */
	test(flab1, FALSE, TRUE);	/* get expression and branch
					 * to flab1 if true */
	setline(fline, fcurrent);	/* make sure we abort on the correct
					 * line number */
	ffabort(xASSERTION);
	setlabel(flab1);
     }
   else
     {
	stgset(TRUE);		/* start staging */
	stgget(&idx, &cidx);	/* mark position in code generator */
	do
	  {
	     if (hier14(&lval))
		rvalue(&lval);
	     stgdel(idx, cidx);	/* just scrap the code */
	  }
	while (matchtoken(','));
	stgset(FALSE);		/* stop staging */
     }				/* if */
   needtoken(tTERM);
}

static void
dogoto(void)
{
   char               *st;
   cell                val;
   symbol             *sym;

   if (lex(&val, &st) == tSYMBOL)
     {
	sym = fetchlab(st);
	jumplabel((int)sym->addr);
	sym->usage |= uREAD;	/* set "uREAD" bit */
	/*
	 * // ??? if the label is defined (check sym->usage & uDEFINE), check
	 * //   sym->compound (nesting level of the label) against nestlevel;
	 * //     if sym->compound < nestlevel, call the destructor operator
	 */
     }
   else
     {
	error(20, st);		/* illegal symbol name */
     }				/* if */
   needtoken(tTERM);
}

static void
dolabel(void)
{
   char               *st;
   cell                val;
   symbol             *sym;

   tokeninfo(&val, &st);	/* retrieve label name again */
   if (find_constval(&tagname_tab, st, 0))
      error(221, st);		/* label name shadows tagname */
   sym = fetchlab(st);
   setlabel((int)sym->addr);
   /* since one can jump around variable declarations or out of compound
    * blocks, the stack must be manually adjusted
    */
   setstk(-declared * sizeof(cell));
   sym->usage |= uDEFINE;	/* label is now defined */
}

/*  fetchlab
 *
 *  Finds a label from the (local) symbol table or adds one to it.
 *  Labels are local in scope.
 *
 *  Note: The "_usage" bit is set to zero. The routines that call
 *  "fetchlab()" must set this bit accordingly.
 */
static symbol      *
fetchlab(char *name)
{
   symbol             *sym;

   sym = findloc(name);		/* labels are local in scope */
   if (sym)
     {
	if (sym->ident != iLABEL)
	   error(19, sym->name);	/* not a label: ... */
     }
   else
     {
	sym = addsym(name, getlabel(), iLABEL, sLOCAL, 0, 0);
	sym->x.declared = (int)declared;
	sym->compound = nestlevel;
     }				/* if */
   return sym;
}

/*  doreturn
 *
 *  Global references: rettype  (altered)
 */
static void
doreturn(void)
{
   int                 tag;

   if (matchtoken(tTERM) == 0)
     {
	if ((rettype & uRETNONE) != 0)
	   error(208);		/* mix "return;" and "return value;" */
	doexpr(TRUE, FALSE, FALSE, TRUE, &tag, FALSE);
	needtoken(tTERM);
	rettype |= uRETVALUE;	/* function returns a value */
	/* check tagname with function tagname */
	assert(curfunc != NULL);
	if (!matchtag(curfunc->tag, tag, TRUE))
	   error(213);		/* tagname mismatch */
     }
   else
     {
	/* this return statement contains no expression */
	const1(0);
	if ((rettype & uRETVALUE) != 0)
	  {
	     char                symname[2 * sNAMEMAX + 16];	/* allow space for user
								 * defined operators */
	     assert(curfunc != NULL);
	     funcdisplayname(symname, curfunc->name);
	     error(209, symname);	/* function should return a value */
	  }			/* if */
	rettype |= uRETNONE;	/* function does not return anything */
     }				/* if */
   destructsymbols(&loctab, 0);	/*call destructor for *all* locals */
   modstk((int)declared * sizeof(cell));	/* end of function, remove
						 *all* * local variables*/
   ffret();
}

static void
dobreak(void)
{
   int                *ptr;

   ptr = readwhile();		/* readwhile() gives an error if not in loop */
   needtoken(tTERM);
   if (!ptr)
      return;
   destructsymbols(&loctab, nestlevel);
   modstk(((int)declared - ptr[wqBRK]) * sizeof(cell));
   jumplabel(ptr[wqEXIT]);
}

static void
docont(void)
{
   int                *ptr;

   ptr = readwhile();		/* readwhile() gives an error if not in loop */
   needtoken(tTERM);
   if (!ptr)
      return;
   destructsymbols(&loctab, nestlevel);
   modstk(((int)declared - ptr[wqCONT]) * sizeof(cell));
   jumplabel(ptr[wqLOOP]);
}

void
exporttag(int tag)
{
   /* find the tag by value in the table, then set the top bit to mark it
    * "public"
    */
   if (tag != 0)
     {
	constvalue         *ptr;

	assert((tag & PUBLICTAG) == 0);
	for (ptr = tagname_tab.next;
	     ptr && tag != (int)(ptr->value & TAGMASK); ptr = ptr->next)
	   /* nothing */ ;
	if (ptr)
	   ptr->value |= PUBLICTAG;
     }				/* if */
}

static void
doexit(void)
{
   int                 tag = 0;

   if (matchtoken(tTERM) == 0)
     {
	doexpr(TRUE, FALSE, FALSE, TRUE, &tag, FALSE);
	needtoken(tTERM);
     }
   else
     {
	const1(0);
     }				/* if */
   const2(tag);
   exporttag(tag);
   destructsymbols(&loctab, 0);	/* call destructor for *all* locals */
   ffabort(xEXIT);
}

static void
dosleep(void)
{
   int                 tag = 0;

   if (matchtoken(tTERM) == 0)
     {
	doexpr(TRUE, FALSE, FALSE, TRUE, &tag, FALSE);
	needtoken(tTERM);
     }
   else
     {
	const1(0);
     }				/* if */
   const2(tag);
   exporttag(tag);
   ffabort(xSLEEP);
}

static void
addwhile(int *ptr)
{
   int                 k;

   ptr[wqBRK] = (int)declared;	/* stack pointer (for "break") */
   ptr[wqCONT] = (int)declared;	/* for "continue", possibly adjusted later */
   ptr[wqLOOP] = getlabel();
   ptr[wqEXIT] = getlabel();
   if (wqptr >= (wq + wqTABSZ - wqSIZE))
      error(102, "loop table");	/* loop table overflow (too many active loops) */
   k = 0;
   while (k < wqSIZE)
     {				/* copy "ptr" to while queue table */
	*wqptr = *ptr;
	wqptr += 1;
	ptr += 1;
	k += 1;
     }				/* while */
}

static void
delwhile(void)
{
   if (wqptr > wq)
      wqptr -= wqSIZE;
}

static int         *
readwhile(void)
{
   if (wqptr <= wq)
     {
	error(24);		/* out of context */
	return NULL;
     }
   else
     {
	return (wqptr - wqSIZE);
     }				/* if */
}