parser-moids-check.c

     
   1  //! @file parser-moids-check.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  //! Mode checker routines.
  25  
  26  // Algol 68 contexts are SOFT, WEAK, MEEK, FIRM and STRONG.
  27  // These contexts are increasing in strength:
  28  // 
  29  //   SOFT: Deproceduring
  30  // 
  31  //   WEAK: Dereferencing to REF [] or REF STRUCT
  32  // 
  33  //   MEEK: Deproceduring and dereferencing
  34  // 
  35  //   FIRM: MEEK followed by uniting
  36  // 
  37  //   STRONG: FIRM followed by rowing, widening or voiding
  38  // 
  39  // Furthermore you will see in this file next switches:
  40  // 
  41  // (1) FORCE_DEFLEXING allows assignment compatibility between FLEX and non FLEX
  42  // rows. This can only be the case when there is no danger of altering bounds of a
  43  // non FLEX row.
  44  // 
  45  // (2) ALIAS_DEFLEXING prohibits aliasing a FLEX row to a non FLEX row (vice versa
  46  // is no problem) so that one cannot alter the bounds of a non FLEX row by
  47  // aliasing it to a FLEX row. This is particularly the case when passing names as
  48  // parameters to procedures:
  49  // 
  50  //    PROC x = (REF STRING s) VOID: ..., PROC y = (REF [] CHAR c) VOID: ...;
  51  // 
  52  //    x (LOC STRING);    # OK #
  53  // 
  54  //    x (LOC [10] CHAR); # Not OK, suppose x changes bounds of s! #
  55  //  
  56  //    y (LOC STRING);    # OK #
  57  // 
  58  //    y (LOC [10] CHAR); # OK #
  59  // 
  60  // (3) SAFE_DEFLEXING sets FLEX row apart from non FLEX row. This holds for names,
  61  // not for values, so common things are not rejected, for instance
  62  // 
  63  //    STRING x = read string;
  64  // 
  65  //    [] CHAR y = read string
  66  // 
  67  // (4) NO_DEFLEXING sets FLEX row apart from non FLEX row.
  68  // 
  69  // Finally, a static scope checker inspects the source. Note that Algol 68 also 
  70  // needs dynamic scope checking. This phase concludes the parser.
  71  
  72  #include "a68g.h"
  73  #include "a68g-parser.h"
  74  #include "a68g-prelude.h"
  75  #include "a68g-moids.h"
  76  
  77  //! @brief Driver for mode checker.
  78  
  79  void mode_checker (NODE_T * p)
  80  {
  81    if (IS (p, PARTICULAR_PROGRAM)) {
  82      SOID_T x, y;
  83      A68 (top_soid_list) = NO_SOID;
  84      make_soid (&x, STRONG, M_VOID, 0);
  85      mode_check_enclosed (SUB (p), &x, &y);
  86      MOID (p) = MOID (&y);
  87    }
  88  }
  89  
  90  //! @brief Mode check on bounds.
  91  
  92  void mode_check_bounds (NODE_T * p)
  93  {
  94    if (p == NO_NODE) {
  95      return;
  96    } else if (IS (p, UNIT)) {
  97      SOID_T x, y;
  98      make_soid (&x, STRONG, M_INT, 0);
  99      mode_check_unit (p, &x, &y);
 100      if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
 101        cannot_coerce (p, MOID (&y), M_INT, MEEK, SAFE_DEFLEXING, UNIT);
 102      }
 103      mode_check_bounds (NEXT (p));
 104    } else {
 105      mode_check_bounds (SUB (p));
 106      mode_check_bounds (NEXT (p));
 107    }
 108  }
 109  
 110  //! @brief Mode check declarer.
 111  
 112  void mode_check_declarer (NODE_T * p)
 113  {
 114    if (p == NO_NODE) {
 115      return;
 116    } else if (IS (p, BOUNDS)) {
 117      mode_check_bounds (SUB (p));
 118      mode_check_declarer (NEXT (p));
 119    } else {
 120      mode_check_declarer (SUB (p));
 121      mode_check_declarer (NEXT (p));
 122    }
 123  }
 124  
 125  //! @brief Mode check identity declaration.
 126  
 127  void mode_check_identity_declaration (NODE_T * p)
 128  {
 129    if (p != NO_NODE) {
 130      switch (ATTRIBUTE (p)) {
 131      case DECLARER:
 132        {
 133          mode_check_declarer (SUB (p));
 134          mode_check_identity_declaration (NEXT (p));
 135          break;
 136        }
 137      case DEFINING_IDENTIFIER:
 138        {
 139          SOID_T x, y;
 140          make_soid (&x, STRONG, MOID (p), 0);
 141          mode_check_unit (NEXT_NEXT (p), &x, &y);
 142          if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
 143            cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT);
 144          } else if (MOID (&x) != MOID (&y)) {
 145  // Check for instance, REF INT i = LOC REF INT.
 146            semantic_pitfall (NEXT_NEXT (p), MOID (&x), IDENTITY_DECLARATION, GENERATOR);
 147          }
 148          break;
 149        }
 150      default:
 151        {
 152          mode_check_identity_declaration (SUB (p));
 153          mode_check_identity_declaration (NEXT (p));
 154          break;
 155        }
 156      }
 157    }
 158  }
 159  
 160  //! @brief Mode check variable declaration.
 161  
 162  void mode_check_variable_declaration (NODE_T * p)
 163  {
 164    if (p != NO_NODE) {
 165      switch (ATTRIBUTE (p)) {
 166      case DECLARER:
 167        {
 168          mode_check_declarer (SUB (p));
 169          mode_check_variable_declaration (NEXT (p));
 170          break;
 171        }
 172      case DEFINING_IDENTIFIER:
 173        {
 174          if (whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) {
 175            SOID_T x, y;
 176            make_soid (&x, STRONG, SUB_MOID (p), 0);
 177            mode_check_unit (NEXT_NEXT (p), &x, &y);
 178            if (!is_coercible_in_context (&y, &x, FORCE_DEFLEXING)) {
 179              cannot_coerce (p, MOID (&y), MOID (&x), STRONG, FORCE_DEFLEXING, UNIT);
 180            } else if (SUB_MOID (&x) != MOID (&y)) {
 181  // Check for instance, REF INT i = LOC REF INT.
 182              semantic_pitfall (NEXT_NEXT (p), MOID (&x), VARIABLE_DECLARATION, GENERATOR);
 183            }
 184          }
 185          break;
 186        }
 187      default:
 188        {
 189          mode_check_variable_declaration (SUB (p));
 190          mode_check_variable_declaration (NEXT (p));
 191          break;
 192        }
 193      }
 194    }
 195  }
 196  
 197  //! @brief Mode check routine text.
 198  
 199  void mode_check_routine_text (NODE_T * p, SOID_T * y)
 200  {
 201    SOID_T w;
 202    if (IS (p, PARAMETER_PACK)) {
 203      mode_check_declarer (SUB (p));
 204      FORWARD (p);
 205    }
 206    mode_check_declarer (SUB (p));
 207    make_soid (&w, STRONG, MOID (p), 0);
 208    mode_check_unit (NEXT_NEXT (p), &w, y);
 209    if (!is_coercible_in_context (y, &w, FORCE_DEFLEXING)) {
 210      cannot_coerce (NEXT_NEXT (p), MOID (y), MOID (&w), STRONG, FORCE_DEFLEXING, UNIT);
 211    }
 212  }
 213  
 214  //! @brief Mode check proc declaration.
 215  
 216  void mode_check_proc_declaration (NODE_T * p)
 217  {
 218    if (p == NO_NODE) {
 219      return;
 220    } else if (IS (p, ROUTINE_TEXT)) {
 221      SOID_T x, y;
 222      make_soid (&x, STRONG, NO_MOID, 0);
 223      mode_check_routine_text (SUB (p), &y);
 224    } else {
 225      mode_check_proc_declaration (SUB (p));
 226      mode_check_proc_declaration (NEXT (p));
 227    }
 228  }
 229  
 230  //! @brief Mode check brief op declaration.
 231  
 232  void mode_check_brief_op_declaration (NODE_T * p)
 233  {
 234    if (p == NO_NODE) {
 235      return;
 236    } else if (IS (p, DEFINING_OPERATOR)) {
 237      SOID_T y;
 238      if (MOID (p) != MOID (NEXT_NEXT (p))) {
 239        SOID_T y2, x;
 240        make_soid (&y2, NO_SORT, MOID (NEXT_NEXT (p)), 0);
 241        make_soid (&x, NO_SORT, MOID (p), 0);
 242        cannot_coerce (NEXT_NEXT (p), MOID (&y2), MOID (&x), STRONG, SKIP_DEFLEXING, ROUTINE_TEXT);
 243      }
 244      mode_check_routine_text (SUB (NEXT_NEXT (p)), &y);
 245    } else {
 246      mode_check_brief_op_declaration (SUB (p));
 247      mode_check_brief_op_declaration (NEXT (p));
 248    }
 249  }
 250  
 251  //! @brief Mode check op declaration.
 252  
 253  void mode_check_op_declaration (NODE_T * p)
 254  {
 255    if (p == NO_NODE) {
 256      return;
 257    } else if (IS (p, DEFINING_OPERATOR)) {
 258      SOID_T y, x;
 259      make_soid (&x, STRONG, MOID (p), 0);
 260      mode_check_unit (NEXT_NEXT (p), &x, &y);
 261      if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
 262        cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT);
 263      }
 264    } else {
 265      mode_check_op_declaration (SUB (p));
 266      mode_check_op_declaration (NEXT (p));
 267    }
 268  }
 269  
 270  //! @brief Mode check declaration list.
 271  
 272  void mode_check_declaration_list (NODE_T * p)
 273  {
 274    if (p != NO_NODE) {
 275      switch (ATTRIBUTE (p)) {
 276      case IDENTITY_DECLARATION:
 277        {
 278          mode_check_identity_declaration (SUB (p));
 279          break;
 280        }
 281      case VARIABLE_DECLARATION:
 282        {
 283          mode_check_variable_declaration (SUB (p));
 284          break;
 285        }
 286      case MODE_DECLARATION:
 287        {
 288          mode_check_declarer (SUB (p));
 289          break;
 290        }
 291      case PROCEDURE_DECLARATION:
 292      case PROCEDURE_VARIABLE_DECLARATION:
 293        {
 294          mode_check_proc_declaration (SUB (p));
 295          break;
 296        }
 297      case BRIEF_OPERATOR_DECLARATION:
 298        {
 299          mode_check_brief_op_declaration (SUB (p));
 300          break;
 301        }
 302      case OPERATOR_DECLARATION:
 303        {
 304          mode_check_op_declaration (SUB (p));
 305          break;
 306        }
 307      default:
 308        {
 309          mode_check_declaration_list (SUB (p));
 310          mode_check_declaration_list (NEXT (p));
 311          break;
 312        }
 313      }
 314    }
 315  }
 316  
 317  //! @brief Mode check serial clause.
 318  
 319  void mode_check_serial (SOID_T ** r, NODE_T * p, SOID_T * x, BOOL_T k)
 320  {
 321    if (p == NO_NODE) {
 322      return;
 323    } else if (IS (p, INITIALISER_SERIES)) {
 324      mode_check_serial (r, SUB (p), x, A68_FALSE);
 325      mode_check_serial (r, NEXT (p), x, k);
 326    } else if (IS (p, DECLARATION_LIST)) {
 327      mode_check_declaration_list (SUB (p));
 328    } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) {
 329      mode_check_serial (r, NEXT (p), x, k);
 330    } else if (is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) {
 331      if (NEXT (p) != NO_NODE) {
 332        if (IS (NEXT (p), EXIT_SYMBOL) || IS (NEXT (p), END_SYMBOL) || IS (NEXT (p), CLOSE_SYMBOL)) {
 333          mode_check_serial (r, SUB (p), x, A68_TRUE);
 334        } else {
 335          mode_check_serial (r, SUB (p), x, A68_FALSE);
 336        }
 337        mode_check_serial (r, NEXT (p), x, k);
 338      } else {
 339        mode_check_serial (r, SUB (p), x, A68_TRUE);
 340      }
 341    } else if (IS (p, LABELED_UNIT)) {
 342      mode_check_serial (r, SUB (p), x, k);
 343    } else if (IS (p, UNIT)) {
 344      SOID_T y;
 345      if (k) {
 346        mode_check_unit (p, x, &y);
 347      } else {
 348        SOID_T w;
 349        make_soid (&w, STRONG, M_VOID, 0);
 350        mode_check_unit (p, &w, &y);
 351      }
 352      if (NEXT (p) != NO_NODE) {
 353        mode_check_serial (r, NEXT (p), x, k);
 354      } else {
 355        if (k) {
 356          add_to_soid_list (r, p, &y);
 357        }
 358      }
 359    }
 360  }
 361  
 362  //! @brief Mode check serial clause units.
 363  
 364  void mode_check_serial_units (NODE_T * p, SOID_T * x, SOID_T * y, int att)
 365  {
 366    SOID_T *top_sl = NO_SOID;
 367    (void) att;
 368    mode_check_serial (&top_sl, SUB (p), x, A68_TRUE);
 369    if (is_balanced (p, top_sl, SORT (x))) {
 370      MOID_T *result = pack_soids_in_moid (top_sl, SERIES_MODE);
 371      make_soid (y, SORT (x), result, SERIAL_CLAUSE);
 372    } else {
 373      make_soid (y, SORT (x), (MOID (x) != NO_MOID ? MOID (x) : M_ERROR), 0);
 374    }
 375    free_soid_list (top_sl);
 376  }
 377  
 378  //! @brief Mode check unit list.
 379  
 380  void mode_check_unit_list (SOID_T ** r, NODE_T * p, SOID_T * x)
 381  {
 382    if (p == NO_NODE) {
 383      return;
 384    } else if (IS (p, UNIT_LIST)) {
 385      mode_check_unit_list (r, SUB (p), x);
 386      mode_check_unit_list (r, NEXT (p), x);
 387    } else if (IS (p, COMMA_SYMBOL)) {
 388      mode_check_unit_list (r, NEXT (p), x);
 389    } else if (IS (p, UNIT)) {
 390      SOID_T y;
 391      mode_check_unit (p, x, &y);
 392      add_to_soid_list (r, p, &y);
 393      mode_check_unit_list (r, NEXT (p), x);
 394    }
 395  }
 396  
 397  //! @brief Mode check struct display.
 398  
 399  void mode_check_struct_display (SOID_T ** r, NODE_T * p, PACK_T ** fields)
 400  {
 401    if (p == NO_NODE) {
 402      return;
 403    } else if (IS (p, UNIT_LIST)) {
 404      mode_check_struct_display (r, SUB (p), fields);
 405      mode_check_struct_display (r, NEXT (p), fields);
 406    } else if (IS (p, COMMA_SYMBOL)) {
 407      mode_check_struct_display (r, NEXT (p), fields);
 408    } else if (IS (p, UNIT)) {
 409      SOID_T x, y;
 410      if (*fields != NO_PACK) {
 411        make_soid (&x, STRONG, MOID (*fields), 0);
 412        FORWARD (*fields);
 413      } else {
 414        make_soid (&x, STRONG, NO_MOID, 0);
 415      }
 416      mode_check_unit (p, &x, &y);
 417      add_to_soid_list (r, p, &y);
 418      mode_check_struct_display (r, NEXT (p), fields);
 419    }
 420  }
 421  
 422  //! @brief Mode check get specified moids.
 423  
 424  void mode_check_get_specified_moids (NODE_T * p, MOID_T * u)
 425  {
 426    for (; p != NO_NODE; FORWARD (p)) {
 427      if (is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) {
 428        mode_check_get_specified_moids (SUB (p), u);
 429      } else if (IS (p, SPECIFIER)) {
 430        MOID_T *m = MOID (NEXT_SUB (p));
 431        add_mode_to_pack (&(PACK (u)), m, NO_TEXT, NODE (m));
 432      }
 433    }
 434  }
 435  
 436  //! @brief Mode check specified unit list.
 437  
 438  void mode_check_specified_unit_list (SOID_T ** r, NODE_T * p, SOID_T * x, MOID_T * u)
 439  {
 440    for (; p != NO_NODE; FORWARD (p)) {
 441      if (is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) {
 442        mode_check_specified_unit_list (r, SUB (p), x, u);
 443      } else if (IS (p, SPECIFIER)) {
 444        MOID_T *m = MOID (NEXT_SUB (p));
 445        if (u != NO_MOID && !is_unitable (m, u, SAFE_DEFLEXING)) {
 446          diagnostic (A68_ERROR, p, ERROR_NO_COMPONENT, m, u);
 447        }
 448      } else if (IS (p, UNIT)) {
 449        SOID_T y;
 450        mode_check_unit (p, x, &y);
 451        add_to_soid_list (r, p, &y);
 452      }
 453    }
 454  }
 455  
 456  //! @brief Mode check united case parts.
 457  
 458  void mode_check_united_case_parts (SOID_T ** ry, NODE_T * p, SOID_T * x)
 459  {
 460    SOID_T enq_expct, enq_yield;
 461    MOID_T *u = NO_MOID, *v = NO_MOID, *w = NO_MOID;
 462  // Check the CASE part and deduce the united mode.
 463    make_soid (&enq_expct, MEEK, NO_MOID, 0);
 464    mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
 465  // Deduce the united mode from the enquiry clause.
 466    u = depref_completely (MOID (&enq_yield));
 467    u = make_united_mode (u);
 468    u = depref_completely (u);
 469  // Also deduce the united mode from the specifiers.
 470    v = new_moid ();
 471    ATTRIBUTE (v) = SERIES_MODE;
 472    mode_check_get_specified_moids (NEXT_SUB (NEXT (p)), v);
 473    v = make_united_mode (v);
 474  // Determine a resulting union.
 475    if (u == M_HIP) {
 476      w = v;
 477    } else {
 478      if (IS (u, UNION_SYMBOL)) {
 479        BOOL_T uv, vu, some;
 480        investigate_firm_relations (PACK (u), PACK (v), &uv, &some);
 481        investigate_firm_relations (PACK (v), PACK (u), &vu, &some);
 482        if (uv && vu) {
 483  // Every component has a specifier.
 484          w = u;
 485        } else if (!uv && !vu) {
 486  // Hmmmm ... let the coercer sort it out.
 487          w = u;
 488        } else {
 489  // This is all the balancing we allow here for the moment. Firmly related
 490  // subsets are not valid so we absorb them. If this doesn't solve it then we
 491  // get a coercion-error later.
 492          w = absorb_related_subsets (u);
 493        }
 494      } else {
 495        diagnostic (A68_ERROR, NEXT_SUB (p), ERROR_NO_UNION, u);
 496        return;
 497      }
 498    }
 499    MOID (SUB (p)) = w;
 500    FORWARD (p);
 501  // Check the IN part.
 502    mode_check_specified_unit_list (ry, NEXT_SUB (p), x, w);
 503  // OUSE, OUT, ESAC.
 504    if ((FORWARD (p)) != NO_NODE) {
 505      if (is_one_of (p, OUT_PART, CHOICE, STOP)) {
 506        mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE);
 507      } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) {
 508        mode_check_united_case_parts (ry, SUB (p), x);
 509      }
 510    }
 511  }
 512  
 513  //! @brief Mode check united case.
 514  
 515  void mode_check_united_case (NODE_T * p, SOID_T * x, SOID_T * y)
 516  {
 517    SOID_T *top_sl = NO_SOID;
 518    MOID_T *z;
 519    mode_check_united_case_parts (&top_sl, p, x);
 520    if (!is_balanced (p, top_sl, SORT (x))) {
 521      if (MOID (x) != NO_MOID) {
 522        make_soid (y, SORT (x), MOID (x), CONFORMITY_CLAUSE);
 523  
 524      } else {
 525        make_soid (y, SORT (x), M_ERROR, 0);
 526      }
 527    } else {
 528      z = pack_soids_in_moid (top_sl, SERIES_MODE);
 529      make_soid (y, SORT (x), z, CONFORMITY_CLAUSE);
 530    }
 531    free_soid_list (top_sl);
 532  }
 533  
 534  //! @brief Mode check unit list 2.
 535  
 536  void mode_check_unit_list_2 (NODE_T * p, SOID_T * x, SOID_T * y)
 537  {
 538    SOID_T *top_sl = NO_SOID;
 539    if (MOID (x) != NO_MOID) {
 540      if (IS_FLEX (MOID (x))) {
 541        SOID_T y2;
 542        make_soid (&y2, SORT (x), SLICE (SUB_MOID (x)), 0);
 543        mode_check_unit_list (&top_sl, SUB (p), &y2);
 544      } else if (IS_ROW (MOID (x))) {
 545        SOID_T y2;
 546        make_soid (&y2, SORT (x), SLICE (MOID (x)), 0);
 547        mode_check_unit_list (&top_sl, SUB (p), &y2);
 548      } else if (IS (MOID (x), STRUCT_SYMBOL)) {
 549        PACK_T *y2 = PACK (MOID (x));
 550        mode_check_struct_display (&top_sl, SUB (p), &y2);
 551      } else {
 552        mode_check_unit_list (&top_sl, SUB (p), x);
 553      }
 554    } else {
 555      mode_check_unit_list (&top_sl, SUB (p), x);
 556    }
 557    make_soid (y, STRONG, pack_soids_in_moid (top_sl, STOWED_MODE), 0);
 558    free_soid_list (top_sl);
 559  }
 560  
 561  //! @brief Mode check closed.
 562  
 563  void mode_check_closed (NODE_T * p, SOID_T * x, SOID_T * y)
 564  {
 565    if (p == NO_NODE) {
 566      return;
 567    } else if (IS (p, SERIAL_CLAUSE)) {
 568      mode_check_serial_units (p, x, y, SERIAL_CLAUSE);
 569    } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) {
 570      mode_check_closed (NEXT (p), x, y);
 571    }
 572    MOID (p) = MOID (y);
 573  }
 574  
 575  //! @brief Mode check collateral.
 576  
 577  void mode_check_collateral (NODE_T * p, SOID_T * x, SOID_T * y)
 578  {
 579    if (p == NO_NODE) {
 580      return;
 581    } else if (whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP)) {
 582      if (SORT (x) == STRONG) {
 583        if (MOID (x) == NO_MOID) {
 584          diagnostic (A68_ERROR, p, ERROR_VACUUM, "REF MODE");
 585        } else {
 586          make_soid (y, STRONG, M_VACUUM, 0);
 587        }
 588      } else {
 589        make_soid (y, STRONG, M_UNDEFINED, 0);
 590      }
 591    } else {
 592      if (IS (p, UNIT_LIST)) {
 593        mode_check_unit_list_2 (p, x, y);
 594      } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) {
 595        mode_check_collateral (NEXT (p), x, y);
 596      }
 597      MOID (p) = MOID (y);
 598    }
 599  }
 600  
 601  //! @brief Mode check conditional 2.
 602  
 603  void mode_check_conditional_2 (SOID_T ** ry, NODE_T * p, SOID_T * x)
 604  {
 605    SOID_T enq_expct, enq_yield;
 606    make_soid (&enq_expct, MEEK, M_BOOL, 0);
 607    mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
 608    if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) {
 609      cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
 610    }
 611    FORWARD (p);
 612    mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE);
 613    if ((FORWARD (p)) != NO_NODE) {
 614      if (is_one_of (p, ELSE_PART, CHOICE, STOP)) {
 615        mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE);
 616      } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
 617        mode_check_conditional_2 (ry, SUB (p), x);
 618      }
 619    }
 620  }
 621  
 622  //! @brief Mode check conditional.
 623  
 624  void mode_check_conditional (NODE_T * p, SOID_T * x, SOID_T * y)
 625  {
 626    SOID_T *top_sl = NO_SOID;
 627    MOID_T *z;
 628    mode_check_conditional_2 (&top_sl, p, x);
 629    if (!is_balanced (p, top_sl, SORT (x))) {
 630      if (MOID (x) != NO_MOID) {
 631        make_soid (y, SORT (x), MOID (x), CONDITIONAL_CLAUSE);
 632      } else {
 633        make_soid (y, SORT (x), M_ERROR, 0);
 634      }
 635    } else {
 636      z = pack_soids_in_moid (top_sl, SERIES_MODE);
 637      make_soid (y, SORT (x), z, CONDITIONAL_CLAUSE);
 638    }
 639    free_soid_list (top_sl);
 640  }
 641  
 642  //! @brief Mode check int case 2.
 643  
 644  void mode_check_int_case_2 (SOID_T ** ry, NODE_T * p, SOID_T * x)
 645  {
 646    SOID_T enq_expct, enq_yield;
 647    make_soid (&enq_expct, MEEK, M_INT, 0);
 648    mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
 649    if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) {
 650      cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
 651    }
 652    FORWARD (p);
 653    mode_check_unit_list (ry, NEXT_SUB (p), x);
 654    if ((FORWARD (p)) != NO_NODE) {
 655      if (is_one_of (p, OUT_PART, CHOICE, STOP)) {
 656        mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE);
 657      } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) {
 658        mode_check_int_case_2 (ry, SUB (p), x);
 659      }
 660    }
 661  }
 662  
 663  //! @brief Mode check int case.
 664  
 665  void mode_check_int_case (NODE_T * p, SOID_T * x, SOID_T * y)
 666  {
 667    SOID_T *top_sl = NO_SOID;
 668    MOID_T *z;
 669    mode_check_int_case_2 (&top_sl, p, x);
 670    if (!is_balanced (p, top_sl, SORT (x))) {
 671      if (MOID (x) != NO_MOID) {
 672        make_soid (y, SORT (x), MOID (x), CASE_CLAUSE);
 673      } else {
 674        make_soid (y, SORT (x), M_ERROR, 0);
 675      }
 676    } else {
 677      z = pack_soids_in_moid (top_sl, SERIES_MODE);
 678      make_soid (y, SORT (x), z, CASE_CLAUSE);
 679    }
 680    free_soid_list (top_sl);
 681  }
 682  
 683  //! @brief Mode check loop 2.
 684  
 685  void mode_check_loop_2 (NODE_T * p, SOID_T * y)
 686  {
 687    if (p == NO_NODE) {
 688      return;
 689    } else if (IS (p, FOR_PART)) {
 690      mode_check_loop_2 (NEXT (p), y);
 691    } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) {
 692      SOID_T ix, iy;
 693      make_soid (&ix, STRONG, M_INT, 0);
 694      mode_check_unit (NEXT_SUB (p), &ix, &iy);
 695      if (!is_coercible_in_context (&iy, &ix, SAFE_DEFLEXING)) {
 696        cannot_coerce (NEXT_SUB (p), MOID (&iy), M_INT, MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
 697      }
 698      mode_check_loop_2 (NEXT (p), y);
 699    } else if (IS (p, WHILE_PART)) {
 700      SOID_T enq_expct, enq_yield;
 701      make_soid (&enq_expct, MEEK, M_BOOL, 0);
 702      mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
 703      if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) {
 704        cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
 705      }
 706      mode_check_loop_2 (NEXT (p), y);
 707    } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) {
 708      SOID_T *z = NO_SOID;
 709      SOID_T ix;
 710      NODE_T *do_p = NEXT_SUB (p), *un_p;
 711      make_soid (&ix, STRONG, M_VOID, 0);
 712      if (IS (do_p, SERIAL_CLAUSE)) {
 713        mode_check_serial (&z, do_p, &ix, A68_TRUE);
 714        un_p = NEXT (do_p);
 715      } else {
 716        un_p = do_p;
 717      }
 718      if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) {
 719        SOID_T enq_expct, enq_yield;
 720        make_soid (&enq_expct, STRONG, M_BOOL, 0);
 721        mode_check_serial_units (NEXT_SUB (un_p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
 722        if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) {
 723          cannot_coerce (un_p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
 724        }
 725      }
 726      free_soid_list (z);
 727    }
 728  }
 729  
 730  //! @brief Mode check loop.
 731  
 732  void mode_check_loop (NODE_T * p, SOID_T * y)
 733  {
 734    SOID_T *z = NO_SOID;
 735    mode_check_loop_2 (p, z);
 736    make_soid (y, STRONG, M_VOID, 0);
 737  }
 738  
 739  //! @brief Mode check enclosed.
 740  
 741  void mode_check_enclosed (NODE_T * p, SOID_T * x, SOID_T * y)
 742  {
 743    if (p == NO_NODE) {
 744      return;
 745    } else if (IS (p, ENCLOSED_CLAUSE)) {
 746      mode_check_enclosed (SUB (p), x, y);
 747    } else if (IS (p, CLOSED_CLAUSE)) {
 748      mode_check_closed (SUB (p), x, y);
 749    } else if (IS (p, PARALLEL_CLAUSE)) {
 750      mode_check_collateral (SUB (NEXT_SUB (p)), x, y);
 751      make_soid (y, STRONG, M_VOID, 0);
 752      MOID (NEXT_SUB (p)) = M_VOID;
 753    } else if (IS (p, COLLATERAL_CLAUSE)) {
 754      mode_check_collateral (SUB (p), x, y);
 755    } else if (IS (p, CONDITIONAL_CLAUSE)) {
 756      mode_check_conditional (SUB (p), x, y);
 757    } else if (IS (p, CASE_CLAUSE)) {
 758      mode_check_int_case (SUB (p), x, y);
 759    } else if (IS (p, CONFORMITY_CLAUSE)) {
 760      mode_check_united_case (SUB (p), x, y);
 761    } else if (IS (p, LOOP_CLAUSE)) {
 762      mode_check_loop (SUB (p), y);
 763    }
 764    MOID (p) = MOID (y);
 765  }
 766  
 767  //! @brief Search table for operator.
 768  
 769  TAG_T *search_table_for_operator (TAG_T * t, char *n, MOID_T * x, MOID_T * y)
 770  {
 771    if (is_mode_isnt_well (x)) {
 772      return A68_PARSER (error_tag);
 773    } else if (y != NO_MOID && is_mode_isnt_well (y)) {
 774      return A68_PARSER (error_tag);
 775    }
 776    for (; t != NO_TAG; FORWARD (t)) {
 777      if (NSYMBOL (NODE (t)) == n) {
 778        PACK_T *p = PACK (MOID (t));
 779        if (is_coercible (x, MOID (p), FIRM, ALIAS_DEFLEXING)) {
 780          FORWARD (p);
 781          if (p == NO_PACK && y == NO_MOID) {
 782  // Matched in case of a monadic.
 783            return t;
 784          } else if (p != NO_PACK && y != NO_MOID && is_coercible (y, MOID (p), FIRM, ALIAS_DEFLEXING)) {
 785  // Matched in case of a dyadic.
 786            return t;
 787          }
 788        }
 789      }
 790    }
 791    return NO_TAG;
 792  }
 793  
 794  //! @brief Search chain of symbol tables and return matching operator "x n y" or "n x".
 795  
 796  TAG_T *search_table_chain_for_operator (TABLE_T * s, char *n, MOID_T * x, MOID_T * y)
 797  {
 798    if (is_mode_isnt_well (x)) {
 799      return A68_PARSER (error_tag);
 800    } else if (y != NO_MOID && is_mode_isnt_well (y)) {
 801      return A68_PARSER (error_tag);
 802    }
 803    while (s != NO_TABLE) {
 804      TAG_T *z = search_table_for_operator (OPERATORS (s), n, x, y);
 805      if (z != NO_TAG) {
 806        return z;
 807      }
 808      BACKWARD (s);
 809    }
 810    return NO_TAG;
 811  }
 812  
 813  //! @brief Return a matching operator "x n y".
 814  
 815  TAG_T *find_operator (TABLE_T * s, char *n, MOID_T * x, MOID_T * y)
 816  {
 817  // Coercions to operand modes are FIRM.
 818    TAG_T *z;
 819    MOID_T *u, *v;
 820  // (A) Catch exceptions first.
 821    if (x == NO_MOID && y == NO_MOID) {
 822      return NO_TAG;
 823    } else if (is_mode_isnt_well (x)) {
 824      return A68_PARSER (error_tag);
 825    } else if (y != NO_MOID && is_mode_isnt_well (y)) {
 826      return A68_PARSER (error_tag);
 827    }
 828  // (B) MONADs.
 829    if (x != NO_MOID && y == NO_MOID) {
 830      z = search_table_chain_for_operator (s, n, x, NO_MOID);
 831      if (z != NO_TAG) {
 832        return z;
 833      } else {
 834  // (B.2) A little trick to allow - (0, 1) or ABS (1, long pi).
 835        if (is_coercible (x, M_COMPLEX, STRONG, SAFE_DEFLEXING)) {
 836          z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, NO_MOID);
 837          if (z != NO_TAG) {
 838            return z;
 839          }
 840        }
 841        if (is_coercible (x, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) {
 842          z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, NO_MOID);
 843          if (z != NO_TAG) {
 844            return z;
 845          }
 846        }
 847        if (is_coercible (x, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) {
 848          z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, NO_MOID);
 849        }
 850      }
 851      return NO_TAG;
 852    }
 853  // (C) DYADs.
 854    z = search_table_chain_for_operator (s, n, x, y);
 855    if (z != NO_TAG) {
 856      return z;
 857    }
 858  // (C.2) Vector and matrix "strong coercions" in standard environ.
 859    u = depref_completely (x);
 860    v = depref_completely (y);
 861    if ((u == M_ROW_REAL || u == M_ROW_ROW_REAL)
 862        || (v == M_ROW_REAL || v == M_ROW_ROW_REAL)
 863        || (u == M_ROW_COMPLEX || u == M_ROW_ROW_COMPLEX)
 864        || (v == M_ROW_COMPLEX || v == M_ROW_ROW_COMPLEX)) {
 865      if (u == M_INT) {
 866        z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, y);
 867        if (z != NO_TAG) {
 868          return z;
 869        }
 870        z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y);
 871        if (z != NO_TAG) {
 872          return z;
 873        }
 874      } else if (v == M_INT) {
 875        z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_REAL);
 876        if (z != NO_TAG) {
 877          return z;
 878        }
 879        z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX);
 880        if (z != NO_TAG) {
 881          return z;
 882        }
 883      } else if (u == M_REAL) {
 884        z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y);
 885        if (z != NO_TAG) {
 886          return z;
 887        }
 888      } else if (v == M_REAL) {
 889        z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX);
 890        if (z != NO_TAG) {
 891          return z;
 892        }
 893      }
 894    }
 895  // (C.3) Look in standenv for an appropriate cross-term.
 896    u = make_series_from_moids (x, y);
 897    u = make_united_mode (u);
 898    v = get_balanced_mode (u, STRONG, NO_DEPREF, SAFE_DEFLEXING);
 899    z = search_table_for_operator (OPERATORS (A68_STANDENV), n, v, v);
 900    if (z != NO_TAG) {
 901      return z;
 902    }
 903    if (is_coercible_series (u, M_REAL, STRONG, SAFE_DEFLEXING)) {
 904      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, M_REAL);
 905      if (z != NO_TAG) {
 906        return z;
 907      }
 908    }
 909    if (is_coercible_series (u, M_LONG_REAL, STRONG, SAFE_DEFLEXING)) {
 910      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_REAL, M_LONG_REAL);
 911      if (z != NO_TAG) {
 912        return z;
 913      }
 914    }
 915    if (is_coercible_series (u, M_LONG_LONG_REAL, STRONG, SAFE_DEFLEXING)) {
 916      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_REAL, M_LONG_LONG_REAL);
 917      if (z != NO_TAG) {
 918        return z;
 919      }
 920    }
 921    if (is_coercible_series (u, M_COMPLEX, STRONG, SAFE_DEFLEXING)) {
 922      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, M_COMPLEX);
 923      if (z != NO_TAG) {
 924        return z;
 925      }
 926    }
 927    if (is_coercible_series (u, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) {
 928      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, M_LONG_COMPLEX);
 929      if (z != NO_TAG) {
 930        return z;
 931      }
 932    }
 933    if (is_coercible_series (u, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) {
 934      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX);
 935      if (z != NO_TAG) {
 936        return z;
 937      }
 938    }
 939  // (C.4) Now allow for depreffing for REF REAL +:= INT and alike.
 940    v = get_balanced_mode (u, STRONG, DEPREF, SAFE_DEFLEXING);
 941    z = search_table_for_operator (OPERATORS (A68_STANDENV), n, v, v);
 942    if (z != NO_TAG) {
 943      return z;
 944    }
 945    return NO_TAG;
 946  }
 947  
 948  //! @brief Mode check monadic operator.
 949  
 950  void mode_check_monadic_operator (NODE_T * p, SOID_T * x, SOID_T * y)
 951  {
 952    if (p != NO_NODE) {
 953      TAG_T *t;
 954      MOID_T *u;
 955      u = determine_unique_mode (y, SAFE_DEFLEXING);
 956      if (is_mode_isnt_well (u)) {
 957        make_soid (y, SORT (x), M_ERROR, 0);
 958      } else if (u == M_HIP) {
 959        diagnostic (A68_ERROR, NEXT (p), ERROR_INVALID_OPERAND, u);
 960        make_soid (y, SORT (x), M_ERROR, 0);
 961      } else {
 962        if (strchr (NOMADS, *(NSYMBOL (p))) != NO_TEXT) {
 963          t = NO_TAG;
 964          diagnostic (A68_SYNTAX_ERROR, p, ERROR_OPERATOR_INVALID, NOMADS);
 965          make_soid (y, SORT (x), M_ERROR, 0);
 966        } else {
 967          t = find_operator (TABLE (p), NSYMBOL (p), u, NO_MOID);
 968          if (t == NO_TAG) {
 969            diagnostic (A68_ERROR, p, ERROR_NO_MONADIC, u);
 970            make_soid (y, SORT (x), M_ERROR, 0);
 971          }
 972        }
 973        if (t != NO_TAG) {
 974          MOID (p) = MOID (t);
 975        }
 976        TAX (p) = t;
 977        if (t != NO_TAG && t != A68_PARSER (error_tag)) {
 978          MOID (p) = MOID (t);
 979          make_soid (y, SORT (x), SUB_MOID (t), 0);
 980        } else {
 981          MOID (p) = M_ERROR;
 982          make_soid (y, SORT (x), M_ERROR, 0);
 983        }
 984      }
 985    }
 986  }
 987  
 988  //! @brief Mode check monadic formula.
 989  
 990  void mode_check_monadic_formula (NODE_T * p, SOID_T * x, SOID_T * y)
 991  {
 992    SOID_T e;
 993    make_soid (&e, FIRM, NO_MOID, 0);
 994    mode_check_formula (NEXT (p), &e, y);
 995    mode_check_monadic_operator (p, &e, y);
 996    make_soid (y, SORT (x), MOID (y), 0);
 997  }
 998  
 999  //! @brief Mode check formula.
1000  
1001  void mode_check_formula (NODE_T * p, SOID_T * x, SOID_T * y)
1002  {
1003    SOID_T ls, rs;
1004    TAG_T *op;
1005    MOID_T *u, *v;
1006    if (IS (p, MONADIC_FORMULA)) {
1007      mode_check_monadic_formula (SUB (p), x, &ls);
1008    } else if (IS (p, FORMULA)) {
1009      mode_check_formula (SUB (p), x, &ls);
1010    } else if (IS (p, SECONDARY)) {
1011      SOID_T e;
1012      make_soid (&e, FIRM, NO_MOID, 0);
1013      mode_check_unit (SUB (p), &e, &ls);
1014    }
1015    u = determine_unique_mode (&ls, SAFE_DEFLEXING);
1016    MOID (p) = u;
1017    if (NEXT (p) == NO_NODE) {
1018      make_soid (y, SORT (x), u, 0);
1019    } else {
1020      NODE_T *q = NEXT_NEXT (p);
1021      if (IS (q, MONADIC_FORMULA)) {
1022        mode_check_monadic_formula (SUB (NEXT_NEXT (p)), x, &rs);
1023      } else if (IS (q, FORMULA)) {
1024        mode_check_formula (SUB (NEXT_NEXT (p)), x, &rs);
1025      } else if (IS (q, SECONDARY)) {
1026        SOID_T e;
1027        make_soid (&e, FIRM, NO_MOID, 0);
1028        mode_check_unit (SUB (q), &e, &rs);
1029      }
1030      v = determine_unique_mode (&rs, SAFE_DEFLEXING);
1031      MOID (q) = v;
1032      if (is_mode_isnt_well (u) || is_mode_isnt_well (v)) {
1033        make_soid (y, SORT (x), M_ERROR, 0);
1034      } else if (u == M_HIP) {
1035        diagnostic (A68_ERROR, p, ERROR_INVALID_OPERAND, u);
1036        make_soid (y, SORT (x), M_ERROR, 0);
1037      } else if (v == M_HIP) {
1038        diagnostic (A68_ERROR, q, ERROR_INVALID_OPERAND, u);
1039        make_soid (y, SORT (x), M_ERROR, 0);
1040      } else {
1041        op = find_operator (TABLE (NEXT (p)), NSYMBOL (NEXT (p)), u, v);
1042        if (op == NO_TAG) {
1043          diagnostic (A68_ERROR, NEXT (p), ERROR_NO_DYADIC, u, v);
1044          make_soid (y, SORT (x), M_ERROR, 0);
1045        }
1046        if (op != NO_TAG) {
1047          MOID (NEXT (p)) = MOID (op);
1048        }
1049        TAX (NEXT (p)) = op;
1050        if (op != NO_TAG && op != A68_PARSER (error_tag)) {
1051          make_soid (y, SORT (x), SUB_MOID (op), 0);
1052        } else {
1053          make_soid (y, SORT (x), M_ERROR, 0);
1054        }
1055      }
1056    }
1057  }
1058  
1059  //! @brief Mode check assignation.
1060  
1061  void mode_check_assignation (NODE_T * p, SOID_T * x, SOID_T * y)
1062  {
1063    SOID_T name, tmp, value;
1064    MOID_T *name_moid, *ori;
1065  // Get destination mode.
1066    make_soid (&name, SOFT, NO_MOID, 0);
1067    mode_check_unit (SUB (p), &name, &tmp);
1068  // SOFT coercion.
1069    ori = determine_unique_mode (&tmp, SAFE_DEFLEXING);
1070    name_moid = deproc_completely (ori);
1071    if (ATTRIBUTE (name_moid) != REF_SYMBOL) {
1072      if (IF_MODE_IS_WELL (name_moid)) {
1073        diagnostic (A68_ERROR, p, ERROR_NO_NAME, ori, ATTRIBUTE (SUB (p)));
1074      }
1075      make_soid (y, SORT (x), M_ERROR, 0);
1076      return;
1077    }
1078    MOID (p) = name_moid;
1079  // Get source mode.
1080    make_soid (&name, STRONG, SUB (name_moid), 0);
1081    mode_check_unit (NEXT_NEXT (p), &name, &value);
1082    if (!is_coercible_in_context (&value, &name, FORCE_DEFLEXING)) {
1083      cannot_coerce (p, MOID (&value), MOID (&name), STRONG, FORCE_DEFLEXING, UNIT);
1084      make_soid (y, SORT (x), M_ERROR, 0);
1085    } else {
1086      make_soid (y, SORT (x), name_moid, 0);
1087    }
1088  }
1089  
1090  //! @brief Mode check identity relation.
1091  
1092  void mode_check_identity_relation (NODE_T * p, SOID_T * x, SOID_T * y)
1093  {
1094    SOID_T e, l, r;
1095    MOID_T *lhs, *rhs, *oril, *orir;
1096    NODE_T *ln = p, *rn = NEXT_NEXT (p);
1097    make_soid (&e, SOFT, NO_MOID, 0);
1098    mode_check_unit (SUB (ln), &e, &l);
1099    mode_check_unit (SUB (rn), &e, &r);
1100  // SOFT coercion.
1101    oril = determine_unique_mode (&l, SAFE_DEFLEXING);
1102    orir = determine_unique_mode (&r, SAFE_DEFLEXING);
1103    lhs = deproc_completely (oril);
1104    rhs = deproc_completely (orir);
1105    if (IF_MODE_IS_WELL (lhs) && lhs != M_HIP && ATTRIBUTE (lhs) != REF_SYMBOL) {
1106      diagnostic (A68_ERROR, ln, ERROR_NO_NAME, oril, ATTRIBUTE (SUB (ln)));
1107      lhs = M_ERROR;
1108    }
1109    if (IF_MODE_IS_WELL (rhs) && rhs != M_HIP && ATTRIBUTE (rhs) != REF_SYMBOL) {
1110      diagnostic (A68_ERROR, rn, ERROR_NO_NAME, orir, ATTRIBUTE (SUB (rn)));
1111      rhs = M_ERROR;
1112    }
1113    if (lhs == M_HIP && rhs == M_HIP) {
1114      diagnostic (A68_ERROR, p, ERROR_NO_UNIQUE_MODE);
1115    }
1116    if (is_coercible (lhs, rhs, STRONG, SAFE_DEFLEXING)) {
1117      lhs = rhs;
1118    } else if (is_coercible (rhs, lhs, STRONG, SAFE_DEFLEXING)) {
1119      rhs = lhs;
1120    } else {
1121      cannot_coerce (NEXT (p), rhs, lhs, SOFT, SKIP_DEFLEXING, TERTIARY);
1122      lhs = rhs = M_ERROR;
1123    }
1124    MOID (ln) = lhs;
1125    MOID (rn) = rhs;
1126    make_soid (y, SORT (x), M_BOOL, 0);
1127  }
1128  
1129  //! @brief Mode check bool functions ANDF and ORF.
1130  
1131  void mode_check_bool_function (NODE_T * p, SOID_T * x, SOID_T * y)
1132  {
1133    SOID_T e, l, r;
1134    NODE_T *ln = p, *rn = NEXT_NEXT (p);
1135    make_soid (&e, STRONG, M_BOOL, 0);
1136    mode_check_unit (SUB (ln), &e, &l);
1137    if (!is_coercible_in_context (&l, &e, SAFE_DEFLEXING)) {
1138      cannot_coerce (ln, MOID (&l), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY);
1139    }
1140    mode_check_unit (SUB (rn), &e, &r);
1141    if (!is_coercible_in_context (&r, &e, SAFE_DEFLEXING)) {
1142      cannot_coerce (rn, MOID (&r), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY);
1143    }
1144    MOID (ln) = M_BOOL;
1145    MOID (rn) = M_BOOL;
1146    make_soid (y, SORT (x), M_BOOL, 0);
1147  }
1148  
1149  //! @brief Mode check cast.
1150  
1151  void mode_check_cast (NODE_T * p, SOID_T * x, SOID_T * y)
1152  {
1153    SOID_T w;
1154    mode_check_declarer (p);
1155    make_soid (&w, STRONG, MOID (p), 0);
1156    CAST (&w) = A68_TRUE;
1157    mode_check_enclosed (SUB_NEXT (p), &w, y);
1158    if (!is_coercible_in_context (y, &w, SAFE_DEFLEXING)) {
1159      cannot_coerce (NEXT (p), MOID (y), MOID (&w), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
1160    }
1161    make_soid (y, SORT (x), MOID (p), 0);
1162  }
1163  
1164  //! @brief Mode check assertion.
1165  
1166  void mode_check_assertion (NODE_T * p)
1167  {
1168    SOID_T w, y;
1169    make_soid (&w, STRONG, M_BOOL, 0);
1170    mode_check_enclosed (SUB_NEXT (p), &w, &y);
1171    SORT (&y) = SORT (&w);
1172    if (!is_coercible_in_context (&y, &w, NO_DEFLEXING)) {
1173      cannot_coerce (NEXT (p), MOID (&y), MOID (&w), MEEK, NO_DEFLEXING, ENCLOSED_CLAUSE);
1174    }
1175  }
1176  
1177  //! @brief Mode check argument list.
1178  
1179  void mode_check_argument_list (SOID_T ** r, NODE_T * p, PACK_T ** x, PACK_T ** v, PACK_T ** w)
1180  {
1181    for (; p != NO_NODE; FORWARD (p)) {
1182      if (IS (p, GENERIC_ARGUMENT_LIST)) {
1183        ATTRIBUTE (p) = ARGUMENT_LIST;
1184      }
1185      if (IS (p, ARGUMENT_LIST)) {
1186        mode_check_argument_list (r, SUB (p), x, v, w);
1187      } else if (IS (p, UNIT)) {
1188        SOID_T y, z;
1189        if (*x != NO_PACK) {
1190          make_soid (&z, STRONG, MOID (*x), 0);
1191          add_mode_to_pack_end (v, MOID (*x), NO_TEXT, p);
1192          FORWARD (*x);
1193        } else {
1194          make_soid (&z, STRONG, NO_MOID, 0);
1195        }
1196        mode_check_unit (p, &z, &y);
1197        add_to_soid_list (r, p, &y);
1198      } else if (IS (p, TRIMMER)) {
1199        SOID_T z;
1200        if (SUB (p) != NO_NODE) {
1201          diagnostic (A68_SYNTAX_ERROR, p, ERROR_SYNTAX, ARGUMENT);
1202          make_soid (&z, STRONG, M_ERROR, 0);
1203          add_mode_to_pack_end (v, M_VOID, NO_TEXT, p);
1204          add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p);
1205          FORWARD (*x);
1206        } else if (*x != NO_PACK) {
1207          make_soid (&z, STRONG, MOID (*x), 0);
1208          add_mode_to_pack_end (v, M_VOID, NO_TEXT, p);
1209          add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p);
1210          FORWARD (*x);
1211        } else {
1212          make_soid (&z, STRONG, NO_MOID, 0);
1213        }
1214        add_to_soid_list (r, p, &z);
1215      } else if (IS (p, SUB_SYMBOL) && !OPTION_BRACKETS (&A68_JOB)) {
1216        diagnostic (A68_SYNTAX_ERROR, p, ERROR_SYNTAX, CALL);
1217      }
1218    }
1219  }
1220  
1221  //! @brief Mode check argument list 2.
1222  
1223  void mode_check_argument_list_2 (NODE_T * p, PACK_T * x, SOID_T * y, PACK_T ** v, PACK_T ** w)
1224  {
1225    SOID_T *top_sl = NO_SOID;
1226    mode_check_argument_list (&top_sl, SUB (p), &x, v, w);
1227    make_soid (y, STRONG, pack_soids_in_moid (top_sl, STOWED_MODE), 0);
1228    free_soid_list (top_sl);
1229  }
1230  
1231  //! @brief Mode check meek int.
1232  
1233  void mode_check_meek_int (NODE_T * p)
1234  {
1235    SOID_T x, y;
1236    make_soid (&x, MEEK, M_INT, 0);
1237    mode_check_unit (p, &x, &y);
1238    if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
1239      cannot_coerce (p, MOID (&y), MOID (&x), MEEK, SAFE_DEFLEXING, 0);
1240    }
1241  }
1242  
1243  //! @brief Mode check trimmer.
1244  
1245  void mode_check_trimmer (NODE_T * p)
1246  {
1247    if (p == NO_NODE) {
1248      return;
1249    } else if (IS (p, TRIMMER)) {
1250      mode_check_trimmer (SUB (p));
1251    } else if (IS (p, UNIT)) {
1252      mode_check_meek_int (p);
1253      mode_check_trimmer (NEXT (p));
1254    } else {
1255      mode_check_trimmer (NEXT (p));
1256    }
1257  }
1258  
1259  //! @brief Mode check indexer.
1260  
1261  void mode_check_indexer (NODE_T * p, int *subs, int *trims)
1262  {
1263    if (p == NO_NODE) {
1264      return;
1265    } else if (IS (p, TRIMMER)) {
1266      (*trims)++;
1267      mode_check_trimmer (SUB (p));
1268    } else if (IS (p, UNIT)) {
1269      (*subs)++;
1270      mode_check_meek_int (p);
1271    } else {
1272      mode_check_indexer (SUB (p), subs, trims);
1273      mode_check_indexer (NEXT (p), subs, trims);
1274    }
1275  }
1276  
1277  //! @brief Mode check call.
1278  
1279  void mode_check_call (NODE_T * p, MOID_T * n, SOID_T * x, SOID_T * y)
1280  {
1281    SOID_T d;
1282    MOID (p) = n;
1283  // "partial_locale" is the mode of the locale.
1284    PARTIAL_LOCALE (GINFO (p)) = new_moid ();
1285    ATTRIBUTE (PARTIAL_LOCALE (GINFO (p))) = PROC_SYMBOL;
1286    PACK (PARTIAL_LOCALE (GINFO (p))) = NO_PACK;
1287    SUB (PARTIAL_LOCALE (GINFO (p))) = SUB (n);
1288  // "partial_proc" is the mode of the resulting proc.
1289    PARTIAL_PROC (GINFO (p)) = new_moid ();
1290    ATTRIBUTE (PARTIAL_PROC (GINFO (p))) = PROC_SYMBOL;
1291    PACK (PARTIAL_PROC (GINFO (p))) = NO_PACK;
1292    SUB (PARTIAL_PROC (GINFO (p))) = SUB (n);
1293  // Check arguments and construct modes.
1294    mode_check_argument_list_2 (NEXT (p), PACK (n), &d, &PACK (PARTIAL_LOCALE (GINFO (p))), &PACK (PARTIAL_PROC (GINFO (p))));
1295    DIM (PARTIAL_PROC (GINFO (p))) = count_pack_members (PACK (PARTIAL_PROC (GINFO (p))));
1296    DIM (PARTIAL_LOCALE (GINFO (p))) = count_pack_members (PACK (PARTIAL_LOCALE (GINFO (p))));
1297    PARTIAL_PROC (GINFO (p)) = register_extra_mode (&TOP_MOID (&A68_JOB), PARTIAL_PROC (GINFO (p)));
1298    PARTIAL_LOCALE (GINFO (p)) = register_extra_mode (&TOP_MOID (&A68_JOB), PARTIAL_LOCALE (GINFO (p)));
1299    if (DIM (MOID (&d)) != DIM (n)) {
1300      diagnostic (A68_ERROR, p, ERROR_ARGUMENT_NUMBER, n);
1301      make_soid (y, SORT (x), SUB (n), 0);
1302  //  make_soid (y, SORT (x), M_ERROR, 0);.
1303    } else {
1304      if (!is_coercible (MOID (&d), n, STRONG, ALIAS_DEFLEXING)) {
1305        cannot_coerce (p, MOID (&d), n, STRONG, ALIAS_DEFLEXING, ARGUMENT);
1306      }
1307      if (DIM (PARTIAL_PROC (GINFO (p))) == 0) {
1308        make_soid (y, SORT (x), SUB (n), 0);
1309      } else {
1310        if (OPTION_PORTCHECK (&A68_JOB)) {
1311          diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, NEXT (p), WARNING_EXTENSION);
1312        }
1313        make_soid (y, SORT (x), PARTIAL_PROC (GINFO (p)), 0);
1314      }
1315    }
1316  }
1317  
1318  //! @brief Mode check slice.
1319  
1320  void mode_check_slice (NODE_T * p, MOID_T * ori, SOID_T * x, SOID_T * y)
1321  {
1322    BOOL_T is_ref;
1323    int rowdim, subs, trims;
1324    MOID_T *m = depref_completely (ori), *n = ori;
1325  // WEAK coercion.
1326    while ((IS_REF (n) && !is_ref_row (n)) || (IS (n, PROC_SYMBOL) && PACK (n) == NO_PACK)) {
1327      n = depref_once (n);
1328    }
1329    if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) {
1330      if (IF_MODE_IS_WELL (n)) {
1331        diagnostic (A68_ERROR, p, ERROR_NO_ROW_OR_PROC, n, ATTRIBUTE (SUB (p)));
1332      }
1333      make_soid (y, SORT (x), M_ERROR, 0);
1334    }
1335  
1336    MOID (p) = n;
1337    subs = trims = 0;
1338    mode_check_indexer (SUB_NEXT (p), &subs, &trims);
1339    if ((is_ref = is_ref_row (n)) != 0) {
1340      rowdim = DIM (DEFLEX (SUB (n)));
1341    } else {
1342      rowdim = DIM (DEFLEX (n));
1343    }
1344    if ((subs + trims) != rowdim) {
1345      diagnostic (A68_ERROR, p, ERROR_INDEXER_NUMBER, n);
1346      make_soid (y, SORT (x), M_ERROR, 0);
1347    } else {
1348      if (subs > 0 && trims == 0) {
1349        ANNOTATION (NEXT (p)) = SLICE;
1350        m = n;
1351      } else {
1352        ANNOTATION (NEXT (p)) = TRIMMER;
1353        m = n;
1354      }
1355      while (subs > 0) {
1356        if (is_ref) {
1357          m = NAME (m);
1358        } else {
1359          if (IS_FLEX (m)) {
1360            m = SUB (m);
1361          }
1362          m = SLICE (m);
1363        }
1364        ABEND (m == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1365        subs--;
1366      }
1367  // A trim cannot be but deflexed.
1368      if (ANNOTATION (NEXT (p)) == TRIMMER && TRIM (m) != NO_MOID) {
1369        ABEND (TRIM (m) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1370        make_soid (y, SORT (x), TRIM (m), 0);
1371      } else {
1372        make_soid (y, SORT (x), m, 0);
1373      }
1374    }
1375  }
1376  
1377  //! @brief Mode check specification.
1378  
1379  int mode_check_specification (NODE_T * p, SOID_T * x, SOID_T * y)
1380  {
1381    SOID_T w, d;
1382    MOID_T *m, *ori;
1383    make_soid (&w, WEAK, NO_MOID, 0);
1384    mode_check_unit (SUB (p), &w, &d);
1385    ori = determine_unique_mode (&d, SAFE_DEFLEXING);
1386    m = depref_completely (ori);
1387    if (IS (m, PROC_SYMBOL)) {
1388  // Assume CALL.
1389      mode_check_call (p, m, x, y);
1390      return CALL;
1391    } else if (IS_ROW (m) || IS_FLEX (m)) {
1392  // Assume SLICE.
1393      mode_check_slice (p, ori, x, y);
1394      return SLICE;
1395    } else {
1396      if (m != M_ERROR) {
1397        diagnostic (A68_SYNTAX_ERROR, p, ERROR_MODE_SPECIFICATION, m);
1398      }
1399      make_soid (y, SORT (x), M_ERROR, 0);
1400      return PRIMARY;
1401    }
1402  }
1403  
1404  //! @brief Mode check selection.
1405  
1406  void mode_check_selection (NODE_T * p, SOID_T * x, SOID_T * y)
1407  {
1408    SOID_T w, d;
1409    BOOL_T coerce;
1410    MOID_T *n, *str, *ori;
1411    PACK_T *t, *t_2;
1412    char *fs;
1413    BOOL_T deflex = A68_FALSE;
1414    NODE_T *secondary = SUB_NEXT (p);
1415    make_soid (&w, WEAK, NO_MOID, 0);
1416    mode_check_unit (secondary, &w, &d);
1417    n = ori = determine_unique_mode (&d, SAFE_DEFLEXING);
1418    coerce = A68_TRUE;
1419    while (coerce) {
1420      if (IS (n, STRUCT_SYMBOL)) {
1421        coerce = A68_FALSE;
1422        t = PACK (n);
1423      } else if (IS_REF (n) && (IS_ROW (SUB (n)) || IS_FLEX (SUB (n))) && MULTIPLE (n) != NO_MOID) {
1424        coerce = A68_FALSE;
1425        deflex = A68_TRUE;
1426        t = PACK (MULTIPLE (n));
1427      } else if ((IS_ROW (n) || IS_FLEX (n)) && MULTIPLE (n) != NO_MOID) {
1428        coerce = A68_FALSE;
1429        deflex = A68_TRUE;
1430        t = PACK (MULTIPLE (n));
1431      } else if (IS_REF (n) && is_name_struct (n)) {
1432        coerce = A68_FALSE;
1433        t = PACK (NAME (n));
1434      } else if (is_deprefable (n)) {
1435        coerce = A68_TRUE;
1436        n = SUB (n);
1437        t = NO_PACK;
1438      } else {
1439        coerce = A68_FALSE;
1440        t = NO_PACK;
1441      }
1442    }
1443    if (t == NO_PACK) {
1444      if (IF_MODE_IS_WELL (MOID (&d))) {
1445        diagnostic (A68_ERROR, secondary, ERROR_NO_STRUCT, ori, ATTRIBUTE (secondary));
1446      }
1447      make_soid (y, SORT (x), M_ERROR, 0);
1448      return;
1449    }
1450    MOID (NEXT (p)) = n;
1451    fs = NSYMBOL (SUB (p));
1452    str = n;
1453    while (IS_REF (str)) {
1454      str = SUB (str);
1455    }
1456    if (IS_FLEX (str)) {
1457      str = SUB (str);
1458    }
1459    if (IS_ROW (str)) {
1460      str = SUB (str);
1461    }
1462    t_2 = PACK (str);
1463    while (t != NO_PACK && t_2 != NO_PACK) {
1464      if (TEXT (t) == fs) {
1465        MOID_T *ret = MOID (t);
1466        if (deflex && TRIM (ret) != NO_MOID) {
1467          ret = TRIM (ret);
1468        }
1469        make_soid (y, SORT (x), ret, 0);
1470        MOID (p) = ret;
1471        NODE_PACK (SUB (p)) = t_2;
1472        return;
1473      }
1474      FORWARD (t);
1475      FORWARD (t_2);
1476    }
1477    make_soid (&d, NO_SORT, n, 0);
1478    diagnostic (A68_ERROR, p, ERROR_NO_FIELD, str, fs);
1479    make_soid (y, SORT (x), M_ERROR, 0);
1480  }
1481  
1482  //! @brief Mode check diagonal.
1483  
1484  void mode_check_diagonal (NODE_T * p, SOID_T * x, SOID_T * y)
1485  {
1486    SOID_T w, d;
1487    NODE_T *tert;
1488    MOID_T *n, *ori;
1489    int rowdim;
1490    BOOL_T is_ref;
1491    if (IS (p, TERTIARY)) {
1492      make_soid (&w, STRONG, M_INT, 0);
1493      mode_check_unit (p, &w, &d);
1494      if (!is_coercible_in_context (&d, &w, SAFE_DEFLEXING)) {
1495        cannot_coerce (p, MOID (&d), MOID (&w), MEEK, SAFE_DEFLEXING, 0);
1496      }
1497      tert = NEXT_NEXT (p);
1498    } else {
1499      tert = NEXT (p);
1500    }
1501    make_soid (&w, WEAK, NO_MOID, 0);
1502    mode_check_unit (tert, &w, &d);
1503    n = ori = determine_unique_mode (&d, SAFE_DEFLEXING);
1504    while (IS_REF (n) && !is_ref_row (n)) {
1505      n = depref_once (n);
1506    }
1507    if (n != NO_MOID && (IS_FLEX (n) || IS_REF_FLEX (n))) {
1508      if (IF_MODE_IS_WELL (n)) {
1509        diagnostic (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY);
1510      }
1511      make_soid (y, SORT (x), M_ERROR, 0);
1512      return;
1513    }
1514    if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) {
1515      if (IF_MODE_IS_WELL (n)) {
1516        diagnostic (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY);
1517      }
1518      make_soid (y, SORT (x), M_ERROR, 0);
1519      return;
1520    }
1521    if ((is_ref = is_ref_row (n)) != A68_FALSE) {
1522      rowdim = DIM (DEFLEX (SUB (n)));
1523    } else {
1524      rowdim = DIM (DEFLEX (n));
1525    }
1526    if (rowdim != 2) {
1527      diagnostic (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY);
1528      make_soid (y, SORT (x), M_ERROR, 0);
1529      return;
1530    }
1531    MOID (tert) = n;
1532    if (is_ref) {
1533      n = NAME (n);
1534      ABEND (!IS_REF (n), ERROR_INTERNAL_CONSISTENCY, PM (n));
1535    } else {
1536      n = SLICE (n);
1537    }
1538    ABEND (n == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1539    make_soid (y, SORT (x), n, 0);
1540  }
1541  
1542  //! @brief Mode check transpose.
1543  
1544  void mode_check_transpose (NODE_T * p, SOID_T * x, SOID_T * y)
1545  {
1546    SOID_T w, d;
1547    NODE_T *tert = NEXT (p);
1548    MOID_T *n, *ori;
1549    int rowdim;
1550    BOOL_T is_ref;
1551    make_soid (&w, WEAK, NO_MOID, 0);
1552    mode_check_unit (tert, &w, &d);
1553    n = ori = determine_unique_mode (&d, SAFE_DEFLEXING);
1554    while (IS_REF (n) && !is_ref_row (n)) {
1555      n = depref_once (n);
1556    }
1557    if (n != NO_MOID && (IS_FLEX (n) || IS_REF_FLEX (n))) {
1558      if (IF_MODE_IS_WELL (n)) {
1559        diagnostic (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY);
1560      }
1561      make_soid (y, SORT (x), M_ERROR, 0);
1562      return;
1563    }
1564    if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) {
1565      if (IF_MODE_IS_WELL (n)) {
1566        diagnostic (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY);
1567      }
1568      make_soid (y, SORT (x), M_ERROR, 0);
1569      return;
1570    }
1571    if ((is_ref = is_ref_row (n)) != A68_FALSE) {
1572      rowdim = DIM (DEFLEX (SUB (n)));
1573    } else {
1574      rowdim = DIM (DEFLEX (n));
1575    }
1576    if (rowdim != 2) {
1577      diagnostic (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY);
1578      make_soid (y, SORT (x), M_ERROR, 0);
1579      return;
1580    }
1581    MOID (tert) = n;
1582    ABEND (n == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1583    make_soid (y, SORT (x), n, 0);
1584  }
1585  
1586  //! @brief Mode check row or column function.
1587  
1588  void mode_check_row_column_function (NODE_T * p, SOID_T * x, SOID_T * y)
1589  {
1590    SOID_T w, d;
1591    NODE_T *tert;
1592    MOID_T *n, *ori;
1593    int rowdim;
1594    BOOL_T is_ref;
1595    if (IS (p, TERTIARY)) {
1596      make_soid (&w, STRONG, M_INT, 0);
1597      mode_check_unit (p, &w, &d);
1598      if (!is_coercible_in_context (&d, &w, SAFE_DEFLEXING)) {
1599        cannot_coerce (p, MOID (&d), MOID (&w), MEEK, SAFE_DEFLEXING, 0);
1600      }
1601      tert = NEXT_NEXT (p);
1602    } else {
1603      tert = NEXT (p);
1604    }
1605    make_soid (&w, WEAK, NO_MOID, 0);
1606    mode_check_unit (tert, &w, &d);
1607    n = ori = determine_unique_mode (&d, SAFE_DEFLEXING);
1608    while (IS_REF (n) && !is_ref_row (n)) {
1609      n = depref_once (n);
1610    }
1611    if (n != NO_MOID && (IS_FLEX (n) || IS_REF_FLEX (n))) {
1612      if (IF_MODE_IS_WELL (n)) {
1613        diagnostic (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY);
1614      }
1615      make_soid (y, SORT (x), M_ERROR, 0);
1616      return;
1617    }
1618    if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) {
1619      if (IF_MODE_IS_WELL (n)) {
1620        diagnostic (A68_ERROR, p, ERROR_NO_VECTOR, ori, TERTIARY);
1621      }
1622      make_soid (y, SORT (x), M_ERROR, 0);
1623      return;
1624    }
1625    if ((is_ref = is_ref_row (n)) != A68_FALSE) {
1626      rowdim = DIM (DEFLEX (SUB (n)));
1627    } else {
1628      rowdim = DIM (DEFLEX (n));
1629    }
1630    if (rowdim != 1) {
1631      diagnostic (A68_ERROR, p, ERROR_NO_VECTOR, ori, TERTIARY);
1632      make_soid (y, SORT (x), M_ERROR, 0);
1633      return;
1634    }
1635    MOID (tert) = n;
1636    ABEND (n == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1637    make_soid (y, SORT (x), ROWED (n), 0);
1638  }
1639  
1640  //! @brief Mode check format text.
1641  
1642  void mode_check_format_text (NODE_T * p)
1643  {
1644    for (; p != NO_NODE; FORWARD (p)) {
1645      mode_check_format_text (SUB (p));
1646      if (IS (p, FORMAT_PATTERN)) {
1647        SOID_T x, y;
1648        make_soid (&x, STRONG, M_FORMAT, 0);
1649        mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
1650        if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
1651          cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
1652        }
1653      } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1654        SOID_T x, y;
1655        make_soid (&x, STRONG, M_ROW_INT, 0);
1656        mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
1657        if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
1658          cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
1659        }
1660      } else if (IS (p, DYNAMIC_REPLICATOR)) {
1661        SOID_T x, y;
1662        make_soid (&x, STRONG, M_INT, 0);
1663        mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
1664        if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
1665          cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
1666        }
1667      }
1668    }
1669  }
1670  
1671  //! @brief Mode check unit.
1672  
1673  void mode_check_unit (NODE_T * p, SOID_T * x, SOID_T * y)
1674  {
1675    if (p == NO_NODE) {
1676      return;
1677    } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) {
1678      mode_check_unit (SUB (p), x, y);
1679  // Ex primary.
1680    } else if (IS (p, SPECIFICATION)) {
1681      ATTRIBUTE (p) = mode_check_specification (SUB (p), x, y);
1682      warn_for_voiding (p, x, y, ATTRIBUTE (p));
1683    } else if (IS (p, CAST)) {
1684      mode_check_cast (SUB (p), x, y);
1685      warn_for_voiding (p, x, y, CAST);
1686    } else if (IS (p, DENOTATION)) {
1687      make_soid (y, SORT (x), MOID (SUB (p)), 0);
1688      warn_for_voiding (p, x, y, DENOTATION);
1689    } else if (IS (p, IDENTIFIER)) {
1690      if ((TAX (p) == NO_TAG) && (MOID (p) == NO_MOID)) {
1691        int att = first_tag_global (TABLE (p), NSYMBOL (p));
1692        if (att == STOP) {
1693          (void) add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
1694          diagnostic (A68_ERROR, p, ERROR_UNDECLARED_TAG);
1695          MOID (p) = M_ERROR;
1696        } else {
1697          TAG_T *z = find_tag_global (TABLE (p), att, NSYMBOL (p));
1698          if (att == IDENTIFIER && z != NO_TAG) {
1699            MOID (p) = MOID (z);
1700          } else {
1701            (void) add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
1702            diagnostic (A68_ERROR, p, ERROR_UNDECLARED_TAG);
1703            MOID (p) = M_ERROR;
1704          }
1705        }
1706      }
1707      make_soid (y, SORT (x), MOID (p), 0);
1708      warn_for_voiding (p, x, y, IDENTIFIER);
1709    } else if (IS (p, ENCLOSED_CLAUSE)) {
1710      mode_check_enclosed (SUB (p), x, y);
1711    } else if (IS (p, FORMAT_TEXT)) {
1712      mode_check_format_text (p);
1713      make_soid (y, SORT (x), M_FORMAT, 0);
1714      warn_for_voiding (p, x, y, FORMAT_TEXT);
1715  // Ex secondary.
1716    } else if (IS (p, GENERATOR)) {
1717      mode_check_declarer (SUB (p));
1718      make_soid (y, SORT (x), MOID (SUB (p)), 0);
1719      warn_for_voiding (p, x, y, GENERATOR);
1720    } else if (IS (p, SELECTION)) {
1721      mode_check_selection (SUB (p), x, y);
1722      warn_for_voiding (p, x, y, SELECTION);
1723  // Ex tertiary.
1724    } else if (IS (p, NIHIL)) {
1725      make_soid (y, STRONG, M_HIP, 0);
1726    } else if (IS (p, FORMULA)) {
1727      mode_check_formula (p, x, y);
1728      if (!IS_REF (MOID (y))) {
1729        warn_for_voiding (p, x, y, FORMULA);
1730      }
1731    } else if (IS (p, DIAGONAL_FUNCTION)) {
1732      mode_check_diagonal (SUB (p), x, y);
1733      warn_for_voiding (p, x, y, DIAGONAL_FUNCTION);
1734    } else if (IS (p, TRANSPOSE_FUNCTION)) {
1735      mode_check_transpose (SUB (p), x, y);
1736      warn_for_voiding (p, x, y, TRANSPOSE_FUNCTION);
1737    } else if (IS (p, ROW_FUNCTION)) {
1738      mode_check_row_column_function (SUB (p), x, y);
1739      warn_for_voiding (p, x, y, ROW_FUNCTION);
1740    } else if (IS (p, COLUMN_FUNCTION)) {
1741      mode_check_row_column_function (SUB (p), x, y);
1742      warn_for_voiding (p, x, y, COLUMN_FUNCTION);
1743  // Ex unit.
1744    } else if (is_one_of (p, JUMP, SKIP, STOP)) {
1745      if (SORT (x) != STRONG) {
1746        diagnostic (A68_WARNING, p, WARNING_HIP, SORT (x));
1747      }
1748  //  make_soid (y, STRONG, M_HIP, 0);
1749      make_soid (y, SORT (x), M_HIP, 0);
1750    } else if (IS (p, ASSIGNATION)) {
1751      mode_check_assignation (SUB (p), x, y);
1752    } else if (IS (p, IDENTITY_RELATION)) {
1753      mode_check_identity_relation (SUB (p), x, y);
1754      warn_for_voiding (p, x, y, IDENTITY_RELATION);
1755    } else if (IS (p, ROUTINE_TEXT)) {
1756      mode_check_routine_text (SUB (p), y);
1757      make_soid (y, SORT (x), MOID (p), 0);
1758      warn_for_voiding (p, x, y, ROUTINE_TEXT);
1759    } else if (IS (p, ASSERTION)) {
1760      mode_check_assertion (SUB (p));
1761      make_soid (y, STRONG, M_VOID, 0);
1762    } else if (IS (p, AND_FUNCTION)) {
1763      mode_check_bool_function (SUB (p), x, y);
1764      warn_for_voiding (p, x, y, AND_FUNCTION);
1765    } else if (IS (p, OR_FUNCTION)) {
1766      mode_check_bool_function (SUB (p), x, y);
1767      warn_for_voiding (p, x, y, OR_FUNCTION);
1768    } else if (IS (p, CODE_CLAUSE)) {
1769      make_soid (y, STRONG, M_HIP, 0);
1770    }
1771    MOID (p) = MOID (y);
1772  }
1773