src/bin/embryo_cc_sc1.c

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