+/* 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>
+
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#endif
+
+#ifdef HAVE_EVIL
+# include <Evil.h>
+#endif /* HAVE_EVIL */
+
+#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[] __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);
+ fsetpos((FILE *) handle, (fpos_t *) position);
+}
+
+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 */
+
+ fgetpos((FILE *) handle, &lastpos);
+ return &lastpos;
+}
+
+int
+sc_eofsrc(void *handle)
+{
+ return feof((FILE *) handle);
+}
+
+void *
+sc_openasm(int fd)
+{
+ return fdopen(fd, "w+");
+}
+
+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;
+ char *tmpdir;
+
+ /* 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 */
+
+#ifndef HAVE_EVIL
+ tmpdir = getenv("TMPDIR");
+ if (!tmpdir) tmpdir = "/tmp";
+#else
+ tmpdir = (char *)evil_tmpdir_get();
+#endif /* ! HAVE_EVIL */
+
+ snprintf(outfname, PATH_MAX, "%s/embryo_cc.asm-tmp-XXXXXX", tmpdir);
+ fd_out = mkstemp(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);
+ 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 value, int tag)
+{
+ errorset(sFORCESET); /* make sure error engine is silenced */
+ sc_status = statIDLE;
+ add_constant(name, value, 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 */
+
+ outfname[0] = '\0'; /* output file name */
+ 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 __UNUSED__, char *rname __UNUSED__)
+{
+ char str[PATH_MAX];
+ int i, stack_size;
+ size_t len;
+
+ /* use embryo include dir always */
+ snprintf(str, sizeof(str), "%s/include/", e_prefix_data_get());
+ 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));
+
+ 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';
+ if (strlen(path) < (sizeof(path) - 1 - 7))
+ {
+ strcat(path, "include");
+ }
+ 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);
+ strcpy(name, firstname); /* save symbol name */
+ 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);
+ strcpy(name, str); /* save symbol name */
+ } /* 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 < LONG_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);
+ strcpy(name, str); /* save symbol name */
+ 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 < LONG_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 */
+ strcpy(constname, str); /* save symbol name */
+ 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 val, value, 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(&val, &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(&val, &str) == tSYMBOL)
+ { /* read in (new) token */
+ strcpy(enumname, str); /* save enum name (last constant) */
+ 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(&val, NULL);
+ while (val-- > 0)
+ multiplier *= 2;
+ } /* if */
+ needtoken(')');
+ } /* if */
+
+ needtoken('{');
+ /* go through all constants */
+ value = 0; /* default starting value */
+ do
+ {
+ if (matchtoken('}'))
+ { /* quick exit if '}' follows ',' */
+ lexpush();
+ break;
+ } /* if */
+ tok = lex(&val, &str); /* read in (new) token */
+ if (tok != tSYMBOL && tok != tLABEL)
+ error(20, str); /* invalid symbol name */
+ strcpy(constname, str); /* save symbol name */
+ size = increment; /* default increment of 'val' */
+ if (tok == tLABEL || matchtoken(':'))
+ constexpr(&size, NULL); /* get size */
+ if (matchtoken('='))
+ constexpr(&value, NULL); /* get value */
+ /* add_constant() checks whether a variable (global or local) or
+ * a constant with the same name already exists */
+ add_constant(constname, value, vclass, tag);
+ if (multiplier == 1)
+ value += size;
+ else
+ value *= 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, value, 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 */
+ 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 */
+ strcpy(name, ptr); /* save symbol name */
+ 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];
+
+ strcpy(arg->name, name);
+ 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 < LONG_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 *name;
+ cell val;
+
+ tokeninfo(&val, &name);
+ if (!(arg->defvalue.size.symname = strdup(name)))
+ 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));
+ strcpy(cur->name, name);
+ 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 invert)
+{
+ 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) ? lval.sym->name : "-unknown-";
+ 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))
+ invert = !invert; /* user-defined ! operator inverted result */
+ if (invert)
+ 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;
+ int ifindent;
+
+ ifindent = stmtindent; /* save the indent of the "if" instruction */
+ 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 wq[wqSIZE]; /* allocate local queue */
+
+ addwhile(wq); /* add entry to queue for "break" */
+ setlabel(wq[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(wq[wqEXIT], TRUE, FALSE); /* branch to wq[wqEXIT] if false */
+ statement(NULL, FALSE); /* if so, do a statement */
+ jumplabel(wq[wqLOOP]); /* and loop to "while" start */
+ setlabel(wq[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 wq[wqSIZE], top;
+
+ addwhile(wq); /* see "dowhile" for more info */
+ top = getlabel(); /* make a label first */
+ setlabel(top); /* loop label */
+ statement(NULL, FALSE);
+ needtoken(tWHILE);
+ setlabel(wq[wqLOOP]); /* "continue" always jumps to WQLOOP. */
+ setline(fline, fcurrent);
+ test(wq[wqEXIT], TRUE, FALSE);
+ jumplabel(top);
+ setlabel(wq[wqEXIT]);
+ delwhile();
+ needtoken(tTERM);
+}
+
+static void
+dofor(void)
+{
+ int wq[wqSIZE], skiplab;
+ cell save_decl;
+ int save_nestlevel, idx;
+ int *ptr;
+
+ save_decl = declared;
+ save_nestlevel = nestlevel;
+
+ addwhile(wq);
+ 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(wq[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(wq[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(wq[wqLOOP]);
+ setlabel(wq[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 */
+ strcpy(labelname, itoh(lbl_exit));
+ }
+ else
+ {
+ /* lbl_case holds the label of the "default" clause */
+ strcpy(labelname, itoh(lbl_case));
+ } /* 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 */
+}