src/bin/embryo_cc_sc2.c

   1 /*
   2  *  vim:ts=8:sw=3:sts=8:noexpandtab:cino=>5n-3f0^-2{2
   3  *
   4  *  Small compiler - File input, preprocessing and lexical analysis functions
   5  *
   6  *  Copyright (c) ITB CompuPhase, 1997-2003
   7  *
   8  *  This software is provided "as-is", without any express or implied warranty.
   9  *  In no event will the authors be held liable for any damages arising from
  10  *  the use of this software.
  11  *
  12  *  Permission is granted to anyone to use this software for any purpose,
  13  *  including commercial applications, and to alter it and redistribute it
  14  *  freely, subject to the following restrictions:
  15  *
  16  *  1.  The origin of this software must not be misrepresented; you must not
  17  *      claim that you wrote the original software. If you use this software in
  18  *      a product, an acknowledgment in the product documentation would be
  19  *      appreciated but is not required.
  20  *  2.  Altered source versions must be plainly marked as such, and must not be
  21  *      misrepresented as being the original software.
  22  *  3.  This notice may not be removed or altered from any source distribution.
  23  *
  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 <stdio.h>
  37 #include <stdlib.h>
  38 #include <string.h>
  39 #include <ctype.h>
  40 #include <math.h>
  41 #include "embryo_cc_osdefs.h"
  42 #include "embryo_cc_sc.h"
  43 #include "Embryo.h"
  44
  45 static int          match(char *st, int end);
  46 static cell         litchar(char **lptr, int rawmode);
  47 static int          alpha(char c);
  48
  49 static int          icomment;   /* currently in multiline comment? */
  50 static int          iflevel;    /* nesting level if #if/#else/#endif */
  51 static int          skiplevel;  /* level at which we started skipping */
  52 static int          elsedone;   /* level at which we have seen an #else */
  53 static char         term_expr[] = "";
  54 static int          listline = -1;      /* "current line" for the list file */
  55
  56 /*  pushstk & popstk
  57  *
  58  *  Uses a LIFO stack to store information. The stack is used by doinclude(),
  59  *  doswitch() (to hold the state of "swactive") and some other routines.
  60  *
  61  *  Porting note: I made the bold assumption that an integer will not be
  62  *  larger than a pointer (it may be smaller). That is, the stack element
  63  *  is typedef'ed as a pointer type, but I also store integers on it. See
  64  *  SC.H for "stkitem"
  65  *
  66  *  Global references: stack,stkidx (private to pushstk() and popstk())
  67  */
  68 static stkitem      stack[sSTKMAX];
  69 static int          stkidx;
  70 void
  71 pushstk(stkitem val)
  72 {
  73    if (stkidx >= sSTKMAX)
  74       error(102, "parser stack");       /* stack overflow (recursive include?) */
  75    stack[stkidx] = val;
  76    stkidx += 1;
  77 }
  78
  79 stkitem
  80 popstk(void)
  81 {
  82    if (stkidx == 0)
  83       return (stkitem) - 1;     /* stack is empty */
  84    stkidx -= 1;
  85    return stack[stkidx];
  86 }
  87
  88 int
  89 plungequalifiedfile(char *name)
  90 {
  91    static char        *extensions[] = { ".inc", ".sma", ".small" };
  92    FILE               *fp;
  93    char               *ext;
  94    int                 ext_idx;
  95
  96    ext_idx = 0;
  97    do
  98      {
  99         fp = (FILE *) sc_opensrc(name);
 100         ext = strchr(name, '\0');       /* save position */
 101         if (fp == NULL)
 102           {
 103              /* try to append an extension */
 104              strcpy(ext, extensions[ext_idx]);
 105              fp = (FILE *) sc_opensrc(name);
 106              if (fp == NULL)
 107                 *ext = '\0';    /* on failure, restore filename */
 108           }                     /* if */
 109         ext_idx++;
 110      }
 111    while (fp == NULL && ext_idx < (sizeof extensions / sizeof extensions[0]));
 112    if (fp == NULL)
 113      {
 114         *ext = '\0';            /* restore filename */
 115         return FALSE;
 116      }                          /* if */
 117    pushstk((stkitem) inpf);
 118    pushstk((stkitem) inpfname); /* pointer to current file name */
 119    pushstk((stkitem) curlibrary);
 120    /* FIXME: 64bit unsafe */
 121    pushstk((stkitem) iflevel);
 122    assert(skiplevel == 0);
 123    /* FIXME: 64bit unsafe */
 124    pushstk((stkitem) icomment);
 125    /* FIXME: 64bit unsafe */
 126    pushstk((stkitem) fcurrent);
 127    /* FIXME: 64bit unsafe */
 128    pushstk((stkitem) fline);
 129    inpfname = strdup(name);     /* set name of include file */
 130    if (inpfname == NULL)
 131       error(103);               /* insufficient memory */
 132    inpf = fp;                   /* set input file pointer to include file */
 133    fnumber++;
 134    fline = 0;                   /* set current line number to 0 */
 135    fcurrent = fnumber;
 136    icomment = FALSE;
 137    setfile(inpfname, fcurrent);
 138    listline = -1;               /* force a #line directive when changing the file */
 139    setactivefile(fcurrent);
 140    return TRUE;
 141 }
 142
 143 int
 144 plungefile(char *name, int try_currentpath, int try_includepaths)
 145 {
 146    int                 result = FALSE;
 147    int                 i;
 148    char               *ptr;
 149
 150    if (try_currentpath)
 151       result = plungequalifiedfile(name);
 152
 153    if (try_includepaths && name[0] != DIRSEP_CHAR)
 154      {
 155         for (i = 0; !result && (ptr = get_path(i)) != NULL; i++)
 156           {
 157              char                path[_MAX_PATH];
 158
 159              strncpy(path, ptr, sizeof path);
 160              path[sizeof path - 1] = '\0';      /* force '\0' termination */
 161              strncat(path, name, sizeof(path) - strlen(path));
 162              path[sizeof path - 1] = '\0';
 163              result = plungequalifiedfile(path);
 164           }                     /* while */
 165      }                          /* if */
 166    return result;
 167 }
 168
 169 static void
 170 check_empty(char *lptr)
 171 {
 172    /* verifies that the string contains only whitespace */
 173    while (*lptr <= ' ' && *lptr != '\0')
 174       lptr++;
 175    if (*lptr != '\0')
 176       error(38);                /* extra characters on line */
 177 }
 178
 179 /*  doinclude
 180  *
 181  *  Gets the name of an include file, pushes the old file on the stack and
 182  *  sets some options. This routine doesn't use lex(), since lex() doesn't
 183  *  recognize file names (and directories).
 184  *
 185  *  Global references: inpf     (altered)
 186  *                     inpfname (altered)
 187  *                     fline    (altered)
 188  *                     lptr     (altered)
 189  */
 190 static void
 191 doinclude(void)
 192 {
 193    char                name[_MAX_PATH], c;
 194    int                 i, result;
 195
 196    while (*lptr <= ' ' && *lptr != 0)   /* skip leading whitespace */
 197       lptr++;
 198    if (*lptr == '<' || *lptr == '\"')
 199      {
 200         c = (char)((*lptr == '\"') ? '\"' : '>');       /* termination character */
 201         lptr++;
 202         while (*lptr <= ' ' && *lptr != 0)      /* skip whitespace after quote */
 203            lptr++;
 204      }
 205    else
 206      {
 207         c = '\0';
 208      }                          /* if */
 209
 210    i = 0;
 211    while (*lptr != c && *lptr != '\0' && i < sizeof name - 1)   /* find the end of the string */
 212       name[i++] = *lptr++;
 213    while (i > 0 && name[i - 1] <= ' ')
 214       i--;                      /* strip trailing whitespace */
 215    assert(i >= 0 && i < sizeof name);
 216    name[i] = '\0';              /* zero-terminate the string */
 217
 218    if (*lptr != c)
 219      {                          /* verify correct string termination */
 220         error(37);              /* invalid string */
 221         return;
 222      }                          /* if */
 223    if (c != '\0')
 224       check_empty(lptr + 1);    /* verify that the rest of the line is whitespace */
 225
 226    /* Include files between "..." or without quotes are read from the current
 227     * directory, or from a list of "include directories". Include files
 228     * between <...> are only read from the list of include directories.
 229     */
 230    result = plungefile(name, (c != '>'), TRUE);
 231    if (!result)
 232       error(100, name);         /* cannot read from ... (fatal error) */
 233 }
 234
 235 /*  readline
 236  *
 237  *  Reads in a new line from the input file pointed to by "inpf". readline()
 238  *  concatenates lines that end with a \ with the next line. If no more data
 239  *  can be read from the file, readline() attempts to pop off the previous file
 240  *  from the stack. If that fails too, it sets "freading" to 0.
 241  *
 242  *  Global references: inpf,fline,inpfname,freading,icomment (altered)
 243  */
 244 static void
 245 readline(char *line)
 246 {
 247    int                 i, num, cont;
 248    char               *ptr;
 249
 250    if (lptr == term_expr)
 251       return;
 252    num = sLINEMAX;
 253    cont = FALSE;
 254    do
 255      {
 256         if (inpf == NULL || sc_eofsrc(inpf))
 257           {
 258              if (cont)
 259                 error(49);      /* invalid line continuation */
 260              if (inpf != NULL && inpf != inpf_org)
 261                 sc_closesrc(inpf);
 262              i = (int)(long)popstk();
 263              if (i == -1)
 264                {                /* All's done; popstk() returns "stack is empty" */
 265                   freading = FALSE;
 266                   *line = '\0';
 267                   /* when there is nothing more to read, the #if/#else stack should
 268                    * be empty and we should not be in a comment
 269                    */
 270                   assert(iflevel >= 0);
 271                   if (iflevel > 0)
 272                      error(1, "#endif", "-end of file-");
 273                   else if (icomment)
 274                      error(1, "*/", "-end of file-");
 275                   return;
 276                }                /* if */
 277              fline = i;
 278              fcurrent = (int)(long)popstk();
 279              icomment = (int)(long)popstk();
 280              assert(skiplevel == 0);    /* skiplevel was not stored on stack, because it should always be zero at this point */
 281              iflevel = (int)(long)popstk();
 282              curlibrary = (constvalue *) popstk();
 283              free(inpfname);    /* return memory allocated for the include file name */
 284              inpfname = (char *)popstk();
 285              inpf = (FILE *) popstk();
 286              setactivefile(fcurrent);
 287              listline = -1;     /* force a #line directive when changing the file */
 288              elsedone = 0;
 289           }                     /* if */
 290
 291         if (sc_readsrc(inpf, line, num) == NULL)
 292           {
 293              *line = '\0';      /* delete line */
 294              cont = FALSE;
 295           }
 296         else
 297           {
 298              /* check whether to erase leading spaces */
 299              if (cont)
 300                {
 301                   char               *ptr = line;
 302
 303                   while (*ptr == ' ' || *ptr == '\t')
 304                      ptr++;
 305                   if (ptr != line)
 306                      memmove(line, ptr, strlen(ptr) + 1);
 307                }                /* if */
 308              cont = FALSE;
 309              /* check whether a full line was read */
 310              if (strchr(line, '\n') == NULL && !sc_eofsrc(inpf))
 311                 error(75);      /* line too long */
 312              /* check if the next line must be concatenated to this line */
 313              if ((ptr = strchr(line, '\n')) != NULL && ptr > line)
 314                {
 315                   assert(*(ptr + 1) == '\0');   /* '\n' should be last in the string */
 316                   while (ptr > line
 317                          && (*ptr == '\n' || *ptr == ' ' || *ptr == '\t'))
 318                      ptr--;     /* skip trailing whitespace */
 319                   if (*ptr == '\\')
 320                     {
 321                        cont = TRUE;
 322                        /* set '\a' at the position of '\\' to make it possible to check
 323                         * for a line continuation in a single line comment (error 49)
 324                         */
 325                        *ptr++ = '\a';
 326                        *ptr = '\0';     /* erase '\n' (and any trailing whitespace) */
 327                     }           /* if */
 328                }                /* if */
 329              num -= strlen(line);
 330              line += strlen(line);
 331           }                     /* if */
 332         fline += 1;
 333      }
 334    while (num >= 0 && cont);
 335 }
 336
 337 /*  stripcom
 338  *
 339  *  Replaces all comments from the line by space characters. It updates
 340  *  a global variable ("icomment") for multiline comments.
 341  *
 342  *  This routine also supports the C++ extension for single line comments.
 343  *  These comments are started with "//" and end at the end of the line.
 344  *
 345  *  Global references: icomment  (private to "stripcom")
 346  */
 347 static void
 348 stripcom(char *line)
 349 {
 350    char                c;
 351
 352    while (*line)
 353      {
 354         if (icomment)
 355           {
 356              if (*line == '*' && *(line + 1) == '/')
 357                {
 358                   icomment = FALSE;     /* comment has ended */
 359                   *line = ' ';  /* replace '*' and '/' characters by spaces */
 360                   *(line + 1) = ' ';
 361                   line += 2;
 362                }
 363              else
 364                {
 365                   if (*line == '/' && *(line + 1) == '*')
 366                      error(216);        /* nested comment */
 367                   *line = ' ';  /* replace comments by spaces */
 368                   line += 1;
 369                }                /* if */
 370           }
 371         else
 372           {
 373              if (*line == '/' && *(line + 1) == '*')
 374                {
 375                   icomment = TRUE;      /* start comment */
 376                   *line = ' ';  /* replace '/' and '*' characters by spaces */
 377                   *(line + 1) = ' ';
 378                   line += 2;
 379                }
 380              else if (*line == '/' && *(line + 1) == '/')
 381                {                /* comment to end of line */
 382                   if (strchr(line, '\a') != NULL)
 383                      error(49); /* invalid line continuation */
 384                   *line++ = '\n';       /* put "newline" at first slash */
 385                   *line = '\0'; /* put "zero-terminator" at second slash */
 386                }
 387              else
 388                {
 389                   if (*line == '\"' || *line == '\'')
 390                     {           /* leave literals unaltered */
 391                        c = *line;       /* ending quote, single or double */
 392                        line += 1;
 393                        while ((*line != c || *(line - 1) == '\\')
 394                               && *line != '\0')
 395                           line += 1;
 396                        line += 1;       /* skip final quote */
 397                     }
 398                   else
 399                     {
 400                        line += 1;
 401                     }           /* if */
 402                }                /* if */
 403           }                     /* if */
 404      }                          /* while */
 405 }
 406
 407 /*  btoi
 408  *
 409  *  Attempts to interpret a numeric symbol as a boolean value. On success
 410  *  it returns the number of characters processed (so the line pointer can be
 411  *  adjusted) and the value is stored in "val". Otherwise it returns 0 and
 412  *  "val" is garbage.
 413  *
 414  *  A boolean value must start with "0b"
 415  */
 416 static int
 417 btoi(cell * val, char *curptr)
 418 {
 419    char               *ptr;
 420
 421    *val = 0;
 422    ptr = curptr;
 423    if (*ptr == '0' && *(ptr + 1) == 'b')
 424      {
 425         ptr += 2;
 426         while (*ptr == '0' || *ptr == '1' || *ptr == '_')
 427           {
 428              if (*ptr != '_')
 429                 *val = (*val << 1) | (*ptr - '0');
 430              ptr++;
 431           }                     /* while */
 432      }
 433    else
 434      {
 435         return 0;
 436      }                          /* if */
 437    if (alphanum(*ptr))          /* number must be delimited by non-alphanumeric char */
 438       return 0;
 439    else
 440       return (int)(ptr - curptr);
 441 }
 442
 443 /*  dtoi
 444  *
 445  *  Attempts to interpret a numeric symbol as a decimal value. On success
 446  *  it returns the number of characters processed and the value is stored in
 447  *  "val". Otherwise it returns 0 and "val" is garbage.
 448  */
 449 static int
 450 dtoi(cell * val, char *curptr)
 451 {
 452    char               *ptr;
 453
 454    *val = 0;
 455    ptr = curptr;
 456    if (!isdigit(*ptr))          /* should start with digit */
 457       return 0;
 458    while (isdigit(*ptr) || *ptr == '_')
 459      {
 460         if (*ptr != '_')
 461            *val = (*val * 10) + (*ptr - '0');
 462         ptr++;
 463      }                          /* while */
 464    if (alphanum(*ptr))          /* number must be delimited by non-alphanumerical */
 465       return 0;
 466    if (*ptr == '.' && isdigit(*(ptr + 1)))
 467       return 0;                 /* but a fractional part must not be present */
 468    return (int)(ptr - curptr);
 469 }
 470
 471 /*  htoi
 472  *
 473  *  Attempts to interpret a numeric symbol as a hexadecimal value. On
 474  *  success it returns the number of characters processed and the value is
 475  *  stored in "val". Otherwise it return 0 and "val" is garbage.
 476  */
 477 static int
 478 htoi(cell * val, char *curptr)
 479 {
 480    char               *ptr;
 481
 482    *val = 0;
 483    ptr = curptr;
 484    if (!isdigit(*ptr))          /* should start with digit */
 485       return 0;
 486    if (*ptr == '0' && *(ptr + 1) == 'x')
 487      {                          /* C style hexadecimal notation */
 488         ptr += 2;
 489         while (isxdigit(*ptr) || *ptr == '_')
 490           {
 491              if (*ptr != '_')
 492                {
 493                   assert(isxdigit(*ptr));
 494                   *val = *val << 4;
 495                   if (isdigit(*ptr))
 496                      *val += (*ptr - '0');
 497                   else
 498                      *val += (tolower(*ptr) - 'a' + 10);
 499                }                /* if */
 500              ptr++;
 501           }                     /* while */
 502      }
 503    else
 504      {
 505         return 0;
 506      }                          /* if */
 507    if (alphanum(*ptr))
 508       return 0;
 509    else
 510       return (int)(ptr - curptr);
 511 }
 512
 513 #if defined LINUX
 514 static double
 515 pow10(int value)
 516 {
 517    double              res = 1.0;
 518
 519    while (value >= 4)
 520      {
 521         res *= 10000.0;
 522         value -= 5;
 523      }                          /* while */
 524    while (value >= 2)
 525      {
 526         res *= 100.0;
 527         value -= 2;
 528      }                          /* while */
 529    while (value >= 1)
 530      {
 531         res *= 10.0;
 532         value -= 1;
 533      }                          /* while */
 534    return res;
 535 }
 536 #endif
 537
 538 /*  ftoi
 539  *
 540  *  Attempts to interpret a numeric symbol as a rational number, either as
 541  *  IEEE 754 single precision floating point or as a fixed point integer.
 542  *  On success it returns the number of characters processed and the value is
 543  *  stored in "val". Otherwise it returns 0 and "val" is unchanged.
 544  *
 545  *  Small has stricter definition for floating point numbers than most:
 546  *  o  the value must start with a digit; ".5" is not a valid number, you
 547  *     should write "0.5"
 548  *  o  a period must appear in the value, even if an exponent is given; "2e3"
 549  *     is not a valid number, you should write "2.0e3"
 550  *  o  at least one digit must follow the period; "6." is not a valid number,
 551  *     you should write "6.0"
 552  */
 553 static int
 554 ftoi(cell * val, char *curptr)
 555 {
 556    char               *ptr;
 557    double              fnum, ffrac, fmult;
 558    unsigned long       dnum, dbase;
 559    int                 i, ignore;
 560
 561    assert(rational_digits >= 0 && rational_digits < 9);
 562    for (i = 0, dbase = 1; i < rational_digits; i++)
 563       dbase *= 10;
 564    fnum = 0.0;
 565    dnum = 0L;
 566    ptr = curptr;
 567    if (!isdigit(*ptr))          /* should start with digit */
 568       return 0;
 569    while (isdigit(*ptr) || *ptr == '_')
 570      {
 571         if (*ptr != '_')
 572           {
 573              fnum = (fnum * 10.0) + (*ptr - '0');
 574              dnum = (dnum * 10L) + (*ptr - '0') * dbase;
 575           }                     /* if */
 576         ptr++;
 577      }                          /* while */
 578    if (*ptr != '.')
 579       return 0;                 /* there must be a period */
 580    ptr++;
 581    if (!isdigit(*ptr))          /* there must be at least one digit after the dot */
 582       return 0;
 583    ffrac = 0.0;
 584    fmult = 1.0;
 585    ignore = FALSE;
 586    while (isdigit(*ptr) || *ptr == '_')
 587      {
 588         if (*ptr != '_')
 589           {
 590              ffrac = (ffrac * 10.0) + (*ptr - '0');
 591              fmult = fmult / 10.0;
 592              dbase /= 10L;
 593              dnum += (*ptr - '0') * dbase;
 594              if (dbase == 0L && sc_rationaltag && rational_digits > 0
 595                  && !ignore)
 596                {
 597                   error(222);   /* number of digits exceeds rational number precision */
 598                   ignore = TRUE;
 599                }                /* if */
 600           }                     /* if */
 601         ptr++;
 602      }                          /* while */
 603    fnum += ffrac * fmult;       /* form the number so far */
 604    if (*ptr == 'e')
 605      {                          /* optional fractional part */
 606         int                 exp, sign;
 607
 608         ptr++;
 609         if (*ptr == '-')
 610           {
 611              sign = -1;
 612              ptr++;
 613           }
 614         else
 615           {
 616              sign = 1;
 617           }                     /* if */
 618         if (!isdigit(*ptr))     /* 'e' should be followed by a digit */
 619            return 0;
 620         exp = 0;
 621         while (isdigit(*ptr))
 622           {
 623              exp = (exp * 10) + (*ptr - '0');
 624              ptr++;
 625           }                     /* while */
 626 #if defined LINUX
 627         fmult = pow10(exp * sign);
 628 #else
 629         fmult = pow(10, exp * sign);
 630 #endif
 631         fnum *= fmult;
 632         dnum *= (unsigned long)(fmult + 0.5);
 633      }                          /* if */
 634
 635    /* decide how to store the number */
 636    if (sc_rationaltag == 0)
 637      {
 638         error(70);              /* rational number support was not enabled */
 639         *val = 0;
 640      }
 641    else if (rational_digits == 0)
 642      {
 643         /* floating point */
 644       *val = EMBRYO_FLOAT_TO_CELL((float) fnum);
 645 #if !defined NDEBUG
 646         /* I assume that the C/C++ compiler stores "float" values in IEEE 754
 647          * format (as mandated in the ANSI standard). Test this assumption anyway.
 648          */
 649         {
 650            float test1 = 0.0, test2 = 50.0;
 651            Embryo_Cell c1 = EMBRYO_FLOAT_TO_CELL(test1);
 652            Embryo_Cell c2 = EMBRYO_FLOAT_TO_CELL(test2);
 653
 654            if (c1 != 0x00000000L)
 655              {
 656                 fprintf(stderr,
 657                         "embryo_cc: WARNING! you compiler does not SEEM to interpret IEEE floating\n"
 658                         "point math as embryo expects. this could be bad.\n"
 659                         "\n"
 660                         "(float 0.0 != 0x00000000 bitpattern, 0x%08x instead)\n"
 661                         "\n"
 662                         "this could be an issue with you compiling embryo with gcc 3.2.x that seems\n"
 663                         "to trigger this sanity check. we are not sure why yet, but gcc 3.3.x works\n"
 664                         , c1);
 665              }
 666           else if (c2 != 0x42480000L)
 667              {
 668                 fprintf(stderr,
 669                         "embryo_cc: WARNING! you compiler does not SEEM to interpret IEEE floating\n"
 670                         "point math as embryo expects. This could be bad.\n"
 671                         "\n"
 672                         "(float 50.0 != 0x42480000 bitpattern, 0x%08x instead)\n"
 673                         "\n"
 674                         "this could be an issue with you compiling embryo with gcc 3.2.x that seems\n"
 675                         "to trigger this sanity check. we are not sure why yet, but gcc 3.3.x works\n"
 676                         , c2);
 677              }
 678         }
 679 #endif
 680      }
 681    else
 682      {
 683         /* fixed point */
 684         *val = (cell) dnum;
 685      }                          /* if */
 686
 687    return (int)(ptr - curptr);
 688 }
 689
 690 /*  number
 691  *
 692  *  Reads in a number (binary, decimal or hexadecimal). It returns the number
 693  *  of characters processed or 0 if the symbol couldn't be interpreted as a
 694  *  number (in this case the argument "val" remains unchanged). This routine
 695  *  relies on the 'early dropout' implementation of the logical or (||)
 696  *  operator.
 697  *
 698  *  Note: the routine doesn't check for a sign (+ or -). The - is checked
 699  *        for at "hier2()" (in fact, it is viewed as an operator, not as a
 700  *        sign) and the + is invalid (as in K&R C, and unlike ANSI C).
 701  */
 702 static int
 703 number(cell * val, char *curptr)
 704 {
 705    int                 i;
 706    cell                value;
 707
 708    if ((i = btoi(&value, curptr)) != 0  /* binary? */
 709        || (i = htoi(&value, curptr)) != 0       /* hexadecimal? */
 710        || (i = dtoi(&value, curptr)) != 0)      /* decimal? */
 711      {
 712         *val = value;
 713         return i;
 714      }
 715    else
 716      {
 717         return 0;               /* else not a number */
 718      }                          /* if */
 719 }
 720
 721 static void
 722 chrcat(char *str, char chr)
 723 {
 724    str = strchr(str, '\0');
 725    *str++ = chr;
 726    *str = '\0';
 727 }
 728
 729 static int
 730 preproc_expr(cell * val, int *tag)
 731 {
 732    int                 result;
 733    int                 index;
 734    cell                code_index;
 735    char               *term;
 736
 737    /* Disable staging; it should be disabled already because
 738     * expressions may not be cut off half-way between conditional
 739     * compilations. Reset the staging index, but keep the code
 740     * index.
 741     */
 742    if (stgget(&index, &code_index))
 743      {
 744         error(57);              /* unfinished expression */
 745         stgdel(0, code_index);
 746         stgset(FALSE);
 747      }                          /* if */
 748    /* append a special symbol to the string, so the expression
 749     * analyzer won't try to read a next line when it encounters
 750     * an end-of-line
 751     */
 752    assert(strlen(pline) < sLINEMAX);
 753    term = strchr(pline, '\0');
 754    assert(term != NULL);
 755    chrcat(pline, PREPROC_TERM); /* the "DEL" code (see SC.H) */
 756    result = constexpr(val, tag);        /* get value (or 0 on error) */
 757    *term = '\0';                /* erase the token (if still present) */
 758    lexclr(FALSE);               /* clear any "pushed" tokens */
 759    return result;
 760 }
 761
 762 /* getstring
 763  * Returns returns a pointer behind the closing quote or to the other
 764  * character that caused the input to be ended.
 765  */
 766 static char        *
 767 getstring(char *dest, int max, char *line)
 768 {
 769    assert(dest != NULL && line != NULL);
 770    *dest = '\0';
 771    while (*line <= ' ' && *line != '\0')
 772       line++;                   /* skip whitespace */
 773    if (*line != '"')
 774      {
 775         error(37);              /* invalid string */
 776      }
 777    else if (*line == '\0')
 778      {
 779         int                 len = 0;
 780
 781         line++;                 /* skip " */
 782         while (*line != '"' && *line != '\0')
 783           {
 784              if (len < max - 1)
 785                 dest[len++] = *line;
 786              line++;
 787           }                     /* if */
 788         dest[len] = '\0';
 789         if (*line == '"')
 790            lptr++;              /* skip closing " */
 791         else
 792            error(37);           /* invalid string */
 793      }                          /* if */
 794    return lptr;
 795 }
 796
 797 enum
 798 {
 799    CMD_NONE,
 800    CMD_TERM,
 801    CMD_EMPTYLINE,
 802    CMD_CONDFALSE,
 803    CMD_INCLUDE,
 804    CMD_DEFINE,
 805    CMD_IF,
 806    CMD_DIRECTIVE,
 807 };
 808
 809 /*  command
 810  *
 811  *  Recognizes the compiler directives. The function returns:
 812  *     CMD_NONE         the line must be processed
 813  *     CMD_TERM         a pending expression must be completed before processing further lines
 814  *     Other value: the line must be skipped, because:
 815  *     CMD_CONDFALSE    false "#if.." code
 816  *     CMD_EMPTYLINE    line is empty
 817  *     CMD_INCLUDE      the line contains a #include directive
 818  *     CMD_DEFINE       the line contains a #subst directive
 819  *     CMD_IF           the line contains a #if/#else/#endif directive
 820  *     CMD_DIRECTIVE    the line contains some other compiler directive
 821  *
 822  *  Global variables: iflevel, skiplevel, elsedone (altered)
 823  *                    lptr      (altered)
 824  */
 825 static int
 826 command(void)
 827 {
 828    int                 tok, ret;
 829    cell                val;
 830    char               *str;
 831    int                 index;
 832    cell                code_index;
 833
 834    while (*lptr <= ' ' && *lptr != '\0')
 835       lptr += 1;
 836    if (*lptr == '\0')
 837       return CMD_EMPTYLINE;     /* empty line */
 838    if (*lptr != '#')
 839       return skiplevel > 0 ? CMD_CONDFALSE : CMD_NONE;  /* it is not a compiler directive */
 840    /* compiler directive found */
 841    indent_nowarn = TRUE;        /* allow loose indentation" */
 842    lexclr(FALSE);               /* clear any "pushed" tokens */
 843    /* on a pending expression, force to return a silent ';' token and force to
 844     * re-read the line
 845     */
 846    if (!sc_needsemicolon && stgget(&index, &code_index))
 847      {
 848         lptr = term_expr;
 849         return CMD_TERM;
 850      }                          /* if */
 851    tok = lex(&val, &str);
 852    ret = skiplevel > 0 ? CMD_CONDFALSE : CMD_DIRECTIVE; /* preset 'ret' to CMD_DIRECTIVE (most common case) */
 853    switch (tok)
 854      {
 855      case tpIF:         /* conditional compilation */
 856         ret = CMD_IF;
 857         iflevel += 1;
 858         if (skiplevel)
 859            break;               /* break out of switch */
 860         preproc_expr(&val, NULL);       /* get value (or 0 on error) */
 861         if (!val)
 862            skiplevel = iflevel;
 863         check_empty(lptr);
 864         break;
 865      case tpELSE:
 866         ret = CMD_IF;
 867         if (iflevel == 0 && skiplevel == 0)
 868           {
 869              error(26);         /* no matching #if */
 870              errorset(sRESET);
 871           }
 872         else
 873           {
 874              if (elsedone == iflevel)
 875                 error(60);      /* multiple #else directives between #if ... #endif */
 876              elsedone = iflevel;
 877              if (skiplevel == iflevel)
 878                 skiplevel = 0;
 879              else if (skiplevel == 0)
 880                 skiplevel = iflevel;
 881           }                     /* if */
 882         check_empty(lptr);
 883         break;
 884 #if 0                           /* ??? *really* need to use a stack here */
 885      case tpELSEIF:
 886         ret = CMD_IF;
 887         if (iflevel == 0 && skiplevel == 0)
 888           {
 889              error(26);         /* no matching #if */
 890              errorset(sRESET);
 891           }
 892         else if (elsedone == iflevel)
 893           {
 894              error(61);         /* #elseif directive may not follow an #else */
 895              errorset(sRESET);
 896           }
 897         else
 898           {
 899              preproc_expr(&val, NULL);  /* get value (or 0 on error) */
 900              if (skiplevel == 0)
 901                 skiplevel = iflevel;    /* we weren't skipping, start skipping now */
 902              else if (val)
 903                 skiplevel = 0;  /* we were skipping, condition is valid -> stop skipping */
 904              /* else: we were skipping and condition is invalid -> keep skipping */
 905              check_empty(lptr);
 906           }                     /* if */
 907         break;
 908 #endif
 909      case tpENDIF:
 910         ret = CMD_IF;
 911         if (iflevel == 0 && skiplevel == 0)
 912           {
 913              error(26);
 914              errorset(sRESET);
 915           }
 916         else
 917           {
 918              if (skiplevel == iflevel)
 919                 skiplevel = 0;
 920              if (elsedone == iflevel)
 921                 elsedone = 0;   /* ??? actually, should build a stack of #if/#endif and keep
 922                                  * the state whether an #else was seen per nesting level */
 923              iflevel -= 1;
 924           }                     /* if */
 925         check_empty(lptr);
 926         break;
 927      case tINCLUDE:             /* #include directive */
 928         ret = CMD_INCLUDE;
 929         if (skiplevel == 0)
 930            doinclude();
 931         break;
 932      case tpFILE:
 933         if (skiplevel == 0)
 934           {
 935              char                pathname[_MAX_PATH];
 936
 937              lptr = getstring(pathname, sizeof pathname, lptr);
 938              if (pathname[0] != '\0')
 939                {
 940                   free(inpfname);
 941                   inpfname = strdup(pathname);
 942                   if (inpfname == NULL)
 943                      error(103);        /* insufficient memory */
 944                }                /* if */
 945           }                     /* if */
 946         check_empty(lptr);
 947         break;
 948      case tpLINE:
 949         if (skiplevel == 0)
 950           {
 951              if (lex(&val, &str) != tNUMBER)
 952                 error(8);       /* invalid/non-constant expression */
 953              fline = (int)val;
 954           }                     /* if */
 955         check_empty(lptr);
 956         break;
 957      case tpASSERT:
 958         if (skiplevel == 0 && (sc_debug & sCHKBOUNDS) != 0)
 959           {
 960              preproc_expr(&val, NULL);  /* get constant expression (or 0 on error) */
 961              if (!val)
 962                 error(7);       /* assertion failed */
 963              check_empty(lptr);
 964           }                     /* if */
 965         break;
 966      case tpPRAGMA:
 967         if (skiplevel == 0)
 968           {
 969              if (lex(&val, &str) == tSYMBOL)
 970                {
 971                   if (strcmp(str, "ctrlchar") == 0)
 972                     {
 973                        if (lex(&val, &str) != tNUMBER)
 974                           error(27);    /* invalid character constant */
 975                        sc_ctrlchar = (char)val;
 976                     }
 977                   else if (strcmp(str, "compress") == 0)
 978                     {
 979                        cell                val;
 980
 981                        preproc_expr(&val, NULL);
 982                        sc_compress = (int)val;  /* switch code packing on/off */
 983                     }
 984                   else if (strcmp(str, "dynamic") == 0)
 985                     {
 986                        preproc_expr(&sc_stksize, NULL);
 987                     }
 988                   else if (strcmp(str, "library") == 0)
 989                     {
 990                        char                name[sNAMEMAX + 1];
 991
 992                        while (*lptr <= ' ' && *lptr != '\0')
 993                           lptr++;
 994                        if (*lptr == '"')
 995                          {
 996                             lptr = getstring(name, sizeof name, lptr);
 997                          }
 998                        else
 999                          {
1000                             int                 i;
1001
1002                             for (i = 0; i < sizeof name && alphanum(*lptr);
1003                                  i++, lptr++)
1004                                name[i] = *lptr;
1005                             name[i] = '\0';
1006                          }      /* if */
1007                        if (name[0] == '\0')
1008                          {
1009                             curlibrary = NULL;
1010                          }
1011                        else
1012                          {
1013                             if (strlen(name) > sEXPMAX)
1014                                error(220, name, sEXPMAX);       /* exported symbol is truncated */
1015                             /* add the name if it does not yet exist in the table */
1016                             if (find_constval(&libname_tab, name, 0) == NULL)
1017                                curlibrary =
1018                                   append_constval(&libname_tab, name, 0, 0);
1019                          }      /* if */
1020                     }
1021                   else if (strcmp(str, "pack") == 0)
1022                     {
1023                        cell                val;
1024
1025                        preproc_expr(&val, NULL);        /* default = packed/unpacked */
1026                        sc_packstr = (int)val;
1027                     }
1028                   else if (strcmp(str, "rational") == 0)
1029                     {
1030                        char                name[sNAMEMAX + 1];
1031                        cell                digits = 0;
1032                        int                 i;
1033
1034                        /* first gather all information, start with the tag name */
1035                        while (*lptr <= ' ' && *lptr != '\0')
1036                           lptr++;
1037                        for (i = 0; i < sizeof name && alphanum(*lptr);
1038                             i++, lptr++)
1039                           name[i] = *lptr;
1040                        name[i] = '\0';
1041                        /* then the precision (for fixed point arithmetic) */
1042                        while (*lptr <= ' ' && *lptr != '\0')
1043                           lptr++;
1044                        if (*lptr == '(')
1045                          {
1046                             preproc_expr(&digits, NULL);
1047                             if (digits <= 0 || digits > 9)
1048                               {
1049                                  error(68);     /* invalid rational number precision */
1050                                  digits = 0;
1051                               } /* if */
1052                             if (*lptr == ')')
1053                                lptr++;
1054                          }      /* if */
1055                        /* add the tag (make it public) and check the values */
1056                        i = sc_addtag(name);
1057                        exporttag(i);
1058                        if (sc_rationaltag == 0
1059                            || (sc_rationaltag == i
1060                                && rational_digits == (int)digits))
1061                          {
1062                             sc_rationaltag = i;
1063                             rational_digits = (int)digits;
1064                          }
1065                        else
1066                          {
1067                             error(69);  /* rational number format already set, can only be set once */
1068                          }      /* if */
1069                     }
1070                   else if (strcmp(str, "semicolon") == 0)
1071                     {
1072                        cell                val;
1073
1074                        preproc_expr(&val, NULL);
1075                        sc_needsemicolon = (int)val;
1076                     }
1077                   else if (strcmp(str, "tabsize") == 0)
1078                     {
1079                        cell                val;
1080
1081                        preproc_expr(&val, NULL);
1082                        sc_tabsize = (int)val;
1083                     }
1084                   else if (strcmp(str, "align") == 0)
1085                     {
1086                        sc_alignnext = TRUE;
1087                     }
1088                   else if (strcmp(str, "unused") == 0)
1089                     {
1090                        char                name[sNAMEMAX + 1];
1091                        int                 i, comma;
1092                        symbol             *sym;
1093
1094                        do
1095                          {
1096                             /* get the name */
1097                             while (*lptr <= ' ' && *lptr != '\0')
1098                                lptr++;
1099                             for (i = 0; i < sizeof name && isalpha(*lptr);
1100                                  i++, lptr++)
1101                                name[i] = *lptr;
1102                             name[i] = '\0';
1103                             /* get the symbol */
1104                             sym = findloc(name);
1105                             if (sym == NULL)
1106                                sym = findglb(name);
1107                             if (sym != NULL)
1108                               {
1109                                  sym->usage |= uREAD;
1110                                  if (sym->ident == iVARIABLE
1111                                      || sym->ident == iREFERENCE
1112                                      || sym->ident == iARRAY
1113                                      || sym->ident == iREFARRAY)
1114                                     sym->usage |= uWRITTEN;
1115                               }
1116                             else
1117                               {
1118                                  error(17, name);       /* undefined symbol */
1119                               } /* if */
1120                             /* see if a comma follows the name */
1121                             while (*lptr <= ' ' && *lptr != '\0')
1122                                lptr++;
1123                             comma = (*lptr == ',');
1124                             if (comma)
1125                                lptr++;
1126                          }
1127                        while (comma);
1128                     }
1129                   else
1130                     {
1131                        error(207);      /* unknown #pragma */
1132                     }           /* if */
1133                }
1134              else
1135                {
1136                   error(207);   /* unknown #pragma */
1137                }                /* if */
1138              check_empty(lptr);
1139           }                     /* if */
1140         break;
1141      case tpENDINPUT:
1142      case tpENDSCRPT:
1143         if (skiplevel == 0)
1144           {
1145              check_empty(lptr);
1146              assert(inpf != NULL);
1147              if (inpf != inpf_org)
1148                 sc_closesrc(inpf);
1149              inpf = NULL;
1150           }                     /* if */
1151         break;
1152 #if !defined NOEMIT
1153      case tpEMIT:
1154         {
1155            /* write opcode to output file */
1156            char                name[40];
1157            int                 i;
1158
1159            while (*lptr <= ' ' && *lptr != '\0')
1160               lptr++;
1161            for (i = 0; i < 40 && (isalpha(*lptr) || *lptr == '.'); i++, lptr++)
1162               name[i] = (char)tolower(*lptr);
1163            name[i] = '\0';
1164            stgwrite("\t");
1165            stgwrite(name);
1166            stgwrite(" ");
1167            code_idx += opcodes(1);
1168            /* write parameter (if any) */
1169            while (*lptr <= ' ' && *lptr != '\0')
1170               lptr++;
1171            if (*lptr != '\0')
1172              {
1173                 symbol             *sym;
1174
1175                 tok = lex(&val, &str);
1176                 switch (tok)
1177                   {
1178                   case tNUMBER:
1179                   case tRATIONAL:
1180                      outval(val, FALSE);
1181                      code_idx += opargs(1);
1182                      break;
1183                   case tSYMBOL:
1184                      sym = findloc(str);
1185                      if (sym == NULL)
1186                         sym = findglb(str);
1187                      if (sym == NULL || (sym->ident != iFUNCTN
1188                          && sym->ident != iREFFUNC
1189                          && (sym->usage & uDEFINE) == 0))
1190                        {
1191                           error(17, str);       /* undefined symbol */
1192                        }
1193                      else
1194                        {
1195                           outval(sym->addr, FALSE);
1196                           /* mark symbol as "used", unknown whether for read or write */
1197                           markusage(sym, uREAD | uWRITTEN);
1198                           code_idx += opargs(1);
1199                        }        /* if */
1200                      break;
1201                   default:
1202                      {
1203                         char                s2[20];
1204                         extern char        *sc_tokens[];        /* forward declaration */
1205
1206                         if (tok < 256)
1207                            sprintf(s2, "%c", (char)tok);
1208                         else
1209                            strcpy(s2, sc_tokens[tok - tFIRST]);
1210                         error(1, sc_tokens[tSYMBOL - tFIRST], s2);
1211                         break;
1212                      }          /* case */
1213                   }             /* switch */
1214              }                  /* if */
1215            stgwrite("\n");
1216            check_empty(lptr);
1217            break;
1218         }                       /* case */
1219 #endif
1220 #if !defined NO_DEFINE
1221      case tpDEFINE:
1222         {
1223            ret = CMD_DEFINE;
1224            if (skiplevel == 0)
1225              {
1226                 char               *pattern, *substitution;
1227                 char               *start, *end;
1228                 int                 count, prefixlen;
1229                 stringpair         *def;
1230
1231                 /* find the pattern to match */
1232                 while (*lptr <= ' ' && *lptr != '\0')
1233                    lptr++;
1234                 start = lptr;   /* save starting point of the match pattern */
1235                 count = 0;
1236                 while (*lptr > ' ' && *lptr != '\0')
1237                   {
1238                      litchar(&lptr, FALSE);     /* litchar() advances "lptr" and handles escape characters */
1239                      count++;
1240                   }             /* while */
1241                 end = lptr;
1242                 /* check pattern to match */
1243                 if (!isalpha(*start) && *start != '_')
1244                   {
1245                      error(74); /* pattern must start with an alphabetic character */
1246                      break;
1247                   }             /* if */
1248                 /* store matched pattern */
1249                 pattern = malloc(count + 1);
1250                 if (pattern == NULL)
1251                    error(103);  /* insufficient memory */
1252                 lptr = start;
1253                 count = 0;
1254                 while (lptr != end)
1255                   {
1256                      assert(lptr < end);
1257                      assert(*lptr != '\0');
1258                      pattern[count++] = (char)litchar(&lptr, FALSE);
1259                   }             /* while */
1260                 pattern[count] = '\0';
1261                 /* special case, erase trailing variable, because it could match anything */
1262                 if (count >= 2 && isdigit(pattern[count - 1])
1263                     && pattern[count - 2] == '%')
1264                    pattern[count - 2] = '\0';
1265                 /* find substitution string */
1266                 while (*lptr <= ' ' && *lptr != '\0')
1267                    lptr++;
1268                 start = lptr;   /* save starting point of the match pattern */
1269                 count = 0;
1270                 end = NULL;
1271                 while (*lptr != '\0')
1272                   {
1273                      /* keep position of the start of trailing whitespace */
1274                      if (*lptr <= ' ')
1275                        {
1276                           if (end == NULL)
1277                              end = lptr;
1278                        }
1279                      else
1280                        {
1281                           end = NULL;
1282                        }        /* if */
1283                      count++;
1284                      lptr++;
1285                   }             /* while */
1286                 if (end == NULL)
1287                    end = lptr;
1288                 /* store matched substitution */
1289                 substitution = malloc(count + 1);       /* +1 for '\0' */
1290                 if (substitution == NULL)
1291                    error(103);  /* insufficient memory */
1292                 lptr = start;
1293                 count = 0;
1294                 while (lptr != end)
1295                   {
1296                      assert(lptr < end);
1297                      assert(*lptr != '\0');
1298                      substitution[count++] = *lptr++;
1299                   }             /* while */
1300                 substitution[count] = '\0';
1301                 /* check whether the definition already exists */
1302                 for (prefixlen = 0, start = pattern;
1303                      isalpha(*start) || isdigit(*start) || *start == '_';
1304                      prefixlen++, start++)
1305                    /* nothing */ ;
1306                 assert(prefixlen > 0);
1307                 if ((def = find_subst(pattern, prefixlen)) != NULL)
1308                   {
1309                      if (strcmp(def->first, pattern) != 0
1310                          || strcmp(def->second, substitution) != 0)
1311                         error(201, pattern);    /* redefinition of macro (non-identical) */
1312                      delete_subst(pattern, prefixlen);
1313                   }             /* if */
1314                 /* add the pattern/substitution pair to the list */
1315                 assert(pattern[0] != '\0');
1316                 insert_subst(pattern, substitution, prefixlen);
1317                 free(pattern);
1318                 free(substitution);
1319              }                  /* if */
1320            break;
1321         }                       /* case */
1322      case tpUNDEF:
1323         if (skiplevel == 0)
1324           {
1325              if (lex(&val, &str) == tSYMBOL)
1326                {
1327                   if (!delete_subst(str, strlen(str)))
1328                      error(17, str);    /* undefined symbol */
1329                }
1330              else
1331                {
1332                   error(20, str);       /* invalid symbol name */
1333                }                /* if */
1334              check_empty(lptr);
1335           }                     /* if */
1336         break;
1337 #endif
1338      default:
1339         error(31);              /* unknown compiler directive */
1340         ret = skiplevel > 0 ? CMD_DIRECTIVE : CMD_NONE; /* line must be processed (if skiplevel==0) */
1341      }                          /* switch */
1342    return ret;
1343 }
1344
1345 #if !defined NO_DEFINE
1346 static int
1347 is_startstring(char *string)
1348 {
1349    if (*string == '\"' || *string == '\'')
1350       return TRUE;              /* "..." */
1351
1352    if (*string == '!')
1353      {
1354         string++;
1355         if (*string == '\"' || *string == '\'')
1356            return TRUE;         /* !"..." */
1357         if (*string == sc_ctrlchar)
1358           {
1359              string++;
1360              if (*string == '\"' || *string == '\'')
1361                 return TRUE;    /* !\"..." */
1362           }                     /* if */
1363      }
1364    else if (*string == sc_ctrlchar)
1365      {
1366         string++;
1367         if (*string == '\"' || *string == '\'')
1368            return TRUE;         /* \"..." */
1369         if (*string == '!')
1370           {
1371              string++;
1372              if (*string == '\"' || *string == '\'')
1373                 return TRUE;    /* \!"..." */
1374           }                     /* if */
1375      }                          /* if */
1376
1377    return FALSE;
1378 }
1379
1380 static char        *
1381 skipstring(char *string)
1382 {
1383    char                endquote;
1384    int                 rawstring = FALSE;
1385
1386    while (*string == '!' || *string == sc_ctrlchar)
1387      {
1388         rawstring = (*string == sc_ctrlchar);
1389         string++;
1390      }                          /* while */
1391
1392    endquote = *string;
1393    assert(endquote == '\"' || endquote == '\'');
1394    string++;                    /* skip open quote */
1395    while (*string != endquote && *string != '\0')
1396       litchar(&string, rawstring);
1397    return string;
1398 }
1399
1400 static char        *
1401 skippgroup(char *string)
1402 {
1403    int                 nest = 0;
1404    char                open = *string;
1405    char                close;
1406
1407    switch (open)
1408      {
1409      case '(':
1410         close = ')';
1411         break;
1412      case '{':
1413         close = '}';
1414         break;
1415      case '[':
1416         close = ']';
1417         break;
1418      case '<':
1419         close = '>';
1420         break;
1421      default:
1422         assert(0);
1423         close = '\0';           /* only to avoid a compiler warning */
1424      }                          /* switch */
1425
1426    string++;
1427    while (*string != close || nest > 0)
1428      {
1429         if (*string == open)
1430            nest++;
1431         else if (*string == close)
1432            nest--;
1433         else if (is_startstring(string))
1434            string = skipstring(string);
1435         if (*string == '\0')
1436            break;
1437         string++;
1438      }                          /* while */
1439    return string;
1440 }
1441
1442 static char        *
1443 strdel(char *str, size_t len)
1444 {
1445    size_t              length = strlen(str);
1446
1447    if (len > length)
1448       len = length;
1449    memmove(str, str + len, length - len + 1);   /* include EOS byte */
1450    return str;
1451 }
1452
1453 static char        *
1454 strins(char *dest, char *src, size_t srclen)
1455 {
1456    size_t              destlen = strlen(dest);
1457
1458    assert(srclen <= strlen(src));
1459    memmove(dest + srclen, dest, destlen + 1);   /* include EOS byte */
1460    memcpy(dest, src, srclen);
1461    return dest;
1462 }
1463
1464 static int
1465 substpattern(char *line, size_t buffersize, char *pattern, char *substitution)
1466 {
1467    int                 prefixlen;
1468    char               *p, *s, *e, *args[10];
1469    int                 match, arg, len;
1470
1471    memset(args, 0, sizeof args);
1472
1473    /* check the length of the prefix */
1474    for (prefixlen = 0, s = pattern; isalpha(*s) || isdigit(*s) || *s == '_';
1475         prefixlen++, s++)
1476       /* nothing */ ;
1477    assert(prefixlen > 0);
1478    assert(strncmp(line, pattern, prefixlen) == 0);
1479
1480    /* pattern prefix matches; match the rest of the pattern, gather
1481     * the parameters
1482     */
1483    s = line + prefixlen;
1484    p = pattern + prefixlen;
1485    match = TRUE;                /* so far, pattern matches */
1486    while (match && *s != '\0' && *p != '\0')
1487      {
1488         if (*p == '%')
1489           {
1490              p++;               /* skip '%' */
1491              if (isdigit(*p))
1492                {
1493                   arg = *p - '0';
1494                   assert(arg >= 0 && arg <= 9);
1495                   p++;          /* skip parameter id */
1496                   assert(*p != '\0');
1497                   /* match the source string up to the character after the digit
1498                    * (skipping strings in the process
1499                    */
1500                   e = s;
1501                   while (*e != *p && *e != '\0' && *e != '\n')
1502                     {
1503                        if (is_startstring(e))   /* skip strings */
1504                           e = skipstring(e);
1505                        else if (strchr("({[", *e) != NULL)      /* skip parenthized groups */
1506                           e = skippgroup(e);
1507                        if (*e != '\0')
1508                           e++;  /* skip non-alphapetic character (or closing quote of
1509                                  * a string, or the closing paranthese of a group) */
1510                     }           /* while */
1511                   /* store the parameter (overrule any earlier) */
1512                   if (args[arg] != NULL)
1513                      free(args[arg]);
1514                   len = (int)(e - s);
1515                   args[arg] = malloc(len + 1);
1516                   if (args[arg] == NULL)
1517                      error(103);        /* insufficient memory */
1518                   strncpy(args[arg], s, len);
1519                   args[arg][len] = '\0';
1520                   /* character behind the pattern was matched too */
1521                   if (*e == *p)
1522                     {
1523                        s = e + 1;
1524                     }
1525                   else if (*e == '\n' && *p == ';' && *(p + 1) == '\0'
1526                            && !sc_needsemicolon)
1527                     {
1528                        s = e;   /* allow a trailing ; in the pattern match to end of line */
1529                     }
1530                   else
1531                     {
1532                        assert(*e == '\0' || *e == '\n');
1533                        match = FALSE;
1534                        s = e;
1535                     }           /* if */
1536                   p++;
1537                }
1538              else
1539                {
1540                   match = FALSE;
1541                }                /* if */
1542           }
1543         else if (*p == ';' && *(p + 1) == '\0' && !sc_needsemicolon)
1544           {
1545              /* source may be ';' or end of the line */
1546              while (*s <= ' ' && *s != '\0')
1547                 s++;            /* skip white space */
1548              if (*s != ';' && *s != '\0')
1549                 match = FALSE;
1550              p++;               /* skip the semicolon in the pattern */
1551           }
1552         else
1553           {
1554              cell                ch;
1555
1556              /* skip whitespace between two non-alphanumeric characters, except
1557               * for two identical symbols
1558               */
1559              assert(p > pattern);
1560              if (!alphanum(*p) && *(p - 1) != *p)
1561                 while (*s <= ' ' && *s != '\0')
1562                    s++;         /* skip white space */
1563              ch = litchar(&p, FALSE);   /* this increments "p" */
1564              if (*s != ch)
1565                 match = FALSE;
1566              else
1567                 s++;            /* this character matches */
1568           }                     /* if */
1569      }                          /* while */
1570
1571    if (match && *p == '\0')
1572      {
1573         /* if the last character to match is an alphanumeric character, the
1574          * current character in the source may not be alphanumeric
1575          */
1576         assert(p > pattern);
1577         if (alphanum(*(p - 1)) && alphanum(*s))
1578            match = FALSE;
1579      }                          /* if */
1580
1581    if (match)
1582      {
1583         /* calculate the length of the substituted string */
1584         for (e = substitution, len = 0; *e != '\0'; e++)
1585           {
1586              if (*e == '%' && isdigit(*(e + 1)))
1587                {
1588                   arg = *(e + 1) - '0';
1589                   assert(arg >= 0 && arg <= 9);
1590                   if (args[arg] != NULL)
1591                      len += strlen(args[arg]);
1592                   e++;          /* skip %, digit is skipped later */
1593                }
1594              else
1595                {
1596                   len++;
1597                }                /* if */
1598           }                     /* for */
1599         /* check length of the string after substitution */
1600         if (strlen(line) + len - (int)(s - line) > buffersize)
1601           {
1602              error(75);         /* line too long */
1603           }
1604         else
1605           {
1606              /* substitute pattern */
1607              strdel(line, (int)(s - line));
1608              for (e = substitution, s = line; *e != '\0'; e++)
1609                {
1610                   if (*e == '%' && isdigit(*(e + 1)))
1611                     {
1612                        arg = *(e + 1) - '0';
1613                        assert(arg >= 0 && arg <= 9);
1614                        if (args[arg] != NULL)
1615                          {
1616                             strins(s, args[arg], strlen(args[arg]));
1617                             s += strlen(args[arg]);
1618                          }      /* if */
1619                        e++;     /* skip %, digit is skipped later */
1620                     }
1621                   else
1622                     {
1623                        strins(s, e, 1);
1624                        s++;
1625                     }           /* if */
1626                }                /* for */
1627           }                     /* if */
1628      }                          /* if */
1629
1630    for (arg = 0; arg < 10; arg++)
1631       if (args[arg] != NULL)
1632          free(args[arg]);
1633
1634    return match;
1635 }
1636
1637 static void
1638 substallpatterns(char *line, int buffersize)
1639 {
1640    char               *start, *end;
1641    int                 prefixlen;
1642    stringpair         *subst;
1643
1644    start = line;
1645    while (*start != '\0')
1646      {
1647         /* find the start of a prefix (skip all non-alphabetic characters),
1648          * also skip strings
1649          */
1650         while (!isalpha(*start) && *start != '_' && *start != '\0')
1651           {
1652              /* skip strings */
1653              if (is_startstring(start))
1654                {
1655                   start = skipstring(start);
1656                   if (*start == '\0')
1657                      break;     /* abort loop on error */
1658                }                /* if */
1659              start++;           /* skip non-alphapetic character (or closing quote of a string) */
1660           }                     /* while */
1661         if (*start == '\0')
1662            break;               /* abort loop on error */
1663         /* get the prefix (length), look for a matching definition */
1664         prefixlen = 0;
1665         end = start;
1666         while (isalpha(*end) || isdigit(*end) || *end == '_')
1667           {
1668              prefixlen++;
1669              end++;
1670           }                     /* while */
1671         assert(prefixlen > 0);
1672         subst = find_subst(start, prefixlen);
1673         if (subst != NULL)
1674           {
1675              /* properly match the pattern and substitute */
1676              if (!substpattern
1677                  (start, buffersize - (start - line), subst->first,
1678                   subst->second))
1679                 start = end;    /* match failed, skip this prefix */
1680              /* match succeeded: do not update "start", because the substitution text
1681               * may be matched by other macros
1682               */
1683           }
1684         else
1685           {
1686              start = end;       /* no macro with this prefix, skip this prefix */
1687           }                     /* if */
1688      }                          /* while */
1689 }
1690 #endif
1691
1692 /*  preprocess
1693  *
1694  *  Reads a line by readline() into "pline" and performs basic preprocessing:
1695  *  deleting comments, skipping lines with false "#if.." code and recognizing
1696  *  other compiler directives. There is an indirect recursion: lex() calls
1697  *  preprocess() if a new line must be read, preprocess() calls command(),
1698  *  which at his turn calls lex() to identify the token.
1699  *
1700  *  Global references: lptr     (altered)
1701  *                     pline    (altered)
1702  *                     freading (referred to only)
1703  */
1704 void
1705 preprocess(void)
1706 {
1707    int                 iscommand;
1708
1709    if (!freading)
1710       return;
1711    do
1712      {
1713         readline(pline);
1714         stripcom(pline);        /* ??? no need for this when reading back from list file (in the second pass) */
1715         lptr = pline;           /* set "line pointer" to start of the parsing buffer */
1716         iscommand = command();
1717         if (iscommand != CMD_NONE)
1718            errorset(sRESET);    /* reset error flag ("panic mode") on empty line or directive */
1719 #if !defined NO_DEFINE
1720         if (iscommand == CMD_NONE)
1721           {
1722              assert(lptr != term_expr);
1723              substallpatterns(pline, sLINEMAX);
1724              lptr = pline;      /* reset "line pointer" to start of the parsing buffer */
1725           }                     /* if */
1726 #endif
1727      }
1728    while (iscommand != CMD_NONE && iscommand != CMD_TERM && freading);  /* enddo */
1729 }
1730
1731 static char        *
1732 unpackedstring(char *lptr, int rawstring)
1733 {
1734    while (*lptr != '\0')
1735      {
1736         /* check for doublequotes indicating the end of the string */
1737         if (*lptr == '\"')
1738         {
1739            /* check whether there's another pair of quotes following.
1740             * If so, paste the two strings together, thus
1741             * "pants""off" becomes "pantsoff"
1742             */
1743            if (*(lptr + 1) == '\"')
1744               lptr += 2;
1745            else
1746               break;
1747         }
1748
1749         if (*lptr == '\a')
1750           {                     /* ignore '\a' (which was inserted at a line concatenation) */
1751              lptr++;
1752              continue;
1753           }                     /* if */
1754         stowlit(litchar(&lptr, rawstring));     /* litchar() alters "lptr" */
1755      }                          /* while */
1756    stowlit(0);                  /* terminate string */
1757    return lptr;
1758 }
1759
1760 static char        *
1761 packedstring(char *lptr, int rawstring)
1762 {
1763    int                 i;
1764    ucell               val, c;
1765
1766    i = sizeof(ucell) - (charbits / 8);  /* start at most significant byte */
1767    val = 0;
1768    while (*lptr != '\0')
1769      {
1770         /* check for doublequotes indicating the end of the string */
1771         if (*lptr == '\"')
1772         {
1773            /* check whether there's another pair of quotes following.
1774             * If so, paste the two strings together, thus
1775             * "pants""off" becomes "pantsoff"
1776             */
1777            if (*(lptr + 1) == '\"')
1778               lptr += 2;
1779            else
1780               break;
1781         }
1782
1783         if (*lptr == '\a')
1784           {                     /* ignore '\a' (which was inserted at a line concatenation) */
1785              lptr++;
1786              continue;
1787           }                     /* if */
1788         c = litchar(&lptr, rawstring);  /* litchar() alters "lptr" */
1789         if (c >= (ucell) (1 << charbits))
1790            error(43);           /* character constant exceeds range */
1791         val |= (c << 8 * i);
1792         if (i == 0)
1793           {
1794              stowlit(val);
1795              val = 0;
1796           }                     /* if */
1797         i = (i + sizeof(ucell) - (charbits / 8)) % sizeof(ucell);
1798      }                          /* if */
1799    /* save last code; make sure there is at least one terminating zero character */
1800    if (i != (int)(sizeof(ucell) - (charbits / 8)))
1801       stowlit(val);             /* at least one zero character in "val" */
1802    else
1803       stowlit(0);               /* add full cell of zeros */
1804    return lptr;
1805 }
1806
1807 /*  lex(lexvalue,lexsym)        Lexical Analysis
1808  *
1809  *  lex() first deletes leading white space, then checks for multi-character
1810  *  operators, keywords (including most compiler directives), numbers,
1811  *  labels, symbols and literals (literal characters are converted to a number
1812  *  and are returned as such). If every check fails, the line must contain
1813  *  a single-character operator. So, lex() returns this character. In the other
1814  *  case (something did match), lex() returns the number of the token. All
1815  *  these tokens have been assigned numbers above 255.
1816  *
1817  *  Some tokens have "attributes":
1818  *     tNUMBER        the value of the number is return in "lexvalue".
1819  *     tRATIONAL      the value is in IEEE 754 encoding or in fixed point
1820  *                    encoding in "lexvalue".
1821  *     tSYMBOL        the first sNAMEMAX characters of the symbol are
1822  *                    stored in a buffer, a pointer to this buffer is
1823  *                    returned in "lexsym".
1824  *     tLABEL         the first sNAMEMAX characters of the label are
1825  *                    stored in a buffer, a pointer to this buffer is
1826  *                    returned in "lexsym".
1827  *     tSTRING        the string is stored in the literal pool, the index
1828  *                    in the literal pool to this string is stored in
1829  *                    "lexvalue".
1830  *
1831  *  lex() stores all information (the token found and possibly its attribute)
1832  *  in global variables. This allows a token to be examined twice. If "_pushed"
1833  *  is true, this information is returned.
1834  *
1835  *  Global references: lptr          (altered)
1836  *                     fline         (referred to only)
1837  *                     litidx        (referred to only)
1838  *                     _lextok, _lexval, _lexstr
1839  *                     _pushed
1840  */
1841
1842 static int          _pushed;
1843 static int          _lextok;
1844 static cell         _lexval;
1845 static char         _lexstr[sLINEMAX + 1];
1846 static int          _lexnewline;
1847
1848 void
1849 lexinit(void)
1850 {
1851    stkidx = 0;                  /* index for pushstk() and popstk() */
1852    iflevel = 0;                 /* preprocessor: nesting of "#if" */
1853    skiplevel = 0;               /* preprocessor: skipping lines or compiling lines */
1854    icomment = FALSE;            /* currently not in a multiline comment */
1855    _pushed = FALSE;             /* no token pushed back into lex */
1856    _lexnewline = FALSE;
1857 }
1858
1859 char               *sc_tokens[] = {
1860    "*=", "/=", "%=", "+=", "-=", "<<=", ">>>=", ">>=", "&=", "^=", "|=",
1861    "||", "&&", "==", "!=", "<=", ">=", "<<", ">>>", ">>", "++", "--",
1862    "...", "..",
1863    "assert", "break", "case", "char", "const", "continue", "default",
1864    "defined", "do", "else", "enum", "exit", "for", "forward", "goto",
1865    "if", "native", "new", "operator", "public", "return", "sizeof",
1866    "sleep", "static", "stock", "switch", "tagof", "while",
1867    "#assert", "#define", "#else", "#emit", "#endif", "#endinput",
1868    "#endscript", "#file", "#if", "#include", "#line", "#pragma", "#undef",
1869    ";", ";", "-integer value-", "-rational value-", "-identifier-",
1870    "-label-", "-string-"
1871 };
1872
1873 int
1874 lex(cell * lexvalue, char **lexsym)
1875 {
1876    int                 i, toolong, newline, rawstring;
1877    char              **tokptr;
1878
1879    if (_pushed)
1880      {
1881         _pushed = FALSE;        /* reset "_pushed" flag */
1882         *lexvalue = _lexval;
1883         *lexsym = _lexstr;
1884         return _lextok;
1885      }                          /* if */
1886
1887    _lextok = 0;                 /* preset all values */
1888    _lexval = 0;
1889    _lexstr[0] = '\0';
1890    *lexvalue = _lexval;
1891    *lexsym = _lexstr;
1892    _lexnewline = FALSE;
1893    if (!freading)
1894       return 0;
1895
1896    newline = (lptr == pline);   /* does lptr point to start of line buffer */
1897    while (*lptr <= ' ')
1898      {                          /* delete leading white space */
1899         if (*lptr == '\0')
1900           {
1901              preprocess();      /* preprocess resets "lptr" */
1902              if (!freading)
1903                 return 0;
1904              if (lptr == term_expr)     /* special sequence to terminate a pending expression */
1905                 return (_lextok = tENDEXPR);
1906              _lexnewline = TRUE;        /* set this after preprocess(), because
1907                                          * preprocess() calls lex() recursively */
1908              newline = TRUE;
1909           }
1910         else
1911           {
1912              lptr += 1;
1913           }                     /* if */
1914      }                          /* while */
1915    if (newline)
1916      {
1917         stmtindent = 0;
1918         for (i = 0; i < (int)(lptr - pline); i++)
1919            if (pline[i] == '\t' && sc_tabsize > 0)
1920               stmtindent +=
1921                  (int)(sc_tabsize - (stmtindent + sc_tabsize) % sc_tabsize);
1922            else
1923               stmtindent++;
1924      }                          /* if */
1925
1926    i = tFIRST;
1927    tokptr = sc_tokens;
1928    while (i <= tMIDDLE)
1929      {                          /* match multi-character operators */
1930         if (match(*tokptr, FALSE))
1931           {
1932              _lextok = i;
1933              return _lextok;
1934           }                     /* if */
1935         i += 1;
1936         tokptr += 1;
1937      }                          /* while */
1938    while (i <= tLAST)
1939      {                          /* match reserved words and compiler directives */
1940         if (match(*tokptr, TRUE))
1941           {
1942              _lextok = i;
1943              errorset(sRESET);  /* reset error flag (clear the "panic mode") */
1944              return _lextok;
1945           }                     /* if */
1946         i += 1;
1947         tokptr += 1;
1948      }                          /* while */
1949
1950    if ((i = number(&_lexval, lptr)) != 0)
1951      {                          /* number */
1952         _lextok = tNUMBER;
1953         *lexvalue = _lexval;
1954         lptr += i;
1955      }
1956    else if ((i = ftoi(&_lexval, lptr)) != 0)
1957      {
1958         _lextok = tRATIONAL;
1959         *lexvalue = _lexval;
1960         lptr += i;
1961      }
1962    else if (alpha(*lptr))
1963      {                          /* symbol or label */
1964         /*  Note: only sNAMEMAX characters are significant. The compiler
1965          *        generates a warning if a symbol exceeds this length.
1966          */
1967         _lextok = tSYMBOL;
1968         i = 0;
1969         toolong = 0;
1970         while (alphanum(*lptr))
1971           {
1972              _lexstr[i] = *lptr;
1973              lptr += 1;
1974              if (i < sNAMEMAX)
1975                 i += 1;
1976              else
1977                 toolong = 1;
1978           }                     /* while */
1979         _lexstr[i] = '\0';
1980         if (toolong)
1981            error(200, _lexstr, sNAMEMAX);       /* symbol too long, truncated to sNAMEMAX chars */
1982         if (_lexstr[0] == PUBLIC_CHAR && _lexstr[1] == '\0')
1983           {
1984              _lextok = PUBLIC_CHAR;     /* '@' all alone is not a symbol, it is an operator */
1985           }
1986         else if (_lexstr[0] == '_' && _lexstr[1] == '\0')
1987           {
1988              _lextok = '_';     /* '_' by itself is not a symbol, it is a placeholder */
1989           }                     /* if */
1990         if (*lptr == ':' && sc_allowtags && _lextok != PUBLIC_CHAR)
1991           {
1992              _lextok = tLABEL;  /* it wasn't a normal symbol, it was a label/tagname */
1993              lptr += 1;         /* skip colon */
1994           }                     /* if */
1995      }
1996    else if (*lptr == '\"' || (*lptr == sc_ctrlchar && *(lptr + 1) == '\"'))
1997      {                          /* unpacked string literal */
1998         _lextok = tSTRING;
1999         rawstring = (*lptr == sc_ctrlchar);
2000         *lexvalue = _lexval = litidx;
2001         lptr += 1;              /* skip double quote */
2002         if (rawstring)
2003            lptr += 1;           /* skip "escape" character too */
2004         lptr =
2005            sc_packstr ? packedstring(lptr, rawstring) : unpackedstring(lptr,
2006                                                                        rawstring);
2007         if (*lptr == '\"')
2008            lptr += 1;           /* skip final quote */
2009         else
2010            error(37);           /* invalid (non-terminated) string */
2011      }
2012    else if ((*lptr == '!' && *(lptr + 1) == '\"')
2013             || (*lptr == '!' && *(lptr + 1) == sc_ctrlchar && *(lptr + 2) == '\"')
2014             || (*lptr == sc_ctrlchar && *(lptr + 1) == '!'
2015             && *(lptr + 2) == '\"'))
2016      {                          /* packed string literal */
2017         _lextok = tSTRING;
2018         rawstring = (*lptr == sc_ctrlchar || *(lptr + 1) == sc_ctrlchar);
2019         *lexvalue = _lexval = litidx;
2020         lptr += 2;              /* skip exclamation point and double quote */
2021         if (rawstring)
2022            lptr += 1;           /* skip "escape" character too */
2023         lptr =
2024            sc_packstr ? unpackedstring(lptr, rawstring) : packedstring(lptr,
2025                                                                        rawstring);
2026         if (*lptr == '\"')
2027            lptr += 1;           /* skip final quote */
2028         else
2029            error(37);           /* invalid (non-terminated) string */
2030      }
2031    else if (*lptr == '\'')
2032      {                          /* character literal */
2033         lptr += 1;              /* skip quote */
2034         _lextok = tNUMBER;
2035         *lexvalue = _lexval = litchar(&lptr, FALSE);
2036         if (*lptr == '\'')
2037            lptr += 1;           /* skip final quote */
2038         else
2039            error(27);           /* invalid character constant (must be one character) */
2040      }
2041    else if (*lptr == ';')
2042      {                          /* semicolumn resets "error" flag */
2043         _lextok = ';';
2044         lptr += 1;
2045         errorset(sRESET);       /* reset error flag (clear the "panic mode") */
2046      }
2047    else
2048      {
2049         _lextok = *lptr;        /* if every match fails, return the character */
2050         lptr += 1;              /* increase the "lptr" pointer */
2051      }                          /* if */
2052    return _lextok;
2053 }
2054
2055 /*  lexpush
2056  *
2057  *  Pushes a token back, so the next call to lex() will return the token
2058  *  last examined, instead of a new token.
2059  *
2060  *  Only one token can be pushed back.
2061  *
2062  *  In fact, lex() already stores the information it finds into global
2063  *  variables, so all that is to be done is set a flag that informs lex()
2064  *  to read and return the information from these variables, rather than
2065  *  to read in a new token from the input file.
2066  */
2067 void
2068 lexpush(void)
2069 {
2070    assert(_pushed == FALSE);
2071    _pushed = TRUE;
2072 }
2073
2074 /*  lexclr
2075  *
2076  *  Sets the variable "_pushed" to 0 to make sure lex() will read in a new
2077  *  symbol (a not continue with some old one). This is required upon return
2078  *  from Assembler mode.
2079  */
2080 void
2081 lexclr(int clreol)
2082 {
2083    _pushed = FALSE;
2084    if (clreol)
2085      {
2086         lptr = strchr(pline, '\0');
2087         assert(lptr != NULL);
2088      }                          /* if */
2089 }
2090
2091 /*  matchtoken
2092  *
2093  *  This routine is useful if only a simple check is needed. If the token
2094  *  differs from the one expected, it is pushed back.
2095  */
2096 int
2097 matchtoken(int token)
2098 {
2099    cell                val;
2100    char               *str;
2101    int                 tok;
2102
2103    tok = lex(&val, &str);
2104    if (tok == token || (token == tTERM && (tok == ';' || tok == tENDEXPR)))
2105      {
2106         return 1;
2107      }
2108    else if (!sc_needsemicolon && token == tTERM && (_lexnewline || !freading))
2109      {
2110         lexpush();              /* push "tok" back, we use the "hidden" newline token */
2111         return 1;
2112      }
2113    else
2114      {
2115         lexpush();
2116         return 0;
2117      }                          /* if */
2118 }
2119
2120 /*  tokeninfo
2121  *
2122  *  Returns additional information of a token after using "matchtoken()"
2123  *  or needtoken(). It does no harm using this routine after a call to
2124  *  "lex()", but lex() already returns the same information.
2125  *
2126  *  The token itself is the return value. Normally, this one is already known.
2127  */
2128 int
2129 tokeninfo(cell * val, char **str)
2130 {
2131    /* if the token was pushed back, tokeninfo() returns the token and
2132     * parameters of the *next* token, not of the *current* token.
2133     */
2134    assert(!_pushed);
2135    *val = _lexval;
2136    *str = _lexstr;
2137    return _lextok;
2138 }
2139
2140 /*  needtoken
2141  *
2142  *  This routine checks for a required token and gives an error message if
2143  *  it isn't there (and returns FALSE in that case).
2144  *
2145  *  Global references: _lextok;
2146  */
2147 int
2148 needtoken(int token)
2149 {
2150    char                s1[20], s2[20];
2151
2152    if (matchtoken(token))
2153      {
2154         return TRUE;
2155      }
2156    else
2157      {
2158         /* token already pushed back */
2159         assert(_pushed);
2160         if (token < 256)
2161            sprintf(s1, "%c", (char)token);      /* single character token */
2162         else
2163            strcpy(s1, sc_tokens[token - tFIRST]);       /* multi-character symbol */
2164         if (!freading)
2165            strcpy(s2, "-end of file-");
2166         else if (_lextok < 256)
2167            sprintf(s2, "%c", (char)_lextok);
2168         else
2169            strcpy(s2, sc_tokens[_lextok - tFIRST]);
2170         error(1, s1, s2);       /* expected ..., but found ... */
2171         return FALSE;
2172      }                          /* if */
2173 }
2174
2175 /*  match
2176  *
2177  *  Compares a series of characters from the input file with the characters
2178  *  in "st" (that contains a token). If the token on the input file matches
2179  *  "st", the input file pointer "lptr" is adjusted to point to the next
2180  *  token, otherwise "lptr" remains unaltered.
2181  *
2182  *  If the parameter "end: is true, match() requires that the first character
2183  *  behind the recognized token is non-alphanumeric.
2184  *
2185  *  Global references: lptr   (altered)
2186  */
2187 static int
2188 match(char *st, int end)
2189 {
2190    int                 k;
2191    char               *ptr;
2192
2193    k = 0;
2194    ptr = lptr;
2195    while (st[k])
2196      {
2197         if (st[k] != *ptr)
2198            return 0;
2199         k += 1;
2200         ptr += 1;
2201      }                          /* while */
2202    if (end)
2203      {                          /* symbol must terminate with non-alphanumeric char */
2204         if (alphanum(*ptr))
2205            return 0;
2206      }                          /* if */
2207    lptr = ptr;                  /* match found, skip symbol */
2208    return 1;
2209 }
2210
2211 /*  stowlit
2212  *
2213  *  Stores a value into the literal queue. The literal queue is used for
2214  *  literal strings used in functions and for initializing array variables.
2215  *
2216  *  Global references: litidx  (altered)
2217  *                     litq    (altered)
2218  */
2219 void
2220 stowlit(cell value)
2221 {
2222    if (litidx >= litmax)
2223      {
2224         cell               *p;
2225
2226         litmax += sDEF_LITMAX;
2227         p = (cell *) realloc(litq, litmax * sizeof(cell));
2228         if (p == NULL)
2229            error(102, "literal table"); /* literal table overflow (fatal error) */
2230         litq = p;
2231      }                          /* if */
2232    assert(litidx < litmax);
2233    litq[litidx++] = value;
2234 }
2235
2236 /*  litchar
2237  *
2238  *  Return current literal character and increase the pointer to point
2239  *  just behind this literal character.
2240  *
2241  *  Note: standard "escape sequences" are suported, but the backslash may be
2242  *        replaced by another character; the syntax '\ddd' is supported,
2243  *        but ddd must be decimal!
2244  */
2245 static cell
2246 litchar(char **lptr, int rawmode)
2247 {
2248    cell                c = 0;
2249    unsigned char      *cptr;
2250
2251    cptr = (unsigned char *)*lptr;
2252    if (rawmode || *cptr != sc_ctrlchar)
2253      {                          /* no escape character */
2254         c = *cptr;
2255         cptr += 1;
2256      }
2257    else
2258      {
2259         cptr += 1;
2260         if (*cptr == sc_ctrlchar)
2261           {
2262              c = *cptr;         /* \\ == \ (the escape character itself) */
2263              cptr += 1;
2264           }
2265         else
2266           {
2267              switch (*cptr)
2268                {
2269                case 'a':        /* \a == audible alarm */
2270                   c = 7;
2271                   cptr += 1;
2272                   break;
2273                case 'b':        /* \b == backspace */
2274                   c = 8;
2275                   cptr += 1;
2276                   break;
2277                case 'e':        /* \e == escape */
2278                   c = 27;
2279                   cptr += 1;
2280                   break;
2281                case 'f':        /* \f == form feed */
2282                   c = 12;
2283                   cptr += 1;
2284                   break;
2285                case 'n':        /* \n == NewLine character */
2286                   c = 10;
2287                   cptr += 1;
2288                   break;
2289                case 'r':        /* \r == carriage return */
2290                   c = 13;
2291                   cptr += 1;
2292                   break;
2293                case 't':        /* \t == horizontal TAB */
2294                   c = 9;
2295                   cptr += 1;
2296                   break;
2297                case 'v':        /* \v == vertical TAB */
2298                   c = 11;
2299                   cptr += 1;
2300                   break;
2301                case '\'':       /* \' == ' (single quote) */
2302                case '"':        /* \" == " (single quote) */
2303                case '%':        /* \% == % (percent) */
2304                   c = *cptr;
2305                   cptr += 1;
2306                   break;
2307                default:
2308                   if (isdigit(*cptr))
2309                     {           /* \ddd */
2310                        c = 0;
2311                        while (*cptr >= '0' && *cptr <= '9')     /* decimal! */
2312                           c = c * 10 + *cptr++ - '0';
2313                        if (*cptr == ';')
2314                           cptr++;       /* swallow a trailing ';' */
2315                     }
2316                   else
2317                     {
2318                        error(27);       /* invalid character constant */
2319                     }           /* if */
2320                }                /* switch */
2321           }                     /* if */
2322      }                          /* if */
2323    *lptr = (char *)cptr;
2324    assert(c >= 0 && c < 256);
2325    return c;
2326 }
2327
2328 /*  alpha
2329  *
2330  *  Test if character "c" is alphabetic ("a".."z"), an underscore ("_")
2331  *  or an "at" sign ("@"). The "@" is an extension to standard C.
2332  */
2333 static int
2334 alpha(char c)
2335 {
2336    return (isalpha(c) || c == '_' || c == PUBLIC_CHAR);
2337 }
2338
2339 /*  alphanum
2340  *
2341  *  Test if character "c" is alphanumeric ("a".."z", "0".."9", "_" or "@")
2342  */
2343 int
2344 alphanum(char c)
2345 {
2346    return (alpha(c) || isdigit(c));
2347 }
2348
2349 /* The local variable table must be searched backwards, so that the deepest
2350  * nesting of local variables is searched first. The simplest way to do
2351  * this is to insert all new items at the head of the list.
2352  * In the global list, the symbols are kept in sorted order, so that the
2353  * public functions are written in sorted order.
2354  */
2355 static symbol      *
2356 add_symbol(symbol * root, symbol * entry, int sort)
2357 {
2358    symbol             *newsym;
2359
2360    if (sort)
2361       while (root->next != NULL && strcmp(entry->name, root->next->name) > 0)
2362          root = root->next;
2363
2364    if ((newsym = (symbol *) malloc(sizeof(symbol))) == NULL)
2365      {
2366         error(103);
2367         return NULL;
2368      }                          /* if */
2369    memcpy(newsym, entry, sizeof(symbol));
2370    newsym->next = root->next;
2371    root->next = newsym;
2372    return newsym;
2373 }
2374
2375 static void
2376 free_symbol(symbol * sym)
2377 {
2378    arginfo            *arg;
2379
2380    /* free all sub-symbol allocated memory blocks, depending on the
2381     * kind of the symbol
2382     */
2383    assert(sym != NULL);
2384    if (sym->ident == iFUNCTN)
2385      {
2386         /* run through the argument list; "default array" arguments
2387          * must be freed explicitly; the tag list must also be freed */
2388         assert(sym->dim.arglist != NULL);
2389         for (arg = sym->dim.arglist; arg->ident != 0; arg++)
2390           {
2391              if (arg->ident == iREFARRAY && arg->hasdefault)
2392                 free(arg->defvalue.array.data);
2393              else if (arg->ident == iVARIABLE
2394                       && ((arg->hasdefault & uSIZEOF) != 0
2395                           || (arg->hasdefault & uTAGOF) != 0))
2396                 free(arg->defvalue.size.symname);
2397              assert(arg->tags != NULL);
2398              free(arg->tags);
2399           }                     /* for */
2400         free(sym->dim.arglist);
2401      }                          /* if */
2402    assert(sym->refer != NULL);
2403    free(sym->refer);
2404    free(sym);
2405 }
2406
2407 void
2408 delete_symbol(symbol * root, symbol * sym)
2409 {
2410    /* find the symbol and its predecessor
2411     * (this function assumes that you will never delete a symbol that is not
2412     * in the table pointed at by "root")
2413     */
2414    assert(root != sym);
2415    while (root->next != sym)
2416      {
2417         root = root->next;
2418         assert(root != NULL);
2419      }                          /* while */
2420
2421    /* unlink it, then free it */
2422    root->next = sym->next;
2423    free_symbol(sym);
2424 }
2425
2426 void
2427 delete_symbols(symbol * root, int level, int delete_labels,
2428                int delete_functions)
2429 {
2430    symbol             *sym;
2431
2432    /* erase only the symbols with a deeper nesting level than the
2433     * specified nesting level */
2434    while (root->next != NULL)
2435      {
2436         sym = root->next;
2437         if (sym->compound < level)
2438            break;
2439         if ((delete_labels || sym->ident != iLABEL)
2440             && (delete_functions || sym->ident != iFUNCTN
2441                 || (sym->usage & uNATIVE) != 0) && (delete_functions
2442                                                     || sym->ident != iCONSTEXPR
2443                                                     || (sym->usage & uPREDEF) ==
2444                                                     0) && (delete_functions
2445                                                            || (sym->ident !=
2446                                                                iVARIABLE
2447                                                                && sym->ident !=
2448                                                                iARRAY)))
2449           {
2450              root->next = sym->next;
2451              free_symbol(sym);
2452           }
2453         else
2454           {
2455              /* if the function was prototyped, but not implemented in this source,
2456               * mark it as such, so that its use can be flagged
2457               */
2458              if (sym->ident == iFUNCTN && (sym->usage & uDEFINE) == 0)
2459                 sym->usage |= uMISSING;
2460              if (sym->ident == iFUNCTN || sym->ident == iVARIABLE
2461                  || sym->ident == iARRAY)
2462                 sym->usage &= ~uDEFINE; /* clear "defined" flag */
2463              /* for user defined operators, also remove the "prototyped" flag, as
2464               * user-defined operators *must* be declared before use
2465               */
2466              if (sym->ident == iFUNCTN && !isalpha(*sym->name)
2467                  && *sym->name != '_' && *sym->name != PUBLIC_CHAR)
2468                 sym->usage &= ~uPROTOTYPED;
2469              root = sym;        /* skip the symbol */
2470           }                     /* if */
2471      }                          /* if */
2472 }
2473
2474 /* The purpose of the hash is to reduce the frequency of a "name"
2475  * comparison (which is costly). There is little interest in avoiding
2476  * clusters in similar names, which is why this function is plain simple.
2477  */
2478 unsigned int
2479 namehash(char *name)
2480 {
2481    unsigned char      *ptr = (unsigned char *)name;
2482    int                 len = strlen(name);
2483
2484    if (len == 0)
2485       return 0L;
2486    assert(len < 256);
2487    return (len << 24Lu) + (ptr[0] << 16Lu) + (ptr[len - 1] << 8Lu) +
2488       (ptr[len >> 1Lu]);
2489 }
2490
2491 static symbol      *
2492 find_symbol(symbol * root, char *name, int fnumber)
2493 {
2494    symbol             *ptr = root->next;
2495    unsigned long       hash = namehash(name);
2496
2497    while (ptr != NULL)
2498      {
2499         if (hash == ptr->hash && strcmp(name, ptr->name) == 0
2500             && ptr->parent == NULL && (ptr->fnumber < 0
2501                                        || ptr->fnumber == fnumber))
2502            return ptr;
2503         ptr = ptr->next;
2504      }                          /* while */
2505    return NULL;
2506 }
2507
2508 static symbol      *
2509 find_symbol_child(symbol * root, symbol * sym)
2510 {
2511    symbol             *ptr = root->next;
2512
2513    while (ptr != NULL)
2514      {
2515         if (ptr->parent == sym)
2516            return ptr;
2517         ptr = ptr->next;
2518      }                          /* while */
2519    return NULL;
2520 }
2521
2522 /* Adds "bywhom" to the list of referrers of "entry". Typically,
2523  * bywhom will be the function that uses a variable or that calls
2524  * the function.
2525  */
2526 int
2527 refer_symbol(symbol * entry, symbol * bywhom)
2528 {
2529    int                 count;
2530
2531    assert(bywhom != NULL);      /* it makes no sense to add a "void" referrer */
2532    assert(entry != NULL);
2533    assert(entry->refer != NULL);
2534
2535    /* see if it is already there */
2536    for (count = 0; count < entry->numrefers && entry->refer[count] != bywhom;
2537         count++)
2538       /* nothing */ ;
2539    if (count < entry->numrefers)
2540      {
2541         assert(entry->refer[count] == bywhom);
2542         return TRUE;
2543      }                          /* if */
2544
2545    /* see if there is an empty spot in the referrer list */
2546    for (count = 0; count < entry->numrefers && entry->refer[count] != NULL;
2547         count++)
2548       /* nothing */ ;
2549    assert(count <= entry->numrefers);
2550    if (count == entry->numrefers)
2551      {
2552         symbol            **refer;
2553         int                 newsize = 2 * entry->numrefers;
2554
2555         assert(newsize > 0);
2556         /* grow the referrer list */
2557         refer = (symbol **) realloc(entry->refer, newsize * sizeof(symbol *));
2558         if (refer == NULL)
2559            return FALSE;        /* insufficient memory */
2560         /* initialize the new entries */
2561         entry->refer = refer;
2562         for (count = entry->numrefers; count < newsize; count++)
2563            entry->refer[count] = NULL;
2564         count = entry->numrefers;       /* first empty spot */
2565         entry->numrefers = newsize;
2566      }                          /* if */
2567
2568    /* add the referrer */
2569    assert(entry->refer[count] == NULL);
2570    entry->refer[count] = bywhom;
2571    return TRUE;
2572 }
2573
2574 void
2575 markusage(symbol * sym, int usage)
2576 {
2577    sym->usage |= (char)usage;
2578    /* check if (global) reference must be added to the symbol */
2579    if ((usage & (uREAD | uWRITTEN)) != 0)
2580      {
2581         /* only do this for global symbols */
2582         if (sym->vclass == sGLOBAL)
2583           {
2584              /* "curfunc" should always be valid, since statements may not occurs
2585               * outside functions; in the case of syntax errors, however, the
2586               * compiler may arrive through this function
2587               */
2588              if (curfunc != NULL)
2589                 refer_symbol(sym, curfunc);
2590           }                     /* if */
2591      }                          /* if */
2592 }
2593
2594 /*  findglb
2595  *
2596  *  Returns a pointer to the global symbol (if found) or NULL (if not found)
2597  */
2598 symbol     *
2599 findglb(char *name)
2600 {
2601    return find_symbol(&glbtab, name, fcurrent);
2602 }
2603
2604 /*  findloc
2605  *
2606  *  Returns a pointer to the local symbol (if found) or NULL (if not found).
2607  *  See add_symbol() how the deepest nesting level is searched first.
2608  */
2609 symbol     *
2610 findloc(char *name)
2611 {
2612    return find_symbol(&loctab, name, -1);
2613 }
2614
2615 symbol     *
2616 findconst(char *name)
2617 {
2618    symbol             *sym;
2619
2620    sym = find_symbol(&loctab, name, -1);        /* try local symbols first */
2621    if (sym == NULL || sym->ident != iCONSTEXPR) /* not found, or not a constant */
2622       sym = find_symbol(&glbtab, name, fcurrent);
2623    if (sym == NULL || sym->ident != iCONSTEXPR)
2624       return NULL;
2625    assert(sym->parent == NULL); /* constants have no hierarchy */
2626    return sym;
2627 }
2628
2629 symbol     *
2630 finddepend(symbol * parent)
2631 {
2632    symbol             *sym;
2633
2634    sym = find_symbol_child(&loctab, parent);    /* try local symbols first */
2635    if (sym == NULL)             /* not found */
2636       sym = find_symbol_child(&glbtab, parent);
2637    return sym;
2638 }
2639
2640 /*  addsym
2641  *
2642  *  Adds a symbol to the symbol table (either global or local variables,
2643  *  or global and local constants).
2644  */
2645 symbol     *
2646 addsym(char *name, cell addr, int ident, int vclass, int tag, int usage)
2647 {
2648    symbol              entry, **refer;
2649
2650    /* global variables/constants/functions may only be defined once */
2651    assert(!(ident == iFUNCTN || ident == iCONSTEXPR) || vclass != sGLOBAL
2652           || findglb(name) == NULL);
2653    /* labels may only be defined once */
2654    assert(ident != iLABEL || findloc(name) == NULL);
2655
2656    /* create an empty referrer list */
2657    if ((refer = (symbol **) malloc(sizeof(symbol *))) == NULL)
2658      {
2659         error(103);             /* insufficient memory */
2660         return NULL;
2661      }                          /* if */
2662    *refer = NULL;
2663
2664    /* first fill in the entry */
2665    strcpy(entry.name, name);
2666    entry.hash = namehash(name);
2667    entry.addr = addr;
2668    entry.vclass = (char)vclass;
2669    entry.ident = (char)ident;
2670    entry.tag = tag;
2671    entry.usage = (char)usage;
2672    entry.compound = 0;          /* may be overridden later */
2673    entry.fnumber = -1;          /* assume global visibility (ignored for local symbols) */
2674    entry.numrefers = 1;
2675    entry.refer = refer;
2676    entry.parent = NULL;
2677
2678    /* then insert it in the list */
2679    if (vclass == sGLOBAL)
2680       return add_symbol(&glbtab, &entry, TRUE);
2681    else
2682       return add_symbol(&loctab, &entry, FALSE);
2683 }
2684
2685 symbol     *
2686 addvariable(char *name, cell addr, int ident, int vclass, int tag,
2687             int dim[], int numdim, int idxtag[])
2688 {
2689    symbol             *sym, *parent, *top;
2690    int                 level;
2691
2692    /* global variables may only be defined once */
2693    assert(vclass != sGLOBAL || (sym = findglb(name)) == NULL
2694           || (sym->usage & uDEFINE) == 0);
2695
2696    if (ident == iARRAY || ident == iREFARRAY)
2697      {
2698         parent = NULL;
2699         sym = NULL;             /* to avoid a compiler warning */
2700         for (level = 0; level < numdim; level++)
2701           {
2702              top = addsym(name, addr, ident, vclass, tag, uDEFINE);
2703              top->dim.array.length = dim[level];
2704              top->dim.array.level = (short)(numdim - level - 1);
2705              top->x.idxtag = idxtag[level];
2706              top->parent = parent;
2707              parent = top;
2708              if (level == 0)
2709                 sym = top;
2710           }                     /* for */
2711      }
2712    else
2713      {
2714         sym = addsym(name, addr, ident, vclass, tag, uDEFINE);
2715      }                          /* if */
2716    return sym;
2717 }
2718
2719 /*  getlabel
2720  *
2721  *  Return next available internal label number.
2722  */
2723 int
2724 getlabel(void)
2725 {
2726    return labnum++;
2727 }
2728
2729 /*  itoh
2730  *
2731  *  Converts a number to a hexadecimal string and returns a pointer to that
2732  *  string.
2733  */
2734 char       *
2735 itoh(ucell val)
2736 {
2737    static char         itohstr[15];     /* hex number is 10 characters long at most */
2738    char               *ptr;
2739    int                 i, nibble[8];    /* a 32-bit hexadecimal cell has 8 nibbles */
2740    int                 max;
2741
2742 #if defined(BIT16)
2743    max = 4;
2744 #else
2745    max = 8;
2746 #endif
2747    ptr = itohstr;
2748    for (i = 0; i < max; i += 1)
2749      {
2750         nibble[i] = (int)(val & 0x0f);  /* nibble 0 is lowest nibble */
2751         val >>= 4;
2752      }                          /* endfor */
2753    i = max - 1;
2754    while (nibble[i] == 0 && i > 0)      /* search for highest non-zero nibble */
2755       i -= 1;
2756    while (i >= 0)
2757      {
2758         if (nibble[i] >= 10)
2759            *ptr++ = (char)('a' + (nibble[i] - 10));
2760         else
2761            *ptr++ = (char)('0' + nibble[i]);
2762         i -= 1;
2763      }                          /* while */
2764    *ptr = '\0';                 /* and a zero-terminator */
2765    return itohstr;
2766 }