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