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