src/bin/embryo_cc_sc2.c

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