src/bin/embryo_cc_sc1.c

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