parser-scope.c

     
   1  //! @file parser-scope.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  //! Static scope checker.
  25  
  26  // A static scope checker inspects the source. Note that Algol 68 also 
  27  // needs dynamic scope checking. This phase concludes the parser.
  28  
  29  #include "a68g.h"
  30  #include "a68g-parser.h"
  31  
  32  typedef struct TUPLE_T TUPLE_T;
  33  typedef struct SCOPE_T SCOPE_T;
  34  
  35  struct TUPLE_T
  36  {
  37    int level;
  38    BOOL_T transient;
  39  };
  40  
  41  struct SCOPE_T
  42  {
  43    NODE_T *where;
  44    TUPLE_T tuple;
  45    SCOPE_T *next;
  46  };
  47  
  48  enum
  49  { NOT_TRANSIENT = 0, TRANSIENT };
  50  
  51  void gather_scopes_for_youngest (NODE_T *, SCOPE_T **);
  52  void scope_statement (NODE_T *, SCOPE_T **);
  53  void scope_enclosed_clause (NODE_T *, SCOPE_T **);
  54  void scope_formula (NODE_T *, SCOPE_T **);
  55  void scope_routine_text (NODE_T *, SCOPE_T **);
  56  
  57  // Static scope checker, at run time we check dynamic scope as well.
  58  
  59  // Static scope checker. 
  60  // Also a little preparation for the monitor:
  61  // - indicates UNITs that can be interrupted.
  62  
  63  //! @brief Scope_make_tuple.
  64  
  65  TUPLE_T scope_make_tuple (int e, int t)
  66  {
  67    static TUPLE_T z;
  68    LEVEL (&z) = e;
  69    TRANSIENT (&z) = (BOOL_T) t;
  70    return z;
  71  }
  72  
  73  //! @brief Link scope information into the list.
  74  
  75  void scope_add (SCOPE_T ** sl, NODE_T * p, TUPLE_T tup)
  76  {
  77    if (sl != NO_VAR) {
  78      SCOPE_T *ns = (SCOPE_T *) get_temp_heap_space ((unt) SIZE_ALIGNED (SCOPE_T));
  79      WHERE (ns) = p;
  80      TUPLE (ns) = tup;
  81      NEXT (ns) = *sl;
  82      *sl = ns;
  83    }
  84  }
  85  
  86  //! @brief Scope_check.
  87  
  88  BOOL_T scope_check (SCOPE_T * top, int mask, int dest)
  89  {
  90    SCOPE_T *s;
  91    int errors = 0;
  92  // Transient names cannot be stored.
  93    if (mask & TRANSIENT) {
  94      for (s = top; s != NO_SCOPE; FORWARD (s)) {
  95        if (TRANSIENT (&TUPLE (s)) & TRANSIENT) {
  96          diagnostic (A68_ERROR, WHERE (s), ERROR_TRANSIENT_NAME);
  97          STATUS_SET (WHERE (s), SCOPE_ERROR_MASK);
  98          errors++;
  99        }
 100      }
 101    }
 102  // Potential scope violations.
 103    for (s = top; s != NO_SCOPE; FORWARD (s)) {
 104      if (dest < LEVEL (&TUPLE (s)) && !STATUS_TEST (WHERE (s), SCOPE_ERROR_MASK)) {
 105        MOID_T *ws = MOID (WHERE (s));
 106        if (ws != NO_MOID) {
 107          if (IS_REF (ws) || IS (ws, PROC_SYMBOL) || IS (ws, FORMAT_SYMBOL) || IS (ws, UNION_SYMBOL)) {
 108            diagnostic (A68_WARNING, WHERE (s), WARNING_SCOPE_STATIC, MOID (WHERE (s)), ATTRIBUTE (WHERE (s)));
 109          }
 110        }
 111        STATUS_SET (WHERE (s), SCOPE_ERROR_MASK);
 112        errors++;
 113      }
 114    }
 115    return (BOOL_T) (errors == 0);
 116  }
 117  
 118  //! @brief Scope_check_multiple.
 119  
 120  BOOL_T scope_check_multiple (SCOPE_T * top, int mask, SCOPE_T * dest)
 121  {
 122    BOOL_T no_err = A68_TRUE;
 123    for (; dest != NO_SCOPE; FORWARD (dest)) {
 124      no_err &= scope_check (top, mask, LEVEL (&TUPLE (dest)));
 125    }
 126    return no_err;
 127  }
 128  
 129  //! @brief Check_identifier_usage.
 130  
 131  void check_identifier_usage (TAG_T * t, NODE_T * p)
 132  {
 133    for (; p != NO_NODE; FORWARD (p)) {
 134      if (IS (p, IDENTIFIER) && TAX (p) == t && ATTRIBUTE (MOID (t)) != PROC_SYMBOL) {
 135        diagnostic (A68_WARNING, p, WARNING_UNINITIALISED);
 136      }
 137      check_identifier_usage (t, SUB (p));
 138    }
 139  }
 140  
 141  //! @brief Scope_find_youngest_outside.
 142  
 143  TUPLE_T scope_find_youngest_outside (SCOPE_T * s, int treshold)
 144  {
 145    TUPLE_T z = scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT);
 146    for (; s != NO_SCOPE; FORWARD (s)) {
 147      if (LEVEL (&TUPLE (s)) > LEVEL (&z) && LEVEL (&TUPLE (s)) <= treshold) {
 148        z = TUPLE (s);
 149      }
 150    }
 151    return z;
 152  }
 153  
 154  //! @brief Scope_find_youngest.
 155  
 156  TUPLE_T scope_find_youngest (SCOPE_T * s)
 157  {
 158    return scope_find_youngest_outside (s, INT_MAX);
 159  }
 160  
 161  // Routines for determining scope of ROUTINE TEXT or FORMAT TEXT.
 162  
 163  //! @brief Get_declarer_elements.
 164  
 165  void get_declarer_elements (NODE_T * p, SCOPE_T ** r, BOOL_T no_ref)
 166  {
 167    if (p != NO_NODE) {
 168      if (IS (p, BOUNDS)) {
 169        gather_scopes_for_youngest (SUB (p), r);
 170      } else if (IS (p, INDICANT)) {
 171        if (MOID (p) != NO_MOID && TAX (p) != NO_TAG && HAS_ROWS (MOID (p)) && no_ref) {
 172          scope_add (r, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT));
 173        }
 174      } else if (IS_REF (p)) {
 175        get_declarer_elements (NEXT (p), r, A68_FALSE);
 176      } else if (is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) {
 177        ;
 178      } else {
 179        get_declarer_elements (SUB (p), r, no_ref);
 180        get_declarer_elements (NEXT (p), r, no_ref);
 181      }
 182    }
 183  }
 184  
 185  //! @brief Gather_scopes_for_youngest.
 186  
 187  void gather_scopes_for_youngest (NODE_T * p, SCOPE_T ** s)
 188  {
 189    for (; p != NO_NODE; FORWARD (p)) {
 190      if ((is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP)) && (YOUNGEST_ENVIRON (TAX (p)) == PRIMAL_SCOPE)) {
 191        SCOPE_T *t = NO_SCOPE;
 192        TUPLE_T tup;
 193        gather_scopes_for_youngest (SUB (p), &t);
 194        tup = scope_find_youngest_outside (t, LEX_LEVEL (p));
 195        YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup);
 196  // Direct link into list iso "gather_scopes_for_youngest (SUB (p), s);".
 197        if (t != NO_SCOPE) {
 198          SCOPE_T *u = t;
 199          while (NEXT (u) != NO_SCOPE) {
 200            FORWARD (u);
 201          }
 202          NEXT (u) = *s;
 203          (*s) = t;
 204        }
 205      } else if (is_one_of (p, IDENTIFIER, OPERATOR, STOP)) {
 206        if (TAX (p) != NO_TAG && TAG_LEX_LEVEL (TAX (p)) != PRIMAL_SCOPE) {
 207          scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT));
 208        }
 209      } else if (IS (p, DECLARER)) {
 210        get_declarer_elements (p, s, A68_TRUE);
 211      } else {
 212        gather_scopes_for_youngest (SUB (p), s);
 213      }
 214    }
 215  }
 216  
 217  //! @brief Get_youngest_environs.
 218  
 219  void get_youngest_environs (NODE_T * p)
 220  {
 221    for (; p != NO_NODE; FORWARD (p)) {
 222      if (is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP)) {
 223        SCOPE_T *s = NO_SCOPE;
 224        TUPLE_T tup;
 225        gather_scopes_for_youngest (SUB (p), &s);
 226        tup = scope_find_youngest_outside (s, LEX_LEVEL (p));
 227        YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup);
 228      } else {
 229        get_youngest_environs (SUB (p));
 230      }
 231    }
 232  }
 233  
 234  //! @brief Bind_scope_to_tag.
 235  
 236  void bind_scope_to_tag (NODE_T * p)
 237  {
 238    for (; p != NO_NODE; FORWARD (p)) {
 239      if (IS (p, DEFINING_IDENTIFIER) && MOID (p) == M_FORMAT) {
 240        if (IS (NEXT_NEXT (p), FORMAT_TEXT)) {
 241          SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p)));
 242          SCOPE_ASSIGNED (TAX (p)) = A68_TRUE;
 243        }
 244        return;
 245      } else if (IS (p, DEFINING_IDENTIFIER)) {
 246        if (IS (NEXT_NEXT (p), ROUTINE_TEXT)) {
 247          SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p)));
 248          SCOPE_ASSIGNED (TAX (p)) = A68_TRUE;
 249        }
 250        return;
 251      } else {
 252        bind_scope_to_tag (SUB (p));
 253      }
 254    }
 255  }
 256  
 257  //! @brief Bind_scope_to_tags.
 258  
 259  void bind_scope_to_tags (NODE_T * p)
 260  {
 261    for (; p != NO_NODE; FORWARD (p)) {
 262      if (is_one_of (p, PROCEDURE_DECLARATION, IDENTITY_DECLARATION, STOP)) {
 263        bind_scope_to_tag (SUB (p));
 264      } else {
 265        bind_scope_to_tags (SUB (p));
 266      }
 267    }
 268  }
 269  
 270  //! @brief Scope_bounds.
 271  
 272  void scope_bounds (NODE_T * p)
 273  {
 274    for (; p != NO_NODE; FORWARD (p)) {
 275      if (IS (p, UNIT)) {
 276        scope_statement (p, NO_VAR);
 277      } else {
 278        scope_bounds (SUB (p));
 279      }
 280    }
 281  }
 282  
 283  //! @brief Scope_declarer.
 284  
 285  void scope_declarer (NODE_T * p)
 286  {
 287    if (p != NO_NODE) {
 288      if (IS (p, BOUNDS)) {
 289        scope_bounds (SUB (p));
 290      } else if (IS (p, INDICANT)) {
 291        ;
 292      } else if (IS_REF (p)) {
 293        scope_declarer (NEXT (p));
 294      } else if (is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) {
 295        ;
 296      } else {
 297        scope_declarer (SUB (p));
 298        scope_declarer (NEXT (p));
 299      }
 300    }
 301  }
 302  
 303  //! @brief Scope_identity_declaration.
 304  
 305  void scope_identity_declaration (NODE_T * p)
 306  {
 307    for (; p != NO_NODE; FORWARD (p)) {
 308      scope_identity_declaration (SUB (p));
 309      if (IS (p, DEFINING_IDENTIFIER)) {
 310        NODE_T *unit = NEXT_NEXT (p);
 311        SCOPE_T *s = NO_SCOPE;
 312        TUPLE_T tup;
 313        int z = PRIMAL_SCOPE;
 314        if (ATTRIBUTE (MOID (TAX (p))) != PROC_SYMBOL) {
 315          check_identifier_usage (TAX (p), unit);
 316        }
 317        scope_statement (unit, &s);
 318        (void) scope_check (s, TRANSIENT, LEX_LEVEL (p));
 319        tup = scope_find_youngest (s);
 320        z = LEVEL (&tup);
 321        if (z < LEX_LEVEL (p)) {
 322          SCOPE (TAX (p)) = z;
 323          SCOPE_ASSIGNED (TAX (p)) = A68_TRUE;
 324        }
 325        STATUS_SET (unit, INTERRUPTIBLE_MASK);
 326        return;
 327      }
 328    }
 329  }
 330  
 331  //! @brief Scope_variable_declaration.
 332  
 333  void scope_variable_declaration (NODE_T * p)
 334  {
 335    for (; p != NO_NODE; FORWARD (p)) {
 336      scope_variable_declaration (SUB (p));
 337      if (IS (p, DECLARER)) {
 338        scope_declarer (SUB (p));
 339      } else if (IS (p, DEFINING_IDENTIFIER)) {
 340        if (whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) {
 341          NODE_T *unit = NEXT_NEXT (p);
 342          SCOPE_T *s = NO_SCOPE;
 343          check_identifier_usage (TAX (p), unit);
 344          scope_statement (unit, &s);
 345          (void) scope_check (s, TRANSIENT, LEX_LEVEL (p));
 346          STATUS_SET (unit, INTERRUPTIBLE_MASK);
 347          return;
 348        }
 349      }
 350    }
 351  }
 352  
 353  //! @brief Scope_procedure_declaration.
 354  
 355  void scope_procedure_declaration (NODE_T * p)
 356  {
 357    for (; p != NO_NODE; FORWARD (p)) {
 358      scope_procedure_declaration (SUB (p));
 359      if (is_one_of (p, DEFINING_IDENTIFIER, DEFINING_OPERATOR, STOP)) {
 360        NODE_T *unit = NEXT_NEXT (p);
 361        SCOPE_T *s = NO_SCOPE;
 362        scope_statement (unit, &s);
 363        (void) scope_check (s, NOT_TRANSIENT, LEX_LEVEL (p));
 364        STATUS_SET (unit, INTERRUPTIBLE_MASK);
 365        return;
 366      }
 367    }
 368  }
 369  
 370  //! @brief Scope_declaration_list.
 371  
 372  void scope_declaration_list (NODE_T * p)
 373  {
 374    if (p != NO_NODE) {
 375      if (IS (p, IDENTITY_DECLARATION)) {
 376        scope_identity_declaration (SUB (p));
 377      } else if (IS (p, VARIABLE_DECLARATION)) {
 378        scope_variable_declaration (SUB (p));
 379      } else if (IS (p, MODE_DECLARATION)) {
 380        scope_declarer (SUB (p));
 381      } else if (IS (p, PRIORITY_DECLARATION)) {
 382        ;
 383      } else if (IS (p, PROCEDURE_DECLARATION)) {
 384        scope_procedure_declaration (SUB (p));
 385      } else if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
 386        scope_procedure_declaration (SUB (p));
 387      } else if (is_one_of (p, BRIEF_OPERATOR_DECLARATION, OPERATOR_DECLARATION, STOP)) {
 388        scope_procedure_declaration (SUB (p));
 389      } else {
 390        scope_declaration_list (SUB (p));
 391        scope_declaration_list (NEXT (p));
 392      }
 393    }
 394  }
 395  
 396  //! @brief Scope_arguments.
 397  
 398  void scope_arguments (NODE_T * p)
 399  {
 400    for (; p != NO_NODE; FORWARD (p)) {
 401      if (IS (p, UNIT)) {
 402        SCOPE_T *s = NO_SCOPE;
 403        scope_statement (p, &s);
 404        (void) scope_check (s, TRANSIENT, LEX_LEVEL (p));
 405      } else {
 406        scope_arguments (SUB (p));
 407      }
 408    }
 409  }
 410  
 411  //! @brief Is_coercion.
 412  
 413  BOOL_T is_coercion (NODE_T * p)
 414  {
 415    if (p != NO_NODE) {
 416      switch (ATTRIBUTE (p)) {
 417      case DEPROCEDURING:
 418      case DEREFERENCING:
 419      case UNITING:
 420      case ROWING:
 421      case WIDENING:
 422      case VOIDING:
 423      case PROCEDURING:
 424        {
 425          return A68_TRUE;
 426        }
 427      default:
 428        {
 429          return A68_FALSE;
 430        }
 431      }
 432    } else {
 433      return A68_FALSE;
 434    }
 435  }
 436  
 437  //! @brief Scope_coercion.
 438  
 439  void scope_coercion (NODE_T * p, SCOPE_T ** s)
 440  {
 441    if (is_coercion (p)) {
 442      if (IS (p, VOIDING)) {
 443        scope_coercion (SUB (p), NO_VAR);
 444      } else if (IS (p, DEREFERENCING)) {
 445  // Leave this to the dynamic scope checker.
 446        scope_coercion (SUB (p), NO_VAR);
 447      } else if (IS (p, DEPROCEDURING)) {
 448        scope_coercion (SUB (p), NO_VAR);
 449      } else if (IS (p, ROWING)) {
 450        SCOPE_T *z = NO_SCOPE;
 451        scope_coercion (SUB (p), &z);
 452        (void) scope_check (z, TRANSIENT, LEX_LEVEL (p));
 453        if (IS_REF_FLEX (MOID (SUB (p)))) {
 454          scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT));
 455        } else {
 456          scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT));
 457        }
 458      } else if (IS (p, PROCEDURING)) {
 459  // Can only be a JUMP.
 460        NODE_T *q = SUB_SUB (p);
 461        if (IS (q, GOTO_SYMBOL)) {
 462          FORWARD (q);
 463        }
 464        scope_add (s, q, scope_make_tuple (TAG_LEX_LEVEL (TAX (q)), NOT_TRANSIENT));
 465      } else if (IS (p, UNITING)) {
 466        SCOPE_T *z = NO_SCOPE;
 467        scope_coercion (SUB (p), &z);
 468        if (z != NO_SCOPE) {
 469          (void) scope_check (z, TRANSIENT, LEX_LEVEL (p));
 470          scope_add (s, p, scope_find_youngest (z));
 471        }
 472      } else {
 473        scope_coercion (SUB (p), s);
 474      }
 475    } else {
 476      scope_statement (p, s);
 477    }
 478  }
 479  
 480  //! @brief Scope_format_text.
 481  
 482  void scope_format_text (NODE_T * p, SCOPE_T ** s)
 483  {
 484    for (; p != NO_NODE; FORWARD (p)) {
 485      if (IS (p, FORMAT_PATTERN)) {
 486        scope_enclosed_clause (SUB (NEXT_SUB (p)), s);
 487      } else if (IS (p, FORMAT_ITEM_G) && NEXT (p) != NO_NODE) {
 488        scope_enclosed_clause (SUB_NEXT (p), s);
 489      } else if (IS (p, DYNAMIC_REPLICATOR)) {
 490        scope_enclosed_clause (SUB (NEXT_SUB (p)), s);
 491      } else {
 492        scope_format_text (SUB (p), s);
 493      }
 494    }
 495  }
 496  
 497  //! @brief Scope_operand.
 498  
 499  void scope_operand (NODE_T * p, SCOPE_T ** s)
 500  {
 501    if (IS (p, MONADIC_FORMULA)) {
 502      scope_operand (NEXT_SUB (p), s);
 503    } else if (IS (p, FORMULA)) {
 504      scope_formula (p, s);
 505    } else if (IS (p, SECONDARY)) {
 506      scope_statement (SUB (p), s);
 507    }
 508  }
 509  
 510  //! @brief Scope_formula.
 511  
 512  void scope_formula (NODE_T * p, SCOPE_T ** s)
 513  {
 514    NODE_T *q = SUB (p);
 515    SCOPE_T *s2 = NO_SCOPE;
 516    scope_operand (q, &s2);
 517    (void) scope_check (s2, TRANSIENT, LEX_LEVEL (p));
 518    if (NEXT (q) != NO_NODE) {
 519      SCOPE_T *s3 = NO_SCOPE;
 520      scope_operand (NEXT_NEXT (q), &s3);
 521      (void) scope_check (s3, TRANSIENT, LEX_LEVEL (p));
 522    }
 523    (void) s;
 524  }
 525  
 526  //! @brief Scope_routine_text.
 527  
 528  void scope_routine_text (NODE_T * p, SCOPE_T ** s)
 529  {
 530    NODE_T *q = SUB (p), *routine = (IS (q, PARAMETER_PACK) ? NEXT (q) : q);
 531    SCOPE_T *x = NO_SCOPE;
 532    TUPLE_T routine_tuple;
 533    scope_statement (NEXT_NEXT (routine), &x);
 534    (void) scope_check (x, TRANSIENT, LEX_LEVEL (p));
 535    routine_tuple = scope_make_tuple (YOUNGEST_ENVIRON (TAX (p)), NOT_TRANSIENT);
 536    scope_add (s, p, routine_tuple);
 537  }
 538  
 539  //! @brief Scope_statement.
 540  
 541  void scope_statement (NODE_T * p, SCOPE_T ** s)
 542  {
 543    if (is_coercion (p)) {
 544      scope_coercion (p, s);
 545    } else if (is_one_of (p, PRIMARY, SECONDARY, TERTIARY, UNIT, STOP)) {
 546      scope_statement (SUB (p), s);
 547    } else if (is_one_of (p, NIHIL, STOP)) {
 548      scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT));
 549    } else if (IS (p, DENOTATION)) {
 550      ;
 551    } else if (IS (p, IDENTIFIER)) {
 552      if (IS_REF (MOID (p))) {
 553        if (PRIO (TAX (p)) == PARAMETER_IDENTIFIER) {
 554          scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)) - 1, NOT_TRANSIENT));
 555        } else {
 556          if (HEAP (TAX (p)) == HEAP_SYMBOL) {
 557            scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT));
 558          } else if (SCOPE_ASSIGNED (TAX (p))) {
 559            scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT));
 560          } else {
 561            scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT));
 562          }
 563        }
 564      } else if (ATTRIBUTE (MOID (p)) == PROC_SYMBOL && SCOPE_ASSIGNED (TAX (p)) == A68_TRUE) {
 565        scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT));
 566      } else if (MOID (p) == M_FORMAT && SCOPE_ASSIGNED (TAX (p)) == A68_TRUE) {
 567        scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT));
 568      }
 569    } else if (IS (p, ENCLOSED_CLAUSE)) {
 570      scope_enclosed_clause (SUB (p), s);
 571    } else if (IS (p, CALL)) {
 572      SCOPE_T *x = NO_SCOPE;
 573      scope_statement (SUB (p), &x);
 574      (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p));
 575      scope_arguments (NEXT_SUB (p));
 576    } else if (IS (p, SLICE)) {
 577      SCOPE_T *x = NO_SCOPE;
 578      MOID_T *m = MOID (SUB (p));
 579      if (IS_REF (m)) {
 580        if (ATTRIBUTE (SUB (p)) == PRIMARY && ATTRIBUTE (SUB_SUB (p)) == SLICE) {
 581          scope_statement (SUB (p), s);
 582        } else {
 583          scope_statement (SUB (p), &x);
 584          (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p));
 585        }
 586        if (IS_FLEX (SUB (m))) {
 587          scope_add (s, SUB (p), scope_make_tuple (LEX_LEVEL (p), TRANSIENT));
 588        }
 589        scope_bounds (SUB (NEXT_SUB (p)));
 590      }
 591      if (IS_REF (MOID (p))) {
 592        scope_add (s, p, scope_find_youngest (x));
 593      }
 594    } else if (IS (p, FORMAT_TEXT)) {
 595      SCOPE_T *x = NO_SCOPE;
 596      scope_format_text (SUB (p), &x);
 597      scope_add (s, p, scope_find_youngest (x));
 598    } else if (IS (p, CAST)) {
 599      SCOPE_T *x = NO_SCOPE;
 600      scope_enclosed_clause (SUB (NEXT_SUB (p)), &x);
 601      (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p));
 602      scope_add (s, p, scope_find_youngest (x));
 603    } else if (IS (p, SELECTION)) {
 604      SCOPE_T *ns = NO_SCOPE;
 605      scope_statement (NEXT_SUB (p), &ns);
 606      (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (p));
 607      if (is_ref_refety_flex (MOID (NEXT_SUB (p)))) {
 608        scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT));
 609      }
 610      scope_add (s, p, scope_find_youngest (ns));
 611    } else if (IS (p, GENERATOR)) {
 612      if (IS (SUB (p), LOC_SYMBOL)) {
 613        if (NON_LOCAL (p) != NO_TABLE) {
 614          scope_add (s, p, scope_make_tuple (LEVEL (NON_LOCAL (p)), NOT_TRANSIENT));
 615        } else {
 616          scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT));
 617        }
 618      } else {
 619        scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT));
 620      }
 621      scope_declarer (SUB (NEXT_SUB (p)));
 622    } else if (IS (p, DIAGONAL_FUNCTION)) {
 623      NODE_T *q = SUB (p);
 624      SCOPE_T *ns = NO_SCOPE;
 625      if (IS (q, TERTIARY)) {
 626        scope_statement (SUB (q), &ns);
 627        (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
 628        ns = NO_SCOPE;
 629        FORWARD (q);
 630      }
 631      scope_statement (SUB_NEXT (q), &ns);
 632      (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
 633      scope_add (s, p, scope_find_youngest (ns));
 634    } else if (IS (p, TRANSPOSE_FUNCTION)) {
 635      NODE_T *q = SUB (p);
 636      SCOPE_T *ns = NO_SCOPE;
 637      scope_statement (SUB_NEXT (q), &ns);
 638      (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
 639      scope_add (s, p, scope_find_youngest (ns));
 640    } else if (IS (p, ROW_FUNCTION)) {
 641      NODE_T *q = SUB (p);
 642      SCOPE_T *ns = NO_SCOPE;
 643      if (IS (q, TERTIARY)) {
 644        scope_statement (SUB (q), &ns);
 645        (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
 646        ns = NO_SCOPE;
 647        FORWARD (q);
 648      }
 649      scope_statement (SUB_NEXT (q), &ns);
 650      (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
 651      scope_add (s, p, scope_find_youngest (ns));
 652    } else if (IS (p, COLUMN_FUNCTION)) {
 653      NODE_T *q = SUB (p);
 654      SCOPE_T *ns = NO_SCOPE;
 655      if (IS (q, TERTIARY)) {
 656        scope_statement (SUB (q), &ns);
 657        (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
 658        ns = NO_SCOPE;
 659        FORWARD (q);
 660      }
 661      scope_statement (SUB_NEXT (q), &ns);
 662      (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
 663      scope_add (s, p, scope_find_youngest (ns));
 664    } else if (IS (p, FORMULA)) {
 665      scope_formula (p, s);
 666    } else if (IS (p, ASSIGNATION)) {
 667      NODE_T *unit = NEXT (NEXT_SUB (p));
 668      SCOPE_T *ns = NO_SCOPE, *nd = NO_SCOPE;
 669      TUPLE_T tup;
 670      scope_statement (SUB_SUB (p), &nd);
 671      scope_statement (unit, &ns);
 672      (void) scope_check_multiple (ns, TRANSIENT, nd);
 673      tup = scope_find_youngest (nd);
 674      scope_add (s, p, scope_make_tuple (LEVEL (&tup), NOT_TRANSIENT));
 675    } else if (IS (p, ROUTINE_TEXT)) {
 676      scope_routine_text (p, s);
 677    } else if (is_one_of (p, IDENTITY_RELATION, AND_FUNCTION, OR_FUNCTION, STOP)) {
 678      SCOPE_T *n = NO_SCOPE;
 679      scope_statement (SUB (p), &n);
 680      scope_statement (NEXT (NEXT_SUB (p)), &n);
 681      (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p));
 682    } else if (IS (p, ASSERTION)) {
 683      SCOPE_T *n = NO_SCOPE;
 684      scope_enclosed_clause (SUB (NEXT_SUB (p)), &n);
 685      (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p));
 686    } else if (is_one_of (p, JUMP, SKIP, STOP)) {
 687      ;
 688    }
 689  }
 690  
 691  //! @brief Scope_statement_list.
 692  
 693  void scope_statement_list (NODE_T * p, SCOPE_T ** s)
 694  {
 695    for (; p != NO_NODE; FORWARD (p)) {
 696      if (IS (p, UNIT)) {
 697        STATUS_SET (p, INTERRUPTIBLE_MASK);
 698        scope_statement (p, s);
 699      } else {
 700        scope_statement_list (SUB (p), s);
 701      }
 702    }
 703  }
 704  
 705  //! @brief Scope_serial_clause.
 706  
 707  void scope_serial_clause (NODE_T * p, SCOPE_T ** s, BOOL_T terminator)
 708  {
 709    if (p != NO_NODE) {
 710      if (IS (p, INITIALISER_SERIES)) {
 711        scope_serial_clause (SUB (p), s, A68_FALSE);
 712        scope_serial_clause (NEXT (p), s, terminator);
 713      } else if (IS (p, DECLARATION_LIST)) {
 714        scope_declaration_list (SUB (p));
 715      } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) {
 716        scope_serial_clause (NEXT (p), s, terminator);
 717      } else if (is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) {
 718        if (NEXT (p) != NO_NODE) {
 719          int j = ATTRIBUTE (NEXT (p));
 720          if (j == EXIT_SYMBOL || j == END_SYMBOL || j == CLOSE_SYMBOL) {
 721            scope_serial_clause (SUB (p), s, A68_TRUE);
 722          } else {
 723            scope_serial_clause (SUB (p), s, A68_FALSE);
 724          }
 725        } else {
 726          scope_serial_clause (SUB (p), s, A68_TRUE);
 727        }
 728        scope_serial_clause (NEXT (p), s, terminator);
 729      } else if (IS (p, LABELED_UNIT)) {
 730        scope_serial_clause (SUB (p), s, terminator);
 731      } else if (IS (p, UNIT)) {
 732        STATUS_SET (p, INTERRUPTIBLE_MASK);
 733        if (terminator) {
 734          scope_statement (p, s);
 735        } else {
 736          scope_statement (p, NO_VAR);
 737        }
 738      }
 739    }
 740  }
 741  
 742  //! @brief Scope_closed_clause.
 743  
 744  void scope_closed_clause (NODE_T * p, SCOPE_T ** s)
 745  {
 746    if (p != NO_NODE) {
 747      if (IS (p, SERIAL_CLAUSE)) {
 748        scope_serial_clause (p, s, A68_TRUE);
 749      } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) {
 750        scope_closed_clause (NEXT (p), s);
 751      }
 752    }
 753  }
 754  
 755  //! @brief Scope_collateral_clause.
 756  
 757  void scope_collateral_clause (NODE_T * p, SCOPE_T ** s)
 758  {
 759    if (p != NO_NODE) {
 760      if (!(whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))) {
 761        scope_statement_list (p, s);
 762      }
 763    }
 764  }
 765  
 766  //! @brief Scope_conditional_clause.
 767  
 768  void scope_conditional_clause (NODE_T * p, SCOPE_T ** s)
 769  {
 770    scope_serial_clause (NEXT_SUB (p), NO_VAR, A68_TRUE);
 771    FORWARD (p);
 772    scope_serial_clause (NEXT_SUB (p), s, A68_TRUE);
 773    if ((FORWARD (p)) != NO_NODE) {
 774      if (is_one_of (p, ELSE_PART, CHOICE, STOP)) {
 775        scope_serial_clause (NEXT_SUB (p), s, A68_TRUE);
 776      } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
 777        scope_conditional_clause (SUB (p), s);
 778      }
 779    }
 780  }
 781  
 782  //! @brief Scope_case_clause.
 783  
 784  void scope_case_clause (NODE_T * p, SCOPE_T ** s)
 785  {
 786    SCOPE_T *n = NO_SCOPE;
 787    scope_serial_clause (NEXT_SUB (p), &n, A68_TRUE);
 788    (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p));
 789    FORWARD (p);
 790    scope_statement_list (NEXT_SUB (p), s);
 791    if ((FORWARD (p)) != NO_NODE) {
 792      if (is_one_of (p, OUT_PART, CHOICE, STOP)) {
 793        scope_serial_clause (NEXT_SUB (p), s, A68_TRUE);
 794      } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) {
 795        scope_case_clause (SUB (p), s);
 796      } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) {
 797        scope_case_clause (SUB (p), s);
 798      }
 799    }
 800  }
 801  
 802  //! @brief Scope_loop_clause.
 803  
 804  void scope_loop_clause (NODE_T * p)
 805  {
 806    if (p != NO_NODE) {
 807      if (IS (p, FOR_PART)) {
 808        scope_loop_clause (NEXT (p));
 809      } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) {
 810        scope_statement (NEXT_SUB (p), NO_VAR);
 811        scope_loop_clause (NEXT (p));
 812      } else if (IS (p, WHILE_PART)) {
 813        scope_serial_clause (NEXT_SUB (p), NO_VAR, A68_TRUE);
 814        scope_loop_clause (NEXT (p));
 815      } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) {
 816        NODE_T *do_p = NEXT_SUB (p), *un_p;
 817        if (IS (do_p, SERIAL_CLAUSE)) {
 818          scope_serial_clause (do_p, NO_VAR, A68_TRUE);
 819          un_p = NEXT (do_p);
 820        } else {
 821          un_p = do_p;
 822        }
 823        if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) {
 824          scope_serial_clause (NEXT_SUB (un_p), NO_VAR, A68_TRUE);
 825        }
 826      }
 827    }
 828  }
 829  
 830  //! @brief Scope_enclosed_clause.
 831  
 832  void scope_enclosed_clause (NODE_T * p, SCOPE_T ** s)
 833  {
 834    if (IS (p, ENCLOSED_CLAUSE)) {
 835      scope_enclosed_clause (SUB (p), s);
 836    } else if (IS (p, CLOSED_CLAUSE)) {
 837      scope_closed_clause (SUB (p), s);
 838    } else if (is_one_of (p, COLLATERAL_CLAUSE, PARALLEL_CLAUSE, STOP)) {
 839      scope_collateral_clause (SUB (p), s);
 840    } else if (IS (p, CONDITIONAL_CLAUSE)) {
 841      scope_conditional_clause (SUB (p), s);
 842    } else if (is_one_of (p, CASE_CLAUSE, CONFORMITY_CLAUSE, STOP)) {
 843      scope_case_clause (SUB (p), s);
 844    } else if (IS (p, LOOP_CLAUSE)) {
 845      scope_loop_clause (SUB (p));
 846    }
 847  }
 848  
 849  //! @brief Whether a symbol table contains no (anonymous) definition.
 850  
 851  BOOL_T empty_table (TABLE_T * t)
 852  {
 853    if (IDENTIFIERS (t) == NO_TAG) {
 854      return (BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG);
 855    } else if (PRIO (IDENTIFIERS (t)) == LOOP_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) {
 856      return (BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG);
 857    } else if (PRIO (IDENTIFIERS (t)) == SPECIFIER_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) {
 858      return (BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG);
 859    } else {
 860      return A68_FALSE;
 861    }
 862  }
 863  
 864  //! @brief Indicate non-local environs.
 865  
 866  void get_non_local_environs (NODE_T * p, int max)
 867  {
 868    for (; p != NO_NODE; FORWARD (p)) {
 869      if (IS (p, ROUTINE_TEXT)) {
 870        get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p)));
 871      } else if (IS (p, FORMAT_TEXT)) {
 872        get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p)));
 873      } else {
 874        get_non_local_environs (SUB (p), max);
 875        NON_LOCAL (p) = NO_TABLE;
 876        if (TABLE (p) != NO_TABLE) {
 877          TABLE_T *q = TABLE (p);
 878          while (q != NO_TABLE && empty_table (q)
 879                 && PREVIOUS (q) != NO_TABLE && LEVEL (PREVIOUS (q)) >= max) {
 880            NON_LOCAL (p) = PREVIOUS (q);
 881            q = PREVIOUS (q);
 882          }
 883        }
 884      }
 885    }
 886  }
 887  
 888  //! @brief Scope_checker.
 889  
 890  void scope_checker (NODE_T * p)
 891  {
 892  // Establish scopes of routine texts and format texts.
 893    get_youngest_environs (p);
 894  // Find non-local environs.
 895    get_non_local_environs (p, PRIMAL_SCOPE);
 896  // PROC and FORMAT identities can now be assigned a scope.
 897    bind_scope_to_tags (p);
 898  // Now check evertyhing else.
 899    scope_enclosed_clause (SUB (p), NO_VAR);
 900  }