src/bin/embryo_cc_sc1.c

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