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


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