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