src/bin/embryo_cc_sc1.c

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