moids-misc.c

     
   1  //! @file moids-misc.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  //! Miscellaneous MOID routines.
  25  
  26  #include "a68g.h"
  27  #include "a68g-parser.h"
  28  #include "a68g-prelude.h"
  29  #include "a68g-moids.h"
  30  
  31  // MODE checker routines.
  32  
  33  //! @brief Absorb nested series modes recursively.
  34  
  35  void absorb_series_pack (MOID_T ** p)
  36  {
  37    BOOL_T go_on;
  38    do {
  39      PACK_T *z = NO_PACK, *t;
  40      go_on = A68_FALSE;
  41      for (t = PACK (*p); t != NO_PACK; FORWARD (t)) {
  42        if (MOID (t) != NO_MOID && IS (MOID (t), SERIES_MODE)) {
  43          PACK_T *s;
  44          go_on = A68_TRUE;
  45          for (s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) {
  46            add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
  47          }
  48        } else {
  49          add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
  50        }
  51      }
  52      PACK (*p) = z;
  53    } while (go_on);
  54  }
  55  
  56  //! @brief Make SERIES (u, v).
  57  
  58  MOID_T *make_series_from_moids (MOID_T * u, MOID_T * v)
  59  {
  60    MOID_T *x = new_moid ();
  61    ATTRIBUTE (x) = SERIES_MODE;
  62    add_mode_to_pack (&(PACK (x)), u, NO_TEXT, NODE (u));
  63    add_mode_to_pack (&(PACK (x)), v, NO_TEXT, NODE (v));
  64    absorb_series_pack (&x);
  65    DIM (x) = count_pack_members (PACK (x));
  66    (void) register_extra_mode (&TOP_MOID (&A68_JOB), x);
  67    if (DIM (x) == 1) {
  68      return MOID (PACK (x));
  69    } else {
  70      return x;
  71    }
  72  }
  73  
  74  //! @brief Absorb firmly related unions in mode.
  75  
  76  MOID_T *absorb_related_subsets (MOID_T * m)
  77  {
  78  // For instance invalid UNION (PROC REF UNION (A, B), A, B) -> valid UNION (A, B),
  79  // which is used in balancing conformity clauses.
  80    int mods;
  81    do {
  82      PACK_T *u = NO_PACK, *v;
  83      mods = 0;
  84      for (v = PACK (m); v != NO_PACK; FORWARD (v)) {
  85        MOID_T *n = depref_completely (MOID (v));
  86        if (IS (n, UNION_SYMBOL) && is_subset (n, m, SAFE_DEFLEXING)) {
  87  // Unpack it.
  88          PACK_T *w;
  89          for (w = PACK (n); w != NO_PACK; FORWARD (w)) {
  90            add_mode_to_pack (&u, MOID (w), NO_TEXT, NODE (w));
  91          }
  92          mods++;
  93        } else {
  94          add_mode_to_pack (&u, MOID (v), NO_TEXT, NODE (v));
  95        }
  96      }
  97      PACK (m) = absorb_union_pack (u);
  98    } while (mods != 0);
  99    return m;
 100  }
 101  
 102  //! @brief Absorb nested series and united modes recursively.
 103  
 104  void absorb_series_union_pack (MOID_T ** p)
 105  {
 106    BOOL_T go_on;
 107    do {
 108      PACK_T *z = NO_PACK, *t;
 109      go_on = A68_FALSE;
 110      for (t = PACK (*p); t != NO_PACK; FORWARD (t)) {
 111        if (MOID (t) != NO_MOID && (IS (MOID (t), SERIES_MODE) || IS (MOID (t), UNION_SYMBOL))) {
 112          PACK_T *s;
 113          go_on = A68_TRUE;
 114          for (s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) {
 115            add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
 116          }
 117        } else {
 118          add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
 119        }
 120      }
 121      PACK (*p) = z;
 122    } while (go_on);
 123  }
 124  
 125  //! @brief Make united mode, from mode that is a SERIES (..).
 126  
 127  MOID_T *make_united_mode (MOID_T * m)
 128  {
 129    MOID_T *u;
 130    PACK_T *w;
 131    int mods;
 132    if (m == NO_MOID) {
 133      return M_ERROR;
 134    } else if (ATTRIBUTE (m) != SERIES_MODE) {
 135      return m;
 136    }
 137  // Do not unite a single UNION.
 138    if (DIM (m) == 1 && IS (MOID (PACK (m)), UNION_SYMBOL)) {
 139      return MOID (PACK (m));
 140    }
 141  // Straighten the series.
 142    absorb_series_union_pack (&m);
 143  // Copy the series into a UNION.
 144    u = new_moid ();
 145    ATTRIBUTE (u) = UNION_SYMBOL;
 146    PACK (u) = NO_PACK;
 147    w = PACK (m);
 148    for (w = PACK (m); w != NO_PACK; FORWARD (w)) {
 149      add_mode_to_pack (&(PACK (u)), MOID (w), NO_TEXT, NODE (m));
 150    }
 151  // Absorb and contract the new UNION.
 152    do {
 153      mods = 0;
 154      absorb_series_union_pack (&u);
 155      DIM (u) = count_pack_members (PACK (u));
 156      PACK (u) = absorb_union_pack (PACK (u));
 157      contract_union (u);
 158      DIM (u) = count_pack_members (PACK (u));
 159    } while (mods != 0);
 160  // A UNION of one mode is that mode itself.
 161    if (DIM (u) == 1) {
 162      return MOID (PACK (u));
 163    } else {
 164      return register_extra_mode (&TOP_MOID (&A68_JOB), u);
 165    }
 166  }
 167  
 168  //! @brief Make SOID data structure.
 169  
 170  void make_soid (SOID_T * s, int sort, MOID_T * type, int attribute)
 171  {
 172    ATTRIBUTE (s) = attribute;
 173    SORT (s) = sort;
 174    MOID (s) = type;
 175    CAST (s) = A68_FALSE;
 176  }
 177  
 178  //! @brief Whether mode is not well defined.
 179  
 180  BOOL_T is_mode_isnt_well (MOID_T * p)
 181  {
 182    if (p == NO_MOID) {
 183      return A68_TRUE;
 184    } else if (!IF_MODE_IS_WELL (p)) {
 185      return A68_TRUE;
 186    } else if (PACK (p) != NO_PACK) {
 187      PACK_T *q = PACK (p);
 188      for (; q != NO_PACK; FORWARD (q)) {
 189        if (!IF_MODE_IS_WELL (MOID (q))) {
 190          return A68_TRUE;
 191        }
 192      }
 193    }
 194    return A68_FALSE;
 195  }
 196  
 197  //! @brief Add SOID data to free chain.
 198  
 199  void free_soid_list (SOID_T * root)
 200  {
 201    if (root != NO_SOID) {
 202      SOID_T *q;
 203      for (q = root; NEXT (q) != NO_SOID; FORWARD (q)) {
 204        ;
 205      }
 206      NEXT (q) = A68 (top_soid_list);
 207      A68 (top_soid_list) = root;
 208    }
 209  }
 210  
 211  //! @brief Add SOID data structure to soid list.
 212  
 213  void add_to_soid_list (SOID_T ** root, NODE_T * where, SOID_T * soid)
 214  {
 215    if (*root != NO_SOID) {
 216      add_to_soid_list (&(NEXT (*root)), where, soid);
 217    } else {
 218      SOID_T *new_one;
 219      if (A68 (top_soid_list) == NO_SOID) {
 220        new_one = (SOID_T *) get_temp_heap_space ((size_t) SIZE_ALIGNED (SOID_T));
 221      } else {
 222        new_one = A68 (top_soid_list);
 223        FORWARD (A68 (top_soid_list));
 224      }
 225      make_soid (new_one, SORT (soid), MOID (soid), 0);
 226      NODE (new_one) = where;
 227      NEXT (new_one) = NO_SOID;
 228      *root = new_one;
 229    }
 230  }
 231  
 232  //! @brief Pack soids in moid, gather resulting moids from terminators in a clause.
 233  
 234  MOID_T *pack_soids_in_moid (SOID_T * top_sl, int attribute)
 235  {
 236    MOID_T *x = new_moid ();
 237    PACK_T *t, **p;
 238    ATTRIBUTE (x) = attribute;
 239    DIM (x) = 0;
 240    SUB (x) = NO_MOID;
 241    EQUIVALENT (x) = NO_MOID;
 242    SLICE (x) = NO_MOID;
 243    DEFLEXED (x) = NO_MOID;
 244    NAME (x) = NO_MOID;
 245    NEXT (x) = NO_MOID;
 246    PACK (x) = NO_PACK;
 247    p = &(PACK (x));
 248    for (; top_sl != NO_SOID; FORWARD (top_sl)) {
 249      t = new_pack ();
 250      MOID (t) = MOID (top_sl);
 251      TEXT (t) = NO_TEXT;
 252      NODE (t) = NODE (top_sl);
 253      NEXT (t) = NO_PACK;
 254      DIM (x)++;
 255      *p = t;
 256      p = &NEXT (t);
 257    }
 258    (void) register_extra_mode (&TOP_MOID (&A68_JOB), x);
 259    return x;
 260  }
 261  
 262  //! @brief Whether "p" is compatible with "q".
 263  
 264  BOOL_T is_equal_modes (MOID_T * p, MOID_T * q, int deflex)
 265  {
 266    if (deflex == FORCE_DEFLEXING) {
 267      return DEFLEX (p) == DEFLEX (q);
 268    } else if (deflex == ALIAS_DEFLEXING) {
 269      if (IS (p, REF_SYMBOL) && IS (q, REF_SYMBOL)) {
 270        return p == q || DEFLEX (p) == q;
 271      } else if (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL)) {
 272        return DEFLEX (p) == DEFLEX (q);
 273      }
 274    } else if (deflex == SAFE_DEFLEXING) {
 275      if (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL)) {
 276        return DEFLEX (p) == DEFLEX (q);
 277      }
 278    }
 279    return p == q;
 280  }
 281  
 282  //! @brief Whether mode is deprefable.
 283  
 284  BOOL_T is_deprefable (MOID_T * p)
 285  {
 286    if (IS_REF (p)) {
 287      return A68_TRUE;
 288    } else {
 289      return (BOOL_T) (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK);
 290    }
 291  }
 292  
 293  //! @brief Depref mode once.
 294  
 295  MOID_T *depref_once (MOID_T * p)
 296  {
 297    if (IS_REF_FLEX (p)) {
 298      return SUB_SUB (p);
 299    } else if (IS_REF (p)) {
 300      return SUB (p);
 301    } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) {
 302      return SUB (p);
 303    } else {
 304      return NO_MOID;
 305    }
 306  }
 307  
 308  //! @brief Depref mode completely.
 309  
 310  MOID_T *depref_completely (MOID_T * p)
 311  {
 312    while (is_deprefable (p)) {
 313      p = depref_once (p);
 314    }
 315    return p;
 316  }
 317  
 318  //! @brief Deproc_completely.
 319  
 320  MOID_T *deproc_completely (MOID_T * p)
 321  {
 322    while (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) {
 323      p = depref_once (p);
 324    }
 325    return p;
 326  }
 327  
 328  //! @brief Depref rows.
 329  
 330  MOID_T *depref_rows (MOID_T * p, MOID_T * q)
 331  {
 332    if (q == M_ROWS) {
 333      while (is_deprefable (p)) {
 334        p = depref_once (p);
 335      }
 336      return p;
 337    } else {
 338      return q;
 339    }
 340  }
 341  
 342  //! @brief Derow mode, strip FLEX and BOUNDS.
 343  
 344  MOID_T *derow (MOID_T * p)
 345  {
 346    if (IS_ROW (p) || IS_FLEX (p)) {
 347      return derow (SUB (p));
 348    } else {
 349      return p;
 350    }
 351  }
 352  
 353  //! @brief Whether rows type.
 354  
 355  BOOL_T is_rows_type (MOID_T * p)
 356  {
 357    switch (ATTRIBUTE (p)) {
 358    case ROW_SYMBOL:
 359    case FLEX_SYMBOL:
 360      {
 361        return A68_TRUE;
 362      }
 363    case UNION_SYMBOL:
 364      {
 365        PACK_T *t = PACK (p);
 366        BOOL_T go_on = A68_TRUE;
 367        while (t != NO_PACK && go_on) {
 368          go_on &= is_rows_type (MOID (t));
 369          FORWARD (t);
 370        }
 371        return go_on;
 372      }
 373    default:
 374      {
 375        return A68_FALSE;
 376      }
 377    }
 378  }
 379  
 380  //! @brief Whether mode is PROC (REF FILE) VOID or FORMAT.
 381  
 382  BOOL_T is_proc_ref_file_void_or_format (MOID_T * p)
 383  {
 384    if (p == M_PROC_REF_FILE_VOID) {
 385      return A68_TRUE;
 386    } else if (p == M_FORMAT) {
 387      return A68_TRUE;
 388    } else {
 389      return A68_FALSE;
 390    }
 391  }
 392  
 393  //! @brief Whether mode can be transput.
 394  
 395  BOOL_T is_transput_mode (MOID_T * p, char rw)
 396  {
 397    if (p == M_INT) {
 398      return A68_TRUE;
 399    } else if (p == M_LONG_INT) {
 400      return A68_TRUE;
 401    } else if (p == M_LONG_LONG_INT) {
 402      return A68_TRUE;
 403    } else if (p == M_REAL) {
 404      return A68_TRUE;
 405    } else if (p == M_LONG_REAL) {
 406      return A68_TRUE;
 407    } else if (p == M_LONG_LONG_REAL) {
 408      return A68_TRUE;
 409    } else if (p == M_BOOL) {
 410      return A68_TRUE;
 411    } else if (p == M_CHAR) {
 412      return A68_TRUE;
 413    } else if (p == M_BITS) {
 414      return A68_TRUE;
 415    } else if (p == M_LONG_BITS) {
 416      return A68_TRUE;
 417    } else if (p == M_LONG_LONG_BITS) {
 418      return A68_TRUE;
 419    } else if (p == M_COMPLEX) {
 420      return A68_TRUE;
 421    } else if (p == M_LONG_COMPLEX) {
 422      return A68_TRUE;
 423    } else if (p == M_LONG_LONG_COMPLEX) {
 424      return A68_TRUE;
 425    } else if (p == M_ROW_CHAR) {
 426      return A68_TRUE;
 427    } else if (p == M_STRING) {
 428      return A68_TRUE;
 429    } else if (p == M_SOUND) {
 430      return A68_TRUE;
 431    } else if (IS (p, UNION_SYMBOL) || IS (p, STRUCT_SYMBOL)) {
 432      PACK_T *q = PACK (p);
 433      BOOL_T k = A68_TRUE;
 434      for (; q != NO_PACK && k; FORWARD (q)) {
 435        k = (BOOL_T) (k & (is_transput_mode (MOID (q), rw) || is_proc_ref_file_void_or_format (MOID (q))));
 436      }
 437      return k;
 438    } else if (IS_FLEX (p)) {
 439      if (SUB (p) == M_ROW_CHAR) {
 440        return A68_TRUE;
 441      } else {
 442        return (BOOL_T) (rw == 'w' ? is_transput_mode (SUB (p), rw) : A68_FALSE);
 443      }
 444    } else if (IS_ROW (p)) {
 445      return (BOOL_T) (is_transput_mode (SUB (p), rw) || is_proc_ref_file_void_or_format (SUB (p)));
 446    } else {
 447      return A68_FALSE;
 448    }
 449  }
 450  
 451  //! @brief Whether mode is printable.
 452  
 453  BOOL_T is_printable_mode (MOID_T * p)
 454  {
 455    if (is_proc_ref_file_void_or_format (p)) {
 456      return A68_TRUE;
 457    } else {
 458      return is_transput_mode (p, 'w');
 459    }
 460  }
 461  
 462  //! @brief Whether mode is readable.
 463  
 464  BOOL_T is_readable_mode (MOID_T * p)
 465  {
 466    if (is_proc_ref_file_void_or_format (p)) {
 467      return A68_TRUE;
 468    } else {
 469      return (BOOL_T) (IS_REF (p) ? is_transput_mode (SUB (p), 'r') : A68_FALSE);
 470    }
 471  }
 472  
 473  //! @brief Whether name struct.
 474  
 475  BOOL_T is_name_struct (MOID_T * p)
 476  {
 477    return (BOOL_T) (NAME (p) != NO_MOID ? IS (DEFLEX (SUB (p)), STRUCT_SYMBOL) : A68_FALSE);
 478  }
 479  
 480  //! @brief Yield mode to unite to.
 481  
 482  MOID_T *unites_to (MOID_T * m, MOID_T * u)
 483  {
 484  // Uniting U (m).
 485    MOID_T *v = NO_MOID;
 486    PACK_T *p;
 487    if (u == M_SIMPLIN || u == M_SIMPLOUT) {
 488      return m;
 489    }
 490    for (p = PACK (u); p != NO_PACK; FORWARD (p)) {
 491  // Prefer []->[] over []->FLEX [].
 492      if (m == MOID (p)) {
 493        v = MOID (p);
 494      } else if (v == NO_MOID && DEFLEX (m) == DEFLEX (MOID (p))) {
 495        v = MOID (p);
 496      }
 497    }
 498    return v;
 499  }
 500  
 501  //! @brief Whether moid in pack.
 502  
 503  BOOL_T is_moid_in_pack (MOID_T * u, PACK_T * v, int deflex)
 504  {
 505    for (; v != NO_PACK; FORWARD (v)) {
 506      if (is_equal_modes (u, MOID (v), deflex)) {
 507        return A68_TRUE;
 508      }
 509    }
 510    return A68_FALSE;
 511  }
 512  
 513  //! @brief Whether "p" is a subset of "q".
 514  
 515  BOOL_T is_subset (MOID_T * p, MOID_T * q, int deflex)
 516  {
 517    PACK_T *u = PACK (p);
 518    BOOL_T j = A68_TRUE;
 519    for (; u != NO_PACK && j; FORWARD (u)) {
 520      j = (BOOL_T) (j && is_moid_in_pack (MOID (u), PACK (q), deflex));
 521    }
 522    return j;
 523  }
 524  
 525  //! @brief Whether "p" can be united to UNION "q".
 526  
 527  BOOL_T is_unitable (MOID_T * p, MOID_T * q, int deflex)
 528  {
 529    if (IS (q, UNION_SYMBOL)) {
 530      if (IS (p, UNION_SYMBOL)) {
 531        return is_subset (p, q, deflex);
 532      } else {
 533        return is_moid_in_pack (p, PACK (q), deflex);
 534      }
 535    }
 536    return A68_FALSE;
 537  }
 538  
 539  //! @brief Whether all or some components of "u" can be firmly coerced to a component mode of "v"..
 540  
 541  void investigate_firm_relations (PACK_T * u, PACK_T * v, BOOL_T * all, BOOL_T * some)
 542  {
 543    *all = A68_TRUE;
 544    *some = A68_FALSE;
 545    for (; v != NO_PACK; FORWARD (v)) {
 546      PACK_T *w;
 547      BOOL_T k = A68_FALSE;
 548      for (w = u; w != NO_PACK; FORWARD (w)) {
 549        k |= is_coercible (MOID (w), MOID (v), FIRM, FORCE_DEFLEXING);
 550      }
 551      *some |= k;
 552      *all &= k;
 553    }
 554  }
 555  
 556  //! @brief Whether there is a soft path from "p" to "q".
 557  
 558  BOOL_T is_softly_coercible (MOID_T * p, MOID_T * q, int deflex)
 559  {
 560    if (is_equal_modes (p, q, deflex)) {
 561      return A68_TRUE;
 562    } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) {
 563      return is_softly_coercible (SUB (p), q, deflex);
 564    } else {
 565      return A68_FALSE;
 566    }
 567  }
 568  
 569  //! @brief Whether there is a weak path from "p" to "q".
 570  
 571  BOOL_T is_weakly_coercible (MOID_T * p, MOID_T * q, int deflex)
 572  {
 573    if (is_equal_modes (p, q, deflex)) {
 574      return A68_TRUE;
 575    } else if (is_deprefable (p)) {
 576      return is_weakly_coercible (depref_once (p), q, deflex);
 577    } else {
 578      return A68_FALSE;
 579    }
 580  }
 581  
 582  //! @brief Whether there is a meek path from "p" to "q".
 583  
 584  BOOL_T is_meekly_coercible (MOID_T * p, MOID_T * q, int deflex)
 585  {
 586    if (is_equal_modes (p, q, deflex)) {
 587      return A68_TRUE;
 588    } else if (is_deprefable (p)) {
 589      return is_meekly_coercible (depref_once (p), q, deflex);
 590    } else {
 591      return A68_FALSE;
 592    }
 593  }
 594  
 595  //! @brief Whether there is a firm path from "p" to "q".
 596  
 597  BOOL_T is_firmly_coercible (MOID_T * p, MOID_T * q, int deflex)
 598  {
 599    if (is_equal_modes (p, q, deflex)) {
 600      return A68_TRUE;
 601    } else if (q == M_ROWS && is_rows_type (p)) {
 602      return A68_TRUE;
 603    } else if (is_unitable (p, q, deflex)) {
 604      return A68_TRUE;
 605    } else if (is_deprefable (p)) {
 606      return is_firmly_coercible (depref_once (p), q, deflex);
 607    } else {
 608      return A68_FALSE;
 609    }
 610  }
 611  
 612  //! @brief Whether firm.
 613  
 614  BOOL_T is_firm (MOID_T * p, MOID_T * q)
 615  {
 616    return (BOOL_T) (is_firmly_coercible (p, q, SAFE_DEFLEXING) || is_firmly_coercible (q, p, SAFE_DEFLEXING));
 617  }
 618  
 619  //! @brief Whether "p" widens to "q".
 620  
 621  MOID_T *widens_to (MOID_T * p, MOID_T * q)
 622  {
 623    if (p == M_INT) {
 624      if (q == M_LONG_INT || q == M_LONG_LONG_INT || q == M_LONG_REAL || q == M_LONG_LONG_REAL || q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) {
 625        return M_LONG_INT;
 626      } else if (q == M_REAL || q == M_COMPLEX) {
 627        return M_REAL;
 628      } else {
 629        return NO_MOID;
 630      }
 631    } else if (p == M_LONG_INT) {
 632      if (q == M_LONG_LONG_INT) {
 633        return M_LONG_LONG_INT;
 634      } else if (q == M_LONG_REAL || q == M_LONG_LONG_REAL || q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) {
 635        return M_LONG_REAL;
 636      } else {
 637        return NO_MOID;
 638      }
 639    } else if (p == M_LONG_LONG_INT) {
 640      if (q == M_LONG_LONG_REAL || q == M_LONG_LONG_COMPLEX) {
 641        return M_LONG_LONG_REAL;
 642      } else {
 643        return NO_MOID;
 644      }
 645    } else if (p == M_REAL) {
 646      if (q == M_LONG_REAL || q == M_LONG_LONG_REAL || q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) {
 647        return M_LONG_REAL;
 648      } else if (q == M_COMPLEX) {
 649        return M_COMPLEX;
 650      } else {
 651        return NO_MOID;
 652      }
 653    } else if (p == M_COMPLEX) {
 654      if (q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) {
 655        return M_LONG_COMPLEX;
 656      } else {
 657        return NO_MOID;
 658      }
 659    } else if (p == M_LONG_REAL) {
 660      if (q == M_LONG_LONG_REAL || q == M_LONG_LONG_COMPLEX) {
 661        return M_LONG_LONG_REAL;
 662      } else if (q == M_LONG_COMPLEX) {
 663        return M_LONG_COMPLEX;
 664      } else {
 665        return NO_MOID;
 666      }
 667    } else if (p == M_LONG_COMPLEX) {
 668      if (q == M_LONG_LONG_COMPLEX) {
 669        return M_LONG_LONG_COMPLEX;
 670      } else {
 671        return NO_MOID;
 672      }
 673    } else if (p == M_LONG_LONG_REAL) {
 674      if (q == M_LONG_LONG_COMPLEX) {
 675        return M_LONG_LONG_COMPLEX;
 676      } else {
 677        return NO_MOID;
 678      }
 679    } else if (p == M_BITS) {
 680      if (q == M_LONG_BITS || q == M_LONG_LONG_BITS) {
 681        return M_LONG_BITS;
 682      } else if (q == M_ROW_BOOL) {
 683        return M_ROW_BOOL;
 684      } else if (q == M_FLEX_ROW_BOOL) {
 685        return M_FLEX_ROW_BOOL;
 686      } else {
 687        return NO_MOID;
 688      }
 689    } else if (p == M_LONG_BITS) {
 690      if (q == M_LONG_LONG_BITS) {
 691        return M_LONG_LONG_BITS;
 692      } else if (q == M_ROW_BOOL) {
 693        return M_ROW_BOOL;
 694      } else if (q == M_FLEX_ROW_BOOL) {
 695        return M_FLEX_ROW_BOOL;
 696      } else {
 697        return NO_MOID;
 698      }
 699    } else if (p == M_LONG_LONG_BITS) {
 700      if (q == M_ROW_BOOL) {
 701        return M_ROW_BOOL;
 702      } else if (q == M_FLEX_ROW_BOOL) {
 703        return M_FLEX_ROW_BOOL;
 704      } else {
 705        return NO_MOID;
 706      }
 707    } else if (p == M_BYTES && q == M_ROW_CHAR) {
 708      return M_ROW_CHAR;
 709    } else if (p == M_LONG_BYTES && q == M_ROW_CHAR) {
 710      return M_ROW_CHAR;
 711    } else if (p == M_BYTES && q == M_FLEX_ROW_CHAR) {
 712      return M_FLEX_ROW_CHAR;
 713    } else if (p == M_LONG_BYTES && q == M_FLEX_ROW_CHAR) {
 714      return M_FLEX_ROW_CHAR;
 715    } else {
 716      return NO_MOID;
 717    }
 718  }
 719  
 720  //! @brief Whether "p" widens to "q".
 721  
 722  BOOL_T is_widenable (MOID_T * p, MOID_T * q)
 723  {
 724    MOID_T *z = widens_to (p, q);
 725    if (z != NO_MOID) {
 726      return (BOOL_T) (z == q ? A68_TRUE : is_widenable (z, q));
 727    } else {
 728      return A68_FALSE;
 729    }
 730  }
 731  
 732  //! @brief Whether "p" is a REF ROW.
 733  
 734  BOOL_T is_ref_row (MOID_T * p)
 735  {
 736    return (BOOL_T) (NAME (p) != NO_MOID ? IS_ROW (DEFLEX (SUB (p))) : A68_FALSE);
 737  }
 738  
 739  //! @brief Whether strong name.
 740  
 741  BOOL_T is_strong_name (MOID_T * p, MOID_T * q)
 742  {
 743    if (p == q) {
 744      return A68_TRUE;
 745    } else if (is_ref_row (q)) {
 746      return is_strong_name (p, NAME (q));
 747    } else {
 748      return A68_FALSE;
 749    }
 750  }
 751  
 752  //! @brief Whether strong slice.
 753  
 754  BOOL_T is_strong_slice (MOID_T * p, MOID_T * q)
 755  {
 756    if (p == q || is_widenable (p, q)) {
 757      return A68_TRUE;
 758    } else if (SLICE (q) != NO_MOID) {
 759      return is_strong_slice (p, SLICE (q));
 760    } else if (IS_FLEX (q)) {
 761      return is_strong_slice (p, SUB (q));
 762    } else if (is_ref_row (q)) {
 763      return is_strong_name (p, q);
 764    } else {
 765      return A68_FALSE;
 766    }
 767  }
 768  
 769  //! @brief Whether strongly coercible.
 770  
 771  BOOL_T is_strongly_coercible (MOID_T * p, MOID_T * q, int deflex)
 772  {
 773  // Keep this sequence of statements.
 774    if (is_equal_modes (p, q, deflex)) {
 775      return A68_TRUE;
 776    } else if (q == M_VOID) {
 777      return A68_TRUE;
 778    } else if ((q == M_SIMPLIN || q == M_ROW_SIMPLIN) && is_readable_mode (p)) {
 779      return A68_TRUE;
 780    } else if (q == M_ROWS && is_rows_type (p)) {
 781      return A68_TRUE;
 782    } else if (is_unitable (p, derow (q), deflex)) {
 783      return A68_TRUE;
 784    }
 785    if (is_ref_row (q) && is_strong_name (p, q)) {
 786      return A68_TRUE;
 787    } else if (SLICE (q) != NO_MOID && is_strong_slice (p, q)) {
 788      return A68_TRUE;
 789    } else if (IS_FLEX (q) && is_strong_slice (p, q)) {
 790      return A68_TRUE;
 791    } else if (is_widenable (p, q)) {
 792      return A68_TRUE;
 793    } else if (is_deprefable (p)) {
 794      return is_strongly_coercible (depref_once (p), q, deflex);
 795    } else if (q == M_SIMPLOUT || q == M_ROW_SIMPLOUT) {
 796      return is_printable_mode (p);
 797    } else {
 798      return A68_FALSE;
 799    }
 800  }
 801  
 802  //! @brief Basic coercions.
 803  
 804  BOOL_T basic_coercions (MOID_T * p, MOID_T * q, int c, int deflex)
 805  {
 806    if (is_equal_modes (p, q, deflex)) {
 807      return A68_TRUE;
 808    } else if (c == NO_SORT) {
 809      return (BOOL_T) (p == q);
 810    } else if (c == SOFT) {
 811      return is_softly_coercible (p, q, deflex);
 812    } else if (c == WEAK) {
 813      return is_weakly_coercible (p, q, deflex);
 814    } else if (c == MEEK) {
 815      return is_meekly_coercible (p, q, deflex);
 816    } else if (c == FIRM) {
 817      return is_firmly_coercible (p, q, deflex);
 818    } else if (c == STRONG) {
 819      return is_strongly_coercible (p, q, deflex);
 820    } else {
 821      return A68_FALSE;
 822    }
 823  }
 824  
 825  //! @brief Whether coercible stowed.
 826  
 827  BOOL_T is_coercible_stowed (MOID_T * p, MOID_T * q, int c, int deflex)
 828  {
 829    if (c != STRONG) {
 830  // Such construct is always in a strong position, is it not?
 831      return A68_FALSE;
 832    } else if (q == M_VOID) {
 833      return A68_TRUE;
 834    } else if (IS_FLEX (q)) {
 835      PACK_T *u = PACK (p);
 836      BOOL_T j = A68_TRUE;
 837      for (; u != NO_PACK && j; FORWARD (u)) {
 838        j &= is_coercible (MOID (u), SLICE (SUB (q)), c, deflex);
 839      }
 840      return j;
 841    } else if (IS_ROW (q)) {
 842      PACK_T *u = PACK (p);
 843      BOOL_T j = A68_TRUE;
 844      for (; u != NO_PACK && j; FORWARD (u)) {
 845        j &= is_coercible (MOID (u), SLICE (q), c, deflex);
 846      }
 847      return j;
 848    } else if (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL)) {
 849      PACK_T *u = PACK (p), *v = PACK (q);
 850      if (DIM (p) != DIM (q)) {
 851        return A68_FALSE;
 852      } else {
 853        BOOL_T j = A68_TRUE;
 854        while (u != NO_PACK && v != NO_PACK && j) {
 855          j &= is_coercible (MOID (u), MOID (v), c, deflex);
 856          FORWARD (u);
 857          FORWARD (v);
 858          }
 859        return j;
 860      }
 861    } else {
 862      return A68_FALSE;
 863    }
 864  }
 865  
 866  //! @brief Whether coercible series.
 867  
 868  BOOL_T is_coercible_series (MOID_T * p, MOID_T * q, int c, int deflex)
 869  {
 870    if (c == NO_SORT) {
 871      return A68_FALSE;
 872    } else if (p == NO_MOID || q == NO_MOID) {
 873      return A68_FALSE;
 874    } else if (IS (p, SERIES_MODE) && PACK (p) == NO_PACK) {
 875      return A68_FALSE;
 876    } else if (IS (q, SERIES_MODE) && PACK (q) == NO_PACK) {
 877      return A68_FALSE;
 878    } else if (PACK (p) == NO_PACK) {
 879      return is_coercible (p, q, c, deflex);
 880    } else {
 881      PACK_T *u = PACK (p);
 882      BOOL_T j = A68_TRUE;
 883      for (; u != NO_PACK && j; FORWARD (u)) {
 884        if (MOID (u) != NO_MOID) {
 885          j &= is_coercible (MOID (u), q, c, deflex);
 886        }
 887      }
 888      return j;
 889    }
 890  }
 891  
 892  //! @brief Whether "p" can be coerced to "q" in a "c" context.
 893  
 894  BOOL_T is_coercible (MOID_T * p, MOID_T * q, int c, int deflex)
 895  {
 896    if (is_mode_isnt_well (p) || is_mode_isnt_well (q)) {
 897      return A68_TRUE;
 898    } else if (is_equal_modes (p, q, deflex)) {
 899      return A68_TRUE;
 900    } else if (p == M_HIP) {
 901      return A68_TRUE;
 902    } else if (IS (p, STOWED_MODE)) {
 903      return is_coercible_stowed (p, q, c, deflex);
 904    } else if (IS (p, SERIES_MODE)) {
 905      return is_coercible_series (p, q, c, deflex);
 906    } else if (p == M_VACUUM && IS_ROW (DEFLEX (q))) {
 907      return A68_TRUE;
 908    } else {
 909      return basic_coercions (p, q, c, deflex);
 910    }
 911  }
 912  
 913  //! @brief Whether coercible in context.
 914  
 915  BOOL_T is_coercible_in_context (SOID_T * p, SOID_T * q, int deflex)
 916  {
 917    if (SORT (p) != SORT (q)) {
 918      return A68_FALSE;
 919    } else if (MOID (p) == MOID (q)) {
 920      return A68_TRUE;
 921    } else {
 922      return is_coercible (MOID (p), MOID (q), SORT (q), deflex);
 923    }
 924  }
 925  
 926  //! @brief Whether list "y" is balanced.
 927  
 928  BOOL_T is_balanced (NODE_T * n, SOID_T * y, int sort)
 929  {
 930    if (sort == STRONG) {
 931      return A68_TRUE;
 932    } else {
 933      BOOL_T k = A68_FALSE;
 934      for (; y != NO_SOID && !k; FORWARD (y)) {
 935        k = (BOOL_T) (!IS (MOID (y), STOWED_MODE));
 936      }
 937      if (k == A68_FALSE) {
 938        diagnostic (A68_ERROR, n, ERROR_NO_UNIQUE_MODE);
 939      }
 940      return k;
 941    }
 942  }
 943  
 944  //! @brief A moid from "m" to which all other members can be coerced.
 945  
 946  MOID_T *get_balanced_mode (MOID_T * m, int sort, BOOL_T return_depreffed, int deflex)
 947  {
 948    MOID_T *common_moid = NO_MOID;
 949    if (m != NO_MOID && !is_mode_isnt_well (m) && IS (m, UNION_SYMBOL)) {
 950      int depref_level;
 951      BOOL_T go_on = A68_TRUE;
 952  // Test for increasing depreffing.
 953      for (depref_level = 0; go_on; depref_level++) {
 954        PACK_T *p;
 955        go_on = A68_FALSE;
 956  // Test the whole pack.
 957        for (p = PACK (m); p != NO_PACK; FORWARD (p)) {
 958  // HIPs are not eligible of course.
 959          if (MOID (p) != M_HIP) {
 960            MOID_T *candidate = MOID (p);
 961            int k;
 962  // Depref as far as allowed.
 963            for (k = depref_level; k > 0 && is_deprefable (candidate); k--) {
 964              candidate = depref_once (candidate);
 965            }
 966  // Only need testing if all allowed deprefs succeeded.
 967            if (k == 0) {
 968              PACK_T *q;
 969              MOID_T *to = (return_depreffed ? depref_completely (candidate) : candidate);
 970              BOOL_T all_coercible = A68_TRUE;
 971              go_on = A68_TRUE;
 972              for (q = PACK (m); q != NO_PACK && all_coercible; FORWARD (q)) {
 973                MOID_T *from = MOID (q);
 974                if (p != q && from != to) {
 975                  all_coercible &= is_coercible (from, to, sort, deflex);
 976                }
 977              }
 978  // If the pack is coercible to the candidate, we mark the candidate.
 979  // We continue searching for longest series of REF REF PROC REF.
 980              if (all_coercible) {
 981                MOID_T *mark = (return_depreffed ? MOID (p) : candidate);
 982                if (common_moid == NO_MOID) {
 983                  common_moid = mark;
 984                } else if (IS_FLEX (candidate) && DEFLEX (candidate) == common_moid) {
 985  // We prefer FLEX.
 986                  common_moid = mark;
 987                }
 988              }
 989            }
 990          }
 991        }                         // for
 992      }                           // for
 993    }
 994    return common_moid == NO_MOID ? m : common_moid;
 995  }
 996  
 997  //! @brief Whether we can search a common mode from a clause or not.
 998  
 999  BOOL_T clause_allows_balancing (int att)
1000  {
1001    switch (att) {
1002    case CLOSED_CLAUSE:
1003    case CONDITIONAL_CLAUSE:
1004    case CASE_CLAUSE:
1005    case SERIAL_CLAUSE:
1006    case CONFORMITY_CLAUSE:
1007      {
1008        return A68_TRUE;
1009      }
1010    }
1011    return A68_FALSE;
1012  }
1013  
1014  //! @brief A unique mode from "z".
1015  
1016  MOID_T *determine_unique_mode (SOID_T * z, int deflex)
1017  {
1018    if (z == NO_SOID) {
1019      return NO_MOID;
1020    } else {
1021      MOID_T *x = MOID (z);
1022      if (is_mode_isnt_well (x)) {
1023        return M_ERROR;
1024      }
1025      x = make_united_mode (x);
1026      if (clause_allows_balancing (ATTRIBUTE (z))) {
1027        return get_balanced_mode (x, STRONG, NO_DEPREF, deflex);
1028      } else {
1029        return x;
1030      }
1031    }
1032  }
1033  
1034  //! @brief Insert coercion "a" in the tree.
1035  
1036  void make_coercion (NODE_T * l, int a, MOID_T * m)
1037  {
1038    make_sub (l, l, a);
1039    MOID (l) = depref_rows (MOID (l), m);
1040  }
1041  
1042  //! @brief Make widening coercion.
1043  
1044  void make_widening_coercion (NODE_T * n, MOID_T * p, MOID_T * q)
1045  {
1046    MOID_T *z = widens_to (p, q);
1047    make_coercion (n, WIDENING, z);
1048    if (z != q) {
1049      make_widening_coercion (n, z, q);
1050    }
1051  }
1052  
1053  //! @brief Make ref rowing coercion.
1054  
1055  void make_ref_rowing_coercion (NODE_T * n, MOID_T * p, MOID_T * q)
1056  {
1057    if (DEFLEX (p) != DEFLEX (q)) {
1058      if (is_widenable (p, q)) {
1059        make_widening_coercion (n, p, q);
1060      } else if (is_ref_row (q)) {
1061        make_ref_rowing_coercion (n, p, NAME (q));
1062        make_coercion (n, ROWING, q);
1063      }
1064    }
1065  }
1066  
1067  //! @brief Make rowing coercion.
1068  
1069  void make_rowing_coercion (NODE_T * n, MOID_T * p, MOID_T * q)
1070  {
1071    if (DEFLEX (p) != DEFLEX (q)) {
1072      if (is_widenable (p, q)) {
1073        make_widening_coercion (n, p, q);
1074      } else if (SLICE (q) != NO_MOID) {
1075        make_rowing_coercion (n, p, SLICE (q));
1076        make_coercion (n, ROWING, q);
1077      } else if (IS_FLEX (q)) {
1078        make_rowing_coercion (n, p, SUB (q));
1079      } else if (is_ref_row (q)) {
1080        make_ref_rowing_coercion (n, p, q);
1081      }
1082    }
1083  }
1084  
1085  //! @brief Make uniting coercion.
1086  
1087  void make_uniting_coercion (NODE_T * n, MOID_T * q)
1088  {
1089    make_coercion (n, UNITING, derow (q));
1090    if (IS_ROW (q) || IS_FLEX (q)) {
1091      make_rowing_coercion (n, derow (q), q);
1092    }
1093  }
1094  
1095  //! @brief Make depreffing coercion.
1096  
1097  void make_depreffing_coercion (NODE_T * n, MOID_T * p, MOID_T * q)
1098  {
1099    if (DEFLEX (p) == DEFLEX (q)) {
1100      return;
1101    } else if (q == M_SIMPLOUT && is_printable_mode (p)) {
1102      make_coercion (n, UNITING, q);
1103    } else if (q == M_ROW_SIMPLOUT && is_printable_mode (p)) {
1104      make_coercion (n, UNITING, M_SIMPLOUT);
1105      make_coercion (n, ROWING, M_ROW_SIMPLOUT);
1106    } else if (q == M_SIMPLIN && is_readable_mode (p)) {
1107      make_coercion (n, UNITING, q);
1108    } else if (q == M_ROW_SIMPLIN && is_readable_mode (p)) {
1109      make_coercion (n, UNITING, M_SIMPLIN);
1110      make_coercion (n, ROWING, M_ROW_SIMPLIN);
1111    } else if (q == M_ROWS && is_rows_type (p)) {
1112      make_coercion (n, UNITING, M_ROWS);
1113      MOID (n) = M_ROWS;
1114    } else if (is_widenable (p, q)) {
1115      make_widening_coercion (n, p, q);
1116    } else if (is_unitable (p, derow (q), SAFE_DEFLEXING)) {
1117      make_uniting_coercion (n, q);
1118    } else if (is_ref_row (q) && is_strong_name (p, q)) {
1119      make_ref_rowing_coercion (n, p, q);
1120    } else if (SLICE (q) != NO_MOID && is_strong_slice (p, q)) {
1121      make_rowing_coercion (n, p, q);
1122    } else if (IS_FLEX (q) && is_strong_slice (p, q)) {
1123      make_rowing_coercion (n, p, q);
1124    } else if (IS_REF (p)) {
1125      MOID_T *r = depref_once (p);
1126      make_coercion (n, DEREFERENCING, r);
1127      make_depreffing_coercion (n, r, q);
1128    } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) {
1129      MOID_T *r = SUB (p);
1130      make_coercion (n, DEPROCEDURING, r);
1131      make_depreffing_coercion (n, r, q);
1132    } else if (p != q) {
1133      cannot_coerce (n, p, q, NO_SORT, SKIP_DEFLEXING, 0);
1134    }
1135  }
1136  
1137  //! @brief Whether p is a nonproc mode (that is voided directly).
1138  
1139  BOOL_T is_nonproc (MOID_T * p)
1140  {
1141    if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) {
1142      return A68_FALSE;
1143    } else if (IS_REF (p)) {
1144      return is_nonproc (SUB (p));
1145    } else {
1146      return A68_TRUE;
1147    }
1148  }
1149  
1150  //! @brief Make_void: voiden in an appropriate way.
1151  
1152  void make_void (NODE_T * p, MOID_T * q)
1153  {
1154    switch (ATTRIBUTE (p)) {
1155    case ASSIGNATION:
1156    case IDENTITY_RELATION:
1157    case GENERATOR:
1158    case CAST:
1159    case DENOTATION:
1160      {
1161        make_coercion (p, VOIDING, M_VOID);
1162        return;
1163      }
1164    }
1165  // MORFs are an involved case.
1166    switch (ATTRIBUTE (p)) {
1167    case SELECTION:
1168    case SLICE:
1169    case ROUTINE_TEXT:
1170    case FORMULA:
1171    case CALL:
1172    case IDENTIFIER:
1173      {
1174  // A nonproc moid value is eliminated directly.
1175        if (is_nonproc (q)) {
1176          make_coercion (p, VOIDING, M_VOID);
1177          return;
1178        } else {
1179  // Descend the chain of e.g. REF PROC .. until a nonproc moid remains.
1180          MOID_T *z = q;
1181          while (!is_nonproc (z)) {
1182            if (IS_REF (z)) {
1183              make_coercion (p, DEREFERENCING, SUB (z));
1184            }
1185            if (IS (z, PROC_SYMBOL) && NODE_PACK (p) == NO_PACK) {
1186              make_coercion (p, DEPROCEDURING, SUB (z));
1187            }
1188            z = SUB (z);
1189          }
1190          if (z != M_VOID) {
1191            make_coercion (p, VOIDING, M_VOID);
1192          }
1193          return;
1194        }
1195      }
1196    }
1197  // All other is voided straight away.
1198    make_coercion (p, VOIDING, M_VOID);
1199  }
1200  
1201  //! @brief Make strong coercion.
1202  
1203  void make_strong (NODE_T * n, MOID_T * p, MOID_T * q)
1204  {
1205    if (q == M_VOID && p != M_VOID) {
1206      make_void (n, p);
1207    } else {
1208      make_depreffing_coercion (n, p, q);
1209    }
1210  }
1211