src/bin/embryo_cc_sc1.c

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