parser-scanner.c

     
   1  //! @file parser-scanner.c
   2  //! @author J. Marcel van der Veer
   3  
   4  //! @section Copyright
   5  //!
   6  //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
   7  //! Copyright 2001-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
   8  
   9  //! @section License
  10  //!
  11  //! This program is free software; you can redistribute it and/or modify it 
  12  //! under the terms of the GNU General Public License as published by the 
  13  //! Free Software Foundation; either version 3 of the License, or 
  14  //! (at your option) any later version.
  15  //!
  16  //! This program is distributed in the hope that it will be useful, but 
  17  //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
  18  //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
  19  //! more details. You should have received a copy of the GNU General Public 
  20  //! License along with this program. If not, see [http://www.gnu.org/licenses/].
  21  
  22  //! @section Synopsis 
  23  //!
  24  //! Context-dependent Algol 68 tokeniser.
  25  
  26  #include "a68g.h"
  27  #include "a68g-parser.h"
  28  #include "a68g-prelude.h"
  29  #include "a68g-options.h"
  30  #include "a68g-environ.h"
  31  
  32  // Macros.
  33  
  34  #define SCAN_DIGITS(c)\
  35    while (IS_DIGIT (c)) {\
  36      (sym++)[0] = (c);\
  37      (c) = next_char (ref_l, ref_s, A68_TRUE);\
  38    }
  39  
  40  #define SCAN_EXPONENT_PART(c)\
  41    (sym++)[0] = EXPONENT_CHAR;\
  42    (c) = next_char (ref_l, ref_s, A68_TRUE);\
  43    if ((c) == '+' || (c) == '-') {\
  44      (sym++)[0] = (c);\
  45      (c) = next_char (ref_l, ref_s, A68_TRUE);\
  46    }\
  47    SCAN_ERROR (!IS_DIGIT (c), *start_l, *start_c, ERROR_EXPONENT_DIGIT);\
  48    SCAN_DIGITS (c)
  49  
  50  //! @brief Save scanner state, for character look-ahead.
  51  
  52  void save_state (LINE_T * ref_l, char *ref_s, char ch)
  53  {
  54    SCAN_STATE_L (&A68_JOB) = ref_l;
  55    SCAN_STATE_S (&A68_JOB) = ref_s;
  56    SCAN_STATE_C (&A68_JOB) = ch;
  57  }
  58  
  59  //! @brief Restore scanner state, for character look-ahead.
  60  
  61  void restore_state (LINE_T ** ref_l, char **ref_s, char *ch)
  62  {
  63    *ref_l = SCAN_STATE_L (&A68_JOB);
  64    *ref_s = SCAN_STATE_S (&A68_JOB);
  65    *ch = SCAN_STATE_C (&A68_JOB);
  66  }
  67  
  68  //! @brief New_source_line.
  69  
  70  LINE_T *new_source_line (void)
  71  {
  72    LINE_T *z = (LINE_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (LINE_T));
  73    MARKER (z)[0] = NULL_CHAR;
  74    STRING (z) = NO_TEXT;
  75    FILENAME (z) = NO_TEXT;
  76    DIAGNOSTICS (z) = NO_DIAGNOSTIC;
  77    NUMBER (z) = 0;
  78    PRINT_STATUS (z) = 0;
  79    LIST (z) = A68_TRUE;
  80    NEXT (z) = NO_LINE;
  81    PREVIOUS (z) = NO_LINE;
  82    return z;
  83  }
  84  
  85  //! @brief Append a source line to the internal source file.
  86  
  87  void append_source_line (char *str, LINE_T ** ref_l, int *line_num, char *filename)
  88  {
  89    LINE_T *z = new_source_line ();
  90  // Allow shell command in first line, f.i. "#!/usr/share/bin/a68g".
  91    if (*line_num == 1) {
  92      if (strlen (str) >= 2 && strncmp (str, "#!", 2) == 0) {
  93        ABEND (strstr (str, "run-script") != NO_TEXT, ERROR_SHELL_SCRIPT, __func__);
  94        (*line_num)++;
  95        return;
  96      }
  97    }
  98  // Link line into the chain.
  99    STRING (z) = new_fixed_string (str);
 100    FILENAME (z) = filename;
 101    NUMBER (z) = (*line_num)++;
 102    PRINT_STATUS (z) = NOT_PRINTED;
 103    LIST (z) = A68_TRUE;
 104    DIAGNOSTICS (z) = NO_DIAGNOSTIC;
 105    NEXT (z) = NO_LINE;
 106    PREVIOUS (z) = *ref_l;
 107    if (TOP_LINE (&A68_JOB) == NO_LINE) {
 108      TOP_LINE (&A68_JOB) = z;
 109    }
 110    if (*ref_l != NO_LINE) {
 111      NEXT (*ref_l) = z;
 112    }
 113    *ref_l = z;
 114  }
 115  
 116  // Scanner, tokenises the source code.
 117  
 118  //! @brief Whether ch is unworthy.
 119  
 120  void unworthy (LINE_T * u, char *v, char ch)
 121  {
 122    if (IS_PRINT (ch)) {
 123      ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "*%s", ERROR_UNWORTHY_CHARACTER) >= 0);
 124    } else {
 125      ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "*%s %s", ERROR_UNWORTHY_CHARACTER, ctrl_char (ch)) >= 0);
 126    }
 127    scan_error (u, v, A68 (edit_line));
 128  }
 129  
 130  //! @brief Concatenate lines that terminate in '\' with next line.
 131  
 132  void concatenate_lines (LINE_T * top)
 133  {
 134    LINE_T *q;
 135  // Work from bottom backwards.
 136    for (q = top; q != NO_LINE && NEXT (q) != NO_LINE; q = NEXT (q)) {
 137      ;
 138    }
 139    for (; q != NO_LINE; BACKWARD (q)) {
 140      char *z = STRING (q);
 141      int len = (int) strlen (z);
 142      if (len >= 2 && z[len - 2] == BACKSLASH_CHAR && z[len - 1] == NEWLINE_CHAR && NEXT (q) != NO_LINE && STRING (NEXT (q)) != NO_TEXT) {
 143        z[len - 2] = NULL_CHAR;
 144        len += (int) strlen (STRING (NEXT (q)));
 145        z = (char *) get_fixed_heap_space ((size_t) (len + 1));
 146        bufcpy (z, STRING (q), len + 1);
 147        bufcat (z, STRING (NEXT (q)), len + 1);
 148        STRING (NEXT (q))[0] = NULL_CHAR;
 149        STRING (q) = z;
 150      }
 151    }
 152  }
 153  
 154  //! @brief Whether u is bold tag v, independent of stropping regime.
 155  
 156  BOOL_T is_bold (char *u, char *v)
 157  {
 158    unt len = (unt) strlen (v);
 159    if (OPTION_STROPPING (&A68_JOB) == QUOTE_STROPPING) {
 160      if (u[0] == '\'') {
 161        return (BOOL_T) (strncmp (++u, v, len) == 0 && u[len] == '\'');
 162      } else {
 163        return A68_FALSE;
 164      }
 165    } else {
 166      return (BOOL_T) (strncmp (u, v, len) == 0 && !IS_UPPER (u[len]));
 167    }
 168  }
 169  
 170  //! @brief Skip string.
 171  
 172  BOOL_T skip_string (LINE_T ** top, char **ch)
 173  {
 174    LINE_T *u = *top;
 175    char *v = *ch;
 176    v++;
 177    while (u != NO_LINE) {
 178      while (v[0] != NULL_CHAR) {
 179        if (v[0] == QUOTE_CHAR && v[1] != QUOTE_CHAR) {
 180          *top = u;
 181          *ch = &v[1];
 182          return A68_TRUE;
 183        } else if (v[0] == QUOTE_CHAR && v[1] == QUOTE_CHAR) {
 184          v += 2;
 185        } else {
 186          v++;
 187        }
 188      }
 189      FORWARD (u);
 190      if (u != NO_LINE) {
 191        v = &(STRING (u)[0]);
 192      } else {
 193        v = NO_TEXT;
 194      }
 195    }
 196    return A68_FALSE;
 197  }
 198  
 199  //! @brief Skip comment.
 200  
 201  BOOL_T skip_comment (LINE_T ** top, char **ch, int delim)
 202  {
 203    LINE_T *u = *top;
 204    char *v = *ch;
 205    v++;
 206    while (u != NO_LINE) {
 207      while (v[0] != NULL_CHAR) {
 208        if (is_bold (v, "COMMENT") && delim == BOLD_COMMENT_SYMBOL) {
 209          *top = u;
 210          *ch = &v[1];
 211          return A68_TRUE;
 212        } else if (is_bold (v, "CO") && delim == STYLE_I_COMMENT_SYMBOL) {
 213          *top = u;
 214          *ch = &v[1];
 215          return A68_TRUE;
 216        } else if (v[0] == '#' && delim == STYLE_II_COMMENT_SYMBOL) {
 217          *top = u;
 218          *ch = &v[1];
 219          return A68_TRUE;
 220        } else {
 221          v++;
 222        }
 223      }
 224      FORWARD (u);
 225      if (u != NO_LINE) {
 226        v = &(STRING (u)[0]);
 227      } else {
 228        v = NO_TEXT;
 229      }
 230    }
 231    return A68_FALSE;
 232  }
 233  
 234  //! @brief Skip rest of pragmat.
 235  
 236  BOOL_T skip_pragmat (LINE_T ** top, char **ch, int delim, BOOL_T whitespace)
 237  {
 238    LINE_T *u = *top;
 239    char *v = *ch;
 240    while (u != NO_LINE) {
 241      while (v[0] != NULL_CHAR) {
 242        if (is_bold (v, "PRAGMAT") && delim == BOLD_PRAGMAT_SYMBOL) {
 243          *top = u;
 244          *ch = &v[1];
 245          return A68_TRUE;
 246        } else if (is_bold (v, "PR") && delim == STYLE_I_PRAGMAT_SYMBOL) {
 247          *top = u;
 248          *ch = &v[1];
 249          return A68_TRUE;
 250        } else {
 251          if (whitespace && !IS_SPACE (v[0]) && v[0] != NEWLINE_CHAR) {
 252            scan_error (u, v, ERROR_PRAGMENT);
 253          } else if (IS_UPPER (v[0])) {
 254  // Skip a bold word as you may trigger on REPR, for instance ...
 255            while (IS_UPPER (v[0])) {
 256              v++;
 257            }
 258          } else {
 259            v++;
 260          }
 261        }
 262      }
 263      FORWARD (u);
 264      if (u != NO_LINE) {
 265        v = &(STRING (u)[0]);
 266      } else {
 267        v = NO_TEXT;
 268      }
 269    }
 270    return A68_FALSE;
 271  }
 272  
 273  //! @brief Return pointer to next token within pragmat.
 274  
 275  char *get_pragmat_item (LINE_T ** top, char **ch)
 276  {
 277    LINE_T *u = *top;
 278    char *v = *ch;
 279    while (u != NO_LINE) {
 280      while (v[0] != NULL_CHAR) {
 281        if (!IS_SPACE (v[0]) && v[0] != NEWLINE_CHAR) {
 282          *top = u;
 283          *ch = v;
 284          return v;
 285        } else {
 286          v++;
 287        }
 288      }
 289      FORWARD (u);
 290      if (u != NO_LINE) {
 291        v = &(STRING (u)[0]);
 292      } else {
 293        v = NO_TEXT;
 294      }
 295    }
 296    return NO_TEXT;
 297  }
 298  
 299  //! @brief Case insensitive strncmp for at most the number of chars in 'v'.
 300  
 301  int streq (char *u, char *v)
 302  {
 303    int diff;
 304    for (diff = 0; diff == 0 && u[0] != NULL_CHAR && v[0] != NULL_CHAR; u++, v++) {
 305      diff = ((int) TO_LOWER (u[0])) - ((int) TO_LOWER (v[0]));
 306    }
 307    return diff;
 308  }
 309  
 310  //! @brief Scan for next pragmat and yield first pragmat item.
 311  
 312  char *next_preprocessor_item (LINE_T ** top, char **ch, int *delim)
 313  {
 314    LINE_T *u = *top;
 315    char *v = *ch;
 316    *delim = 0;
 317    while (u != NO_LINE) {
 318      while (v[0] != NULL_CHAR) {
 319        LINE_T *start_l = u;
 320        char *start_c = v;
 321  // STRINGs must be skipped.
 322        if (v[0] == QUOTE_CHAR) {
 323          SCAN_ERROR (!skip_string (&u, &v), start_l, start_c, ERROR_UNTERMINATED_STRING);
 324        }
 325  // COMMENTS must be skipped.
 326        else if (is_bold (v, "COMMENT")) {
 327          SCAN_ERROR (!skip_comment (&u, &v, BOLD_COMMENT_SYMBOL), start_l, start_c, ERROR_UNTERMINATED_COMMENT);
 328        } else if (is_bold (v, "CO")) {
 329          SCAN_ERROR (!skip_comment (&u, &v, STYLE_I_COMMENT_SYMBOL), start_l, start_c, ERROR_UNTERMINATED_COMMENT);
 330        } else if (v[0] == '#') {
 331          SCAN_ERROR (!skip_comment (&u, &v, STYLE_II_COMMENT_SYMBOL), start_l, start_c, ERROR_UNTERMINATED_COMMENT);
 332        } else if (is_bold (v, "PRAGMAT") || is_bold (v, "PR")) {
 333  // We caught a PRAGMAT.
 334          char *item;
 335          if (is_bold (v, "PRAGMAT")) {
 336            *delim = BOLD_PRAGMAT_SYMBOL;
 337            v = &v[strlen ("PRAGMAT")];
 338          } else if (is_bold (v, "PR")) {
 339            *delim = STYLE_I_PRAGMAT_SYMBOL;
 340            v = &v[strlen ("PR")];
 341          }
 342          item = get_pragmat_item (&u, &v);
 343          SCAN_ERROR (item == NO_TEXT, start_l, start_c, ERROR_UNTERMINATED_PRAGMAT);
 344  // Item "preprocessor" restarts preprocessing if it is off.
 345          if (A68_PARSER (no_preprocessing) && streq (item, "PREPROCESSOR") == 0) {
 346            A68_PARSER (no_preprocessing) = A68_FALSE;
 347            SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_TRUE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT);
 348          }
 349  // If preprocessing is switched off, we idle to closing bracket.
 350          else if (A68_PARSER (no_preprocessing)) {
 351            SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_FALSE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT);
 352          }
 353  // Item "nopreprocessor" stops preprocessing if it is on.
 354          if (streq (item, "NOPREPROCESSOR") == 0) {
 355            A68_PARSER (no_preprocessing) = A68_TRUE;
 356            SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_TRUE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT);
 357          }
 358  // Item "INCLUDE" includes a file.
 359          else if (streq (item, "INCLUDE") == 0) {
 360            *top = u;
 361            *ch = v;
 362            return item;
 363          }
 364  // Item "READ" includes a file.
 365          else if (streq (item, "READ") == 0) {
 366            *top = u;
 367            *ch = v;
 368            return item;
 369          }
 370  // Unrecognised item - probably options handled later by the tokeniser.
 371          else {
 372            SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_FALSE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT);
 373          }
 374        } else if (IS_UPPER (v[0])) {
 375  // Skip a bold word as you may trigger on REPR, for instance ...
 376          while (IS_UPPER (v[0])) {
 377            v++;
 378          }
 379        } else {
 380          v++;
 381        }
 382      }
 383      FORWARD (u);
 384      if (u != NO_LINE) {
 385        v = &(STRING (u)[0]);
 386      } else {
 387        v = NO_TEXT;
 388      }
 389    }
 390    *top = u;
 391    *ch = v;
 392    return NO_TEXT;
 393  }
 394  
 395  //! @brief Include files.
 396  
 397  void include_files (LINE_T * top)
 398  {
 399  // include_files
 400  // 
 401  // syntax: PR read "filename" PR
 402  //         PR include "filename" PR
 403  // 
 404  // The file gets inserted before the line containing the pragmat. In this way
 405  // correct line numbers are preserved which helps diagnostics. A file that has
 406  // been included will not be included a second time - it will be ignored. 
 407  // A rigorous fail-safe, but there is no mechanism to prevent recursive includes 
 408  // in A68 source code. User reports do not indicate sophisticated use of INCLUDE, 
 409  // so this is fine for now.
 410  // TODO - some day we might need `app', analogous to `cpp'.
 411    BOOL_T make_pass = A68_TRUE;
 412    while (make_pass) {
 413      LINE_T *s, *t, *u = top;
 414      char *v = &(STRING (u)[0]);
 415      make_pass = A68_FALSE;
 416      errno = 0;
 417      while (u != NO_LINE) {
 418        int pr_lim;
 419        char *item = next_preprocessor_item (&u, &v, &pr_lim);
 420        LINE_T *start_l = u;
 421        char *start_c = v;
 422  // Search for PR include "filename" PR.
 423        if (item != NO_TEXT && (streq (item, "INCLUDE") == 0 || streq (item, "READ") == 0)) {
 424          FILE_T fd;
 425          int n, linum, fsize, k, bytes_read, fnwid;
 426          char *fbuf, delim;
 427          BUFFER fnb;
 428          char *fn;
 429  // Skip to filename.
 430          while (IS_ALPHA (v[0])) {
 431            v++;
 432          }
 433          while (IS_SPACE (v[0])) {
 434            v++;
 435          }
 436  // Scan quoted filename.
 437          SCAN_ERROR ((v[0] != QUOTE_CHAR && v[0] != '\''), start_l, start_c, ERROR_INCORRECT_FILENAME);
 438          delim = (v++)[0];
 439          n = 0;
 440          fnb[0] = NULL_CHAR;
 441  // Scan Algol 68 string (note: "" denotes a ", while in C it concatenates).
 442          do {
 443            SCAN_ERROR (EOL (v[0]), start_l, start_c, ERROR_INCORRECT_FILENAME);
 444            SCAN_ERROR (n == BUFFER_SIZE - 1, start_l, start_c, ERROR_INCORRECT_FILENAME);
 445            if (v[0] == delim) {
 446              while (v[0] == delim && v[1] == delim) {
 447                SCAN_ERROR (n == BUFFER_SIZE - 1, start_l, start_c, ERROR_INCORRECT_FILENAME);
 448                fnb[n++] = delim;
 449                fnb[n] = NULL_CHAR;
 450                v += 2;
 451              }
 452            } else if (IS_PRINT (v[0])) {
 453              fnb[n++] = *(v++);
 454              fnb[n] = NULL_CHAR;
 455            } else {
 456              SCAN_ERROR (A68_TRUE, start_l, start_c, ERROR_INCORRECT_FILENAME);
 457            }
 458          } while (v[0] != delim);
 459  // Insist that the pragmat is closed properly.
 460          v = &v[1];
 461          SCAN_ERROR (!skip_pragmat (&u, &v, pr_lim, A68_TRUE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT);
 462          SCAN_ERROR (n == 0, start_l, start_c, ERROR_INCORRECT_FILENAME);
 463  // Make the name relative to the position of the source file (C preprocessor standard).
 464          if (FILENAME (u) != NO_TEXT) {
 465            fn = a68_relpath (a68_dirname (FILENAME (u)), a68_dirname (fnb), a68_basename (fnb));
 466          } else {
 467            fn = a68_relpath (FILE_PATH (&A68_JOB), a68_dirname (fnb), a68_basename (fnb));
 468          }
 469  // Do not check errno, since errno may be undefined here after a successful call.
 470          if (fn != NO_TEXT) {
 471            bufcpy (fnb, fn, BUFFER_SIZE);
 472          } else {
 473            SCAN_ERROR (A68_TRUE, NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_INCLUDE_OPEN);
 474          }
 475          fnwid = (int) strlen (fnb) + 1;
 476          fn = (char *) get_fixed_heap_space ((size_t) fnwid);
 477          bufcpy (fn, fnb, fnwid);
 478  // Ignore the file when included more than once.
 479          for (t = top; t != NO_LINE; t = NEXT (t)) {
 480            if (strcmp (FILENAME (t), fn) == 0) {
 481              goto search_next_pragmat;
 482            }
 483          }
 484          t = NO_LINE;
 485  // Access the file.
 486          errno = 0;
 487          fd = open (fn, O_RDONLY | O_BINARY);
 488          SCAN_ERROR (fd == -1, start_l, start_c, ERROR_SOURCE_FILE_INCLUDE_OPEN);
 489          errno = 0;
 490          fsize = (int) lseek (fd, 0, SEEK_END);
 491          ASSERT (fsize >= 0);
 492          SCAN_ERROR (errno != 0, start_l, start_c, ERROR_FILE_READ);
 493          fbuf = (char *) get_temp_heap_space ((unt) (8 + fsize));
 494          errno = 0;
 495          ASSERT (lseek (fd, 0, SEEK_SET) >= 0);
 496          SCAN_ERROR (errno != 0, start_l, start_c, ERROR_FILE_READ);
 497          errno = 0;
 498          bytes_read = (int) io_read (fd, fbuf, (size_t) fsize);
 499          SCAN_ERROR (errno != 0 || bytes_read != fsize, start_l, start_c, ERROR_FILE_READ);
 500  // Buffer still usable?.
 501          if (fsize > A68_PARSER (max_scan_buf_length)) {
 502            A68_PARSER (max_scan_buf_length) = fsize;
 503            A68_PARSER (scan_buf) = (char *) get_temp_heap_space ((unt) (8 + A68_PARSER (max_scan_buf_length)));
 504          }
 505  // Link all lines into the list.
 506          linum = 1;
 507          s = u;
 508          t = PREVIOUS (u);
 509          k = 0;
 510          if (fsize == 0) {
 511  // If file is empty, insert single empty line.
 512            A68_PARSER (scan_buf)[0] = NEWLINE_CHAR;
 513            A68_PARSER (scan_buf)[1] = NULL_CHAR;
 514            append_source_line (A68_PARSER (scan_buf), &t, &linum, fn);
 515          } else
 516            while (k < fsize) {
 517              n = 0;
 518              A68_PARSER (scan_buf)[0] = NULL_CHAR;
 519              while (k < fsize && fbuf[k] != NEWLINE_CHAR) {
 520                SCAN_ERROR ((IS_CNTRL (fbuf[k]) && !IS_SPACE (fbuf[k])) || fbuf[k] == STOP_CHAR, start_l, start_c, ERROR_FILE_INCLUDE_CTRL);
 521                A68_PARSER (scan_buf)[n++] = fbuf[k++];
 522                A68_PARSER (scan_buf)[n] = NULL_CHAR;
 523              }
 524              A68_PARSER (scan_buf)[n++] = NEWLINE_CHAR;
 525              A68_PARSER (scan_buf)[n] = NULL_CHAR;
 526              if (k < fsize) {
 527                k++;
 528              }
 529              append_source_line (A68_PARSER (scan_buf), &t, &linum, fn);
 530            }
 531  // Conclude and go find another include directive, if any.
 532          NEXT (t) = s;
 533          PREVIOUS (s) = t;
 534          concatenate_lines (top);
 535          ASSERT (close (fd) == 0);
 536          make_pass = A68_TRUE;
 537        }
 538      search_next_pragmat:_SKIP_;
 539      }
 540    }
 541  }
 542  
 543  //! @brief Size of source file.
 544  
 545  int get_source_size (void)
 546  {
 547    FILE_T f = FILE_SOURCE_FD (&A68_JOB);
 548  // This is why WIN32 must open as "read binary".
 549    return (int) lseek (f, 0, SEEK_END);
 550  }
 551  
 552  //! @brief Append environment source lines.
 553  
 554  void append_environ (char *str[], LINE_T ** ref_l, int *line_num, char *name)
 555  {
 556    for (int k = 0; str[k] != NO_TEXT; k++) {
 557      int zero_line_num = 0;
 558      (*line_num)++;
 559      append_source_line (str[k], ref_l, &zero_line_num, name);
 560    }
 561  }
 562  
 563  //! @brief Read script file and make internal copy.
 564  
 565  BOOL_T read_script_file (void)
 566  {
 567    LINE_T *ref_l = NO_LINE;
 568    int k, n, num;
 569    unt len;
 570    BOOL_T file_end = A68_FALSE;
 571    BUFFER filename, linenum;
 572    char ch, *fn, *line;
 573    char *buffer = (char *) get_temp_heap_space ((unt) (8 + A68_PARSER (source_file_size)));
 574    FILE_T source = FILE_SOURCE_FD (&A68_JOB);
 575    ABEND (source == -1, ERROR_ACTION, __func__);
 576    buffer[0] = NULL_CHAR;
 577    n = 0;
 578    len = (unt) (8 + A68_PARSER (source_file_size));
 579    buffer = (char *) get_temp_heap_space (len);
 580    ASSERT (lseek (source, 0, SEEK_SET) >= 0);
 581    while (!file_end) {
 582  // Read the original file name.
 583      filename[0] = NULL_CHAR;
 584      k = 0;
 585      if (io_read (source, &ch, 1) == 0) {
 586        file_end = A68_TRUE;
 587        continue;
 588      }
 589      while (ch != NEWLINE_CHAR) {
 590        filename[k++] = ch;
 591        ASSERT (io_read (source, &ch, 1) == 1);
 592      }
 593      filename[k] = NULL_CHAR;
 594      fn = TEXT (add_token (&A68 (top_token), filename));
 595  // Read the original file number.
 596      linenum[0] = NULL_CHAR;
 597      k = 0;
 598      ASSERT (io_read (source, &ch, 1) == 1);
 599      while (ch != NEWLINE_CHAR) {
 600        linenum[k++] = ch;
 601        ASSERT (io_read (source, &ch, 1) == 1);
 602      }
 603      linenum[k] = NULL_CHAR;
 604      num = (int) strtol (linenum, NO_VAR, 10);
 605      ABEND (errno == ERANGE, ERROR_INTERNAL_CONSISTENCY, __func__);
 606  // COPY original line into buffer.
 607      ASSERT (io_read (source, &ch, 1) == 1);
 608      line = &buffer[n];
 609      while (ch != NEWLINE_CHAR) {
 610        buffer[n++] = ch;
 611        ASSERT (io_read (source, &ch, 1) == 1);
 612        ABEND ((unt) n >= len, ERROR_ACTION, __func__);
 613      }
 614      buffer[n++] = NEWLINE_CHAR;
 615      buffer[n] = NULL_CHAR;
 616      append_source_line (line, &ref_l, &num, fn);
 617    }
 618    return A68_TRUE;
 619  }
 620  
 621  //! @brief Read source file and make internal copy.
 622  
 623  BOOL_T read_source_file (void)
 624  {
 625    LINE_T *ref_l = NO_LINE;
 626    int line_num = 0, k, bytes_read;
 627    ssize_t l;
 628    FILE_T f = FILE_SOURCE_FD (&A68_JOB);
 629    char **prelude_start, **postlude, *buffer;
 630  // Prelude.
 631    if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) {
 632      prelude_start = bold_prelude_start;
 633      postlude = bold_postlude;
 634    } else if (OPTION_STROPPING (&A68_JOB) == QUOTE_STROPPING) {
 635      prelude_start = quote_prelude_start;
 636      postlude = quote_postlude;
 637    } else {
 638      prelude_start = postlude = NO_VAR;
 639    }
 640    append_environ (prelude_start, &ref_l, &line_num, "prelude");
 641  // Read the file into a single buffer, so we save on system calls.
 642    line_num = 1;
 643    errno = 0;
 644    buffer = (char *) get_temp_heap_space ((unt) (8 + A68_PARSER (source_file_size)));
 645    ABEND (errno != 0 || buffer == NO_TEXT, ERROR_ALLOCATION, __func__);
 646    ASSERT (lseek (f, 0, SEEK_SET) >= 0);
 647    ABEND (errno != 0, ERROR_ACTION, __func__);
 648    errno = 0;
 649    bytes_read = (int) io_read (f, buffer, (size_t) A68_PARSER (source_file_size));
 650    ABEND (errno != 0 || bytes_read != A68_PARSER (source_file_size), ERROR_ACTION, __func__);
 651  // Link all lines into the list.
 652    k = 0;
 653    while (k < A68_PARSER (source_file_size)) {
 654      l = 0;
 655      A68_PARSER (scan_buf)[0] = NULL_CHAR;
 656      while (k < A68_PARSER (source_file_size) && buffer[k] != NEWLINE_CHAR) {
 657        if (k < A68_PARSER (source_file_size) - 1 && buffer[k] == CR_CHAR && buffer[k + 1] == NEWLINE_CHAR) {
 658          k++;
 659        } else {
 660          A68_PARSER (scan_buf)[l++] = buffer[k++];
 661          A68_PARSER (scan_buf)[l] = NULL_CHAR;
 662        }
 663      }
 664      A68_PARSER (scan_buf)[l++] = NEWLINE_CHAR;
 665      A68_PARSER (scan_buf)[l] = NULL_CHAR;
 666      if (k < A68_PARSER (source_file_size)) {
 667        k++;
 668      }
 669      append_source_line (A68_PARSER (scan_buf), &ref_l, &line_num, FILE_SOURCE_NAME (&A68_JOB));
 670      SCAN_ERROR (l != (ssize_t) strlen (A68_PARSER (scan_buf)), NO_LINE, NO_TEXT, ERROR_FILE_SOURCE_CTRL);
 671    }
 672  // Postlude.
 673    append_environ (postlude, &ref_l, &line_num, "postlude");
 674  // Concatenate lines.
 675    concatenate_lines (TOP_LINE (&A68_JOB));
 676  // Include files.
 677    include_files (TOP_LINE (&A68_JOB));
 678    return A68_TRUE;
 679  }
 680  
 681  //! @brief Next_char get next character from internal copy of source file.
 682  
 683  char next_char (LINE_T ** ref_l, char **ref_s, BOOL_T allow_typo)
 684  {
 685    char ch;
 686  #if defined (NO_TYPO)
 687    allow_typo = A68_FALSE;
 688  #endif
 689    LOW_STACK_ALERT (NO_NODE);
 690  // Source empty?.
 691    if (*ref_l == NO_LINE) {
 692      return STOP_CHAR;
 693    } else {
 694      LIST (*ref_l) = (BOOL_T) (OPTION_NODEMASK (&A68_JOB) & SOURCE_MASK ? A68_TRUE : A68_FALSE);
 695  // Take new line?.
 696      if ((*ref_s)[0] == NEWLINE_CHAR || (*ref_s)[0] == NULL_CHAR) {
 697        *ref_l = NEXT (*ref_l);
 698        if (*ref_l == NO_LINE) {
 699          return STOP_CHAR;
 700        }
 701        *ref_s = STRING (*ref_l);
 702      } else {
 703        (*ref_s)++;
 704      }
 705  // Deliver next char.
 706      ch = (*ref_s)[0];
 707      if (allow_typo && (IS_SPACE (ch) || ch == FORMFEED_CHAR)) {
 708        ch = next_char (ref_l, ref_s, allow_typo);
 709      }
 710      return ch;
 711    }
 712  }
 713  
 714  //! @brief Find first character that can start a valid symbol.
 715  
 716  void get_good_char (char *ref_c, LINE_T ** ref_l, char **ref_s)
 717  {
 718    while (*ref_c != STOP_CHAR && (IS_SPACE (*ref_c) || (*ref_c == NULL_CHAR))) {
 719      if (*ref_l != NO_LINE) {
 720        LIST (*ref_l) = (BOOL_T) (OPTION_NODEMASK (&A68_JOB) & SOURCE_MASK ? A68_TRUE : A68_FALSE);
 721      }
 722      *ref_c = next_char (ref_l, ref_s, A68_FALSE);
 723    }
 724  }
 725  
 726  //! @brief Handle a pragment (pragmat or comment).
 727  
 728  char *pragment (int type, LINE_T ** ref_l, char **ref_c)
 729  {
 730  #define INIT_BUFFER {chars_in_buf = 0; A68_PARSER (scan_buf)[chars_in_buf] = NULL_CHAR;}
 731  #define ADD_ONE_CHAR(ch) {A68_PARSER (scan_buf)[chars_in_buf ++] = ch; A68_PARSER (scan_buf)[chars_in_buf] = NULL_CHAR;}
 732    char c = **ref_c, *term_s = NO_TEXT, *start_c = *ref_c;
 733    char *z = NO_TEXT;
 734    LINE_T *start_l = *ref_l;
 735    int term_s_length, chars_in_buf;
 736    BOOL_T stop, pragmat = A68_FALSE;
 737  // Set terminator.
 738    if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) {
 739      if (type == STYLE_I_COMMENT_SYMBOL) {
 740        term_s = "CO";
 741      } else if (type == STYLE_II_COMMENT_SYMBOL) {
 742        term_s = "#";
 743      } else if (type == BOLD_COMMENT_SYMBOL) {
 744        term_s = "COMMENT";
 745      } else if (type == STYLE_I_PRAGMAT_SYMBOL) {
 746        term_s = "PR";
 747        pragmat = A68_TRUE;
 748      } else if (type == BOLD_PRAGMAT_SYMBOL) {
 749        term_s = "PRAGMAT";
 750        pragmat = A68_TRUE;
 751      }
 752    } else if (OPTION_STROPPING (&A68_JOB) == QUOTE_STROPPING) {
 753      if (type == STYLE_I_COMMENT_SYMBOL) {
 754        term_s = "'CO'";
 755      } else if (type == STYLE_II_COMMENT_SYMBOL) {
 756        term_s = "#";
 757      } else if (type == BOLD_COMMENT_SYMBOL) {
 758        term_s = "'COMMENT'";
 759      } else if (type == STYLE_I_PRAGMAT_SYMBOL) {
 760        term_s = "'PR'";
 761        pragmat = A68_TRUE;
 762      } else if (type == BOLD_PRAGMAT_SYMBOL) {
 763        term_s = "'PRAGMAT'";
 764        pragmat = A68_TRUE;
 765      }
 766    }
 767    term_s_length = (int) strlen (term_s);
 768  // Scan for terminator.
 769    INIT_BUFFER;
 770    stop = A68_FALSE;
 771    while (stop == A68_FALSE) {
 772      SCAN_ERROR (c == STOP_CHAR, start_l, start_c, ERROR_UNTERMINATED_PRAGMENT);
 773  // A ".." or '..' delimited string in a PRAGMAT.
 774      if (pragmat && (c == QUOTE_CHAR || (c == '\'' && OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING))) {
 775        char delim = c;
 776        BOOL_T eos = A68_FALSE;
 777        ADD_ONE_CHAR (c);
 778        c = next_char (ref_l, ref_c, A68_FALSE);
 779        while (!eos) {
 780          SCAN_ERROR (EOL (c), start_l, start_c, ERROR_LONG_STRING);
 781          if (c == delim) {
 782            ADD_ONE_CHAR (delim);
 783            save_state (*ref_l, *ref_c, c);
 784            c = next_char (ref_l, ref_c, A68_FALSE);
 785            if (c == delim) {
 786              c = next_char (ref_l, ref_c, A68_FALSE);
 787            } else {
 788              restore_state (ref_l, ref_c, &c);
 789              eos = A68_TRUE;
 790            }
 791          } else if (IS_PRINT (c)) {
 792            ADD_ONE_CHAR (c);
 793            c = next_char (ref_l, ref_c, A68_FALSE);
 794          } else {
 795            unworthy (start_l, start_c, c);
 796          }
 797        }
 798      } else if (EOL (c)) {
 799        ADD_ONE_CHAR (NEWLINE_CHAR);
 800      } else if (IS_PRINT (c) || IS_SPACE (c)) {
 801        ADD_ONE_CHAR (c);
 802      }
 803      if (chars_in_buf >= term_s_length) {
 804  // Check whether we encountered the terminator.
 805        stop = (BOOL_T) (strcmp (term_s, &(A68_PARSER (scan_buf)[chars_in_buf - term_s_length])) == 0);
 806      }
 807      c = next_char (ref_l, ref_c, A68_FALSE);
 808    }
 809    A68_PARSER (scan_buf)[chars_in_buf - term_s_length] = NULL_CHAR;
 810    z = new_string (term_s, A68_PARSER (scan_buf), term_s, NO_TEXT);
 811    if (type == STYLE_I_PRAGMAT_SYMBOL || type == BOLD_PRAGMAT_SYMBOL) {
 812      isolate_options (A68_PARSER (scan_buf), start_l);
 813    }
 814    return z;
 815  #undef ADD_ONE_CHAR
 816  #undef INIT_BUFFER
 817  }
 818  
 819  //! @brief Attribute for format item.
 820  
 821  int get_format_item (char ch)
 822  {
 823    switch (TO_LOWER (ch)) {
 824    case 'a': {
 825        return FORMAT_ITEM_A;
 826      }
 827    case 'b': {
 828        return FORMAT_ITEM_B;
 829      }
 830    case 'c': {
 831        return FORMAT_ITEM_C;
 832      }
 833    case 'd': {
 834        return FORMAT_ITEM_D;
 835      }
 836    case 'e': {
 837        return FORMAT_ITEM_E;
 838      }
 839    case 'f': {
 840        return FORMAT_ITEM_F;
 841      }
 842    case 'g': {
 843        return FORMAT_ITEM_G;
 844      }
 845    case 'h': {
 846        return FORMAT_ITEM_H;
 847      }
 848    case 'i': {
 849        return FORMAT_ITEM_I;
 850      }
 851    case 'j': {
 852        return FORMAT_ITEM_J;
 853      }
 854    case 'k': {
 855        return FORMAT_ITEM_K;
 856      }
 857    case 'l':
 858    case '/': {
 859        return FORMAT_ITEM_L;
 860      }
 861    case 'm': {
 862        return FORMAT_ITEM_M;
 863      }
 864    case 'n': {
 865        return FORMAT_ITEM_N;
 866      }
 867    case 'o': {
 868        return FORMAT_ITEM_O;
 869      }
 870    case 'p': {
 871        return FORMAT_ITEM_P;
 872      }
 873    case 'q': {
 874        return FORMAT_ITEM_Q;
 875      }
 876    case 'r': {
 877        return FORMAT_ITEM_R;
 878      }
 879    case 's': {
 880        return FORMAT_ITEM_S;
 881      }
 882    case 't': {
 883        return FORMAT_ITEM_T;
 884      }
 885    case 'u': {
 886        return FORMAT_ITEM_U;
 887      }
 888    case 'v': {
 889        return FORMAT_ITEM_V;
 890      }
 891    case 'w': {
 892        return FORMAT_ITEM_W;
 893      }
 894    case 'x': {
 895        return FORMAT_ITEM_X;
 896      }
 897    case 'y': {
 898        return FORMAT_ITEM_Y;
 899      }
 900    case 'z': {
 901        return FORMAT_ITEM_Z;
 902      }
 903    case '+': {
 904        return FORMAT_ITEM_PLUS;
 905      }
 906    case '-': {
 907        return FORMAT_ITEM_MINUS;
 908      }
 909    case POINT_CHAR: {
 910        return FORMAT_ITEM_POINT;
 911      }
 912    case '%': {
 913        return FORMAT_ITEM_ESCAPE;
 914      }
 915    default: {
 916        return 0;
 917      }
 918    }
 919  }
 920  
 921  //! @brief Whether input shows exponent character.
 922  
 923  BOOL_T is_exp_char (LINE_T ** ref_l, char **ref_s, char *ch)
 924  {
 925    BOOL_T ret = A68_FALSE;
 926    char exp_syms[3];
 927    if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) {
 928      exp_syms[0] = EXPONENT_CHAR;
 929      exp_syms[1] = (char) TO_UPPER (EXPONENT_CHAR);
 930      exp_syms[2] = NULL_CHAR;
 931    } else {
 932      exp_syms[0] = (char) TO_UPPER (EXPONENT_CHAR);
 933      exp_syms[1] = BACKSLASH_CHAR;
 934      exp_syms[2] = NULL_CHAR;
 935    }
 936    save_state (*ref_l, *ref_s, *ch);
 937    if (strchr (exp_syms, *ch) != NO_TEXT) {
 938      *ch = next_char (ref_l, ref_s, A68_TRUE);
 939      ret = (BOOL_T) (strchr ("+-0123456789", *ch) != NO_TEXT);
 940    }
 941    restore_state (ref_l, ref_s, ch);
 942    return ret;
 943  }
 944  
 945  //! @brief Whether input shows radix character.
 946  
 947  BOOL_T is_radix_char (LINE_T ** ref_l, char **ref_s, char *ch)
 948  {
 949    BOOL_T ret = A68_FALSE;
 950    save_state (*ref_l, *ref_s, *ch);
 951    if (OPTION_STROPPING (&A68_JOB) == QUOTE_STROPPING) {
 952      if (*ch == TO_UPPER (RADIX_CHAR)) {
 953        *ch = next_char (ref_l, ref_s, A68_TRUE);
 954        ret = (BOOL_T) (strchr ("0123456789ABCDEF", *ch) != NO_TEXT);
 955      }
 956    } else {
 957      if (*ch == RADIX_CHAR) {
 958        *ch = next_char (ref_l, ref_s, A68_TRUE);
 959        ret = (BOOL_T) (strchr ("0123456789abcdef", *ch) != NO_TEXT);
 960      }
 961    }
 962    restore_state (ref_l, ref_s, ch);
 963    return ret;
 964  }
 965  
 966  //! @brief Whether input shows decimal point.
 967  
 968  BOOL_T is_decimal_point (LINE_T ** ref_l, char **ref_s, char *ch)
 969  {
 970    BOOL_T ret = A68_FALSE;
 971    save_state (*ref_l, *ref_s, *ch);
 972    if (*ch == POINT_CHAR) {
 973      char exp_syms[3];
 974      if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) {
 975        exp_syms[0] = EXPONENT_CHAR;
 976        exp_syms[1] = (char) TO_UPPER (EXPONENT_CHAR);
 977        exp_syms[2] = NULL_CHAR;
 978      } else {
 979        exp_syms[0] = (char) TO_UPPER (EXPONENT_CHAR);
 980        exp_syms[1] = BACKSLASH_CHAR;
 981        exp_syms[2] = NULL_CHAR;
 982      }
 983      *ch = next_char (ref_l, ref_s, A68_TRUE);
 984      if (strchr (exp_syms, *ch) != NO_TEXT) {
 985        *ch = next_char (ref_l, ref_s, A68_TRUE);
 986        ret = (BOOL_T) (strchr ("+-0123456789", *ch) != NO_TEXT);
 987      } else {
 988        ret = (BOOL_T) (strchr ("0123456789", *ch) != NO_TEXT);
 989      }
 990    }
 991    restore_state (ref_l, ref_s, ch);
 992    return ret;
 993  }
 994  
 995  //! @brief Get next token from internal copy of source file..
 996  
 997  void get_next_token (BOOL_T in_format, LINE_T ** ref_l, char **ref_s, LINE_T ** start_l, char **start_c, int *att)
 998  {
 999    char c = **ref_s, *sym = A68_PARSER (scan_buf);
1000    sym[0] = NULL_CHAR;
1001    get_good_char (&c, ref_l, ref_s);
1002    *start_l = *ref_l;
1003    *start_c = *ref_s;
1004    if (c == STOP_CHAR) {
1005  // We are at EOF.
1006      (sym++)[0] = STOP_CHAR;
1007      sym[0] = NULL_CHAR;
1008      return;
1009    }
1010  // In a format.
1011    if (in_format) {
1012      char *format_items;
1013      if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) {
1014        format_items = "/%\\+-.abcdefghijklmnopqrstuvwxyz";
1015      } else if (OPTION_STROPPING (&A68_JOB) == QUOTE_STROPPING) {
1016        format_items = "/%\\+-.ABCDEFGHIJKLMNOPQRSTUVWXYZ";
1017      } else {
1018        format_items = "/%\\+-.abcdefghijklmnopqrstuvwxyz";
1019      }
1020      if (strchr (format_items, c) != NO_TEXT) {
1021  // General format items.
1022        (sym++)[0] = c;
1023        sym[0] = NULL_CHAR;
1024        *att = get_format_item (c);
1025        (void) next_char (ref_l, ref_s, A68_FALSE);
1026        return;
1027      }
1028      if (IS_DIGIT (c)) {
1029  // INT denotation for static replicator.
1030        SCAN_DIGITS (c);
1031        sym[0] = NULL_CHAR;
1032        *att = STATIC_REPLICATOR;
1033        return;
1034      }
1035    }
1036  // Not in a format.
1037    if (IS_UPPER (c)) {
1038      if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) {
1039  // Upper case word - bold tag.
1040        while (IS_UPPER (c) || c == '_') {
1041          (sym++)[0] = c;
1042          c = next_char (ref_l, ref_s, A68_FALSE);
1043        }
1044        sym[0] = NULL_CHAR;
1045        *att = BOLD_TAG;
1046      } else if (OPTION_STROPPING (&A68_JOB) == QUOTE_STROPPING) {
1047        while (IS_UPPER (c) || IS_DIGIT (c) || c == '_') {
1048          (sym++)[0] = c;
1049          c = next_char (ref_l, ref_s, A68_TRUE);
1050        }
1051        sym[0] = NULL_CHAR;
1052        *att = IDENTIFIER;
1053      }
1054    } else if (c == '\'') {
1055  // Quote, uppercase word, quote - bold tag.
1056      int k = 0;
1057      c = next_char (ref_l, ref_s, A68_FALSE);
1058      while (IS_UPPER (c) || IS_DIGIT (c) || c == '_') {
1059        (sym++)[0] = c;
1060        k++;
1061        c = next_char (ref_l, ref_s, A68_TRUE);
1062      }
1063      SCAN_ERROR (k == 0, *start_l, *start_c, ERROR_QUOTED_BOLD_TAG);
1064      sym[0] = NULL_CHAR;
1065      *att = BOLD_TAG;
1066  // Skip terminating quote, or complain if it is not there.
1067      SCAN_ERROR (c != '\'', *start_l, *start_c, ERROR_QUOTED_BOLD_TAG);
1068      c = next_char (ref_l, ref_s, A68_FALSE);
1069    } else if (IS_LOWER (c)) {
1070  // Lower case word - identifier.
1071      while (IS_LOWER (c) || IS_DIGIT (c) || c == '_') {
1072        (sym++)[0] = c;
1073        c = next_char (ref_l, ref_s, A68_TRUE);
1074      }
1075      sym[0] = NULL_CHAR;
1076      *att = IDENTIFIER;
1077    } else if (c == POINT_CHAR) {
1078  // Begins with a point symbol - point, dotdot, L REAL denotation.
1079      if (is_decimal_point (ref_l, ref_s, &c)) {
1080        (sym++)[0] = '0';
1081        (sym++)[0] = POINT_CHAR;
1082        c = next_char (ref_l, ref_s, A68_TRUE);
1083        SCAN_DIGITS (c);
1084        if (is_exp_char (ref_l, ref_s, &c)) {
1085          SCAN_EXPONENT_PART (c);
1086        }
1087        sym[0] = NULL_CHAR;
1088        *att = REAL_DENOTATION;
1089      } else {
1090        c = next_char (ref_l, ref_s, A68_TRUE);
1091        if (c == POINT_CHAR) {
1092          (sym++)[0] = POINT_CHAR;
1093          (sym++)[0] = POINT_CHAR;
1094          sym[0] = NULL_CHAR;
1095          *att = DOTDOT_SYMBOL;
1096          c = next_char (ref_l, ref_s, A68_FALSE);
1097        } else {
1098          (sym++)[0] = POINT_CHAR;
1099          sym[0] = NULL_CHAR;
1100          *att = POINT_SYMBOL;
1101        }
1102      }
1103    } else if (IS_DIGIT (c)) {
1104  // Something that begins with a digit - L INT denotation, L REAL denotation.
1105      SCAN_DIGITS (c);
1106      if (is_decimal_point (ref_l, ref_s, &c)) {
1107        c = next_char (ref_l, ref_s, A68_TRUE);
1108        if (is_exp_char (ref_l, ref_s, &c)) {
1109          (sym++)[0] = POINT_CHAR;
1110          (sym++)[0] = '0';
1111          SCAN_EXPONENT_PART (c);
1112          *att = REAL_DENOTATION;
1113        } else {
1114          (sym++)[0] = POINT_CHAR;
1115          SCAN_DIGITS (c);
1116          if (is_exp_char (ref_l, ref_s, &c)) {
1117            SCAN_EXPONENT_PART (c);
1118          }
1119          *att = REAL_DENOTATION;
1120        }
1121      } else if (is_exp_char (ref_l, ref_s, &c)) {
1122        SCAN_EXPONENT_PART (c);
1123        *att = REAL_DENOTATION;
1124      } else if (is_radix_char (ref_l, ref_s, &c)) {
1125        (sym++)[0] = c;
1126        c = next_char (ref_l, ref_s, A68_TRUE);
1127        if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) {
1128          while (IS_DIGIT (c) || strchr ("abcdef", c) != NO_TEXT) {
1129            (sym++)[0] = c;
1130            c = next_char (ref_l, ref_s, A68_TRUE);
1131          }
1132        } else {
1133          while (IS_DIGIT (c) || strchr ("ABCDEF", c) != NO_TEXT) {
1134            (sym++)[0] = c;
1135            c = next_char (ref_l, ref_s, A68_TRUE);
1136          }
1137        }
1138        *att = BITS_DENOTATION;
1139      } else {
1140        *att = INT_DENOTATION;
1141      }
1142      sym[0] = NULL_CHAR;
1143    } else if (c == QUOTE_CHAR) {
1144  // STRING denotation.
1145      BOOL_T stop = A68_FALSE;
1146      while (!stop) {
1147        c = next_char (ref_l, ref_s, A68_FALSE);
1148        while (c != QUOTE_CHAR && c != STOP_CHAR) {
1149          SCAN_ERROR (EOL (c), *start_l, *start_c, ERROR_LONG_STRING);
1150          (sym++)[0] = c;
1151          c = next_char (ref_l, ref_s, A68_FALSE);
1152        }
1153        SCAN_ERROR (*ref_l == NO_LINE, *start_l, *start_c, ERROR_UNTERMINATED_STRING);
1154        c = next_char (ref_l, ref_s, A68_FALSE);
1155        if (c == QUOTE_CHAR) {
1156          (sym++)[0] = QUOTE_CHAR;
1157        } else {
1158          stop = A68_TRUE;
1159        }
1160      }
1161      sym[0] = NULL_CHAR;
1162      *att = (in_format ? LITERAL : ROW_CHAR_DENOTATION);
1163    } else if (strchr ("#$()[]{},;@", c) != NO_TEXT) {
1164  // Single character symbols.
1165      (sym++)[0] = c;
1166      (void) next_char (ref_l, ref_s, A68_FALSE);
1167      sym[0] = NULL_CHAR;
1168      *att = 0;
1169    } else if (c == '|') {
1170  // Bar.
1171      (sym++)[0] = c;
1172      c = next_char (ref_l, ref_s, A68_FALSE);
1173      if (c == ':') {
1174        (sym++)[0] = c;
1175        (void) next_char (ref_l, ref_s, A68_FALSE);
1176      }
1177      sym[0] = NULL_CHAR;
1178      *att = 0;
1179    } else if (c == '!' && OPTION_STROPPING (&A68_JOB) == QUOTE_STROPPING) {
1180  // Bar, will be replaced with modern variant.
1181  // For this reason ! is not a MONAD with quote-stropping.
1182      (sym++)[0] = '|';
1183      c = next_char (ref_l, ref_s, A68_FALSE);
1184      if (c == ':') {
1185        (sym++)[0] = c;
1186        (void) next_char (ref_l, ref_s, A68_FALSE);
1187      }
1188      sym[0] = NULL_CHAR;
1189      *att = 0;
1190    } else if (c == ':') {
1191  // Colon, semicolon, IS, ISNT.
1192      (sym++)[0] = c;
1193      c = next_char (ref_l, ref_s, A68_FALSE);
1194      if (c == '=') {
1195        (sym++)[0] = c;
1196        if ((c = next_char (ref_l, ref_s, A68_FALSE)) == ':') {
1197          (sym++)[0] = c;
1198          c = next_char (ref_l, ref_s, A68_FALSE);
1199        }
1200      } else if (c == '/') {
1201        (sym++)[0] = c;
1202        if ((c = next_char (ref_l, ref_s, A68_FALSE)) == '=') {
1203          (sym++)[0] = c;
1204          if ((c = next_char (ref_l, ref_s, A68_FALSE)) == ':') {
1205            (sym++)[0] = c;
1206            c = next_char (ref_l, ref_s, A68_FALSE);
1207          }
1208        }
1209      } else if (c == ':') {
1210        (sym++)[0] = c;
1211        if ((c = next_char (ref_l, ref_s, A68_FALSE)) == '=') {
1212          (sym++)[0] = c;
1213        }
1214      }
1215      sym[0] = NULL_CHAR;
1216      *att = 0;
1217    } else if (c == '=') {
1218  // Operator starting with "=".
1219      char *scanned = sym;
1220      (sym++)[0] = c;
1221      c = next_char (ref_l, ref_s, A68_FALSE);
1222      if (strchr (NOMADS, c) != NO_TEXT) {
1223        (sym++)[0] = c;
1224        c = next_char (ref_l, ref_s, A68_FALSE);
1225      }
1226      if (c == '=') {
1227        (sym++)[0] = c;
1228        if (next_char (ref_l, ref_s, A68_FALSE) == ':') {
1229          (sym++)[0] = ':';
1230          c = next_char (ref_l, ref_s, A68_FALSE);
1231          if (strlen (sym) < 4 && c == '=') {
1232            (sym++)[0] = '=';
1233            (void) next_char (ref_l, ref_s, A68_FALSE);
1234          }
1235        }
1236      } else if (c == ':') {
1237        (sym++)[0] = c;
1238        sym[0] = NULL_CHAR;
1239        if (next_char (ref_l, ref_s, A68_FALSE) == '=') {
1240          (sym++)[0] = '=';
1241          (void) next_char (ref_l, ref_s, A68_FALSE);
1242        } else {
1243          SCAN_ERROR (!(strcmp (scanned, "=:") == 0 || strcmp (scanned, "==:") == 0), *start_l, *start_c, ERROR_INVALID_OPERATOR_TAG);
1244        }
1245      }
1246      sym[0] = NULL_CHAR;
1247      if (strcmp (scanned, "=") == 0) {
1248        *att = EQUALS_SYMBOL;
1249      } else {
1250        *att = OPERATOR;
1251      }
1252    } else if (strchr (MONADS, c) != NO_TEXT || strchr (NOMADS, c) != NO_TEXT) {
1253  // Operator.
1254      char *scanned = sym;
1255      (sym++)[0] = c;
1256      c = next_char (ref_l, ref_s, A68_FALSE);
1257      if (strchr (NOMADS, c) != NO_TEXT) {
1258        (sym++)[0] = c;
1259        c = next_char (ref_l, ref_s, A68_FALSE);
1260      }
1261      if (c == '=') {
1262        (sym++)[0] = c;
1263        if (next_char (ref_l, ref_s, A68_FALSE) == ':') {
1264          (sym++)[0] = ':';
1265          c = next_char (ref_l, ref_s, A68_FALSE);
1266          if (strlen (scanned) < 4 && c == '=') {
1267            (sym++)[0] = '=';
1268            (void) next_char (ref_l, ref_s, A68_FALSE);
1269          }
1270        }
1271      } else if (c == ':') {
1272        (sym++)[0] = c;
1273        sym[0] = NULL_CHAR;
1274        if (next_char (ref_l, ref_s, A68_FALSE) == '=') {
1275          (sym++)[0] = '=';
1276          sym[0] = NULL_CHAR;
1277          (void) next_char (ref_l, ref_s, A68_FALSE);
1278        } else {
1279          SCAN_ERROR (strcmp (&(scanned[1]), "=:") != 0, *start_l, *start_c, ERROR_INVALID_OPERATOR_TAG);
1280        }
1281      }
1282      sym[0] = NULL_CHAR;
1283      *att = OPERATOR;
1284    } else {
1285  // Afuuus ... strange characters!.
1286      unworthy (*start_l, *start_c, (int) c);
1287    }
1288  }
1289  
1290  //! @brief Whether att opens an embedded clause.
1291  
1292  BOOL_T open_nested_clause (int att)
1293  {
1294    switch (att) {
1295    case OPEN_SYMBOL:
1296    case BEGIN_SYMBOL:
1297    case PAR_SYMBOL:
1298    case IF_SYMBOL:
1299    case CASE_SYMBOL:
1300    case FOR_SYMBOL:
1301    case FROM_SYMBOL:
1302    case BY_SYMBOL:
1303    case TO_SYMBOL:
1304    case DOWNTO_SYMBOL:
1305    case WHILE_SYMBOL:
1306    case DO_SYMBOL:
1307    case SUB_SYMBOL:
1308    case ACCO_SYMBOL: {
1309        return A68_TRUE;
1310      }
1311    }
1312    return A68_FALSE;
1313  }
1314  
1315  //! @brief Whether att closes an embedded clause.
1316  
1317  BOOL_T close_nested_clause (int att)
1318  {
1319    switch (att) {
1320    case CLOSE_SYMBOL:
1321    case END_SYMBOL:
1322    case FI_SYMBOL:
1323    case ESAC_SYMBOL:
1324    case OD_SYMBOL:
1325    case BUS_SYMBOL:
1326    case OCCA_SYMBOL: {
1327        return A68_TRUE;
1328      }
1329    }
1330    return A68_FALSE;
1331  }
1332  
1333  //! @brief Cast a string to lower case.
1334  
1335  void make_lower_case (char *p)
1336  {
1337    for (; p != NO_TEXT && p[0] != NULL_CHAR; p++) {
1338      p[0] = (char) TO_LOWER (p[0]);
1339    }
1340  }
1341  
1342  //! @brief Construct a linear list of tokens.
1343  
1344  void tokenise_source (NODE_T ** root, int level, BOOL_T in_format, LINE_T ** l, char **s, LINE_T ** start_l, char **start_c)
1345  {
1346    char *lpr = NO_TEXT;
1347    int lprt = 0;
1348    while (l != NO_VAR && !A68_PARSER (stop_scanner)) {
1349      int att = 0;
1350      get_next_token (in_format, l, s, start_l, start_c, &att);
1351      if (A68_PARSER (scan_buf)[0] == STOP_CHAR) {
1352        A68_PARSER (stop_scanner) = A68_TRUE;
1353      } else if (strlen (A68_PARSER (scan_buf)) > 0 || att == ROW_CHAR_DENOTATION || att == LITERAL) {
1354        KEYWORD_T *kw;
1355        char *c = NO_TEXT;
1356        BOOL_T make_node = A68_TRUE;
1357        char *trailing = NO_TEXT;
1358        if (att != IDENTIFIER) {
1359          kw = find_keyword (A68 (top_keyword), A68_PARSER (scan_buf));
1360        } else {
1361          kw = NO_KEYWORD;
1362        }
1363        if (!(kw != NO_KEYWORD && att != ROW_CHAR_DENOTATION)) {
1364          if (att == IDENTIFIER) {
1365            make_lower_case (A68_PARSER (scan_buf));
1366          }
1367          if (att != ROW_CHAR_DENOTATION && att != LITERAL) {
1368            int len = (int) strlen (A68_PARSER (scan_buf));
1369            while (len >= 1 && A68_PARSER (scan_buf)[len - 1] == '_') {
1370              trailing = "_";
1371              A68_PARSER (scan_buf)[len - 1] = NULL_CHAR;
1372              len--;
1373            }
1374          }
1375          c = TEXT (add_token (&A68 (top_token), A68_PARSER (scan_buf)));
1376        } else {
1377          if (IS (kw, TO_SYMBOL)) {
1378  // Merge GO and TO to GOTO.
1379            if (*root != NO_NODE && IS (*root, GO_SYMBOL)) {
1380              ATTRIBUTE (*root) = GOTO_SYMBOL;
1381              NSYMBOL (*root) = TEXT (find_keyword (A68 (top_keyword), "GOTO"));
1382              make_node = A68_FALSE;
1383            } else {
1384              att = ATTRIBUTE (kw);
1385              c = TEXT (kw);
1386            }
1387          } else {
1388            if (att == 0 || att == BOLD_TAG) {
1389              att = ATTRIBUTE (kw);
1390            }
1391            c = TEXT (kw);
1392  // Handle pragments.
1393            if (att == STYLE_II_COMMENT_SYMBOL || att == STYLE_I_COMMENT_SYMBOL || att == BOLD_COMMENT_SYMBOL) {
1394              char *nlpr = pragment (ATTRIBUTE (kw), l, s);
1395              if (lpr == NO_TEXT || (int) strlen (lpr) == 0) {
1396                lpr = nlpr;
1397              } else {
1398                char *stale = lpr;
1399                lpr = new_string (lpr, "\n\n", nlpr, NO_TEXT);
1400                a68_free (nlpr);
1401                a68_free (stale);
1402              }
1403              lprt = att;
1404              make_node = A68_FALSE;
1405            } else if (att == STYLE_I_PRAGMAT_SYMBOL || att == BOLD_PRAGMAT_SYMBOL) {
1406              char *nlpr = pragment (ATTRIBUTE (kw), l, s);
1407              if (lpr == NO_TEXT || (int) strlen (lpr) == 0) {
1408                lpr = nlpr;
1409              } else {
1410                char *stale = lpr;
1411                lpr = new_string (lpr, "\n\n", nlpr, NO_TEXT);
1412                a68_free (nlpr);
1413                a68_free (stale);
1414              }
1415              lprt = att;
1416              if (!A68_PARSER (stop_scanner)) {
1417                (void) set_options (OPTION_LIST (&A68_JOB), A68_FALSE);
1418                make_node = A68_FALSE;
1419              }
1420            }
1421          }
1422        }
1423  // Add token to the tree.
1424        if (make_node) {
1425          NODE_T *q = new_node ();
1426          INFO (q) = new_node_info ();
1427          switch (att) {
1428          case ASSIGN_SYMBOL:
1429          case END_SYMBOL:
1430          case ESAC_SYMBOL:
1431          case OD_SYMBOL:
1432          case OF_SYMBOL:
1433          case FI_SYMBOL:
1434          case CLOSE_SYMBOL:
1435          case BUS_SYMBOL:
1436          case COLON_SYMBOL:
1437          case COMMA_SYMBOL:
1438          case DOTDOT_SYMBOL:
1439          case SEMI_SYMBOL: {
1440              GINFO (q) = NO_GINFO;
1441              break;
1442            }
1443          default: {
1444              GINFO (q) = new_genie_info ();
1445              break;
1446            }
1447          }
1448          STATUS (q) = OPTION_NODEMASK (&A68_JOB);
1449          LINE (INFO (q)) = *start_l;
1450          CHAR_IN_LINE (INFO (q)) = *start_c;
1451          PRIO (INFO (q)) = 0;
1452          PROCEDURE_LEVEL (INFO (q)) = 0;
1453          ATTRIBUTE (q) = att;
1454          NSYMBOL (q) = c;
1455          PREVIOUS (q) = *root;
1456          SUB (q) = NEXT (q) = NO_NODE;
1457          TABLE (q) = NO_TABLE;
1458          MOID (q) = NO_MOID;
1459          TAX (q) = NO_TAG;
1460          if (lpr != NO_TEXT) {
1461            NPRAGMENT (q) = lpr;
1462            NPRAGMENT_TYPE (q) = lprt;
1463            lpr = NO_TEXT;
1464            lprt = 0;
1465          }
1466          if (*root != NO_NODE) {
1467            NEXT (*root) = q;
1468          }
1469          if (TOP_NODE (&A68_JOB) == NO_NODE) {
1470            TOP_NODE (&A68_JOB) = q;
1471          }
1472          *root = q;
1473          if (trailing != NO_TEXT) {
1474            diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, q, WARNING_TRAILING, trailing, att);
1475          }
1476        }
1477  // Redirection in tokenising formats. The scanner is a recursive-descent type as
1478  // to know when it scans a format text and when not. 
1479        if (in_format && att == FORMAT_DELIMITER_SYMBOL) {
1480          return;
1481        } else if (!in_format && att == FORMAT_DELIMITER_SYMBOL) {
1482          tokenise_source (root, level + 1, A68_TRUE, l, s, start_l, start_c);
1483        } else if (in_format && open_nested_clause (att)) {
1484          NODE_T *z = PREVIOUS (*root);
1485          if (z != NO_NODE && is_one_of (z, FORMAT_ITEM_N, FORMAT_ITEM_G, FORMAT_ITEM_H, FORMAT_ITEM_F, STOP)) {
1486            tokenise_source (root, level, A68_FALSE, l, s, start_l, start_c);
1487          } else if (att == OPEN_SYMBOL) {
1488            ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL;
1489          } else if (OPTION_BRACKETS (&A68_JOB) && att == SUB_SYMBOL) {
1490            ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL;
1491          } else if (OPTION_BRACKETS (&A68_JOB) && att == ACCO_SYMBOL) {
1492            ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL;
1493          }
1494        } else if (!in_format && level > 0 && open_nested_clause (att)) {
1495          tokenise_source (root, level + 1, A68_FALSE, l, s, start_l, start_c);
1496        } else if (!in_format && level > 0 && close_nested_clause (att)) {
1497          return;
1498        } else if (in_format && att == CLOSE_SYMBOL) {
1499          ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL;
1500        } else if (OPTION_BRACKETS (&A68_JOB) && in_format && att == BUS_SYMBOL) {
1501          ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL;
1502        } else if (OPTION_BRACKETS (&A68_JOB) && in_format && att == OCCA_SYMBOL) {
1503          ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL;
1504        }
1505      }
1506    }
1507  }
1508  
1509  //! @brief Tokenise source file, build initial syntax tree.
1510  
1511  BOOL_T lexical_analyser (void)
1512  {
1513    LINE_T *l = NO_LINE, *start_l = NO_LINE;
1514    char *s = NO_TEXT, *start_c = NO_TEXT;
1515    NODE_T *root = NO_NODE;
1516    A68_PARSER (scan_buf) = NO_TEXT;
1517    A68_PARSER (max_scan_buf_length) = A68_PARSER (source_file_size) = get_source_size ();
1518  // Errors in file?.
1519    if (A68_PARSER (max_scan_buf_length) == 0) {
1520      return A68_FALSE;
1521    }
1522    if (OPTION_RUN_SCRIPT (&A68_JOB)) {
1523      A68_PARSER (scan_buf) = (char *) get_temp_heap_space ((unt) (8 + A68_PARSER (max_scan_buf_length)));
1524      if (!read_script_file ()) {
1525        return A68_FALSE;
1526      }
1527    } else {
1528      A68_PARSER (max_scan_buf_length) += KILOBYTE;       // for the environ, more than enough
1529      A68_PARSER (scan_buf) = (char *) get_temp_heap_space ((unt) A68_PARSER (max_scan_buf_length));
1530  // Errors in file?.
1531      if (!read_source_file ()) {
1532        return A68_FALSE;
1533      }
1534    }
1535  // Start tokenising.
1536    A68_PARSER (read_error) = A68_FALSE;
1537    A68_PARSER (stop_scanner) = A68_FALSE;
1538    if ((l = TOP_LINE (&A68_JOB)) != NO_LINE) {
1539      s = STRING (l);
1540    }
1541    tokenise_source (&root, 0, A68_FALSE, &l, &s, &start_l, &start_c);
1542    return A68_TRUE;
1543  }