parser.c

     
   1  //! @file parser.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-2025 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  //! Mailloux-type Algol 68 parser driver.
  25  
  26  // The Algol 68 grammar is a two level (Van Wijngaarden, "VW") grammar 
  27  // that incorporates, as syntactical rules, the semantical rules in 
  28  // other languages. Examples are correct use of symbols, modes and scope.
  29  // 
  30  // This code constitutes an effective "VW Algol 68 parser". A pragmatic
  31  // approach was chosen since in the early days of Algol 68, many "ab initio" 
  32  // implementations failed, probably because techniques to parse a language
  33  // like Algol 68 had yet to be invented.
  34  // 
  35  // This is a Mailloux-type parser, in the sense that it scans a "phrase" for
  36  // definitions needed for parsing. Algol 68 allows for tags to be used
  37  // before they are defined, which gives freedom in top-down programming.
  38  // 
  39  //    B. J. Mailloux. On the implementation of Algol 68.
  40  //    Thesis, Universiteit van Amsterdam (Mathematisch Centrum) [1968].
  41  // 
  42  // Technically, Mailloux's approach renders the two-level grammar LALR.
  43  // 
  44  // First part of the parser is the scanner. The source file is read,
  45  // is tokenised, and if needed a refinement preprocessor elaborates a stepwise
  46  // refined program. The result is a linear list of tokens that is input for the
  47  // parser, that will transform the linear list into a syntax tree.
  48  // 
  49  // Algol68G tokenises all symbols before the bottom-up parser is invoked. 
  50  // This means that scanning does not use information from the parser.
  51  // The scanner does of course some rudimentary parsing. Format texts can have
  52  // enclosed clauses in them, so we record information in a stack as to know
  53  // what is being scanned. Also, the refinement preprocessor implements a
  54  // (trivial) grammar.
  55  // 
  56  // The scanner supports two stropping regimes: "bold" (or "upper") and "quote". 
  57  // Examples of both:
  58  // 
  59  //    bold stropping: BEGIN INT i = 1, j = 1; print (i + j) END
  60  // 
  61  //    quote stropping: 'BEGIN' 'INT' I = 1, J = 1; PRINT (I + J) 'END'
  62  // 
  63  // Quote stropping was used frequently in the (excusez-le-mot) punch-card age.
  64  // Hence, bold stropping is the default. There also existed point stropping, 
  65  // but that has not been implemented here.
  66  // 
  67  // Next part of the parser is a recursive-descent type to check parenthesis.
  68  // Also a first set-up is made of symbol tables, needed by the bottom-up parser.
  69  // Next part is the bottom-up parser, that parses without knowing modes while
  70  // parsing and reducing. It can therefore not exchange "[]" with "()" as was
  71  // blessed by the Revised Report. This is solved by treating CALL and SLICE as
  72  // equivalent for the moment and letting the mode checker sort it out later.
  73  // 
  74  // Parsing progresses in various phases to avoid spurious diagnostics from a
  75  // recovering parser. Every phase "tightens" the grammar more.
  76  // An error in any phase makes the parser quit when that phase ends.
  77  // The parser is forgiving in case of superfluous semicolons.
  78  // 
  79  // These are the parser phases:
  80  // 
  81  //  (1) Parenthesis are checked to see whether they match. Then, a top-down 
  82  //      parser determines the basic-block structure of the program
  83  //      so symbol tables can be set up that the bottom-up parser will consult
  84  //      as you can define things before they are applied.
  85  // 
  86  //  (2) A bottom-up parser resolves the structure of the program.
  87  // 
  88  //  (3) After the symbol tables have been finalised, a small rearrangement of the
  89  //      tree may be required where JUMPs have no GOTO. This leads to the
  90  //      non-standard situation that JUMPs without GOTO can have the syntactic
  91  //      position of a PRIMARY, SECONDARY or TERTIARY. The bottom-up parser also
  92  //      does not check VICTAL correctness of declarers. This is done separately. 
  93  //      Also structure of format texts is checked separately.
  94  // 
  95  // The parser sets up symbol tables and populates them as far as needed to parse
  96  // the source. After the bottom-up parser terminates succesfully, the symbol tables
  97  // are completed.
  98  // 
  99  //  (4) Next, modes are collected and rules for well-formedness and structural 
 100  //      equivalence are applied. Then the symbol-table is completed now moids are 
 101  //      all known.
 102  // 
 103  //  (5) Next phases are the mode checker and coercion inserter. The syntax tree is 
 104  //      traversed to determine and check all modes, and to select operators. Then 
 105  //      the tree is traversed again to insert coercions.
 106  // 
 107  //  (6) A static scope checker detects where objects are transported out of scope.
 108  //      At run time, a dynamic scope checker will check that what the static scope 
 109  //      checker cannot see.
 110  
 111  #include "a68g.h"
 112  #include "a68g-parser.h"
 113  #include "a68g-mp.h"
 114  #include "a68g-postulates.h"
 115  #include "a68g-prelude.h"
 116  
 117  //! @brief First initialisations.
 118  
 119  void init_before_tokeniser (void)
 120  {
 121  // Heap management set-up.
 122    errno = 0;
 123    init_heap ();
 124    A68 (top_keyword) = NO_KEYWORD;
 125    A68 (top_token) = NO_TOKEN;
 126    TOP_NODE (&A68_JOB) = NO_NODE;
 127    TOP_MOID (&A68_JOB) = NO_MOID;
 128    TOP_LINE (&A68_JOB) = NO_LINE;
 129    STANDENV_MOID (&A68_JOB) = NO_MOID;
 130    set_up_tables ();
 131  // Various initialisations.
 132    ERROR_COUNT (&A68_JOB) = WARNING_COUNT (&A68_JOB) = 0;
 133    ABEND (errno != 0, ERROR_ALLOCATION, __func__);
 134    errno = 0;
 135  }
 136  
 137  void init_parser (void)
 138  {
 139    A68_PARSER (stop_scanner) = A68_FALSE;
 140    A68_PARSER (read_error) = A68_FALSE;
 141    A68_PARSER (no_preprocessing) = A68_FALSE;
 142  }
 143  
 144  //! @brief Is_ref_refety_flex.
 145  
 146  BOOL_T is_ref_refety_flex (MOID_T * m)
 147  {
 148    if (IS_REF_FLEX (m)) {
 149      return A68_TRUE;
 150    } else if (IS_REF (m)) {
 151      return is_ref_refety_flex (SUB (m));
 152    } else {
 153      return A68_FALSE;
 154    }
 155  }
 156  
 157  //! @brief Count number of operands in operator parameter list.
 158  
 159  int count_operands (NODE_T * p)
 160  {
 161    if (p != NO_NODE) {
 162      if (IS (p, DECLARER)) {
 163        return count_operands (NEXT (p));
 164      } else if (IS (p, COMMA_SYMBOL)) {
 165        return 1 + count_operands (NEXT (p));
 166      } else {
 167        return count_operands (NEXT (p)) + count_operands (SUB (p));
 168      }
 169    } else {
 170      return 0;
 171    }
 172  }
 173  
 174  //! @brief Count formal bounds in declarer in tree.
 175  
 176  int count_formal_bounds (NODE_T * p)
 177  {
 178    if (p == NO_NODE) {
 179      return 0;
 180    } else {
 181      if (IS (p, COMMA_SYMBOL)) {
 182        return 1;
 183      } else {
 184        return count_formal_bounds (NEXT (p)) + count_formal_bounds (SUB (p));
 185      }
 186    }
 187  }
 188  
 189  //! @brief Count pictures.
 190  
 191  void count_pictures (NODE_T * p, int *k)
 192  {
 193    for (; p != NO_NODE; FORWARD (p)) {
 194      if (IS (p, PICTURE)) {
 195        (*k)++;
 196      }
 197      count_pictures (SUB (p), k);
 198    }
 199  }
 200  
 201  //! @brief Whether token cannot follow semicolon or EXIT.
 202  
 203  BOOL_T is_semicolon_less (NODE_T * p)
 204  {
 205    switch (ATTRIBUTE (p)) {
 206    case BUS_SYMBOL:
 207    case CLOSE_SYMBOL:
 208    case END_SYMBOL:
 209    case SEMI_SYMBOL:
 210    case EXIT_SYMBOL:
 211    case THEN_BAR_SYMBOL:
 212    case ELSE_BAR_SYMBOL:
 213    case THEN_SYMBOL:
 214    case ELIF_SYMBOL:
 215    case ELSE_SYMBOL:
 216    case FI_SYMBOL:
 217    case IN_SYMBOL:
 218    case OUT_SYMBOL:
 219    case OUSE_SYMBOL:
 220    case ESAC_SYMBOL:
 221    case EDOC_SYMBOL:
 222    case OCCA_SYMBOL:
 223    case OD_SYMBOL:
 224    case UNTIL_SYMBOL: {
 225        return A68_TRUE;
 226      }
 227    default: {
 228        return A68_FALSE;
 229      }
 230    }
 231  }
 232  
 233  //! @brief Whether formal bounds.
 234  
 235  BOOL_T is_formal_bounds (NODE_T * p)
 236  {
 237    if (p == NO_NODE) {
 238      return A68_TRUE;
 239    } else {
 240      switch (ATTRIBUTE (p)) {
 241      case OPEN_SYMBOL:
 242      case CLOSE_SYMBOL:
 243      case SUB_SYMBOL:
 244      case BUS_SYMBOL:
 245      case COMMA_SYMBOL:
 246      case COLON_SYMBOL:
 247      case DOTDOT_SYMBOL:
 248      case INT_DENOTATION:
 249      case IDENTIFIER:
 250      case OPERATOR: {
 251          return (BOOL_T) (is_formal_bounds (SUB (p)) && is_formal_bounds (NEXT (p)));
 252        }
 253      default: {
 254          return A68_FALSE;
 255        }
 256      }
 257    }
 258  }
 259  
 260  //! @brief Whether token terminates a unit.
 261  
 262  BOOL_T is_unit_terminator (NODE_T * p)
 263  {
 264    switch (ATTRIBUTE (p)) {
 265    case BUS_SYMBOL:
 266    case CLOSE_SYMBOL:
 267    case END_SYMBOL:
 268    case SEMI_SYMBOL:
 269    case EXIT_SYMBOL:
 270    case COMMA_SYMBOL:
 271    case THEN_BAR_SYMBOL:
 272    case ELSE_BAR_SYMBOL:
 273    case THEN_SYMBOL:
 274    case ELIF_SYMBOL:
 275    case ELSE_SYMBOL:
 276    case FI_SYMBOL:
 277    case IN_SYMBOL:
 278    case OUT_SYMBOL:
 279    case OUSE_SYMBOL:
 280    case ESAC_SYMBOL:
 281    case EDOC_SYMBOL:
 282    case OCCA_SYMBOL: {
 283        return A68_TRUE;
 284      }
 285    }
 286    return A68_FALSE;
 287  }
 288  
 289  //! @brief Whether token is a unit-terminator in a loop clause.
 290  
 291  BOOL_T is_loop_keyword (NODE_T * p)
 292  {
 293    switch (ATTRIBUTE (p)) {
 294    case FOR_SYMBOL:
 295    case FROM_SYMBOL:
 296    case BY_SYMBOL:
 297    case TO_SYMBOL:
 298    case DOWNTO_SYMBOL:
 299    case WHILE_SYMBOL:
 300    case DO_SYMBOL: {
 301        return A68_TRUE;
 302      }
 303    }
 304    return A68_FALSE;
 305  }
 306  
 307  //! @brief Get good attribute.
 308  
 309  int get_good_attribute (NODE_T * p)
 310  {
 311    switch (ATTRIBUTE (p)) {
 312    case UNIT:
 313    case TERTIARY:
 314    case SECONDARY:
 315    case PRIMARY:
 316    case ENCLOSED_CLAUSE: {
 317        return get_good_attribute (SUB (p));
 318      }
 319    case DECLARER: {
 320      if (IS (SUB (p), INDICANT)) {
 321        return ATTRIBUTE (SUB_SUB (p));
 322      } else {
 323        return DECLARER;
 324      }
 325    }
 326    case DECLARATION_LIST: {
 327      if (SUB (p) != NO_NODE) {
 328        return ATTRIBUTE (SUB (p));
 329      } else {
 330        return ATTRIBUTE (p);
 331      }
 332    }
 333    default: {
 334        return ATTRIBUTE (p);
 335      }
 336    }
 337  }
 338  
 339  //! @brief Intelligible diagnostic from syntax tree branch.
 340  
 341  char *phrase_to_text (NODE_T * p, NODE_T ** w)
 342  {
 343  #define MAX_TERMINALS 10
 344    int count = 0;
 345    BOOL_T put_space = A68_FALSE;
 346    static BUFFER buffer;
 347    buffer[0] = NULL_CHAR;
 348    while (p != NO_NODE && count < MAX_TERMINALS) {
 349      if (LINE_NUMBER (p) > 0) {
 350        int gatt = get_good_attribute (p);
 351        char *z = non_terminal_string (A68 (input_line), gatt);
 352  // Where to put the error message? 
 353  // The actual content of a  diagnostic is not as important 
 354  // as accurately indicating *were* the problem is! 
 355        if (w != NO_REF) {
 356          if (count == 0 || (*w) == NO_NODE) {
 357            *w = p;
 358          } else if (dont_mark_here (*w)) {
 359            *w = p;
 360          }
 361        }
 362        switch (gatt) {
 363          case SEMI_SYMBOL:
 364          case COMMA_SYMBOL:
 365          case CLOSE_SYMBOL:
 366          case BUS_SYMBOL: {
 367            // Next symbol may have leading space.
 368            put_space = A68_TRUE;
 369            break;
 370          }
 371          case OPEN_SYMBOL:
 372          case SUB_SYMBOL: {
 373            if (put_space) {
 374              a68g_bufcat (buffer, " ", BUFFER_SIZE);
 375            }
 376            // Next symbol has no leading space.
 377            put_space = A68_FALSE;
 378            break;              
 379          }
 380          default: {
 381            if (put_space) {
 382              a68g_bufcat (buffer, " ", BUFFER_SIZE);
 383            }
 384            // Next symbol may have leading space.
 385            put_space = A68_TRUE;
 386            break;
 387          }
 388        }
 389  // Attribute or symbol.
 390        if (z != NO_TEXT) {
 391          switch (gatt) {
 392            case DENOTATION:
 393            case IDENTIFIER: {
 394              ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s '%s'", z, NSYMBOL (p)) >= 0);
 395              break;
 396            }
 397            case OPERATOR: {
 398              ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", NSYMBOL (p)) >= 0);
 399              break;
 400            }
 401            case DECLARER:
 402            case COLON_SYMBOL: {
 403              ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", z) >= 0);
 404              break;
 405            }
 406            default: {
 407              if (SUB (p) == NO_NODE && NSYMBOL (p) != NO_TEXT) {
 408                ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", NSYMBOL (p)) >= 0);
 409              } else {
 410                ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", z) >= 0);
 411              }
 412              break;
 413            }
 414          }
 415        } else if (NSYMBOL (p) != NO_TEXT) {
 416          ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", NSYMBOL (p)) >= 0);
 417        } else {
 418          ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "...") >= 0);
 419        }
 420        a68g_bufcat (buffer, A68 (edit_line), BUFFER_SIZE);
 421        count++;
 422      }
 423      FORWARD (p);
 424    }
 425    if (p != NO_NODE && count == MAX_TERMINALS) {
 426      a68g_bufcat (buffer, " ... ", BUFFER_SIZE);
 427    }
 428    return buffer;
 429  }
 430  
 431  //! @brief Preferably don't put intelligible diagnostic here.
 432  
 433  BOOL_T dont_mark_here (NODE_T * p)
 434  {
 435    switch (ATTRIBUTE (p)) {
 436    case ACCO_SYMBOL:
 437    case ALT_DO_SYMBOL:
 438    case ALT_EQUALS_SYMBOL:
 439    case ANDF_SYMBOL:
 440    case ASSERT_SYMBOL:
 441    case ASSIGN_SYMBOL:
 442    case ASSIGN_TO_SYMBOL:
 443    case AT_SYMBOL:
 444    case BEGIN_SYMBOL:
 445    case BITS_SYMBOL:
 446    case BOLD_COMMENT_SYMBOL:
 447    case BOLD_PRAGMAT_SYMBOL:
 448    case BOOL_SYMBOL:
 449    case BUS_SYMBOL:
 450    case BY_SYMBOL:
 451    case BYTES_SYMBOL:
 452    case CASE_SYMBOL:
 453    case CHANNEL_SYMBOL:
 454    case CHAR_SYMBOL:
 455    case CLOSE_SYMBOL:
 456    case CODE_SYMBOL:
 457    case COLON_SYMBOL:
 458    case COLUMN_SYMBOL:
 459    case COMMA_SYMBOL:
 460    case COMPLEX_SYMBOL:
 461    case COMPL_SYMBOL:
 462    case DIAGONAL_SYMBOL:
 463    case DO_SYMBOL:
 464    case DOTDOT_SYMBOL:
 465    case DOWNTO_SYMBOL:
 466    case EDOC_SYMBOL:
 467    case ELIF_SYMBOL:
 468    case ELSE_BAR_SYMBOL:
 469    case ELSE_SYMBOL:
 470    case EMPTY_SYMBOL:
 471    case END_SYMBOL:
 472    case ENVIRON_SYMBOL:
 473    case EQUALS_SYMBOL:
 474    case ESAC_SYMBOL:
 475    case EXIT_SYMBOL:
 476    case FALSE_SYMBOL:
 477    case FILE_SYMBOL:
 478    case FI_SYMBOL:
 479    case FLEX_SYMBOL:
 480    case FORMAT_DELIMITER_SYMBOL:
 481    case FORMAT_SYMBOL:
 482    case FOR_SYMBOL:
 483    case FROM_SYMBOL:
 484    case GO_SYMBOL:
 485    case GOTO_SYMBOL:
 486    case HEAP_SYMBOL:
 487    case IF_SYMBOL:
 488    case IN_SYMBOL:
 489    case INT_SYMBOL:
 490    case ISNT_SYMBOL:
 491    case IS_SYMBOL:
 492    case LOC_SYMBOL:
 493    case LONG_SYMBOL:
 494    case MAIN_SYMBOL:
 495    case MODE_SYMBOL:
 496    case NIL_SYMBOL:
 497    case OCCA_SYMBOL:
 498    case OD_SYMBOL:
 499    case OF_SYMBOL:
 500    case OPEN_SYMBOL:
 501    case OP_SYMBOL:
 502    case ORF_SYMBOL:
 503    case OUSE_SYMBOL:
 504    case OUT_SYMBOL:
 505    case PAR_SYMBOL:
 506    case PIPE_SYMBOL:
 507    case POINT_SYMBOL:
 508    case PRIO_SYMBOL:
 509    case PROC_SYMBOL:
 510    case REAL_SYMBOL:
 511    case REF_SYMBOL:
 512    case ROWS_SYMBOL:
 513    case ROW_SYMBOL:
 514    case SEMA_SYMBOL:
 515    case SEMI_SYMBOL:
 516    case SHORT_SYMBOL:
 517    case SKIP_SYMBOL:
 518    case SOUND_SYMBOL:
 519    case STRING_SYMBOL:
 520    case STRUCT_SYMBOL:
 521    case STYLE_I_COMMENT_SYMBOL:
 522    case STYLE_II_COMMENT_SYMBOL:
 523    case STYLE_I_PRAGMAT_SYMBOL:
 524    case SUB_SYMBOL:
 525    case THEN_BAR_SYMBOL:
 526    case THEN_SYMBOL:
 527    case TO_SYMBOL:
 528    case TRANSPOSE_SYMBOL:
 529    case TRUE_SYMBOL:
 530    case UNION_SYMBOL:
 531    case UNTIL_SYMBOL:
 532    case VOID_SYMBOL:
 533    case WHILE_SYMBOL:
 534    case SERIAL_CLAUSE:
 535    case ENQUIRY_CLAUSE:
 536    case INITIALISER_SERIES:
 537    case DECLARATION_LIST: {
 538        return A68_TRUE;
 539      }
 540    }
 541    return A68_FALSE;
 542  }
 543  
 544  void a68g_parser (void)
 545  {
 546  // Tokeniser.
 547    FILE_SOURCE_OPENED (&A68_JOB) = A68_TRUE;
 548    announce_phase ("initialiser");
 549    A68_PARSER (error_tag) = (TAG_T *) new_tag ();
 550    init_parser ();
 551    if (ERROR_COUNT (&A68_JOB) == 0) {
 552      int frame_stack_size_2 = A68 (frame_stack_size);
 553      int expr_stack_size_2 = A68 (expr_stack_size);
 554      int heap_size_2 = A68 (heap_size);
 555      int handle_pool_size_2 = A68 (handle_pool_size);
 556      BOOL_T ok;
 557      announce_phase ("tokeniser");
 558      ok = lexical_analyser ();
 559      if (!ok || errno != 0) {
 560        diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS);
 561        return;
 562      }
 563  // Maybe the program asks for more memory through a PRAGMAT. We restart.
 564      if (frame_stack_size_2 != A68 (frame_stack_size) || expr_stack_size_2 != A68 (expr_stack_size) || heap_size_2 != A68 (heap_size) || handle_pool_size_2 != A68 (handle_pool_size)) {
 565        announce_phase ("tokeniser");
 566        free_syntax_tree (TOP_NODE (&A68_JOB));
 567        discard_heap ();
 568        init_before_tokeniser ();
 569        SOURCE_SCAN (&A68_JOB)++;
 570        ok = lexical_analyser ();
 571        verbosity ();
 572      }
 573      if (!ok || errno != 0) {
 574        diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS);
 575        return;
 576      }
 577      ASSERT (close (FILE_SOURCE_FD (&A68_JOB)) == 0);
 578      FILE_SOURCE_OPENED (&A68_JOB) = A68_FALSE;
 579      prune_echoes (OPTION_LIST (&A68_JOB));
 580      TREE_LISTING_SAFE (&A68_JOB) = A68_TRUE;
 581      int renum = 0;
 582      renumber_nodes (TOP_NODE (&A68_JOB), &renum);
 583    }
 584  // Now the default precision of LONG LONG modes is fixed.
 585    if (long_mp_digits () == 0) {
 586      set_long_mp_digits (LONG_LONG_MP_DIGITS);
 587    }
 588  // Final initialisations.
 589    if (ERROR_COUNT (&A68_JOB) == 0) {
 590      if (OPTION_REGRESSION_TEST (&A68_JOB)) {
 591        a68g_bufcpy (A68 (a68g_cmd_name), "a68g", BUFFER_SIZE);
 592        io_close_tty_line ();
 593        WRITE (A68_STDERR, "[");
 594        WRITE (A68_STDERR, FILE_INITIAL_NAME (&A68_JOB));
 595        WRITE (A68_STDERR, "]\n");
 596      }
 597      A68_STANDENV = NO_TABLE;
 598      init_postulates ();
 599      A68 (mode_count) = 0;
 600      make_special_mode (&M_HIP, A68 (mode_count)++);
 601      make_special_mode (&M_UNDEFINED, A68 (mode_count)++);
 602      make_special_mode (&M_ERROR, A68 (mode_count)++);
 603      make_special_mode (&M_VACUUM, A68 (mode_count)++);
 604      make_special_mode (&M_C_STRING, A68 (mode_count)++);
 605      make_special_mode (&M_COLLITEM, A68 (mode_count)++);
 606      make_special_mode (&M_SOUND_DATA, A68 (mode_count)++);
 607    }
 608  // Refinement preprocessor.
 609    if (ERROR_COUNT (&A68_JOB) == 0) {
 610      announce_phase ("preprocessor");
 611      get_refinements ();
 612      if (ERROR_COUNT (&A68_JOB) == 0) {
 613        put_refinements ();
 614      }
 615      int renum = 0;
 616      renumber_nodes (TOP_NODE (&A68_JOB), &renum);
 617      verbosity ();
 618    }
 619  // Top-down parser.
 620    if (ERROR_COUNT (&A68_JOB) == 0) {
 621      announce_phase ("parser phase 1");
 622      check_parenthesis (TOP_NODE (&A68_JOB));
 623      if (ERROR_COUNT (&A68_JOB) == 0) {
 624        if (OPTION_BRACKETS (&A68_JOB)) {
 625          substitute_brackets (TOP_NODE (&A68_JOB));
 626        }
 627        A68 (symbol_table_count) = 0;
 628        A68_STANDENV = new_symbol_table (NO_TABLE);
 629        LEVEL (A68_STANDENV) = 0;
 630        top_down_parser (TOP_NODE (&A68_JOB));
 631      }
 632      int renum = 0;
 633      renumber_nodes (TOP_NODE (&A68_JOB), &renum);
 634      verbosity ();
 635    }
 636  // Standard environment builder.
 637    if (ERROR_COUNT (&A68_JOB) == 0) {
 638      announce_phase ("standard environ builder");
 639      TABLE (TOP_NODE (&A68_JOB)) = new_symbol_table (A68_STANDENV);
 640      make_standard_environ ();
 641      STANDENV_MOID (&A68_JOB) = TOP_MOID (&A68_JOB);
 642      verbosity ();
 643    }
 644  // Bottom-up parser.
 645    if (ERROR_COUNT (&A68_JOB) == 0) {
 646      announce_phase ("parser phase 2");
 647      preliminary_symbol_table_setup (TOP_NODE (&A68_JOB));
 648      bottom_up_parser (TOP_NODE (&A68_JOB));
 649      int renum = 0;
 650      renumber_nodes (TOP_NODE (&A68_JOB), &renum);
 651      verbosity ();
 652    }
 653    if (ERROR_COUNT (&A68_JOB) == 0) {
 654      announce_phase ("parser phase 3");
 655      bottom_up_error_check (TOP_NODE (&A68_JOB));
 656      victal_checker (TOP_NODE (&A68_JOB));
 657      if (ERROR_COUNT (&A68_JOB) == 0) {
 658        finalise_symbol_table_setup (TOP_NODE (&A68_JOB), 2);
 659        NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3;
 660        reset_symbol_table_nest_count (TOP_NODE (&A68_JOB));
 661        fill_symbol_table_outer (TOP_NODE (&A68_JOB), TABLE (TOP_NODE (&A68_JOB)));
 662        set_nest (TOP_NODE (&A68_JOB), NO_NODE);
 663        set_proc_level (TOP_NODE (&A68_JOB), 1);
 664      }
 665      int renum = 0;
 666      renumber_nodes (TOP_NODE (&A68_JOB), &renum);
 667      verbosity ();
 668    }
 669  // Mode table builder.
 670    if (ERROR_COUNT (&A68_JOB) == 0) {
 671      announce_phase ("mode table builder");
 672      make_moid_list (&A68_JOB);
 673      verbosity ();
 674    }
 675    CROSS_REFERENCE_SAFE (&A68_JOB) = A68_TRUE;
 676  // Symbol table builder.
 677    if (ERROR_COUNT (&A68_JOB) == 0) {
 678      announce_phase ("symbol table builder");
 679      collect_taxes (TOP_NODE (&A68_JOB));
 680      verbosity ();
 681    }
 682  // Post parser.
 683    if (ERROR_COUNT (&A68_JOB) == 0) {
 684      announce_phase ("parser phase 4");
 685      rearrange_goto_less_jumps (TOP_NODE (&A68_JOB));
 686      verbosity ();
 687    }
 688  // Mode checker.
 689    if (ERROR_COUNT (&A68_JOB) == 0) {
 690      announce_phase ("mode checker");
 691      mode_checker (TOP_NODE (&A68_JOB));
 692      verbosity ();
 693    }
 694  // Coercion inserter.
 695    if (ERROR_COUNT (&A68_JOB) == 0) {
 696      announce_phase ("coercion enforcer");
 697      coercion_inserter (TOP_NODE (&A68_JOB));
 698      widen_denotation (TOP_NODE (&A68_JOB));
 699      get_max_simplout_size (TOP_NODE (&A68_JOB));
 700      set_moid_sizes (TOP_MOID (&A68_JOB));
 701      assign_offsets_table (A68_STANDENV);
 702      assign_offsets (TOP_NODE (&A68_JOB));
 703      assign_offsets_packs (TOP_MOID (&A68_JOB));
 704      int renum = 0;
 705      renumber_nodes (TOP_NODE (&A68_JOB), &renum);
 706      verbosity ();
 707    }
 708  // Application checker.
 709    if (ERROR_COUNT (&A68_JOB) == 0) {
 710      announce_phase ("application checker");
 711      mark_moids (TOP_NODE (&A68_JOB));
 712      mark_auxilliary (TOP_NODE (&A68_JOB));
 713      jumps_from_procs (TOP_NODE (&A68_JOB));
 714      warn_for_unused_tags (TOP_NODE (&A68_JOB));
 715      verbosity ();
 716    }
 717  // Scope checker.
 718    if (ERROR_COUNT (&A68_JOB) == 0) {
 719      announce_phase ("static scope checker");
 720      tie_label_to_serial (TOP_NODE (&A68_JOB));
 721      tie_label_to_unit (TOP_NODE (&A68_JOB));
 722      bind_routine_tags_to_tree (TOP_NODE (&A68_JOB));
 723      bind_format_tags_to_tree (TOP_NODE (&A68_JOB));
 724      scope_checker (TOP_NODE (&A68_JOB));
 725      verbosity ();
 726    }
 727  }
 728  
 729  //! @brief Renumber nodes.
 730  
 731  void renumber_nodes (NODE_T * p, int *n)
 732  {
 733    for (; p != NO_NODE; FORWARD (p)) {
 734      NUMBER (p) = (*n)++;
 735      renumber_nodes (SUB (p), n);
 736    }
 737  }
 738  
 739  //! @brief Register nodes.
 740  
 741  void register_nodes (NODE_T * p)
 742  {
 743    for (; p != NO_NODE; FORWARD (p)) {
 744      A68 (node_register)[NUMBER (p)] = p;
 745      register_nodes (SUB (p));
 746    }
 747  }
 748  
 749  //! @brief New_node_info.
 750  
 751  NODE_INFO_T *new_node_info (void)
 752  {
 753    NODE_INFO_T *z = (NODE_INFO_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (NODE_INFO_T));
 754    A68 (new_node_infos)++;
 755    PROCEDURE_LEVEL (z) = 0;
 756    CHAR_IN_LINE (z) = NO_TEXT;
 757    SYMBOL (z) = NO_TEXT;
 758    PRAGMENT (z) = NO_TEXT;
 759    PRAGMENT_TYPE (z) = 0;
 760    LINE (z) = NO_LINE;
 761    return z;
 762  }
 763  
 764  //! @brief New_genie_info.
 765  
 766  GINFO_T *new_genie_info (void)
 767  {
 768    GINFO_T *z = (GINFO_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (GINFO_T));
 769    A68 (new_genie_infos)++;
 770    UNIT (&PROP (z)) = NO_PPROC;
 771    SOURCE (&PROP (z)) = NO_NODE;
 772    PARTIAL_PROC (z) = NO_MOID;
 773    PARTIAL_LOCALE (z) = NO_MOID;
 774    IS_COERCION (z) = A68_FALSE;
 775    IS_NEW_LEXICAL_LEVEL (z) = A68_FALSE;
 776    NEED_DNS (z) = A68_FALSE;
 777    PARENT (z) = NO_NODE;
 778    OFFSET (z) = NO_BYTE;
 779    CONSTANT (z) = NO_CONSTANT;
 780    LEVEL (z) = 0;
 781    ARGSIZE (z) = 0;
 782    SIZE (z) = 0;
 783    COMPILE_NAME (z) = NO_TEXT;
 784    COMPILE_NODE (z) = 0;
 785    return z;
 786  }
 787  
 788  //! @brief New_node.
 789  
 790  NODE_T *new_node (void)
 791  {
 792    NODE_T *z = (NODE_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (NODE_T));
 793    A68 (new_nodes)++;
 794    STATUS (z) = NULL_MASK;
 795    CODEX (z) = NULL_MASK;
 796    TABLE (z) = NO_TABLE;
 797    INFO (z) = NO_NINFO;
 798    GINFO (z) = NO_GINFO;
 799    ATTRIBUTE (z) = 0;
 800    ANNOTATION (z) = 0;
 801    MOID (z) = NO_MOID;
 802    NEXT (z) = NO_NODE;
 803    PREVIOUS (z) = NO_NODE;
 804    SUB (z) = NO_NODE;
 805    NEST (z) = NO_NODE;
 806    NON_LOCAL (z) = NO_TABLE;
 807    TAX (z) = NO_TAG;
 808    SEQUENCE (z) = NO_NODE;
 809    PACK (z) = NO_PACK;
 810    return z;
 811  }
 812  
 813  //! @brief New_symbol_table.
 814  
 815  TABLE_T *new_symbol_table (TABLE_T * p)
 816  {
 817    TABLE_T *z = (TABLE_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (TABLE_T));
 818    NUM (z) = A68 (symbol_table_count);
 819    LEVEL (z) = A68 (symbol_table_count)++;
 820    NEST (z) = A68 (symbol_table_count);
 821    ATTRIBUTE (z) = 0;
 822    AP_INCREMENT (z) = 0;
 823    INITIALISE_FRAME (z) = A68_TRUE;
 824    PROC_OPS (z) = A68_TRUE;
 825    INITIALISE_ANON (z) = A68_TRUE;
 826    PREVIOUS (z) = p;
 827    OUTER (z) = NO_TABLE;
 828    IDENTIFIERS (z) = NO_TAG;
 829    OPERATORS (z) = NO_TAG;
 830    PRIO (z) = NO_TAG;
 831    INDICANTS (z) = NO_TAG;
 832    LABELS (z) = NO_TAG;
 833    ANONYMOUS (z) = NO_TAG;
 834    JUMP_TO (z) = NO_NODE;
 835    SEQUENCE (z) = NO_NODE;
 836    return z;
 837  }
 838  
 839  //! @brief New_moid.
 840  
 841  MOID_T *new_moid (void)
 842  {
 843    MOID_T *z = (MOID_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (MOID_T));
 844    A68 (new_modes)++;
 845    ATTRIBUTE (z) = 0;
 846    NUMBER (z) = 0;
 847    DIM (z) = 0;
 848    USE (z) = A68_FALSE;
 849    HAS_ROWS (z) = A68_FALSE;
 850    SIZE (z) = 0;
 851    DIGITS (z) = 0;
 852    SIZE_COMPL (z) = 0;
 853    DIGITS_COMPL (z) = 0;
 854    PORTABLE (z) = A68_TRUE;
 855    DERIVATE (z) = A68_FALSE;
 856    NODE (z) = NO_NODE;
 857    PACK (z) = NO_PACK;
 858    SUB (z) = NO_MOID;
 859    EQUIVALENT_MODE (z) = NO_MOID;
 860    SLICE (z) = NO_MOID;
 861    TRIM (z) = NO_MOID;
 862    DEFLEXED (z) = NO_MOID;
 863    NAME (z) = NO_MOID;
 864    MULTIPLE_MODE (z) = NO_MOID;
 865    NEXT (z) = NO_MOID;
 866    return z;
 867  }
 868  
 869  //! @brief New_pack.
 870  
 871  PACK_T *new_pack (void)
 872  {
 873    PACK_T *z = (PACK_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (PACK_T));
 874    MOID (z) = NO_MOID;
 875    TEXT (z) = NO_TEXT;
 876    NODE (z) = NO_NODE;
 877    NEXT (z) = NO_PACK;
 878    PREVIOUS (z) = NO_PACK;
 879    SIZE (z) = 0;
 880    OFFSET (z) = 0;
 881    return z;
 882  }
 883  
 884  //! @brief New_tag.
 885  
 886  TAG_T *new_tag (void)
 887  {
 888    TAG_T *z = (TAG_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (TAG_T));
 889    STATUS (z) = NULL_MASK;
 890    CODEX (z) = NULL_MASK;
 891    TAG_TABLE (z) = NO_TABLE;
 892    MOID (z) = NO_MOID;
 893    NODE (z) = NO_NODE;
 894    UNIT (z) = NO_NODE;
 895    VALUE (z) = NO_TEXT;
 896    A68_STANDENV_PROC (z) = 0;
 897    PROCEDURE (z) = NO_GPROC;
 898    SCOPE (z) = PRIMAL_SCOPE;
 899    SCOPE_ASSIGNED (z) = A68_FALSE;
 900    PRIO (z) = 0;
 901    USE (z) = A68_FALSE;
 902    IN_PROC (z) = A68_FALSE;
 903    HEAP (z) = A68_FALSE;
 904    SIZE (z) = 0;
 905    OFFSET (z) = 0;
 906    YOUNGEST_ENVIRON (z) = PRIMAL_SCOPE;
 907    LOC_ASSIGNED (z) = A68_FALSE;
 908    NEXT (z) = NO_TAG;
 909    BODY (z) = NO_TAG;
 910    PORTABLE (z) = A68_TRUE;
 911    NUMBER (z) = ++A68_PARSER (tag_number);
 912    return z;
 913  }
 914  
 915  //! @brief Make special, internal mode.
 916  
 917  void make_special_mode (MOID_T ** n, int m)
 918  {
 919    (*n) = new_moid ();
 920    ATTRIBUTE (*n) = 0;
 921    NUMBER (*n) = m;
 922    PACK (*n) = NO_PACK;
 923    SUB (*n) = NO_MOID;
 924    EQUIVALENT (*n) = NO_MOID;
 925    DEFLEXED (*n) = NO_MOID;
 926    NAME (*n) = NO_MOID;
 927    SLICE (*n) = NO_MOID;
 928    TRIM (*n) = NO_MOID;
 929    ROWED (*n) = NO_MOID;
 930  }
 931  
 932  //! @brief Whether x matches c; case insensitive.
 933  
 934  BOOL_T match_string (char *x, char *c, char alt)
 935  {
 936    BOOL_T match = A68_TRUE;
 937    while ((IS_UPPER (c[0]) || IS_DIGIT (c[0]) || c[0] == '-') && match) {
 938      match = (BOOL_T) (match & (TO_LOWER (x[0]) == TO_LOWER ((c++)[0])));
 939      if (!(x[0] == NULL_CHAR || x[0] == alt)) {
 940        x++;
 941      }
 942    }
 943    while (x[0] != NULL_CHAR && x[0] != alt && c[0] != NULL_CHAR && match) {
 944      match = (BOOL_T) (match & (TO_LOWER ((x++)[0]) == TO_LOWER ((c++)[0])));
 945    }
 946    return (BOOL_T) (match ? (x[0] == NULL_CHAR || x[0] == alt) : A68_FALSE);
 947  }
 948  
 949  //! @brief Whether attributes match in subsequent nodes.
 950  
 951  BOOL_T whether (NODE_T * p, ...)
 952  {
 953    va_list vl;
 954    va_start (vl, p);
 955    int a;
 956    while ((a = va_arg (vl, int)) != STOP)
 957    {
 958      if (p != NO_NODE && a == WILDCARD) {
 959        FORWARD (p);
 960      } else if (p != NO_NODE && (a == KEYWORD)) {
 961        if (find_keyword_from_attribute (A68 (top_keyword), ATTRIBUTE (p)) != NO_KEYWORD) {
 962          FORWARD (p);
 963        } else {
 964          va_end (vl);
 965          return A68_FALSE;
 966        }
 967      } else if (p != NO_NODE && (a >= 0 ? a == ATTRIBUTE (p) : (-a) != ATTRIBUTE (p))) {
 968        FORWARD (p);
 969      } else {
 970        va_end (vl);
 971        return A68_FALSE;
 972      }
 973    }
 974    va_end (vl);
 975    return A68_TRUE;
 976  }
 977  
 978  //! @brief Whether one of a series of attributes matches a node.
 979  
 980  BOOL_T is_one_of (NODE_T * p, ...)
 981  {
 982    if (p != NO_NODE) {
 983      va_list vl;
 984      va_start (vl, p);
 985      BOOL_T match = A68_FALSE;
 986      int a;
 987      while ((a = va_arg (vl, int)) != STOP)
 988      {
 989        match = (BOOL_T) (match | (BOOL_T) (IS (p, a)));
 990      }
 991      va_end (vl);
 992      return match;
 993    } else {
 994      return A68_FALSE;
 995    }
 996  }
 997  
 998  //! @brief Isolate nodes p-q making p a branch to p-q.
 999  
1000  void make_sub (NODE_T * p, NODE_T * q, int t)
1001  {
1002    NODE_T *z = new_node ();
1003    ABEND (p == NO_NODE || q == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
1004    *z = *p;
1005    if (GINFO (p) != NO_GINFO) {
1006      GINFO (z) = new_genie_info ();
1007    }
1008    PREVIOUS (z) = NO_NODE;
1009    if (p == q) {
1010      NEXT (z) = NO_NODE;
1011    } else {
1012      if (NEXT (p) != NO_NODE) {
1013        PREVIOUS (NEXT (p)) = z;
1014      }
1015      NEXT (p) = NEXT (q);
1016      if (NEXT (p) != NO_NODE) {
1017        PREVIOUS (NEXT (p)) = p;
1018      }
1019      NEXT (q) = NO_NODE;
1020    }
1021    SUB (p) = z;
1022    ATTRIBUTE (p) = t;
1023  }
1024  
1025  //! @brief Find symbol table at level 'i'.
1026  
1027  TABLE_T *find_level (NODE_T * n, int i)
1028  {
1029    if (n == NO_NODE) {
1030      return NO_TABLE;
1031    } else {
1032      TABLE_T *s = TABLE (n);
1033      if (s != NO_TABLE && LEVEL (s) == i) {
1034        return s;
1035      } else if ((s = find_level (SUB (n), i)) != NO_TABLE) {
1036        return s;
1037      } else if ((s = find_level (NEXT (n), i)) != NO_TABLE) {
1038        return s;
1039      } else {
1040        return NO_TABLE;
1041      }
1042    }
1043  }
1044  
1045  //! @brief Whether 'p' is top of lexical level.
1046  
1047  BOOL_T is_new_lexical_level (NODE_T * p)
1048  {
1049    switch (ATTRIBUTE (p)) {
1050    case ALT_DO_PART:
1051    case BRIEF_ELIF_PART:
1052    case BRIEF_OUSE_PART:
1053    case BRIEF_CONFORMITY_OUSE_PART:
1054    case CHOICE:
1055    case CLOSED_CLAUSE:
1056    case CONDITIONAL_CLAUSE:
1057    case DO_PART:
1058    case ELIF_PART:
1059    case ELSE_PART:
1060    case FORMAT_TEXT:
1061    case CASE_CLAUSE:
1062    case CASE_CHOICE_CLAUSE:
1063    case CASE_IN_PART:
1064    case CASE_OUSE_PART:
1065    case OUT_PART:
1066    case ROUTINE_TEXT:
1067    case SPECIFIED_UNIT:
1068    case THEN_PART:
1069    case UNTIL_PART:
1070    case CONFORMITY_CLAUSE:
1071    case CONFORMITY_CHOICE:
1072    case CONFORMITY_IN_PART:
1073    case CONFORMITY_OUSE_PART:
1074    case WHILE_PART: {
1075        return A68_TRUE;
1076      }
1077    default: {
1078        return A68_FALSE;
1079      }
1080    }
1081  }
1082  
1083  //! @brief Some_node.
1084  
1085  NODE_T *some_node (char *t)
1086  {
1087    NODE_T *z = new_node ();
1088    INFO (z) = new_node_info ();
1089    GINFO (z) = new_genie_info ();
1090    NSYMBOL (z) = t;
1091    return z;
1092  }
     


© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)