parser-moids-coerce.c

     
   1  //! @file parser-moids-coerce.c
   2  //! @author J. Marcel van der Veer
   3  //!
   4  //! @section Copyright
   5  //!
   6  //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
   7  //! Copyright 2001-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
   8  //!
   9  //! @section License
  10  //!
  11  //! This program is free software; you can redistribute it and/or modify it 
  12  //! under the terms of the GNU General Public License as published by the 
  13  //! Free Software Foundation; either version 3 of the License, or 
  14  //! (at your option) any later version.
  15  //!
  16  //! This program is distributed in the hope that it will be useful, but 
  17  //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
  18  //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
  19  //! more details. You should have received a copy of the GNU General Public 
  20  //! License along with this program. If not, see [http://www.gnu.org/licenses/].
  21  
  22  //! @section Synopsis
  23  //!
  24  //! Mode coercion driver.
  25  
  26  #include "a68g.h"
  27  #include "a68g-parser.h"
  28  #include "a68g-prelude.h"
  29  #include "a68g-moids.h"
  30  
  31  //! @brief Coerce bounds.
  32  
  33  void coerce_bounds (NODE_T * p)
  34  {
  35    for (; p != NO_NODE; FORWARD (p)) {
  36      if (IS (p, UNIT)) {
  37        SOID_T q;
  38        make_soid (&q, MEEK, M_INT, 0);
  39        coerce_unit (p, &q);
  40      } else {
  41        coerce_bounds (SUB (p));
  42      }
  43    }
  44  }
  45  
  46  //! @brief Coerce declarer.
  47  
  48  void coerce_declarer (NODE_T * p)
  49  {
  50    for (; p != NO_NODE; FORWARD (p)) {
  51      if (IS (p, BOUNDS)) {
  52        coerce_bounds (SUB (p));
  53      } else {
  54        coerce_declarer (SUB (p));
  55      }
  56    }
  57  }
  58  
  59  //! @brief Coerce identity declaration.
  60  
  61  void coerce_identity_declaration (NODE_T * p)
  62  {
  63    if (p != NO_NODE) {
  64      switch (ATTRIBUTE (p)) {
  65      case DECLARER:
  66        {
  67          coerce_declarer (SUB (p));
  68          coerce_identity_declaration (NEXT (p));
  69          break;
  70        }
  71      case DEFINING_IDENTIFIER:
  72        {
  73          SOID_T q;
  74          make_soid (&q, STRONG, MOID (p), 0);
  75          coerce_unit (NEXT_NEXT (p), &q);
  76          break;
  77        }
  78      default:
  79        {
  80          coerce_identity_declaration (SUB (p));
  81          coerce_identity_declaration (NEXT (p));
  82          break;
  83        }
  84      }
  85    }
  86  }
  87  
  88  //! @brief Coerce variable declaration.
  89  
  90  void coerce_variable_declaration (NODE_T * p)
  91  {
  92    if (p != NO_NODE) {
  93      switch (ATTRIBUTE (p)) {
  94      case DECLARER:
  95        {
  96          coerce_declarer (SUB (p));
  97          coerce_variable_declaration (NEXT (p));
  98          break;
  99        }
 100      case DEFINING_IDENTIFIER:
 101        {
 102          if (whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) {
 103            SOID_T q;
 104            make_soid (&q, STRONG, SUB_MOID (p), 0);
 105            coerce_unit (NEXT_NEXT (p), &q);
 106            break;
 107          }
 108        }
 109      default:
 110        {
 111          coerce_variable_declaration (SUB (p));
 112          coerce_variable_declaration (NEXT (p));
 113          break;
 114        }
 115      }
 116    }
 117  }
 118  
 119  //! @brief Coerce routine text.
 120  
 121  void coerce_routine_text (NODE_T * p)
 122  {
 123    SOID_T w;
 124    if (IS (p, PARAMETER_PACK)) {
 125      FORWARD (p);
 126    }
 127    make_soid (&w, STRONG, MOID (p), 0);
 128    coerce_unit (NEXT_NEXT (p), &w);
 129  }
 130  
 131  //! @brief Coerce proc declaration.
 132  
 133  void coerce_proc_declaration (NODE_T * p)
 134  {
 135    if (p == NO_NODE) {
 136      return;
 137    } else if (IS (p, ROUTINE_TEXT)) {
 138      coerce_routine_text (SUB (p));
 139    } else {
 140      coerce_proc_declaration (SUB (p));
 141      coerce_proc_declaration (NEXT (p));
 142    }
 143  }
 144  
 145  //! @brief Coerce_op_declaration.
 146  
 147  void coerce_op_declaration (NODE_T * p)
 148  {
 149    if (p == NO_NODE) {
 150      return;
 151    } else if (IS (p, DEFINING_OPERATOR)) {
 152      SOID_T q;
 153      make_soid (&q, STRONG, MOID (p), 0);
 154      coerce_unit (NEXT_NEXT (p), &q);
 155    } else {
 156      coerce_op_declaration (SUB (p));
 157      coerce_op_declaration (NEXT (p));
 158    }
 159  }
 160  
 161  //! @brief Coerce brief op declaration.
 162  
 163  void coerce_brief_op_declaration (NODE_T * p)
 164  {
 165    if (p == NO_NODE) {
 166      return;
 167    } else if (IS (p, DEFINING_OPERATOR)) {
 168      coerce_routine_text (SUB (NEXT_NEXT (p)));
 169    } else {
 170      coerce_brief_op_declaration (SUB (p));
 171      coerce_brief_op_declaration (NEXT (p));
 172    }
 173  }
 174  
 175  //! @brief Coerce declaration list.
 176  
 177  void coerce_declaration_list (NODE_T * p)
 178  {
 179    if (p != NO_NODE) {
 180      switch (ATTRIBUTE (p)) {
 181      case IDENTITY_DECLARATION:
 182        {
 183          coerce_identity_declaration (SUB (p));
 184          break;
 185        }
 186      case VARIABLE_DECLARATION:
 187        {
 188          coerce_variable_declaration (SUB (p));
 189          break;
 190        }
 191      case MODE_DECLARATION:
 192        {
 193          coerce_declarer (SUB (p));
 194          break;
 195        }
 196      case PROCEDURE_DECLARATION:
 197      case PROCEDURE_VARIABLE_DECLARATION:
 198        {
 199          coerce_proc_declaration (SUB (p));
 200          break;
 201        }
 202      case BRIEF_OPERATOR_DECLARATION:
 203        {
 204          coerce_brief_op_declaration (SUB (p));
 205          break;
 206        }
 207      case OPERATOR_DECLARATION:
 208        {
 209          coerce_op_declaration (SUB (p));
 210          break;
 211        }
 212      default:
 213        {
 214          coerce_declaration_list (SUB (p));
 215          coerce_declaration_list (NEXT (p));
 216          break;
 217        }
 218      }
 219    }
 220  }
 221  
 222  //! @brief Coerce serial.
 223  
 224  void coerce_serial (NODE_T * p, SOID_T * q, BOOL_T k)
 225  {
 226    if (p == NO_NODE) {
 227      return;
 228    } else if (IS (p, INITIALISER_SERIES)) {
 229      coerce_serial (SUB (p), q, A68_FALSE);
 230      coerce_serial (NEXT (p), q, k);
 231    } else if (IS (p, DECLARATION_LIST)) {
 232      coerce_declaration_list (SUB (p));
 233    } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) {
 234      coerce_serial (NEXT (p), q, k);
 235    } else if (is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) {
 236      NODE_T *z = NEXT (p);
 237      if (z != NO_NODE) {
 238        if (IS (z, EXIT_SYMBOL) || IS (z, END_SYMBOL) || IS (z, CLOSE_SYMBOL) || IS (z, OCCA_SYMBOL)) {
 239          coerce_serial (SUB (p), q, A68_TRUE);
 240        } else {
 241          coerce_serial (SUB (p), q, A68_FALSE);
 242        }
 243      } else {
 244        coerce_serial (SUB (p), q, A68_TRUE);
 245      }
 246      coerce_serial (NEXT (p), q, k);
 247    } else if (IS (p, LABELED_UNIT)) {
 248      coerce_serial (SUB (p), q, k);
 249    } else if (IS (p, UNIT)) {
 250      if (k) {
 251        coerce_unit (p, q);
 252      } else {
 253        SOID_T strongvoid;
 254        make_soid (&strongvoid, STRONG, M_VOID, 0);
 255        coerce_unit (p, &strongvoid);
 256      }
 257    }
 258  }
 259  
 260  //! @brief Coerce closed.
 261  
 262  void coerce_closed (NODE_T * p, SOID_T * q)
 263  {
 264    if (IS (p, SERIAL_CLAUSE)) {
 265      coerce_serial (p, q, A68_TRUE);
 266    } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) {
 267      coerce_closed (NEXT (p), q);
 268    }
 269  }
 270  
 271  //! @brief Coerce conditional.
 272  
 273  void coerce_conditional (NODE_T * p, SOID_T * q)
 274  {
 275    SOID_T w;
 276    make_soid (&w, MEEK, M_BOOL, 0);
 277    coerce_serial (NEXT_SUB (p), &w, A68_TRUE);
 278    FORWARD (p);
 279    coerce_serial (NEXT_SUB (p), q, A68_TRUE);
 280    if ((FORWARD (p)) != NO_NODE) {
 281      if (is_one_of (p, ELSE_PART, CHOICE, STOP)) {
 282        coerce_serial (NEXT_SUB (p), q, A68_TRUE);
 283      } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
 284        coerce_conditional (SUB (p), q);
 285      }
 286    }
 287  }
 288  
 289  //! @brief Coerce unit list.
 290  
 291  void coerce_unit_list (NODE_T * p, SOID_T * q)
 292  {
 293    if (p == NO_NODE) {
 294      return;
 295    } else if (IS (p, UNIT_LIST)) {
 296      coerce_unit_list (SUB (p), q);
 297      coerce_unit_list (NEXT (p), q);
 298    } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP)) {
 299      coerce_unit_list (NEXT (p), q);
 300    } else if (IS (p, UNIT)) {
 301      coerce_unit (p, q);
 302      coerce_unit_list (NEXT (p), q);
 303    }
 304  }
 305  
 306  //! @brief Coerce int case.
 307  
 308  void coerce_int_case (NODE_T * p, SOID_T * q)
 309  {
 310    SOID_T w;
 311    make_soid (&w, MEEK, M_INT, 0);
 312    coerce_serial (NEXT_SUB (p), &w, A68_TRUE);
 313    FORWARD (p);
 314    coerce_unit_list (NEXT_SUB (p), q);
 315    if ((FORWARD (p)) != NO_NODE) {
 316      if (is_one_of (p, OUT_PART, CHOICE, STOP)) {
 317        coerce_serial (NEXT_SUB (p), q, A68_TRUE);
 318      } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) {
 319        coerce_int_case (SUB (p), q);
 320      }
 321    }
 322  }
 323  
 324  //! @brief Coerce spec unit list.
 325  
 326  void coerce_spec_unit_list (NODE_T * p, SOID_T * q)
 327  {
 328    for (; p != NO_NODE; FORWARD (p)) {
 329      if (is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) {
 330        coerce_spec_unit_list (SUB (p), q);
 331      } else if (IS (p, UNIT)) {
 332        coerce_unit (p, q);
 333      }
 334    }
 335  }
 336  
 337  //! @brief Coerce united case.
 338  
 339  void coerce_united_case (NODE_T * p, SOID_T * q)
 340  {
 341    SOID_T w;
 342    make_soid (&w, MEEK, MOID (SUB (p)), 0);
 343    coerce_serial (NEXT_SUB (p), &w, A68_TRUE);
 344    FORWARD (p);
 345    coerce_spec_unit_list (NEXT_SUB (p), q);
 346    if ((FORWARD (p)) != NO_NODE) {
 347      if (is_one_of (p, OUT_PART, CHOICE, STOP)) {
 348        coerce_serial (NEXT_SUB (p), q, A68_TRUE);
 349      } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) {
 350        coerce_united_case (SUB (p), q);
 351      }
 352    }
 353  }
 354  
 355  //! @brief Coerce loop.
 356  
 357  void coerce_loop (NODE_T * p)
 358  {
 359    if (IS (p, FOR_PART)) {
 360      coerce_loop (NEXT (p));
 361    } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) {
 362      SOID_T w;
 363      make_soid (&w, MEEK, M_INT, 0);
 364      coerce_unit (NEXT_SUB (p), &w);
 365      coerce_loop (NEXT (p));
 366    } else if (IS (p, WHILE_PART)) {
 367      SOID_T w;
 368      make_soid (&w, MEEK, M_BOOL, 0);
 369      coerce_serial (NEXT_SUB (p), &w, A68_TRUE);
 370      coerce_loop (NEXT (p));
 371    } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) {
 372      SOID_T w;
 373      NODE_T *do_p = NEXT_SUB (p), *un_p;
 374      make_soid (&w, STRONG, M_VOID, 0);
 375      coerce_serial (do_p, &w, A68_TRUE);
 376      if (IS (do_p, SERIAL_CLAUSE)) {
 377        un_p = NEXT (do_p);
 378      } else {
 379        un_p = do_p;
 380      }
 381      if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) {
 382        SOID_T sw;
 383        make_soid (&sw, MEEK, M_BOOL, 0);
 384        coerce_serial (NEXT_SUB (un_p), &sw, A68_TRUE);
 385      }
 386    }
 387  }
 388  
 389  //! @brief Coerce struct display.
 390  
 391  void coerce_struct_display (PACK_T ** r, NODE_T * p)
 392  {
 393    if (p == NO_NODE) {
 394      return;
 395    } else if (IS (p, UNIT_LIST)) {
 396      coerce_struct_display (r, SUB (p));
 397      coerce_struct_display (r, NEXT (p));
 398    } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP)) {
 399      coerce_struct_display (r, NEXT (p));
 400    } else if (IS (p, UNIT)) {
 401      SOID_T s;
 402      make_soid (&s, STRONG, MOID (*r), 0);
 403      coerce_unit (p, &s);
 404      FORWARD (*r);
 405      coerce_struct_display (r, NEXT (p));
 406    }
 407  }
 408  
 409  //! @brief Coerce collateral.
 410  
 411  void coerce_collateral (NODE_T * p, SOID_T * q)
 412  {
 413    if (!(whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))) {
 414      if (IS (MOID (q), STRUCT_SYMBOL)) {
 415        PACK_T *t = PACK (MOID (q));
 416        coerce_struct_display (&t, p);
 417      } else if (IS_FLEX (MOID (q))) {
 418        SOID_T w;
 419        make_soid (&w, STRONG, SLICE (SUB_MOID (q)), 0);
 420        coerce_unit_list (p, &w);
 421      } else if (IS_ROW (MOID (q))) {
 422        SOID_T w;
 423        make_soid (&w, STRONG, SLICE (MOID (q)), 0);
 424        coerce_unit_list (p, &w);
 425      } else {
 426  // if (MOID (q) != M_VOID).
 427        coerce_unit_list (p, q);
 428      }
 429    }
 430  }
 431  
 432  //! @brief Coerce_enclosed.
 433  
 434  void coerce_enclosed (NODE_T * p, SOID_T * q)
 435  {
 436    if (IS (p, ENCLOSED_CLAUSE)) {
 437      coerce_enclosed (SUB (p), q);
 438    } else if (IS (p, CLOSED_CLAUSE)) {
 439      coerce_closed (SUB (p), q);
 440    } else if (IS (p, COLLATERAL_CLAUSE)) {
 441      coerce_collateral (SUB (p), q);
 442    } else if (IS (p, PARALLEL_CLAUSE)) {
 443      coerce_collateral (SUB (NEXT_SUB (p)), q);
 444    } else if (IS (p, CONDITIONAL_CLAUSE)) {
 445      coerce_conditional (SUB (p), q);
 446    } else if (IS (p, CASE_CLAUSE)) {
 447      coerce_int_case (SUB (p), q);
 448    } else if (IS (p, CONFORMITY_CLAUSE)) {
 449      coerce_united_case (SUB (p), q);
 450    } else if (IS (p, LOOP_CLAUSE)) {
 451      coerce_loop (SUB (p));
 452    }
 453    MOID (p) = depref_rows (MOID (p), MOID (q));
 454  }
 455  
 456  //! @brief Get monad moid.
 457  
 458  MOID_T *get_monad_moid (NODE_T * p)
 459  {
 460    if (TAX (p) != NO_TAG && TAX (p) != A68_PARSER (error_tag)) {
 461      MOID (p) = MOID (TAX (p));
 462      return MOID (PACK (MOID (p)));
 463    } else {
 464      return M_ERROR;
 465    }
 466  }
 467  
 468  //! @brief Coerce monad oper.
 469  
 470  void coerce_monad_oper (NODE_T * p, SOID_T * q)
 471  {
 472    if (p != NO_NODE) {
 473      SOID_T z;
 474      make_soid (&z, FIRM, MOID (PACK (MOID (TAX (p)))), 0);
 475      INSERT_COERCIONS (NEXT (p), MOID (q), &z);
 476    }
 477  }
 478  
 479  //! @brief Coerce monad formula.
 480  
 481  void coerce_monad_formula (NODE_T * p)
 482  {
 483    SOID_T e;
 484    make_soid (&e, STRONG, get_monad_moid (p), 0);
 485    coerce_operand (NEXT (p), &e);
 486    coerce_monad_oper (p, &e);
 487  }
 488  
 489  //! @brief Coerce operand.
 490  
 491  void coerce_operand (NODE_T * p, SOID_T * q)
 492  {
 493    if (IS (p, MONADIC_FORMULA)) {
 494      coerce_monad_formula (SUB (p));
 495      if (MOID (p) != MOID (q)) {
 496        make_sub (p, p, FORMULA);
 497        INSERT_COERCIONS (p, MOID (p), q);
 498        make_sub (p, p, TERTIARY);
 499      }
 500      MOID (p) = depref_rows (MOID (p), MOID (q));
 501    } else if (IS (p, FORMULA)) {
 502      coerce_formula (SUB (p), q);
 503      INSERT_COERCIONS (p, MOID (p), q);
 504      MOID (p) = depref_rows (MOID (p), MOID (q));
 505    } else if (IS (p, SECONDARY)) {
 506      coerce_unit (SUB (p), q);
 507      MOID (p) = MOID (SUB (p));
 508    }
 509  }
 510  
 511  //! @brief Coerce formula.
 512  
 513  void coerce_formula (NODE_T * p, SOID_T * q)
 514  {
 515    (void) q;
 516    if (IS (p, MONADIC_FORMULA) && NEXT (p) == NO_NODE) {
 517      coerce_monad_formula (SUB (p));
 518    } else {
 519      if (TAX (NEXT (p)) != NO_TAG && TAX (NEXT (p)) != A68_PARSER (error_tag)) {
 520        SOID_T s;
 521        NODE_T *op = NEXT (p), *nq = NEXT_NEXT (p);
 522        MOID_T *w = MOID (op);
 523        MOID_T *u = MOID (PACK (w)), *v = MOID (NEXT (PACK (w)));
 524        make_soid (&s, STRONG, u, 0);
 525        coerce_operand (p, &s);
 526        make_soid (&s, STRONG, v, 0);
 527        coerce_operand (nq, &s);
 528      }
 529    }
 530  }
 531  
 532  //! @brief Coerce assignation.
 533  
 534  void coerce_assignation (NODE_T * p)
 535  {
 536    SOID_T w;
 537    make_soid (&w, SOFT, MOID (p), 0);
 538    coerce_unit (SUB (p), &w);
 539    make_soid (&w, STRONG, SUB_MOID (p), 0);
 540    coerce_unit (NEXT_NEXT (p), &w);
 541  }
 542  
 543  //! @brief Coerce relation.
 544  
 545  void coerce_relation (NODE_T * p)
 546  {
 547    SOID_T w;
 548    make_soid (&w, STRONG, MOID (p), 0);
 549    coerce_unit (SUB (p), &w);
 550    make_soid (&w, STRONG, MOID (NEXT_NEXT (p)), 0);
 551    coerce_unit (SUB (NEXT_NEXT (p)), &w);
 552  }
 553  
 554  //! @brief Coerce bool function.
 555  
 556  void coerce_bool_function (NODE_T * p)
 557  {
 558    SOID_T w;
 559    make_soid (&w, STRONG, M_BOOL, 0);
 560    coerce_unit (SUB (p), &w);
 561    coerce_unit (SUB (NEXT_NEXT (p)), &w);
 562  }
 563  
 564  //! @brief Coerce assertion.
 565  
 566  void coerce_assertion (NODE_T * p)
 567  {
 568    SOID_T w;
 569    make_soid (&w, MEEK, M_BOOL, 0);
 570    coerce_enclosed (SUB_NEXT (p), &w);
 571  }
 572  
 573  //! @brief Coerce selection.
 574  
 575  void coerce_selection (NODE_T * p)
 576  {
 577    SOID_T w;
 578    make_soid (&w, STRONG, MOID (NEXT (p)), 0);
 579    coerce_unit (SUB_NEXT (p), &w);
 580  }
 581  
 582  //! @brief Coerce cast.
 583  
 584  void coerce_cast (NODE_T * p)
 585  {
 586    SOID_T w;
 587    coerce_declarer (p);
 588    make_soid (&w, STRONG, MOID (p), 0);
 589    coerce_enclosed (NEXT (p), &w);
 590  }
 591  
 592  //! @brief Coerce argument list.
 593  
 594  void coerce_argument_list (PACK_T ** r, NODE_T * p)
 595  {
 596    for (; p != NO_NODE; FORWARD (p)) {
 597      if (IS (p, ARGUMENT_LIST)) {
 598        coerce_argument_list (r, SUB (p));
 599      } else if (IS (p, UNIT)) {
 600        SOID_T s;
 601        make_soid (&s, STRONG, MOID (*r), 0);
 602        coerce_unit (p, &s);
 603        FORWARD (*r);
 604      } else if (IS (p, TRIMMER)) {
 605        FORWARD (*r);
 606      }
 607    }
 608  }
 609  
 610  //! @brief Coerce call.
 611  
 612  void coerce_call (NODE_T * p)
 613  {
 614    MOID_T *proc = MOID (p);
 615    SOID_T w;
 616    PACK_T *t;
 617    make_soid (&w, MEEK, proc, 0);
 618    coerce_unit (SUB (p), &w);
 619    FORWARD (p);
 620    t = PACK (proc);
 621    coerce_argument_list (&t, SUB (p));
 622  }
 623  
 624  //! @brief Coerce meek int.
 625  
 626  void coerce_meek_int (NODE_T * p)
 627  {
 628    SOID_T x;
 629    make_soid (&x, MEEK, M_INT, 0);
 630    coerce_unit (p, &x);
 631  }
 632  
 633  //! @brief Coerce trimmer.
 634  
 635  void coerce_trimmer (NODE_T * p)
 636  {
 637    if (p != NO_NODE) {
 638      if (IS (p, UNIT)) {
 639        coerce_meek_int (p);
 640        coerce_trimmer (NEXT (p));
 641      } else {
 642        coerce_trimmer (NEXT (p));
 643      }
 644    }
 645  }
 646  
 647  //! @brief Coerce indexer.
 648  
 649  void coerce_indexer (NODE_T * p)
 650  {
 651    if (p != NO_NODE) {
 652      if (IS (p, TRIMMER)) {
 653        coerce_trimmer (SUB (p));
 654      } else if (IS (p, UNIT)) {
 655        coerce_meek_int (p);
 656      } else {
 657        coerce_indexer (SUB (p));
 658        coerce_indexer (NEXT (p));
 659      }
 660    }
 661  }
 662  
 663  //! @brief Coerce_slice.
 664  
 665  void coerce_slice (NODE_T * p)
 666  {
 667    SOID_T w;
 668    MOID_T *row;
 669    row = MOID (p);
 670    make_soid (&w, STRONG, row, 0);
 671    coerce_unit (SUB (p), &w);
 672    coerce_indexer (SUB_NEXT (p));
 673  }
 674  
 675  //! @brief Mode coerce diagonal.
 676  
 677  void coerce_diagonal (NODE_T * p)
 678  {
 679    SOID_T w;
 680    if (IS (p, TERTIARY)) {
 681      make_soid (&w, MEEK, M_INT, 0);
 682      coerce_unit (SUB (p), &w);
 683      FORWARD (p);
 684    }
 685    make_soid (&w, STRONG, MOID (NEXT (p)), 0);
 686    coerce_unit (SUB_NEXT (p), &w);
 687  }
 688  
 689  //! @brief Mode coerce transpose.
 690  
 691  void coerce_transpose (NODE_T * p)
 692  {
 693    SOID_T w;
 694    make_soid (&w, STRONG, MOID (NEXT (p)), 0);
 695    coerce_unit (SUB_NEXT (p), &w);
 696  }
 697  
 698  //! @brief Mode coerce row or column function.
 699  
 700  void coerce_row_column_function (NODE_T * p)
 701  {
 702    SOID_T w;
 703    if (IS (p, TERTIARY)) {
 704      make_soid (&w, MEEK, M_INT, 0);
 705      coerce_unit (SUB (p), &w);
 706      FORWARD (p);
 707    }
 708    make_soid (&w, STRONG, MOID (NEXT (p)), 0);
 709    coerce_unit (SUB_NEXT (p), &w);
 710  }
 711  
 712  //! @brief Coerce format text.
 713  
 714  void coerce_format_text (NODE_T * p)
 715  {
 716    for (; p != NO_NODE; FORWARD (p)) {
 717      coerce_format_text (SUB (p));
 718      if (IS (p, FORMAT_PATTERN)) {
 719        SOID_T x;
 720        make_soid (&x, STRONG, M_FORMAT, 0);
 721        coerce_enclosed (SUB (NEXT_SUB (p)), &x);
 722      } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
 723        SOID_T x;
 724        make_soid (&x, STRONG, M_ROW_INT, 0);
 725        coerce_enclosed (SUB (NEXT_SUB (p)), &x);
 726      } else if (IS (p, DYNAMIC_REPLICATOR)) {
 727        SOID_T x;
 728        make_soid (&x, STRONG, M_INT, 0);
 729        coerce_enclosed (SUB (NEXT_SUB (p)), &x);
 730      }
 731    }
 732  }
 733  
 734  //! @brief Coerce unit.
 735  
 736  void coerce_unit (NODE_T * p, SOID_T * q)
 737  {
 738    if (p == NO_NODE) {
 739      return;
 740    } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) {
 741      coerce_unit (SUB (p), q);
 742      MOID (p) = MOID (SUB (p));
 743  // Ex primary.
 744    } else if (IS (p, CALL)) {
 745      coerce_call (SUB (p));
 746      INSERT_COERCIONS (p, MOID (p), q);
 747    } else if (IS (p, SLICE)) {
 748      coerce_slice (SUB (p));
 749      INSERT_COERCIONS (p, MOID (p), q);
 750    } else if (IS (p, CAST)) {
 751      coerce_cast (SUB (p));
 752      INSERT_COERCIONS (p, MOID (p), q);
 753    } else if (is_one_of (p, DENOTATION, IDENTIFIER, STOP)) {
 754      INSERT_COERCIONS (p, MOID (p), q);
 755    } else if (IS (p, FORMAT_TEXT)) {
 756      coerce_format_text (SUB (p));
 757      INSERT_COERCIONS (p, MOID (p), q);
 758    } else if (IS (p, ENCLOSED_CLAUSE)) {
 759      coerce_enclosed (p, q);
 760  // Ex secondary.
 761    } else if (IS (p, SELECTION)) {
 762      coerce_selection (SUB (p));
 763      INSERT_COERCIONS (p, MOID (p), q);
 764    } else if (IS (p, GENERATOR)) {
 765      coerce_declarer (SUB (p));
 766      INSERT_COERCIONS (p, MOID (p), q);
 767  // Ex tertiary.
 768    } else if (IS (p, NIHIL)) {
 769      if (ATTRIBUTE (MOID (q)) != REF_SYMBOL && MOID (q) != M_VOID) {
 770        diagnostic (A68_ERROR, p, ERROR_NO_NAME_REQUIRED);
 771      }
 772      MOID (p) = depref_rows (MOID (p), MOID (q));
 773    } else if (IS (p, FORMULA)) {
 774      coerce_formula (SUB (p), q);
 775      INSERT_COERCIONS (p, MOID (p), q);
 776    } else if (IS (p, DIAGONAL_FUNCTION)) {
 777      coerce_diagonal (SUB (p));
 778      INSERT_COERCIONS (p, MOID (p), q);
 779    } else if (IS (p, TRANSPOSE_FUNCTION)) {
 780      coerce_transpose (SUB (p));
 781      INSERT_COERCIONS (p, MOID (p), q);
 782    } else if (IS (p, ROW_FUNCTION)) {
 783      coerce_row_column_function (SUB (p));
 784      INSERT_COERCIONS (p, MOID (p), q);
 785    } else if (IS (p, COLUMN_FUNCTION)) {
 786      coerce_row_column_function (SUB (p));
 787      INSERT_COERCIONS (p, MOID (p), q);
 788  // Ex unit.
 789    } else if (IS (p, JUMP)) {
 790      if (MOID (q) == M_PROC_VOID) {
 791        make_sub (p, p, PROCEDURING);
 792      }
 793      MOID (p) = depref_rows (MOID (p), MOID (q));
 794    } else if (IS (p, SKIP)) {
 795      MOID (p) = depref_rows (MOID (p), MOID (q));
 796    } else if (IS (p, ASSIGNATION)) {
 797      coerce_assignation (SUB (p));
 798      INSERT_COERCIONS (p, MOID (p), q);
 799      MOID (p) = depref_rows (MOID (p), MOID (q));
 800    } else if (IS (p, IDENTITY_RELATION)) {
 801      coerce_relation (SUB (p));
 802      INSERT_COERCIONS (p, MOID (p), q);
 803    } else if (IS (p, ROUTINE_TEXT)) {
 804      coerce_routine_text (SUB (p));
 805      INSERT_COERCIONS (p, MOID (p), q);
 806    } else if (is_one_of (p, AND_FUNCTION, OR_FUNCTION, STOP)) {
 807      coerce_bool_function (SUB (p));
 808      INSERT_COERCIONS (p, MOID (p), q);
 809    } else if (IS (p, ASSERTION)) {
 810      coerce_assertion (SUB (p));
 811      INSERT_COERCIONS (p, MOID (p), q);
 812    }
 813  }
 814  
 815  //! @brief Widen denotation depending on mode required, this is an extension to A68.
 816  
 817  void widen_denotation (NODE_T * p)
 818  {
 819  #define WIDEN {\
 820    *q = *(SUB (q));\
 821    ATTRIBUTE (q) = DENOTATION;\
 822    MOID (q) = lm;\
 823    STATUS_SET (q, OPTIMAL_MASK);\
 824    }
 825  #define WARN_WIDENING\
 826    if (OPTION_PORTCHECK (&A68_JOB) && !(STATUS_TEST (SUB (q), OPTIMAL_MASK))) {\
 827      diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, q, WARNING_WIDENING_NOT_PORTABLE);\
 828    }
 829    NODE_T *q;
 830    for (q = p; q != NO_NODE; FORWARD (q)) {
 831      widen_denotation (SUB (q));
 832      if (IS (q, WIDENING) && IS (SUB (q), DENOTATION)) {
 833        MOID_T *lm = MOID (q), *m = MOID (SUB (q));
 834        if (lm == M_LONG_LONG_INT && m == M_LONG_INT) {
 835          WARN_WIDENING;
 836          WIDEN;
 837        }
 838        if (lm == M_LONG_INT && m == M_INT) {
 839          WARN_WIDENING;
 840          WIDEN;
 841        }
 842        if (lm == M_LONG_LONG_REAL && m == M_LONG_REAL) {
 843          WARN_WIDENING;
 844          WIDEN;
 845        }
 846        if (lm == M_LONG_REAL && m == M_REAL) {
 847          WARN_WIDENING;
 848          WIDEN;
 849        }
 850        if (lm == M_LONG_REAL && m == M_LONG_INT) {
 851          WIDEN;
 852        }
 853        if (lm == M_REAL && m == M_INT) {
 854          WIDEN;
 855        }
 856        if (lm == M_LONG_LONG_BITS && m == M_LONG_BITS) {
 857          WARN_WIDENING;
 858          WIDEN;
 859        }
 860        if (lm == M_LONG_BITS && m == M_BITS) {
 861          WARN_WIDENING;
 862          WIDEN;
 863        }
 864        return;
 865      }
 866    }
 867  #undef WIDEN
 868  #undef WARN_WIDENING
 869  }
 870  
 871  //! @brief Driver for coercion inserions.
 872  
 873  void coercion_inserter (NODE_T * p)
 874  {
 875    if (IS (p, PARTICULAR_PROGRAM)) {
 876      SOID_T q;
 877      make_soid (&q, STRONG, M_VOID, 0);
 878      coerce_enclosed (SUB (p), &q);
 879    }
 880  }
 881