src/bin/embryo_cc_sc1.c

   1 /*  Small compiler
   2  *  Function and variable definition and declaration, statement parser.
   3  *
   4  *  Copyright (c) ITB CompuPhase, 1997-2003
   5  *
   6  * This software is provided "as-is", without any express or implied
   7  * warranty.  In no event will the authors be held liable for any
   8  * damages arising from the use of this software. Permission is granted
   9  * to anyone to use this software for any purpose, including commercial
  10  * applications, and to alter it and redistribute it freely, subject to
  11  * the following restrictions:
  12  *
  13  *  1.  The origin of this software must not be misrepresented;
  14  *  you must not claim that you wrote the original software.
  15  *  If you use this software in a product, an acknowledgment in the
  16  *  product documentation would be appreciated but is not required.
  17  *  2.  Altered source versions must be plainly marked as such, and
  18  *  must not be misrepresented as being the original software.
  19  *  3.  This notice may not be removed or altered from any source
  20  *  distribution.
  21  *  Version: $Id$
  22  */
  23
  24
  25 #ifdef HAVE_CONFIG_H
  26 # include <config.h>
  27 #endif
  28
  29 #include <assert.h>
  30 #include <ctype.h>
  31 #include <limits.h>
  32 #include <stdarg.h>
  33 #include <stdio.h>
  34 #include <stdlib.h>
  35 #include <string.h>
  36
  37 #ifdef HAVE_UNISTD_H
  38 # include <unistd.h>
  39 #endif
  40
  41 #ifdef HAVE_EVIL
  42 # include <Evil.h>
  43 #endif /* HAVE_EVIL */
  44
  45 #include "embryo_cc_sc.h"
  46 #include "embryo_cc_prefix.h"
  47
  48 #define VERSION_STR "2.4"
  49 #define VERSION_INT 240
  50
  51 static void         resetglobals(void);
  52 static void         initglobals(void);
  53 static void         setopt(int argc, char **argv,
  54                            char *iname, char *oname,
  55                            char *pname, char *rname);
  56 static void         setconfig(char *root);
  57 static void         about(void);
  58 static void         setconstants(void);
  59 static void         parse(void);
  60 static void         dumplits(void);
  61 static void         dumpzero(int count);
  62 static void         declfuncvar(int tok, char *symname,
  63                                 int tag, int fpublic,
  64                                 int fstatic, int fstock, int fconst);
  65 static void         declglb(char *firstname, int firsttag,
  66                             int fpublic, int fstatic, int stock, int fconst);
  67 static int          declloc(int fstatic);
  68 static void         decl_const(int table);
  69 static void         decl_enum(int table);
  70 static cell         needsub(int *tag);
  71 static void         initials(int ident, int tag,
  72                              cell * size, int dim[], int numdim);
  73 static cell         initvector(int ident, int tag, cell size, int fillzero);
  74 static cell         init(int ident, int *tag);
  75 static void         funcstub(int native);
  76 static int          newfunc(char *firstname, int firsttag,
  77                             int fpublic, int fstatic, int stock);
  78 static int          declargs(symbol * sym);
  79 static void         doarg(char *name, int ident, int offset,
  80                           int tags[], int numtags,
  81                           int fpublic, int fconst, arginfo * arg);
  82 static void         reduce_referrers(symbol * root);
  83 static int          testsymbols(symbol * root, int level,
  84                                 int testlabs, int testconst);
  85 static void         destructsymbols(symbol * root, int level);
  86 static constvalue  *find_constval_byval(constvalue * table, cell val);
  87 static void         statement(int *lastindent, int allow_decl);
  88 static void         compound(void);
  89 static void         doexpr(int comma, int chkeffect,
  90                            int allowarray, int mark_endexpr,
  91                            int *tag, int chkfuncresult);
  92 static void         doassert(void);
  93 static void         doexit(void);
  94 static void         test(int label, int parens, int invert);
  95 static void         doif(void);
  96 static void         dowhile(void);
  97 static void         dodo(void);
  98 static void         dofor(void);
  99 static void         doswitch(void);
 100 static void         dogoto(void);
 101 static void         dolabel(void);
 102 static symbol      *fetchlab(char *name);
 103 static void         doreturn(void);
 104 static void         dobreak(void);
 105 static void         docont(void);
 106 static void         dosleep(void);
 107 static void         addwhile(int *ptr);
 108 static void         delwhile(void);
 109 static int         *readwhile(void);
 110
 111 static int          lastst = 0; /* last executed statement type */
 112 static int          nestlevel = 0;      /* number of active (open) compound statements */
 113 static int          rettype = 0;        /* the type that a "return" expression should have */
 114 static int          skipinput = 0;      /* number of lines to skip from the first input file */
 115 static int          wq[wqTABSZ];        /* "while queue", internal stack for nested loops */
 116 static int         *wqptr;      /* pointer to next entry */
 117 static char         binfname[PATH_MAX]; /* binary file name */
 118
 119 int
 120 main(int argc, char *argv[], char *env[] __UNUSED__)
 121 {
 122    e_prefix_determine(argv[0]);
 123    return sc_compile(argc, argv);
 124 }
 125
 126 int
 127 sc_error(int number, char *message, char *filename, int firstline,
 128          int lastline, va_list argptr)
 129 {
 130    static char        *prefix[3] = { "error", "fatal error", "warning" };
 131
 132    if (number != 0)
 133      {
 134         char               *pre;
 135
 136         pre = prefix[number / 100];
 137         if (firstline >= 0)
 138            fprintf(stderr, "%s(%d -- %d) : %s %03d: ", filename, firstline,
 139                    lastline, pre, number);
 140         else
 141            fprintf(stderr, "%s(%d) : %s %03d: ", filename, lastline, pre,
 142                    number);
 143      }                          /* if */
 144    vfprintf(stderr, message, argptr);
 145    fflush(stderr);
 146    return 0;
 147 }
 148
 149 void               *
 150 sc_opensrc(char *filename)
 151 {
 152    return fopen(filename, "rb");
 153 }
 154
 155 void
 156 sc_closesrc(void *handle)
 157 {
 158    assert(handle != NULL);
 159    fclose((FILE *) handle);
 160 }
 161
 162 void
 163 sc_resetsrc(void *handle, void *position)
 164 {
 165    assert(handle != NULL);
 166    fsetpos((FILE *) handle, (fpos_t *) position);
 167 }
 168
 169 char               *
 170 sc_readsrc(void *handle, char *target, int maxchars)
 171 {
 172    return fgets(target, maxchars, (FILE *) handle);
 173 }
 174
 175 void               *
 176 sc_getpossrc(void *handle)
 177 {
 178    static fpos_t       lastpos; /* may need to have a LIFO stack of
 179                                  * such positions */
 180
 181    fgetpos((FILE *) handle, &lastpos);
 182    return &lastpos;
 183 }
 184
 185 int
 186 sc_eofsrc(void *handle)
 187 {
 188    return feof((FILE *) handle);
 189 }
 190
 191 void               *
 192 sc_openasm(int fd)
 193 {
 194    return fdopen(fd, "w+");
 195 }
 196
 197 void
 198 sc_closeasm(void *handle)
 199 {
 200    if (handle)
 201       fclose((FILE *) handle);
 202 }
 203
 204 void
 205 sc_resetasm(void *handle)
 206 {
 207    fflush((FILE *) handle);
 208    fseek((FILE *) handle, 0, SEEK_SET);
 209 }
 210
 211 int
 212 sc_writeasm(void *handle, char *st)
 213 {
 214    return fputs(st, (FILE *) handle) >= 0;
 215 }
 216
 217 char               *
 218 sc_readasm(void *handle, char *target, int maxchars)
 219 {
 220    return fgets(target, maxchars, (FILE *) handle);
 221 }
 222
 223 void               *
 224 sc_openbin(char *filename)
 225 {
 226    return fopen(filename, "wb");
 227 }
 228
 229 void
 230 sc_closebin(void *handle, int deletefile)
 231 {
 232    fclose((FILE *) handle);
 233    if (deletefile)
 234       unlink(binfname);
 235 }
 236
 237 void
 238 sc_resetbin(void *handle)
 239 {
 240    fflush((FILE *) handle);
 241    fseek((FILE *) handle, 0, SEEK_SET);
 242 }
 243
 244 int
 245 sc_writebin(void *handle, void *buffer, int size)
 246 {
 247    return (int)fwrite(buffer, 1, size, (FILE *) handle) == size;
 248 }
 249
 250 long
 251 sc_lengthbin(void *handle)
 252 {
 253    return ftell((FILE *) handle);
 254 }
 255
 256 /*  "main" of the compiler
 257  */
 258 int
 259 sc_compile(int argc, char *argv[])
 260 {
 261    int                 entry, i, jmpcode, fd_out;
 262    int                 retcode;
 263    char                incfname[PATH_MAX];
 264    char                reportname[PATH_MAX];
 265    FILE               *binf;
 266    void               *inpfmark;
 267    char                lcl_ctrlchar;
 268    int                 lcl_packstr, lcl_needsemicolon, lcl_tabsize;
 269    char               *tmpdir;
 270
 271    /* set global variables to their initial value */
 272    binf = NULL;
 273    initglobals();
 274    errorset(sRESET);
 275    errorset(sEXPRRELEASE);
 276    lexinit();
 277
 278    /* make sure that we clean up on a fatal error; do this before the
 279     * first call to error(). */
 280    if ((jmpcode = setjmp(errbuf)) != 0)
 281       goto cleanup;
 282
 283    /* allocate memory for fixed tables */
 284    inpfname = (char *)malloc(PATH_MAX);
 285    litq = (cell *) malloc(litmax * sizeof(cell));
 286    if (!litq)
 287       error(103);               /* insufficient memory */
 288    if (!phopt_init())
 289       error(103);               /* insufficient memory */
 290
 291    setopt(argc, argv, inpfname, binfname, incfname, reportname);
 292
 293    /* open the output file */
 294
 295 #ifndef HAVE_EVIL
 296    tmpdir = getenv("TMPDIR");
 297    if (!tmpdir) tmpdir = "/tmp";
 298 #else
 299    tmpdir = (char *)evil_tmpdir_get();
 300 #endif /* ! HAVE_EVIL */
 301
 302    snprintf(outfname, PATH_MAX, "%s/embryo_cc.asm-tmp-XXXXXX", tmpdir);
 303    fd_out = mkstemp(outfname);
 304    if (fd_out < 0)
 305      error(101, outfname);
 306
 307    setconfig(argv[0]);          /* the path to the include files */
 308    lcl_ctrlchar = sc_ctrlchar;
 309    lcl_packstr = sc_packstr;
 310    lcl_needsemicolon = sc_needsemicolon;
 311    lcl_tabsize = sc_tabsize;
 312    inpf = inpf_org = (FILE *) sc_opensrc(inpfname);
 313    if (!inpf)
 314       error(100, inpfname);
 315    freading = TRUE;
 316    outf = (FILE *) sc_openasm(fd_out);  /* first write to assembler
 317                                                  * file (may be temporary) */
 318    if (!outf)
 319       error(101, outfname);
 320    /* immediately open the binary file, for other programs to check */
 321    binf = (FILE *) sc_openbin(binfname);
 322    if (!binf)
 323      error(101, binfname);
 324    setconstants();              /* set predefined constants and tagnames */
 325    for (i = 0; i < skipinput; i++)      /* skip lines in the input file */
 326       if (sc_readsrc(inpf, pline, sLINEMAX))
 327          fline++;               /* keep line number up to date */
 328    skipinput = fline;
 329    sc_status = statFIRST;
 330    /* do the first pass through the file */
 331    inpfmark = sc_getpossrc(inpf);
 332    if (incfname[0] != '\0')
 333      {
 334         if (strcmp(incfname, sDEF_PREFIX) == 0)
 335           {
 336              plungefile(incfname, FALSE, TRUE); /* parse "default.inc" */
 337           }
 338         else
 339           {
 340              if (!plungequalifiedfile(incfname))        /* parse "prefix" include
 341                                                          * file */
 342                 error(100, incfname);   /* cannot read from ... (fatal error) */
 343           }                     /* if */
 344      }                          /* if */
 345    preprocess();                /* fetch first line */
 346    parse();                     /* process all input */
 347
 348    /* second pass */
 349    sc_status = statWRITE;       /* set, to enable warnings */
 350
 351    /* ??? for re-parsing the listing file instead of the original source
 352     * file (and doing preprocessing twice):
 353     * - close input file, close listing file
 354     * - re-open listing file for reading (inpf)
 355     * - open assembler file (outf)
 356     */
 357
 358    /* reset "defined" flag of all functions and global variables */
 359    reduce_referrers(&glbtab);
 360    delete_symbols(&glbtab, 0, TRUE, FALSE);
 361 #if !defined NO_DEFINE
 362    delete_substtable();
 363 #endif
 364    resetglobals();
 365    sc_ctrlchar = lcl_ctrlchar;
 366    sc_packstr = lcl_packstr;
 367    sc_needsemicolon = lcl_needsemicolon;
 368    sc_tabsize = lcl_tabsize;
 369    errorset(sRESET);
 370    /* reset the source file */
 371    inpf = inpf_org;
 372    freading = TRUE;
 373    sc_resetsrc(inpf, inpfmark); /* reset file position */
 374    fline = skipinput;           /* reset line number */
 375    lexinit();                   /* clear internal flags of lex() */
 376    sc_status = statWRITE;       /* allow to write --this variable was reset
 377                                  * by resetglobals() */
 378    writeleader();
 379    setfile(inpfname, fnumber);
 380    if (incfname[0] != '\0')
 381      {
 382         if (strcmp(incfname, sDEF_PREFIX) == 0)
 383            plungefile(incfname, FALSE, TRUE);   /* parse "default.inc" (again) */
 384         else
 385            plungequalifiedfile(incfname);       /* parse implicit include
 386                                                  * file (again) */
 387      }                          /* if */
 388    preprocess();                /* fetch first line */
 389    parse();                     /* process all input */
 390    /* inpf is already closed when readline() attempts to pop of a file */
 391    writetrailer();              /* write remaining stuff */
 392
 393    entry = testsymbols(&glbtab, 0, TRUE, FALSE);        /* test for unused
 394                                                          * or undefined functions and variables */
 395    if (!entry)
 396       error(13);                /* no entry point (no public functions) */
 397
 398  cleanup:
 399    if (inpf)            /* main source file is not closed, do it now */
 400       sc_closesrc(inpf);
 401    /* write the binary file (the file is already open) */
 402    if (errnum == 0 && jmpcode == 0)
 403      {
 404         assert(binf != NULL);
 405         sc_resetasm(outf);      /* flush and loop back, for reading */
 406         assemble(binf, outf);   /* assembler file is now input */
 407      }                          /* if */
 408    if (outf)
 409       sc_closeasm(outf);
 410    unlink (outfname);
 411    if (binf)
 412       sc_closebin(binf, errnum != 0);
 413
 414    if (inpfname)
 415       free(inpfname);
 416    if (litq)
 417       free(litq);
 418    phopt_cleanup();
 419    stgbuffer_cleanup();
 420    assert(jmpcode != 0 || loctab.next == NULL); /* on normal flow,
 421                                                  * local symbols
 422                                                  * should already have been deleted */
 423    delete_symbols(&loctab, 0, TRUE, TRUE);      /* delete local variables
 424                                                  * if not yet  done (i.e.
 425                                                  * on a fatal error) */
 426    delete_symbols(&glbtab, 0, TRUE, TRUE);
 427    delete_consttable(&tagname_tab);
 428    delete_consttable(&libname_tab);
 429    delete_aliastable();
 430    delete_pathtable();
 431 #if !defined NO_DEFINE
 432    delete_substtable();
 433 #endif
 434    if (errnum != 0)
 435      {
 436         printf("\n%d Error%s.\n", errnum, (errnum > 1) ? "s" : "");
 437         retcode = 2;
 438      }
 439    else if (warnnum != 0)
 440      {
 441         printf("\n%d Warning%s.\n", warnnum, (warnnum > 1) ? "s" : "");
 442         retcode = 1;
 443      }
 444    else
 445      {
 446         retcode = jmpcode;
 447      }                          /* if */
 448    return retcode;
 449 }
 450
 451 int
 452 sc_addconstant(char *name, cell value, int tag)
 453 {
 454    errorset(sFORCESET);         /* make sure error engine is silenced */
 455    sc_status = statIDLE;
 456    add_constant(name, value, sGLOBAL, tag);
 457    return 1;
 458 }
 459
 460 int
 461 sc_addtag(char *name)
 462 {
 463    cell                val;
 464    constvalue         *ptr;
 465    int                 last, tag;
 466
 467    if (!name)
 468      {
 469         /* no tagname was given, check for one */
 470         if (lex(&val, &name) != tLABEL)
 471           {
 472              lexpush();
 473              return 0;          /* untagged */
 474           }                     /* if */
 475      }                          /* if */
 476
 477    last = 0;
 478    ptr = tagname_tab.next;
 479    while (ptr)
 480      {
 481         tag = (int)(ptr->value & TAGMASK);
 482         if (strcmp(name, ptr->name) == 0)
 483            return tag;          /* tagname is known, return its sequence number */
 484         tag &= (int)~FIXEDTAG;
 485         if (tag > last)
 486            last = tag;
 487         ptr = ptr->next;
 488      }                          /* while */
 489
 490    /* tagname currently unknown, add it */
 491    tag = last + 1;              /* guaranteed not to exist already */
 492    if (sc_isupper(*name))
 493       tag |= (int)FIXEDTAG;
 494    append_constval(&tagname_tab, name, (cell) tag, 0);
 495    return tag;
 496 }
 497
 498 static void
 499 resetglobals(void)
 500 {
 501    /* reset the subset of global variables that is modified by the
 502     * first pass */
 503    curfunc = NULL;              /* pointer to current function */
 504    lastst = 0;                  /* last executed statement type */
 505    nestlevel = 0;               /* number of active (open) compound statements */
 506    rettype = 0;                 /* the type that a "return" expression should have */
 507    litidx = 0;                  /* index to literal table */
 508    stgidx = 0;                  /* index to the staging buffer */
 509    labnum = 0;                  /* number of (internal) labels */
 510    staging = 0;                 /* true if staging output */
 511    declared = 0;                /* number of local cells declared */
 512    glb_declared = 0;            /* number of global cells declared */
 513    code_idx = 0;                /* number of bytes with generated code */
 514    ntv_funcid = 0;              /* incremental number of native function */
 515    curseg = 0;                  /* 1 if currently parsing CODE, 2 if parsing DATA */
 516    freading = FALSE;            /* no input file ready yet */
 517    fline = 0;                   /* the line number in the current file */
 518    fnumber = 0;                 /* the file number in the file table (debugging) */
 519    fcurrent = 0;                /* current file being processed (debugging) */
 520    intest = 0;                  /* true if inside a test */
 521    sideeffect = 0;              /* true if an expression causes a side-effect */
 522    stmtindent = 0;              /* current indent of the statement */
 523    indent_nowarn = TRUE;        /* do not skip warning "217 loose indentation" */
 524    sc_allowtags = TRUE;         /* allow/detect tagnames */
 525    sc_status = statIDLE;
 526 }
 527
 528 static void
 529 initglobals(void)
 530 {
 531    resetglobals();
 532
 533    skipinput = 0;               /* number of lines to skip from the first
 534                                  * input file */
 535    sc_ctrlchar = CTRL_CHAR;     /* the escape character */
 536    litmax = sDEF_LITMAX;        /* current size of the literal table */
 537    errnum = 0;                  /* number of errors */
 538    warnnum = 0;                 /* number of warnings */
 539 /* sc_debug=sCHKBOUNDS; by default: bounds checking+assertions */
 540    sc_debug = 0;                /* by default: no debug */
 541    charbits = 8;                /* a "char" is 8 bits */
 542    sc_packstr = FALSE;          /* strings are unpacked by default */
 543 /* sc_compress=TRUE;     compress output bytecodes */
 544    sc_compress = FALSE;         /* compress output bytecodes */
 545    sc_needsemicolon = FALSE;    /* semicolon required to terminate
 546                                  * expressions? */
 547    sc_dataalign = 4;
 548    sc_stksize = sDEF_AMXSTACK;  /* default stack size */
 549    sc_tabsize = 8;              /* assume a TAB is 8 spaces */
 550    sc_rationaltag = 0;          /* assume no support for rational numbers */
 551    rational_digits = 0;         /* number of fractional digits */
 552
 553    outfname[0] = '\0';          /* output file name */
 554    inpf = NULL;                 /* file read from */
 555    inpfname = NULL;             /* pointer to name of the file currently
 556                                  * read from */
 557    outf = NULL;                 /* file written to */
 558    litq = NULL;                 /* the literal queue */
 559    glbtab.next = NULL;          /* clear global variables/constants table */
 560    loctab.next = NULL;          /*   "   local      "    /    "       "   */
 561    tagname_tab.next = NULL;     /* tagname table */
 562    libname_tab.next = NULL;     /* library table (#pragma library "..."
 563                                  * syntax) */
 564
 565    pline[0] = '\0';             /* the line read from the input file */
 566    lptr = NULL;                 /* points to the current position in "pline" */
 567    curlibrary = NULL;           /* current library */
 568    inpf_org = NULL;             /* main source file */
 569
 570    wqptr = wq;                  /* initialize while queue pointer */
 571
 572 }
 573
 574 static void
 575 parseoptions(int argc, char **argv, char *iname, char *oname,
 576              char *pname __UNUSED__, char *rname __UNUSED__)
 577 {
 578    char str[PATH_MAX];
 579    int i, stack_size;
 580    size_t len;
 581
 582    /* use embryo include dir always */
 583    snprintf(str, sizeof(str), "%s/include/", e_prefix_data_get());
 584    insert_path(str);
 585    insert_path("./");
 586
 587    for (i = 1; i < argc; i++)
 588    {
 589       if (!strcmp (argv[i], "-i") && (i + 1 < argc) && *argv[i + 1])
 590       {
 591          /* include directory */
 592          i++;
 593          strncpy(str, argv[i], sizeof(str));
 594
 595          len = strlen(str);
 596          if (str[len - 1] != DIRSEP_CHAR)
 597          {
 598             str[len] = DIRSEP_CHAR;
 599             str[len + 1] = '\0';
 600          }
 601
 602          insert_path(str);
 603       }
 604       else if (!strcmp (argv[i], "-o") && (i + 1 < argc) && *argv[i + 1])
 605       {
 606          /* output file */
 607          i++;
 608          strcpy(oname, argv[i]); /* FIXME */
 609       }
 610       else if (!strcmp (argv[i], "-S") && (i + 1 < argc) && *argv[i + 1])
 611       {
 612          /* stack size */
 613          i++;
 614          stack_size = atoi(argv[i]);
 615
 616          if (stack_size > 64)
 617             sc_stksize = (cell) stack_size;
 618          else
 619             about();
 620       }
 621       else if (!*iname)
 622       {
 623          /* input file */
 624          strcpy(iname, argv[i]); /* FIXME */
 625       }
 626       else
 627       {
 628          /* only allow one input filename */
 629          about();
 630       }
 631    }
 632 }
 633
 634 static void
 635 setopt(int argc, char **argv, char *iname, char *oname,
 636        char *pname, char *rname)
 637 {
 638    *iname = '\0';
 639    *oname = '\0';
 640    *pname = '\0';
 641    *rname = '\0';
 642    strcpy(pname, sDEF_PREFIX);
 643
 644    parseoptions(argc, argv, iname, oname, pname, rname);
 645    if (iname[0] == '\0')
 646       about();
 647 }
 648
 649 static void
 650 setconfig(char *root)
 651 {
 652    char                path[PATH_MAX];
 653    char               *ptr;
 654    int                 len;
 655
 656    path[sizeof(path) - 1] = 0;
 657
 658    /* add the default "include" directory */
 659    if (root)
 660      {
 661         /* path + filename (hopefully) */
 662         strncpy(path, root, sizeof(path) - 1);
 663         path[sizeof(path) - 1] = 0;
 664      }
 665 /* terminate just behind last \ or : */
 666    if ((ptr = strrchr(path, DIRSEP_CHAR))
 667        || (ptr = strchr(path, ':')))
 668      {
 669         /* If there was no terminating "\" or ":",
 670          * the filename probably does not
 671          * contain the path; so we just don't add it
 672          * to the list in that case
 673          */
 674         *(ptr + 1) = '\0';
 675         if (strlen(path) < (sizeof(path) - 1 - 7))
 676           {
 677              strcat(path, "include");
 678           }
 679         len = strlen(path);
 680         path[len] = DIRSEP_CHAR;
 681         path[len + 1] = '\0';
 682         insert_path(path);
 683      }                          /* if */
 684 }
 685
 686 static void
 687 about(void)
 688 {
 689    printf("Usage:   embryo_cc <filename> [options]\n\n");
 690    printf("Options:\n");
 691 #if 0
 692         printf
 693            ("         -A<num>  alignment in bytes of the data segment and the\
 694      stack\n");
 695
 696         printf
 697            ("         -a       output assembler code (skip code generation\
 698     pass)\n");
 699
 700         printf
 701            ("         -C[+/-]  compact encoding for output file (default=%c)\n",
 702             sc_compress ? '+' : '-');
 703         printf("         -c8      [default] a character is 8-bits\
 704      (ASCII/ISO Latin-1)\n");
 705
 706         printf("         -c16     a character is 16-bits (Unicode)\n");
 707 #if defined dos_setdrive
 708         printf("         -Dpath   active directory path\n");
 709 #endif
 710         printf
 711            ("         -d0      no symbolic information, no run-time checks\n");
 712         printf("         -d1      [default] run-time checks, no symbolic\
 713      information\n");
 714         printf
 715            ("         -d2      full debug information and dynamic checking\n");
 716         printf("         -d3      full debug information, dynamic checking,\
 717      no optimization\n");
 718 #endif
 719         printf("         -i <name> path for include files\n");
 720 #if 0
 721         printf("         -l       create list file (preprocess only)\n");
 722 #endif
 723         printf("         -o <name> set base name of output file\n");
 724 #if 0
 725         printf
 726            ("         -P[+/-]  strings are \"packed\" by default (default=%c)\n",
 727             sc_packstr ? '+' : '-');
 728         printf("         -p<name> set name of \"prefix\" file\n");
 729         if (!waitkey())
 730            longjmp(errbuf, 3);
 731 #endif
 732         printf
 733            ("         -S <num>  stack/heap size in cells (default=%d, min=65)\n",
 734             (int)sc_stksize);
 735 #if 0
 736         printf("         -s<num>  skip lines from the input file\n");
 737         printf
 738            ("         -t<num>  TAB indent size (in character positions)\n");
 739         printf("         -\\       use '\\' for escape characters\n");
 740         printf("         -^       use '^' for escape characters\n");
 741         printf("         -;[+/-]  require a semicolon to end each statement\
 742      (default=%c)\n", sc_needsemicolon ? '+' : '-');
 743
 744         printf
 745            ("         sym=val  define constant \"sym\" with value \"val\"\n");
 746         printf("         sym=     define constant \"sym\" with value 0\n");
 747 #endif
 748         longjmp(errbuf, 3);             /* user abort */
 749 }
 750
 751 static void
 752 setconstants(void)
 753 {
 754    int                 debug;
 755
 756    assert(sc_status == statIDLE);
 757    append_constval(&tagname_tab, "_", 0, 0);    /* "untagged" */
 758    append_constval(&tagname_tab, "bool", 1, 0);
 759
 760    add_constant("true", 1, sGLOBAL, 1); /* boolean flags */
 761    add_constant("false", 0, sGLOBAL, 1);
 762    add_constant("EOS", 0, sGLOBAL, 0);  /* End Of String, or '\0' */
 763    add_constant("cellbits", 32, sGLOBAL, 0);
 764    add_constant("cellmax", INT_MAX, sGLOBAL, 0);
 765    add_constant("cellmin", INT_MIN, sGLOBAL, 0);
 766    add_constant("charbits", charbits, sGLOBAL, 0);
 767    add_constant("charmin", 0, sGLOBAL, 0);
 768    add_constant("charmax", (charbits == 16) ? 0xffff : 0xff, sGLOBAL, 0);
 769
 770    add_constant("__Small", VERSION_INT, sGLOBAL, 0);
 771
 772    debug = 0;
 773    if ((sc_debug & (sCHKBOUNDS | sSYMBOLIC)) == (sCHKBOUNDS | sSYMBOLIC))
 774       debug = 2;
 775    else if ((sc_debug & sCHKBOUNDS) == sCHKBOUNDS)
 776       debug = 1;
 777    add_constant("debug", debug, sGLOBAL, 0);
 778 }
 779
 780 /*  parse       - process all input text
 781  *
 782  *  At this level, only static declarations and function definitions
 783  *  are legal.
 784  */
 785 static void
 786 parse(void)
 787 {
 788    int                 tok, tag, fconst, fstock, fstatic;
 789    cell                val;
 790    char               *str;
 791
 792    while (freading)
 793      {
 794         /* first try whether a declaration possibly is native or public */
 795         tok = lex(&val, &str);  /* read in (new) token */
 796         switch (tok)
 797           {
 798           case 0:
 799              /* ignore zero's */
 800              break;
 801           case tNEW:
 802              fconst = matchtoken(tCONST);
 803              declglb(NULL, 0, FALSE, FALSE, FALSE, fconst);
 804              break;
 805           case tSTATIC:
 806              /* This can be a static function or a static global variable;
 807               * we know which of the two as soon as we have parsed up to the
 808               * point where an opening parenthesis of a function would be
 809               * expected. To back out after deciding it was a declaration of
 810               * a static variable after all, we have to store the symbol name
 811               * and tag.
 812               */
 813              fstock = matchtoken(tSTOCK);
 814              fconst = matchtoken(tCONST);
 815              tag = sc_addtag(NULL);
 816              tok = lex(&val, &str);
 817              if (tok == tNATIVE || tok == tPUBLIC)
 818                {
 819                   error(42);    /* invalid combination of class specifiers */
 820                   break;
 821                }                /* if */
 822              declfuncvar(tok, str, tag, FALSE, TRUE, fstock, fconst);
 823              break;
 824           case tCONST:
 825              decl_const(sGLOBAL);
 826              break;
 827           case tENUM:
 828              decl_enum(sGLOBAL);
 829              break;
 830           case tPUBLIC:
 831              /* This can be a public function or a public variable;
 832               * see the comment above (for static functions/variables)
 833               * for details.
 834               */
 835              fconst = matchtoken(tCONST);
 836              tag = sc_addtag(NULL);
 837              tok = lex(&val, &str);
 838              if (tok == tNATIVE || tok == tSTOCK || tok == tSTATIC)
 839                {
 840                   error(42);    /* invalid combination of class specifiers */
 841                   break;
 842                }                /* if */
 843              declfuncvar(tok, str, tag, TRUE, FALSE, FALSE, fconst);
 844              break;
 845           case tSTOCK:
 846              /* This can be a stock function or a stock *global) variable;
 847               * see the comment above (for static functions/variables) for
 848               * details.
 849               */
 850              fstatic = matchtoken(tSTATIC);
 851              fconst = matchtoken(tCONST);
 852              tag = sc_addtag(NULL);
 853              tok = lex(&val, &str);
 854              if (tok == tNATIVE || tok == tPUBLIC)
 855                {
 856                   error(42);    /* invalid combination of class specifiers */
 857                   break;
 858                }                /* if */
 859              declfuncvar(tok, str, tag, FALSE, fstatic, TRUE, fconst);
 860              break;
 861           case tLABEL:
 862           case tSYMBOL:
 863           case tOPERATOR:
 864              lexpush();
 865              if (!newfunc(NULL, -1, FALSE, FALSE, FALSE))
 866                {
 867                   error(10);    /* illegal function or declaration */
 868                   lexclr(TRUE); /* drop the rest of the line */
 869                }                /* if */
 870              break;
 871           case tNATIVE:
 872              funcstub(TRUE);    /* create a dummy function */
 873              break;
 874           case tFORWARD:
 875              funcstub(FALSE);
 876              break;
 877           case '}':
 878              error(54);         /* unmatched closing brace */
 879              break;
 880           case '{':
 881              error(55);         /* start of function body without function header */
 882              break;
 883           default:
 884              if (freading)
 885                {
 886                   error(10);    /* illegal function or declaration */
 887                   lexclr(TRUE); /* drop the rest of the line */
 888                }                /* if */
 889           }                     /* switch */
 890      }                          /* while */
 891 }
 892
 893 /*  dumplits
 894  *
 895  *  Dump the literal pool (strings etc.)
 896  *
 897  *  Global references: litidx (referred to only)
 898  */
 899 static void
 900 dumplits(void)
 901 {
 902    int                 j, k;
 903
 904    k = 0;
 905    while (k < litidx)
 906      {
 907         /* should be in the data segment */
 908         assert(curseg == 2);
 909         defstorage();
 910         j = 16;                 /* 16 values per line */
 911         while (j && k < litidx)
 912           {
 913              outval(litq[k], FALSE);
 914              stgwrite(" ");
 915              k++;
 916              j--;
 917              if (j == 0 || k >= litidx)
 918                 stgwrite("\n"); /* force a newline after 10 dumps */
 919              /* Note: stgwrite() buffers a line until it is complete. It recognizes
 920               * the end of line as a sequence of "\n\0", so something like "\n\t"
 921               * so should not be passed to stgwrite().
 922               */
 923           }                     /* while */
 924      }                          /* while */
 925 }
 926
 927 /*  dumpzero
 928  *
 929  *  Dump zero's for default initial values
 930  */
 931 static void
 932 dumpzero(int count)
 933 {
 934    int                 i;
 935
 936    if (count <= 0)
 937       return;
 938    assert(curseg == 2);
 939    defstorage();
 940    i = 0;
 941    while (count-- > 0)
 942      {
 943         outval(0, FALSE);
 944         i = (i + 1) % 16;
 945         stgwrite((i == 0 || count == 0) ? "\n" : " ");
 946         if (i == 0 && count > 0)
 947            defstorage();
 948      }                          /* while */
 949 }
 950
 951 static void
 952 aligndata(int numbytes)
 953 {
 954    if ((((glb_declared + litidx) * sizeof(cell)) % numbytes) != 0)
 955      {
 956         while ((((glb_declared + litidx) * sizeof(cell)) % numbytes) != 0)
 957            stowlit(0);
 958      }                          /* if */
 959
 960 }
 961
 962 static void
 963 declfuncvar(int tok, char *symname, int tag, int fpublic, int fstatic,
 964             int fstock, int fconst)
 965 {
 966    char                name[sNAMEMAX + 1];
 967
 968    if (tok != tSYMBOL && tok != tOPERATOR)
 969      {
 970         if (freading)
 971            error(20, symname);  /* invalid symbol name */
 972         return;
 973      }                          /* if */
 974    if (tok == tOPERATOR)
 975      {
 976         lexpush();
 977         if (!newfunc(NULL, tag, fpublic, fstatic, fstock))
 978            error(10);           /* illegal function or declaration */
 979      }
 980    else
 981      {
 982         assert(strlen(symname) <= sNAMEMAX);
 983         strcpy(name, symname);
 984         if (fconst || !newfunc(name, tag, fpublic, fstatic, fstock))
 985            declglb(name, tag, fpublic, fstatic, fstock, fconst);
 986         /* if not a static function, try a static variable */
 987      }                          /* if */
 988 }
 989
 990 /*  declglb     - declare global symbols
 991  *
 992  *  Declare a static (global) variable. Global variables are stored in
 993  *  the DATA segment.
 994  *
 995  *  global references: glb_declared     (altered)
 996  */
 997 static void
 998 declglb(char *firstname, int firsttag, int fpublic, int fstatic,
 999         int stock, int fconst)
1000 {
1001    int                 ident, tag, ispublic;
1002    int                 idxtag[sDIMEN_MAX];
1003    char                name[sNAMEMAX + 1];
1004    cell                val, size, cidx;
1005    char               *str;
1006    int                 dim[sDIMEN_MAX];
1007    int                 numdim, level;
1008    int                 filenum;
1009    symbol             *sym;
1010
1011 #if !defined NDEBUG
1012    cell                glbdecl = 0;
1013 #endif
1014
1015    filenum = fcurrent;          /* save file number at the start of the
1016                                  * declaration */
1017    do
1018      {
1019         size = 1;               /* single size (no array) */
1020         numdim = 0;             /* no dimensions */
1021         ident = iVARIABLE;
1022         if (firstname)
1023           {
1024              assert(strlen(firstname) <= sNAMEMAX);
1025              strcpy(name, firstname);   /* save symbol name */
1026              tag = firsttag;
1027              firstname = NULL;
1028           }
1029         else
1030           {
1031              tag = sc_addtag(NULL);
1032              if (lex(&val, &str) != tSYMBOL)    /* read in (new) token */
1033                 error(20, str); /* invalid symbol name */
1034              assert(strlen(str) <= sNAMEMAX);
1035              strcpy(name, str); /* save symbol name */
1036           }                     /* if */
1037         sym = findglb(name);
1038         if (!sym)
1039            sym = findconst(name);
1040         if (sym && (sym->usage & uDEFINE) != 0)
1041            error(21, name);     /* symbol already defined */
1042         ispublic = fpublic;
1043         if (name[0] == PUBLIC_CHAR)
1044           {
1045              ispublic = TRUE;   /* implicitly public variable */
1046              if (stock || fstatic)
1047                 error(42);      /* invalid combination of class specifiers */
1048           }                     /* if */
1049         while (matchtoken('['))
1050           {
1051              ident = iARRAY;
1052              if (numdim == sDIMEN_MAX)
1053                {
1054                   error(53);    /* exceeding maximum number of dimensions */
1055                   return;
1056                }                /* if */
1057              if (numdim > 0 && dim[numdim - 1] == 0)
1058                 error(52);      /* only last dimension may be variable length */
1059              size = needsub(&idxtag[numdim]);   /* get size; size==0 for
1060                                                  * "var[]" */
1061 #if INT_MAX < LONG_MAX
1062              if (size > INT_MAX)
1063                 error(105);     /* overflow, exceeding capacity */
1064 #endif
1065              if (ispublic)
1066                 error(56, name);        /* arrays cannot be public */
1067              dim[numdim++] = (int)size;
1068           }                     /* while */
1069         /* if this variable is never used (which can be detected only in
1070          * the second stage), shut off code generation; make an exception
1071          * for public variables
1072          */
1073         cidx = 0;               /* only to avoid a compiler warning */
1074         if (sc_status == statWRITE && sym
1075             && (sym->usage & (uREAD | uWRITTEN | uPUBLIC)) == 0)
1076           {
1077              sc_status = statSKIP;
1078              cidx = code_idx;
1079 #if !defined NDEBUG
1080              glbdecl = glb_declared;
1081 #endif
1082           }                     /* if */
1083         defsymbol(name, ident, sGLOBAL, sizeof(cell) * glb_declared, tag);
1084         begdseg();              /* real (initialized) data in data segment */
1085         assert(litidx == 0);    /* literal queue should be empty */
1086         if (sc_alignnext)
1087           {
1088              litidx = 0;
1089              aligndata(sc_dataalign);
1090              dumplits();        /* dump the literal queue */
1091              sc_alignnext = FALSE;
1092              litidx = 0;        /* global initial data is dumped, so restart at zero */
1093           }                     /* if */
1094         initials(ident, tag, &size, dim, numdim);       /* stores values in
1095                                                          * the literal queue */
1096         if (numdim == 1)
1097            dim[0] = (int)size;
1098         dumplits();             /* dump the literal queue */
1099         dumpzero((int)size - litidx);
1100         litidx = 0;
1101         if (!sym)
1102           {                     /* define only if not yet defined */
1103              sym =
1104                 addvariable(name, sizeof(cell) * glb_declared, ident, sGLOBAL,
1105                             tag, dim, numdim, idxtag);
1106           }
1107         else
1108           {                     /* if declared but not yet defined, adjust the
1109                                  * variable's address */
1110              sym->addr = sizeof(cell) * glb_declared;
1111              sym->usage |= uDEFINE;
1112           }                     /* if */
1113         if (ispublic)
1114            sym->usage |= uPUBLIC;
1115         if (fconst)
1116            sym->usage |= uCONST;
1117         if (stock)
1118            sym->usage |= uSTOCK;
1119         if (fstatic)
1120            sym->fnumber = filenum;
1121         if (ident == iARRAY)
1122            for (level = 0; level < numdim; level++)
1123               symbolrange(level, dim[level]);
1124         if (sc_status == statSKIP)
1125           {
1126              sc_status = statWRITE;
1127              code_idx = cidx;
1128              assert(glb_declared == glbdecl);
1129           }
1130         else
1131           {
1132              glb_declared += (int)size; /* add total number of cells */
1133           }                     /* if */
1134      }
1135    while (matchtoken(','));     /* enddo *//* more? */
1136    needtoken(tTERM);            /* if not comma, must be semicolumn */
1137 }
1138
1139 /*  declloc     - declare local symbols
1140  *
1141  *  Declare local (automatic) variables. Since these variables are
1142  *  relative to the STACK, there is no switch to the DATA segment.
1143  *  These variables cannot be initialized either.
1144  *
1145  *  global references: declared   (altered)
1146  *                     funcstatus (referred to only)
1147  */
1148 static int
1149 declloc(int fstatic)
1150 {
1151    int                 ident, tag;
1152    int                 idxtag[sDIMEN_MAX];
1153    char                name[sNAMEMAX + 1];
1154    symbol             *sym;
1155    cell                val, size;
1156    char               *str;
1157    value               lval = { NULL, 0, 0, 0, 0, NULL };
1158    int                 cur_lit = 0;
1159    int                 dim[sDIMEN_MAX];
1160    int                 numdim, level;
1161    int                 fconst;
1162
1163    fconst = matchtoken(tCONST);
1164    do
1165      {
1166         ident = iVARIABLE;
1167         size = 1;
1168         numdim = 0;             /* no dimensions */
1169         tag = sc_addtag(NULL);
1170         if (lex(&val, &str) != tSYMBOL) /* read in (new) token */
1171            error(20, str);      /* invalid symbol name */
1172         assert(strlen(str) <= sNAMEMAX);
1173         strcpy(name, str);      /* save symbol name */
1174         if (name[0] == PUBLIC_CHAR)
1175            error(56, name);     /* local variables cannot be public */
1176         /* Note: block locals may be named identical to locals at higher
1177          * compound blocks (as with standard C); so we must check (and add)
1178          * the "nesting level" of local variables to verify the
1179          * multi-definition of symbols.
1180          */
1181         if ((sym = findloc(name)) && sym->compound == nestlevel)
1182            error(21, name);     /* symbol already defined */
1183         /* Although valid, a local variable whose name is equal to that
1184          * of a global variable or to that of a local variable at a lower
1185          * level might indicate a bug.
1186          */
1187         if (((sym = findloc(name)) && sym->compound != nestlevel)
1188             || findglb(name))
1189            error(219, name);    /* variable shadows another symbol */
1190         while (matchtoken('['))
1191           {
1192              ident = iARRAY;
1193              if (numdim == sDIMEN_MAX)
1194                {
1195                   error(53);    /* exceeding maximum number of dimensions */
1196                   return ident;
1197                }                /* if */
1198              if (numdim > 0 && dim[numdim - 1] == 0)
1199                 error(52);      /* only last dimension may be variable length */
1200              size = needsub(&idxtag[numdim]);   /* get size; size==0 for "var[]" */
1201 #if INT_MAX < LONG_MAX
1202              if (size > INT_MAX)
1203                 error(105);     /* overflow, exceeding capacity */
1204 #endif
1205              dim[numdim++] = (int)size;
1206           }                     /* while */
1207         if (ident == iARRAY || fstatic)
1208           {
1209              if (sc_alignnext)
1210                {
1211                   aligndata(sc_dataalign);
1212                   sc_alignnext = FALSE;
1213                }                /* if */
1214              cur_lit = litidx;  /* save current index in the literal table */
1215              initials(ident, tag, &size, dim, numdim);
1216              if (size == 0)
1217                 return ident;   /* error message already given */
1218              if (numdim == 1)
1219                 dim[0] = (int)size;
1220           }                     /* if */
1221         /* reserve memory (on the stack) for the variable */
1222         if (fstatic)
1223           {
1224              /* write zeros for uninitialized fields */
1225              while (litidx < cur_lit + size)
1226                 stowlit(0);
1227              sym =
1228                 addvariable(name, (cur_lit + glb_declared) * sizeof(cell),
1229                             ident, sSTATIC, tag, dim, numdim, idxtag);
1230              defsymbol(name, ident, sSTATIC,
1231                        (cur_lit + glb_declared) * sizeof(cell), tag);
1232           }
1233         else
1234           {
1235              declared += (int)size;     /* variables are put on stack,
1236                                          * adjust "declared" */
1237              sym =
1238                 addvariable(name, -declared * sizeof(cell), ident, sLOCAL, tag,
1239                             dim, numdim, idxtag);
1240              defsymbol(name, ident, sLOCAL, -declared * sizeof(cell), tag);
1241              modstk(-(int)size * sizeof(cell));
1242           }                     /* if */
1243         /* now that we have reserved memory for the variable, we can
1244          * proceed to initialize it */
1245         sym->compound = nestlevel;      /* for multiple declaration/shadowing */
1246         if (fconst)
1247            sym->usage |= uCONST;
1248         if (ident == iARRAY)
1249            for (level = 0; level < numdim; level++)
1250               symbolrange(level, dim[level]);
1251         if (!fstatic)
1252           {                     /* static variables already initialized */
1253              if (ident == iVARIABLE)
1254                {
1255                   /* simple variable, also supports initialization */
1256                   int                 ctag = tag;       /* set to "tag" by default */
1257                   int                 explicit_init = FALSE;    /* is the variable explicitly
1258                                                                  * initialized? */
1259                   if (matchtoken('='))
1260                     {
1261                        doexpr(FALSE, FALSE, FALSE, FALSE, &ctag, TRUE);
1262                        explicit_init = TRUE;
1263                     }
1264                   else
1265                     {
1266                        const1(0);       /* uninitialized variable, set to zero */
1267                     }           /* if */
1268                   /* now try to save the value (still in PRI) in the variable */
1269                   lval.sym = sym;
1270                   lval.ident = iVARIABLE;
1271                   lval.constval = 0;
1272                   lval.tag = tag;
1273                   check_userop(NULL, ctag, lval.tag, 2, NULL, &ctag);
1274                   store(&lval);
1275                   endexpr(TRUE);        /* full expression ends after the store */
1276                   if (!matchtag(tag, ctag, TRUE))
1277                      error(213);        /* tag mismatch */
1278                   /* if the variable was not explicitly initialized, reset the
1279                    * "uWRITTEN" flag that store() set */
1280                   if (!explicit_init)
1281                      sym->usage &= ~uWRITTEN;
1282                }
1283              else
1284                {
1285                   /* an array */
1286                   if (litidx - cur_lit < size)
1287                      fillarray(sym, size * sizeof(cell), 0);
1288                   if (cur_lit < litidx)
1289                     {
1290                        /* check whether the complete array is set to a single value;
1291                         * if it is, more compact code can be generated */
1292                        cell                first = litq[cur_lit];
1293                        int                 i;
1294
1295                        for (i = cur_lit; i < litidx && litq[i] == first; i++)
1296                           /* nothing */ ;
1297                        if (i == litidx)
1298                          {
1299                             /* all values are the same */
1300                             fillarray(sym, (litidx - cur_lit) * sizeof(cell),
1301                                       first);
1302                             litidx = cur_lit;   /* reset literal table */
1303                          }
1304                        else
1305                          {
1306                             /* copy the literals to the array */
1307                             const1((cur_lit + glb_declared) * sizeof(cell));
1308                             copyarray(sym, (litidx - cur_lit) * sizeof(cell));
1309                          }      /* if */
1310                     }           /* if */
1311                }                /* if */
1312           }                     /* if */
1313      }
1314    while (matchtoken(','));     /* enddo *//* more? */
1315    needtoken(tTERM);            /* if not comma, must be semicolumn */
1316    return ident;
1317 }
1318
1319 static              cell
1320 calc_arraysize(int dim[], int numdim, int cur)
1321 {
1322    if (cur == numdim)
1323       return 0;
1324    return dim[cur] + (dim[cur] * calc_arraysize(dim, numdim, cur + 1));
1325 }
1326
1327 /*  initials
1328  *
1329  *  Initialize global objects and local arrays.
1330  *    size==array cells (count), if 0 on input, the routine counts
1331  *    the number of elements
1332  *    tag==required tagname id (not the returned tag)
1333  *
1334  *  Global references: litidx (altered)
1335  */
1336 static void
1337 initials(int ident, int tag, cell * size, int dim[], int numdim)
1338 {
1339    int                 ctag;
1340    int                 curlit = litidx;
1341    int                 d;
1342
1343    if (!matchtoken('='))
1344      {
1345         if (ident == iARRAY && dim[numdim - 1] == 0)
1346           {
1347              /* declared as "myvar[];" which is senseless (note: this *does* make
1348               * sense in the case of a iREFARRAY, which is a function parameter)
1349               */
1350              error(9);          /* array has zero length -> invalid size */
1351           }                     /* if */
1352         if (numdim > 1)
1353           {
1354              /* initialize the indirection tables */
1355 #if sDIMEN_MAX>2
1356 #error Array algorithms for more than 2 dimensions are not implemented
1357 #endif
1358              assert(numdim == 2);
1359              *size = calc_arraysize(dim, numdim, 0);
1360              for (d = 0; d < dim[0]; d++)
1361                 stowlit((dim[0] + d * (dim[1] - 1)) * sizeof(cell));
1362           }                     /* if */
1363         return;
1364      }                          /* if */
1365
1366    if (ident == iVARIABLE)
1367      {
1368         assert(*size == 1);
1369         init(ident, &ctag);
1370         if (!matchtag(tag, ctag, TRUE))
1371            error(213);          /* tag mismatch */
1372      }
1373    else
1374      {
1375         assert(numdim > 0);
1376         if (numdim == 1)
1377           {
1378              *size = initvector(ident, tag, dim[0], FALSE);
1379           }
1380         else
1381           {
1382              cell                offs, dsize;
1383
1384              /* The simple algorithm below only works for arrays with one or
1385               * two dimensions. This should be some recursive algorithm.
1386               */
1387              if (dim[numdim - 1] != 0)
1388                 /* set size to (known) full size */
1389                 *size = calc_arraysize(dim, numdim, 0);
1390              /* dump indirection tables */
1391              for (d = 0; d < dim[0]; d++)
1392                 stowlit(0);
1393              /* now dump individual vectors */
1394              needtoken('{');
1395              offs = dim[0];
1396              for (d = 0; d < dim[0]; d++)
1397                {
1398                   litq[curlit + d] = offs * sizeof(cell);
1399                   dsize = initvector(ident, tag, dim[1], TRUE);
1400                   offs += dsize - 1;
1401                   if (d + 1 < dim[0])
1402                      needtoken(',');
1403                   if (matchtoken('{') || matchtoken(tSTRING))
1404                      /* expect a '{' or a string */
1405                      lexpush();
1406                   else
1407                      break;
1408                }                /* for */
1409              matchtoken(',');
1410              needtoken('}');
1411           }                     /* if */
1412      }                          /* if */
1413
1414    if (*size == 0)
1415       *size = litidx - curlit;  /* number of elements defined */
1416 }
1417
1418 /*  initvector
1419  *  Initialize a single dimensional array
1420  */
1421 static              cell
1422 initvector(int ident, int tag, cell size, int fillzero)
1423 {
1424    cell                prev1 = 0, prev2 = 0;
1425    int                 ctag;
1426    int                 ellips = FALSE;
1427    int                 curlit = litidx;
1428
1429    assert(ident == iARRAY || ident == iREFARRAY);
1430    if (matchtoken('{'))
1431      {
1432         do
1433           {
1434              if (matchtoken('}'))
1435                {                /* to allow for trailing ',' after the initialization */
1436                   lexpush();
1437                   break;
1438                }                /* if */
1439              if ((ellips = matchtoken(tELLIPS)) != 0)
1440                 break;
1441              prev2 = prev1;
1442              prev1 = init(ident, &ctag);
1443              if (!matchtag(tag, ctag, TRUE))
1444                 error(213);     /* tag mismatch */
1445           }
1446         while (matchtoken(','));        /* do */
1447         needtoken('}');
1448      }
1449    else
1450      {
1451         init(ident, &ctag);
1452         if (!matchtag(tag, ctag, TRUE))
1453            error(213);          /* tagname mismatch */
1454      }                          /* if */
1455    /* fill up the literal queue with a series */
1456    if (ellips)
1457      {
1458         cell                step =
1459            ((litidx - curlit) == 1) ? (cell) 0 : prev1 - prev2;
1460         if (size == 0 || (litidx - curlit) == 0)
1461            error(41);           /* invalid ellipsis, array size unknown */
1462         else if ((litidx - curlit) == (int)size)
1463            error(18);           /* initialisation data exceeds declared size */
1464         while ((litidx - curlit) < (int)size)
1465           {
1466              prev1 += step;
1467              stowlit(prev1);
1468           }                     /* while */
1469      }                          /* if */
1470    if (fillzero && size > 0)
1471      {
1472         while ((litidx - curlit) < (int)size)
1473            stowlit(0);
1474      }                          /* if */
1475    if (size == 0)
1476      {
1477         size = litidx - curlit; /* number of elements defined */
1478      }
1479    else if (litidx - curlit > (int)size)
1480      {                          /* e.g. "myvar[3]={1,2,3,4};" */
1481         error(18);              /* initialisation data exceeds declared size */
1482         litidx = (int)size + curlit;    /* avoid overflow in memory moves */
1483      }                          /* if */
1484    return size;
1485 }
1486
1487 /*  init
1488  *
1489  *  Evaluate one initializer.
1490  */
1491 static              cell
1492 init(int ident, int *tag)
1493 {
1494    cell                i = 0;
1495
1496    if (matchtoken(tSTRING))
1497      {
1498         /* lex() automatically stores strings in the literal table (and
1499          * increases "litidx") */
1500         if (ident == iVARIABLE)
1501           {
1502              error(6);          /* must be assigned to an array */
1503              litidx = 1;        /* reset literal queue */
1504           }                     /* if */
1505         *tag = 0;
1506      }
1507    else if (constexpr(&i, tag))
1508      {
1509         stowlit(i);             /* store expression result in literal table */
1510      }                          /* if */
1511    return i;
1512 }
1513
1514 /*  needsub
1515  *
1516  *  Get required array size
1517  */
1518 static              cell
1519 needsub(int *tag)
1520 {
1521    cell                val;
1522
1523    *tag = 0;
1524    if (matchtoken(']'))         /* we've already seen "[" */
1525       return 0;                 /* null size (like "char msg[]") */
1526    constexpr(&val, tag);        /* get value (must be constant expression) */
1527    if (val < 0)
1528      {
1529         error(9);               /* negative array size is invalid; assumed zero */
1530         val = 0;
1531      }                          /* if */
1532    needtoken(']');
1533    return val;                  /* return array size */
1534 }
1535
1536 /*  decl_const  - declare a single constant
1537  *
1538  */
1539 static void
1540 decl_const(int vclass)
1541 {
1542    char                constname[sNAMEMAX + 1];
1543    cell                val;
1544    char               *str;
1545    int                 tag, exprtag;
1546    int                 symbolline;
1547
1548    tag = sc_addtag(NULL);
1549    if (lex(&val, &str) != tSYMBOL)      /* read in (new) token */
1550       error(20, str);           /* invalid symbol name */
1551    symbolline = fline;          /* save line where symbol was found */
1552    strcpy(constname, str);      /* save symbol name */
1553    needtoken('=');
1554    constexpr(&val, &exprtag);   /* get value */
1555    needtoken(tTERM);
1556    /* add_constant() checks for duplicate definitions */
1557    if (!matchtag(tag, exprtag, FALSE))
1558      {
1559         /* temporarily reset the line number to where the symbol was
1560          * defined */
1561         int                 orgfline = fline;
1562
1563         fline = symbolline;
1564         error(213);             /* tagname mismatch */
1565         fline = orgfline;
1566      }                          /* if */
1567    add_constant(constname, val, vclass, tag);
1568 }
1569
1570 /*  decl_enum   - declare enumerated constants
1571  *
1572  */
1573 static void
1574 decl_enum(int vclass)
1575 {
1576    char                enumname[sNAMEMAX + 1], constname[sNAMEMAX + 1];
1577    cell                val, value, size;
1578    char               *str;
1579    int                 tok, tag, explicittag;
1580    cell                increment, multiplier;
1581
1582    /* get an explicit tag, if any (we need to remember whether an
1583     * explicit tag was passed, even if that explicit tag was "_:", so we
1584     * cannot call sc_addtag() here
1585     */
1586    if (lex(&val, &str) == tLABEL)
1587      {
1588         tag = sc_addtag(str);
1589         explicittag = TRUE;
1590      }
1591    else
1592      {
1593         lexpush();
1594         tag = 0;
1595         explicittag = FALSE;
1596      }                          /* if */
1597
1598    /* get optional enum name (also serves as a tag if no explicit
1599     * tag was set) */
1600    if (lex(&val, &str) == tSYMBOL)
1601      {                          /* read in (new) token */
1602         strcpy(enumname, str);  /* save enum name (last constant) */
1603         if (!explicittag)
1604            tag = sc_addtag(enumname);
1605      }
1606    else
1607      {
1608         lexpush();              /* analyze again */
1609         enumname[0] = '\0';
1610      }                          /* if */
1611
1612    /* get increment and multiplier */
1613    increment = 1;
1614    multiplier = 1;
1615    if (matchtoken('('))
1616      {
1617         if (matchtoken(taADD))
1618           {
1619              constexpr(&increment, NULL);
1620           }
1621         else if (matchtoken(taMULT))
1622           {
1623              constexpr(&multiplier, NULL);
1624           }
1625         else if (matchtoken(taSHL))
1626           {
1627              constexpr(&val, NULL);
1628              while (val-- > 0)
1629                 multiplier *= 2;
1630           }                     /* if */
1631         needtoken(')');
1632      }                          /* if */
1633
1634    needtoken('{');
1635    /* go through all constants */
1636    value = 0;                   /* default starting value */
1637    do
1638      {
1639         if (matchtoken('}'))
1640           {                     /* quick exit if '}' follows ',' */
1641              lexpush();
1642              break;
1643           }                     /* if */
1644         tok = lex(&val, &str);  /* read in (new) token */
1645         if (tok != tSYMBOL && tok != tLABEL)
1646            error(20, str);      /* invalid symbol name */
1647         strcpy(constname, str); /* save symbol name */
1648         size = increment;       /* default increment of 'val' */
1649         if (tok == tLABEL || matchtoken(':'))
1650            constexpr(&size, NULL);      /* get size */
1651         if (matchtoken('='))
1652            constexpr(&value, NULL);     /* get value */
1653         /* add_constant() checks whether a variable (global or local) or
1654          * a constant with the same name already exists */
1655         add_constant(constname, value, vclass, tag);
1656         if (multiplier == 1)
1657            value += size;
1658         else
1659            value *= size * multiplier;
1660      }
1661    while (matchtoken(','));
1662    needtoken('}');              /* terminates the constant list */
1663    matchtoken(';');             /* eat an optional ; */
1664
1665    /* set the enum name to the last value plus one */
1666    if (enumname[0] != '\0')
1667       add_constant(enumname, value, vclass, tag);
1668 }
1669
1670 /*
1671  *  Finds a function in the global symbol table or creates a new entry.
1672  *  It does some basic processing and error checking.
1673  */
1674 symbol     *
1675 fetchfunc(char *name, int tag)
1676 {
1677    symbol             *sym;
1678    cell                offset;
1679
1680    offset = code_idx;
1681    if ((sc_debug & sSYMBOLIC) != 0)
1682      {
1683         offset += opcodes(1) + opargs(3) + nameincells(name);
1684         /* ^^^ The address for the symbol is the code address. But the
1685          * "symbol" instruction itself generates code. Therefore the
1686          * offset is pre-adjusted to the value it will have after the
1687          * symbol instruction.
1688          */
1689      }                          /* if */
1690    if ((sym = findglb(name)))
1691      {                          /* already in symbol table? */
1692         if (sym->ident != iFUNCTN)
1693           {
1694              error(21, name);   /* yes, but not as a function */
1695              return NULL;       /* make sure the old symbol is not damaged */
1696           }
1697         else if ((sym->usage & uDEFINE) != 0)
1698           {
1699              error(21, name);   /* yes, and it's already defined */
1700           }
1701         else if ((sym->usage & uNATIVE) != 0)
1702           {
1703              error(21, name);   /* yes, and it is an native */
1704           }                     /* if */
1705         assert(sym->vclass == sGLOBAL);
1706         if ((sym->usage & uDEFINE) == 0)
1707           {
1708              /* as long as the function stays undefined, update the address
1709               * and the tag */
1710              sym->addr = offset;
1711              sym->tag = tag;
1712           }                     /* if */
1713      }
1714    else
1715      {
1716         /* don't set the "uDEFINE" flag; it may be a prototype */
1717         sym = addsym(name, offset, iFUNCTN, sGLOBAL, tag, 0);
1718         /* assume no arguments */
1719         sym->dim.arglist = (arginfo *) malloc(1 * sizeof(arginfo));
1720         sym->dim.arglist[0].ident = 0;
1721         /* set library ID to NULL (only for native functions) */
1722         sym->x.lib = NULL;
1723      }                          /* if */
1724    return sym;
1725 }
1726
1727 /* This routine adds symbolic information for each argument.
1728  */
1729 static void
1730 define_args(void)
1731 {
1732    symbol             *sym;
1733
1734    /* At this point, no local variables have been declared. All
1735     * local symbols are function arguments.
1736     */
1737    sym = loctab.next;
1738    while (sym)
1739      {
1740         assert(sym->ident != iLABEL);
1741         assert(sym->vclass == sLOCAL);
1742         defsymbol(sym->name, sym->ident, sLOCAL, sym->addr, sym->tag);
1743         if (sym->ident == iREFARRAY)
1744           {
1745              symbol             *sub = sym;
1746
1747              while (sub)
1748                {
1749                   symbolrange(sub->dim.array.level, sub->dim.array.length);
1750                   sub = finddepend(sub);
1751                }                /* while */
1752           }                     /* if */
1753         sym = sym->next;
1754      }                          /* while */
1755 }
1756
1757 static int
1758 operatorname(char *name)
1759 {
1760    int                 opertok;
1761    char               *str;
1762    cell                val;
1763
1764    assert(name != NULL);
1765
1766    /* check the operator */
1767    opertok = lex(&val, &str);
1768    switch (opertok)
1769      {
1770      case '+':
1771      case '-':
1772      case '*':
1773      case '/':
1774      case '%':
1775      case '>':
1776      case '<':
1777      case '!':
1778      case '~':
1779      case '=':
1780         name[0] = (char)opertok;
1781         name[1] = '\0';
1782         break;
1783      case tINC:
1784         strcpy(name, "++");
1785         break;
1786      case tDEC:
1787         strcpy(name, "--");
1788         break;
1789      case tlEQ:
1790         strcpy(name, "==");
1791         break;
1792      case tlNE:
1793         strcpy(name, "!=");
1794         break;
1795      case tlLE:
1796         strcpy(name, "<=");
1797         break;
1798      case tlGE:
1799         strcpy(name, ">=");
1800         break;
1801      default:
1802         name[0] = '\0';
1803         error(61);              /* operator cannot be redefined
1804                                  * (or bad operator name) */
1805         return 0;
1806      }                          /* switch */
1807
1808    return opertok;
1809 }
1810
1811 static int
1812 operatoradjust(int opertok, symbol * sym, char *opername, int resulttag)
1813 {
1814    int                 tags[2] = { 0, 0 };
1815    int                 count = 0;
1816    arginfo            *arg;
1817    char                tmpname[sNAMEMAX + 1];
1818    symbol             *oldsym;
1819
1820    if (opertok == 0)
1821       return TRUE;
1822
1823    /* count arguments and save (first two) tags */
1824    while (arg = &sym->dim.arglist[count], arg->ident != 0)
1825      {
1826         if (count < 2)
1827           {
1828              if (arg->numtags > 1)
1829                 error(65, count + 1);   /* function argument may only have
1830                                          * a single tag */
1831              else if (arg->numtags == 1)
1832                 tags[count] = arg->tags[0];
1833           }                     /* if */
1834         if (opertok == '~' && count == 0)
1835           {
1836              if (arg->ident != iREFARRAY)
1837                 error(73, arg->name);   /* must be an array argument */
1838           }
1839         else
1840           {
1841              if (arg->ident != iVARIABLE)
1842                 error(66, arg->name);   /* must be non-reference argument */
1843           }                     /* if */
1844         if (arg->hasdefault)
1845            error(59, arg->name);        /* arguments of an operator may not
1846                                          * have a default value */
1847         count++;
1848      }                          /* while */
1849
1850    /* for '!', '++' and '--', count must be 1
1851     * for '-', count may be 1 or 2
1852     * for '=', count must be 1, and the resulttag is also important
1853     * for all other (binary) operators and the special '~'
1854     * operator, count must be 2
1855     */
1856    switch (opertok)
1857      {
1858      case '!':
1859      case '=':
1860      case tINC:
1861      case tDEC:
1862         if (count != 1)
1863            error(62);           /* number or placement of the operands does
1864                                  * not fit the operator */
1865         break;
1866      case '-':
1867         if (count != 1 && count != 2)
1868            error(62);           /* number or placement of the operands does
1869                                  * not fit the operator */
1870         break;
1871      default:
1872         if (count != 2)
1873            error(62);           /* number or placement of the operands does
1874                                  * not fit the operator */
1875      }                          /* switch */
1876
1877    if (tags[0] == 0
1878        && ((opertok != '=' && tags[1] == 0) || (opertok == '=' && resulttag == 0)))
1879       error(64);                /* cannot change predefined operators */
1880
1881    /* change the operator name */
1882    assert(opername[0] != '\0');
1883    operator_symname(tmpname, opername, tags[0], tags[1], count, resulttag);
1884    if ((oldsym = findglb(tmpname)))
1885      {
1886         int                 i;
1887
1888         if ((oldsym->usage & uDEFINE) != 0)
1889           {
1890              char                errname[2 * sNAMEMAX + 16];
1891
1892              funcdisplayname(errname, tmpname);
1893              error(21, errname);        /* symbol already defined */
1894           }                     /* if */
1895         sym->usage |= oldsym->usage;    /* copy flags from the previous
1896                                          * definition */
1897         for (i = 0; i < oldsym->numrefers; i++)
1898            if (oldsym->refer[i])
1899               refer_symbol(sym, oldsym->refer[i]);
1900         delete_symbol(&glbtab, oldsym);
1901      }                          /* if */
1902    if ((sc_debug & sSYMBOLIC) != 0)
1903       sym->addr += nameincells(tmpname) - nameincells(sym->name);
1904    strcpy(sym->name, tmpname);
1905    sym->hash = namehash(sym->name);     /* calculate new hash */
1906
1907    /* operators should return a value, except the '~' operator */
1908    if (opertok != '~')
1909       sym->usage |= uRETVALUE;
1910
1911    return TRUE;
1912 }
1913
1914 static int
1915 check_operatortag(int opertok, int resulttag, char *opername)
1916 {
1917    assert(opername != NULL && opername[0] != '\0');
1918    switch (opertok)
1919      {
1920      case '!':
1921      case '<':
1922      case '>':
1923      case tlEQ:
1924      case tlNE:
1925      case tlLE:
1926      case tlGE:
1927         if (resulttag != sc_addtag("bool"))
1928           {
1929              error(63, opername, "bool:");      /* operator X requires
1930                                                  * a "bool:" result tag */
1931              return FALSE;
1932           }                     /* if */
1933         break;
1934      case '~':
1935         if (resulttag != 0)
1936           {
1937              error(63, opername, "_:"); /* operator "~" requires
1938                                          * a "_:" result tag */
1939              return FALSE;
1940           }                     /* if */
1941         break;
1942      }                          /* switch */
1943    return TRUE;
1944 }
1945
1946 static char        *
1947 tag2str(char *dest, int tag)
1948 {
1949    tag &= TAGMASK;
1950    assert(tag >= 0);
1951    sprintf(dest, "0%x", tag);
1952    return sc_isdigit(dest[1]) ? &dest[1] : dest;
1953 }
1954
1955 char       *
1956 operator_symname(char *symname, char *opername, int tag1, int tag2,
1957                  int numtags, int resulttag)
1958 {
1959    char                tagstr1[10], tagstr2[10];
1960    int                 opertok;
1961
1962    assert(numtags >= 1 && numtags <= 2);
1963    opertok = (opername[1] == '\0') ? opername[0] : 0;
1964    if (opertok == '=')
1965       sprintf(symname, "%s%s%s", tag2str(tagstr1, resulttag), opername,
1966               tag2str(tagstr2, tag1));
1967    else if (numtags == 1 || opertok == '~')
1968       sprintf(symname, "%s%s", opername, tag2str(tagstr1, tag1));
1969    else
1970       sprintf(symname, "%s%s%s", tag2str(tagstr1, tag1), opername,
1971               tag2str(tagstr2, tag2));
1972    return symname;
1973 }
1974
1975 static int
1976 parse_funcname(char *fname, int *tag1, int *tag2, char *opname)
1977 {
1978    char               *ptr, *name;
1979    int                 unary;
1980
1981    /* tags are only positive, so if the function name starts with a '-',
1982     * the operator is an unary '-' or '--' operator.
1983     */
1984    if (*fname == '-')
1985      {
1986         *tag1 = 0;
1987         unary = TRUE;
1988         ptr = fname;
1989      }
1990    else
1991      {
1992         *tag1 = (int)strtol(fname, &ptr, 16);
1993         unary = ptr == fname;   /* unary operator if it doesn't start
1994                                  * with a tag name */
1995      }                          /* if */
1996    assert(!unary || *tag1 == 0);
1997    assert(*ptr != '\0');
1998    for (name = opname; !sc_isdigit(*ptr);)
1999       *name++ = *ptr++;
2000    *name = '\0';
2001    *tag2 = (int)strtol(ptr, NULL, 16);
2002    return unary;
2003 }
2004
2005 char       *
2006 funcdisplayname(char *dest, char *funcname)
2007 {
2008    int                 tags[2];
2009    char                opname[10];
2010    constvalue         *tagsym[2];
2011    int                 unary;
2012
2013    if (sc_isalpha(*funcname) || *funcname == '_' || *funcname == PUBLIC_CHAR
2014        || *funcname == '\0')
2015      {
2016         if (dest != funcname)
2017            strcpy(dest, funcname);
2018         return dest;
2019      }                          /* if */
2020
2021    unary = parse_funcname(funcname, &tags[0], &tags[1], opname);
2022    tagsym[1] = find_constval_byval(&tagname_tab, tags[1]);
2023    assert(tagsym[1] != NULL);
2024    if (unary)
2025      {
2026         sprintf(dest, "operator%s(%s:)", opname, tagsym[1]->name);
2027      }
2028    else
2029      {
2030         tagsym[0] = find_constval_byval(&tagname_tab, tags[0]);
2031         /* special case: the assignment operator has the return value
2032          * as the 2nd tag */
2033         if (opname[0] == '=' && opname[1] == '\0')
2034            sprintf(dest, "%s:operator%s(%s:)", tagsym[0]->name, opname,
2035                    tagsym[1]->name);
2036         else
2037            sprintf(dest, "operator%s(%s:,%s:)", opname, tagsym[0]->name,
2038                    tagsym[1]->name);
2039      }                          /* if */
2040    return dest;
2041 }
2042
2043 static void
2044 funcstub(int native)
2045 {
2046    int                 tok, tag;
2047    char               *str;
2048    cell                val;
2049    char                symbolname[sNAMEMAX + 1];
2050    symbol             *sym;
2051    int                 opertok;
2052
2053    opertok = 0;
2054    lastst = 0;
2055    litidx = 0;                  /* clear the literal pool */
2056
2057    tag = sc_addtag(NULL);
2058    tok = lex(&val, &str);
2059    if (native)
2060      {
2061         if (tok == tPUBLIC || tok == tSTOCK || tok == tSTATIC ||
2062             (tok == tSYMBOL && *str == PUBLIC_CHAR))
2063            error(42);           /* invalid combination of class specifiers */
2064      }
2065    else
2066      {
2067         if (tok == tPUBLIC || tok == tSTATIC)
2068            tok = lex(&val, &str);
2069      }                          /* if */
2070    if (tok == tOPERATOR)
2071      {
2072         opertok = operatorname(symbolname);
2073         if (opertok == 0)
2074            return;              /* error message already given */
2075         check_operatortag(opertok, tag, symbolname);
2076      }
2077    else
2078      {
2079         if (tok != tSYMBOL && freading)
2080           {
2081              error(10);         /* illegal function or declaration */
2082              return;
2083           }                     /* if */
2084         strcpy(symbolname, str);
2085      }                          /* if */
2086    needtoken('(');              /* only functions may be native/forward */
2087
2088    sym = fetchfunc(symbolname, tag);    /* get a pointer to the
2089                                          * function entry */
2090    if (!sym)
2091       return;
2092    if (native)
2093      {
2094         sym->usage = uNATIVE | uRETVALUE | uDEFINE;
2095         sym->x.lib = curlibrary;
2096      }                          /* if */
2097
2098    declargs(sym);
2099    /* "declargs()" found the ")" */
2100    if (!operatoradjust(opertok, sym, symbolname, tag))
2101       sym->usage &= ~uDEFINE;
2102    /* for a native operator, also need to specify an "exported"
2103     * function name; for a native function, this is optional
2104     */
2105    if (native)
2106      {
2107         if (opertok != 0)
2108           {
2109              needtoken('=');
2110              lexpush();         /* push back, for matchtoken() to retrieve again */
2111           }                     /* if */
2112         if (matchtoken('='))
2113           {
2114              /* allow number or symbol */
2115              if (matchtoken(tSYMBOL))
2116                {
2117                   tokeninfo(&val, &str);
2118                   if (strlen(str) > sEXPMAX)
2119                     {
2120                        error(220, str, sEXPMAX);
2121                        str[sEXPMAX] = '\0';
2122                     }           /* if */
2123                   insert_alias(sym->name, str);
2124                }
2125              else
2126                {
2127                   constexpr(&val, NULL);
2128                   sym->addr = val;
2129                   /*
2130                    * ?? Must mark this address, so that it won't be generated again
2131                    * and it won't be written to the output file. At the moment,
2132                    * I have assumed that this syntax is only valid if val < 0.
2133                    * To properly mix "normal" native functions and indexed native
2134                    * functions, one should use negative indices anyway.
2135                    * Special code for a negative index in sym->addr exists in
2136                    * SC4.C (ffcall()) and in SC6.C (the loops for counting the
2137                    * number of native variables and for writing them).
2138                    */
2139                }                /* if */
2140           }                     /* if */
2141      }                          /* if */
2142    needtoken(tTERM);
2143
2144    litidx = 0;                  /* clear the literal pool */
2145    /* clear local variables queue */
2146    delete_symbols(&loctab, 0, TRUE, TRUE);
2147 }
2148
2149 /*  newfunc    - begin a function
2150  *
2151  *  This routine is called from "parse" and tries to make a function
2152  *  out of the following text
2153  *
2154  *  Global references: funcstatus,lastst,litidx
2155  *                     rettype  (altered)
2156  *                     curfunc  (altered)
2157  *                     declared (altered)
2158  *                     glb_declared (altered)
2159  *                     sc_alignnext (altered)
2160  */
2161 static int
2162 newfunc(char *firstname, int firsttag, int fpublic, int fstatic, int stock)
2163 {
2164    symbol             *sym;
2165    int                 argcnt, tok, tag, funcline;
2166    int                 opertok, opererror;
2167    char                symbolname[sNAMEMAX + 1];
2168    char               *str;
2169    cell                val, cidx, glbdecl;
2170    int                 filenum;
2171
2172    litidx = 0;                  /* clear the literal pool ??? */
2173    opertok = 0;
2174    lastst = 0;                  /* no statement yet */
2175    cidx = 0;                    /* just to avoid compiler warnings */
2176    glbdecl = 0;
2177    filenum = fcurrent;          /* save file number at start of declaration */
2178
2179    if (firstname)
2180      {
2181         assert(strlen(firstname) <= sNAMEMAX);
2182         strcpy(symbolname, firstname);  /* save symbol name */
2183         tag = firsttag;
2184      }
2185    else
2186      {
2187         tag = (firsttag >= 0) ? firsttag : sc_addtag(NULL);
2188         tok = lex(&val, &str);
2189         assert(!fpublic);
2190         if (tok == tNATIVE || (tok == tPUBLIC && stock))
2191            error(42);           /* invalid combination of class specifiers */
2192         if (tok == tOPERATOR)
2193           {
2194              opertok = operatorname(symbolname);
2195              if (opertok == 0)
2196                 return TRUE;    /* error message already given */
2197              check_operatortag(opertok, tag, symbolname);
2198           }
2199         else
2200           {
2201              if (tok != tSYMBOL && freading)
2202                {
2203                   error(20, str);       /* invalid symbol name */
2204                   return FALSE;
2205                }                /* if */
2206              assert(strlen(str) <= sNAMEMAX);
2207              strcpy(symbolname, str);
2208           }                     /* if */
2209      }                          /* if */
2210    /* check whether this is a function or a variable declaration */
2211    if (!matchtoken('('))
2212       return FALSE;
2213    /* so it is a function, proceed */
2214    funcline = fline;            /* save line at which the function is defined */
2215    if (symbolname[0] == PUBLIC_CHAR)
2216      {
2217         fpublic = TRUE;         /* implicitly public function */
2218         if (stock)
2219            error(42);           /* invalid combination of class specifiers */
2220      }                          /* if */
2221    sym = fetchfunc(symbolname, tag);    /* get a pointer to the
2222                                          * function entry */
2223    if (!sym)
2224       return TRUE;
2225    if (fpublic)
2226       sym->usage |= uPUBLIC;
2227    if (fstatic)
2228       sym->fnumber = filenum;
2229    /* declare all arguments */
2230    argcnt = declargs(sym);
2231    opererror = !operatoradjust(opertok, sym, symbolname, tag);
2232    if (strcmp(symbolname, uMAINFUNC) == 0)
2233      {
2234         if (argcnt > 0)
2235            error(5);            /* "main()" function may not have any arguments */
2236         sym->usage |= uREAD;    /* "main()" is the program's entry point:
2237                                  * always used */
2238      }                          /* if */
2239    /* "declargs()" found the ")"; if a ";" appears after this, it was a
2240     * prototype */
2241    if (matchtoken(';'))
2242      {
2243         if (!sc_needsemicolon)
2244            error(218);          /* old style prototypes used with optional
2245                                  * semicolumns */
2246         delete_symbols(&loctab, 0, TRUE, TRUE); /* prototype is done;
2247                                                  * forget everything */
2248         return TRUE;
2249      }                          /* if */
2250    /* so it is not a prototype, proceed */
2251    /* if this is a function that is not referred to (this can only be
2252     * detected in the second stage), shut code generation off */
2253    if (sc_status == statWRITE && (sym->usage & uREAD) == 0)
2254      {
2255         sc_status = statSKIP;
2256         cidx = code_idx;
2257         glbdecl = glb_declared;
2258      }                          /* if */
2259    begcseg();
2260    sym->usage |= uDEFINE;       /* set the definition flag */
2261    if (fpublic)
2262       sym->usage |= uREAD;      /* public functions are always "used" */
2263    if (stock)
2264       sym->usage |= uSTOCK;
2265    if (opertok != 0 && opererror)
2266       sym->usage &= ~uDEFINE;
2267    defsymbol(sym->name, iFUNCTN, sGLOBAL,
2268              code_idx + opcodes(1) + opargs(3) + nameincells(sym->name), tag);
2269    /* ^^^ The address for the symbol is the code address. But the
2270     * "symbol" instruction itself generates code. Therefore the
2271     * offset is pre-adjusted to the value it will have after the
2272     * symbol instruction.
2273     */
2274    startfunc(sym->name);        /* creates stack frame */
2275    if ((sc_debug & sSYMBOLIC) != 0)
2276       setline(funcline, fcurrent);
2277    if (sc_alignnext)
2278      {
2279         alignframe(sc_dataalign);
2280         sc_alignnext = FALSE;
2281      }                          /* if */
2282    declared = 0;                /* number of local cells */
2283    rettype = (sym->usage & uRETVALUE);  /* set "return type" variable */
2284    curfunc = sym;
2285    define_args();               /* add the symbolic info for the function arguments */
2286    statement(NULL, FALSE);
2287    if ((rettype & uRETVALUE) != 0)
2288       sym->usage |= uRETVALUE;
2289    if (declared != 0)
2290      {
2291         /* This happens only in a very special (and useless) case, where a
2292          * function has only a single statement in its body (no compound
2293          * block) and that statement declares a new variable
2294          */
2295         modstk((int)declared * sizeof(cell));   /* remove all local
2296                                                  * variables */
2297         declared = 0;
2298      }                          /* if */
2299    if ((lastst != tRETURN) && (lastst != tGOTO))
2300      {
2301         const1(0);
2302         ffret();
2303         if ((sym->usage & uRETVALUE) != 0)
2304           {
2305              char                symname[2 * sNAMEMAX + 16];    /* allow space for user
2306                                                                  * defined operators */
2307              funcdisplayname(symname, sym->name);
2308              error(209, symname);       /* function should return a value */
2309           }                     /* if */
2310      }                          /* if */
2311    endfunc();
2312    if (litidx)
2313      {                          /* if there are literals defined */
2314         glb_declared += litidx;
2315         begdseg();              /* flip to DATA segment */
2316         dumplits();             /* dump literal strings */
2317         litidx = 0;
2318      }                          /* if */
2319    testsymbols(&loctab, 0, TRUE, TRUE); /* test for unused arguments
2320                                          * and labels */
2321    delete_symbols(&loctab, 0, TRUE, TRUE);      /* clear local variables
2322                                                  * queue */
2323    assert(loctab.next == NULL);
2324    curfunc = NULL;
2325    if (sc_status == statSKIP)
2326      {
2327         sc_status = statWRITE;
2328         code_idx = cidx;
2329         glb_declared = glbdecl;
2330      }                          /* if */
2331    return TRUE;
2332 }
2333
2334 static int
2335 argcompare(arginfo * a1, arginfo * a2)
2336 {
2337    int                 result, level;
2338
2339    result = strcmp(a1->name, a2->name) == 0;
2340    if (result)
2341       result = a1->ident == a2->ident;
2342    if (result)
2343       result = a1->usage == a2->usage;
2344    if (result)
2345       result = a1->numtags == a2->numtags;
2346    if (result)
2347      {
2348         int                 i;
2349
2350         for (i = 0; i < a1->numtags && result; i++)
2351            result = a1->tags[i] == a2->tags[i];
2352      }                          /* if */
2353    if (result)
2354       result = a1->hasdefault == a2->hasdefault;
2355    if (a1->hasdefault)
2356      {
2357         if (a1->ident == iREFARRAY)
2358           {
2359              if (result)
2360                 result = a1->defvalue.array.size == a2->defvalue.array.size;
2361              if (result)
2362                 result =
2363                    a1->defvalue.array.arraysize == a2->defvalue.array.arraysize;
2364              /* also check the dimensions of both arrays */
2365              if (result)
2366                 result = a1->numdim == a2->numdim;
2367              for (level = 0; result && level < a1->numdim; level++)
2368                 result = a1->dim[level] == a2->dim[level];
2369              /* ??? should also check contents of the default array
2370               * (these troubles go away in a 2-pass compiler that forbids
2371               * double declarations, but Small currently does not forbid them)
2372               */
2373           }
2374         else
2375           {
2376              if (result)
2377                {
2378                   if ((a1->hasdefault & uSIZEOF) != 0
2379                       || (a1->hasdefault & uTAGOF) != 0)
2380                      result = a1->hasdefault == a2->hasdefault
2381                         && strcmp(a1->defvalue.size.symname,
2382                                   a2->defvalue.size.symname) == 0
2383                         && a1->defvalue.size.level == a2->defvalue.size.level;
2384                   else
2385                      result = a1->defvalue.val == a2->defvalue.val;
2386                }                /* if */
2387           }                     /* if */
2388         if (result)
2389            result = a1->defvalue_tag == a2->defvalue_tag;
2390      }                          /* if */
2391    return result;
2392 }
2393
2394 /*  declargs()
2395  *
2396  *  This routine adds an entry in the local symbol table for each
2397  *  argument found in the argument list.
2398  *  It returns the number of arguments.
2399  */
2400 static int
2401 declargs(symbol * sym)
2402 {
2403 #define MAXTAGS 16
2404    char               *ptr;
2405    int                 argcnt, oldargcnt, tok, tags[MAXTAGS], numtags;
2406    cell                val;
2407    arginfo             arg, *arglist;
2408    char                name[sNAMEMAX + 1];
2409    int                 ident, fpublic, fconst;
2410    int                 idx;
2411
2412    /* if the function is already defined earlier, get the number of
2413     * arguments of the existing definition
2414     */
2415    oldargcnt = 0;
2416    if ((sym->usage & uPROTOTYPED) != 0)
2417       while (sym->dim.arglist[oldargcnt].ident != 0)
2418          oldargcnt++;
2419    argcnt = 0;                  /* zero aruments up to now */
2420    ident = iVARIABLE;
2421    numtags = 0;
2422    fconst = FALSE;
2423    fpublic = (sym->usage & uPUBLIC) != 0;
2424    /* the '(' parantheses has already been parsed */
2425    if (!matchtoken(')'))
2426      {
2427         do
2428           {                     /* there are arguments; process them */
2429              /* any legal name increases argument count (and stack offset) */
2430              tok = lex(&val, &ptr);
2431              switch (tok)
2432                {
2433                case 0:
2434                   /* nothing */
2435                   break;
2436                case '&':
2437                   if (ident != iVARIABLE || numtags > 0)
2438                      error(1, "-identifier-", "&");
2439                   ident = iREFERENCE;
2440                   break;
2441                case tCONST:
2442                   if (ident != iVARIABLE || numtags > 0)
2443                      error(1, "-identifier-", "const");
2444                   fconst = TRUE;
2445                   break;
2446                case tLABEL:
2447                   if (numtags > 0)
2448                      error(1, "-identifier-", "-tagname-");
2449                   tags[0] = sc_addtag(ptr);
2450                   numtags = 1;
2451                   break;
2452                case '{':
2453                   if (numtags > 0)
2454                      error(1, "-identifier-", "-tagname-");
2455                   numtags = 0;
2456                   while (numtags < MAXTAGS)
2457                     {
2458                        if (!matchtoken('_') && !needtoken(tSYMBOL))
2459                           break;
2460                        tokeninfo(&val, &ptr);
2461                        tags[numtags++] = sc_addtag(ptr);
2462                        if (matchtoken('}'))
2463                           break;
2464                        needtoken(',');
2465                     }           /* for */
2466                   needtoken(':');
2467                   tok = tLABEL; /* for outer loop:
2468                                  * flag that we have seen a tagname */
2469                   break;
2470                case tSYMBOL:
2471                   if (argcnt >= sMAXARGS)
2472                      error(45); /* too many function arguments */
2473                   strcpy(name, ptr);    /* save symbol name */
2474                   if (name[0] == PUBLIC_CHAR)
2475                      error(56, name);   /* function arguments cannot be public */
2476                   if (numtags == 0)
2477                      tags[numtags++] = 0;       /* default tag */
2478                   /* Stack layout:
2479                    *   base + 0*sizeof(cell)  == previous "base"
2480                    *   base + 1*sizeof(cell)  == function return address
2481                    *   base + 2*sizeof(cell)  == number of arguments
2482                    *   base + 3*sizeof(cell)  == first argument of the function
2483                    * So the offset of each argument is:
2484                    * "(argcnt+3) * sizeof(cell)".
2485                    */
2486                   doarg(name, ident, (argcnt + 3) * sizeof(cell), tags, numtags,
2487                         fpublic, fconst, &arg);
2488                   if (fpublic && arg.hasdefault)
2489                      error(59, name);   /* arguments of a public function may not
2490                                          * have a default value */
2491                   if ((sym->usage & uPROTOTYPED) == 0)
2492                     {
2493                        /* redimension the argument list, add the entry */
2494                        sym->dim.arglist =
2495                           (arginfo *) realloc(sym->dim.arglist,
2496                                               (argcnt + 2) * sizeof(arginfo));
2497                        if (!sym->dim.arglist)
2498                           error(103);   /* insufficient memory */
2499                        sym->dim.arglist[argcnt] = arg;
2500                        sym->dim.arglist[argcnt + 1].ident = 0;  /* keep the list
2501                                                                  * terminated */
2502                     }
2503                   else
2504                     {
2505                        /* check the argument with the earlier definition */
2506                        if (argcnt > oldargcnt
2507                            || !argcompare(&sym->dim.arglist[argcnt], &arg))
2508                           error(25);    /* function definition does not match prototype */
2509                        /* may need to free default array argument and the tag list */
2510                        if (arg.ident == iREFARRAY && arg.hasdefault)
2511                           free(arg.defvalue.array.data);
2512                        else if (arg.ident == iVARIABLE
2513                                 && ((arg.hasdefault & uSIZEOF) != 0
2514                                     || (arg.hasdefault & uTAGOF) != 0))
2515                           free(arg.defvalue.size.symname);
2516                        free(arg.tags);
2517                     }           /* if */
2518                   argcnt++;
2519                   ident = iVARIABLE;
2520                   numtags = 0;
2521                   fconst = FALSE;
2522                   break;
2523                case tELLIPS:
2524                   if (ident != iVARIABLE)
2525                      error(10); /* illegal function or declaration */
2526                   if (numtags == 0)
2527                      tags[numtags++] = 0;       /* default tag */
2528                   if ((sym->usage & uPROTOTYPED) == 0)
2529                     {
2530                        /* redimension the argument list, add the entry iVARARGS */
2531                        sym->dim.arglist =
2532                           (arginfo *) realloc(sym->dim.arglist,
2533                                               (argcnt + 2) * sizeof(arginfo));
2534                        if (!sym->dim.arglist)
2535                           error(103);   /* insufficient memory */
2536                        sym->dim.arglist[argcnt + 1].ident = 0;  /* keep the list
2537                                                                  * terminated */
2538                        sym->dim.arglist[argcnt].ident = iVARARGS;
2539                        sym->dim.arglist[argcnt].hasdefault = FALSE;
2540                        sym->dim.arglist[argcnt].defvalue.val = 0;
2541                        sym->dim.arglist[argcnt].defvalue_tag = 0;
2542                        sym->dim.arglist[argcnt].numtags = numtags;
2543                        sym->dim.arglist[argcnt].tags =
2544                           (int *)malloc(numtags * sizeof tags[0]);
2545                        if (!sym->dim.arglist[argcnt].tags)
2546                           error(103);   /* insufficient memory */
2547                        memcpy(sym->dim.arglist[argcnt].tags, tags,
2548                               numtags * sizeof tags[0]);
2549                     }
2550                   else
2551                     {
2552                        if (argcnt > oldargcnt
2553                            || sym->dim.arglist[argcnt].ident != iVARARGS)
2554                           error(25);    /* function definition does not match prototype */
2555                     }           /* if */
2556                   argcnt++;
2557                   break;
2558                default:
2559                   error(10);    /* illegal function or declaration */
2560                }                /* switch */
2561           }
2562         while (tok == '&' || tok == tLABEL || tok == tCONST || (tok != tELLIPS && matchtoken(',')));    /* more? */
2563         /* if the next token is not ",", it should be ")" */
2564         needtoken(')');
2565      }                          /* if */
2566    /* resolve any "sizeof" arguments (now that all arguments are known) */
2567    assert(sym->dim.arglist != NULL);
2568    arglist = sym->dim.arglist;
2569    for (idx = 0; idx < argcnt && arglist[idx].ident != 0; idx++)
2570      {
2571         if ((arglist[idx].hasdefault & uSIZEOF) != 0
2572             || (arglist[idx].hasdefault & uTAGOF) != 0)
2573           {
2574              int                 altidx;
2575
2576              /* Find the argument with the name mentioned after the "sizeof".
2577               * Note that we cannot use findloc here because we need the
2578               * arginfo struct, not the symbol.
2579               */
2580              ptr = arglist[idx].defvalue.size.symname;
2581              for (altidx = 0;
2582                   altidx < argcnt && strcmp(ptr, arglist[altidx].name) != 0;
2583                   altidx++)
2584                 /* nothing */ ;
2585              if (altidx >= argcnt)
2586                {
2587                   error(17, ptr);       /* undefined symbol */
2588                }
2589              else
2590                {
2591                   /* check the level against the number of dimensions */
2592                   /* the level must be zero for "tagof" values */
2593                   assert(arglist[idx].defvalue.size.level == 0
2594                          || (arglist[idx].hasdefault & uSIZEOF) != 0);
2595                   if (arglist[idx].defvalue.size.level > 0
2596                       && arglist[idx].defvalue.size.level >=
2597                       arglist[altidx].numdim)
2598                      error(28); /* invalid subscript */
2599                   if (arglist[altidx].ident != iREFARRAY)
2600                     {
2601                        assert(arglist[altidx].ident == iVARIABLE
2602                               || arglist[altidx].ident == iREFERENCE);
2603                        error(223, ptr); /* redundant sizeof */
2604                     }           /* if */
2605                }                /* if */
2606           }                     /* if */
2607      }                          /* for */
2608
2609    sym->usage |= uPROTOTYPED;
2610    errorset(sRESET);            /* reset error flag (clear the "panic mode") */
2611    return argcnt;
2612 }
2613
2614 /*  doarg       - declare one argument type
2615  *
2616  * this routine is called from "declargs()" and adds an entry in the
2617  * local  symbol table for one argument. "fpublic" indicates whether
2618  * the function for this argument list is public.
2619  * The arguments themselves are never public.
2620  */
2621 static void
2622 doarg(char *name, int ident, int offset, int tags[], int numtags,
2623       int fpublic, int fconst, arginfo * arg)
2624 {
2625    symbol             *argsym;
2626    cell                size;
2627    int                 idxtag[sDIMEN_MAX];
2628
2629    strcpy(arg->name, name);
2630    arg->hasdefault = FALSE;     /* preset (most common case) */
2631    arg->defvalue.val = 0;       /* clear */
2632    arg->defvalue_tag = 0;
2633    arg->numdim = 0;
2634    if (matchtoken('['))
2635      {
2636         if (ident == iREFERENCE)
2637            error(67, name);     /*illegal declaration ("&name[]" is unsupported) */
2638         do
2639           {
2640              if (arg->numdim == sDIMEN_MAX)
2641                {
2642                   error(53);    /* exceeding maximum number of dimensions */
2643                   return;
2644                }                /* if */
2645              /* there is no check for non-zero major dimensions here, only if
2646               * the array parameter has a default value, we enforce that all
2647               * array dimensions, except the last, are non-zero
2648               */
2649              size = needsub(&idxtag[arg->numdim]);      /* may be zero here,
2650                                                          *it is a pointer anyway */
2651 #if INT_MAX < LONG_MAX
2652              if (size > INT_MAX)
2653                 error(105);     /* overflow, exceeding capacity */
2654 #endif
2655              arg->dim[arg->numdim] = (int)size;
2656              arg->numdim += 1;
2657           }
2658         while (matchtoken('['));
2659         ident = iREFARRAY;      /* "reference to array" (is a pointer) */
2660         if (matchtoken('='))
2661           {
2662              int                 level;
2663
2664              lexpush();         /* initials() needs the "=" token again */
2665              assert(numtags > 0);
2666              /* for the moment, when a default value is given for the array,
2667               * all dimension sizes, except the last, must be non-zero
2668               * (function initials() requires to know the major dimensions)
2669               */
2670              for (level = 0; level < arg->numdim - 1; level++)
2671                 if (arg->dim[level] == 0)
2672                    error(52);   /* only last dimension may be variable length */
2673              initials(ident, tags[0], &size, arg->dim, arg->numdim);
2674              assert(size >= litidx);
2675              /* allocate memory to hold the initial values */
2676              arg->defvalue.array.data = (cell *) malloc(litidx * sizeof(cell));
2677              if (arg->defvalue.array.data)
2678                {
2679                   int                 i;
2680
2681                   memcpy(arg->defvalue.array.data, litq, litidx * sizeof(cell));
2682                   arg->hasdefault = TRUE;       /* argument has default value */
2683                   arg->defvalue.array.size = litidx;
2684                   arg->defvalue.array.addr = -1;
2685                   /* calculate size to reserve on the heap */
2686                   arg->defvalue.array.arraysize = 1;
2687                   for (i = 0; i < arg->numdim; i++)
2688                      arg->defvalue.array.arraysize *= arg->dim[i];
2689                   if (arg->defvalue.array.arraysize < arg->defvalue.array.size)
2690                      arg->defvalue.array.arraysize = arg->defvalue.array.size;
2691                }                /* if */
2692              litidx = 0;        /* reset */
2693           }                     /* if */
2694      }
2695    else
2696      {
2697         if (matchtoken('='))
2698           {
2699              unsigned char       size_tag_token;
2700
2701              assert(ident == iVARIABLE || ident == iREFERENCE);
2702              arg->hasdefault = TRUE;    /* argument has a default value */
2703              size_tag_token =
2704                 (unsigned char)(matchtoken(tSIZEOF) ? uSIZEOF : 0);
2705              if (size_tag_token == 0)
2706                 size_tag_token =
2707                    (unsigned char)(matchtoken(tTAGOF) ? uTAGOF : 0);
2708              if (size_tag_token != 0)
2709                {
2710                   int                 paranthese;
2711
2712                   if (ident == iREFERENCE)
2713                      error(66, name);   /* argument may not be a reference */
2714                   paranthese = 0;
2715                   while (matchtoken('('))
2716                      paranthese++;
2717                   if (needtoken(tSYMBOL))
2718                     {
2719                        /* save the name of the argument whose size id to take */
2720                        char               *name;
2721                        cell                val;
2722
2723                        tokeninfo(&val, &name);
2724                        if (!(arg->defvalue.size.symname = strdup(name)))
2725                           error(103);   /* insufficient memory */
2726                        arg->defvalue.size.level = 0;
2727                        if (size_tag_token == uSIZEOF)
2728                          {
2729                             while (matchtoken('['))
2730                               {
2731                                  arg->defvalue.size.level += (short)1;
2732                                  needtoken(']');
2733                               } /* while */
2734                          }      /* if */
2735                        if (ident == iVARIABLE)  /* make sure we set this only if
2736                                                  * not a reference */
2737                           arg->hasdefault |= size_tag_token;    /* uSIZEOF or uTAGOF */
2738                     }           /* if */
2739                   while (paranthese--)
2740                      needtoken(')');
2741                }
2742              else
2743                {
2744                   constexpr(&arg->defvalue.val, &arg->defvalue_tag);
2745                   assert(numtags > 0);
2746                   if (!matchtag(tags[0], arg->defvalue_tag, TRUE))
2747                      error(213);        /* tagname mismatch */
2748                }                /* if */
2749           }                     /* if */
2750      }                          /* if */
2751    arg->ident = (char)ident;
2752    arg->usage = (char)(fconst ? uCONST : 0);
2753    arg->numtags = numtags;
2754    arg->tags = (int *)malloc(numtags * sizeof tags[0]);
2755    if (!arg->tags)
2756       error(103);               /* insufficient memory */
2757    memcpy(arg->tags, tags, numtags * sizeof tags[0]);
2758    argsym = findloc(name);
2759    if (argsym)
2760      {
2761         error(21, name);        /* symbol already defined */
2762      }
2763    else
2764      {
2765         if ((argsym = findglb(name)) && argsym->ident != iFUNCTN)
2766            error(219, name);    /* variable shadows another symbol */
2767         /* add details of type and address */
2768         assert(numtags > 0);
2769         argsym = addvariable(name, offset, ident, sLOCAL, tags[0],
2770                              arg->dim, arg->numdim, idxtag);
2771         argsym->compound = 0;
2772         if (ident == iREFERENCE)
2773            argsym->usage |= uREAD;      /* because references are passed back */
2774         if (fpublic)
2775            argsym->usage |= uREAD;      /* arguments of public functions
2776                                          * are always "used" */
2777         if (fconst)
2778            argsym->usage |= uCONST;
2779      }                          /* if */
2780 }
2781
2782 static int
2783 count_referrers(symbol * entry)
2784 {
2785    int                 i, count;
2786
2787    count = 0;
2788    for (i = 0; i < entry->numrefers; i++)
2789       if (entry->refer[i])
2790          count++;
2791    return count;
2792 }
2793
2794 /* Every symbol has a referrer list, that contains the functions that
2795  * use the symbol. Now, if function "apple" is accessed by functions
2796  * "banana" and "citron", but neither function "banana" nor "citron" are
2797  * used by anyone else, then, by inference, function "apple" is not used
2798  * either.  */
2799 static void
2800 reduce_referrers(symbol * root)
2801 {
2802    int                 i, restart;
2803    symbol             *sym, *ref;
2804
2805    do
2806      {
2807         restart = 0;
2808         for (sym = root->next; sym; sym = sym->next)
2809           {
2810              if (sym->parent)
2811                 continue;       /* hierarchical data type */
2812              if (sym->ident == iFUNCTN
2813                  && (sym->usage & uNATIVE) == 0
2814                  && (sym->usage & uPUBLIC) == 0
2815                  && strcmp(sym->name, uMAINFUNC) != 0
2816                  && count_referrers(sym) == 0)
2817                {
2818                   sym->usage &= ~(uREAD | uWRITTEN);    /* erase usage bits if
2819                                                          * there is no referrer */
2820                   /* find all symbols that are referred by this symbol */
2821                   for (ref = root->next; ref; ref = ref->next)
2822                     {
2823                        if (ref->parent)
2824                           continue;     /* hierarchical data type */
2825                        assert(ref->refer != NULL);
2826                        for (i = 0; i < ref->numrefers && ref->refer[i] != sym;
2827                             i++)
2828                           /* nothing */ ;
2829                        if (i < ref->numrefers)
2830                          {
2831                             assert(ref->refer[i] == sym);
2832                             ref->refer[i] = NULL;
2833                             restart++;
2834                          }      /* if */
2835                     }           /* for */
2836                }
2837              else if ((sym->ident == iVARIABLE || sym->ident == iARRAY)
2838                       && (sym->usage & uPUBLIC) == 0
2839                       && !sym->parent && count_referrers(sym) == 0)
2840                {
2841                   sym->usage &= ~(uREAD | uWRITTEN);    /* erase usage bits if
2842                                                          * there is no referrer */
2843                }                /* if */
2844           }                     /* for */
2845         /* after removing a symbol, check whether more can be removed */
2846      }
2847    while (restart > 0);
2848 }
2849
2850 /*  testsymbols - test for unused local or global variables
2851  *
2852  *  "Public" functions are excluded from the check, since these
2853  *  may be exported to other object modules.
2854  *  Labels are excluded from the check if the argument 'testlabs'
2855  *  is 0. Thus, labels are not tested until the end of the function.
2856  *  Constants may also be excluded (convenient for global constants).
2857  *
2858  *  When the nesting level drops below "level", the check stops.
2859  *
2860  *  The function returns whether there is an "entry" point for the file.
2861  *  This flag will only be 1 when browsing the global symbol table.
2862  */
2863 static int
2864 testsymbols(symbol * root, int level, int testlabs, int testconst)
2865 {
2866    char                symname[2 * sNAMEMAX + 16];
2867    int                 entry = FALSE;
2868
2869    symbol             *sym = root->next;
2870
2871    while (sym && sym->compound >= level)
2872      {
2873         switch (sym->ident)
2874           {
2875           case iLABEL:
2876              if (testlabs)
2877                {
2878                   if ((sym->usage & uDEFINE) == 0)
2879                      error(19, sym->name);      /* not a label: ... */
2880                   else if ((sym->usage & uREAD) == 0)
2881                      error(203, sym->name);     /* symbol isn't used: ... */
2882                }                /* if */
2883              break;
2884           case iFUNCTN:
2885              if ((sym->usage & (uDEFINE | uREAD | uNATIVE | uSTOCK)) == uDEFINE)
2886                {
2887                   funcdisplayname(symname, sym->name);
2888                   if (symname[0] != '\0')
2889                      error(203, symname);       /* symbol isn't used ...
2890                                                  * (and not native/stock) */
2891                }                /* if */
2892              if ((sym->usage & uPUBLIC) != 0
2893                  || strcmp(sym->name, uMAINFUNC) == 0)
2894                 entry = TRUE;   /* there is an entry point */
2895              break;
2896           case iCONSTEXPR:
2897              if (testconst && (sym->usage & uREAD) == 0)
2898                 error(203, sym->name);  /* symbol isn't used: ... */
2899              break;
2900           default:
2901              /* a variable */
2902              if (sym->parent)
2903                 break;          /* hierarchical data type */
2904              if ((sym->usage & (uWRITTEN | uREAD | uSTOCK | uPUBLIC)) == 0)
2905                 error(203, sym->name);  /* symbol isn't used (and not stock
2906                                          * or public) */
2907              else if ((sym->usage & (uREAD | uSTOCK | uPUBLIC)) == 0)
2908                 error(204, sym->name);  /* value assigned to symbol is
2909                                          * never used */
2910 #if 0                           /*// ??? not sure whether it is a good idea to
2911                                  * force people use "const" */
2912              else if ((sym->usage & (uWRITTEN | uPUBLIC | uCONST)) == 0
2913                       && sym->ident == iREFARRAY)
2914                 error(214, sym->name);  /* make array argument "const" */
2915 #endif
2916           }                     /* if */
2917         sym = sym->next;
2918      }                          /* while */
2919
2920    return entry;
2921 }
2922
2923 static              cell
2924 calc_array_datasize(symbol * sym, cell * offset)
2925 {
2926    cell                length;
2927
2928    assert(sym != NULL);
2929    assert(sym->ident == iARRAY || sym->ident == iREFARRAY);
2930    length = sym->dim.array.length;
2931    if (sym->dim.array.level > 0)
2932      {
2933         cell                sublength =
2934            calc_array_datasize(finddepend(sym), offset);
2935         if (offset)
2936            *offset = length * (*offset + sizeof(cell));
2937         if (sublength > 0)
2938            length *= length * sublength;
2939         else
2940            length = 0;
2941      }
2942    else
2943      {
2944         if (offset)
2945            *offset = 0;
2946      }                          /* if */
2947    return length;
2948 }
2949
2950 static void
2951 destructsymbols(symbol * root, int level)
2952 {
2953    cell                offset = 0;
2954    int                 savepri = FALSE;
2955    symbol             *sym = root->next;
2956
2957    while (sym && sym->compound >= level)
2958      {
2959         if (sym->ident == iVARIABLE || sym->ident == iARRAY)
2960           {
2961              char                symbolname[16];
2962              symbol             *opsym;
2963              cell                elements;
2964
2965              /* check that the '~' operator is defined for this tag */
2966              operator_symname(symbolname, "~", sym->tag, 0, 1, 0);
2967              if ((opsym = findglb(symbolname)))
2968                {
2969                   /* save PRI, in case of a return statement */
2970                   if (!savepri)
2971                     {
2972                        push1(); /* right-hand operand is in PRI */
2973                        savepri = TRUE;
2974                     }           /* if */
2975                   /* if the variable is an array, get the number of elements */
2976                   if (sym->ident == iARRAY)
2977                     {
2978                        elements = calc_array_datasize(sym, &offset);
2979                        /* "elements" can be zero when the variable is declared like
2980                         *    new mytag: myvar[2][] = { {1, 2}, {3, 4} }
2981                         * one should declare all dimensions!
2982                         */
2983                        if (elements == 0)
2984                           error(46, sym->name); /* array size is unknown */
2985                     }
2986                   else
2987                     {
2988                        elements = 1;
2989                        offset = 0;
2990                     }           /* if */
2991                   pushval(elements);
2992                   /* call the '~' operator */
2993                   address(sym);
2994                   addconst(offset);     /*add offset to array data to the address */
2995                   push1();
2996                   pushval(2 * sizeof(cell));    /* 2 parameters */
2997                   ffcall(opsym, 1);
2998                   if (sc_status != statSKIP)
2999                      markusage(opsym, uREAD);   /* do not mark as "used" when this
3000                                                  * call itself is skipped */
3001                   if (opsym->x.lib)
3002                      opsym->x.lib->value += 1;  /* increment "usage count"
3003                                                  * of the library */
3004                }                /* if */
3005           }                     /* if */
3006         sym = sym->next;
3007      }                          /* while */
3008    /* restore PRI, if it was saved */
3009    if (savepri)
3010       pop1();
3011 }
3012
3013 static constvalue  *
3014 insert_constval(constvalue * prev, constvalue * next, char *name,
3015                 cell val, short idx)
3016 {
3017    constvalue         *cur;
3018
3019    if (!(cur = (constvalue *)malloc(sizeof(constvalue))))
3020       error(103);               /* insufficient memory (fatal error) */
3021    memset(cur, 0, sizeof(constvalue));
3022    strcpy(cur->name, name);
3023    cur->value = val;
3024    cur->index = idx;
3025    cur->next = next;
3026    prev->next = cur;
3027    return cur;
3028 }
3029
3030 constvalue *
3031 append_constval(constvalue * table, char *name, cell val, short idx)
3032 {
3033    constvalue         *cur, *prev;
3034
3035    /* find the end of the constant table */
3036    for (prev = table, cur = table->next; cur;
3037         prev = cur, cur = cur->next)
3038       /* nothing */ ;
3039    return insert_constval(prev, NULL, name, val, idx);
3040 }
3041
3042 constvalue *
3043 find_constval(constvalue * table, char *name, short idx)
3044 {
3045    constvalue         *ptr = table->next;
3046
3047    while (ptr)
3048      {
3049         if (strcmp(name, ptr->name) == 0 && ptr->index == idx)
3050            return ptr;
3051         ptr = ptr->next;
3052      }                          /* while */
3053    return NULL;
3054 }
3055
3056 static constvalue  *
3057 find_constval_byval(constvalue * table, cell val)
3058 {
3059    constvalue         *ptr = table->next;
3060
3061    while (ptr)
3062      {
3063         if (ptr->value == val)
3064            return ptr;
3065         ptr = ptr->next;
3066      }                          /* while */
3067    return NULL;
3068 }
3069
3070 #if 0                           /* never used */
3071 static int
3072 delete_constval(constvalue * table, char *name)
3073 {
3074    constvalue         *prev = table;
3075    constvalue         *cur = prev->next;
3076
3077    while (cur != NULL)
3078      {
3079         if (strcmp(name, cur->name) == 0)
3080           {
3081              prev->next = cur->next;
3082              free(cur);
3083              return TRUE;
3084           }                     /* if */
3085         prev = cur;
3086         cur = cur->next;
3087      }                          /* while */
3088    return FALSE;
3089 }
3090 #endif
3091
3092 void
3093 delete_consttable(constvalue * table)
3094 {
3095    constvalue         *cur = table->next, *next;
3096
3097    while (cur)
3098      {
3099         next = cur->next;
3100         free(cur);
3101         cur = next;
3102      }                          /* while */
3103    memset(table, 0, sizeof(constvalue));
3104 }
3105
3106 /*  add_constant
3107  *
3108  *  Adds a symbol to the #define symbol table.
3109  */
3110 void
3111 add_constant(char *name, cell val, int vclass, int tag)
3112 {
3113    symbol             *sym;
3114
3115    /* Test whether a global or local symbol with the same name exists. Since
3116     * constants are stored in the symbols table, this also finds previously
3117     * defind constants. */
3118    sym = findglb(name);
3119    if (!sym)
3120       sym = findloc(name);
3121    if (sym)
3122      {
3123         /* silently ignore redefinitions of constants with the same value */
3124         if (sym->ident == iCONSTEXPR)
3125           {
3126              if (sym->addr != val)
3127                 error(201, name);       /* redefinition of constant (different value) */
3128           }
3129         else
3130           {
3131              error(21, name);   /* symbol already defined */
3132           }                     /* if */
3133         return;
3134      }                          /* if */
3135
3136    /* constant doesn't exist yet, an entry must be created */
3137    sym = addsym(name, val, iCONSTEXPR, vclass, tag, uDEFINE);
3138    if (sc_status == statIDLE)
3139       sym->usage |= uPREDEF;
3140 }
3141
3142 /*  statement           - The Statement Parser
3143  *
3144  *  This routine is called whenever the parser needs to know what
3145  *  statement it encounters (i.e. whenever program syntax requires a
3146  *  statement).
3147  */
3148 static void
3149 statement(int *lastindent, int allow_decl)
3150 {
3151    int                 tok;
3152    cell                val;
3153    char               *st;
3154
3155    if (!freading)
3156      {
3157         error(36);              /* empty statement */
3158         return;
3159      }                          /* if */
3160    errorset(sRESET);
3161
3162    tok = lex(&val, &st);
3163    if (tok != '{')
3164       setline(fline, fcurrent);
3165    /* lex() has set stmtindent */
3166    if (lastindent && tok != tLABEL)
3167      {
3168 #if 0
3169         if (*lastindent >= 0 && *lastindent != stmtindent &&
3170             !indent_nowarn && sc_tabsize > 0)
3171            error(217);          /* loose indentation */
3172 #endif
3173         *lastindent = stmtindent;
3174         indent_nowarn = TRUE;   /* if warning was blocked, re-enable it */
3175      }                          /* if */
3176    switch (tok)
3177      {
3178      case 0:
3179         /* nothing */
3180         break;
3181      case tNEW:
3182         if (allow_decl)
3183           {
3184              declloc(FALSE);
3185              lastst = tNEW;
3186           }
3187         else
3188           {
3189              error(3);          /* declaration only valid in a block */
3190           }                     /* if */
3191         break;
3192      case tSTATIC:
3193         if (allow_decl)
3194           {
3195              declloc(TRUE);
3196              lastst = tNEW;
3197           }
3198         else
3199           {
3200              error(3);          /* declaration only valid in a block */
3201           }                     /* if */
3202         break;
3203      case '{':
3204         if (!matchtoken('}'))   /* {} is the empty statement */
3205            compound();
3206         /* lastst (for "last statement") does not change */
3207         break;
3208      case ';':
3209         error(36);              /* empty statement */
3210         break;
3211      case tIF:
3212         doif();
3213         lastst = tIF;
3214         break;
3215      case tWHILE:
3216         dowhile();
3217         lastst = tWHILE;
3218         break;
3219      case tDO:
3220         dodo();
3221         lastst = tDO;
3222         break;
3223      case tFOR:
3224         dofor();
3225         lastst = tFOR;
3226         break;
3227      case tSWITCH:
3228         doswitch();
3229         lastst = tSWITCH;
3230         break;
3231      case tCASE:
3232      case tDEFAULT:
3233         error(14);              /* not in switch */
3234         break;
3235      case tGOTO:
3236         dogoto();
3237         lastst = tGOTO;
3238         break;
3239      case tLABEL:
3240         dolabel();
3241         lastst = tLABEL;
3242         break;
3243      case tRETURN:
3244         doreturn();
3245         lastst = tRETURN;
3246         break;
3247      case tBREAK:
3248         dobreak();
3249         lastst = tBREAK;
3250         break;
3251      case tCONTINUE:
3252         docont();
3253         lastst = tCONTINUE;
3254         break;
3255      case tEXIT:
3256         doexit();
3257         lastst = tEXIT;
3258         break;
3259      case tASSERT:
3260         doassert();
3261         lastst = tASSERT;
3262         break;
3263      case tSLEEP:
3264         dosleep();
3265         lastst = tSLEEP;
3266         break;
3267      case tCONST:
3268         decl_const(sLOCAL);
3269         break;
3270      case tENUM:
3271         decl_enum(sLOCAL);
3272         break;
3273      default:                   /* non-empty expression */
3274         lexpush();              /* analyze token later */
3275         doexpr(TRUE, TRUE, TRUE, TRUE, NULL, FALSE);
3276         needtoken(tTERM);
3277         lastst = tEXPR;
3278      }                          /* switch */
3279 }
3280
3281 static void
3282 compound(void)
3283 {
3284    int                 indent = -1;
3285    cell                save_decl = declared;
3286    int                 count_stmt = 0;
3287
3288    nestlevel += 1;              /* increase compound statement level */
3289    while (matchtoken('}') == 0)
3290      {                          /* repeat until compound statement is closed */
3291         if (!freading)
3292           {
3293              needtoken('}');    /* gives error: "expected token }" */
3294              break;
3295           }
3296         else
3297           {
3298              if (count_stmt > 0
3299                  && (lastst == tRETURN || lastst == tBREAK
3300                      || lastst == tCONTINUE))
3301                 error(225);     /* unreachable code */
3302              statement(&indent, TRUE);  /* do a statement */
3303              count_stmt++;
3304           }                     /* if */
3305      }                          /* while */
3306    if (lastst != tRETURN)
3307       destructsymbols(&loctab, nestlevel);
3308    if (lastst != tRETURN && lastst != tGOTO)
3309       /* delete local variable space */
3310       modstk((int)(declared - save_decl) * sizeof(cell));
3311
3312    testsymbols(&loctab, nestlevel, FALSE, TRUE);        /* look for unused
3313                                                          * block locals */
3314    declared = save_decl;
3315    delete_symbols(&loctab, nestlevel, FALSE, TRUE);
3316    /* erase local symbols, but
3317     * retain block local labels
3318     * (within the function) */
3319
3320    nestlevel -= 1;              /* decrease compound statement level */
3321 }
3322
3323 /*  doexpr
3324  *
3325  *  Global references: stgidx   (referred to only)
3326  */
3327 static void
3328 doexpr(int comma, int chkeffect, int allowarray, int mark_endexpr,
3329        int *tag, int chkfuncresult)
3330 {
3331    int                 constant, idx, ident;
3332    int                 localstaging = FALSE;
3333    cell                val;
3334
3335    if (!staging)
3336      {
3337         stgset(TRUE);           /* start stage-buffering */
3338         localstaging = TRUE;
3339         assert(stgidx == 0);
3340      }                          /* if */
3341    idx = stgidx;
3342    errorset(sEXPRMARK);
3343    do
3344      {
3345         /* on second round through, mark the end of the previous expression */
3346         if (idx != stgidx)
3347            endexpr(TRUE);
3348         sideeffect = FALSE;
3349         ident = expression(&constant, &val, tag, chkfuncresult);
3350         if (!allowarray && (ident == iARRAY || ident == iREFARRAY))
3351            error(33, "-unknown-");      /* array must be indexed */
3352         if (chkeffect && !sideeffect)
3353            error(215);          /* expression has no effect */
3354      }
3355    while (comma && matchtoken(','));    /* more? */
3356    if (mark_endexpr)
3357       endexpr(TRUE);            /* optionally, mark the end of the expression */
3358    errorset(sEXPRRELEASE);
3359    if (localstaging)
3360      {
3361         stgout(idx);
3362         stgset(FALSE);          /* stop staging */
3363      }                          /* if */
3364 }
3365
3366 /*  constexpr
3367  */
3368 int
3369 constexpr(cell * val, int *tag)
3370 {
3371    int                 constant, idx;
3372    cell                cidx;
3373
3374    stgset(TRUE);                /* start stage-buffering */
3375    stgget(&idx, &cidx); /* mark position in code generator */
3376    errorset(sEXPRMARK);
3377    expression(&constant, val, tag, FALSE);
3378    stgdel(idx, cidx);           /* scratch generated code */
3379    stgset(FALSE);               /* stop stage-buffering */
3380    if (constant == 0)
3381       error(8);                 /* must be constant expression */
3382    errorset(sEXPRRELEASE);
3383    return constant;
3384 }
3385
3386 /*  test
3387  *
3388  *  In the case a "simple assignment" operator ("=") is used within a
3389  *  test, *  the warning "possibly unintended assignment" is displayed.
3390  *  This routine sets the global variable "intest" to true, it is
3391  *  restored upon termination. In the case the assignment was intended,
3392  *  use parantheses around the expression to avoid the warning;
3393  *  primary() sets "intest" to 0.
3394  *
3395  *  Global references: intest   (altered, but restored upon termination)
3396  */
3397 static void
3398 test(int label, int parens, int invert)
3399 {
3400    int                 idx, tok;
3401    cell                cidx;
3402    value               lval = { NULL, 0, 0, 0, 0, NULL };
3403    int                 localstaging = FALSE;
3404
3405    if (!staging)
3406      {
3407         stgset(TRUE);           /* start staging */
3408         localstaging = TRUE;
3409 #if !defined NDEBUG
3410         stgget(&idx, &cidx);    /* should start at zero if started
3411                                  * locally */
3412         assert(idx == 0);
3413 #endif
3414      }                          /* if */
3415
3416    pushstk((stkitem) intest);
3417    intest = 1;
3418    if (parens)
3419       needtoken('(');
3420    do
3421      {
3422         stgget(&idx, &cidx);    /* mark position (of last expression) in
3423                                  * code generator */
3424         if (hier14(&lval))
3425            rvalue(&lval);
3426         tok = matchtoken(',');
3427         if (tok)
3428            endexpr(TRUE);
3429      }
3430    while (tok);                 /* do */
3431    if (parens)
3432       needtoken(')');
3433    if (lval.ident == iARRAY || lval.ident == iREFARRAY)
3434      {
3435         char               *ptr =
3436            (lval.sym->name) ? lval.sym->name : "-unknown-";
3437         error(33, ptr);         /* array must be indexed */
3438      }                          /* if */
3439    if (lval.ident == iCONSTEXPR)
3440      {                          /* constant expression */
3441         intest = (int)(long)popstk();   /* restore stack */
3442         stgdel(idx, cidx);
3443         if (lval.constval)
3444           {                     /* code always executed */
3445              error(206);        /* redundant test: always non-zero */
3446           }
3447         else
3448           {
3449              error(205);        /* redundant code: never executed */
3450              jumplabel(label);
3451           }                     /* if */
3452         if (localstaging)
3453           {
3454              stgout(0);         /* write "jumplabel" code */
3455              stgset(FALSE);     /* stop staging */
3456           }                     /* if */
3457         return;
3458      }                          /* if */
3459    if (lval.tag != 0 && lval.tag != sc_addtag("bool"))
3460       if (check_userop(lneg, lval.tag, 0, 1, NULL, &lval.tag))
3461          invert = !invert;      /* user-defined ! operator inverted result */
3462    if (invert)
3463       jmp_ne0(label);           /* jump to label if true (different from 0) */
3464    else
3465       jmp_eq0(label);           /* jump to label if false (equal to 0) */
3466    endexpr(TRUE);               /* end expression (give optimizer a chance) */
3467    intest = (int)(long)popstk();        /* double typecast to avoid warning
3468                                          * with Microsoft C */
3469    if (localstaging)
3470      {
3471         stgout(0);              /* output queue from the very beginning (see
3472                                  * assert() when localstaging is set to TRUE) */
3473         stgset(FALSE);          /* stop staging */
3474      }                          /* if */
3475 }
3476
3477 static void
3478 doif(void)
3479 {
3480    int                 flab1, flab2;
3481    int                 ifindent;
3482
3483    ifindent = stmtindent;       /* save the indent of the "if" instruction */
3484    flab1 = getlabel();          /* get label number for false branch */
3485    test(flab1, TRUE, FALSE);    /*get expression, branch to flab1 if false */
3486    statement(NULL, FALSE);      /* if true, do a statement */
3487    if (matchtoken(tELSE) == 0)
3488      {                          /* if...else ? */
3489         setlabel(flab1);        /* no, simple if..., print false label */
3490      }
3491    else
3492      {
3493         /* to avoid the "dangling else" error, we want a warning if the "else"
3494          * has a lower indent than the matching "if" */
3495 #if 0
3496         if (stmtindent < ifindent && sc_tabsize > 0)
3497            error(217);          /* loose indentation */
3498 #endif
3499         flab2 = getlabel();
3500         if ((lastst != tRETURN) && (lastst != tGOTO))
3501            jumplabel(flab2);
3502         setlabel(flab1);        /* print false label */
3503         statement(NULL, FALSE); /* do "else" clause */
3504         setlabel(flab2);        /* print true label */
3505      }                          /* endif */
3506 }
3507
3508 static void
3509 dowhile(void)
3510 {
3511    int                 wq[wqSIZE];      /* allocate local queue */
3512
3513    addwhile(wq);                /* add entry to queue for "break" */
3514    setlabel(wq[wqLOOP]);        /* loop label */
3515    /* The debugger uses the "line" opcode to be able to "break" out of
3516     * a loop. To make sure that each loop has a line opcode, even for the
3517     * tiniest loop, set it below the top of the loop */
3518    setline(fline, fcurrent);
3519    test(wq[wqEXIT], TRUE, FALSE);       /* branch to wq[wqEXIT] if false */
3520    statement(NULL, FALSE);      /* if so, do a statement */
3521    jumplabel(wq[wqLOOP]);       /* and loop to "while" start */
3522    setlabel(wq[wqEXIT]);        /* exit label */
3523    delwhile();                  /* delete queue entry */
3524 }
3525
3526 /*
3527  *  Note that "continue" will in this case not jump to the top of the
3528  *  loop, but  to the end: just before the TRUE-or-FALSE testing code.
3529  */
3530 static void
3531 dodo(void)
3532 {
3533    int                 wq[wqSIZE], top;
3534
3535    addwhile(wq);                /* see "dowhile" for more info */
3536    top = getlabel();            /* make a label first */
3537    setlabel(top);               /* loop label */
3538    statement(NULL, FALSE);
3539    needtoken(tWHILE);
3540    setlabel(wq[wqLOOP]);        /* "continue" always jumps to WQLOOP. */
3541    setline(fline, fcurrent);
3542    test(wq[wqEXIT], TRUE, FALSE);
3543    jumplabel(top);
3544    setlabel(wq[wqEXIT]);
3545    delwhile();
3546    needtoken(tTERM);
3547 }
3548
3549 static void
3550 dofor(void)
3551 {
3552    int                 wq[wqSIZE], skiplab;
3553    cell                save_decl;
3554    int                 save_nestlevel, idx;
3555    int                *ptr;
3556
3557    save_decl = declared;
3558    save_nestlevel = nestlevel;
3559
3560    addwhile(wq);
3561    skiplab = getlabel();
3562    needtoken('(');
3563    if (matchtoken(';') == 0)
3564      {
3565         /* new variable declarations are allowed here */
3566         if (matchtoken(tNEW))
3567           {
3568              /* The variable in expr1 of the for loop is at a
3569               * 'compound statement' level of it own.
3570               */
3571              nestlevel++;
3572              declloc(FALSE);    /* declare local variable */
3573           }
3574         else
3575           {
3576              doexpr(TRUE, TRUE, TRUE, TRUE, NULL, FALSE);       /* expression 1 */
3577              needtoken(';');
3578           }                     /* if */
3579      }                          /* if */
3580    /* Adjust the "declared" field in the "while queue", in case that
3581     * local variables were declared in the first expression of the
3582     * "for" loop. These are deleted in separately, so a "break" or a
3583     * "continue" must ignore these fields.
3584     */
3585    ptr = readwhile();
3586    assert(ptr != NULL);
3587    ptr[wqBRK] = (int)declared;
3588    ptr[wqCONT] = (int)declared;
3589    jumplabel(skiplab);          /* skip expression 3 1st time */
3590    setlabel(wq[wqLOOP]);        /* "continue" goes to this label: expr3 */
3591    setline(fline, fcurrent);
3592    /* Expressions 2 and 3 are reversed in the generated code:
3593     * expression 3 precedes expression 2.
3594     * When parsing, the code is buffered and marks for
3595     * the start of each expression are insterted in the buffer.
3596     */
3597    assert(!staging);
3598    stgset(TRUE);                /* start staging */
3599    assert(stgidx == 0);
3600    idx = stgidx;
3601    stgmark(sSTARTREORDER);
3602    stgmark((char)(sEXPRSTART + 0));     /* mark start of 2nd expression
3603                                          * in stage */
3604    setlabel(skiplab);           /*jump to this point after 1st expression */
3605    if (matchtoken(';') == 0)
3606      {
3607         test(wq[wqEXIT], FALSE, FALSE); /* expression 2
3608                                          *(jump to wq[wqEXIT] if false) */
3609         needtoken(';');
3610      }                          /* if */
3611    stgmark((char)(sEXPRSTART + 1));     /* mark start of 3th expression
3612                                          * in stage */
3613    if (matchtoken(')') == 0)
3614      {
3615         doexpr(TRUE, TRUE, TRUE, TRUE, NULL, FALSE);    /* expression 3 */
3616         needtoken(')');
3617      }                          /* if */
3618    stgmark(sENDREORDER);        /* mark end of reversed evaluation */
3619    stgout(idx);
3620    stgset(FALSE);               /* stop staging */
3621    statement(NULL, FALSE);
3622    jumplabel(wq[wqLOOP]);
3623    setlabel(wq[wqEXIT]);
3624    delwhile();
3625
3626    assert(nestlevel >= save_nestlevel);
3627    if (nestlevel > save_nestlevel)
3628      {
3629         /* Clean up the space and the symbol table for the local
3630          * variable in "expr1".
3631          */
3632         destructsymbols(&loctab, nestlevel);
3633         modstk((int)(declared - save_decl) * sizeof(cell));
3634         declared = save_decl;
3635         delete_symbols(&loctab, nestlevel, FALSE, TRUE);
3636         nestlevel = save_nestlevel;     /* reset 'compound statement'
3637                                          * nesting level */
3638      }                          /* if */
3639 }
3640
3641 /* The switch statement is incompatible with its C sibling:
3642  * 1. the cases are not drop through
3643  * 2. only one instruction may appear below each case, use a compound
3644  *    instruction to execute multiple instructions
3645  * 3. the "case" keyword accepts a comma separated list of values to
3646  *    match, it also accepts a range using the syntax "1 .. 4"
3647  *
3648  * SWITCH param
3649  *   PRI = expression result
3650  *   param = table offset (code segment)
3651  *
3652  */
3653 static void
3654 doswitch(void)
3655 {
3656    int                 lbl_table, lbl_exit, lbl_case;
3657    int                 tok, swdefault, casecount;
3658    cell                val;
3659    char               *str;
3660    constvalue          caselist = { NULL, "", 0, 0 };   /*case list starts empty */
3661    constvalue         *cse, *csp;
3662    char                labelname[sNAMEMAX + 1];
3663
3664    needtoken('(');
3665    doexpr(TRUE, FALSE, FALSE, TRUE, NULL, FALSE);       /* evaluate
3666                                                          * switch expression */
3667    needtoken(')');
3668    /* generate the code for the switch statement, the label is the
3669     * address of the case table (to be generated later).
3670     */
3671    lbl_table = getlabel();
3672    lbl_case = 0;                /* just to avoid a compiler warning */
3673    ffswitch(lbl_table);
3674
3675    needtoken('{');
3676    lbl_exit = getlabel();       /*get label number for jumping out of switch */
3677    swdefault = FALSE;
3678    casecount = 0;
3679    do
3680      {
3681         tok = lex(&val, &str);  /* read in (new) token */
3682         switch (tok)
3683           {
3684           case tCASE:
3685              if (swdefault != FALSE)
3686                 error(15);      /* "default" case must be last in switch
3687                                  * statement */
3688              lbl_case = getlabel();
3689              sc_allowtags = FALSE;      /* do not allow tagnames here */
3690              do
3691                {
3692                   casecount++;
3693
3694                   /* ??? enforce/document that, in a switch, a statement cannot
3695                    * start an opening brace (marks the start of a compound
3696                    * statement) and search for the right-most colon before that
3697                    * statement.
3698                    * Now, by replacing the ':' by a special COLON token, you can
3699                    * parse all expressions until that special token.
3700                    */
3701
3702                   constexpr(&val, NULL);
3703                   /* Search the insertion point (the table is kept in sorted
3704                    * order, so that advanced abstract machines can sift the
3705                    * case table with a binary search). Check for duplicate
3706                    * case values at the same time.
3707                    */
3708                   for (csp = &caselist, cse = caselist.next;
3709                        cse && cse->value < val;
3710                        csp = cse, cse = cse->next)
3711                      /* nothing */ ;
3712                   if (cse && cse->value == val)
3713                      error(40, val);    /* duplicate "case" label */
3714                   /* Since the label is stored as a string in the
3715                    * "constvalue", the size of an identifier must
3716                    * be at least 8, as there are 8
3717                    * hexadecimal digits in a 32-bit number.
3718                    */
3719 #if sNAMEMAX < 8
3720 #error Length of identifier (sNAMEMAX) too small.
3721 #endif
3722                   insert_constval(csp, cse, itoh(lbl_case), val, 0);
3723                   if (matchtoken(tDBLDOT))
3724                     {
3725                        cell                end;
3726
3727                        constexpr(&end, NULL);
3728                        if (end <= val)
3729                           error(50);    /* invalid range */
3730                        while (++val <= end)
3731                          {
3732                             casecount++;
3733                             /* find the new insertion point */
3734                             for (csp = &caselist, cse = caselist.next;
3735                                  cse && cse->value < val;
3736                                  csp = cse, cse = cse->next)
3737                                /* nothing */ ;
3738                             if (cse && cse->value == val)
3739                                error(40, val);  /* duplicate "case" label */
3740                             insert_constval(csp, cse, itoh(lbl_case), val, 0);
3741                          }      /* if */
3742                     }           /* if */
3743                }
3744              while (matchtoken(','));
3745              needtoken(':');    /* ':' ends the case */
3746              sc_allowtags = TRUE;       /* reset */
3747              setlabel(lbl_case);
3748              statement(NULL, FALSE);
3749              jumplabel(lbl_exit);
3750              break;
3751           case tDEFAULT:
3752              if (swdefault != FALSE)
3753                 error(16);      /* multiple defaults in switch */
3754              lbl_case = getlabel();
3755              setlabel(lbl_case);
3756              needtoken(':');
3757              swdefault = TRUE;
3758              statement(NULL, FALSE);
3759              /* Jump to lbl_exit, even thouh this is the last clause in the
3760               *switch, because the jump table is generated between the last
3761               * clause of the switch and the exit label.
3762               */
3763              jumplabel(lbl_exit);
3764              break;
3765           case '}':
3766              /* nothing, but avoid dropping into "default" */
3767              break;
3768           default:
3769              error(2);
3770              indent_nowarn = TRUE;      /* disable this check */
3771              tok = '}';         /* break out of the loop after an error */
3772           }                     /* switch */
3773      }
3774    while (tok != '}');
3775
3776 #if !defined NDEBUG
3777    /* verify that the case table is sorted (unfortunately, duplicates can
3778     * occur; there really shouldn't be duplicate cases, but the compiler
3779     * may not crash or drop into an assertion for a user error). */
3780    for (cse = caselist.next; cse && cse->next; cse = cse->next)
3781      ; /* empty. no idea whether this is correct, but we MUST NOT do
3782         * the setlabel(lbl_table) call in the loop body. doing so breaks
3783         * switch statements that only have one case statement following.
3784         */
3785 #endif
3786
3787    /* generate the table here, before lbl_exit (general jump target) */
3788    setlabel(lbl_table);
3789
3790    if (swdefault == FALSE)
3791      {
3792         /* store lbl_exit as the "none-matched" label in the switch table */
3793         strcpy(labelname, itoh(lbl_exit));
3794      }
3795    else
3796      {
3797         /* lbl_case holds the label of the "default" clause */
3798         strcpy(labelname, itoh(lbl_case));
3799      }                          /* if */
3800    ffcase(casecount, labelname, TRUE);
3801    /* generate the rest of the table */
3802    for (cse = caselist.next; cse; cse = cse->next)
3803       ffcase(cse->value, cse->name, FALSE);
3804
3805    setlabel(lbl_exit);
3806    delete_consttable(&caselist);        /* clear list of case labels */
3807 }
3808
3809 static void
3810 doassert(void)
3811 {
3812    int                 flab1, idx;
3813    cell                cidx;
3814    value               lval = { NULL, 0, 0, 0, 0, NULL };
3815
3816    if ((sc_debug & sCHKBOUNDS) != 0)
3817      {
3818         flab1 = getlabel();     /* get label number for "OK" branch */
3819         test(flab1, FALSE, TRUE);       /* get expression and branch
3820                                          * to flab1 if true */
3821         setline(fline, fcurrent);       /* make sure we abort on the correct
3822                                          * line number */
3823         ffabort(xASSERTION);
3824         setlabel(flab1);
3825      }
3826    else
3827      {
3828         stgset(TRUE);           /* start staging */
3829         stgget(&idx, &cidx);    /* mark position in code generator */
3830         do
3831           {
3832              if (hier14(&lval))
3833                 rvalue(&lval);
3834              stgdel(idx, cidx); /* just scrap the code */
3835           }
3836         while (matchtoken(','));
3837         stgset(FALSE);          /* stop staging */
3838      }                          /* if */
3839    needtoken(tTERM);
3840 }
3841
3842 static void
3843 dogoto(void)
3844 {
3845    char               *st;
3846    cell                val;
3847    symbol             *sym;
3848
3849    if (lex(&val, &st) == tSYMBOL)
3850      {
3851         sym = fetchlab(st);
3852         jumplabel((int)sym->addr);
3853         sym->usage |= uREAD;    /* set "uREAD" bit */
3854         /*
3855          * // ??? if the label is defined (check sym->usage & uDEFINE), check
3856          * //   sym->compound (nesting level of the label) against nestlevel;
3857          * //     if sym->compound < nestlevel, call the destructor operator
3858          */
3859      }
3860    else
3861      {
3862         error(20, st);          /* illegal symbol name */
3863      }                          /* if */
3864    needtoken(tTERM);
3865 }
3866
3867 static void
3868 dolabel(void)
3869 {
3870    char               *st;
3871    cell                val;
3872    symbol             *sym;
3873
3874    tokeninfo(&val, &st);        /* retrieve label name again */
3875    if (find_constval(&tagname_tab, st, 0))
3876       error(221, st);           /* label name shadows tagname */
3877    sym = fetchlab(st);
3878    setlabel((int)sym->addr);
3879    /* since one can jump around variable declarations or out of compound
3880     * blocks, the stack must be manually adjusted
3881     */
3882    setstk(-declared * sizeof(cell));
3883    sym->usage |= uDEFINE;       /* label is now defined */
3884 }
3885
3886 /*  fetchlab
3887  *
3888  *  Finds a label from the (local) symbol table or adds one to it.
3889  *  Labels are local in scope.
3890  *
3891  *  Note: The "_usage" bit is set to zero. The routines that call
3892  *  "fetchlab()" must set this bit accordingly.
3893  */
3894 static symbol      *
3895 fetchlab(char *name)
3896 {
3897    symbol             *sym;
3898
3899    sym = findloc(name);         /* labels are local in scope */
3900    if (sym)
3901      {
3902         if (sym->ident != iLABEL)
3903            error(19, sym->name);        /* not a label: ... */
3904      }
3905    else
3906      {
3907         sym = addsym(name, getlabel(), iLABEL, sLOCAL, 0, 0);
3908         sym->x.declared = (int)declared;
3909         sym->compound = nestlevel;
3910      }                          /* if */
3911    return sym;
3912 }
3913
3914 /*  doreturn
3915  *
3916  *  Global references: rettype  (altered)
3917  */
3918 static void
3919 doreturn(void)
3920 {
3921    int                 tag;
3922
3923    if (matchtoken(tTERM) == 0)
3924      {
3925         if ((rettype & uRETNONE) != 0)
3926            error(208);          /* mix "return;" and "return value;" */
3927         doexpr(TRUE, FALSE, FALSE, TRUE, &tag, FALSE);
3928         needtoken(tTERM);
3929         rettype |= uRETVALUE;   /* function returns a value */
3930         /* check tagname with function tagname */
3931         assert(curfunc != NULL);
3932         if (!matchtag(curfunc->tag, tag, TRUE))
3933            error(213);          /* tagname mismatch */
3934      }
3935    else
3936      {
3937         /* this return statement contains no expression */
3938         const1(0);
3939         if ((rettype & uRETVALUE) != 0)
3940           {
3941              char                symname[2 * sNAMEMAX + 16];    /* allow space for user
3942                                                                  * defined operators */
3943              assert(curfunc != NULL);
3944              funcdisplayname(symname, curfunc->name);
3945              error(209, symname);       /* function should return a value */
3946           }                     /* if */
3947         rettype |= uRETNONE;    /* function does not return anything */
3948      }                          /* if */
3949    destructsymbols(&loctab, 0); /*call destructor for *all* locals */
3950    modstk((int)declared * sizeof(cell));        /* end of function, remove
3951                                                  *all* * local variables*/
3952    ffret();
3953 }
3954
3955 static void
3956 dobreak(void)
3957 {
3958    int                *ptr;
3959
3960    ptr = readwhile();           /* readwhile() gives an error if not in loop */
3961    needtoken(tTERM);
3962    if (!ptr)
3963       return;
3964    destructsymbols(&loctab, nestlevel);
3965    modstk(((int)declared - ptr[wqBRK]) * sizeof(cell));
3966    jumplabel(ptr[wqEXIT]);
3967 }
3968
3969 static void
3970 docont(void)
3971 {
3972    int                *ptr;
3973
3974    ptr = readwhile();           /* readwhile() gives an error if not in loop */
3975    needtoken(tTERM);
3976    if (!ptr)
3977       return;
3978    destructsymbols(&loctab, nestlevel);
3979    modstk(((int)declared - ptr[wqCONT]) * sizeof(cell));
3980    jumplabel(ptr[wqLOOP]);
3981 }
3982
3983 void
3984 exporttag(int tag)
3985 {
3986    /* find the tag by value in the table, then set the top bit to mark it
3987     * "public"
3988     */
3989    if (tag != 0)
3990      {
3991         constvalue         *ptr;
3992
3993         assert((tag & PUBLICTAG) == 0);
3994         for (ptr = tagname_tab.next;
3995              ptr && tag != (int)(ptr->value & TAGMASK); ptr = ptr->next)
3996            /* nothing */ ;
3997         if (ptr)
3998            ptr->value |= PUBLICTAG;
3999      }                          /* if */
4000 }
4001
4002 static void
4003 doexit(void)
4004 {
4005    int                 tag = 0;
4006
4007    if (matchtoken(tTERM) == 0)
4008      {
4009         doexpr(TRUE, FALSE, FALSE, TRUE, &tag, FALSE);
4010         needtoken(tTERM);
4011      }
4012    else
4013      {
4014         const1(0);
4015      }                          /* if */
4016    const2(tag);
4017    exporttag(tag);
4018    destructsymbols(&loctab, 0); /* call destructor for *all* locals */
4019    ffabort(xEXIT);
4020 }
4021
4022 static void
4023 dosleep(void)
4024 {
4025    int                 tag = 0;
4026
4027    if (matchtoken(tTERM) == 0)
4028      {
4029         doexpr(TRUE, FALSE, FALSE, TRUE, &tag, FALSE);
4030         needtoken(tTERM);
4031      }
4032    else
4033      {
4034         const1(0);
4035      }                          /* if */
4036    const2(tag);
4037    exporttag(tag);
4038    ffabort(xSLEEP);
4039 }
4040
4041 static void
4042 addwhile(int *ptr)
4043 {
4044    int                 k;
4045
4046    ptr[wqBRK] = (int)declared;  /* stack pointer (for "break") */
4047    ptr[wqCONT] = (int)declared; /* for "continue", possibly adjusted later */
4048    ptr[wqLOOP] = getlabel();
4049    ptr[wqEXIT] = getlabel();
4050    if (wqptr >= (wq + wqTABSZ - wqSIZE))
4051       error(102, "loop table"); /* loop table overflow (too many active loops) */
4052    k = 0;
4053    while (k < wqSIZE)
4054      {                          /* copy "ptr" to while queue table */
4055         *wqptr = *ptr;
4056         wqptr += 1;
4057         ptr += 1;
4058         k += 1;
4059      }                          /* while */
4060 }
4061
4062 static void
4063 delwhile(void)
4064 {
4065    if (wqptr > wq)
4066       wqptr -= wqSIZE;
4067 }
4068
4069 static int         *
4070 readwhile(void)
4071 {
4072    if (wqptr <= wq)
4073      {
4074         error(24);              /* out of context */
4075         return NULL;
4076      }
4077    else
4078      {
4079         return (wqptr - wqSIZE);
4080      }                          /* if */
4081 }