src/bin/embryo_cc_sc2.c

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