parser-taxes.c

     
   1  //! @file parser-taxes.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  //! Symbol table management.
  25  
  26  #include "a68g.h"
  27  #include "a68g-postulates.h"
  28  #include "a68g-parser.h"
  29  #include "a68g-prelude.h"
  30  
  31  // Symbol table handling, managing TAGS.
  32  
  33  //! @brief Set level for procedures.
  34  
  35  void set_proc_level (NODE_T * p, int n)
  36  {
  37    for (; p != NO_NODE; FORWARD (p)) {
  38      PROCEDURE_LEVEL (INFO (p)) = n;
  39      if (IS (p, ROUTINE_TEXT)) {
  40        set_proc_level (SUB (p), n + 1);
  41      } else {
  42        set_proc_level (SUB (p), n);
  43      }
  44    }
  45  }
  46  
  47  //! @brief Set nests for diagnostics.
  48  
  49  void set_nest (NODE_T * p, NODE_T * s)
  50  {
  51    for (; p != NO_NODE; FORWARD (p)) {
  52      NEST (p) = s;
  53      if (IS (p, PARTICULAR_PROGRAM)) {
  54        set_nest (SUB (p), p);
  55      } else if (IS (p, CLOSED_CLAUSE) && LINE_NUMBER (p) != 0) {
  56        set_nest (SUB (p), p);
  57      } else if (IS (p, COLLATERAL_CLAUSE) && LINE_NUMBER (p) != 0) {
  58        set_nest (SUB (p), p);
  59      } else if (IS (p, CONDITIONAL_CLAUSE) && LINE_NUMBER (p) != 0) {
  60        set_nest (SUB (p), p);
  61      } else if (IS (p, CASE_CLAUSE) && LINE_NUMBER (p) != 0) {
  62        set_nest (SUB (p), p);
  63      } else if (IS (p, CONFORMITY_CLAUSE) && LINE_NUMBER (p) != 0) {
  64        set_nest (SUB (p), p);
  65      } else if (IS (p, LOOP_CLAUSE) && LINE_NUMBER (p) != 0) {
  66        set_nest (SUB (p), p);
  67      } else {
  68        set_nest (SUB (p), s);
  69      }
  70    }
  71  }
  72  
  73  // Routines that work with tags and symbol tables.
  74  
  75  void tax_tags (NODE_T *);
  76  void tax_specifier_list (NODE_T *);
  77  void tax_parameter_list (NODE_T *);
  78  void tax_format_texts (NODE_T *);
  79  
  80  //! @brief Find a tag, searching symbol tables towards the root.
  81  
  82  int first_tag_global (TABLE_T * table, char *name)
  83  {
  84    if (table != NO_TABLE) {
  85      TAG_T *s = NO_TAG;
  86      for (s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s)) {
  87        if (NSYMBOL (NODE (s)) == name) {
  88          return IDENTIFIER;
  89        }
  90      }
  91      for (s = INDICANTS (table); s != NO_TAG; FORWARD (s)) {
  92        if (NSYMBOL (NODE (s)) == name) {
  93          return INDICANT;
  94        }
  95      }
  96      for (s = LABELS (table); s != NO_TAG; FORWARD (s)) {
  97        if (NSYMBOL (NODE (s)) == name) {
  98          return LABEL;
  99        }
 100      }
 101      for (s = OPERATORS (table); s != NO_TAG; FORWARD (s)) {
 102        if (NSYMBOL (NODE (s)) == name) {
 103          return OP_SYMBOL;
 104        }
 105      }
 106      for (s = PRIO (table); s != NO_TAG; FORWARD (s)) {
 107        if (NSYMBOL (NODE (s)) == name) {
 108          return PRIO_SYMBOL;
 109        }
 110      }
 111      return first_tag_global (PREVIOUS (table), name);
 112    } else {
 113      return STOP;
 114    }
 115  }
 116  
 117  #define PORTCHECK_TAX(p, q) {\
 118    if (q == A68_FALSE) {\
 119      diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_TAG_NOT_PORTABLE);\
 120    }}
 121  
 122  //! @brief Check portability of sub tree.
 123  
 124  void portcheck (NODE_T * p)
 125  {
 126    for (; p != NO_NODE; FORWARD (p)) {
 127      portcheck (SUB (p));
 128      if (OPTION_PORTCHECK (&A68_JOB)) {
 129        if (IS (p, INDICANT) && MOID (p) != NO_MOID) {
 130          PORTCHECK_TAX (p, PORTABLE (MOID (p)));
 131          PORTABLE (MOID (p)) = A68_TRUE;
 132        } else if (IS (p, IDENTIFIER)) {
 133          PORTCHECK_TAX (p, PORTABLE (TAX (p)));
 134          PORTABLE (TAX (p)) = A68_TRUE;
 135        } else if (IS (p, OPERATOR)) {
 136          PORTCHECK_TAX (p, PORTABLE (TAX (p)));
 137          PORTABLE (TAX (p)) = A68_TRUE;
 138        } else if (IS (p, ASSERTION)) {
 139          diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_TAG_NOT_PORTABLE);
 140        }
 141      }
 142    }
 143  }
 144  
 145  //! @brief Whether routine can be "lengthety-mapped".
 146  
 147  BOOL_T is_mappable_routine (char *z)
 148  {
 149  #define ACCEPT(u, v) {\
 150    if (strlen (u) >= strlen (v)) {\
 151      if (strcmp (&u[strlen (u) - strlen (v)], v) == 0) {\
 152        return A68_TRUE;\
 153    }}}
 154  // Math routines.
 155    ACCEPT (z, "arccos");
 156    ACCEPT (z, "arccosdg");
 157    ACCEPT (z, "arccot");
 158    ACCEPT (z, "arccotdg");
 159    ACCEPT (z, "arcsin");
 160    ACCEPT (z, "arcsindg");
 161    ACCEPT (z, "arctan");
 162    ACCEPT (z, "arctandg");
 163    ACCEPT (z, "beta");
 164    ACCEPT (z, "betainc");
 165    ACCEPT (z, "cbrt");
 166    ACCEPT (z, "cos");
 167    ACCEPT (z, "cosdg");
 168    ACCEPT (z, "cospi");
 169    ACCEPT (z, "cot");
 170    ACCEPT (z, "cot");
 171    ACCEPT (z, "cotdg");
 172    ACCEPT (z, "cotpi");
 173    ACCEPT (z, "curt");
 174    ACCEPT (z, "erf");
 175    ACCEPT (z, "erfc");
 176    ACCEPT (z, "exp");
 177    ACCEPT (z, "gamma");
 178    ACCEPT (z, "gammainc");
 179    ACCEPT (z, "gammaincg");
 180    ACCEPT (z, "gammaincgf");
 181    ACCEPT (z, "ln");
 182    ACCEPT (z, "log");
 183    ACCEPT (z, "pi");
 184    ACCEPT (z, "sin");
 185    ACCEPT (z, "sindg");
 186    ACCEPT (z, "sinpi");
 187    ACCEPT (z, "sqrt");
 188    ACCEPT (z, "tan");
 189    ACCEPT (z, "tandg");
 190    ACCEPT (z, "tanpi");
 191  // Random generator.
 192    ACCEPT (z, "nextrandom");
 193    ACCEPT (z, "random");
 194  // BITS.
 195    ACCEPT (z, "bitspack");
 196  // Enquiries.
 197    ACCEPT (z, "maxint");
 198    ACCEPT (z, "intwidth");
 199    ACCEPT (z, "maxreal");
 200    ACCEPT (z, "realwidth");
 201    ACCEPT (z, "expwidth");
 202    ACCEPT (z, "maxbits");
 203    ACCEPT (z, "bitswidth");
 204    ACCEPT (z, "byteswidth");
 205    ACCEPT (z, "smallreal");
 206    return A68_FALSE;
 207  #undef ACCEPT
 208  }
 209  
 210  //! @brief Map "short sqrt" onto "sqrt" etcetera.
 211  
 212  TAG_T *bind_lengthety_identifier (char *u)
 213  {
 214  #define CAR(u, v) (strncmp (u, v, strlen(v)) == 0)
 215  // We can only map routines blessed by "is_mappable_routine", so there is no
 216  // "short print" or "long char in string".
 217    if (CAR (u, "short")) {
 218      do {
 219        char *v;
 220        TAG_T *w;
 221        u = &u[strlen ("short")];
 222        v = TEXT (add_token (&A68 (top_token), u));
 223        w = find_tag_local (A68_STANDENV, IDENTIFIER, v);
 224        if (w != NO_TAG && is_mappable_routine (v)) {
 225          return w;
 226        }
 227      } while (CAR (u, "short"));
 228    } else if (CAR (u, "long")) {
 229      do {
 230        char *v;
 231        TAG_T *w;
 232        u = &u[strlen ("long")];
 233        v = TEXT (add_token (&A68 (top_token), u));
 234        w = find_tag_local (A68_STANDENV, IDENTIFIER, v);
 235        if (w != NO_TAG && is_mappable_routine (v)) {
 236          return w;
 237        }
 238      } while (CAR (u, "long"));
 239    }
 240    return NO_TAG;
 241  #undef CAR
 242  }
 243  
 244  //! @brief Bind identifier tags to the symbol table.
 245  
 246  void bind_identifier_tag_to_symbol_table (NODE_T * p)
 247  {
 248    for (; p != NO_NODE; FORWARD (p)) {
 249      bind_identifier_tag_to_symbol_table (SUB (p));
 250      if (is_one_of (p, IDENTIFIER, DEFINING_IDENTIFIER, STOP)) {
 251        int att = first_tag_global (TABLE (p), NSYMBOL (p));
 252        TAG_T *z;
 253        if (att == STOP) {
 254          if ((z = bind_lengthety_identifier (NSYMBOL (p))) != NO_TAG) {
 255            MOID (p) = MOID (z);
 256          }
 257          TAX (p) = z;
 258        } else {
 259          z = find_tag_global (TABLE (p), att, NSYMBOL (p));
 260          if (att == IDENTIFIER && z != NO_TAG) {
 261            MOID (p) = MOID (z);
 262          } else if (att == LABEL && z != NO_TAG) {
 263            ;
 264          } else if ((z = bind_lengthety_identifier (NSYMBOL (p))) != NO_TAG) {
 265            MOID (p) = MOID (z);
 266          } else {
 267            diagnostic (A68_ERROR, p, ERROR_UNDECLARED_TAG);
 268            z = add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
 269            MOID (p) = M_ERROR;
 270          }
 271          TAX (p) = z;
 272          if (IS (p, DEFINING_IDENTIFIER)) {
 273            NODE (z) = p;
 274          }
 275        }
 276      }
 277    }
 278  }
 279  
 280  //! @brief Bind indicant tags to the symbol table.
 281  
 282  void bind_indicant_tag_to_symbol_table (NODE_T * p)
 283  {
 284    for (; p != NO_NODE; FORWARD (p)) {
 285      bind_indicant_tag_to_symbol_table (SUB (p));
 286      if (is_one_of (p, INDICANT, DEFINING_INDICANT, STOP)) {
 287        TAG_T *z = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
 288        if (z != NO_TAG) {
 289          MOID (p) = MOID (z);
 290          TAX (p) = z;
 291          if (IS (p, DEFINING_INDICANT)) {
 292            NODE (z) = p;
 293          }
 294        }
 295      }
 296    }
 297  }
 298  
 299  //! @brief Enter specifier identifiers in the symbol table.
 300  
 301  void tax_specifiers (NODE_T * p)
 302  {
 303    for (; p != NO_NODE; FORWARD (p)) {
 304      tax_specifiers (SUB (p));
 305      if (SUB (p) != NO_NODE && IS (p, SPECIFIER)) {
 306        tax_specifier_list (SUB (p));
 307      }
 308    }
 309  }
 310  
 311  //! @brief Enter specifier identifiers in the symbol table.
 312  
 313  void tax_specifier_list (NODE_T * p)
 314  {
 315    if (p != NO_NODE) {
 316      if (IS (p, OPEN_SYMBOL)) {
 317        tax_specifier_list (NEXT (p));
 318      } else if (is_one_of (p, CLOSE_SYMBOL, VOID_SYMBOL, STOP)) {
 319        ;
 320      } else if (IS (p, IDENTIFIER)) {
 321        TAG_T *z = add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, SPECIFIER_IDENTIFIER);
 322        HEAP (z) = LOC_SYMBOL;
 323      } else if (IS (p, DECLARER)) {
 324        tax_specifiers (SUB (p));
 325        tax_specifier_list (NEXT (p));
 326  // last identifier entry is identifier with this declarer.
 327        if (IDENTIFIERS (TABLE (p)) != NO_TAG && PRIO (IDENTIFIERS (TABLE (p))) == SPECIFIER_IDENTIFIER)
 328          MOID (IDENTIFIERS (TABLE (p))) = MOID (p);
 329      }
 330    }
 331  }
 332  
 333  //! @brief Enter parameter identifiers in the symbol table.
 334  
 335  void tax_parameters (NODE_T * p)
 336  {
 337    for (; p != NO_NODE; FORWARD (p)) {
 338      if (SUB (p) != NO_NODE) {
 339        tax_parameters (SUB (p));
 340        if (IS (p, PARAMETER_PACK)) {
 341          tax_parameter_list (SUB (p));
 342        }
 343      }
 344    }
 345  }
 346  
 347  //! @brief Enter parameter identifiers in the symbol table.
 348  
 349  void tax_parameter_list (NODE_T * p)
 350  {
 351    if (p != NO_NODE) {
 352      if (is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) {
 353        tax_parameter_list (NEXT (p));
 354      } else if (IS (p, CLOSE_SYMBOL)) {
 355        ;
 356      } else if (is_one_of (p, PARAMETER_LIST, PARAMETER, STOP)) {
 357        tax_parameter_list (NEXT (p));
 358        tax_parameter_list (SUB (p));
 359      } else if (IS (p, IDENTIFIER)) {
 360  // parameters are always local.
 361        HEAP (add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, PARAMETER_IDENTIFIER)) = LOC_SYMBOL;
 362      } else if (IS (p, DECLARER)) {
 363        TAG_T *s;
 364        tax_parameter_list (NEXT (p));
 365  // last identifier entries are identifiers with this declarer.
 366        for (s = IDENTIFIERS (TABLE (p)); s != NO_TAG && MOID (s) == NO_MOID; FORWARD (s)) {
 367          MOID (s) = MOID (p);
 368        }
 369        tax_parameters (SUB (p));
 370      }
 371    }
 372  }
 373  
 374  //! @brief Enter FOR identifiers in the symbol table.
 375  
 376  void tax_for_identifiers (NODE_T * p)
 377  {
 378    for (; p != NO_NODE; FORWARD (p)) {
 379      tax_for_identifiers (SUB (p));
 380      if (IS (p, FOR_SYMBOL)) {
 381        if ((FORWARD (p)) != NO_NODE) {
 382          (void) add_tag (TABLE (p), IDENTIFIER, p, M_INT, LOOP_IDENTIFIER);
 383        }
 384      }
 385    }
 386  }
 387  
 388  //! @brief Enter routine texts in the symbol table.
 389  
 390  void tax_routine_texts (NODE_T * p)
 391  {
 392    for (; p != NO_NODE; FORWARD (p)) {
 393      tax_routine_texts (SUB (p));
 394      if (IS (p, ROUTINE_TEXT)) {
 395        TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, MOID (p), ROUTINE_TEXT);
 396        TAX (p) = z;
 397        HEAP (z) = LOC_SYMBOL;
 398        USE (z) = A68_TRUE;
 399      }
 400    }
 401  }
 402  
 403  //! @brief Enter format texts in the symbol table.
 404  
 405  void tax_format_texts (NODE_T * p)
 406  {
 407    for (; p != NO_NODE; FORWARD (p)) {
 408      tax_format_texts (SUB (p));
 409      if (IS (p, FORMAT_TEXT)) {
 410        TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, M_FORMAT, FORMAT_TEXT);
 411        TAX (p) = z;
 412        USE (z) = A68_TRUE;
 413      } else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE) {
 414        TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, M_FORMAT, FORMAT_IDENTIFIER);
 415        TAX (p) = z;
 416        USE (z) = A68_TRUE;
 417      }
 418    }
 419  }
 420  
 421  //! @brief Enter FORMAT pictures in the symbol table.
 422  
 423  void tax_pictures (NODE_T * p)
 424  {
 425    for (; p != NO_NODE; FORWARD (p)) {
 426      tax_pictures (SUB (p));
 427      if (IS (p, PICTURE)) {
 428        TAX (p) = add_tag (TABLE (p), ANONYMOUS, p, M_COLLITEM, FORMAT_IDENTIFIER);
 429      }
 430    }
 431  }
 432  
 433  //! @brief Enter generators in the symbol table.
 434  
 435  void tax_generators (NODE_T * p)
 436  {
 437    for (; p != NO_NODE; FORWARD (p)) {
 438      tax_generators (SUB (p));
 439      if (IS (p, GENERATOR)) {
 440        if (IS (SUB (p), LOC_SYMBOL)) {
 441          TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (SUB (p)), GENERATOR);
 442          HEAP (z) = LOC_SYMBOL;
 443          USE (z) = A68_TRUE;
 444          TAX (p) = z;
 445        }
 446      }
 447    }
 448  }
 449  
 450  //! @brief Find a firmly related operator for operands.
 451  
 452  TAG_T *find_firmly_related_op (TABLE_T * c, char *n, MOID_T * l, MOID_T * r, TAG_T * self)
 453  {
 454    if (c != NO_TABLE) {
 455      TAG_T *s = OPERATORS (c);
 456      for (; s != NO_TAG; FORWARD (s)) {
 457        if (s != self && NSYMBOL (NODE (s)) == n) {
 458          PACK_T *t = PACK (MOID (s));
 459          if (t != NO_PACK && is_firm (MOID (t), l)) {
 460  // catch monadic operator.
 461            if ((FORWARD (t)) == NO_PACK) {
 462              if (r == NO_MOID) {
 463                return s;
 464              }
 465            } else {
 466  // catch dyadic operator.
 467              if (r != NO_MOID && is_firm (MOID (t), r)) {
 468                return s;
 469              }
 470            }
 471          }
 472        }
 473      }
 474    }
 475    return NO_TAG;
 476  }
 477  
 478  //! @brief Check for firmly related operators in this range.
 479  
 480  void test_firmly_related_ops_local (NODE_T * p, TAG_T * s)
 481  {
 482    if (s != NO_TAG) {
 483      PACK_T *u = PACK (MOID (s));
 484      if (u != NO_PACK) {
 485        MOID_T *l = MOID (u);
 486        MOID_T *r = (NEXT (u) != NO_PACK ? MOID (NEXT (u)) : NO_MOID);
 487        TAG_T *t = find_firmly_related_op (TAG_TABLE (s), NSYMBOL (NODE (s)), l, r, s);
 488        if (t != NO_TAG) {
 489          if (TAG_TABLE (t) == A68_STANDENV) {
 490            diagnostic (A68_ERROR, p, ERROR_OPERATOR_RELATED, MOID (s), NSYMBOL (NODE (s)), MOID (t), NSYMBOL (NODE (t)));
 491            ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 492          } else {
 493            diagnostic (A68_ERROR, p, ERROR_OPERATOR_RELATED, MOID (s), NSYMBOL (NODE (s)), MOID (t), NSYMBOL (NODE (t)));
 494          }
 495        }
 496      }
 497      if (NEXT (s) != NO_TAG) {
 498        test_firmly_related_ops_local ((p == NO_NODE ? NO_NODE : NODE (NEXT (s))), NEXT (s));
 499      }
 500    }
 501  }
 502  
 503  //! @brief Find firmly related operators in this program.
 504  
 505  void test_firmly_related_ops (NODE_T * p)
 506  {
 507    for (; p != NO_NODE; FORWARD (p)) {
 508      if (SUB (p) != NO_NODE && is_new_lexical_level (p)) {
 509        TAG_T *oops = OPERATORS (TABLE (SUB (p)));
 510        if (oops != NO_TAG) {
 511          test_firmly_related_ops_local (NODE (oops), oops);
 512        }
 513      }
 514      test_firmly_related_ops (SUB (p));
 515    }
 516  }
 517  
 518  //! @brief Driver for the processing of TAXes.
 519  
 520  void collect_taxes (NODE_T * p)
 521  {
 522    tax_tags (p);
 523    tax_specifiers (p);
 524    tax_parameters (p);
 525    tax_for_identifiers (p);
 526    tax_routine_texts (p);
 527    tax_pictures (p);
 528    tax_format_texts (p);
 529    tax_generators (p);
 530    bind_identifier_tag_to_symbol_table (p);
 531    bind_indicant_tag_to_symbol_table (p);
 532    test_firmly_related_ops (p);
 533    test_firmly_related_ops_local (NO_NODE, OPERATORS (A68_STANDENV));
 534  }
 535  
 536  //! @brief Whether tag has already been declared in this range.
 537  
 538  void already_declared (NODE_T * n, int a)
 539  {
 540    if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) {
 541      diagnostic (A68_ERROR, n, ERROR_MULTIPLE_TAG);
 542    }
 543  }
 544  
 545  //! @brief Whether tag has already been declared in this range.
 546  
 547  void already_declared_hidden (NODE_T * n, int a)
 548  {
 549    TAG_T *s;
 550    if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) {
 551      diagnostic (A68_ERROR, n, ERROR_MULTIPLE_TAG);
 552    }
 553    if ((s = find_tag_global (PREVIOUS (TABLE (n)), a, NSYMBOL (n))) != NO_TAG) {
 554      if (TAG_TABLE (s) == A68_STANDENV) {
 555        diagnostic (A68_WARNING, n, WARNING_HIDES_PRELUDE, MOID (s), NSYMBOL (n));
 556      } else {
 557        diagnostic (A68_WARNING, n, WARNING_HIDES, NSYMBOL (n));
 558      }
 559    }
 560  }
 561  
 562  //! @brief Add tag to local symbol table.
 563  
 564  TAG_T *add_tag (TABLE_T * s, int a, NODE_T * n, MOID_T * m, int p)
 565  {
 566  #define INSERT_TAG(l, n) {NEXT (n) = *(l); *(l) = (n);}
 567    if (s != NO_TABLE) {
 568      TAG_T *z = new_tag ();
 569      TAG_TABLE (z) = s;
 570      PRIO (z) = p;
 571      MOID (z) = m;
 572      NODE (z) = n;
 573  //    TAX(n) = z;.
 574      switch (a) {
 575      case IDENTIFIER:{
 576          already_declared_hidden (n, IDENTIFIER);
 577          already_declared_hidden (n, LABEL);
 578          INSERT_TAG (&IDENTIFIERS (s), z);
 579          break;
 580        }
 581      case INDICANT:{
 582          already_declared_hidden (n, INDICANT);
 583          already_declared (n, OP_SYMBOL);
 584          already_declared (n, PRIO_SYMBOL);
 585          INSERT_TAG (&INDICANTS (s), z);
 586          break;
 587        }
 588      case LABEL:{
 589          already_declared_hidden (n, LABEL);
 590          already_declared_hidden (n, IDENTIFIER);
 591          INSERT_TAG (&LABELS (s), z);
 592          break;
 593        }
 594      case OP_SYMBOL:{
 595          already_declared (n, INDICANT);
 596          INSERT_TAG (&OPERATORS (s), z);
 597          break;
 598        }
 599      case PRIO_SYMBOL:{
 600          already_declared (n, PRIO_SYMBOL);
 601          already_declared (n, INDICANT);
 602          INSERT_TAG (&PRIO (s), z);
 603          break;
 604        }
 605      case ANONYMOUS:{
 606          INSERT_TAG (&ANONYMOUS (s), z);
 607          break;
 608        }
 609      default:{
 610          ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 611        }
 612      }
 613      return z;
 614    } else {
 615      return NO_TAG;
 616    }
 617  }
 618  
 619  //! @brief Find a tag, searching symbol tables towards the root.
 620  
 621  TAG_T *find_tag_global (TABLE_T * table, int a, char *name)
 622  {
 623    if (table != NO_TABLE) {
 624      TAG_T *s = NO_TAG;
 625      switch (a) {
 626      case IDENTIFIER:{
 627          s = IDENTIFIERS (table);
 628          break;
 629        }
 630      case INDICANT:{
 631          s = INDICANTS (table);
 632          break;
 633        }
 634      case LABEL:{
 635          s = LABELS (table);
 636          break;
 637        }
 638      case OP_SYMBOL:{
 639          s = OPERATORS (table);
 640          break;
 641        }
 642      case PRIO_SYMBOL:{
 643          s = PRIO (table);
 644          break;
 645        }
 646      default:{
 647          ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 648          break;
 649        }
 650      }
 651      for (; s != NO_TAG; FORWARD (s)) {
 652        if (NSYMBOL (NODE (s)) == name) {
 653          return s;
 654        }
 655      }
 656      return find_tag_global (PREVIOUS (table), a, name);
 657    } else {
 658      return NO_TAG;
 659    }
 660  }
 661  
 662  //! @brief Whether identifier or label global.
 663  
 664  int is_identifier_or_label_global (TABLE_T * table, char *name)
 665  {
 666    if (table != NO_TABLE) {
 667      TAG_T *s;
 668      for (s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s)) {
 669        if (NSYMBOL (NODE (s)) == name) {
 670          return IDENTIFIER;
 671        }
 672      }
 673      for (s = LABELS (table); s != NO_TAG; FORWARD (s)) {
 674        if (NSYMBOL (NODE (s)) == name) {
 675          return LABEL;
 676        }
 677      }
 678      return is_identifier_or_label_global (PREVIOUS (table), name);
 679    } else {
 680      return 0;
 681    }
 682  }
 683  
 684  //! @brief Find a tag, searching only local symbol table.
 685  
 686  TAG_T *find_tag_local (TABLE_T * table, int a, char *name)
 687  {
 688    if (table != NO_TABLE) {
 689      TAG_T *s = NO_TAG;
 690      if (a == OP_SYMBOL) {
 691        s = OPERATORS (table);
 692      } else if (a == PRIO_SYMBOL) {
 693        s = PRIO (table);
 694      } else if (a == IDENTIFIER) {
 695        s = IDENTIFIERS (table);
 696      } else if (a == INDICANT) {
 697        s = INDICANTS (table);
 698      } else if (a == LABEL) {
 699        s = LABELS (table);
 700      } else {
 701        ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 702      }
 703      for (; s != NO_TAG; FORWARD (s)) {
 704        if (NSYMBOL (NODE (s)) == name) {
 705          return s;
 706        }
 707      }
 708    }
 709    return NO_TAG;
 710  }
 711  
 712  //! @brief Whether context specifies HEAP or LOC for an identifier.
 713  
 714  int tab_qualifier (NODE_T * p)
 715  {
 716    if (p != NO_NODE) {
 717      if (is_one_of (p, UNIT, ASSIGNATION, TERTIARY, SECONDARY, GENERATOR, STOP)) {
 718        return tab_qualifier (SUB (p));
 719      } else if (is_one_of (p, LOC_SYMBOL, HEAP_SYMBOL, NEW_SYMBOL, STOP)) {
 720        return ATTRIBUTE (p) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL;
 721      } else {
 722        return LOC_SYMBOL;
 723      }
 724    } else {
 725      return LOC_SYMBOL;
 726    }
 727  }
 728  
 729  //! @brief Enter identity declarations in the symbol table.
 730  
 731  void tax_identity_dec (NODE_T * p, MOID_T ** m)
 732  {
 733    if (p != NO_NODE) {
 734      if (IS (p, IDENTITY_DECLARATION)) {
 735        tax_identity_dec (SUB (p), m);
 736        tax_identity_dec (NEXT (p), m);
 737      } else if (IS (p, DECLARER)) {
 738        tax_tags (SUB (p));
 739        *m = MOID (p);
 740        tax_identity_dec (NEXT (p), m);
 741      } else if (IS (p, COMMA_SYMBOL)) {
 742        tax_identity_dec (NEXT (p), m);
 743      } else if (IS (p, DEFINING_IDENTIFIER)) {
 744        TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
 745        MOID (p) = *m;
 746        HEAP (entry) = LOC_SYMBOL;
 747        TAX (p) = entry;
 748        MOID (entry) = *m;
 749        if (ATTRIBUTE (*m) == REF_SYMBOL) {
 750          HEAP (entry) = tab_qualifier (NEXT_NEXT (p));
 751        }
 752        tax_identity_dec (NEXT_NEXT (p), m);
 753      } else {
 754        tax_tags (p);
 755      }
 756    }
 757  }
 758  
 759  //! @brief Enter variable declarations in the symbol table.
 760  
 761  void tax_variable_dec (NODE_T * p, int *q, MOID_T ** m)
 762  {
 763    if (p != NO_NODE) {
 764      if (IS (p, VARIABLE_DECLARATION)) {
 765        tax_variable_dec (SUB (p), q, m);
 766        tax_variable_dec (NEXT (p), q, m);
 767      } else if (IS (p, DECLARER)) {
 768        tax_tags (SUB (p));
 769        *m = MOID (p);
 770        tax_variable_dec (NEXT (p), q, m);
 771      } else if (IS (p, QUALIFIER)) {
 772        *q = ATTRIBUTE (SUB (p));
 773        tax_variable_dec (NEXT (p), q, m);
 774      } else if (IS (p, COMMA_SYMBOL)) {
 775        tax_variable_dec (NEXT (p), q, m);
 776      } else if (IS (p, DEFINING_IDENTIFIER)) {
 777        TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
 778        MOID (p) = *m;
 779        TAX (p) = entry;
 780        HEAP (entry) = *q;
 781        if (*q == LOC_SYMBOL) {
 782          TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, SUB (*m), GENERATOR);
 783          HEAP (z) = LOC_SYMBOL;
 784          USE (z) = A68_TRUE;
 785          BODY (entry) = z;
 786        } else {
 787          BODY (entry) = NO_TAG;
 788        }
 789        MOID (entry) = *m;
 790        tax_variable_dec (NEXT (p), q, m);
 791      } else {
 792        tax_tags (p);
 793      }
 794    }
 795  }
 796  
 797  //! @brief Enter procedure variable declarations in the symbol table.
 798  
 799  void tax_proc_variable_dec (NODE_T * p, int *q)
 800  {
 801    if (p != NO_NODE) {
 802      if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
 803        tax_proc_variable_dec (SUB (p), q);
 804        tax_proc_variable_dec (NEXT (p), q);
 805      } else if (IS (p, QUALIFIER)) {
 806        *q = ATTRIBUTE (SUB (p));
 807        tax_proc_variable_dec (NEXT (p), q);
 808      } else if (is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP)) {
 809        tax_proc_variable_dec (NEXT (p), q);
 810      } else if (IS (p, DEFINING_IDENTIFIER)) {
 811        TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
 812        TAX (p) = entry;
 813        HEAP (entry) = *q;
 814        MOID (entry) = MOID (p);
 815        if (*q == LOC_SYMBOL) {
 816          TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (p), GENERATOR);
 817          HEAP (z) = LOC_SYMBOL;
 818          USE (z) = A68_TRUE;
 819          BODY (entry) = z;
 820        } else {
 821          BODY (entry) = NO_TAG;
 822        }
 823        tax_proc_variable_dec (NEXT (p), q);
 824      } else {
 825        tax_tags (p);
 826      }
 827    }
 828  }
 829  
 830  //! @brief Enter procedure declarations in the symbol table.
 831  
 832  void tax_proc_dec (NODE_T * p)
 833  {
 834    if (p != NO_NODE) {
 835      if (IS (p, PROCEDURE_DECLARATION)) {
 836        tax_proc_dec (SUB (p));
 837        tax_proc_dec (NEXT (p));
 838      } else if (is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP)) {
 839        tax_proc_dec (NEXT (p));
 840      } else if (IS (p, DEFINING_IDENTIFIER)) {
 841        TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
 842        MOID_T *m = MOID (NEXT_NEXT (p));
 843        MOID (p) = m;
 844        TAX (p) = entry;
 845        CODEX (entry) |= PROC_DECLARATION_MASK;
 846        HEAP (entry) = LOC_SYMBOL;
 847        MOID (entry) = m;
 848        tax_proc_dec (NEXT (p));
 849      } else {
 850        tax_tags (p);
 851      }
 852    }
 853  }
 854  
 855  //! @brief Check validity of operator declaration.
 856  
 857  void check_operator_dec (NODE_T * p, MOID_T * u)
 858  {
 859    int k = 0;
 860    if (u == NO_MOID) {
 861      NODE_T *pack = SUB_SUB (NEXT_NEXT (p));     // Where the parameter pack is
 862      if (ATTRIBUTE (NEXT_NEXT (p)) != ROUTINE_TEXT) {
 863        pack = SUB (pack);
 864      }
 865      k = 1 + count_operands (pack);
 866    } else {
 867      k = count_pack_members (PACK (u));
 868    }
 869    if (k < 1 || k > 2) {
 870      diagnostic (A68_SYNTAX_ERROR, p, ERROR_OPERAND_NUMBER);
 871      k = 0;
 872    }
 873    if (k == 1 && strchr (NOMADS, NSYMBOL (p)[0]) != NO_TEXT) {
 874      diagnostic (A68_SYNTAX_ERROR, p, ERROR_OPERATOR_INVALID, NOMADS);
 875    } else if (k == 2 && !find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) {
 876      diagnostic (A68_SYNTAX_ERROR, p, ERROR_DYADIC_PRIORITY);
 877    }
 878  }
 879  
 880  //! @brief Enter operator declarations in the symbol table.
 881  
 882  void tax_op_dec (NODE_T * p, MOID_T ** m)
 883  {
 884    if (p != NO_NODE) {
 885      if (IS (p, OPERATOR_DECLARATION)) {
 886        tax_op_dec (SUB (p), m);
 887        tax_op_dec (NEXT (p), m);
 888      } else if (IS (p, OPERATOR_PLAN)) {
 889        tax_tags (SUB (p));
 890        *m = MOID (p);
 891        tax_op_dec (NEXT (p), m);
 892      } else if (IS (p, OP_SYMBOL)) {
 893        tax_op_dec (NEXT (p), m);
 894      } else if (IS (p, COMMA_SYMBOL)) {
 895        tax_op_dec (NEXT (p), m);
 896      } else if (IS (p, DEFINING_OPERATOR)) {
 897        TAG_T *entry = OPERATORS (TABLE (p));
 898        check_operator_dec (p, *m);
 899        while (entry != NO_TAG && NODE (entry) != p) {
 900          FORWARD (entry);
 901        }
 902        MOID (p) = *m;
 903        TAX (p) = entry;
 904        HEAP (entry) = LOC_SYMBOL;
 905        MOID (entry) = *m;
 906        tax_op_dec (NEXT (p), m);
 907      } else {
 908        tax_tags (p);
 909      }
 910    }
 911  }
 912  
 913  //! @brief Enter brief operator declarations in the symbol table.
 914  
 915  void tax_brief_op_dec (NODE_T * p)
 916  {
 917    if (p != NO_NODE) {
 918      if (IS (p, BRIEF_OPERATOR_DECLARATION)) {
 919        tax_brief_op_dec (SUB (p));
 920        tax_brief_op_dec (NEXT (p));
 921      } else if (is_one_of (p, OP_SYMBOL, COMMA_SYMBOL, STOP)) {
 922        tax_brief_op_dec (NEXT (p));
 923      } else if (IS (p, DEFINING_OPERATOR)) {
 924        TAG_T *entry = OPERATORS (TABLE (p));
 925        MOID_T *m = MOID (NEXT_NEXT (p));
 926        check_operator_dec (p, NO_MOID);
 927        while (entry != NO_TAG && NODE (entry) != p) {
 928          FORWARD (entry);
 929        }
 930        MOID (p) = m;
 931        TAX (p) = entry;
 932        HEAP (entry) = LOC_SYMBOL;
 933        MOID (entry) = m;
 934        tax_brief_op_dec (NEXT (p));
 935      } else {
 936        tax_tags (p);
 937      }
 938    }
 939  }
 940  
 941  //! @brief Enter priority declarations in the symbol table.
 942  
 943  void tax_prio_dec (NODE_T * p)
 944  {
 945    if (p != NO_NODE) {
 946      if (IS (p, PRIORITY_DECLARATION)) {
 947        tax_prio_dec (SUB (p));
 948        tax_prio_dec (NEXT (p));
 949      } else if (is_one_of (p, PRIO_SYMBOL, COMMA_SYMBOL, STOP)) {
 950        tax_prio_dec (NEXT (p));
 951      } else if (IS (p, DEFINING_OPERATOR)) {
 952        TAG_T *entry = PRIO (TABLE (p));
 953        while (entry != NO_TAG && NODE (entry) != p) {
 954          FORWARD (entry);
 955        }
 956        MOID (p) = NO_MOID;
 957        TAX (p) = entry;
 958        HEAP (entry) = LOC_SYMBOL;
 959        tax_prio_dec (NEXT (p));
 960      } else {
 961        tax_tags (p);
 962      }
 963    }
 964  }
 965  
 966  //! @brief Enter TAXes in the symbol table.
 967  
 968  void tax_tags (NODE_T * p)
 969  {
 970    for (; p != NO_NODE; FORWARD (p)) {
 971      int heap = LOC_SYMBOL;
 972      MOID_T *m = NO_MOID;
 973      if (IS (p, IDENTITY_DECLARATION)) {
 974        tax_identity_dec (p, &m);
 975      } else if (IS (p, VARIABLE_DECLARATION)) {
 976        tax_variable_dec (p, &heap, &m);
 977      } else if (IS (p, PROCEDURE_DECLARATION)) {
 978        tax_proc_dec (p);
 979      } else if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
 980        tax_proc_variable_dec (p, &heap);
 981      } else if (IS (p, OPERATOR_DECLARATION)) {
 982        tax_op_dec (p, &m);
 983      } else if (IS (p, BRIEF_OPERATOR_DECLARATION)) {
 984        tax_brief_op_dec (p);
 985      } else if (IS (p, PRIORITY_DECLARATION)) {
 986        tax_prio_dec (p);
 987      } else {
 988        tax_tags (SUB (p));
 989      }
 990    }
 991  }
 992  
 993  //! @brief Reset symbol table nest count.
 994  
 995  void reset_symbol_table_nest_count (NODE_T * p)
 996  {
 997    for (; p != NO_NODE; FORWARD (p)) {
 998      if (SUB (p) != NO_NODE && is_new_lexical_level (p)) {
 999        NEST (TABLE (SUB (p))) = A68 (symbol_table_count)++;
1000      }
1001      reset_symbol_table_nest_count (SUB (p));
1002    }
1003  }
1004  
1005  //! @brief Bind routines in symbol table to the tree.
1006  
1007  void bind_routine_tags_to_tree (NODE_T * p)
1008  {
1009  // By inserting coercions etc. some may have shifted.
1010    for (; p != NO_NODE; FORWARD (p)) {
1011      if (IS (p, ROUTINE_TEXT) && TAX (p) != NO_TAG) {
1012        NODE (TAX (p)) = p;
1013      }
1014      bind_routine_tags_to_tree (SUB (p));
1015    }
1016  }
1017  
1018  //! @brief Bind formats in symbol table to tree.
1019  
1020  void bind_format_tags_to_tree (NODE_T * p)
1021  {
1022  // By inserting coercions etc. some may have shifted.
1023    for (; p != NO_NODE; FORWARD (p)) {
1024      if (IS (p, FORMAT_TEXT) && TAX (p) != NO_TAG) {
1025        NODE (TAX (p)) = p;
1026      } else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE && TAX (p) != NO_TAG) {
1027        NODE (TAX (p)) = p;
1028      }
1029      bind_format_tags_to_tree (SUB (p));
1030    }
1031  }
1032  
1033  //! @brief Fill outer level of symbol table.
1034  
1035  void fill_symbol_table_outer (NODE_T * p, TABLE_T * s)
1036  {
1037    for (; p != NO_NODE; FORWARD (p)) {
1038      if (TABLE (p) != NO_TABLE) {
1039        OUTER (TABLE (p)) = s;
1040      }
1041      if (SUB (p) != NO_NODE && IS (p, ROUTINE_TEXT)) {
1042        fill_symbol_table_outer (SUB (p), TABLE (SUB (p)));
1043      } else if (SUB (p) != NO_NODE && IS (p, FORMAT_TEXT)) {
1044        fill_symbol_table_outer (SUB (p), TABLE (SUB (p)));
1045      } else {
1046        fill_symbol_table_outer (SUB (p), s);
1047      }
1048    }
1049  }
1050  
1051  //! @brief Flood branch in tree with local symbol table "s".
1052  
1053  void flood_with_symbol_table_restricted (NODE_T * p, TABLE_T * s)
1054  {
1055    for (; p != NO_NODE; FORWARD (p)) {
1056      TABLE (p) = s;
1057      if (ATTRIBUTE (p) != ROUTINE_TEXT && ATTRIBUTE (p) != SPECIFIED_UNIT) {
1058        if (is_new_lexical_level (p)) {
1059          PREVIOUS (TABLE (SUB (p))) = s;
1060        } else {
1061          flood_with_symbol_table_restricted (SUB (p), s);
1062        }
1063      }
1064    }
1065  }
1066  
1067  //! @brief Final structure of symbol table after parsing.
1068  
1069  void finalise_symbol_table_setup (NODE_T * p, int l)
1070  {
1071    TABLE_T *s = TABLE (p);
1072    NODE_T *q = p;
1073    while (q != NO_NODE) {
1074  // routine texts are ranges.
1075      if (IS (q, ROUTINE_TEXT)) {
1076        flood_with_symbol_table_restricted (SUB (q), new_symbol_table (s));
1077      }
1078  // specifiers are ranges.
1079      else if (IS (q, SPECIFIED_UNIT)) {
1080        flood_with_symbol_table_restricted (SUB (q), new_symbol_table (s));
1081      }
1082  // level count and recursion.
1083      if (SUB (q) != NO_NODE) {
1084        if (is_new_lexical_level (q)) {
1085          LEX_LEVEL (SUB (q)) = l + 1;
1086          PREVIOUS (TABLE (SUB (q))) = s;
1087          finalise_symbol_table_setup (SUB (q), l + 1);
1088          if (IS (q, WHILE_PART)) {
1089  // This was a bug that went unnoticed for 15 years!.
1090            TABLE_T *s2 = TABLE (SUB (q));
1091            if ((FORWARD (q)) == NO_NODE) {
1092              return;
1093            }
1094            if (IS (q, ALT_DO_PART)) {
1095              PREVIOUS (TABLE (SUB (q))) = s2;
1096              LEX_LEVEL (SUB (q)) = l + 2;
1097              finalise_symbol_table_setup (SUB (q), l + 2);
1098            }
1099          }
1100        } else {
1101          TABLE (SUB (q)) = s;
1102          finalise_symbol_table_setup (SUB (q), l);
1103        }
1104      }
1105      TABLE (q) = s;
1106      if (IS (q, FOR_SYMBOL)) {
1107        FORWARD (q);
1108      }
1109      FORWARD (q);
1110    }
1111  // FOR identifiers are in the DO ... OD range.
1112    for (q = p; q != NO_NODE; FORWARD (q)) {
1113      if (IS (q, FOR_SYMBOL)) {
1114        TABLE (NEXT (q)) = TABLE (SEQUENCE (NEXT (q)));
1115      }
1116    }
1117  }
1118  
1119  //! @brief First structure of symbol table for parsing.
1120  
1121  void preliminary_symbol_table_setup (NODE_T * p)
1122  {
1123    NODE_T *q;
1124    TABLE_T *s = TABLE (p);
1125    BOOL_T not_a_for_range = A68_FALSE;
1126  // let the tree point to the current symbol table.
1127    for (q = p; q != NO_NODE; FORWARD (q)) {
1128      TABLE (q) = s;
1129    }
1130  // insert new tables when required.
1131    for (q = p; q != NO_NODE && !not_a_for_range; FORWARD (q)) {
1132      if (SUB (q) != NO_NODE) {
1133  // BEGIN ... END, CODE ... EDOC, DEF ... FED, DO ... OD, $ ... $, { ... } are ranges.
1134        if (is_one_of (q, BEGIN_SYMBOL, DO_SYMBOL, ALT_DO_SYMBOL, FORMAT_DELIMITER_SYMBOL, ACCO_SYMBOL, STOP)) {
1135          TABLE (SUB (q)) = new_symbol_table (s);
1136          preliminary_symbol_table_setup (SUB (q));
1137        }
1138  // ( ... ) is a range.
1139        else if (IS (q, OPEN_SYMBOL)) {
1140          if (whether (q, OPEN_SYMBOL, THEN_BAR_SYMBOL, STOP)) {
1141            TABLE (SUB (q)) = s;
1142            preliminary_symbol_table_setup (SUB (q));
1143            FORWARD (q);
1144            TABLE (SUB (q)) = new_symbol_table (s);
1145            preliminary_symbol_table_setup (SUB (q));
1146            if ((FORWARD (q)) == NO_NODE) {
1147              not_a_for_range = A68_TRUE;
1148            } else {
1149              if (IS (q, THEN_BAR_SYMBOL)) {
1150                TABLE (SUB (q)) = new_symbol_table (s);
1151                preliminary_symbol_table_setup (SUB (q));
1152              }
1153              if (IS (q, OPEN_SYMBOL)) {
1154                TABLE (SUB (q)) = new_symbol_table (s);
1155                preliminary_symbol_table_setup (SUB (q));
1156              }
1157            }
1158          } else {
1159  // don't worry about STRUCT (...), UNION (...), PROC (...) yet.
1160            TABLE (SUB (q)) = new_symbol_table (s);
1161            preliminary_symbol_table_setup (SUB (q));
1162          }
1163        }
1164  // IF ... THEN ... ELSE ... FI are ranges.
1165        else if (IS (q, IF_SYMBOL)) {
1166          if (whether (q, IF_SYMBOL, THEN_SYMBOL, STOP)) {
1167            TABLE (SUB (q)) = s;
1168            preliminary_symbol_table_setup (SUB (q));
1169            FORWARD (q);
1170            TABLE (SUB (q)) = new_symbol_table (s);
1171            preliminary_symbol_table_setup (SUB (q));
1172            if ((FORWARD (q)) == NO_NODE) {
1173              not_a_for_range = A68_TRUE;
1174            } else {
1175              if (IS (q, ELSE_SYMBOL)) {
1176                TABLE (SUB (q)) = new_symbol_table (s);
1177                preliminary_symbol_table_setup (SUB (q));
1178              }
1179              if (IS (q, IF_SYMBOL)) {
1180                TABLE (SUB (q)) = new_symbol_table (s);
1181                preliminary_symbol_table_setup (SUB (q));
1182              }
1183            }
1184          } else {
1185            TABLE (SUB (q)) = new_symbol_table (s);
1186            preliminary_symbol_table_setup (SUB (q));
1187          }
1188        }
1189  // CASE ... IN ... OUT ... ESAC are ranges.
1190        else if (IS (q, CASE_SYMBOL)) {
1191          if (whether (q, CASE_SYMBOL, IN_SYMBOL, STOP)) {
1192            TABLE (SUB (q)) = s;
1193            preliminary_symbol_table_setup (SUB (q));
1194            FORWARD (q);
1195            TABLE (SUB (q)) = new_symbol_table (s);
1196            preliminary_symbol_table_setup (SUB (q));
1197            if ((FORWARD (q)) == NO_NODE) {
1198              not_a_for_range = A68_TRUE;
1199            } else {
1200              if (IS (q, OUT_SYMBOL)) {
1201                TABLE (SUB (q)) = new_symbol_table (s);
1202                preliminary_symbol_table_setup (SUB (q));
1203              }
1204              if (IS (q, CASE_SYMBOL)) {
1205                TABLE (SUB (q)) = new_symbol_table (s);
1206                preliminary_symbol_table_setup (SUB (q));
1207              }
1208            }
1209          } else {
1210            TABLE (SUB (q)) = new_symbol_table (s);
1211            preliminary_symbol_table_setup (SUB (q));
1212          }
1213        }
1214  // UNTIL ... OD is a range.
1215        else if (IS (q, UNTIL_SYMBOL) && SUB (q) != NO_NODE) {
1216          TABLE (SUB (q)) = new_symbol_table (s);
1217          preliminary_symbol_table_setup (SUB (q));
1218  // WHILE ... DO ... OD are ranges.
1219        } else if (IS (q, WHILE_SYMBOL)) {
1220          TABLE_T *u = new_symbol_table (s);
1221          TABLE (SUB (q)) = u;
1222          preliminary_symbol_table_setup (SUB (q));
1223          if ((FORWARD (q)) == NO_NODE) {
1224            not_a_for_range = A68_TRUE;
1225          } else if (IS (q, ALT_DO_SYMBOL)) {
1226            TABLE (SUB (q)) = new_symbol_table (u);
1227            preliminary_symbol_table_setup (SUB (q));
1228          }
1229        } else {
1230          TABLE (SUB (q)) = s;
1231          preliminary_symbol_table_setup (SUB (q));
1232        }
1233      }
1234    }
1235  // FOR identifiers will go to the DO ... OD range.
1236    if (!not_a_for_range) {
1237      for (q = p; q != NO_NODE; FORWARD (q)) {
1238        if (IS (q, FOR_SYMBOL)) {
1239          NODE_T *r = q;
1240          TABLE (NEXT (q)) = NO_TABLE;
1241          for (; r != NO_NODE && TABLE (NEXT (q)) == NO_TABLE; FORWARD (r)) {
1242            if ((is_one_of (r, WHILE_SYMBOL, ALT_DO_SYMBOL, STOP)) && (NEXT (q) != NO_NODE && SUB (r) != NO_NODE)) {
1243              TABLE (NEXT (q)) = TABLE (SUB (r));
1244              SEQUENCE (NEXT (q)) = SUB (r);
1245            }
1246          }
1247        }
1248      }
1249    }
1250  }
1251  
1252  //! @brief Mark a mode as in use.
1253  
1254  void mark_mode (MOID_T * m)
1255  {
1256    if (m != NO_MOID && USE (m) == A68_FALSE) {
1257      PACK_T *p = PACK (m);
1258      USE (m) = A68_TRUE;
1259      for (; p != NO_PACK; FORWARD (p)) {
1260        mark_mode (MOID (p));
1261        mark_mode (SUB (m));
1262        mark_mode (SLICE (m));
1263      }
1264    }
1265  }
1266  
1267  //! @brief Traverse tree and mark modes as used.
1268  
1269  void mark_moids (NODE_T * p)
1270  {
1271    for (; p != NO_NODE; FORWARD (p)) {
1272      mark_moids (SUB (p));
1273      if (MOID (p) != NO_MOID) {
1274        mark_mode (MOID (p));
1275      }
1276    }
1277  }
1278  
1279  //! @brief Mark various tags as used.
1280  
1281  void mark_auxilliary (NODE_T * p)
1282  {
1283    for (; p != NO_NODE; FORWARD (p)) {
1284      if (SUB (p) != NO_NODE) {
1285  // You get no warnings on unused PROC parameters. That is ok since A68 has some
1286  // parameters that you may not use at all - think of PROC (REF FILE) BOOL event
1287  // routines in transput.
1288        mark_auxilliary (SUB (p));
1289      } else if (IS (p, OPERATOR)) {
1290        TAG_T *z;
1291        if (TAX (p) != NO_TAG) {
1292          USE (TAX (p)) = A68_TRUE;
1293        }
1294        if ((z = find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) != NO_TAG) {
1295          USE (z) = A68_TRUE;
1296        }
1297      } else if (IS (p, INDICANT)) {
1298        TAG_T *z = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
1299        if (z != NO_TAG) {
1300          TAX (p) = z;
1301          USE (z) = A68_TRUE;
1302        }
1303      } else if (IS (p, IDENTIFIER)) {
1304        if (TAX (p) != NO_TAG) {
1305          USE (TAX (p)) = A68_TRUE;
1306        }
1307      }
1308    }
1309  }
1310  
1311  //! @brief Check a single tag.
1312  
1313  void unused (TAG_T * s)
1314  {
1315    for (; s != NO_TAG; FORWARD (s)) {
1316      if (LINE_NUMBER (NODE (s)) > 0 && !USE (s)) {
1317        diagnostic (A68_WARNING, NODE (s), WARNING_TAG_UNUSED, NODE (s));
1318      }
1319    }
1320  }
1321  
1322  //! @brief Driver for traversing tree and warn for unused tags.
1323  
1324  void warn_for_unused_tags (NODE_T * p)
1325  {
1326    for (; p != NO_NODE; FORWARD (p)) {
1327      if (SUB (p) != NO_NODE) {
1328        if (is_new_lexical_level (p) && ATTRIBUTE (TABLE (SUB (p))) != ENVIRON_SYMBOL) {
1329          unused (OPERATORS (TABLE (SUB (p))));
1330          unused (PRIO (TABLE (SUB (p))));
1331          unused (IDENTIFIERS (TABLE (SUB (p))));
1332          unused (LABELS (TABLE (SUB (p))));
1333          unused (INDICANTS (TABLE (SUB (p))));
1334        }
1335      }
1336      warn_for_unused_tags (SUB (p));
1337    }
1338  }
1339  
1340  //! @brief Mark jumps and procedured jumps.
1341  
1342  void jumps_from_procs (NODE_T * p)
1343  {
1344    for (; p != NO_NODE; FORWARD (p)) {
1345      if (IS (p, PROCEDURING)) {
1346        NODE_T *u = SUB_SUB (p);
1347        if (IS (u, GOTO_SYMBOL)) {
1348          FORWARD (u);
1349        }
1350        USE (TAX (u)) = A68_TRUE;
1351      } else if (IS (p, JUMP)) {
1352        NODE_T *u = SUB (p);
1353        if (IS (u, GOTO_SYMBOL)) {
1354          FORWARD (u);
1355        }
1356        if ((TAX (u) == NO_TAG) && (MOID (u) == NO_MOID) && (find_tag_global (TABLE (u), LABEL, NSYMBOL (u)) == NO_TAG)) {
1357          (void) add_tag (TABLE (u), LABEL, u, NO_MOID, LOCAL_LABEL);
1358          diagnostic (A68_ERROR, u, ERROR_UNDECLARED_TAG);
1359        } else {
1360          USE (TAX (u)) = A68_TRUE;
1361        }
1362      } else {
1363        jumps_from_procs (SUB (p));
1364      }
1365    }
1366  }
1367  
1368  //! @brief Assign offset tags.
1369  
1370  ADDR_T assign_offset_tags (TAG_T * t, ADDR_T base)
1371  {
1372    ADDR_T sum = base;
1373    for (; t != NO_TAG; FORWARD (t)) {
1374      ABEND (MOID (t) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, NSYMBOL (NODE (t)));
1375      SIZE (t) = moid_size (MOID (t));
1376      if (VALUE (t) == NO_TEXT) {
1377        OFFSET (t) = sum;
1378        sum += SIZE (t);
1379      }
1380    }
1381    return sum;
1382  }
1383  
1384  //! @brief Assign offsets table.
1385  
1386  void assign_offsets_table (TABLE_T * c)
1387  {
1388    AP_INCREMENT (c) = assign_offset_tags (IDENTIFIERS (c), 0);
1389    AP_INCREMENT (c) = assign_offset_tags (OPERATORS (c), AP_INCREMENT (c));
1390    AP_INCREMENT (c) = assign_offset_tags (ANONYMOUS (c), AP_INCREMENT (c));
1391    AP_INCREMENT (c) = A68_ALIGN (AP_INCREMENT (c));
1392  }
1393  
1394  //! @brief Assign offsets.
1395  
1396  void assign_offsets (NODE_T * p)
1397  {
1398    for (; p != NO_NODE; FORWARD (p)) {
1399      if (SUB (p) != NO_NODE && is_new_lexical_level (p)) {
1400        assign_offsets_table (TABLE (SUB (p)));
1401      }
1402      assign_offsets (SUB (p));
1403    }
1404  }
1405  
1406  //! @brief Assign offsets packs in moid list.
1407  
1408  void assign_offsets_packs (MOID_T * q)
1409  {
1410    for (; q != NO_MOID; FORWARD (q)) {
1411      if (EQUIVALENT (q) == NO_MOID && IS (q, STRUCT_SYMBOL)) {
1412        PACK_T *p = PACK (q);
1413        ADDR_T offset = 0;
1414        for (; p != NO_PACK; FORWARD (p)) {
1415          SIZE (p) = moid_size (MOID (p));
1416          OFFSET (p) = offset;
1417          offset += SIZE (p);
1418        }
1419      }
1420    }
1421  }