src/bin/embryo_cc_sc2.c

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