aboutsummaryrefslogtreecommitdiffstats
path: root/src/bin/embryo/embryo_cc_sc2.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/bin/embryo/embryo_cc_sc2.c')
-rw-r--r--src/bin/embryo/embryo_cc_sc2.c2779
1 files changed, 2779 insertions, 0 deletions
diff --git a/src/bin/embryo/embryo_cc_sc2.c b/src/bin/embryo/embryo_cc_sc2.c
new file mode 100644
index 000000000..f72703a64
--- /dev/null
+++ b/src/bin/embryo/embryo_cc_sc2.c
@@ -0,0 +1,2779 @@
+/* Small compiler - File input, preprocessing and lexical analysis functions
+ *
+ * Copyright (c) ITB CompuPhase, 1997-2003
+ *
+ * This software is provided "as-is", without any express or implied warranty.
+ * In no event will the authors be held liable for any damages arising from
+ * the use of this software.
+ *
+ * Permission is granted to anyone to use this software for any purpose,
+ * including commercial applications, and to alter it and redistribute it
+ * freely, subject to the following restrictions:
+ *
+ * 1. The origin of this software must not be misrepresented; you must not
+ * claim that you wrote the original software. If you use this software in
+ * a product, an acknowledgment in the product documentation would be
+ * appreciated but is not required.
+ * 2. Altered source versions must be plainly marked as such, and must not be
+ * misrepresented as being the original software.
+ * 3. This notice may not be removed or altered from any source distribution.
+ *
+ * Version: $Id$
+ */
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+#include <math.h>
+#include "embryo_cc_sc.h"
+#include "Embryo.h"
+
+static int match(char *st, int end);
+static cell litchar(char **lptr, int rawmode);
+static int alpha(char c);
+
+static int icomment; /* currently in multiline comment? */
+static int iflevel; /* nesting level if #if/#else/#endif */
+static int skiplevel; /* level at which we started skipping */
+static int elsedone; /* level at which we have seen an #else */
+static char term_expr[] = "";
+static int listline = -1; /* "current line" for the list file */
+
+/* pushstk & popstk
+ *
+ * Uses a LIFO stack to store information. The stack is used by doinclude(),
+ * doswitch() (to hold the state of "swactive") and some other routines.
+ *
+ * Porting note: I made the bold assumption that an integer will not be
+ * larger than a pointer (it may be smaller). That is, the stack element
+ * is typedef'ed as a pointer type, but I also store integers on it. See
+ * SC.H for "stkitem"
+ *
+ * Global references: stack,stkidx (private to pushstk() and popstk())
+ */
+static stkitem stack[sSTKMAX];
+static int stkidx;
+void
+pushstk(stkitem val)
+{
+ if (stkidx >= sSTKMAX)
+ error(102, "parser stack"); /* stack overflow (recursive include?) */
+ stack[stkidx] = val;
+ stkidx += 1;
+}
+
+stkitem
+popstk(void)
+{
+ if (stkidx == 0)
+ return (stkitem) - 1; /* stack is empty */
+ stkidx -= 1;
+ return stack[stkidx];
+}
+
+int
+plungequalifiedfile(char *name)
+{
+ static char *extensions[] = { ".inc", ".sma", ".small" };
+ FILE *fp;
+ char *ext;
+ int ext_idx;
+
+ ext_idx = 0;
+ do
+ {
+ fp = (FILE *) sc_opensrc(name);
+ ext = strchr(name, '\0'); /* save position */
+ if (!fp)
+ {
+ /* try to append an extension */
+ strcpy(ext, extensions[ext_idx]);
+ fp = (FILE *) sc_opensrc(name);
+ if (!fp)
+ *ext = '\0'; /* on failure, restore filename */
+ } /* if */
+ ext_idx++;
+ }
+ while ((!fp) &&
+ (ext_idx < (int)(sizeof extensions / sizeof extensions[0])));
+ if (!fp)
+ {
+ *ext = '\0'; /* restore filename */
+ return FALSE;
+ } /* if */
+ pushstk((stkitem) inpf);
+ pushstk((stkitem) inpfname); /* pointer to current file name */
+ pushstk((stkitem) curlibrary);
+ pushstk((stkitem) iflevel);
+ assert(skiplevel == 0);
+ pushstk((stkitem) icomment);
+ pushstk((stkitem) fcurrent);
+ pushstk((stkitem) fline);
+ inpfname = strdup(name); /* set name of include file */
+ if (!inpfname)
+ error(103); /* insufficient memory */
+ inpf = fp; /* set input file pointer to include file */
+ fnumber++;
+ fline = 0; /* set current line number to 0 */
+ fcurrent = fnumber;
+ icomment = FALSE;
+ setfile(inpfname, fcurrent);
+ listline = -1; /* force a #line directive when changing the file */
+ setactivefile(fcurrent);
+ return TRUE;
+}
+
+int
+plungefile(char *name, int try_currentpath, int try_includepaths)
+{
+ int result = FALSE;
+ int i;
+ char *ptr;
+
+ if (try_currentpath)
+ result = plungequalifiedfile(name);
+
+ if (try_includepaths && name[0] != DIRSEP_CHAR)
+ {
+ for (i = 0; !result && (ptr = get_path(i)); i++)
+ {
+ char path[PATH_MAX];
+
+ strncpy(path, ptr, sizeof path);
+ path[sizeof path - 1] = '\0'; /* force '\0' termination */
+ strncat(path, name, sizeof(path) - strlen(path));
+ path[sizeof path - 1] = '\0';
+ result = plungequalifiedfile(path);
+ } /* while */
+ } /* if */
+ return result;
+}
+
+static void
+check_empty(char *lptr)
+{
+ /* verifies that the string contains only whitespace */
+ while (*lptr <= ' ' && *lptr != '\0')
+ lptr++;
+ if (*lptr != '\0')
+ error(38); /* extra characters on line */
+}
+
+/* doinclude
+ *
+ * Gets the name of an include file, pushes the old file on the stack and
+ * sets some options. This routine doesn't use lex(), since lex() doesn't
+ * recognize file names (and directories).
+ *
+ * Global references: inpf (altered)
+ * inpfname (altered)
+ * fline (altered)
+ * lptr (altered)
+ */
+static void
+doinclude(void)
+{
+ char name[PATH_MAX], c;
+ int i, result;
+
+ while (*lptr <= ' ' && *lptr != 0) /* skip leading whitespace */
+ lptr++;
+ if (*lptr == '<' || *lptr == '\"')
+ {
+ c = (char)((*lptr == '\"') ? '\"' : '>'); /* termination character */
+ lptr++;
+ while (*lptr <= ' ' && *lptr != 0) /* skip whitespace after quote */
+ lptr++;
+ }
+ else
+ {
+ c = '\0';
+ } /* if */
+
+ i = 0;
+ while ((*lptr != c) && (*lptr != '\0') && (i < (int)(sizeof(name) - 1))) /* find the end of the string */
+ name[i++] = *lptr++;
+ while (i > 0 && name[i - 1] <= ' ')
+ i--; /* strip trailing whitespace */
+ assert((i >= 0) && (i < (int)(sizeof(name))));
+ name[i] = '\0'; /* zero-terminate the string */
+
+ if (*lptr != c)
+ { /* verify correct string termination */
+ error(37); /* invalid string */
+ return;
+ } /* if */
+ if (c != '\0')
+ check_empty(lptr + 1); /* verify that the rest of the line is whitespace */
+
+ /* Include files between "..." or without quotes are read from the current
+ * directory, or from a list of "include directories". Include files
+ * between <...> are only read from the list of include directories.
+ */
+ result = plungefile(name, (c != '>'), TRUE);
+ if (!result)
+ error(100, name); /* cannot read from ... (fatal error) */
+}
+
+/* readline
+ *
+ * Reads in a new line from the input file pointed to by "inpf". readline()
+ * concatenates lines that end with a \ with the next line. If no more data
+ * can be read from the file, readline() attempts to pop off the previous file
+ * from the stack. If that fails too, it sets "freading" to 0.
+ *
+ * Global references: inpf,fline,inpfname,freading,icomment (altered)
+ */
+static void
+readline(char *line)
+{
+ int i, num, cont;
+ char *ptr;
+
+ if (lptr == term_expr)
+ return;
+ num = sLINEMAX;
+ cont = FALSE;
+ do
+ {
+ if (!inpf || sc_eofsrc(inpf))
+ {
+ if (cont)
+ error(49); /* invalid line continuation */
+ if (inpf && inpf != inpf_org)
+ sc_closesrc(inpf);
+ i = (int)(long)popstk();
+ if (i == -1)
+ { /* All's done; popstk() returns "stack is empty" */
+ freading = FALSE;
+ *line = '\0';
+ /* when there is nothing more to read, the #if/#else stack should
+ * be empty and we should not be in a comment
+ */
+ assert(iflevel >= 0);
+ if (iflevel > 0)
+ error(1, "#endif", "-end of file-");
+ else if (icomment)
+ error(1, "*/", "-end of file-");
+ return;
+ } /* if */
+ fline = i;
+ fcurrent = (int)(long)popstk();
+ icomment = (int)(long)popstk();
+ assert(skiplevel == 0); /* skiplevel was not stored on stack, because it should always be zero at this point */
+ iflevel = (int)(long)popstk();
+ curlibrary = (constvalue *) popstk();
+ free(inpfname); /* return memory allocated for the include file name */
+ inpfname = (char *)popstk();
+ inpf = (FILE *) popstk();
+ setactivefile(fcurrent);
+ listline = -1; /* force a #line directive when changing the file */
+ elsedone = 0;
+ } /* if */
+
+ if (!sc_readsrc(inpf, line, num))
+ {
+ *line = '\0'; /* delete line */
+ cont = FALSE;
+ }
+ else
+ {
+ /* check whether to erase leading spaces */
+ if (cont)
+ {
+ char *ptr = line;
+
+ while (*ptr == ' ' || *ptr == '\t')
+ ptr++;
+ if (ptr != line)
+ memmove(line, ptr, strlen(ptr) + 1);
+ } /* if */
+ cont = FALSE;
+ /* check whether a full line was read */
+ if (!strchr(line, '\n') && !sc_eofsrc(inpf))
+ error(75); /* line too long */
+ /* check if the next line must be concatenated to this line */
+ if ((ptr = strchr(line, '\n')) && ptr > line)
+ {
+ assert(*(ptr + 1) == '\0'); /* '\n' should be last in the string */
+ while (ptr > line
+ && (*ptr == '\n' || *ptr == ' ' || *ptr == '\t'))
+ ptr--; /* skip trailing whitespace */
+ if (*ptr == '\\')
+ {
+ cont = TRUE;
+ /* set '\a' at the position of '\\' to make it possible to check
+ * for a line continuation in a single line comment (error 49)
+ */
+ *ptr++ = '\a';
+ *ptr = '\0'; /* erase '\n' (and any trailing whitespace) */
+ } /* if */
+ } /* if */
+ num -= strlen(line);
+ line += strlen(line);
+ } /* if */
+ fline += 1;
+ }
+ while (num >= 0 && cont);
+}
+
+/* stripcom
+ *
+ * Replaces all comments from the line by space characters. It updates
+ * a global variable ("icomment") for multiline comments.
+ *
+ * This routine also supports the C++ extension for single line comments.
+ * These comments are started with "//" and end at the end of the line.
+ *
+ * Global references: icomment (private to "stripcom")
+ */
+static void
+stripcom(char *line)
+{
+ char c;
+
+ while (*line)
+ {
+ if (icomment)
+ {
+ if (*line == '*' && *(line + 1) == '/')
+ {
+ icomment = FALSE; /* comment has ended */
+ *line = ' '; /* replace '*' and '/' characters by spaces */
+ *(line + 1) = ' ';
+ line += 2;
+ }
+ else
+ {
+ if (*line == '/' && *(line + 1) == '*')
+ error(216); /* nested comment */
+ *line = ' '; /* replace comments by spaces */
+ line += 1;
+ } /* if */
+ }
+ else
+ {
+ if (*line == '/' && *(line + 1) == '*')
+ {
+ icomment = TRUE; /* start comment */
+ *line = ' '; /* replace '/' and '*' characters by spaces */
+ *(line + 1) = ' ';
+ line += 2;
+ }
+ else if (*line == '/' && *(line + 1) == '/')
+ { /* comment to end of line */
+ if (strchr(line, '\a'))
+ error(49); /* invalid line continuation */
+ *line++ = '\n'; /* put "newline" at first slash */
+ *line = '\0'; /* put "zero-terminator" at second slash */
+ }
+ else
+ {
+ if (*line == '\"' || *line == '\'')
+ { /* leave literals unaltered */
+ c = *line; /* ending quote, single or double */
+ line += 1;
+ while ((*line != c || *(line - 1) == '\\')
+ && *line != '\0')
+ line += 1;
+ line += 1; /* skip final quote */
+ }
+ else
+ {
+ line += 1;
+ } /* if */
+ } /* if */
+ } /* if */
+ } /* while */
+}
+
+/* btoi
+ *
+ * Attempts to interpret a numeric symbol as a boolean value. On success
+ * it returns the number of characters processed (so the line pointer can be
+ * adjusted) and the value is stored in "val". Otherwise it returns 0 and
+ * "val" is garbage.
+ *
+ * A boolean value must start with "0b"
+ */
+static int
+btoi(cell * val, char *curptr)
+{
+ char *ptr;
+
+ *val = 0;
+ ptr = curptr;
+ if (*ptr == '0' && *(ptr + 1) == 'b')
+ {
+ ptr += 2;
+ while (*ptr == '0' || *ptr == '1' || *ptr == '_')
+ {
+ if (*ptr != '_')
+ *val = (*val << 1) | (*ptr - '0');
+ ptr++;
+ } /* while */
+ }
+ else
+ {
+ return 0;
+ } /* if */
+ if (alphanum(*ptr)) /* number must be delimited by non-alphanumeric char */
+ return 0;
+ else
+ return (int)(ptr - curptr);
+}
+
+/* dtoi
+ *
+ * Attempts to interpret a numeric symbol as a decimal value. On success
+ * it returns the number of characters processed and the value is stored in
+ * "val". Otherwise it returns 0 and "val" is garbage.
+ */
+static int
+dtoi(cell * val, char *curptr)
+{
+ char *ptr;
+
+ *val = 0;
+ ptr = curptr;
+ if (!sc_isdigit(*ptr)) /* should start with digit */
+ return 0;
+ while (sc_isdigit(*ptr) || *ptr == '_')
+ {
+ if (*ptr != '_')
+ *val = (*val * 10) + (*ptr - '0');
+ ptr++;
+ } /* while */
+ if (alphanum(*ptr)) /* number must be delimited by non-alphanumerical */
+ return 0;
+ if (*ptr == '.' && sc_isdigit(*(ptr + 1)))
+ return 0; /* but a fractional part must not be present */
+ return (int)(ptr - curptr);
+}
+
+/* htoi
+ *
+ * Attempts to interpret a numeric symbol as a hexadecimal value. On
+ * success it returns the number of characters processed and the value is
+ * stored in "val". Otherwise it return 0 and "val" is garbage.
+ */
+static int
+htoi(cell * val, char *curptr)
+{
+ char *ptr;
+
+ *val = 0;
+ ptr = curptr;
+ if (!sc_isdigit(*ptr)) /* should start with digit */
+ return 0;
+ if (*ptr == '0' && *(ptr + 1) == 'x')
+ { /* C style hexadecimal notation */
+ ptr += 2;
+ while (sc_isxdigit(*ptr) || *ptr == '_')
+ {
+ if (*ptr != '_')
+ {
+ assert(sc_isxdigit(*ptr));
+ *val = *val << 4;
+ if (sc_isdigit(*ptr))
+ *val += (*ptr - '0');
+ else
+ *val += (tolower(*ptr) - 'a' + 10);
+ } /* if */
+ ptr++;
+ } /* while */
+ }
+ else
+ {
+ return 0;
+ } /* if */
+ if (alphanum(*ptr))
+ return 0;
+ else
+ return (int)(ptr - curptr);
+}
+
+#if defined LINUX
+static double
+pow10(int value)
+{
+ double res = 1.0;
+
+ while (value >= 4)
+ {
+ res *= 10000.0;
+ value -= 5;
+ } /* while */
+ while (value >= 2)
+ {
+ res *= 100.0;
+ value -= 2;
+ } /* while */
+ while (value >= 1)
+ {
+ res *= 10.0;
+ value -= 1;
+ } /* while */
+ return res;
+}
+#endif
+
+/* ftoi
+ *
+ * Attempts to interpret a numeric symbol as a rational number, either as
+ * IEEE 754 single precision floating point or as a fixed point integer.
+ * On success it returns the number of characters processed and the value is
+ * stored in "val". Otherwise it returns 0 and "val" is unchanged.
+ *
+ * Small has stricter definition for floating point numbers than most:
+ * o the value must start with a digit; ".5" is not a valid number, you
+ * should write "0.5"
+ * o a period must appear in the value, even if an exponent is given; "2e3"
+ * is not a valid number, you should write "2.0e3"
+ * o at least one digit must follow the period; "6." is not a valid number,
+ * you should write "6.0"
+ */
+static int
+ftoi(cell * val, char *curptr)
+{
+ char *ptr;
+ double fnum, ffrac, fmult;
+ unsigned long dnum, dbase;
+ int i, ignore;
+
+ assert(rational_digits >= 0 && rational_digits < 9);
+ for (i = 0, dbase = 1; i < rational_digits; i++)
+ dbase *= 10;
+ fnum = 0.0;
+ dnum = 0L;
+ ptr = curptr;
+ if (!sc_isdigit(*ptr)) /* should start with digit */
+ return 0;
+ while (sc_isdigit(*ptr) || *ptr == '_')
+ {
+ if (*ptr != '_')
+ {
+ fnum = (fnum * 10.0) + (*ptr - '0');
+ dnum = (dnum * 10L) + (*ptr - '0') * dbase;
+ } /* if */
+ ptr++;
+ } /* while */
+ if (*ptr != '.')
+ return 0; /* there must be a period */
+ ptr++;
+ if (!sc_isdigit(*ptr)) /* there must be at least one digit after the dot */
+ return 0;
+ ffrac = 0.0;
+ fmult = 1.0;
+ ignore = FALSE;
+ while (sc_isdigit(*ptr) || *ptr == '_')
+ {
+ if (*ptr != '_')
+ {
+ ffrac = (ffrac * 10.0) + (*ptr - '0');
+ fmult = fmult / 10.0;
+ dbase /= 10L;
+ dnum += (*ptr - '0') * dbase;
+ if (dbase == 0L && sc_rationaltag && rational_digits > 0
+ && !ignore)
+ {
+ error(222); /* number of digits exceeds rational number precision */
+ ignore = TRUE;
+ } /* if */
+ } /* if */
+ ptr++;
+ } /* while */
+ fnum += ffrac * fmult; /* form the number so far */
+ if (*ptr == 'e')
+ { /* optional fractional part */
+ int exp, sign;
+
+ ptr++;
+ if (*ptr == '-')
+ {
+ sign = -1;
+ ptr++;
+ }
+ else
+ {
+ sign = 1;
+ } /* if */
+ if (!sc_isdigit(*ptr)) /* 'e' should be followed by a digit */
+ return 0;
+ exp = 0;
+ while (sc_isdigit(*ptr))
+ {
+ exp = (exp * 10) + (*ptr - '0');
+ ptr++;
+ } /* while */
+#if defined LINUX
+ fmult = pow10(exp * sign);
+#else
+ fmult = pow(10, exp * sign);
+#endif
+ fnum *= fmult;
+ dnum *= (unsigned long)(fmult + 0.5);
+ } /* if */
+
+ /* decide how to store the number */
+ if (sc_rationaltag == 0)
+ {
+ error(70); /* rational number support was not enabled */
+ *val = 0;
+ }
+ else if (rational_digits == 0)
+ {
+ float f = (float) fnum;
+ /* floating point */
+ *val = EMBRYO_FLOAT_TO_CELL(f);
+#if !defined NDEBUG
+ /* I assume that the C/C++ compiler stores "float" values in IEEE 754
+ * format (as mandated in the ANSI standard). Test this assumption anyway.
+ */
+ {
+ float test1 = 0.0, test2 = 50.0;
+ Embryo_Cell c1 = EMBRYO_FLOAT_TO_CELL(test1);
+ Embryo_Cell c2 = EMBRYO_FLOAT_TO_CELL(test2);
+
+ if (c1 != 0x00000000L)
+ {
+ fprintf(stderr,
+ "embryo_cc: WARNING! you compiler does not SEEM to interpret IEEE floating\n"
+ "point math as embryo expects. this could be bad.\n"
+ "\n"
+ "(float 0.0 != 0x00000000 bitpattern, 0x%08x instead)\n"
+ "\n"
+ "this could be an issue with you compiling embryo with gcc 3.2.x that seems\n"
+ "to trigger this sanity check. we are not sure why yet, but gcc 3.3.x works\n"
+ , c1);
+ }
+ else if (c2 != 0x42480000L)
+ {
+ fprintf(stderr,
+ "embryo_cc: WARNING! you compiler does not SEEM to interpret IEEE floating\n"
+ "point math as embryo expects. This could be bad.\n"
+ "\n"
+ "(float 50.0 != 0x42480000 bitpattern, 0x%08x instead)\n"
+ "\n"
+ "this could be an issue with you compiling embryo with gcc 3.2.x that seems\n"
+ "to trigger this sanity check. we are not sure why yet, but gcc 3.3.x works\n"
+ , c2);
+ }
+ }
+#endif
+ }
+ else
+ {
+ /* fixed point */
+ *val = (cell) dnum;
+ } /* if */
+
+ return (int)(ptr - curptr);
+}
+
+/* number
+ *
+ * Reads in a number (binary, decimal or hexadecimal). It returns the number
+ * of characters processed or 0 if the symbol couldn't be interpreted as a
+ * number (in this case the argument "val" remains unchanged). This routine
+ * relies on the 'early dropout' implementation of the logical or (||)
+ * operator.
+ *
+ * Note: the routine doesn't check for a sign (+ or -). The - is checked
+ * for at "hier2()" (in fact, it is viewed as an operator, not as a
+ * sign) and the + is invalid (as in K&R C, and unlike ANSI C).
+ */
+static int
+number(cell * val, char *curptr)
+{
+ int i;
+ cell value;
+
+ if ((i = btoi(&value, curptr)) != 0 /* binary? */
+ || (i = htoi(&value, curptr)) != 0 /* hexadecimal? */
+ || (i = dtoi(&value, curptr)) != 0) /* decimal? */
+ {
+ *val = value;
+ return i;
+ }
+ else
+ {
+ return 0; /* else not a number */
+ } /* if */
+}
+
+static void
+chrcat(char *str, char chr)
+{
+ str = strchr(str, '\0');
+ *str++ = chr;
+ *str = '\0';
+}
+
+static int
+preproc_expr(cell * val, int *tag)
+{
+ int result;
+ int idx;
+ cell code_index;
+ char *term;
+
+ /* Disable staging; it should be disabled already because
+ * expressions may not be cut off half-way between conditional
+ * compilations. Reset the staging index, but keep the code
+ * index.
+ */
+ if (stgget(&idx, &code_index))
+ {
+ error(57); /* unfinished expression */
+ stgdel(0, code_index);
+ stgset(FALSE);
+ } /* if */
+ /* append a special symbol to the string, so the expression
+ * analyzer won't try to read a next line when it encounters
+ * an end-of-line
+ */
+ assert(strlen(pline) < sLINEMAX);
+ term = strchr(pline, '\0');
+ assert(term != NULL);
+ chrcat(pline, PREPROC_TERM); /* the "DEL" code (see SC.H) */
+ result = constexpr(val, tag); /* get value (or 0 on error) */
+ *term = '\0'; /* erase the token (if still present) */
+ lexclr(FALSE); /* clear any "pushed" tokens */
+ return result;
+}
+
+/* getstring
+ * Returns returns a pointer behind the closing quote or to the other
+ * character that caused the input to be ended.
+ */
+static char *
+getstring(char *dest, int max)
+{
+ assert(dest != NULL);
+ *dest = '\0';
+ while (*lptr <= ' ' && *lptr != '\0')
+ lptr++; /* skip whitespace */
+ if (*lptr != '"')
+ {
+ error(37); /* invalid string */
+ }
+ else
+ {
+ int len = 0;
+
+ lptr++; /* skip " */
+ while (*lptr != '"' && *lptr != '\0')
+ {
+ if (len < max - 1)
+ dest[len++] = *lptr;
+ lptr++;
+ } /* if */
+ dest[len] = '\0';
+ if (*lptr == '"')
+ lptr++; /* skip closing " */
+ else
+ error(37); /* invalid string */
+ } /* if */
+ return lptr;
+}
+
+enum
+{
+ CMD_NONE,
+ CMD_TERM,
+ CMD_EMPTYLINE,
+ CMD_CONDFALSE,
+ CMD_INCLUDE,
+ CMD_DEFINE,
+ CMD_IF,
+ CMD_DIRECTIVE,
+};
+
+/* command
+ *
+ * Recognizes the compiler directives. The function returns:
+ * CMD_NONE the line must be processed
+ * CMD_TERM a pending expression must be completed before processing further lines
+ * Other value: the line must be skipped, because:
+ * CMD_CONDFALSE false "#if.." code
+ * CMD_EMPTYLINE line is empty
+ * CMD_INCLUDE the line contains a #include directive
+ * CMD_DEFINE the line contains a #subst directive
+ * CMD_IF the line contains a #if/#else/#endif directive
+ * CMD_DIRECTIVE the line contains some other compiler directive
+ *
+ * Global variables: iflevel, skiplevel, elsedone (altered)
+ * lptr (altered)
+ */
+static int
+command(void)
+{
+ int tok, ret;
+ cell val;
+ char *str;
+ int idx;
+ cell code_index;
+
+ while (*lptr <= ' ' && *lptr != '\0')
+ lptr += 1;
+ if (*lptr == '\0')
+ return CMD_EMPTYLINE; /* empty line */
+ if (*lptr != '#')
+ return skiplevel > 0 ? CMD_CONDFALSE : CMD_NONE; /* it is not a compiler directive */
+ /* compiler directive found */
+ indent_nowarn = TRUE; /* allow loose indentation" */
+ lexclr(FALSE); /* clear any "pushed" tokens */
+ /* on a pending expression, force to return a silent ';' token and force to
+ * re-read the line
+ */
+ if (!sc_needsemicolon && stgget(&idx, &code_index))
+ {
+ lptr = term_expr;
+ return CMD_TERM;
+ } /* if */
+ tok = lex(&val, &str);
+ ret = skiplevel > 0 ? CMD_CONDFALSE : CMD_DIRECTIVE; /* preset 'ret' to CMD_DIRECTIVE (most common case) */
+ switch (tok)
+ {
+ case tpIF: /* conditional compilation */
+ ret = CMD_IF;
+ iflevel += 1;
+ if (skiplevel)
+ break; /* break out of switch */
+ preproc_expr(&val, NULL); /* get value (or 0 on error) */
+ if (!val)
+ skiplevel = iflevel;
+ check_empty(lptr);
+ break;
+ case tpELSE:
+ ret = CMD_IF;
+ if (iflevel == 0 && skiplevel == 0)
+ {
+ error(26); /* no matching #if */
+ errorset(sRESET);
+ }
+ else
+ {
+ if (elsedone == iflevel)
+ error(60); /* multiple #else directives between #if ... #endif */
+ elsedone = iflevel;
+ if (skiplevel == iflevel)
+ skiplevel = 0;
+ else if (skiplevel == 0)
+ skiplevel = iflevel;
+ } /* if */
+ check_empty(lptr);
+ break;
+#if 0 /* ??? *really* need to use a stack here */
+ case tpELSEIF:
+ ret = CMD_IF;
+ if (iflevel == 0 && skiplevel == 0)
+ {
+ error(26); /* no matching #if */
+ errorset(sRESET);
+ }
+ else if (elsedone == iflevel)
+ {
+ error(61); /* #elseif directive may not follow an #else */
+ errorset(sRESET);
+ }
+ else
+ {
+ preproc_expr(&val, NULL); /* get value (or 0 on error) */
+ if (skiplevel == 0)
+ skiplevel = iflevel; /* we weren't skipping, start skipping now */
+ else if (val)
+ skiplevel = 0; /* we were skipping, condition is valid -> stop skipping */
+ /* else: we were skipping and condition is invalid -> keep skipping */
+ check_empty(lptr);
+ } /* if */
+ break;
+#endif
+ case tpENDIF:
+ ret = CMD_IF;
+ if (iflevel == 0 && skiplevel == 0)
+ {
+ error(26);
+ errorset(sRESET);
+ }
+ else
+ {
+ if (skiplevel == iflevel)
+ skiplevel = 0;
+ if (elsedone == iflevel)
+ elsedone = 0; /* ??? actually, should build a stack of #if/#endif and keep
+ * the state whether an #else was seen per nesting level */
+ iflevel -= 1;
+ } /* if */
+ check_empty(lptr);
+ break;
+ case tINCLUDE: /* #include directive */
+ ret = CMD_INCLUDE;
+ if (skiplevel == 0)
+ doinclude();
+ break;
+ case tpFILE:
+ if (skiplevel == 0)
+ {
+ char pathname[PATH_MAX];
+
+ lptr = getstring(pathname, sizeof pathname);
+ if (pathname[0] != '\0')
+ {
+ free(inpfname);
+ inpfname = strdup(pathname);
+ if (!inpfname)
+ error(103); /* insufficient memory */
+ } /* if */
+ } /* if */
+ check_empty(lptr);
+ break;
+ case tpLINE:
+ if (skiplevel == 0)
+ {
+ if (lex(&val, &str) != tNUMBER)
+ error(8); /* invalid/non-constant expression */
+ fline = (int)val;
+
+ while (*lptr == ' ' && *lptr != '\0')
+ lptr++; /* skip whitespace */
+ if (*lptr == '"')
+ {
+ char pathname[PATH_MAX];
+
+ lptr = getstring(pathname, sizeof pathname);
+ if (pathname[0] != '\0')
+ {
+ free(inpfname);
+ inpfname = strdup(pathname);
+ if (!inpfname)
+ error(103); /* insufficient memory */
+ } /* if */
+ }
+ } /* if */
+ check_empty(lptr);
+ break;
+ case tpASSERT:
+ if (skiplevel == 0 && (sc_debug & sCHKBOUNDS) != 0)
+ {
+ preproc_expr(&val, NULL); /* get constant expression (or 0 on error) */
+ if (!val)
+ error(7); /* assertion failed */
+ check_empty(lptr);
+ } /* if */
+ break;
+ case tpPRAGMA:
+ if (skiplevel == 0)
+ {
+ if (lex(&val, &str) == tSYMBOL)
+ {
+ if (strcmp(str, "ctrlchar") == 0)
+ {
+ if (lex(&val, &str) != tNUMBER)
+ error(27); /* invalid character constant */
+ sc_ctrlchar = (char)val;
+ }
+ else if (strcmp(str, "compress") == 0)
+ {
+ cell val;
+
+ preproc_expr(&val, NULL);
+ sc_compress = (int)val; /* switch code packing on/off */
+ }
+ else if (strcmp(str, "dynamic") == 0)
+ {
+ preproc_expr(&sc_stksize, NULL);
+ }
+ else if (strcmp(str, "library") == 0)
+ {
+ char name[sNAMEMAX + 1];
+
+ while (*lptr <= ' ' && *lptr != '\0')
+ lptr++;
+ if (*lptr == '"')
+ {
+ lptr = getstring(name, sizeof name);
+ }
+ else
+ {
+ int i;
+
+ for (i = 0;
+ (i < (int)(sizeof(name))) &&
+ (alphanum(*lptr));
+ i++, lptr++)
+ name[i] = *lptr;
+ name[i] = '\0';
+ } /* if */
+ if (name[0] == '\0')
+ {
+ curlibrary = NULL;
+ }
+ else
+ {
+ if (strlen(name) > sEXPMAX)
+ error(220, name, sEXPMAX); /* exported symbol is truncated */
+ /* add the name if it does not yet exist in the table */
+ if (!find_constval(&libname_tab, name, 0))
+ curlibrary =
+ append_constval(&libname_tab, name, 0, 0);
+ } /* if */
+ }
+ else if (strcmp(str, "pack") == 0)
+ {
+ cell val;
+
+ preproc_expr(&val, NULL); /* default = packed/unpacked */
+ sc_packstr = (int)val;
+ }
+ else if (strcmp(str, "rational") == 0)
+ {
+ char name[sNAMEMAX + 1];
+ cell digits = 0;
+ int i;
+
+ /* first gather all information, start with the tag name */
+ while ((*lptr <= ' ') && (*lptr != '\0'))
+ lptr++;
+ for (i = 0;
+ (i < (int)(sizeof(name))) &&
+ (alphanum(*lptr));
+ i++, lptr++)
+ name[i] = *lptr;
+ name[i] = '\0';
+ /* then the precision (for fixed point arithmetic) */
+ while (*lptr <= ' ' && *lptr != '\0')
+ lptr++;
+ if (*lptr == '(')
+ {
+ preproc_expr(&digits, NULL);
+ if (digits <= 0 || digits > 9)
+ {
+ error(68); /* invalid rational number precision */
+ digits = 0;
+ } /* if */
+ if (*lptr == ')')
+ lptr++;
+ } /* if */
+ /* add the tag (make it public) and check the values */
+ i = sc_addtag(name);
+ exporttag(i);
+ if (sc_rationaltag == 0
+ || (sc_rationaltag == i
+ && rational_digits == (int)digits))
+ {
+ sc_rationaltag = i;
+ rational_digits = (int)digits;
+ }
+ else
+ {
+ error(69); /* rational number format already set, can only be set once */
+ } /* if */
+ }
+ else if (strcmp(str, "semicolon") == 0)
+ {
+ cell val;
+
+ preproc_expr(&val, NULL);
+ sc_needsemicolon = (int)val;
+ }
+ else if (strcmp(str, "tabsize") == 0)
+ {
+ cell val;
+
+ preproc_expr(&val, NULL);
+ sc_tabsize = (int)val;
+ }
+ else if (strcmp(str, "align") == 0)
+ {
+ sc_alignnext = TRUE;
+ }
+ else if (strcmp(str, "unused") == 0)
+ {
+ char name[sNAMEMAX + 1];
+ int i, comma;
+ symbol *sym;
+
+ do
+ {
+ /* get the name */
+ while ((*lptr <= ' ') && (*lptr != '\0'))
+ lptr++;
+ for (i = 0;
+ (i < (int)(sizeof(name))) &&
+ (sc_isalpha(*lptr));
+ i++, lptr++)
+ name[i] = *lptr;
+ name[i] = '\0';
+ /* get the symbol */
+ sym = findloc(name);
+ if (!sym)
+ sym = findglb(name);
+ if (sym)
+ {
+ sym->usage |= uREAD;
+ if (sym->ident == iVARIABLE
+ || sym->ident == iREFERENCE
+ || sym->ident == iARRAY
+ || sym->ident == iREFARRAY)
+ sym->usage |= uWRITTEN;
+ }
+ else
+ {
+ error(17, name); /* undefined symbol */
+ } /* if */
+ /* see if a comma follows the name */
+ while (*lptr <= ' ' && *lptr != '\0')
+ lptr++;
+ comma = (*lptr == ',');
+ if (comma)
+ lptr++;
+ }
+ while (comma);
+ }
+ else
+ {
+ error(207); /* unknown #pragma */
+ } /* if */
+ }
+ else
+ {
+ error(207); /* unknown #pragma */
+ } /* if */
+ check_empty(lptr);
+ } /* if */
+ break;
+ case tpENDINPUT:
+ case tpENDSCRPT:
+ if (skiplevel == 0)
+ {
+ check_empty(lptr);
+ assert(inpf != NULL);
+ if (inpf != inpf_org)
+ sc_closesrc(inpf);
+ inpf = NULL;
+ } /* if */
+ break;
+#if !defined NOEMIT
+ case tpEMIT:
+ {
+ /* write opcode to output file */
+ char name[40];
+ int i;
+
+ while (*lptr <= ' ' && *lptr != '\0')
+ lptr++;
+ for (i = 0; i < 40 && (sc_isalpha(*lptr) || *lptr == '.'); i++, lptr++)
+ name[i] = (char)tolower(*lptr);
+ name[i] = '\0';
+ stgwrite("\t");
+ stgwrite(name);
+ stgwrite(" ");
+ code_idx += opcodes(1);
+ /* write parameter (if any) */
+ while (*lptr <= ' ' && *lptr != '\0')
+ lptr++;
+ if (*lptr != '\0')
+ {
+ symbol *sym;
+
+ tok = lex(&val, &str);
+ switch (tok)
+ {
+ case tNUMBER:
+ case tRATIONAL:
+ outval(val, FALSE);
+ code_idx += opargs(1);
+ break;
+ case tSYMBOL:
+ sym = findloc(str);
+ if (!sym)
+ sym = findglb(str);
+ if (!sym || (sym->ident != iFUNCTN
+ && sym->ident != iREFFUNC
+ && (sym->usage & uDEFINE) == 0))
+ {
+ error(17, str); /* undefined symbol */
+ }
+ else
+ {
+ outval(sym->addr, FALSE);
+ /* mark symbol as "used", unknown whether for read or write */
+ markusage(sym, uREAD | uWRITTEN);
+ code_idx += opargs(1);
+ } /* if */
+ break;
+ default:
+ {
+ char s2[20];
+ extern char *sc_tokens[]; /* forward declaration */
+
+ if (tok < 256)
+ sprintf(s2, "%c", (char)tok);
+ else
+ strcpy(s2, sc_tokens[tok - tFIRST]);
+ error(1, sc_tokens[tSYMBOL - tFIRST], s2);
+ break;
+ } /* case */
+ } /* switch */
+ } /* if */
+ stgwrite("\n");
+ check_empty(lptr);
+ break;
+ } /* case */
+#endif
+#if !defined NO_DEFINE
+ case tpDEFINE:
+ {
+ ret = CMD_DEFINE;
+ if (skiplevel == 0)
+ {
+ char *pattern, *substitution;
+ char *start, *end;
+ int count, prefixlen;
+ stringpair *def;
+
+ /* find the pattern to match */
+ while (*lptr <= ' ' && *lptr != '\0')
+ lptr++;
+ start = lptr; /* save starting point of the match pattern */
+ count = 0;
+ while (*lptr > ' ' && *lptr != '\0')
+ {
+ litchar(&lptr, FALSE); /* litchar() advances "lptr" and handles escape characters */
+ count++;
+ } /* while */
+ end = lptr;
+ /* check pattern to match */
+ if (!sc_isalpha(*start) && *start != '_')
+ {
+ error(74); /* pattern must start with an alphabetic character */
+ break;
+ } /* if */
+ /* store matched pattern */
+ pattern = malloc(count + 1);
+ if (!pattern)
+ error(103); /* insufficient memory */
+ lptr = start;
+ count = 0;
+ while (lptr != end)
+ {
+ assert(lptr < end);
+ assert(*lptr != '\0');
+ pattern[count++] = (char)litchar(&lptr, FALSE);
+ } /* while */
+ pattern[count] = '\0';
+ /* special case, erase trailing variable, because it could match anything */
+ if (count >= 2 && sc_isdigit(pattern[count - 1])
+ && pattern[count - 2] == '%')
+ pattern[count - 2] = '\0';
+ /* find substitution string */
+ while (*lptr <= ' ' && *lptr != '\0')
+ lptr++;
+ start = lptr; /* save starting point of the match pattern */
+ count = 0;
+ end = NULL;
+ while (*lptr != '\0')
+ {
+ /* keep position of the start of trailing whitespace */
+ if (*lptr <= ' ')
+ {
+ if (!end)
+ end = lptr;
+ }
+ else
+ {
+ end = NULL;
+ } /* if */
+ count++;
+ lptr++;
+ } /* while */
+ if (!end)
+ end = lptr;
+ /* store matched substitution */
+ substitution = malloc(count + 1); /* +1 for '\0' */
+ if (!substitution)
+ error(103); /* insufficient memory */
+ lptr = start;
+ count = 0;
+ while (lptr != end)
+ {
+ assert(lptr < end);
+ assert(*lptr != '\0');
+ substitution[count++] = *lptr++;
+ } /* while */
+ substitution[count] = '\0';
+ /* check whether the definition already exists */
+ for (prefixlen = 0, start = pattern;
+ sc_isalpha(*start) || sc_isdigit(*start) || *start == '_';
+ prefixlen++, start++)
+ /* nothing */ ;
+ assert(prefixlen > 0);
+ if ((def = find_subst(pattern, prefixlen)))
+ {
+ if (strcmp(def->first, pattern) != 0
+ || strcmp(def->second, substitution) != 0)
+ error(201, pattern); /* redefinition of macro (non-identical) */
+ delete_subst(pattern, prefixlen);
+ } /* if */
+ /* add the pattern/substitution pair to the list */
+ assert(pattern[0] != '\0');
+ insert_subst(pattern, substitution, prefixlen);
+ free(pattern);
+ free(substitution);
+ } /* if */
+ break;
+ } /* case */
+ case tpUNDEF:
+ if (skiplevel == 0)
+ {
+ if (lex(&val, &str) == tSYMBOL)
+ {
+ if (!delete_subst(str, strlen(str)))
+ error(17, str); /* undefined symbol */
+ }
+ else
+ {
+ error(20, str); /* invalid symbol name */
+ } /* if */
+ check_empty(lptr);
+ } /* if */
+ break;
+#endif
+ default:
+ error(31); /* unknown compiler directive */
+ ret = skiplevel > 0 ? CMD_DIRECTIVE : CMD_NONE; /* line must be processed (if skiplevel==0) */
+ } /* switch */
+ return ret;
+}
+
+#if !defined NO_DEFINE
+static int
+is_startstring(char *string)
+{
+ if (*string == '\"' || *string == '\'')
+ return TRUE; /* "..." */
+
+ if (*string == '!')
+ {
+ string++;
+ if (*string == '\"' || *string == '\'')
+ return TRUE; /* !"..." */
+ if (*string == sc_ctrlchar)
+ {
+ string++;
+ if (*string == '\"' || *string == '\'')
+ return TRUE; /* !\"..." */
+ } /* if */
+ }
+ else if (*string == sc_ctrlchar)
+ {
+ string++;
+ if (*string == '\"' || *string == '\'')
+ return TRUE; /* \"..." */
+ if (*string == '!')
+ {
+ string++;
+ if (*string == '\"' || *string == '\'')
+ return TRUE; /* \!"..." */
+ } /* if */
+ } /* if */
+
+ return FALSE;
+}
+
+static char *
+skipstring(char *string)
+{
+ char endquote;
+ int rawstring = FALSE;
+
+ while (*string == '!' || *string == sc_ctrlchar)
+ {
+ rawstring = (*string == sc_ctrlchar);
+ string++;
+ } /* while */
+
+ endquote = *string;
+ assert(endquote == '\"' || endquote == '\'');
+ string++; /* skip open quote */
+ while (*string != endquote && *string != '\0')
+ litchar(&string, rawstring);
+ return string;
+}
+
+static char *
+skippgroup(char *string)
+{
+ int nest = 0;
+ char open = *string;
+ char close;
+
+ switch (open)
+ {
+ case '(':
+ close = ')';
+ break;
+ case '{':
+ close = '}';
+ break;
+ case '[':
+ close = ']';
+ break;
+ case '<':
+ close = '>';
+ break;
+ default:
+ assert(0);
+ close = '\0'; /* only to avoid a compiler warning */
+ } /* switch */
+
+ string++;
+ while (*string != close || nest > 0)
+ {
+ if (*string == open)
+ nest++;
+ else if (*string == close)
+ nest--;
+ else if (is_startstring(string))
+ string = skipstring(string);
+ if (*string == '\0')
+ break;
+ string++;
+ } /* while */
+ return string;
+}
+
+static char *
+strdel(char *str, size_t len)
+{
+ size_t length = strlen(str);
+
+ if (len > length)
+ len = length;
+ memmove(str, str + len, length - len + 1); /* include EOS byte */
+ return str;
+}
+
+static char *
+strins(char *dest, char *src, size_t srclen)
+{
+ size_t destlen = strlen(dest);
+
+ assert(srclen <= strlen(src));
+ memmove(dest + srclen, dest, destlen + 1); /* include EOS byte */
+ memcpy(dest, src, srclen);
+ return dest;
+}
+
+static int
+substpattern(char *line, size_t buffersize, char *pattern, char *substitution)
+{
+ int prefixlen;
+ char *p, *s, *e, *args[10];
+ int match, arg, len;
+
+ memset(args, 0, sizeof args);
+
+ /* check the length of the prefix */
+ for (prefixlen = 0, s = pattern; sc_isalpha(*s) || sc_isdigit(*s) || *s == '_';
+ prefixlen++, s++)
+ /* nothing */ ;
+ assert(prefixlen > 0);
+ assert(strncmp(line, pattern, prefixlen) == 0);
+
+ /* pattern prefix matches; match the rest of the pattern, gather
+ * the parameters
+ */
+ s = line + prefixlen;
+ p = pattern + prefixlen;
+ match = TRUE; /* so far, pattern matches */
+ while (match && *s != '\0' && *p != '\0')
+ {
+ if (*p == '%')
+ {
+ p++; /* skip '%' */
+ if (sc_isdigit(*p))
+ {
+ arg = *p - '0';
+ assert(arg >= 0 && arg <= 9);
+ p++; /* skip parameter id */
+ assert(*p != '\0');
+ /* match the source string up to the character after the digit
+ * (skipping strings in the process
+ */
+ e = s;
+ while (*e != *p && *e != '\0' && *e != '\n')
+ {
+ if (is_startstring(e)) /* skip strings */
+ e = skipstring(e);
+ else if (strchr("({[", *e)) /* skip parenthized groups */
+ e = skippgroup(e);
+ if (*e != '\0')
+ e++; /* skip non-alphapetic character (or closing quote of
+ * a string, or the closing paranthese of a group) */
+ } /* while */
+ /* store the parameter (overrule any earlier) */
+ if (args[arg])
+ free(args[arg]);
+ len = (int)(e - s);
+ args[arg] = malloc(len + 1);
+ if (!args[arg])
+ error(103); /* insufficient memory */
+ strncpy(args[arg], s, len);
+ args[arg][len] = '\0';
+ /* character behind the pattern was matched too */
+ if (*e == *p)
+ {
+ s = e + 1;
+ }
+ else if (*e == '\n' && *p == ';' && *(p + 1) == '\0'
+ && !sc_needsemicolon)
+ {
+ s = e; /* allow a trailing ; in the pattern match to end of line */
+ }
+ else
+ {
+ assert(*e == '\0' || *e == '\n');
+ match = FALSE;
+ s = e;
+ } /* if */
+ p++;
+ }
+ else
+ {
+ match = FALSE;
+ } /* if */
+ }
+ else if (*p == ';' && *(p + 1) == '\0' && !sc_needsemicolon)
+ {
+ /* source may be ';' or end of the line */
+ while (*s <= ' ' && *s != '\0')
+ s++; /* skip white space */
+ if (*s != ';' && *s != '\0')
+ match = FALSE;
+ p++; /* skip the semicolon in the pattern */
+ }
+ else
+ {
+ cell ch;
+
+ /* skip whitespace between two non-alphanumeric characters, except
+ * for two identical symbols
+ */
+ assert(p > pattern);
+ if (!alphanum(*p) && *(p - 1) != *p)
+ while (*s <= ' ' && *s != '\0')
+ s++; /* skip white space */
+ ch = litchar(&p, FALSE); /* this increments "p" */
+ if (*s != ch)
+ match = FALSE;
+ else
+ s++; /* this character matches */
+ } /* if */
+ } /* while */
+
+ if (match && *p == '\0')
+ {
+ /* if the last character to match is an alphanumeric character, the
+ * current character in the source may not be alphanumeric
+ */
+ assert(p > pattern);
+ if (alphanum(*(p - 1)) && alphanum(*s))
+ match = FALSE;
+ } /* if */
+
+ if (match)
+ {
+ /* calculate the length of the substituted string */
+ for (e = substitution, len = 0; *e != '\0'; e++)
+ {
+ if (*e == '%' && sc_isdigit(*(e + 1)))
+ {
+ arg = *(e + 1) - '0';
+ assert(arg >= 0 && arg <= 9);
+ if (args[arg])
+ len += strlen(args[arg]);
+ e++; /* skip %, digit is skipped later */
+ }
+ else
+ {
+ len++;
+ } /* if */
+ } /* for */
+ /* check length of the string after substitution */
+ if (strlen(line) + len - (int)(s - line) > buffersize)
+ {
+ error(75); /* line too long */
+ }
+ else
+ {
+ /* substitute pattern */
+ strdel(line, (int)(s - line));
+ for (e = substitution, s = line; *e != '\0'; e++)
+ {
+ if (*e == '%' && sc_isdigit(*(e + 1)))
+ {
+ arg = *(e + 1) - '0';
+ assert(arg >= 0 && arg <= 9);
+ if (args[arg])
+ {
+ strins(s, args[arg], strlen(args[arg]));
+ s += strlen(args[arg]);
+ } /* if */
+ e++; /* skip %, digit is skipped later */
+ }
+ else
+ {
+ strins(s, e, 1);
+ s++;
+ } /* if */
+ } /* for */
+ } /* if */
+ } /* if */
+
+ for (arg = 0; arg < 10; arg++)
+ if (args[arg])
+ free(args[arg]);
+
+ return match;
+}
+
+static void
+substallpatterns(char *line, int buffersize)
+{
+ char *start, *end;
+ int prefixlen;
+ stringpair *subst;
+
+ start = line;
+ while (*start != '\0')
+ {
+ /* find the start of a prefix (skip all non-alphabetic characters),
+ * also skip strings
+ */
+ while (!sc_isalpha(*start) && *start != '_' && *start != '\0')
+ {
+ /* skip strings */
+ if (is_startstring(start))
+ {
+ start = skipstring(start);
+ if (*start == '\0')
+ break; /* abort loop on error */
+ } /* if */
+ start++; /* skip non-alphapetic character (or closing quote of a string) */
+ } /* while */
+ if (*start == '\0')
+ break; /* abort loop on error */
+ /* get the prefix (length), look for a matching definition */
+ prefixlen = 0;
+ end = start;
+ while (sc_isalpha(*end) || sc_isdigit(*end) || *end == '_')
+ {
+ prefixlen++;
+ end++;
+ } /* while */
+ assert(prefixlen > 0);
+ subst = find_subst(start, prefixlen);
+ if (subst)
+ {
+ /* properly match the pattern and substitute */
+ if (!substpattern
+ (start, buffersize - (start - line), subst->first,
+ subst->second))
+ start = end; /* match failed, skip this prefix */
+ /* match succeeded: do not update "start", because the substitution text
+ * may be matched by other macros
+ */
+ }
+ else
+ {
+ start = end; /* no macro with this prefix, skip this prefix */
+ } /* if */
+ } /* while */
+}
+#endif
+
+/* preprocess
+ *
+ * Reads a line by readline() into "pline" and performs basic preprocessing:
+ * deleting comments, skipping lines with false "#if.." code and recognizing
+ * other compiler directives. There is an indirect recursion: lex() calls
+ * preprocess() if a new line must be read, preprocess() calls command(),
+ * which at his turn calls lex() to identify the token.
+ *
+ * Global references: lptr (altered)
+ * pline (altered)
+ * freading (referred to only)
+ */
+void
+preprocess(void)
+{
+ int iscommand;
+
+ if (!freading)
+ return;
+ do
+ {
+ readline(pline);
+ stripcom(pline); /* ??? no need for this when reading back from list file (in the second pass) */
+ lptr = pline; /* set "line pointer" to start of the parsing buffer */
+ iscommand = command();
+ if (iscommand != CMD_NONE)
+ errorset(sRESET); /* reset error flag ("panic mode") on empty line or directive */
+#if !defined NO_DEFINE
+ if (iscommand == CMD_NONE)
+ {
+ assert(lptr != term_expr);
+ substallpatterns(pline, sLINEMAX);
+ lptr = pline; /* reset "line pointer" to start of the parsing buffer */
+ } /* if */
+#endif
+ }
+ while (iscommand != CMD_NONE && iscommand != CMD_TERM && freading); /* enddo */
+}
+
+static char *
+unpackedstring(char *lptr, int rawstring)
+{
+ while (*lptr != '\0')
+ {
+ /* check for doublequotes indicating the end of the string */
+ if (*lptr == '\"')
+ {
+ /* check whether there's another pair of quotes following.
+ * If so, paste the two strings together, thus
+ * "pants""off" becomes "pantsoff"
+ */
+ if (*(lptr + 1) == '\"')
+ lptr += 2;
+ else
+ break;
+ }
+
+ if (*lptr == '\a')
+ { /* ignore '\a' (which was inserted at a line concatenation) */
+ lptr++;
+ continue;
+ } /* if */
+ stowlit(litchar(&lptr, rawstring)); /* litchar() alters "lptr" */
+ } /* while */
+ stowlit(0); /* terminate string */
+ return lptr;
+}
+
+static char *
+packedstring(char *lptr, int rawstring)
+{
+ int i;
+ ucell val, c;
+
+ i = sizeof(ucell) - (charbits / 8); /* start at most significant byte */
+ val = 0;
+ while (*lptr != '\0')
+ {
+ /* check for doublequotes indicating the end of the string */
+ if (*lptr == '\"')
+ {
+ /* check whether there's another pair of quotes following.
+ * If so, paste the two strings together, thus
+ * "pants""off" becomes "pantsoff"
+ */
+ if (*(lptr + 1) == '\"')
+ lptr += 2;
+ else
+ break;
+ }
+
+ if (*lptr == '\a')
+ { /* ignore '\a' (which was inserted at a line concatenation) */
+ lptr++;
+ continue;
+ } /* if */
+ c = litchar(&lptr, rawstring); /* litchar() alters "lptr" */
+ if (c >= (ucell) (1 << charbits))
+ error(43); /* character constant exceeds range */
+ val |= (c << 8 * i);
+ if (i == 0)
+ {
+ stowlit(val);
+ val = 0;
+ } /* if */
+ i = (i + sizeof(ucell) - (charbits / 8)) % sizeof(ucell);
+ } /* if */
+ /* save last code; make sure there is at least one terminating zero character */
+ if (i != (int)(sizeof(ucell) - (charbits / 8)))
+ stowlit(val); /* at least one zero character in "val" */
+ else
+ stowlit(0); /* add full cell of zeros */
+ return lptr;
+}
+
+/* lex(lexvalue,lexsym) Lexical Analysis
+ *
+ * lex() first deletes leading white space, then checks for multi-character
+ * operators, keywords (including most compiler directives), numbers,
+ * labels, symbols and literals (literal characters are converted to a number
+ * and are returned as such). If every check fails, the line must contain
+ * a single-character operator. So, lex() returns this character. In the other
+ * case (something did match), lex() returns the number of the token. All
+ * these tokens have been assigned numbers above 255.
+ *
+ * Some tokens have "attributes":
+ * tNUMBER the value of the number is return in "lexvalue".
+ * tRATIONAL the value is in IEEE 754 encoding or in fixed point
+ * encoding in "lexvalue".
+ * tSYMBOL the first sNAMEMAX characters of the symbol are
+ * stored in a buffer, a pointer to this buffer is
+ * returned in "lexsym".
+ * tLABEL the first sNAMEMAX characters of the label are
+ * stored in a buffer, a pointer to this buffer is
+ * returned in "lexsym".
+ * tSTRING the string is stored in the literal pool, the index
+ * in the literal pool to this string is stored in
+ * "lexvalue".
+ *
+ * lex() stores all information (the token found and possibly its attribute)
+ * in global variables. This allows a token to be examined twice. If "_pushed"
+ * is true, this information is returned.
+ *
+ * Global references: lptr (altered)
+ * fline (referred to only)
+ * litidx (referred to only)
+ * _lextok, _lexval, _lexstr
+ * _pushed
+ */
+
+static int _pushed;
+static int _lextok;
+static cell _lexval;
+static char _lexstr[sLINEMAX + 1];
+static int _lexnewline;
+
+void
+lexinit(void)
+{
+ stkidx = 0; /* index for pushstk() and popstk() */
+ iflevel = 0; /* preprocessor: nesting of "#if" */
+ skiplevel = 0; /* preprocessor: skipping lines or compiling lines */
+ icomment = FALSE; /* currently not in a multiline comment */
+ _pushed = FALSE; /* no token pushed back into lex */
+ _lexnewline = FALSE;
+}
+
+char *sc_tokens[] = {
+ "*=", "/=", "%=", "+=", "-=", "<<=", ">>>=", ">>=", "&=", "^=", "|=",
+ "||", "&&", "==", "!=", "<=", ">=", "<<", ">>>", ">>", "++", "--",
+ "...", "..",
+ "assert", "break", "case", "char", "const", "continue", "default",
+ "defined", "do", "else", "enum", "exit", "for", "forward", "goto",
+ "if", "native", "new", "operator", "public", "return", "sizeof",
+ "sleep", "static", "stock", "switch", "tagof", "while",
+ "#assert", "#define", "#else", "#emit", "#endif", "#endinput",
+ "#endscript", "#file", "#if", "#include", "#line", "#pragma", "#undef",
+ ";", ";", "-integer value-", "-rational value-", "-identifier-",
+ "-label-", "-string-"
+};
+
+int
+lex(cell * lexvalue, char **lexsym)
+{
+ int i, toolong, newline, rawstring;
+ char **tokptr;
+
+ if (_pushed)
+ {
+ _pushed = FALSE; /* reset "_pushed" flag */
+ *lexvalue = _lexval;
+ *lexsym = _lexstr;
+ return _lextok;
+ } /* if */
+
+ _lextok = 0; /* preset all values */
+ _lexval = 0;
+ _lexstr[0] = '\0';
+ *lexvalue = _lexval;
+ *lexsym = _lexstr;
+ _lexnewline = FALSE;
+ if (!freading)
+ return 0;
+
+ newline = (lptr == pline); /* does lptr point to start of line buffer */
+ while (*lptr <= ' ')
+ { /* delete leading white space */
+ if (*lptr == '\0')
+ {
+ preprocess(); /* preprocess resets "lptr" */
+ if (!freading)
+ return 0;
+ if (lptr == term_expr) /* special sequence to terminate a pending expression */
+ return (_lextok = tENDEXPR);
+ _lexnewline = TRUE; /* set this after preprocess(), because
+ * preprocess() calls lex() recursively */
+ newline = TRUE;
+ }
+ else
+ {
+ lptr += 1;
+ } /* if */
+ } /* while */
+ if (newline)
+ {
+ stmtindent = 0;
+ for (i = 0; i < (int)(lptr - pline); i++)
+ if (pline[i] == '\t' && sc_tabsize > 0)
+ stmtindent +=
+ (int)(sc_tabsize - (stmtindent + sc_tabsize) % sc_tabsize);
+ else
+ stmtindent++;
+ } /* if */
+
+ i = tFIRST;
+ tokptr = sc_tokens;
+ while (i <= tMIDDLE)
+ { /* match multi-character operators */
+ if (match(*tokptr, FALSE))
+ {
+ _lextok = i;
+ return _lextok;
+ } /* if */
+ i += 1;
+ tokptr += 1;
+ } /* while */
+ while (i <= tLAST)
+ { /* match reserved words and compiler directives */
+ if (match(*tokptr, TRUE))
+ {
+ _lextok = i;
+ errorset(sRESET); /* reset error flag (clear the "panic mode") */
+ return _lextok;
+ } /* if */
+ i += 1;
+ tokptr += 1;
+ } /* while */
+
+ if ((i = number(&_lexval, lptr)) != 0)
+ { /* number */
+ _lextok = tNUMBER;
+ *lexvalue = _lexval;
+ lptr += i;
+ }
+ else if ((i = ftoi(&_lexval, lptr)) != 0)
+ {
+ _lextok = tRATIONAL;
+ *lexvalue = _lexval;
+ lptr += i;
+ }
+ else if (alpha(*lptr))
+ { /* symbol or label */
+ /* Note: only sNAMEMAX characters are significant. The compiler
+ * generates a warning if a symbol exceeds this length.
+ */
+ _lextok = tSYMBOL;
+ i = 0;
+ toolong = 0;
+ while (alphanum(*lptr))
+ {
+ _lexstr[i] = *lptr;
+ lptr += 1;
+ if (i < sNAMEMAX)
+ i += 1;
+ else
+ toolong = 1;
+ } /* while */
+ _lexstr[i] = '\0';
+ if (toolong)
+ error(200, _lexstr, sNAMEMAX); /* symbol too long, truncated to sNAMEMAX chars */
+ if (_lexstr[0] == PUBLIC_CHAR && _lexstr[1] == '\0')
+ {
+ _lextok = PUBLIC_CHAR; /* '@' all alone is not a symbol, it is an operator */
+ }
+ else if (_lexstr[0] == '_' && _lexstr[1] == '\0')
+ {
+ _lextok = '_'; /* '_' by itself is not a symbol, it is a placeholder */
+ } /* if */
+ if (*lptr == ':' && sc_allowtags && _lextok != PUBLIC_CHAR)
+ {
+ _lextok = tLABEL; /* it wasn't a normal symbol, it was a label/tagname */
+ lptr += 1; /* skip colon */
+ } /* if */
+ }
+ else if (*lptr == '\"' || (*lptr == sc_ctrlchar && *(lptr + 1) == '\"'))
+ { /* unpacked string literal */
+ _lextok = tSTRING;
+ rawstring = (*lptr == sc_ctrlchar);
+ *lexvalue = _lexval = litidx;
+ lptr += 1; /* skip double quote */
+ if (rawstring)
+ lptr += 1; /* skip "escape" character too */
+ lptr =
+ sc_packstr ? packedstring(lptr, rawstring) : unpackedstring(lptr,
+ rawstring);
+ if (*lptr == '\"')
+ lptr += 1; /* skip final quote */
+ else
+ error(37); /* invalid (non-terminated) string */
+ }
+ else if ((*lptr == '!' && *(lptr + 1) == '\"')
+ || (*lptr == '!' && *(lptr + 1) == sc_ctrlchar && *(lptr + 2) == '\"')
+ || (*lptr == sc_ctrlchar && *(lptr + 1) == '!'
+ && *(lptr + 2) == '\"'))
+ { /* packed string literal */
+ _lextok = tSTRING;
+ rawstring = (*lptr == sc_ctrlchar || *(lptr + 1) == sc_ctrlchar);
+ *lexvalue = _lexval = litidx;
+ lptr += 2; /* skip exclamation point and double quote */
+ if (rawstring)
+ lptr += 1; /* skip "escape" character too */
+ lptr =
+ sc_packstr ? unpackedstring(lptr, rawstring) : packedstring(lptr,
+ rawstring);
+ if (*lptr == '\"')
+ lptr += 1; /* skip final quote */
+ else
+ error(37); /* invalid (non-terminated) string */
+ }
+ else if (*lptr == '\'')
+ { /* character literal */
+ lptr += 1; /* skip quote */
+ _lextok = tNUMBER;
+ *lexvalue = _lexval = litchar(&lptr, FALSE);
+ if (*lptr == '\'')
+ lptr += 1; /* skip final quote */
+ else
+ error(27); /* invalid character constant (must be one character) */
+ }
+ else if (*lptr == ';')
+ { /* semicolumn resets "error" flag */
+ _lextok = ';';
+ lptr += 1;
+ errorset(sRESET); /* reset error flag (clear the "panic mode") */
+ }
+ else
+ {
+ _lextok = *lptr; /* if every match fails, return the character */
+ lptr += 1; /* increase the "lptr" pointer */
+ } /* if */
+ return _lextok;
+}
+
+/* lexpush
+ *
+ * Pushes a token back, so the next call to lex() will return the token
+ * last examined, instead of a new token.
+ *
+ * Only one token can be pushed back.
+ *
+ * In fact, lex() already stores the information it finds into global
+ * variables, so all that is to be done is set a flag that informs lex()
+ * to read and return the information from these variables, rather than
+ * to read in a new token from the input file.
+ */
+void
+lexpush(void)
+{
+ assert(_pushed == FALSE);
+ _pushed = TRUE;
+}
+
+/* lexclr
+ *
+ * Sets the variable "_pushed" to 0 to make sure lex() will read in a new
+ * symbol (a not continue with some old one). This is required upon return
+ * from Assembler mode.
+ */
+void
+lexclr(int clreol)
+{
+ _pushed = FALSE;
+ if (clreol)
+ {
+ lptr = strchr(pline, '\0');
+ assert(lptr != NULL);
+ } /* if */
+}
+
+/* matchtoken
+ *
+ * This routine is useful if only a simple check is needed. If the token
+ * differs from the one expected, it is pushed back.
+ */
+int
+matchtoken(int token)
+{
+ cell val;
+ char *str;
+ int tok;
+
+ tok = lex(&val, &str);
+ if (tok == token || (token == tTERM && (tok == ';' || tok == tENDEXPR)))
+ {
+ return 1;
+ }
+ else if (!sc_needsemicolon && token == tTERM && (_lexnewline || !freading))
+ {
+ lexpush(); /* push "tok" back, we use the "hidden" newline token */
+ return 1;
+ }
+ else
+ {
+ lexpush();
+ return 0;
+ } /* if */
+}
+
+/* tokeninfo
+ *
+ * Returns additional information of a token after using "matchtoken()"
+ * or needtoken(). It does no harm using this routine after a call to
+ * "lex()", but lex() already returns the same information.
+ *
+ * The token itself is the return value. Normally, this one is already known.
+ */
+int
+tokeninfo(cell * val, char **str)
+{
+ /* if the token was pushed back, tokeninfo() returns the token and
+ * parameters of the *next* token, not of the *current* token.
+ */
+ assert(!_pushed);
+ *val = _lexval;
+ *str = _lexstr;
+ return _lextok;
+}
+
+/* needtoken
+ *
+ * This routine checks for a required token and gives an error message if
+ * it isn't there (and returns FALSE in that case).
+ *
+ * Global references: _lextok;
+ */
+int
+needtoken(int token)
+{
+ char s1[20], s2[20];
+
+ if (matchtoken(token))
+ {
+ return TRUE;
+ }
+ else
+ {
+ /* token already pushed back */
+ assert(_pushed);
+ if (token < 256)
+ sprintf(s1, "%c", (char)token); /* single character token */
+ else
+ strcpy(s1, sc_tokens[token - tFIRST]); /* multi-character symbol */
+ if (!freading)
+ strcpy(s2, "-end of file-");
+ else if (_lextok < 256)
+ sprintf(s2, "%c", (char)_lextok);
+ else
+ strcpy(s2, sc_tokens[_lextok - tFIRST]);
+ error(1, s1, s2); /* expected ..., but found ... */
+ return FALSE;
+ } /* if */
+}
+
+/* match
+ *
+ * Compares a series of characters from the input file with the characters
+ * in "st" (that contains a token). If the token on the input file matches
+ * "st", the input file pointer "lptr" is adjusted to point to the next
+ * token, otherwise "lptr" remains unaltered.
+ *
+ * If the parameter "end: is true, match() requires that the first character
+ * behind the recognized token is non-alphanumeric.
+ *
+ * Global references: lptr (altered)
+ */
+static int
+match(char *st, int end)
+{
+ int k;
+ char *ptr;
+
+ k = 0;
+ ptr = lptr;
+ while (st[k])
+ {
+ if (st[k] != *ptr)
+ return 0;
+ k += 1;
+ ptr += 1;
+ } /* while */
+ if (end)
+ { /* symbol must terminate with non-alphanumeric char */
+ if (alphanum(*ptr))
+ return 0;
+ } /* if */
+ lptr = ptr; /* match found, skip symbol */
+ return 1;
+}
+
+/* stowlit
+ *
+ * Stores a value into the literal queue. The literal queue is used for
+ * literal strings used in functions and for initializing array variables.
+ *
+ * Global references: litidx (altered)
+ * litq (altered)
+ */
+void
+stowlit(cell value)
+{
+ if (litidx >= litmax)
+ {
+ cell *p;
+
+ litmax += sDEF_LITMAX;
+ p = (cell *) realloc(litq, litmax * sizeof(cell));
+ if (!p)
+ error(102, "literal table"); /* literal table overflow (fatal error) */
+ litq = p;
+ } /* if */
+ assert(litidx < litmax);
+ litq[litidx++] = value;
+}
+
+/* litchar
+ *
+ * Return current literal character and increase the pointer to point
+ * just behind this literal character.
+ *
+ * Note: standard "escape sequences" are suported, but the backslash may be
+ * replaced by another character; the syntax '\ddd' is supported,
+ * but ddd must be decimal!
+ */
+static cell
+litchar(char **lptr, int rawmode)
+{
+ cell c = 0;
+ unsigned char *cptr;
+
+ cptr = (unsigned char *)*lptr;
+ if (rawmode || *cptr != sc_ctrlchar)
+ { /* no escape character */
+ c = *cptr;
+ cptr += 1;
+ }
+ else
+ {
+ cptr += 1;
+ if (*cptr == sc_ctrlchar)
+ {
+ c = *cptr; /* \\ == \ (the escape character itself) */
+ cptr += 1;
+ }
+ else
+ {
+ switch (*cptr)
+ {
+ case 'a': /* \a == audible alarm */
+ c = 7;
+ cptr += 1;
+ break;
+ case 'b': /* \b == backspace */
+ c = 8;
+ cptr += 1;
+ break;
+ case 'e': /* \e == escape */
+ c = 27;
+ cptr += 1;
+ break;
+ case 'f': /* \f == form feed */
+ c = 12;
+ cptr += 1;
+ break;
+ case 'n': /* \n == NewLine character */
+ c = 10;
+ cptr += 1;
+ break;
+ case 'r': /* \r == carriage return */
+ c = 13;
+ cptr += 1;
+ break;
+ case 't': /* \t == horizontal TAB */
+ c = 9;
+ cptr += 1;
+ break;
+ case 'v': /* \v == vertical TAB */
+ c = 11;
+ cptr += 1;
+ break;
+ case '\'': /* \' == ' (single quote) */
+ case '"': /* \" == " (single quote) */
+ case '%': /* \% == % (percent) */
+ c = *cptr;
+ cptr += 1;
+ break;
+ default:
+ if (sc_isdigit(*cptr))
+ { /* \ddd */
+ c = 0;
+ while (*cptr >= '0' && *cptr <= '9') /* decimal! */
+ c = c * 10 + *cptr++ - '0';
+ if (*cptr == ';')
+ cptr++; /* swallow a trailing ';' */
+ }
+ else
+ {
+ error(27); /* invalid character constant */
+ } /* if */
+ } /* switch */
+ } /* if */
+ } /* if */
+ *lptr = (char *)cptr;
+ assert(c >= 0 && c < 256);
+ return c;
+}
+
+/* alpha
+ *
+ * Test if character "c" is alphabetic ("a".."z"), an underscore ("_")
+ * or an "at" sign ("@"). The "@" is an extension to standard C.
+ */
+static int
+alpha(char c)
+{
+ return (sc_isalpha(c) || c == '_' || c == PUBLIC_CHAR);
+}
+
+/* alphanum
+ *
+ * Test if character "c" is alphanumeric ("a".."z", "0".."9", "_" or "@")
+ */
+int
+alphanum(char c)
+{
+ return (alpha(c) || sc_isdigit(c));
+}
+
+/* The local variable table must be searched backwards, so that the deepest
+ * nesting of local variables is searched first. The simplest way to do
+ * this is to insert all new items at the head of the list.
+ * In the global list, the symbols are kept in sorted order, so that the
+ * public functions are written in sorted order.
+ */
+static symbol *
+add_symbol(symbol * root, symbol * entry, int sort)
+{
+ symbol *newsym;
+
+ if (sort)
+ while (root->next && strcmp(entry->name, root->next->name) > 0)
+ root = root->next;
+
+ if (!(newsym = (symbol *)malloc(sizeof(symbol))))
+ {
+ error(103);
+ return NULL;
+ } /* if */
+ memcpy(newsym, entry, sizeof(symbol));
+ newsym->next = root->next;
+ root->next = newsym;
+ return newsym;
+}
+
+static void
+free_symbol(symbol * sym)
+{
+ arginfo *arg;
+
+ /* free all sub-symbol allocated memory blocks, depending on the
+ * kind of the symbol
+ */
+ assert(sym != NULL);
+ if (sym->ident == iFUNCTN)
+ {
+ /* run through the argument list; "default array" arguments
+ * must be freed explicitly; the tag list must also be freed */
+ assert(sym->dim.arglist != NULL);
+ for (arg = sym->dim.arglist; arg->ident != 0; arg++)
+ {
+ if (arg->ident == iREFARRAY && arg->hasdefault)
+ free(arg->defvalue.array.data);
+ else if (arg->ident == iVARIABLE
+ && ((arg->hasdefault & uSIZEOF) != 0
+ || (arg->hasdefault & uTAGOF) != 0))
+ free(arg->defvalue.size.symname);
+ assert(arg->tags != NULL);
+ free(arg->tags);
+ } /* for */
+ free(sym->dim.arglist);
+ } /* if */
+ assert(sym->refer != NULL);
+ free(sym->refer);
+ free(sym);
+}
+
+void
+delete_symbol(symbol * root, symbol * sym)
+{
+ /* find the symbol and its predecessor
+ * (this function assumes that you will never delete a symbol that is not
+ * in the table pointed at by "root")
+ */
+ assert(root != sym);
+ while (root->next != sym)
+ {
+ root = root->next;
+ assert(root != NULL);
+ } /* while */
+
+ /* unlink it, then free it */
+ root->next = sym->next;
+ free_symbol(sym);
+}
+
+void
+delete_symbols(symbol * root, int level, int delete_labels,
+ int delete_functions)
+{
+ symbol *sym;
+
+ /* erase only the symbols with a deeper nesting level than the
+ * specified nesting level */
+ while (root->next)
+ {
+ sym = root->next;
+ if (sym->compound < level)
+ break;
+ if ((delete_labels || sym->ident != iLABEL)
+ && (delete_functions || sym->ident != iFUNCTN
+ || (sym->usage & uNATIVE) != 0) && (delete_functions
+ || sym->ident != iCONSTEXPR
+ || (sym->usage & uPREDEF) ==
+ 0) && (delete_functions
+ || (sym->ident !=
+ iVARIABLE
+ && sym->ident !=
+ iARRAY)))
+ {
+ root->next = sym->next;
+ free_symbol(sym);
+ }
+ else
+ {
+ /* if the function was prototyped, but not implemented in this source,
+ * mark it as such, so that its use can be flagged
+ */
+ if (sym->ident == iFUNCTN && (sym->usage & uDEFINE) == 0)
+ sym->usage |= uMISSING;
+ if (sym->ident == iFUNCTN || sym->ident == iVARIABLE
+ || sym->ident == iARRAY)
+ sym->usage &= ~uDEFINE; /* clear "defined" flag */
+ /* for user defined operators, also remove the "prototyped" flag, as
+ * user-defined operators *must* be declared before use
+ */
+ if (sym->ident == iFUNCTN && !sc_isalpha(*sym->name)
+ && *sym->name != '_' && *sym->name != PUBLIC_CHAR)
+ sym->usage &= ~uPROTOTYPED;
+ root = sym; /* skip the symbol */
+ } /* if */
+ } /* if */
+}
+
+/* The purpose of the hash is to reduce the frequency of a "name"
+ * comparison (which is costly). There is little interest in avoiding
+ * clusters in similar names, which is why this function is plain simple.
+ */
+unsigned int
+namehash(char *name)
+{
+ unsigned char *ptr = (unsigned char *)name;
+ int len = strlen(name);
+
+ if (len == 0)
+ return 0L;
+ assert(len < 256);
+ return (len << 24Lu) + (ptr[0] << 16Lu) + (ptr[len - 1] << 8Lu) +
+ (ptr[len >> 1Lu]);
+}
+
+static symbol *
+find_symbol(symbol * root, char *name, int fnumber)
+{
+ symbol *ptr = root->next;
+ unsigned long hash = namehash(name);
+
+ while (ptr)
+ {
+ if (hash == ptr->hash && strcmp(name, ptr->name) == 0
+ && !ptr->parent && (ptr->fnumber < 0
+ || ptr->fnumber == fnumber))
+ return ptr;
+ ptr = ptr->next;
+ } /* while */
+ return NULL;
+}
+
+static symbol *
+find_symbol_child(symbol * root, symbol * sym)
+{
+ symbol *ptr = root->next;
+
+ while (ptr)
+ {
+ if (ptr->parent == sym)
+ return ptr;
+ ptr = ptr->next;
+ } /* while */
+ return NULL;
+}
+
+/* Adds "bywhom" to the list of referrers of "entry". Typically,
+ * bywhom will be the function that uses a variable or that calls
+ * the function.
+ */
+int
+refer_symbol(symbol * entry, symbol * bywhom)
+{
+ int count;
+
+ assert(bywhom != NULL); /* it makes no sense to add a "void" referrer */
+ assert(entry != NULL);
+ assert(entry->refer != NULL);
+
+ /* see if it is already there */
+ for (count = 0; count < entry->numrefers && entry->refer[count] != bywhom;
+ count++)
+ /* nothing */ ;
+ if (count < entry->numrefers)
+ {
+ assert(entry->refer[count] == bywhom);
+ return TRUE;
+ } /* if */
+
+ /* see if there is an empty spot in the referrer list */
+ for (count = 0; count < entry->numrefers && entry->refer[count];
+ count++)
+ /* nothing */ ;
+ assert(count <= entry->numrefers);
+ if (count == entry->numrefers)
+ {
+ symbol **refer;
+ int newsize = 2 * entry->numrefers;
+
+ assert(newsize > 0);
+ /* grow the referrer list */
+ refer = (symbol **) realloc(entry->refer, newsize * sizeof(symbol *));
+ if (!refer)
+ return FALSE; /* insufficient memory */
+ /* initialize the new entries */
+ entry->refer = refer;
+ for (count = entry->numrefers; count < newsize; count++)
+ entry->refer[count] = NULL;
+ count = entry->numrefers; /* first empty spot */
+ entry->numrefers = newsize;
+ } /* if */
+
+ /* add the referrer */
+ assert(entry->refer[count] == NULL);
+ entry->refer[count] = bywhom;
+ return TRUE;
+}
+
+void
+markusage(symbol * sym, int usage)
+{
+ sym->usage |= (char)usage;
+ /* check if (global) reference must be added to the symbol */
+ if ((usage & (uREAD | uWRITTEN)) != 0)
+ {
+ /* only do this for global symbols */
+ if (sym->vclass == sGLOBAL)
+ {
+ /* "curfunc" should always be valid, since statements may not occurs
+ * outside functions; in the case of syntax errors, however, the
+ * compiler may arrive through this function
+ */
+ if (curfunc)
+ refer_symbol(sym, curfunc);
+ } /* if */
+ } /* if */
+}
+
+/* findglb
+ *
+ * Returns a pointer to the global symbol (if found) or NULL (if not found)
+ */
+symbol *
+findglb(char *name)
+{
+ return find_symbol(&glbtab, name, fcurrent);
+}
+
+/* findloc
+ *
+ * Returns a pointer to the local symbol (if found) or NULL (if not found).
+ * See add_symbol() how the deepest nesting level is searched first.
+ */
+symbol *
+findloc(char *name)
+{
+ return find_symbol(&loctab, name, -1);
+}
+
+symbol *
+findconst(char *name)
+{
+ symbol *sym;
+
+ sym = find_symbol(&loctab, name, -1); /* try local symbols first */
+ if (!sym || sym->ident != iCONSTEXPR) /* not found, or not a constant */
+ sym = find_symbol(&glbtab, name, fcurrent);
+ if (!sym || sym->ident != iCONSTEXPR)
+ return NULL;
+ assert(sym->parent == NULL); /* constants have no hierarchy */
+ return sym;
+}
+
+symbol *
+finddepend(symbol * parent)
+{
+ symbol *sym;
+
+ sym = find_symbol_child(&loctab, parent); /* try local symbols first */
+ if (!sym) /* not found */
+ sym = find_symbol_child(&glbtab, parent);
+ return sym;
+}
+
+/* addsym
+ *
+ * Adds a symbol to the symbol table (either global or local variables,
+ * or global and local constants).
+ */
+symbol *
+addsym(char *name, cell addr, int ident, int vclass, int tag, int usage)
+{
+ symbol entry, **refer;
+
+ /* global variables/constants/functions may only be defined once */
+ assert(!(ident == iFUNCTN || ident == iCONSTEXPR) || vclass != sGLOBAL
+ || findglb(name) == NULL);
+ /* labels may only be defined once */
+ assert(ident != iLABEL || findloc(name) == NULL);
+
+ /* create an empty referrer list */
+ if (!(refer = (symbol **)malloc(sizeof(symbol *))))
+ {
+ error(103); /* insufficient memory */
+ return NULL;
+ } /* if */
+ *refer = NULL;
+
+ /* first fill in the entry */
+ strcpy(entry.name, name);
+ entry.hash = namehash(name);
+ entry.addr = addr;
+ entry.vclass = (char)vclass;
+ entry.ident = (char)ident;
+ entry.tag = tag;
+ entry.usage = (char)usage;
+ entry.compound = 0; /* may be overridden later */
+ entry.fnumber = -1; /* assume global visibility (ignored for local symbols) */
+ entry.numrefers = 1;
+ entry.refer = refer;
+ entry.parent = NULL;
+
+ /* then insert it in the list */
+ if (vclass == sGLOBAL)
+ return add_symbol(&glbtab, &entry, TRUE);
+ else
+ return add_symbol(&loctab, &entry, FALSE);
+}
+
+symbol *
+addvariable(char *name, cell addr, int ident, int vclass, int tag,
+ int dim[], int numdim, int idxtag[])
+{
+ symbol *sym, *parent, *top;
+ int level;
+
+ /* global variables may only be defined once */
+ assert(vclass != sGLOBAL || (sym = findglb(name)) == NULL
+ || (sym->usage & uDEFINE) == 0);
+
+ if (ident == iARRAY || ident == iREFARRAY)
+ {
+ parent = NULL;
+ sym = NULL; /* to avoid a compiler warning */
+ for (level = 0; level < numdim; level++)
+ {
+ top = addsym(name, addr, ident, vclass, tag, uDEFINE);
+ top->dim.array.length = dim[level];
+ top->dim.array.level = (short)(numdim - level - 1);
+ top->x.idxtag = idxtag[level];
+ top->parent = parent;
+ parent = top;
+ if (level == 0)
+ sym = top;
+ } /* for */
+ }
+ else
+ {
+ sym = addsym(name, addr, ident, vclass, tag, uDEFINE);
+ } /* if */
+ return sym;
+}
+
+/* getlabel
+ *
+ * Return next available internal label number.
+ */
+int
+getlabel(void)
+{
+ return labnum++;
+}
+
+/* itoh
+ *
+ * Converts a number to a hexadecimal string and returns a pointer to that
+ * string.
+ */
+char *
+itoh(ucell val)
+{
+ static char itohstr[15]; /* hex number is 10 characters long at most */
+ char *ptr;
+ int i, nibble[8]; /* a 32-bit hexadecimal cell has 8 nibbles */
+ int max;
+
+#if defined(BIT16)
+ max = 4;
+#else
+ max = 8;
+#endif
+ ptr = itohstr;
+ for (i = 0; i < max; i += 1)
+ {
+ nibble[i] = (int)(val & 0x0f); /* nibble 0 is lowest nibble */
+ val >>= 4;
+ } /* endfor */
+ i = max - 1;
+ while (nibble[i] == 0 && i > 0) /* search for highest non-zero nibble */
+ i -= 1;
+ while (i >= 0)
+ {
+ if (nibble[i] >= 10)
+ *ptr++ = (char)('a' + (nibble[i] - 10));
+ else
+ *ptr++ = (char)('0' + nibble[i]);
+ i -= 1;
+ } /* while */
+ *ptr = '\0'; /* and a zero-terminator */
+ return itohstr;
+}