mobile/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 (!sc_isdigit(*ptr))               /* should start with digit */
 447       return 0;
 448    while (sc_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 == '.' && sc_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 (!sc_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 (sc_isxdigit(*ptr) || *ptr == '_')
 480           {
 481              if (*ptr != '_')
 482                {
 483                   assert(sc_isxdigit(*ptr));
 484                   *val = *val << 4;
 485                   if (sc_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 (!sc_isdigit(*ptr))               /* should start with digit */
 558       return 0;
 559    while (sc_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 (!sc_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 (sc_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 (!sc_isdigit(*ptr))  /* 'e' should be followed by a digit */
 609            return 0;
 610         exp = 0;
 611         while (sc_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                 idx;
 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(&idx, &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)
 759 {
 760    assert(dest != NULL);
 761    *dest = '\0';
 762    while (*lptr <= ' ' && *lptr != '\0')
 763       lptr++;                   /* skip whitespace */
 764    if (*lptr != '"')
 765      {
 766         error(37);              /* invalid string */
 767      }
 768    else
 769      {
 770         int                 len = 0;
 771
 772         lptr++;                 /* skip " */
 773         while (*lptr != '"' && *lptr != '\0')
 774           {
 775              if (len < max - 1)
 776                 dest[len++] = *lptr;
 777              lptr++;
 778           }                     /* if */
 779         dest[len] = '\0';
 780         if (*lptr == '"')
 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                 idx;
 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(&idx, &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);
 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
 946              while (*lptr == ' ' && *lptr != '\0')
 947                 lptr++;                 /* skip whitespace */
 948              if (*lptr == '"')
 949                {
 950                   char pathname[PATH_MAX];
 951
 952                   lptr = getstring(pathname, sizeof pathname);
 953                   if (pathname[0] != '\0')
 954                     {
 955                        free(inpfname);
 956                        inpfname = strdup(pathname);
 957                        if (!inpfname)
 958                           error(103);   /* insufficient memory */
 959                     }           /* if */
 960                }
 961           }                     /* if */
 962         check_empty(lptr);
 963         break;
 964      case tpASSERT:
 965         if (skiplevel == 0 && (sc_debug & sCHKBOUNDS) != 0)
 966           {
 967              preproc_expr(&val, NULL);  /* get constant expression (or 0 on error) */
 968              if (!val)
 969                 error(7);       /* assertion failed */
 970              check_empty(lptr);
 971           }                     /* if */
 972         break;
 973      case tpPRAGMA:
 974         if (skiplevel == 0)
 975           {
 976              if (lex(&val, &str) == tSYMBOL)
 977                {
 978                   if (strcmp(str, "ctrlchar") == 0)
 979                     {
 980                        if (lex(&val, &str) != tNUMBER)
 981                           error(27);    /* invalid character constant */
 982                        sc_ctrlchar = (char)val;
 983                     }
 984                   else if (strcmp(str, "compress") == 0)
 985                     {
 986                        cell                val;
 987
 988                        preproc_expr(&val, NULL);
 989                        sc_compress = (int)val;  /* switch code packing on/off */
 990                     }
 991                   else if (strcmp(str, "dynamic") == 0)
 992                     {
 993                        preproc_expr(&sc_stksize, NULL);
 994                     }
 995                   else if (strcmp(str, "library") == 0)
 996                     {
 997                        char                name[sNAMEMAX + 1];
 998
 999                        while (*lptr <= ' ' && *lptr != '\0')
1000                           lptr++;
1001                        if (*lptr == '"')
1002                          {
1003                             lptr = getstring(name, sizeof name);
1004                          }
1005                        else
1006                          {
1007                             int                 i;
1008
1009                             for (i = 0;
1010                                  (i < (int)(sizeof(name))) &&
1011                                  (alphanum(*lptr));
1012                                  i++, lptr++)
1013                                name[i] = *lptr;
1014                             name[i] = '\0';
1015                          }      /* if */
1016                        if (name[0] == '\0')
1017                          {
1018                             curlibrary = NULL;
1019                          }
1020                        else
1021                          {
1022                             if (strlen(name) > sEXPMAX)
1023                                error(220, name, sEXPMAX);       /* exported symbol is truncated */
1024                             /* add the name if it does not yet exist in the table */
1025                             if (!find_constval(&libname_tab, name, 0))
1026                                curlibrary =
1027                                   append_constval(&libname_tab, name, 0, 0);
1028                          }      /* if */
1029                     }
1030                   else if (strcmp(str, "pack") == 0)
1031                     {
1032                        cell                val;
1033
1034                        preproc_expr(&val, NULL);        /* default = packed/unpacked */
1035                        sc_packstr = (int)val;
1036                     }
1037                   else if (strcmp(str, "rational") == 0)
1038                     {
1039                        char                name[sNAMEMAX + 1];
1040                        cell                digits = 0;
1041                        int                 i;
1042
1043                        /* first gather all information, start with the tag name */
1044                        while ((*lptr <= ' ') && (*lptr != '\0'))
1045                           lptr++;
1046                        for (i = 0;
1047                             (i < (int)(sizeof(name))) &&
1048                             (alphanum(*lptr));
1049                             i++, lptr++)
1050                           name[i] = *lptr;
1051                        name[i] = '\0';
1052                        /* then the precision (for fixed point arithmetic) */
1053                        while (*lptr <= ' ' && *lptr != '\0')
1054                           lptr++;
1055                        if (*lptr == '(')
1056                          {
1057                             preproc_expr(&digits, NULL);
1058                             if (digits <= 0 || digits > 9)
1059                               {
1060                                  error(68);     /* invalid rational number precision */
1061                                  digits = 0;
1062                               } /* if */
1063                             if (*lptr == ')')
1064                                lptr++;
1065                          }      /* if */
1066                        /* add the tag (make it public) and check the values */
1067                        i = sc_addtag(name);
1068                        exporttag(i);
1069                        if (sc_rationaltag == 0
1070                            || (sc_rationaltag == i
1071                                && rational_digits == (int)digits))
1072                          {
1073                             sc_rationaltag = i;
1074                             rational_digits = (int)digits;
1075                          }
1076                        else
1077                          {
1078                             error(69);  /* rational number format already set, can only be set once */
1079                          }      /* if */
1080                     }
1081                   else if (strcmp(str, "semicolon") == 0)
1082                     {
1083                        cell                val;
1084
1085                        preproc_expr(&val, NULL);
1086                        sc_needsemicolon = (int)val;
1087                     }
1088                   else if (strcmp(str, "tabsize") == 0)
1089                     {
1090                        cell                val;
1091
1092                        preproc_expr(&val, NULL);
1093                        sc_tabsize = (int)val;
1094                     }
1095                   else if (strcmp(str, "align") == 0)
1096                     {
1097                        sc_alignnext = TRUE;
1098                     }
1099                   else if (strcmp(str, "unused") == 0)
1100                     {
1101                        char                name[sNAMEMAX + 1];
1102                        int                 i, comma;
1103                        symbol             *sym;
1104
1105                        do
1106                          {
1107                             /* get the name */
1108                             while ((*lptr <= ' ') && (*lptr != '\0'))
1109                                lptr++;
1110                             for (i = 0;
1111                                  (i < (int)(sizeof(name))) &&
1112                                  (sc_isalpha(*lptr));
1113                                  i++, lptr++)
1114                                name[i] = *lptr;
1115                             name[i] = '\0';
1116                             /* get the symbol */
1117                             sym = findloc(name);
1118                             if (!sym)
1119                                sym = findglb(name);
1120                             if (sym)
1121                               {
1122                                  sym->usage |= uREAD;
1123                                  if (sym->ident == iVARIABLE
1124                                      || sym->ident == iREFERENCE
1125                                      || sym->ident == iARRAY
1126                                      || sym->ident == iREFARRAY)
1127                                     sym->usage |= uWRITTEN;
1128                               }
1129                             else
1130                               {
1131                                  error(17, name);       /* undefined symbol */
1132                               } /* if */
1133                             /* see if a comma follows the name */
1134                             while (*lptr <= ' ' && *lptr != '\0')
1135                                lptr++;
1136                             comma = (*lptr == ',');
1137                             if (comma)
1138                                lptr++;
1139                          }
1140                        while (comma);
1141                     }
1142                   else
1143                     {
1144                        error(207);      /* unknown #pragma */
1145                     }           /* if */
1146                }
1147              else
1148                {
1149                   error(207);   /* unknown #pragma */
1150                }                /* if */
1151              check_empty(lptr);
1152           }                     /* if */
1153         break;
1154      case tpENDINPUT:
1155      case tpENDSCRPT:
1156         if (skiplevel == 0)
1157           {
1158              check_empty(lptr);
1159              assert(inpf != NULL);
1160              if (inpf != inpf_org)
1161                 sc_closesrc(inpf);
1162              inpf = NULL;
1163           }                     /* if */
1164         break;
1165 #if !defined NOEMIT
1166      case tpEMIT:
1167         {
1168            /* write opcode to output file */
1169            char                name[40];
1170            int                 i;
1171
1172            while (*lptr <= ' ' && *lptr != '\0')
1173               lptr++;
1174            for (i = 0; i < 40 && (sc_isalpha(*lptr) || *lptr == '.'); i++, lptr++)
1175               name[i] = (char)tolower(*lptr);
1176            name[i] = '\0';
1177            stgwrite("\t");
1178            stgwrite(name);
1179            stgwrite(" ");
1180            code_idx += opcodes(1);
1181            /* write parameter (if any) */
1182            while (*lptr <= ' ' && *lptr != '\0')
1183               lptr++;
1184            if (*lptr != '\0')
1185              {
1186                 symbol             *sym;
1187
1188                 tok = lex(&val, &str);
1189                 switch (tok)
1190                   {
1191                   case tNUMBER:
1192                   case tRATIONAL:
1193                      outval(val, FALSE);
1194                      code_idx += opargs(1);
1195                      break;
1196                   case tSYMBOL:
1197                      sym = findloc(str);
1198                      if (!sym)
1199                         sym = findglb(str);
1200                      if (!sym || (sym->ident != iFUNCTN
1201                          && sym->ident != iREFFUNC
1202                          && (sym->usage & uDEFINE) == 0))
1203                        {
1204                           error(17, str);       /* undefined symbol */
1205                        }
1206                      else
1207                        {
1208                           outval(sym->addr, FALSE);
1209                           /* mark symbol as "used", unknown whether for read or write */
1210                           markusage(sym, uREAD | uWRITTEN);
1211                           code_idx += opargs(1);
1212                        }        /* if */
1213                      break;
1214                   default:
1215                      {
1216                         char                s2[20];
1217                         extern char        *sc_tokens[];        /* forward declaration */
1218
1219                         if (tok < 256)
1220                            sprintf(s2, "%c", (char)tok);
1221                         else
1222                            strcpy(s2, sc_tokens[tok - tFIRST]);
1223                         error(1, sc_tokens[tSYMBOL - tFIRST], s2);
1224                         break;
1225                      }          /* case */
1226                   }             /* switch */
1227              }                  /* if */
1228            stgwrite("\n");
1229            check_empty(lptr);
1230            break;
1231         }                       /* case */
1232 #endif
1233 #if !defined NO_DEFINE
1234      case tpDEFINE:
1235         {
1236            ret = CMD_DEFINE;
1237            if (skiplevel == 0)
1238              {
1239                 char               *pattern, *substitution;
1240                 char               *start, *end;
1241                 int                 count, prefixlen;
1242                 stringpair         *def;
1243
1244                 /* find the pattern to match */
1245                 while (*lptr <= ' ' && *lptr != '\0')
1246                    lptr++;
1247                 start = lptr;   /* save starting point of the match pattern */
1248                 count = 0;
1249                 while (*lptr > ' ' && *lptr != '\0')
1250                   {
1251                      litchar(&lptr, FALSE);     /* litchar() advances "lptr" and handles escape characters */
1252                      count++;
1253                   }             /* while */
1254                 end = lptr;
1255                 /* check pattern to match */
1256                 if (!sc_isalpha(*start) && *start != '_')
1257                   {
1258                      error(74); /* pattern must start with an alphabetic character */
1259                      break;
1260                   }             /* if */
1261                 /* store matched pattern */
1262                 pattern = malloc(count + 1);
1263                 if (!pattern)
1264                    error(103);  /* insufficient memory */
1265                 lptr = start;
1266                 count = 0;
1267                 while (lptr != end)
1268                   {
1269                      assert(lptr < end);
1270                      assert(*lptr != '\0');
1271                      pattern[count++] = (char)litchar(&lptr, FALSE);
1272                   }             /* while */
1273                 pattern[count] = '\0';
1274                 /* special case, erase trailing variable, because it could match anything */
1275                 if (count >= 2 && sc_isdigit(pattern[count - 1])
1276                     && pattern[count - 2] == '%')
1277                    pattern[count - 2] = '\0';
1278                 /* find substitution string */
1279                 while (*lptr <= ' ' && *lptr != '\0')
1280                    lptr++;
1281                 start = lptr;   /* save starting point of the match pattern */
1282                 count = 0;
1283                 end = NULL;
1284                 while (*lptr != '\0')
1285                   {
1286                      /* keep position of the start of trailing whitespace */
1287                      if (*lptr <= ' ')
1288                        {
1289                           if (!end)
1290                              end = lptr;
1291                        }
1292                      else
1293                        {
1294                           end = NULL;
1295                        }        /* if */
1296                      count++;
1297                      lptr++;
1298                   }             /* while */
1299                 if (!end)
1300                    end = lptr;
1301                 /* store matched substitution */
1302                 substitution = malloc(count + 1);       /* +1 for '\0' */
1303                 if (!substitution)
1304                    error(103);  /* insufficient memory */
1305                 lptr = start;
1306                 count = 0;
1307                 while (lptr != end)
1308                   {
1309                      assert(lptr < end);
1310                      assert(*lptr != '\0');
1311                      substitution[count++] = *lptr++;
1312                   }             /* while */
1313                 substitution[count] = '\0';
1314                 /* check whether the definition already exists */
1315                 for (prefixlen = 0, start = pattern;
1316                      sc_isalpha(*start) || sc_isdigit(*start) || *start == '_';
1317                      prefixlen++, start++)
1318                    /* nothing */ ;
1319                 assert(prefixlen > 0);
1320                 if ((def = find_subst(pattern, prefixlen)))
1321                   {
1322                      if (strcmp(def->first, pattern) != 0
1323                          || strcmp(def->second, substitution) != 0)
1324                         error(201, pattern);    /* redefinition of macro (non-identical) */
1325                      delete_subst(pattern, prefixlen);
1326                   }             /* if */
1327                 /* add the pattern/substitution pair to the list */
1328                 assert(pattern[0] != '\0');
1329                 insert_subst(pattern, substitution, prefixlen);
1330                 free(pattern);
1331                 free(substitution);
1332              }                  /* if */
1333            break;
1334         }                       /* case */
1335      case tpUNDEF:
1336         if (skiplevel == 0)
1337           {
1338              if (lex(&val, &str) == tSYMBOL)
1339                {
1340                   if (!delete_subst(str, strlen(str)))
1341                      error(17, str);    /* undefined symbol */
1342                }
1343              else
1344                {
1345                   error(20, str);       /* invalid symbol name */
1346                }                /* if */
1347              check_empty(lptr);
1348           }                     /* if */
1349         break;
1350 #endif
1351      default:
1352         error(31);              /* unknown compiler directive */
1353         ret = skiplevel > 0 ? CMD_DIRECTIVE : CMD_NONE; /* line must be processed (if skiplevel==0) */
1354      }                          /* switch */
1355    return ret;
1356 }
1357
1358 #if !defined NO_DEFINE
1359 static int
1360 is_startstring(char *string)
1361 {
1362    if (*string == '\"' || *string == '\'')
1363       return TRUE;              /* "..." */
1364
1365    if (*string == '!')
1366      {
1367         string++;
1368         if (*string == '\"' || *string == '\'')
1369            return TRUE;         /* !"..." */
1370         if (*string == sc_ctrlchar)
1371           {
1372              string++;
1373              if (*string == '\"' || *string == '\'')
1374                 return TRUE;    /* !\"..." */
1375           }                     /* if */
1376      }
1377    else if (*string == sc_ctrlchar)
1378      {
1379         string++;
1380         if (*string == '\"' || *string == '\'')
1381            return TRUE;         /* \"..." */
1382         if (*string == '!')
1383           {
1384              string++;
1385              if (*string == '\"' || *string == '\'')
1386                 return TRUE;    /* \!"..." */
1387           }                     /* if */
1388      }                          /* if */
1389
1390    return FALSE;
1391 }
1392
1393 static char        *
1394 skipstring(char *string)
1395 {
1396    char                endquote;
1397    int                 rawstring = FALSE;
1398
1399    while (*string == '!' || *string == sc_ctrlchar)
1400      {
1401         rawstring = (*string == sc_ctrlchar);
1402         string++;
1403      }                          /* while */
1404
1405    endquote = *string;
1406    assert(endquote == '\"' || endquote == '\'');
1407    string++;                    /* skip open quote */
1408    while (*string != endquote && *string != '\0')
1409       litchar(&string, rawstring);
1410    return string;
1411 }
1412
1413 static char        *
1414 skippgroup(char *string)
1415 {
1416    int                 nest = 0;
1417    char                open = *string;
1418    char                close;
1419
1420    switch (open)
1421      {
1422      case '(':
1423         close = ')';
1424         break;
1425      case '{':
1426         close = '}';
1427         break;
1428      case '[':
1429         close = ']';
1430         break;
1431      case '<':
1432         close = '>';
1433         break;
1434      default:
1435         assert(0);
1436         close = '\0';           /* only to avoid a compiler warning */
1437      }                          /* switch */
1438
1439    string++;
1440    while (*string != close || nest > 0)
1441      {
1442         if (*string == open)
1443            nest++;
1444         else if (*string == close)
1445            nest--;
1446         else if (is_startstring(string))
1447            string = skipstring(string);
1448         if (*string == '\0')
1449            break;
1450         string++;
1451      }                          /* while */
1452    return string;
1453 }
1454
1455 static char        *
1456 strdel(char *str, size_t len)
1457 {
1458    size_t              length = strlen(str);
1459
1460    if (len > length)
1461       len = length;
1462    memmove(str, str + len, length - len + 1);   /* include EOS byte */
1463    return str;
1464 }
1465
1466 static char        *
1467 strins(char *dest, char *src, size_t srclen)
1468 {
1469    size_t              destlen = strlen(dest);
1470
1471    assert(srclen <= strlen(src));
1472    memmove(dest + srclen, dest, destlen + 1);   /* include EOS byte */
1473    memcpy(dest, src, srclen);
1474    return dest;
1475 }
1476
1477 static int
1478 substpattern(char *line, size_t buffersize, char *pattern, char *substitution)
1479 {
1480    int                 prefixlen;
1481    char               *p, *s, *e, *args[10];
1482    int                 match, arg, len;
1483
1484    memset(args, 0, sizeof args);
1485
1486    /* check the length of the prefix */
1487    for (prefixlen = 0, s = pattern; sc_isalpha(*s) || sc_isdigit(*s) || *s == '_';
1488         prefixlen++, s++)
1489       /* nothing */ ;
1490    assert(prefixlen > 0);
1491    assert(strncmp(line, pattern, prefixlen) == 0);
1492
1493    /* pattern prefix matches; match the rest of the pattern, gather
1494     * the parameters
1495     */
1496    s = line + prefixlen;
1497    p = pattern + prefixlen;
1498    match = TRUE;                /* so far, pattern matches */
1499    while (match && *s != '\0' && *p != '\0')
1500      {
1501         if (*p == '%')
1502           {
1503              p++;               /* skip '%' */
1504              if (sc_isdigit(*p))
1505                {
1506                   arg = *p - '0';
1507                   assert(arg >= 0 && arg <= 9);
1508                   p++;          /* skip parameter id */
1509                   assert(*p != '\0');
1510                   /* match the source string up to the character after the digit
1511                    * (skipping strings in the process
1512                    */
1513                   e = s;
1514                   while (*e != *p && *e != '\0' && *e != '\n')
1515                     {
1516                        if (is_startstring(e))   /* skip strings */
1517                           e = skipstring(e);
1518                        else if (strchr("({[", *e))      /* skip parenthized groups */
1519                           e = skippgroup(e);
1520                        if (*e != '\0')
1521                           e++;  /* skip non-alphapetic character (or closing quote of
1522                                  * a string, or the closing paranthese of a group) */
1523                     }           /* while */
1524                   /* store the parameter (overrule any earlier) */
1525                   if (args[arg])
1526                      free(args[arg]);
1527                   len = (int)(e - s);
1528                   args[arg] = malloc(len + 1);
1529                   if (!args[arg])
1530                      error(103);        /* insufficient memory */
1531                   strncpy(args[arg], s, len);
1532                   args[arg][len] = '\0';
1533                   /* character behind the pattern was matched too */
1534                   if (*e == *p)
1535                     {
1536                        s = e + 1;
1537                     }
1538                   else if (*e == '\n' && *p == ';' && *(p + 1) == '\0'
1539                            && !sc_needsemicolon)
1540                     {
1541                        s = e;   /* allow a trailing ; in the pattern match to end of line */
1542                     }
1543                   else
1544                     {
1545                        assert(*e == '\0' || *e == '\n');
1546                        match = FALSE;
1547                        s = e;
1548                     }           /* if */
1549                   p++;
1550                }
1551              else
1552                {
1553                   match = FALSE;
1554                }                /* if */
1555           }
1556         else if (*p == ';' && *(p + 1) == '\0' && !sc_needsemicolon)
1557           {
1558              /* source may be ';' or end of the line */
1559              while (*s <= ' ' && *s != '\0')
1560                 s++;            /* skip white space */
1561              if (*s != ';' && *s != '\0')
1562                 match = FALSE;
1563              p++;               /* skip the semicolon in the pattern */
1564           }
1565         else
1566           {
1567              cell                ch;
1568
1569              /* skip whitespace between two non-alphanumeric characters, except
1570               * for two identical symbols
1571               */
1572              assert(p > pattern);
1573              if (!alphanum(*p) && *(p - 1) != *p)
1574                 while (*s <= ' ' && *s != '\0')
1575                    s++;         /* skip white space */
1576              ch = litchar(&p, FALSE);   /* this increments "p" */
1577              if (*s != ch)
1578                 match = FALSE;
1579              else
1580                 s++;            /* this character matches */
1581           }                     /* if */
1582      }                          /* while */
1583
1584    if (match && *p == '\0')
1585      {
1586         /* if the last character to match is an alphanumeric character, the
1587          * current character in the source may not be alphanumeric
1588          */
1589         assert(p > pattern);
1590         if (alphanum(*(p - 1)) && alphanum(*s))
1591            match = FALSE;
1592      }                          /* if */
1593
1594    if (match)
1595      {
1596         /* calculate the length of the substituted string */
1597         for (e = substitution, len = 0; *e != '\0'; e++)
1598           {
1599              if (*e == '%' && sc_isdigit(*(e + 1)))
1600                {
1601                   arg = *(e + 1) - '0';
1602                   assert(arg >= 0 && arg <= 9);
1603                   if (args[arg])
1604                      len += strlen(args[arg]);
1605                   e++;          /* skip %, digit is skipped later */
1606                }
1607              else
1608                {
1609                   len++;
1610                }                /* if */
1611           }                     /* for */
1612         /* check length of the string after substitution */
1613         if (strlen(line) + len - (int)(s - line) > buffersize)
1614           {
1615              error(75);         /* line too long */
1616           }
1617         else
1618           {
1619              /* substitute pattern */
1620              strdel(line, (int)(s - line));
1621              for (e = substitution, s = line; *e != '\0'; e++)
1622                {
1623                   if (*e == '%' && sc_isdigit(*(e + 1)))
1624                     {
1625                        arg = *(e + 1) - '0';
1626                        assert(arg >= 0 && arg <= 9);
1627                        if (args[arg])
1628                          {
1629                             strins(s, args[arg], strlen(args[arg]));
1630                             s += strlen(args[arg]);
1631                          }      /* if */
1632                        e++;     /* skip %, digit is skipped later */
1633                     }
1634                   else
1635                     {
1636                        strins(s, e, 1);
1637                        s++;
1638                     }           /* if */
1639                }                /* for */
1640           }                     /* if */
1641      }                          /* if */
1642
1643    for (arg = 0; arg < 10; arg++)
1644       if (args[arg])
1645          free(args[arg]);
1646
1647    return match;
1648 }
1649
1650 static void
1651 substallpatterns(char *line, int buffersize)
1652 {
1653    char               *start, *end;
1654    int                 prefixlen;
1655    stringpair         *subst;
1656
1657    start = line;
1658    while (*start != '\0')
1659      {
1660         /* find the start of a prefix (skip all non-alphabetic characters),
1661          * also skip strings
1662          */
1663         while (!sc_isalpha(*start) && *start != '_' && *start != '\0')
1664           {
1665              /* skip strings */
1666              if (is_startstring(start))
1667                {
1668                   start = skipstring(start);
1669                   if (*start == '\0')
1670                      break;     /* abort loop on error */
1671                }                /* if */
1672              start++;           /* skip non-alphapetic character (or closing quote of a string) */
1673           }                     /* while */
1674         if (*start == '\0')
1675            break;               /* abort loop on error */
1676         /* get the prefix (length), look for a matching definition */
1677         prefixlen = 0;
1678         end = start;
1679         while (sc_isalpha(*end) || sc_isdigit(*end) || *end == '_')
1680           {
1681              prefixlen++;
1682              end++;
1683           }                     /* while */
1684         assert(prefixlen > 0);
1685         subst = find_subst(start, prefixlen);
1686         if (subst)
1687           {
1688              /* properly match the pattern and substitute */
1689              if (!substpattern
1690                  (start, buffersize - (start - line), subst->first,
1691                   subst->second))
1692                 start = end;    /* match failed, skip this prefix */
1693              /* match succeeded: do not update "start", because the substitution text
1694               * may be matched by other macros
1695               */
1696           }
1697         else
1698           {
1699              start = end;       /* no macro with this prefix, skip this prefix */
1700           }                     /* if */
1701      }                          /* while */
1702 }
1703 #endif
1704
1705 /*  preprocess
1706  *
1707  *  Reads a line by readline() into "pline" and performs basic preprocessing:
1708  *  deleting comments, skipping lines with false "#if.." code and recognizing
1709  *  other compiler directives. There is an indirect recursion: lex() calls
1710  *  preprocess() if a new line must be read, preprocess() calls command(),
1711  *  which at his turn calls lex() to identify the token.
1712  *
1713  *  Global references: lptr     (altered)
1714  *                     pline    (altered)
1715  *                     freading (referred to only)
1716  */
1717 void
1718 preprocess(void)
1719 {
1720    int                 iscommand;
1721
1722    if (!freading)
1723       return;
1724    do
1725      {
1726         readline(pline);
1727         stripcom(pline);        /* ??? no need for this when reading back from list file (in the second pass) */
1728         lptr = pline;           /* set "line pointer" to start of the parsing buffer */
1729         iscommand = command();
1730         if (iscommand != CMD_NONE)
1731            errorset(sRESET);    /* reset error flag ("panic mode") on empty line or directive */
1732 #if !defined NO_DEFINE
1733         if (iscommand == CMD_NONE)
1734           {
1735              assert(lptr != term_expr);
1736              substallpatterns(pline, sLINEMAX);
1737              lptr = pline;      /* reset "line pointer" to start of the parsing buffer */
1738           }                     /* if */
1739 #endif
1740      }
1741    while (iscommand != CMD_NONE && iscommand != CMD_TERM && freading);  /* enddo */
1742 }
1743
1744 static char        *
1745 unpackedstring(char *lptr, int rawstring)
1746 {
1747    while (*lptr != '\0')
1748      {
1749         /* check for doublequotes indicating the end of the string */
1750         if (*lptr == '\"')
1751         {
1752            /* check whether there's another pair of quotes following.
1753             * If so, paste the two strings together, thus
1754             * "pants""off" becomes "pantsoff"
1755             */
1756            if (*(lptr + 1) == '\"')
1757               lptr += 2;
1758            else
1759               break;
1760         }
1761
1762         if (*lptr == '\a')
1763           {                     /* ignore '\a' (which was inserted at a line concatenation) */
1764              lptr++;
1765              continue;
1766           }                     /* if */
1767         stowlit(litchar(&lptr, rawstring));     /* litchar() alters "lptr" */
1768      }                          /* while */
1769    stowlit(0);                  /* terminate string */
1770    return lptr;
1771 }
1772
1773 static char        *
1774 packedstring(char *lptr, int rawstring)
1775 {
1776    int                 i;
1777    ucell               val, c;
1778
1779    i = sizeof(ucell) - (charbits / 8);  /* start at most significant byte */
1780    val = 0;
1781    while (*lptr != '\0')
1782      {
1783         /* check for doublequotes indicating the end of the string */
1784         if (*lptr == '\"')
1785         {
1786            /* check whether there's another pair of quotes following.
1787             * If so, paste the two strings together, thus
1788             * "pants""off" becomes "pantsoff"
1789             */
1790            if (*(lptr + 1) == '\"')
1791               lptr += 2;
1792            else
1793               break;
1794         }
1795
1796         if (*lptr == '\a')
1797           {                     /* ignore '\a' (which was inserted at a line concatenation) */
1798              lptr++;
1799              continue;
1800           }                     /* if */
1801         c = litchar(&lptr, rawstring);  /* litchar() alters "lptr" */
1802         if (c >= (ucell) (1 << charbits))
1803            error(43);           /* character constant exceeds range */
1804         val |= (c << 8 * i);
1805         if (i == 0)
1806           {
1807              stowlit(val);
1808              val = 0;
1809           }                     /* if */
1810         i = (i + sizeof(ucell) - (charbits / 8)) % sizeof(ucell);
1811      }                          /* if */
1812    /* save last code; make sure there is at least one terminating zero character */
1813    if (i != (int)(sizeof(ucell) - (charbits / 8)))
1814       stowlit(val);             /* at least one zero character in "val" */
1815    else
1816       stowlit(0);               /* add full cell of zeros */
1817    return lptr;
1818 }
1819
1820 /*  lex(lexvalue,lexsym)        Lexical Analysis
1821  *
1822  *  lex() first deletes leading white space, then checks for multi-character
1823  *  operators, keywords (including most compiler directives), numbers,
1824  *  labels, symbols and literals (literal characters are converted to a number
1825  *  and are returned as such). If every check fails, the line must contain
1826  *  a single-character operator. So, lex() returns this character. In the other
1827  *  case (something did match), lex() returns the number of the token. All
1828  *  these tokens have been assigned numbers above 255.
1829  *
1830  *  Some tokens have "attributes":
1831  *     tNUMBER        the value of the number is return in "lexvalue".
1832  *     tRATIONAL      the value is in IEEE 754 encoding or in fixed point
1833  *                    encoding in "lexvalue".
1834  *     tSYMBOL        the first sNAMEMAX characters of the symbol are
1835  *                    stored in a buffer, a pointer to this buffer is
1836  *                    returned in "lexsym".
1837  *     tLABEL         the first sNAMEMAX characters of the label are
1838  *                    stored in a buffer, a pointer to this buffer is
1839  *                    returned in "lexsym".
1840  *     tSTRING        the string is stored in the literal pool, the index
1841  *                    in the literal pool to this string is stored in
1842  *                    "lexvalue".
1843  *
1844  *  lex() stores all information (the token found and possibly its attribute)
1845  *  in global variables. This allows a token to be examined twice. If "_pushed"
1846  *  is true, this information is returned.
1847  *
1848  *  Global references: lptr          (altered)
1849  *                     fline         (referred to only)
1850  *                     litidx        (referred to only)
1851  *                     _lextok, _lexval, _lexstr
1852  *                     _pushed
1853  */
1854
1855 static int          _pushed;
1856 static int          _lextok;
1857 static cell         _lexval;
1858 static char         _lexstr[sLINEMAX + 1];
1859 static int          _lexnewline;
1860
1861 void
1862 lexinit(void)
1863 {
1864    stkidx = 0;                  /* index for pushstk() and popstk() */
1865    iflevel = 0;                 /* preprocessor: nesting of "#if" */
1866    skiplevel = 0;               /* preprocessor: skipping lines or compiling lines */
1867    icomment = FALSE;            /* currently not in a multiline comment */
1868    _pushed = FALSE;             /* no token pushed back into lex */
1869    _lexnewline = FALSE;
1870 }
1871
1872 char               *sc_tokens[] = {
1873    "*=", "/=", "%=", "+=", "-=", "<<=", ">>>=", ">>=", "&=", "^=", "|=",
1874    "||", "&&", "==", "!=", "<=", ">=", "<<", ">>>", ">>", "++", "--",
1875    "...", "..",
1876    "assert", "break", "case", "char", "const", "continue", "default",
1877    "defined", "do", "else", "enum", "exit", "for", "forward", "goto",
1878    "if", "native", "new", "operator", "public", "return", "sizeof",
1879    "sleep", "static", "stock", "switch", "tagof", "while",
1880    "#assert", "#define", "#else", "#emit", "#endif", "#endinput",
1881    "#endscript", "#file", "#if", "#include", "#line", "#pragma", "#undef",
1882    ";", ";", "-integer value-", "-rational value-", "-identifier-",
1883    "-label-", "-string-"
1884 };
1885
1886 int
1887 lex(cell * lexvalue, char **lexsym)
1888 {
1889    int                 i, toolong, newline, rawstring;
1890    char              **tokptr;
1891
1892    if (_pushed)
1893      {
1894         _pushed = FALSE;        /* reset "_pushed" flag */
1895         *lexvalue = _lexval;
1896         *lexsym = _lexstr;
1897         return _lextok;
1898      }                          /* if */
1899
1900    _lextok = 0;                 /* preset all values */
1901    _lexval = 0;
1902    _lexstr[0] = '\0';
1903    *lexvalue = _lexval;
1904    *lexsym = _lexstr;
1905    _lexnewline = FALSE;
1906    if (!freading)
1907       return 0;
1908
1909    newline = (lptr == pline);   /* does lptr point to start of line buffer */
1910    while (*lptr <= ' ')
1911      {                          /* delete leading white space */
1912         if (*lptr == '\0')
1913           {
1914              preprocess();      /* preprocess resets "lptr" */
1915              if (!freading)
1916                 return 0;
1917              if (lptr == term_expr)     /* special sequence to terminate a pending expression */
1918                 return (_lextok = tENDEXPR);
1919              _lexnewline = TRUE;        /* set this after preprocess(), because
1920                                          * preprocess() calls lex() recursively */
1921              newline = TRUE;
1922           }
1923         else
1924           {
1925              lptr += 1;
1926           }                     /* if */
1927      }                          /* while */
1928    if (newline)
1929      {
1930         stmtindent = 0;
1931         for (i = 0; i < (int)(lptr - pline); i++)
1932            if (pline[i] == '\t' && sc_tabsize > 0)
1933               stmtindent +=
1934                  (int)(sc_tabsize - (stmtindent + sc_tabsize) % sc_tabsize);
1935            else
1936               stmtindent++;
1937      }                          /* if */
1938
1939    i = tFIRST;
1940    tokptr = sc_tokens;
1941    while (i <= tMIDDLE)
1942      {                          /* match multi-character operators */
1943         if (match(*tokptr, FALSE))
1944           {
1945              _lextok = i;
1946              return _lextok;
1947           }                     /* if */
1948         i += 1;
1949         tokptr += 1;
1950      }                          /* while */
1951    while (i <= tLAST)
1952      {                          /* match reserved words and compiler directives */
1953         if (match(*tokptr, TRUE))
1954           {
1955              _lextok = i;
1956              errorset(sRESET);  /* reset error flag (clear the "panic mode") */
1957              return _lextok;
1958           }                     /* if */
1959         i += 1;
1960         tokptr += 1;
1961      }                          /* while */
1962
1963    if ((i = number(&_lexval, lptr)) != 0)
1964      {                          /* number */
1965         _lextok = tNUMBER;
1966         *lexvalue = _lexval;
1967         lptr += i;
1968      }
1969    else if ((i = ftoi(&_lexval, lptr)) != 0)
1970      {
1971         _lextok = tRATIONAL;
1972         *lexvalue = _lexval;
1973         lptr += i;
1974      }
1975    else if (alpha(*lptr))
1976      {                          /* symbol or label */
1977         /*  Note: only sNAMEMAX characters are significant. The compiler
1978          *        generates a warning if a symbol exceeds this length.
1979          */
1980         _lextok = tSYMBOL;
1981         i = 0;
1982         toolong = 0;
1983         while (alphanum(*lptr))
1984           {
1985              _lexstr[i] = *lptr;
1986              lptr += 1;
1987              if (i < sNAMEMAX)
1988                 i += 1;
1989              else
1990                 toolong = 1;
1991           }                     /* while */
1992         _lexstr[i] = '\0';
1993         if (toolong)
1994            error(200, _lexstr, sNAMEMAX);       /* symbol too long, truncated to sNAMEMAX chars */
1995         if (_lexstr[0] == PUBLIC_CHAR && _lexstr[1] == '\0')
1996           {
1997              _lextok = PUBLIC_CHAR;     /* '@' all alone is not a symbol, it is an operator */
1998           }
1999         else if (_lexstr[0] == '_' && _lexstr[1] == '\0')
2000           {
2001              _lextok = '_';     /* '_' by itself is not a symbol, it is a placeholder */
2002           }                     /* if */
2003         if (*lptr == ':' && sc_allowtags && _lextok != PUBLIC_CHAR)
2004           {
2005              _lextok = tLABEL;  /* it wasn't a normal symbol, it was a label/tagname */
2006              lptr += 1;         /* skip colon */
2007           }                     /* if */
2008      }
2009    else if (*lptr == '\"' || (*lptr == sc_ctrlchar && *(lptr + 1) == '\"'))
2010      {                          /* unpacked string literal */
2011         _lextok = tSTRING;
2012         rawstring = (*lptr == sc_ctrlchar);
2013         *lexvalue = _lexval = litidx;
2014         lptr += 1;              /* skip double quote */
2015         if (rawstring)
2016            lptr += 1;           /* skip "escape" character too */
2017         lptr =
2018            sc_packstr ? packedstring(lptr, rawstring) : unpackedstring(lptr,
2019                                                                        rawstring);
2020         if (*lptr == '\"')
2021            lptr += 1;           /* skip final quote */
2022         else
2023            error(37);           /* invalid (non-terminated) string */
2024      }
2025    else if ((*lptr == '!' && *(lptr + 1) == '\"')
2026             || (*lptr == '!' && *(lptr + 1) == sc_ctrlchar && *(lptr + 2) == '\"')
2027             || (*lptr == sc_ctrlchar && *(lptr + 1) == '!'
2028             && *(lptr + 2) == '\"'))
2029      {                          /* packed string literal */
2030         _lextok = tSTRING;
2031         rawstring = (*lptr == sc_ctrlchar || *(lptr + 1) == sc_ctrlchar);
2032         *lexvalue = _lexval = litidx;
2033         lptr += 2;              /* skip exclamation point and double quote */
2034         if (rawstring)
2035            lptr += 1;           /* skip "escape" character too */
2036         lptr =
2037            sc_packstr ? unpackedstring(lptr, rawstring) : packedstring(lptr,
2038                                                                        rawstring);
2039         if (*lptr == '\"')
2040            lptr += 1;           /* skip final quote */
2041         else
2042            error(37);           /* invalid (non-terminated) string */
2043      }
2044    else if (*lptr == '\'')
2045      {                          /* character literal */
2046         lptr += 1;              /* skip quote */
2047         _lextok = tNUMBER;
2048         *lexvalue = _lexval = litchar(&lptr, FALSE);
2049         if (*lptr == '\'')
2050            lptr += 1;           /* skip final quote */
2051         else
2052            error(27);           /* invalid character constant (must be one character) */
2053      }
2054    else if (*lptr == ';')
2055      {                          /* semicolumn resets "error" flag */
2056         _lextok = ';';
2057         lptr += 1;
2058         errorset(sRESET);       /* reset error flag (clear the "panic mode") */
2059      }
2060    else
2061      {
2062         _lextok = *lptr;        /* if every match fails, return the character */
2063         lptr += 1;              /* increase the "lptr" pointer */
2064      }                          /* if */
2065    return _lextok;
2066 }
2067
2068 /*  lexpush
2069  *
2070  *  Pushes a token back, so the next call to lex() will return the token
2071  *  last examined, instead of a new token.
2072  *
2073  *  Only one token can be pushed back.
2074  *
2075  *  In fact, lex() already stores the information it finds into global
2076  *  variables, so all that is to be done is set a flag that informs lex()
2077  *  to read and return the information from these variables, rather than
2078  *  to read in a new token from the input file.
2079  */
2080 void
2081 lexpush(void)
2082 {
2083    assert(_pushed == FALSE);
2084    _pushed = TRUE;
2085 }
2086
2087 /*  lexclr
2088  *
2089  *  Sets the variable "_pushed" to 0 to make sure lex() will read in a new
2090  *  symbol (a not continue with some old one). This is required upon return
2091  *  from Assembler mode.
2092  */
2093 void
2094 lexclr(int clreol)
2095 {
2096    _pushed = FALSE;
2097    if (clreol)
2098      {
2099         lptr = strchr(pline, '\0');
2100         assert(lptr != NULL);
2101      }                          /* if */
2102 }
2103
2104 /*  matchtoken
2105  *
2106  *  This routine is useful if only a simple check is needed. If the token
2107  *  differs from the one expected, it is pushed back.
2108  */
2109 int
2110 matchtoken(int token)
2111 {
2112    cell                val;
2113    char               *str;
2114    int                 tok;
2115
2116    tok = lex(&val, &str);
2117    if (tok == token || (token == tTERM && (tok == ';' || tok == tENDEXPR)))
2118      {
2119         return 1;
2120      }
2121    else if (!sc_needsemicolon && token == tTERM && (_lexnewline || !freading))
2122      {
2123         lexpush();              /* push "tok" back, we use the "hidden" newline token */
2124         return 1;
2125      }
2126    else
2127      {
2128         lexpush();
2129         return 0;
2130      }                          /* if */
2131 }
2132
2133 /*  tokeninfo
2134  *
2135  *  Returns additional information of a token after using "matchtoken()"
2136  *  or needtoken(). It does no harm using this routine after a call to
2137  *  "lex()", but lex() already returns the same information.
2138  *
2139  *  The token itself is the return value. Normally, this one is already known.
2140  */
2141 int
2142 tokeninfo(cell * val, char **str)
2143 {
2144    /* if the token was pushed back, tokeninfo() returns the token and
2145     * parameters of the *next* token, not of the *current* token.
2146     */
2147    assert(!_pushed);
2148    *val = _lexval;
2149    *str = _lexstr;
2150    return _lextok;
2151 }
2152
2153 /*  needtoken
2154  *
2155  *  This routine checks for a required token and gives an error message if
2156  *  it isn't there (and returns FALSE in that case).
2157  *
2158  *  Global references: _lextok;
2159  */
2160 int
2161 needtoken(int token)
2162 {
2163    char                s1[20], s2[20];
2164
2165    if (matchtoken(token))
2166      {
2167         return TRUE;
2168      }
2169    else
2170      {
2171         /* token already pushed back */
2172         assert(_pushed);
2173         if (token < 256)
2174            sprintf(s1, "%c", (char)token);      /* single character token */
2175         else
2176            strcpy(s1, sc_tokens[token - tFIRST]);       /* multi-character symbol */
2177         if (!freading)
2178            strcpy(s2, "-end of file-");
2179         else if (_lextok < 256)
2180            sprintf(s2, "%c", (char)_lextok);
2181         else
2182            strcpy(s2, sc_tokens[_lextok - tFIRST]);
2183         error(1, s1, s2);       /* expected ..., but found ... */
2184         return FALSE;
2185      }                          /* if */
2186 }
2187
2188 /*  match
2189  *
2190  *  Compares a series of characters from the input file with the characters
2191  *  in "st" (that contains a token). If the token on the input file matches
2192  *  "st", the input file pointer "lptr" is adjusted to point to the next
2193  *  token, otherwise "lptr" remains unaltered.
2194  *
2195  *  If the parameter "end: is true, match() requires that the first character
2196  *  behind the recognized token is non-alphanumeric.
2197  *
2198  *  Global references: lptr   (altered)
2199  */
2200 static int
2201 match(char *st, int end)
2202 {
2203    int                 k;
2204    char               *ptr;
2205
2206    k = 0;
2207    ptr = lptr;
2208    while (st[k])
2209      {
2210         if (st[k] != *ptr)
2211            return 0;
2212         k += 1;
2213         ptr += 1;
2214      }                          /* while */
2215    if (end)
2216      {                          /* symbol must terminate with non-alphanumeric char */
2217         if (alphanum(*ptr))
2218            return 0;
2219      }                          /* if */
2220    lptr = ptr;                  /* match found, skip symbol */
2221    return 1;
2222 }
2223
2224 /*  stowlit
2225  *
2226  *  Stores a value into the literal queue. The literal queue is used for
2227  *  literal strings used in functions and for initializing array variables.
2228  *
2229  *  Global references: litidx  (altered)
2230  *                     litq    (altered)
2231  */
2232 void
2233 stowlit(cell value)
2234 {
2235    if (litidx >= litmax)
2236      {
2237         cell               *p;
2238
2239         litmax += sDEF_LITMAX;
2240         p = (cell *) realloc(litq, litmax * sizeof(cell));
2241         if (!p)
2242            error(102, "literal table"); /* literal table overflow (fatal error) */
2243         litq = p;
2244      }                          /* if */
2245    assert(litidx < litmax);
2246    litq[litidx++] = value;
2247 }
2248
2249 /*  litchar
2250  *
2251  *  Return current literal character and increase the pointer to point
2252  *  just behind this literal character.
2253  *
2254  *  Note: standard "escape sequences" are suported, but the backslash may be
2255  *        replaced by another character; the syntax '\ddd' is supported,
2256  *        but ddd must be decimal!
2257  */
2258 static cell
2259 litchar(char **lptr, int rawmode)
2260 {
2261    cell                c = 0;
2262    unsigned char      *cptr;
2263
2264    cptr = (unsigned char *)*lptr;
2265    if (rawmode || *cptr != sc_ctrlchar)
2266      {                          /* no escape character */
2267         c = *cptr;
2268         cptr += 1;
2269      }
2270    else
2271      {
2272         cptr += 1;
2273         if (*cptr == sc_ctrlchar)
2274           {
2275              c = *cptr;         /* \\ == \ (the escape character itself) */
2276              cptr += 1;
2277           }
2278         else
2279           {
2280              switch (*cptr)
2281                {
2282                case 'a':        /* \a == audible alarm */
2283                   c = 7;
2284                   cptr += 1;
2285                   break;
2286                case 'b':        /* \b == backspace */
2287                   c = 8;
2288                   cptr += 1;
2289                   break;
2290                case 'e':        /* \e == escape */
2291                   c = 27;
2292                   cptr += 1;
2293                   break;
2294                case 'f':        /* \f == form feed */
2295                   c = 12;
2296                   cptr += 1;
2297                   break;
2298                case 'n':        /* \n == NewLine character */
2299                   c = 10;
2300                   cptr += 1;
2301                   break;
2302                case 'r':        /* \r == carriage return */
2303                   c = 13;
2304                   cptr += 1;
2305                   break;
2306                case 't':        /* \t == horizontal TAB */
2307                   c = 9;
2308                   cptr += 1;
2309                   break;
2310                case 'v':        /* \v == vertical TAB */
2311                   c = 11;
2312                   cptr += 1;
2313                   break;
2314                case '\'':       /* \' == ' (single quote) */
2315                case '"':        /* \" == " (single quote) */
2316                case '%':        /* \% == % (percent) */
2317                   c = *cptr;
2318                   cptr += 1;
2319                   break;
2320                default:
2321                   if (sc_isdigit(*cptr))
2322                     {           /* \ddd */
2323                        c = 0;
2324                        while (*cptr >= '0' && *cptr <= '9')     /* decimal! */
2325                           c = c * 10 + *cptr++ - '0';
2326                        if (*cptr == ';')
2327                           cptr++;       /* swallow a trailing ';' */
2328                     }
2329                   else
2330                     {
2331                        error(27);       /* invalid character constant */
2332                     }           /* if */
2333                }                /* switch */
2334           }                     /* if */
2335      }                          /* if */
2336    *lptr = (char *)cptr;
2337    assert(c >= 0 && c < 256);
2338    return c;
2339 }
2340
2341 /*  alpha
2342  *
2343  *  Test if character "c" is alphabetic ("a".."z"), an underscore ("_")
2344  *  or an "at" sign ("@"). The "@" is an extension to standard C.
2345  */
2346 static int
2347 alpha(char c)
2348 {
2349    return (sc_isalpha(c) || c == '_' || c == PUBLIC_CHAR);
2350 }
2351
2352 /*  alphanum
2353  *
2354  *  Test if character "c" is alphanumeric ("a".."z", "0".."9", "_" or "@")
2355  */
2356 int
2357 alphanum(char c)
2358 {
2359    return (alpha(c) || sc_isdigit(c));
2360 }
2361
2362 /* The local variable table must be searched backwards, so that the deepest
2363  * nesting of local variables is searched first. The simplest way to do
2364  * this is to insert all new items at the head of the list.
2365  * In the global list, the symbols are kept in sorted order, so that the
2366  * public functions are written in sorted order.
2367  */
2368 static symbol      *
2369 add_symbol(symbol * root, symbol * entry, int sort)
2370 {
2371    symbol             *newsym;
2372
2373    if (sort)
2374       while (root->next && strcmp(entry->name, root->next->name) > 0)
2375          root = root->next;
2376
2377    if (!(newsym = (symbol *)malloc(sizeof(symbol))))
2378      {
2379         error(103);
2380         return NULL;
2381      }                          /* if */
2382    memcpy(newsym, entry, sizeof(symbol));
2383    newsym->next = root->next;
2384    root->next = newsym;
2385    return newsym;
2386 }
2387
2388 static void
2389 free_symbol(symbol * sym)
2390 {
2391    arginfo            *arg;
2392
2393    /* free all sub-symbol allocated memory blocks, depending on the
2394     * kind of the symbol
2395     */
2396    assert(sym != NULL);
2397    if (sym->ident == iFUNCTN)
2398      {
2399         /* run through the argument list; "default array" arguments
2400          * must be freed explicitly; the tag list must also be freed */
2401         assert(sym->dim.arglist != NULL);
2402         for (arg = sym->dim.arglist; arg->ident != 0; arg++)
2403           {
2404              if (arg->ident == iREFARRAY && arg->hasdefault)
2405                 free(arg->defvalue.array.data);
2406              else if (arg->ident == iVARIABLE
2407                       && ((arg->hasdefault & uSIZEOF) != 0
2408                           || (arg->hasdefault & uTAGOF) != 0))
2409                 free(arg->defvalue.size.symname);
2410              assert(arg->tags != NULL);
2411              free(arg->tags);
2412           }                     /* for */
2413         free(sym->dim.arglist);
2414      }                          /* if */
2415    assert(sym->refer != NULL);
2416    free(sym->refer);
2417    free(sym);
2418 }
2419
2420 void
2421 delete_symbol(symbol * root, symbol * sym)
2422 {
2423    /* find the symbol and its predecessor
2424     * (this function assumes that you will never delete a symbol that is not
2425     * in the table pointed at by "root")
2426     */
2427    assert(root != sym);
2428    while (root->next != sym)
2429      {
2430         root = root->next;
2431         assert(root != NULL);
2432      }                          /* while */
2433
2434    /* unlink it, then free it */
2435    root->next = sym->next;
2436    free_symbol(sym);
2437 }
2438
2439 void
2440 delete_symbols(symbol * root, int level, int delete_labels,
2441                int delete_functions)
2442 {
2443    symbol             *sym;
2444
2445    /* erase only the symbols with a deeper nesting level than the
2446     * specified nesting level */
2447    while (root->next)
2448      {
2449         sym = root->next;
2450         if (sym->compound < level)
2451            break;
2452         if ((delete_labels || sym->ident != iLABEL)
2453             && (delete_functions || sym->ident != iFUNCTN
2454                 || (sym->usage & uNATIVE) != 0) && (delete_functions
2455                                                     || sym->ident != iCONSTEXPR
2456                                                     || (sym->usage & uPREDEF) ==
2457                                                     0) && (delete_functions
2458                                                            || (sym->ident !=
2459                                                                iVARIABLE
2460                                                                && sym->ident !=
2461                                                                iARRAY)))
2462           {
2463              root->next = sym->next;
2464              free_symbol(sym);
2465           }
2466         else
2467           {
2468              /* if the function was prototyped, but not implemented in this source,
2469               * mark it as such, so that its use can be flagged
2470               */
2471              if (sym->ident == iFUNCTN && (sym->usage & uDEFINE) == 0)
2472                 sym->usage |= uMISSING;
2473              if (sym->ident == iFUNCTN || sym->ident == iVARIABLE
2474                  || sym->ident == iARRAY)
2475                 sym->usage &= ~uDEFINE; /* clear "defined" flag */
2476              /* for user defined operators, also remove the "prototyped" flag, as
2477               * user-defined operators *must* be declared before use
2478               */
2479              if (sym->ident == iFUNCTN && !sc_isalpha(*sym->name)
2480                  && *sym->name != '_' && *sym->name != PUBLIC_CHAR)
2481                 sym->usage &= ~uPROTOTYPED;
2482              root = sym;        /* skip the symbol */
2483           }                     /* if */
2484      }                          /* if */
2485 }
2486
2487 /* The purpose of the hash is to reduce the frequency of a "name"
2488  * comparison (which is costly). There is little interest in avoiding
2489  * clusters in similar names, which is why this function is plain simple.
2490  */
2491 unsigned int
2492 namehash(char *name)
2493 {
2494    unsigned char      *ptr = (unsigned char *)name;
2495    int                 len = strlen(name);
2496
2497    if (len == 0)
2498       return 0L;
2499    assert(len < 256);
2500    return (len << 24Lu) + (ptr[0] << 16Lu) + (ptr[len - 1] << 8Lu) +
2501       (ptr[len >> 1Lu]);
2502 }
2503
2504 static symbol      *
2505 find_symbol(symbol * root, char *name, int fnumber)
2506 {
2507    symbol             *ptr = root->next;
2508    unsigned long       hash = namehash(name);
2509
2510    while (ptr)
2511      {
2512         if (hash == ptr->hash && strcmp(name, ptr->name) == 0
2513             && !ptr->parent && (ptr->fnumber < 0
2514                                        || ptr->fnumber == fnumber))
2515            return ptr;
2516         ptr = ptr->next;
2517      }                          /* while */
2518    return NULL;
2519 }
2520
2521 static symbol      *
2522 find_symbol_child(symbol * root, symbol * sym)
2523 {
2524    symbol             *ptr = root->next;
2525
2526    while (ptr)
2527      {
2528         if (ptr->parent == sym)
2529            return ptr;
2530         ptr = ptr->next;
2531      }                          /* while */
2532    return NULL;
2533 }
2534
2535 /* Adds "bywhom" to the list of referrers of "entry". Typically,
2536  * bywhom will be the function that uses a variable or that calls
2537  * the function.
2538  */
2539 int
2540 refer_symbol(symbol * entry, symbol * bywhom)
2541 {
2542    int                 count;
2543
2544    assert(bywhom != NULL);      /* it makes no sense to add a "void" referrer */
2545    assert(entry != NULL);
2546    assert(entry->refer != NULL);
2547
2548    /* see if it is already there */
2549    for (count = 0; count < entry->numrefers && entry->refer[count] != bywhom;
2550         count++)
2551       /* nothing */ ;
2552    if (count < entry->numrefers)
2553      {
2554         assert(entry->refer[count] == bywhom);
2555         return TRUE;
2556      }                          /* if */
2557
2558    /* see if there is an empty spot in the referrer list */
2559    for (count = 0; count < entry->numrefers && entry->refer[count];
2560         count++)
2561       /* nothing */ ;
2562    assert(count <= entry->numrefers);
2563    if (count == entry->numrefers)
2564      {
2565         symbol            **refer;
2566         int                 newsize = 2 * entry->numrefers;
2567
2568         assert(newsize > 0);
2569         /* grow the referrer list */
2570         refer = (symbol **) realloc(entry->refer, newsize * sizeof(symbol *));
2571         if (!refer)
2572            return FALSE;        /* insufficient memory */
2573         /* initialize the new entries */
2574         entry->refer = refer;
2575         for (count = entry->numrefers; count < newsize; count++)
2576            entry->refer[count] = NULL;
2577         count = entry->numrefers;       /* first empty spot */
2578         entry->numrefers = newsize;
2579      }                          /* if */
2580
2581    /* add the referrer */
2582    assert(entry->refer[count] == NULL);
2583    entry->refer[count] = bywhom;
2584    return TRUE;
2585 }
2586
2587 void
2588 markusage(symbol * sym, int usage)
2589 {
2590    sym->usage |= (char)usage;
2591    /* check if (global) reference must be added to the symbol */
2592    if ((usage & (uREAD | uWRITTEN)) != 0)
2593      {
2594         /* only do this for global symbols */
2595         if (sym->vclass == sGLOBAL)
2596           {
2597              /* "curfunc" should always be valid, since statements may not occurs
2598               * outside functions; in the case of syntax errors, however, the
2599               * compiler may arrive through this function
2600               */
2601              if (curfunc)
2602                 refer_symbol(sym, curfunc);
2603           }                     /* if */
2604      }                          /* if */
2605 }
2606
2607 /*  findglb
2608  *
2609  *  Returns a pointer to the global symbol (if found) or NULL (if not found)
2610  */
2611 symbol     *
2612 findglb(char *name)
2613 {
2614    return find_symbol(&glbtab, name, fcurrent);
2615 }
2616
2617 /*  findloc
2618  *
2619  *  Returns a pointer to the local symbol (if found) or NULL (if not found).
2620  *  See add_symbol() how the deepest nesting level is searched first.
2621  */
2622 symbol     *
2623 findloc(char *name)
2624 {
2625    return find_symbol(&loctab, name, -1);
2626 }
2627
2628 symbol     *
2629 findconst(char *name)
2630 {
2631    symbol             *sym;
2632
2633    sym = find_symbol(&loctab, name, -1);        /* try local symbols first */
2634    if (!sym || sym->ident != iCONSTEXPR)        /* not found, or not a constant */
2635       sym = find_symbol(&glbtab, name, fcurrent);
2636    if (!sym || sym->ident != iCONSTEXPR)
2637       return NULL;
2638    assert(sym->parent == NULL); /* constants have no hierarchy */
2639    return sym;
2640 }
2641
2642 symbol     *
2643 finddepend(symbol * parent)
2644 {
2645    symbol             *sym;
2646
2647    sym = find_symbol_child(&loctab, parent);    /* try local symbols first */
2648    if (!sym)            /* not found */
2649       sym = find_symbol_child(&glbtab, parent);
2650    return sym;
2651 }
2652
2653 /*  addsym
2654  *
2655  *  Adds a symbol to the symbol table (either global or local variables,
2656  *  or global and local constants).
2657  */
2658 symbol     *
2659 addsym(char *name, cell addr, int ident, int vclass, int tag, int usage)
2660 {
2661    symbol              entry, **refer;
2662
2663    /* global variables/constants/functions may only be defined once */
2664    assert(!(ident == iFUNCTN || ident == iCONSTEXPR) || vclass != sGLOBAL
2665           || findglb(name) == NULL);
2666    /* labels may only be defined once */
2667    assert(ident != iLABEL || findloc(name) == NULL);
2668
2669    /* create an empty referrer list */
2670    if (!(refer = (symbol **)malloc(sizeof(symbol *))))
2671      {
2672         error(103);             /* insufficient memory */
2673         return NULL;
2674      }                          /* if */
2675    *refer = NULL;
2676
2677    /* first fill in the entry */
2678    strcpy(entry.name, name);
2679    entry.hash = namehash(name);
2680    entry.addr = addr;
2681    entry.vclass = (char)vclass;
2682    entry.ident = (char)ident;
2683    entry.tag = tag;
2684    entry.usage = (char)usage;
2685    entry.compound = 0;          /* may be overridden later */
2686    entry.fnumber = -1;          /* assume global visibility (ignored for local symbols) */
2687    entry.numrefers = 1;
2688    entry.refer = refer;
2689    entry.parent = NULL;
2690
2691    /* then insert it in the list */
2692    if (vclass == sGLOBAL)
2693       return add_symbol(&glbtab, &entry, TRUE);
2694    else
2695       return add_symbol(&loctab, &entry, FALSE);
2696 }
2697
2698 symbol     *
2699 addvariable(char *name, cell addr, int ident, int vclass, int tag,
2700             int dim[], int numdim, int idxtag[])
2701 {
2702    symbol             *sym, *parent, *top;
2703    int                 level;
2704
2705    /* global variables may only be defined once */
2706    assert(vclass != sGLOBAL || (sym = findglb(name)) == NULL
2707           || (sym->usage & uDEFINE) == 0);
2708
2709    if (ident == iARRAY || ident == iREFARRAY)
2710      {
2711         parent = NULL;
2712         sym = NULL;             /* to avoid a compiler warning */
2713         for (level = 0; level < numdim; level++)
2714           {
2715              top = addsym(name, addr, ident, vclass, tag, uDEFINE);
2716              top->dim.array.length = dim[level];
2717              top->dim.array.level = (short)(numdim - level - 1);
2718              top->x.idxtag = idxtag[level];
2719              top->parent = parent;
2720              parent = top;
2721              if (level == 0)
2722                 sym = top;
2723           }                     /* for */
2724      }
2725    else
2726      {
2727         sym = addsym(name, addr, ident, vclass, tag, uDEFINE);
2728      }                          /* if */
2729    return sym;
2730 }
2731
2732 /*  getlabel
2733  *
2734  *  Return next available internal label number.
2735  */
2736 int
2737 getlabel(void)
2738 {
2739    return labnum++;
2740 }
2741
2742 /*  itoh
2743  *
2744  *  Converts a number to a hexadecimal string and returns a pointer to that
2745  *  string.
2746  */
2747 char       *
2748 itoh(ucell val)
2749 {
2750    static char         itohstr[15];     /* hex number is 10 characters long at most */
2751    char               *ptr;
2752    int                 i, nibble[8];    /* a 32-bit hexadecimal cell has 8 nibbles */
2753    int                 max;
2754
2755 #if defined(BIT16)
2756    max = 4;
2757 #else
2758    max = 8;
2759 #endif
2760    ptr = itohstr;
2761    for (i = 0; i < max; i += 1)
2762      {
2763         nibble[i] = (int)(val & 0x0f);  /* nibble 0 is lowest nibble */
2764         val >>= 4;
2765      }                          /* endfor */
2766    i = max - 1;
2767    while (nibble[i] == 0 && i > 0)      /* search for highest non-zero nibble */
2768       i -= 1;
2769    while (i >= 0)
2770      {
2771         if (nibble[i] >= 10)
2772            *ptr++ = (char)('a' + (nibble[i] - 10));
2773         else
2774            *ptr++ = (char)('0' + nibble[i]);
2775         i -= 1;
2776      }                          /* while */
2777    *ptr = '\0';                 /* and a zero-terminator */
2778    return itohstr;
2779 }