--- /dev/null
+/* MOID diagnostics routines.
+ Copyright (C) 2001-2023 J. Marcel van der Veer.
+ Copyright (C) 2025 Jose E. Marchesi.
+
+ Original implementation by J. Marcel van der Veer.
+ Adapted for GCC by Jose E. Marchesi.
+
+ GCC is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ GCC is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING3. If not see
+ <http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+/* Give accurate error message. */
+
+const char *
+a68_mode_error_text (NODE_T *n, MOID_T *p, MOID_T *q, int context, int deflex, int depth)
+{
+#define TAIL(z) (&(z)[strlen (z)])
+#define ACTUAL_SNPRINTF_SIZE ((SNPRINTF_SIZE - len))
+ static BUFFER txt;
+ size_t len;
+ if (depth == 1)
+ txt[0] = '\0';
+ if (IS (p, SERIES_MODE))
+ {
+ len = strlen (txt);
+ PACK_T *u = PACK (p);
+
+ int N = 0;
+ if (u == NO_PACK)
+ {
+ if (snprintf (txt, ACTUAL_SNPRINTF_SIZE, "empty mode-list") < 0)
+ gcc_unreachable ();
+ N++;
+ }
+ else
+ {
+ for (; u != NO_PACK; FORWARD (u))
+ {
+ if (MOID (u) != NO_MOID)
+ {
+ if (IS (MOID (u), SERIES_MODE))
+ (void) a68_mode_error_text (n, MOID (u), q, context, deflex, depth + 1);
+ else if (!a68_is_coercible (MOID (u), q, context, deflex))
+ {
+ len = strlen (txt);
+ if (len > BUFFER_SIZE / 2)
+ {
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " etcetera") < 0)
+ gcc_unreachable ();
+ N++;
+ }
+ else
+ {
+ if (len > 0)
+ {
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " and ") < 0)
+ gcc_unreachable ();
+ N++;
+ len = strlen (txt);
+ }
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%%<%s%%>",
+ a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) < 0)
+ gcc_unreachable ();
+ N++;
+ }
+ }
+ }
+ }
+ }
+ if (depth == 1)
+ {
+ len = strlen (txt);
+ if (N == 0)
+ {
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "mode") < 0)
+ gcc_unreachable ();
+ len = strlen (txt);
+ }
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " cannot be coerced to %%<%s%%>",
+ a68_moid_to_string (q, MOID_ERROR_WIDTH, n)) < 0)
+ gcc_unreachable ();
+ }
+ }
+ else if (IS (p, STOWED_MODE) && IS_FLEX (q))
+ {
+ PACK_T *u = PACK (p);
+ len = strlen (txt);
+ if (u == NO_PACK)
+ {
+ if (snprintf (txt, ACTUAL_SNPRINTF_SIZE, "empty mode-list") < 0)
+ gcc_unreachable ();
+ }
+ else
+ {
+ for (; u != NO_PACK; FORWARD (u))
+ {
+ if (!a68_is_coercible (MOID (u), SLICE (SUB (q)), context, deflex))
+ {
+ len = strlen (txt);
+ if (len > BUFFER_SIZE / 2)
+ {
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " etcetera") < 0)
+ gcc_unreachable ();
+ }
+ else
+ {
+ if (len > 0)
+ {
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " and ") < 0)
+ gcc_unreachable ();
+ len = strlen (txt);
+ }
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%s",
+ a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) < 0)
+ gcc_unreachable ();
+ }
+ }
+ }
+ len = strlen (txt);
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " cannot be coerced to %%<%s%%>",
+ a68_moid_to_string (SLICE (SUB (q)), MOID_ERROR_WIDTH, n)) < 0)
+ gcc_unreachable ();
+ }
+ }
+ else if (IS (p, STOWED_MODE) && IS (q, ROW_SYMBOL))
+ {
+ PACK_T *u = PACK (p);
+ len = strlen (txt);
+ if (u == NO_PACK)
+ {
+ if (snprintf (txt, ACTUAL_SNPRINTF_SIZE, "empty mode-list") < 0)
+ gcc_unreachable ();
+ }
+ else
+ {
+ for (; u != NO_PACK; FORWARD (u))
+ {
+ if (!a68_is_coercible (MOID (u), SLICE (q), context, deflex))
+ {
+ len = strlen (txt);
+ if (len > BUFFER_SIZE / 2)
+ {
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " etcetera") < 0)
+ gcc_unreachable ();
+ }
+ else
+ {
+ if (len > 0)
+ {
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " and ") < 0)
+ gcc_unreachable ();
+ len = strlen (txt);
+ }
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%%<%s%%>",
+ a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) < 0)
+ gcc_unreachable ();
+ }
+ }
+ }
+ len = strlen (txt);
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " cannot be coerced to %s",
+ a68_moid_to_string (SLICE (q), MOID_ERROR_WIDTH, n)) < 0)
+ gcc_unreachable ();
+ }
+ }
+ else if (IS (p, STOWED_MODE) && (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL)))
+ {
+ PACK_T *u = PACK (p), *v = PACK (q);
+ len = strlen (txt);
+ if (u == NO_PACK)
+ {
+ if (snprintf (txt, ACTUAL_SNPRINTF_SIZE, "empty mode-list") < 0)
+ gcc_unreachable ();
+ }
+ else
+ {
+ for (; u != NO_PACK && v != NO_PACK; FORWARD (u), FORWARD (v))
+ {
+ if (!a68_is_coercible (MOID (u), MOID (v), context, deflex))
+ {
+ len = strlen (txt);
+ if (len > BUFFER_SIZE / 2)
+ {
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " etcetera") < 0)
+ gcc_unreachable ();
+ }
+ else
+ {
+ if (len > 0)
+ {
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " and ") < 0)
+ gcc_unreachable ();
+ len = strlen (txt);
+ }
+ if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%%<%s%%> cannot be coerced to %%<%s%%>",
+ a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n),
+ a68_moid_to_string (MOID (v), MOID_ERROR_WIDTH, n)) < 0)
+ gcc_unreachable ();
+ }
+ }
+ }
+ }
+ }
+ return txt;
+#undef TAIL
+#undef ACTUAL_SNPRINTF_SIZE
+}
+
+/* Cannot coerce error. */
+
+void
+a68_cannot_coerce (NODE_T *p, MOID_T *from, MOID_T *to, int context, int deflex, int att)
+{
+ const char *txt = a68_mode_error_text (p, from, to, context, deflex, 1);
+
+ if (att == STOP)
+ {
+ if (strlen (txt) == 0)
+ a68_error (p, "M cannot be coerced to M in C context", from, to, context);
+ else
+ a68_error (p, "Y in C context", txt, context);
+ }
+ else
+ {
+ if (strlen (txt) == 0)
+ a68_error (p, "M cannot be coerced to M in C-A", from, to, context, att);
+ else
+ a68_error (p, "Y in C-A", txt, context, att);
+ }
+}
+
+/* Give a warning when a value is silently discarded. */
+
+void
+a68_warn_for_voiding (NODE_T *p, SOID_T *x, SOID_T *y, int c)
+{
+ (void) c;
+
+ if (CAST (x) == false)
+ {
+ if (MOID (x) == M_VOID && MOID (y) != M_ERROR && !(MOID (y) == M_VOID || !a68_is_nonproc (MOID (y))))
+ {
+ if (IS (p, FORMULA))
+ a68_warning (p, OPT_Wvoiding, "value of M @ will be voided", MOID (y));
+ else
+ a68_warning (p, OPT_Wvoiding, "value of M @ will be voided", MOID (y));
+ }
+ }
+}
+
+/* Warn for things that are likely unintended. */
+
+void
+a68_semantic_pitfall (NODE_T *p, MOID_T *m, int c, int u)
+{
+ /* semantic_pitfall: warn for things that are likely unintended, for instance
+ REF INT i := LOC INT := 0, which should probably be
+ REF INT i = LOC INT := 0. */
+ if (IS (p, u))
+ a68_warning (p, 0, "possibly unintended M A in M A",
+ MOID (p), u, m, c);
+ else if (a68_is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP))
+ a68_semantic_pitfall (SUB (p), m, c, u);
+}
--- /dev/null
+/* Miscellaneous MOID routines.
+ Copyright (C) 2001-2023 J. Marcel van der Veer.
+ Copyright (C) 2025 Jose E. Marchesi.
+
+ Original implementation by J. Marcel van der Veer.
+ Adapted for GCC by Jose E. Marchesi.
+
+ GCC is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ GCC is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING3. If not see
+ <http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+/*
+ * MODE checker routines.
+ */
+
+/* Absorb nested series modes recursively. */
+
+void
+a68_absorb_series_pack (MOID_T **p)
+{
+ bool siga;
+
+ do
+ {
+ PACK_T *z = NO_PACK;
+
+ siga = false;
+ for (PACK_T *t = PACK (*p); t != NO_PACK; FORWARD (t))
+ {
+ if (MOID (t) != NO_MOID && IS (MOID (t), SERIES_MODE))
+ {
+ siga = true;
+ for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s))
+ a68_add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
+ }
+ else
+ a68_add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
+ }
+ PACK (*p) = z;
+ }
+ while (siga);
+}
+
+/* Make SERIES (u, v). */
+
+MOID_T *
+a68_make_series_from_moids (MOID_T *u, MOID_T *v)
+{
+ MOID_T *x = a68_new_moid ();
+
+ ATTRIBUTE (x) = SERIES_MODE;
+ a68_add_mode_to_pack (&(PACK (x)), u, NO_TEXT, NODE (u));
+ a68_add_mode_to_pack (&(PACK (x)), v, NO_TEXT, NODE (v));
+ a68_absorb_series_pack (&x);
+ DIM (x) = a68_count_pack_members (PACK (x));
+ (void) a68_register_extra_mode (&TOP_MOID (&A68_JOB), x);
+ if (DIM (x) == 1)
+ return MOID (PACK (x));
+ else
+ return x;
+}
+
+/* Absorb firmly related unions in mode.
+
+ For instance invalid UNION (PROC REF UNION (A, B), A, B) -> valid
+ UNION (A, B), which is used in balancing conformity clauses. */
+
+MOID_T *
+a68_absorb_related_subsets (MOID_T * m)
+{
+ /* For instance invalid UNION (PROC REF UNION (A, B), A, B) -> valid UNION
+ (A, B), which is used in balancing conformity clauses. */
+ bool siga;
+
+ do
+ {
+ PACK_T *u = NO_PACK;
+
+ siga = false;
+ for (PACK_T *v = PACK (m); v != NO_PACK; FORWARD (v))
+ {
+ MOID_T *n = a68_depref_completely (MOID (v));
+
+ if (IS (n, UNION_SYMBOL) && a68_is_subset (n, m, SAFE_DEFLEXING))
+ {
+ /* Unpack it. */
+ for (PACK_T *w = PACK (n); w != NO_PACK; FORWARD (w))
+ a68_add_mode_to_pack (&u, MOID (w), NO_TEXT, NODE (w));
+ siga = true;
+ }
+ else
+ a68_add_mode_to_pack (&u, MOID (v), NO_TEXT, NODE (v));
+ }
+ PACK (m) = a68_absorb_union_pack (u);
+ }
+ while (siga);
+ return m;
+}
+
+/* Absorb nested series and united modes recursively. */
+
+void
+a68_absorb_series_union_pack (MOID_T **p)
+{
+ bool siga;
+
+ do
+ {
+ PACK_T *z = NO_PACK;
+
+ siga = false;
+ for (PACK_T *t = PACK (*p); t != NO_PACK; FORWARD (t))
+ {
+ if (MOID (t) != NO_MOID && (IS (MOID (t), SERIES_MODE) || IS (MOID (t), UNION_SYMBOL)))
+ {
+ siga = true;
+ for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s))
+ a68_add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
+ }
+ else
+ a68_add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
+ }
+ PACK (*p) = z;
+ }
+ while (siga);
+}
+
+/* Make united mode, from mode that is a SERIES (..). */
+
+MOID_T *
+a68_make_united_mode (MOID_T *m)
+{
+ if (m == NO_MOID)
+ return M_ERROR;
+ else if (ATTRIBUTE (m) != SERIES_MODE)
+ return m;
+
+ /* Do not unite a single UNION. */
+ if (DIM (m) == 1 && IS (MOID (PACK (m)), UNION_SYMBOL))
+ return MOID (PACK (m));
+
+ /* Straighten the series. */
+ a68_absorb_series_union_pack (&m);
+ /* Copy the series into a UNION. */
+ MOID_T *u = a68_new_moid ();
+ ATTRIBUTE (u) = UNION_SYMBOL;
+ PACK (u) = NO_PACK;
+ for (PACK_T *w = PACK (m); w != NO_PACK; FORWARD (w))
+ a68_add_mode_to_pack (&(PACK (u)), MOID (w), NO_TEXT, NODE (m));
+
+ /* Absorb and contract the new UNION. */
+ a68_absorb_series_union_pack (&u);
+ DIM (u) = a68_count_pack_members (PACK (u));
+ PACK (u) = a68_absorb_union_pack (PACK (u));
+ a68_contract_union (u);
+ DIM (u) = a68_count_pack_members (PACK (u));
+ /* A UNION of one mode is that mode itself. */
+ if (DIM (u) == 1)
+ return MOID (PACK (u));
+ else
+ return a68_register_extra_mode (&TOP_MOID (&A68_JOB), u);
+}
+
+/* Make SOID data structure. */
+
+void
+a68_make_soid (SOID_T *s, int sort, MOID_T *type, int attribute)
+{
+ ATTRIBUTE (s) = attribute;
+ SORT (s) = sort;
+ MOID (s) = type;
+ CAST (s) = false;
+}
+
+/* Whether mode is not well defined. */
+
+bool
+a68_is_mode_isnt_well (MOID_T *p)
+{
+ if (p == NO_MOID)
+ return true;
+ else if (!A68_IF_MODE_IS_WELL (p))
+ return true;
+ else if (PACK (p) != NO_PACK)
+ {
+ for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q))
+ {
+ if (!A68_IF_MODE_IS_WELL (MOID (q)))
+ return true;
+ }
+ }
+ return false;
+}
+
+/* Add SOID data to free chain. */
+
+void
+a68_free_soid_list (SOID_T *root)
+{
+ if (root != NO_SOID)
+ {
+ SOID_T *q = root;
+
+ for (; NEXT (q) != NO_SOID; FORWARD (q))
+ ;
+ NEXT (q) = A68 (top_soid_list);
+ A68 (top_soid_list) = root;
+ }
+}
+
+/* Add SOID data structure to soid list. */
+
+void
+a68_add_to_soid_list (SOID_T **root, NODE_T *where, SOID_T *soid)
+{
+ if (*root != NO_SOID)
+ a68_add_to_soid_list (&(NEXT (*root)), where, soid);
+ else
+ {
+ SOID_T *new_one;
+
+ if (A68 (top_soid_list) == NO_SOID)
+ new_one = (SOID_T *) ggc_cleared_alloc<SOID_T> ();
+ else
+ {
+ new_one = A68 (top_soid_list);
+ FORWARD (A68 (top_soid_list));
+ }
+
+ a68_make_soid (new_one, SORT (soid), MOID (soid), 0);
+ NODE (new_one) = where;
+ NEXT (new_one) = NO_SOID;
+ *root = new_one;
+ }
+}
+
+/* Pack soids in moid, gather resulting moids from terminators in a clause. */
+
+MOID_T *
+a68_pack_soids_in_moid (SOID_T *top_sl, int attribute)
+{
+ MOID_T *x = a68_new_moid ();
+ PACK_T *t, **p;
+
+ ATTRIBUTE (x) = attribute;
+ DIM (x) = 0;
+ SUB (x) = NO_MOID;
+ EQUIVALENT (x) = NO_MOID;
+ SLICE (x) = NO_MOID;
+ DEFLEXED (x) = NO_MOID;
+ NAME (x) = NO_MOID;
+ NEXT (x) = NO_MOID;
+ PACK (x) = NO_PACK;
+ p = &(PACK (x));
+ for (; top_sl != NO_SOID; FORWARD (top_sl))
+ {
+ t = a68_new_pack ();
+ MOID (t) = MOID (top_sl);
+ TEXT (t) = NO_TEXT;
+ NODE (t) = NODE (top_sl);
+ NEXT (t) = NO_PACK;
+ DIM (x)++;
+ *p = t;
+ p = &NEXT (t);
+ }
+ (void) a68_register_extra_mode (&TOP_MOID (&A68_JOB), x);
+ return x;
+}
+
+/* Whether P is compatible with Q. */
+
+bool
+a68_is_equal_modes (MOID_T *p, MOID_T *q, int deflex)
+{
+ if (deflex == FORCE_DEFLEXING)
+ return DEFLEX (p) == DEFLEX (q);
+ else if (deflex == ALIAS_DEFLEXING)
+ {
+ if (IS (p, REF_SYMBOL) && IS (q, REF_SYMBOL))
+ return (p == q
+ || a68_prove_moid_equivalence (p, q)
+ || a68_prove_moid_equivalence (DEFLEX (p), q)
+ || DEFLEX (p) == q);
+ else if (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL))
+ return (DEFLEX (p) == DEFLEX (q)
+ || a68_prove_moid_equivalence (DEFLEX (p), DEFLEX (q)));
+ }
+ else if (deflex == SAFE_DEFLEXING)
+ {
+ if (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL))
+ return (DEFLEX (p) == DEFLEX (q)
+ || a68_prove_moid_equivalence (DEFLEX (p), DEFLEX (q)));
+ }
+
+ return (p == q || a68_prove_moid_equivalence (p, q));
+}
+
+/* Whether mode is deprefable, i.e. whether it can be either deferred or
+ deprocedured. */
+
+bool
+a68_is_deprefable (MOID_T *p)
+{
+ if (IS_REF (p))
+ return true;
+ else
+ return (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK);
+}
+
+/* Deref or deproc the mode P once. */
+
+MOID_T *
+a68_depref_once (MOID_T *p)
+{
+ if (IS_REF_FLEX (p))
+ return SUB_SUB (p);
+ else if (IS_REF (p))
+ return SUB (p);
+ else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)
+ return SUB (p);
+ else
+ return NO_MOID;
+}
+
+/* Depref mode completely. */
+
+MOID_T *
+a68_depref_completely (MOID_T *p)
+{
+ while (a68_is_deprefable (p))
+ p = a68_depref_once (p);
+ return p;
+}
+
+/* Deproc_completely. */
+
+MOID_T *
+a68_deproc_completely (MOID_T *p)
+{
+ while (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)
+ p = a68_depref_once (p);
+ return p;
+}
+
+/* Depref rows. */
+
+MOID_T *
+a68_depref_rows (MOID_T *p, MOID_T *q)
+{
+ if (q == M_ROWS)
+ {
+ while (a68_is_deprefable (p))
+ p = a68_depref_once (p);
+ return p;
+ }
+ else
+ return q;
+}
+
+/* Derow mode, strip FLEX and BOUNDS. */
+
+MOID_T *
+a68_derow (MOID_T *p)
+{
+ if (IS_ROW (p) || IS_FLEX (p))
+ return a68_derow (SUB (p));
+ else
+ return p;
+}
+
+/* Whether rows type. */
+
+bool
+a68_is_rows_type (MOID_T *p)
+{
+ switch (ATTRIBUTE (p))
+ {
+ case ROW_SYMBOL:
+ case FLEX_SYMBOL:
+ return true;
+ case UNION_SYMBOL:
+ {
+ PACK_T *t = PACK (p);
+ bool siga = true;
+ while (t != NO_PACK && siga)
+ {
+ siga &= a68_is_rows_type (MOID (t));
+ FORWARD (t);
+ }
+ return siga;
+ }
+ default:
+ return false;
+ }
+}
+
+/* Whether mode is PROC (REF FILE) VOID or FORMAT. */
+
+bool
+a68_is_proc_ref_file_void_or_format (MOID_T *p)
+{
+ if (p == M_PROC_REF_FILE_VOID)
+ return true;
+ else if (p == M_FORMAT)
+ return true;
+ else
+ return false;
+}
+
+/* Whether mode can be transput. */
+
+bool
+a68_is_transput_mode (MOID_T *p, char rw)
+{
+ if (p == M_INT)
+ return true;
+ else if (p == M_SHORT_INT)
+ return true;
+ else if (p == M_SHORT_SHORT_INT)
+ return true;
+ else if (p == M_LONG_INT)
+ return true;
+ else if (p == M_LONG_LONG_INT)
+ return true;
+ else if (p == M_REAL)
+ return true;
+ else if (p == M_LONG_REAL)
+ return true;
+ else if (p == M_LONG_LONG_REAL)
+ return true;
+ else if (p == M_BOOL)
+ return true;
+ else if (p == M_CHAR)
+ return true;
+ else if (p == M_BITS)
+ return true;
+ else if (p == M_SHORT_BITS)
+ return true;
+ else if (p == M_SHORT_SHORT_BITS)
+ return true;
+ else if (p == M_LONG_BITS)
+ return true;
+ else if (p == M_LONG_LONG_BITS)
+ return true;
+ else if (p == M_COMPLEX)
+ return true;
+ else if (p == M_LONG_COMPLEX)
+ return true;
+ else if (p == M_LONG_LONG_COMPLEX)
+ return true;
+ else if (p == M_ROW_CHAR)
+ return true;
+ else if (p == M_STRING)
+ return true;
+ else if (IS (p, UNION_SYMBOL) || IS (p, STRUCT_SYMBOL))
+ {
+ for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q))
+ {
+ if (!(a68_is_transput_mode (MOID (q), rw)
+ || a68_is_proc_ref_file_void_or_format (MOID (q))))
+ return false;
+ }
+ return true;
+ }
+ else if (IS_FLEX (p))
+ {
+ if (SUB (p) == M_ROW_CHAR)
+ return true;
+ else
+ return (rw == 'w' ? a68_is_transput_mode (SUB (p), rw) : false);
+ }
+ else if (IS_ROW (p))
+ return (a68_is_transput_mode (SUB (p), rw)
+ || a68_is_proc_ref_file_void_or_format (SUB (p)));
+ else
+ return false;
+}
+
+/* Whether mode is printable. */
+
+bool
+a68_is_printable_mode (MOID_T *p)
+{
+ if (a68_is_proc_ref_file_void_or_format (p))
+ return true;
+ else
+ return a68_is_transput_mode (p, 'w');
+}
+
+/* Whether mode is readable. */
+
+bool
+a68_is_readable_mode (MOID_T *p)
+{
+ if (a68_is_proc_ref_file_void_or_format (p))
+ return true;
+ else if (IS_REF (p))
+ return a68_is_transput_mode (SUB (p), 'r');
+ else if (IS_UNION (p))
+ {
+ for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q))
+ {
+ if (!IS_REF (MOID (q)))
+ return false;
+ else if (!a68_is_transput_mode (SUB (MOID (q)), 'r'))
+ return false;
+ }
+ return true;
+ }
+ else
+ return false;
+}
+
+/* Whether name struct. */
+
+bool
+a68_is_name_struct (MOID_T *p)
+{
+ return (NAME (p) != NO_MOID ? IS (DEFLEX (SUB (p)), STRUCT_SYMBOL) : false);
+}
+
+/* Yield mode to unite to. */
+
+MOID_T *
+a68_unites_to (MOID_T *m, MOID_T *u)
+{
+ /* Uniting U (m). */
+ MOID_T *v = NO_MOID;
+
+ if (u == M_SIMPLIN || u == M_SIMPLOUT)
+ return m;
+
+ for (PACK_T *p = PACK (u); p != NO_PACK; FORWARD (p))
+ {
+ /* Prefer []->[] over []->FLEX []. */
+ if (m == MOID (p))
+ v = MOID (p);
+ else if (v == NO_MOID && DEFLEX (m) == DEFLEX (MOID (p)))
+ v = MOID (p);
+ }
+ return v;
+}
+
+/* Whether moid in pack. */
+
+bool
+a68_is_moid_in_pack (MOID_T *u, PACK_T *v, int deflex)
+{
+ for (; v != NO_PACK; FORWARD (v))
+ {
+ if (a68_is_equal_modes (u, MOID (v), deflex))
+ return true;
+ }
+
+ return false;
+}
+
+/* Whether a rows type in pack. */
+
+bool
+a68_is_rows_in_pack (PACK_T *v)
+{
+ for (; v != NO_PACK; FORWARD (v))
+ {
+ if (a68_is_rows_type (MOID (v)))
+ return true;
+ }
+
+ return false;
+}
+
+/* Whether P is a subset of Q. */
+
+bool
+a68_is_subset (MOID_T *p, MOID_T *q, int deflex)
+{
+ bool j =true;
+
+ for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u))
+ j = (j && a68_is_moid_in_pack (MOID (u), PACK (q), deflex));
+
+ return j;
+}
+
+/* Whether P can be united to UNION Q. */
+
+bool
+a68_is_unitable (MOID_T *p, MOID_T *q, int deflex)
+{
+ if (IS (q, UNION_SYMBOL))
+ {
+ if (IS (p, UNION_SYMBOL))
+ return a68_is_subset (p, q, deflex);
+ else if (p == M_ROWS)
+ return a68_is_rows_in_pack (PACK (q));
+ else
+ return a68_is_moid_in_pack (p, PACK (q), deflex);
+ }
+
+ return false;
+}
+
+/* Whether all or some components of U can be firmly coerced to a component
+ mode of V.. */
+
+void
+a68_investigate_firm_relations (PACK_T *u, PACK_T *v, bool *all, bool *some)
+{
+ *all = true;
+ *some = true;
+ for (; v != NO_PACK; FORWARD (v))
+ {
+ bool k = false;
+
+ for (PACK_T *w = u; w != NO_PACK; FORWARD (w))
+ k |= a68_is_coercible (MOID (w), MOID (v), FIRM, FORCE_DEFLEXING);
+ *some |= k;
+ *all &= k;
+ }
+}
+
+/* Whether there is a soft path from P to Q. */
+
+bool
+a68_is_softly_coercible (MOID_T *p, MOID_T *q, int deflex)
+{
+ if (a68_is_equal_modes (p, q, deflex))
+ return true;
+ else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)
+ return a68_is_softly_coercible (SUB (p), q, deflex);
+ else
+ return false;
+}
+
+/* Whether there is a weak path from P to Q. */
+
+bool
+a68_is_weakly_coercible (MOID_T * p, MOID_T * q, int deflex)
+{
+ if (a68_is_equal_modes (p, q, deflex))
+ return true;
+ else if (a68_is_deprefable (p))
+ return a68_is_weakly_coercible (a68_depref_once (p), q, deflex);
+ else
+ return false;
+}
+
+/* Whether there is a meek path from P to Q. */
+
+bool
+a68_is_meekly_coercible (MOID_T *p, MOID_T *q, int deflex)
+{
+ if (a68_is_equal_modes (p, q, deflex))
+ return true;
+ else if (a68_is_deprefable (p))
+ return a68_is_meekly_coercible (a68_depref_once (p), q, deflex);
+ else
+ return false;
+}
+
+/* Whether there is a firm path from P to Q. */
+
+bool
+a68_is_firmly_coercible (MOID_T *p, MOID_T *q, int deflex)
+{
+ if (a68_is_equal_modes (p, q, deflex))
+ return true;
+ else if (q == M_ROWS && a68_is_rows_type (p))
+ return true;
+ else if (a68_is_unitable (p, q, deflex))
+ return true;
+ else if (a68_is_deprefable (p))
+ return a68_is_firmly_coercible (a68_depref_once (p), q, deflex);
+ else
+ return false;
+}
+
+/* Whether firm. */
+
+bool
+a68_is_firm (MOID_T *p, MOID_T *q)
+{
+ return (a68_is_firmly_coercible (p, q, SAFE_DEFLEXING)
+ || a68_is_firmly_coercible (q, p, SAFE_DEFLEXING));
+}
+
+/* Whether P widens to Q.
+
+ This function returns:
+
+ The destination mode Q if P, or
+ Some other mode which is an intermediate step from P to Q, or
+ NO_MOID if P cannot be widened to Q.
+
+ This means that if P is known to widen to Q (a68_is_widenable (P,Q) return
+ true) this function can be invoked repeteadly and it will eventually return
+ Q. */
+
+MOID_T *
+a68_widens_to (MOID_T *p, MOID_T *q)
+{
+ if (p == M_INT)
+ {
+ if (q == M_REAL || q == M_COMPLEX)
+ {
+ return M_REAL;
+ }
+ else
+ {
+ return NO_MOID;
+ }
+ }
+ else if (p == M_LONG_INT)
+ {
+ if (q == M_LONG_REAL)
+ {
+ return M_LONG_REAL;
+ }
+ else
+ {
+ return NO_MOID;
+ }
+ }
+ else if (p == M_LONG_LONG_INT)
+ {
+ if (q == M_LONG_LONG_REAL || q == M_LONG_LONG_COMPLEX)
+ return M_LONG_LONG_REAL;
+ else
+ return NO_MOID;
+ }
+ else if (p == M_REAL)
+ {
+ if (q == M_COMPLEX)
+ {
+ return M_COMPLEX;
+ }
+ else
+ {
+ return NO_MOID;
+ }
+ }
+ else if (p == M_LONG_REAL)
+ {
+ if (q == M_LONG_COMPLEX)
+ return M_LONG_COMPLEX;
+ else
+ return NO_MOID;
+ }
+ else if (p == M_LONG_LONG_REAL)
+ {
+ if (q == M_LONG_LONG_COMPLEX)
+ return M_LONG_LONG_COMPLEX;
+ else
+ return NO_MOID;
+ }
+ else if (p == M_BITS)
+ {
+ if (q == M_ROW_BOOL)
+ return M_ROW_BOOL;
+ else if (q == M_FLEX_ROW_BOOL)
+ return M_FLEX_ROW_BOOL;
+ else
+ return NO_MOID;
+ }
+ else if (p == M_SHORT_BITS)
+ {
+ if (q == M_ROW_BOOL)
+ return M_ROW_BOOL;
+ else if (q == M_FLEX_ROW_BOOL)
+ return M_FLEX_ROW_BOOL;
+ else
+ return NO_MOID;
+ }
+ else if (p == M_SHORT_SHORT_BITS)
+ {
+ if (q == M_ROW_BOOL)
+ return M_ROW_BOOL;
+ else if (q == M_FLEX_ROW_BOOL)
+ return M_FLEX_ROW_BOOL;
+ else
+ return NO_MOID;
+ }
+ else if (p == M_LONG_BITS)
+ {
+ if (q == M_ROW_BOOL)
+ return M_ROW_BOOL;
+ else if (q == M_FLEX_ROW_BOOL)
+ return M_FLEX_ROW_BOOL;
+ else
+ return NO_MOID;
+ }
+ else if (p == M_LONG_LONG_BITS)
+ {
+ if (q == M_ROW_BOOL)
+ return M_ROW_BOOL;
+ else if (q == M_FLEX_ROW_BOOL)
+ return M_FLEX_ROW_BOOL;
+ else
+ return NO_MOID;
+ }
+ else if (p == M_BYTES && q == M_ROW_CHAR)
+ return M_ROW_CHAR;
+ else if (p == M_LONG_BYTES && q == M_ROW_CHAR)
+ return M_ROW_CHAR;
+ else if (p == M_BYTES && q == M_FLEX_ROW_CHAR)
+ return M_FLEX_ROW_CHAR;
+ else if (p == M_LONG_BYTES && q == M_FLEX_ROW_CHAR)
+ return M_FLEX_ROW_CHAR;
+ else
+ return NO_MOID;
+}
+
+/* Whether P widens to Q. */
+
+bool
+a68_is_widenable (MOID_T *p, MOID_T *q)
+{
+ MOID_T *z = a68_widens_to (p, q);
+
+ if (z != NO_MOID)
+ return (z == q ? true : a68_is_widenable (z, q));
+ else
+ return false;
+}
+
+/* Whether P is a REF ROW. */
+
+bool
+a68_is_ref_row (MOID_T *p)
+{
+ return (NAME (p) != NO_MOID ? IS_ROW (DEFLEX (SUB (p))) : false);
+}
+
+/* Whether strong name. */
+
+bool
+a68_is_strong_name (MOID_T *p, MOID_T *q)
+{
+ if (p == q)
+ return true;
+ else if (a68_is_ref_row (q))
+ return a68_is_strong_name (p, NAME (q));
+ else
+ return false;
+}
+
+/* Whether strong slice. */
+
+bool
+a68_is_strong_slice (MOID_T *p, MOID_T *q)
+{
+ if (p == q || a68_is_widenable (p, q))
+ return true;
+ else if (SLICE (q) != NO_MOID)
+ return a68_is_strong_slice (p, SLICE (q));
+ else if (IS_FLEX (q))
+ return a68_is_strong_slice (p, SUB (q));
+ else if (a68_is_ref_row (q))
+ return a68_is_strong_name (p, q);
+ else
+ return false;
+}
+
+/* Whether strongly coercible. */
+
+bool
+a68_is_strongly_coercible (MOID_T *p, MOID_T *q, int deflex)
+{
+ /* Keep this sequence of statements. */
+ if (a68_is_equal_modes (p, q, deflex))
+ return true;
+ else if (q == M_VOID)
+ return true;
+ else if ((q == M_SIMPLIN || q == M_ROW_SIMPLIN) && a68_is_readable_mode (p))
+ return true;
+ else if (q == M_ROWS && a68_is_rows_type (p))
+ return true;
+ else if (a68_is_unitable (p, a68_derow (q), deflex))
+ return true;
+
+ if (a68_is_ref_row (q) && a68_is_strong_name (p, q))
+ return true;
+ else if (SLICE (q) != NO_MOID && a68_is_strong_slice (p, q))
+ return true;
+ else if (IS_FLEX (q) && a68_is_strong_slice (p, q))
+ return true;
+ else if (a68_is_widenable (p, q))
+ return true;
+ else if (a68_is_deprefable (p))
+ return a68_is_strongly_coercible (a68_depref_once (p), q, deflex);
+ else if (q == M_SIMPLOUT || q == M_ROW_SIMPLOUT)
+ return a68_is_printable_mode (p);
+ else
+ return false;
+}
+
+/* Basic coercions. */
+
+bool
+a68_basic_coercions (MOID_T *p, MOID_T *q, int c, int deflex)
+{
+ if (a68_is_equal_modes (p, q, deflex))
+ return true;
+ else if (c == NO_SORT)
+ return (p == q);
+ else if (c == SOFT)
+ return a68_is_softly_coercible (p, q, deflex);
+ else if (c == WEAK)
+ return a68_is_weakly_coercible (p, q, deflex);
+ else if (c == MEEK)
+ return a68_is_meekly_coercible (p, q, deflex);
+ else if (c == FIRM)
+ return a68_is_firmly_coercible (p, q, deflex);
+ else if (c == STRONG)
+ return a68_is_strongly_coercible (p, q, deflex);
+ else
+ return false;
+}
+
+/* Whether coercible stowed. */
+
+bool
+a68_is_coercible_stowed (MOID_T *p, MOID_T *q, int c, int deflex)
+{
+ if (c != STRONG)
+ /* Such construct is always in a strong position, is it not? */
+ return false;
+ else if (q == M_VOID)
+ return true;
+ else if (IS_FLEX (q))
+ {
+ bool j = true;
+
+ for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u))
+ j &= a68_is_coercible (MOID (u), SLICE (SUB (q)), c, deflex);
+ return j;
+ }
+ else if (IS_ROW (q))
+ {
+ bool j = true;
+
+ for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u))
+ j &= a68_is_coercible (MOID (u), SLICE (q), c, deflex);
+ return j;
+ }
+ else if (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL))
+ {
+ if (DIM (p) != DIM (q))
+ return false;
+ else
+ {
+ PACK_T *u = PACK (p), *v = PACK (q);
+ bool j = true;
+
+ while (u != NO_PACK && v != NO_PACK && j)
+ {
+ j &= a68_is_coercible (MOID (u), MOID (v), c, deflex);
+ FORWARD (u);
+ FORWARD (v);
+ }
+ return j;
+ }
+ }
+ else
+ return false;
+}
+
+/* Whether coercible series. */
+
+bool
+a68_is_coercible_series (MOID_T *p, MOID_T *q, int c, int deflex)
+{
+ if (c == NO_SORT)
+ return false;
+ else if (p == NO_MOID || q == NO_MOID)
+ return false;
+ else if (IS (p, SERIES_MODE) && PACK (p) == NO_PACK)
+ return false;
+ else if (IS (q, SERIES_MODE) && PACK (q) == NO_PACK)
+ return false;
+ else if (PACK (p) == NO_PACK)
+ return a68_is_coercible (p, q, c, deflex);
+ else
+ {
+ bool j = true;
+
+ for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u))
+ {
+ if (MOID (u) != NO_MOID)
+ j &= a68_is_coercible (MOID (u), q, c, deflex);
+ }
+ return j;
+ }
+}
+
+/* Whether P can be coerced to Q in a C context.
+
+ If P is a STOWED modes serie (A, B, ...) and Q is a routine mode like `proc
+ (X, Y, ...)' then this routine determines whether A can be coerced to X, B
+ to Y, etc. */
+
+bool
+a68_is_coercible (MOID_T *p, MOID_T *q, int c, int deflex)
+{
+ if (a68_is_mode_isnt_well (p) || a68_is_mode_isnt_well (q))
+ return true;
+ else if (a68_is_equal_modes (p, q, deflex))
+ return true;
+ else if (p == M_HIP)
+ return true;
+ else if (IS (p, STOWED_MODE))
+ return a68_is_coercible_stowed (p, q, c, deflex);
+ else if (IS (p, SERIES_MODE))
+ return a68_is_coercible_series (p, q, c, deflex);
+ else if (p == M_VACUUM && IS_ROW (DEFLEX (q)))
+ return true;
+ else
+ return a68_basic_coercions (p, q, c, deflex);
+}
+
+/* Whether coercible in context. */
+
+bool
+a68_is_coercible_in_context (SOID_T *p, SOID_T *q, int deflex)
+{
+ if (SORT (p) != SORT (q))
+ return false;
+ else if (MOID (p) == MOID (q))
+ return true;
+ else
+ return a68_is_coercible (MOID (p), MOID (q), SORT (q), deflex);
+}
+
+/* Whether list Y is balanced. */
+
+bool
+a68_is_balanced (NODE_T *n, SOID_T *y, int sort)
+{
+ if (sort == STRONG)
+ return true;
+ else
+ {
+ bool k = false;
+
+ for (; y != NO_SOID && !k; FORWARD (y))
+ k = (!IS (MOID (y), STOWED_MODE));
+
+ if (k == false)
+ a68_error (n, "construct has no unique mode");
+ return k;
+ }
+}
+
+/* A moid from M to which all other members can be coerced.
+ If no fulcrum of the balance is found, return NO_MOID. */
+
+MOID_T *
+a68_get_balanced_mode_or_no_mode (MOID_T *m, int sort, bool return_depreffed, int deflex)
+{
+ MOID_T *common_moid = NO_MOID;
+
+ if (m != NO_MOID && !a68_is_mode_isnt_well (m) && IS (m, UNION_SYMBOL))
+ {
+ int depref_level;
+ bool siga = true;
+ /* Test for increasing depreffing. */
+ for (depref_level = 0; siga; depref_level++)
+ {
+ siga = false;
+ /* Test the whole pack. */
+ for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p))
+ {
+ /* HIPs are not eligible of course. */
+ if (MOID (p) != M_HIP)
+ {
+ MOID_T *candidate = MOID (p);
+ int k;
+ /* Depref as far as allowed. */
+ for (k = depref_level; k > 0 && a68_is_deprefable (candidate); k--)
+ candidate = a68_depref_once (candidate);
+ /* Only need testing if all allowed deprefs succeeded. */
+ if (k == 0)
+ {
+ MOID_T *to = (return_depreffed ? a68_depref_completely (candidate) : candidate);
+ bool all_coercible = true;
+
+ siga = true;
+ for (PACK_T *q = PACK (m); q != NO_PACK && all_coercible; FORWARD (q))
+ {
+ MOID_T *from = MOID (q);
+ if (p != q && from != to)
+ all_coercible &= a68_is_coercible (from, to, sort, deflex);
+ }
+ /* If the pack is coercible to the candidate, we mark the
+ candidate. We continue searching for longest series
+ of REF REF PROC REF. */
+ if (all_coercible)
+ {
+ MOID_T *mark = (return_depreffed ? MOID (p) : candidate);
+
+ if (common_moid == NO_MOID)
+ common_moid = mark;
+ else if (IS_FLEX (candidate) && DEFLEX (candidate) == common_moid)
+ /* We prefer FLEX. */
+ common_moid = mark;
+ }
+ }
+ }
+ }
+ }
+ }
+
+ return common_moid;
+}
+
+/* A moid from M to which all other members can be coerced.
+ If no fulcrum of the balance is found, return M. */
+
+MOID_T *
+a68_get_balanced_mode (MOID_T *m, int sort, bool return_depreffed, int deflex)
+{
+ MOID_T *common_moid
+ = a68_get_balanced_mode_or_no_mode (m, sort, return_depreffed, deflex);
+ return common_moid == NO_MOID ? m : common_moid;
+}
+
+/* Whether we can search a common mode from a clause or not. */
+
+bool
+a68_clause_allows_balancing (int att)
+{
+ switch (att)
+ {
+ case CLOSED_CLAUSE:
+ case CONDITIONAL_CLAUSE:
+ case CASE_CLAUSE:
+ case SERIAL_CLAUSE:
+ case CONFORMITY_CLAUSE:
+ return true;
+ }
+ return false;
+}
+
+/* A unique mode from Z. */
+
+MOID_T *
+a68_determine_unique_mode (SOID_T *z, int deflex)
+{
+ if (z == NO_SOID)
+ return NO_MOID;
+ else
+ {
+ MOID_T *x = MOID (z);
+
+ if (a68_is_mode_isnt_well (x))
+ return M_ERROR;
+
+ /* If X is a series containing one union, a68_make_united_mode will
+ return that union (because 'union (union (...))' is the same than
+ 'union (...)') and then a68_get_balanced_mode below will try to
+ balance the modes in that union. Not what we want. */
+ if (ATTRIBUTE (x) == SERIES_MODE
+ && DIM (x) == 1
+ && IS (MOID (PACK (x)), UNION_SYMBOL))
+ return MOID (PACK (x));
+
+ x = a68_make_united_mode (x);
+ if (a68_clause_allows_balancing (ATTRIBUTE (z)))
+ return a68_get_balanced_mode (x, STRONG, A68_NO_DEPREF, deflex);
+ else
+ return x;
+ }
+}
+
+/* Insert coercion A in the tree. */
+
+void
+a68_make_coercion (NODE_T *l, enum a68_attribute a, MOID_T *m)
+{
+ a68_make_sub (l, l, a);
+ MOID (l) = a68_depref_rows (MOID (l), m);
+}
+
+/* Make widening coercion. */
+
+static void
+make_widening_coercion (NODE_T *n, MOID_T *p, MOID_T *q)
+{
+ MOID_T *z = a68_widens_to (p, q);
+
+ a68_make_coercion (n, WIDENING, z);
+ if (z != q)
+ make_widening_coercion (n, z, q);
+}
+
+/* Make ref rowing coercion. */
+
+void
+a68_make_ref_rowing_coercion (NODE_T *n, MOID_T *p, MOID_T *q)
+{
+ if (DEFLEX (p) != DEFLEX (q))
+ {
+ if (a68_is_widenable (p, q))
+ make_widening_coercion (n, p, q);
+ else if (a68_is_ref_row (q))
+ {
+ a68_make_ref_rowing_coercion (n, p, NAME (q));
+ a68_make_coercion (n, ROWING, q);
+ }
+ }
+}
+
+/* Make rowing coercion. */
+
+void
+a68_make_rowing_coercion (NODE_T *n, MOID_T *p, MOID_T *q)
+{
+ if (DEFLEX (p) != DEFLEX (q))
+ {
+ if (a68_is_widenable (p, q))
+ make_widening_coercion (n, p, q);
+ else if (SLICE (q) != NO_MOID)
+ {
+ a68_make_rowing_coercion (n, p, SLICE (q));
+ a68_make_coercion (n, ROWING, q);
+ }
+ else if (IS_FLEX (q))
+ a68_make_rowing_coercion (n, p, SUB (q));
+ else if (a68_is_ref_row (q))
+ a68_make_ref_rowing_coercion (n, p, q);
+ }
+}
+
+/* Make uniting coercion. */
+
+void
+a68_make_uniting_coercion (NODE_T *n, MOID_T *q)
+{
+ a68_make_coercion (n, UNITING, a68_derow (q));
+ if (IS_ROW (q) || IS_FLEX (q))
+ a68_make_rowing_coercion (n, a68_derow (q), q);
+}
+
+/* Make depreffing coercion to coerce node N from mode P to mode Q in a strong
+ context. */
+
+void
+a68_make_depreffing_coercion (NODE_T *n, MOID_T *p, MOID_T *q)
+{
+ if (DEFLEX (p) == DEFLEX (q))
+ return;
+ else if (q == M_SIMPLOUT && a68_is_printable_mode (p))
+ a68_make_coercion (n, UNITING, q);
+ else if (q == M_ROW_SIMPLOUT && a68_is_printable_mode (p))
+ {
+ a68_make_coercion (n, UNITING, M_SIMPLOUT);
+ a68_make_coercion (n, ROWING, M_ROW_SIMPLOUT);
+ }
+ else if (q == M_SIMPLIN && a68_is_readable_mode (p))
+ a68_make_coercion (n, UNITING, q);
+ else if (q == M_ROW_SIMPLIN && a68_is_readable_mode (p))
+ {
+ a68_make_coercion (n, UNITING, M_SIMPLIN);
+ a68_make_coercion (n, ROWING, M_ROW_SIMPLIN);
+ }
+ else if (q == M_ROWS && a68_is_rows_type (p))
+ {
+ a68_make_coercion (n, UNITING, M_ROWS);
+ MOID (n) = M_ROWS;
+ }
+ else if (a68_is_widenable (p, q))
+ make_widening_coercion (n, p, q);
+ else if (a68_is_unitable (p, a68_derow (q), SAFE_DEFLEXING))
+ a68_make_uniting_coercion (n, q);
+ else if (a68_is_ref_row (q) && a68_is_strong_name (p, q))
+ a68_make_ref_rowing_coercion (n, p, q);
+ else if (SLICE (q) != NO_MOID && a68_is_strong_slice (p, q))
+ a68_make_rowing_coercion (n, p, q);
+ else if (IS_FLEX (q) && a68_is_strong_slice (p, q))
+ a68_make_rowing_coercion (n, p, q);
+ else if (IS_REF (p))
+ {
+ MOID_T *r = a68_depref_once (p);
+ a68_make_coercion (n, DEREFERENCING, r);
+ a68_make_depreffing_coercion (n, r, q);
+ }
+ else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)
+ {
+ MOID_T *r = SUB (p);
+
+ a68_make_coercion (n, DEPROCEDURING, r);
+ a68_make_depreffing_coercion (n, r, q);
+ }
+ else if (p != q)
+ a68_cannot_coerce (n, p, q, NO_SORT, SKIP_DEFLEXING, 0);
+}
+
+/* Whether p is a nonproc mode (that is voided directly). */
+
+bool
+a68_is_nonproc (MOID_T *p)
+{
+ if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)
+ return false;
+ else if (IS_REF (p))
+ return a68_is_nonproc (SUB (p));
+ else
+ return true;
+}
+
+/* Voiden in an appropriate way. */
+
+void
+a68_make_void (NODE_T *p, MOID_T *q)
+{
+ switch (ATTRIBUTE (p))
+ {
+ case ASSIGNATION:
+ case IDENTITY_RELATION:
+ case GENERATOR:
+ case CAST:
+ case DENOTATION:
+ a68_make_coercion (p, VOIDING, M_VOID);
+ return;
+ default:
+ break;
+ }
+
+ /* MORFs are an involved case. */
+ switch (ATTRIBUTE (p))
+ {
+ case SELECTION:
+ case SLICE:
+ case ROUTINE_TEXT:
+ case FORMULA:
+ case CALL:
+ case IDENTIFIER:
+ /* A nonproc moid value is eliminated directly. */
+ if (a68_is_nonproc (q))
+ {
+ a68_make_coercion (p, VOIDING, M_VOID);
+ return;
+ }
+ else
+ {
+ /* Descend the chain of e.g. REF PROC .. until a nonproc moid
+ remains. */
+ MOID_T *z = q;
+
+ while (!a68_is_nonproc (z))
+ {
+ if (IS_REF (z))
+ a68_make_coercion (p, DEREFERENCING, SUB (z));
+ if (IS (z, PROC_SYMBOL) && NODE_PACK (p) == NO_PACK)
+ a68_make_coercion (p, DEPROCEDURING, SUB (z));
+ z = SUB (z);
+ }
+ if (z != M_VOID)
+ a68_make_coercion (p, VOIDING, M_VOID);
+ return;
+ }
+ default:
+ break;
+ }
+
+ /* All other is voided straight away. */
+ a68_make_coercion (p, VOIDING, M_VOID);
+}
+
+/* Make strong coercion of node N from mode P to mode Q. */
+
+void
+a68_make_strong (NODE_T *n, MOID_T *p, MOID_T *q)
+{
+ if (q == M_VOID && p != M_VOID)
+ a68_make_void (n, p);
+ else
+ a68_make_depreffing_coercion (n, p, q);
+}
--- /dev/null
+/* Pretty-print a MOID.
+ Copyright (C) 2001-2023 J. Marcel van der Veer.
+ Copyright (C) 2025 Jose E. Marchesi.
+
+ Original implementation by J. Marcel van der Veer.
+ Adapted for GCC by Jose E. Marchesi.
+
+ GCC is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ GCC is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING3. If not see
+ <http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+/*
+ * A pretty printer for moids.
+ *
+ * For example "PROC (REF STRUCT (REF SELF, UNION (INT, VOID))) REF SELF"
+ * for a procedure yielding a pointer to an object of its own mode.
+ */
+
+static void moid_to_string_2 (char *, MOID_T *, size_t *, NODE_T *,
+ bool indicant_value);
+
+/* Add string to MOID text. */
+
+static void
+add_to_moid_text (char *dst, const char *str, size_t *w)
+{
+ a68_bufcat (dst, str, BUFFER_SIZE);
+ (*w) -= strlen (str);
+}
+
+/* Find a tag, searching symbol tables towards the root. */
+
+static TAG_T *
+find_indicant_global (TABLE_T * table, MOID_T * mode)
+{
+ if (table != NO_TABLE)
+ {
+ for (TAG_T *s = INDICANTS (table); s != NO_TAG; FORWARD (s))
+ {
+ if (MOID (s) == mode)
+ return s;
+ }
+ return find_indicant_global (PREVIOUS (table), mode);
+ }
+ else
+ return NO_TAG;
+}
+
+/* Pack to string. */
+
+static void
+pack_to_string (char *b, PACK_T *p, size_t *w, bool text, NODE_T *idf,
+ bool indicant_value)
+{
+ for (; p != NO_PACK; FORWARD (p))
+ {
+ moid_to_string_2 (b, MOID (p), w, idf, indicant_value);
+ if (text)
+ {
+ if (TEXT (p) != NO_TEXT)
+ {
+ add_to_moid_text (b, " ", w);
+ add_to_moid_text (b, TEXT (p), w);
+ }
+ }
+ if (p != NO_PACK && NEXT (p) != NO_PACK)
+ add_to_moid_text (b, ", ", w);
+ }
+}
+
+/* Moid to string 2. */
+
+static void moid_to_string_2 (char *b, MOID_T *n, size_t *w, NODE_T *idf,
+ bool indicant_value)
+{
+ bool supper_stropping = (OPTION_STROPPING (&A68_JOB) == SUPPER_STROPPING);
+ const char *strop_self = supper_stropping ? "self" : "SELF";
+ const char *strop_hip = supper_stropping ? "hip" : "HIP";
+ const char *strop_compl = supper_stropping ? "compl" : "COMPL";
+ const char *strop_long_compl = supper_stropping ? "long compl" : "LONG COMPL";
+ const char *strop_long_long_compl = supper_stropping ? "long long compl" : "LONG LONG COMPL";
+ const char *strop_string = supper_stropping ? "string" : "STRING";
+ const char *strop_collitem = supper_stropping ? "collitem" : "COLLITEM";
+ const char *strop_simplin = supper_stropping ? "%%<simplin%%>" : "%%<SIMPLIN%%>";
+ const char *strop_simplout = supper_stropping ? "%%<simplout%%>" : "%%<SIMPLOUT%%>";
+ const char *strop_rows = supper_stropping ? "%%<rows%%>" : "%%<ROWS%%>";
+ const char *strop_vacuum = supper_stropping ? "%%<vacuum%%>" : "%%<VACUUM%%>";
+ const char *strop_long = supper_stropping ? "long" : "LONG";
+ const char *strop_short = supper_stropping ? "short" : "SHORT";
+ const char *strop_ref = supper_stropping ? "ref" : "REF";
+ const char *strop_flex = supper_stropping ? "flex" : "FLEX";
+ const char *strop_struct = supper_stropping ? "struct" : "STRUCT";
+ const char *strop_union = supper_stropping ? "union" : "UNION";
+ const char *strop_proc = supper_stropping ? "proc" : "PROC";
+
+ if (n == NO_MOID)
+ {
+ /* Oops. Should not happen. */
+ add_to_moid_text (b, "null", w);;
+ return;
+ }
+
+ /* Reference to self through REF or PROC. */
+ if (a68_is_postulated (A68 (postulates), n))
+ {
+ add_to_moid_text (b, strop_self, w);
+ return;
+ }
+
+ /* If declared by a mode-declaration, present the indicant. */
+ if (idf != NO_NODE && !IS (n, STANDARD))
+ {
+ TAG_T *indy = find_indicant_global (TABLE (idf), n);
+
+ if (indy != NO_TAG)
+ {
+ add_to_moid_text (b, NSYMBOL (NODE (indy)), w);
+ if (!indicant_value)
+ return;
+ else
+ add_to_moid_text (b, " = ", w);
+ }
+ }
+
+ /* Write the standard modes. */
+ if (n == M_HIP)
+ add_to_moid_text (b, strop_hip, w);
+ else if (n == M_ERROR)
+ add_to_moid_text (b, "ERROR", w);
+ else if (n == M_UNDEFINED)
+ add_to_moid_text (b, "unresolved mode", w);
+ else if (n == M_C_STRING)
+ add_to_moid_text (b, "C-STRING", w);
+ else if (n == M_COMPLEX)
+ add_to_moid_text (b, strop_compl, w);
+ else if (n == M_LONG_COMPLEX)
+ add_to_moid_text (b, strop_long_compl, w);
+ else if (n == M_LONG_LONG_COMPLEX)
+ add_to_moid_text (b, strop_long_long_compl, w);
+ else if (n == M_STRING)
+ add_to_moid_text (b, strop_string, w);
+ else if (n == M_COLLITEM)
+ add_to_moid_text (b, strop_collitem, w);
+ else if (IS (n, IN_TYPE_MODE))
+ add_to_moid_text (b, strop_simplin, w);
+ else if (IS (n, OUT_TYPE_MODE))
+ add_to_moid_text (b, strop_simplout, w);
+ else if (IS (n, ROWS_SYMBOL))
+ add_to_moid_text (b, strop_rows, w);
+ else if (n == M_VACUUM)
+ add_to_moid_text (b, strop_vacuum, w);
+ else if (IS (n, VOID_SYMBOL) || IS (n, STANDARD) || IS (n, INDICANT))
+ {
+ if (DIM (n) > 0)
+ {
+ size_t k = DIM (n);
+
+ if ((*w) >= k * strlen ("LONG ") + strlen (NSYMBOL (NODE (n))))
+ {
+ while (k--)
+ {
+ add_to_moid_text (b, strop_long, w);
+ add_to_moid_text (b, " ", w);
+ }
+
+ const char *strop_symbol = a68_strop_keyword (NSYMBOL (NODE (n)));
+ add_to_moid_text (b, strop_symbol, w);
+ }
+ else
+ add_to_moid_text (b, "..", w);
+ }
+ else if (DIM (n) < 0)
+ {
+ size_t k = -DIM (n);
+
+ if ((*w) >= k * strlen ("SHORT ") + strlen (NSYMBOL (NODE (n))))
+ {
+ while (k--)
+ {
+ add_to_moid_text (b, strop_short, w);
+ add_to_moid_text (b, " ", w);
+ }
+
+ const char *strop_symbol = a68_strop_keyword (NSYMBOL (NODE (n)));
+ add_to_moid_text (b, strop_symbol, w);
+ }
+ else
+ add_to_moid_text (b, "..", w);
+ }
+ else if (DIM (n) == 0)
+ {
+ const char *strop_symbol = a68_strop_keyword (NSYMBOL (NODE (n)));
+ add_to_moid_text (b, strop_symbol, w);
+ }
+
+ /* Write compxounded modes. */
+ }
+ else if (IS_REF (n))
+ {
+ if ((*w) >= strlen ("REF .."))
+ {
+ add_to_moid_text (b, strop_ref, w);
+ add_to_moid_text (b, " ", w);
+ moid_to_string_2 (b, SUB (n), w, idf, indicant_value);
+ }
+ else
+ {
+ add_to_moid_text (b, strop_ref, w);
+ add_to_moid_text (b, " ..", w);
+ }
+ }
+ else if (IS_FLEX (n))
+ {
+ if ((*w) >= strlen ("FLEX .."))
+ {
+ add_to_moid_text (b, strop_flex, w);
+ add_to_moid_text (b, " ", w);
+ moid_to_string_2 (b, SUB (n), w, idf, indicant_value);
+ }
+ else
+ {
+ add_to_moid_text (b, strop_flex, w);
+ add_to_moid_text (b, " ..", w);
+ }
+ }
+ else if (IS_ROW (n))
+ {
+ size_t j = strlen ("[] ..") + (DIM (n) - 1) * strlen (",");
+
+ if ((*w) >= j)
+ {
+ size_t k = DIM (n) - 1;
+ add_to_moid_text (b, "[", w);
+ while (k-- > 0)
+ add_to_moid_text (b, ",", w);
+ add_to_moid_text (b, "] ", w);
+ moid_to_string_2 (b, SUB (n), w, idf, indicant_value);
+ }
+ else if (DIM (n) == 1)
+ {
+ add_to_moid_text (b, "[] ..", w);
+ }
+ else
+ {
+ size_t k = DIM (n);
+ add_to_moid_text (b, "[", w);
+ while (k--)
+ add_to_moid_text (b, ",", w);
+ add_to_moid_text (b, "] ..", w);
+ }
+ }
+ else if (IS_STRUCT (n))
+ {
+ size_t j = (strlen ("STRUCT ()") + (DIM (n) - 1)
+ * strlen (".., ") + strlen (".."));
+
+ if ((*w) >= j)
+ {
+ POSTULATE_T *save = A68 (postulates);
+ a68_make_postulate (&A68 (postulates), n, NO_MOID);
+ add_to_moid_text (b, strop_struct, w);
+ add_to_moid_text (b, " (", w);
+ pack_to_string (b, PACK (n), w, true, idf, indicant_value);
+ add_to_moid_text (b, ")", w);
+ a68_free_postulate_list (A68 (postulates), save);
+ A68 (postulates) = save;
+ }
+ else
+ {
+ size_t k = DIM (n);
+ add_to_moid_text (b, strop_struct, w);
+ add_to_moid_text (b, " (", w);
+ while (k-- > 0)
+ add_to_moid_text (b, ",", w);
+ add_to_moid_text (b, ")", w);
+ }
+ }
+ else if (IS_UNION (n))
+ {
+ size_t j = (strlen ("UNION ()") + (DIM (n) - 1)
+ * strlen (".., ") + strlen (".."));
+
+ if ((*w) >= j)
+ {
+ POSTULATE_T *save = A68 (postulates);
+ a68_make_postulate (&A68 (postulates), n, NO_MOID);
+ add_to_moid_text (b, strop_union, w);
+ add_to_moid_text (b, " (", w);
+ pack_to_string (b, PACK (n), w, false, idf, indicant_value);
+ add_to_moid_text (b, ")", w);
+ a68_free_postulate_list (A68 (postulates), save);
+ A68 (postulates) = save;
+ }
+ else
+ {
+ size_t k = DIM (n);
+ add_to_moid_text (b, strop_union, w);
+ add_to_moid_text (b, " (", w);
+ while (k-- > 0)
+ add_to_moid_text (b, ",", w);
+ add_to_moid_text (b, ")", w);
+ }
+ }
+ else if (IS (n, PROC_SYMBOL) && DIM (n) == 0)
+ {
+ if ((*w) >= strlen ("PROC .."))
+ {
+ add_to_moid_text (b, strop_proc, w);
+ add_to_moid_text (b, " ", w);
+ moid_to_string_2 (b, SUB (n), w, idf, indicant_value);
+ }
+ else
+ {
+ add_to_moid_text (b, strop_proc, w);
+ add_to_moid_text (b, " ..", w);
+ }
+ }
+ else if (IS (n, PROC_SYMBOL) && DIM (n) > 0)
+ {
+ size_t j = (strlen ("PROC () ..") + (DIM (n) - 1)
+ * strlen (".., ") + strlen (".."));
+
+ if ((*w) >= j)
+ {
+ POSTULATE_T *save = A68 (postulates);
+ a68_make_postulate (&A68 (postulates), n, NO_MOID);
+ add_to_moid_text (b, strop_proc, w);
+ add_to_moid_text (b, " (", w);
+ pack_to_string (b, PACK (n), w, false, idf, indicant_value);
+ add_to_moid_text (b, ") ", w);
+ moid_to_string_2 (b, SUB (n), w, idf, indicant_value);
+ a68_free_postulate_list (A68 (postulates), save);
+ A68 (postulates) = save;
+ }
+ else
+ {
+ size_t k = DIM (n);
+
+ add_to_moid_text (b, strop_proc, w);
+ add_to_moid_text (b, " (", w);
+ while (k-- > 0)
+ add_to_moid_text (b, ",", w);
+ add_to_moid_text (b, ") ..", w);
+ }
+ }
+ else if (IS (n, SERIES_MODE) || IS (n, STOWED_MODE))
+ {
+ size_t j = (strlen ("()") + (DIM (n) - 1)
+ * strlen (".., ") + strlen (".."));
+
+ if ((*w) >= j)
+ {
+ add_to_moid_text (b, "(", w);
+ pack_to_string (b, PACK (n), w, false, idf, indicant_value);
+ add_to_moid_text (b, ")", w);
+ }
+ else
+ {
+ size_t k = DIM (n);
+
+ add_to_moid_text (b, "(", w);
+ while (k-- > 0)
+ add_to_moid_text (b, ",", w);
+ add_to_moid_text (b, ")", w);
+ }
+ }
+ else
+ {
+ char str[SMALL_BUFFER_SIZE];
+ if (snprintf (str, (size_t) SMALL_BUFFER_SIZE, "\\%d", ATTRIBUTE (n)) < 0)
+ gcc_unreachable ();
+ add_to_moid_text (b, str, w);
+ }
+}
+
+/* Pretty-formatted mode N; W is a measure of width. */
+
+const char *
+a68_moid_to_string (MOID_T *n, size_t w, NODE_T *idf, bool indicant_value)
+{
+#define MAX_MTS 8
+ /* We use a static buffer of MAX_MTS strings. This value 8 should be safe.
+ No more than MAX_MTS calls can be pending in for instance printf. Instead
+ we could allocate each string on the heap but that leaks memory. */
+ static int mts_buff_ptr = 0;
+ static char mts_buff[8][BUFFER_SIZE];
+ char *a = &(mts_buff[mts_buff_ptr][0]);
+ mts_buff_ptr++;
+ if (mts_buff_ptr >= MAX_MTS)
+ mts_buff_ptr = 0;
+ a[0] = '\0';
+ if (w >= BUFFER_SIZE)
+ w = BUFFER_SIZE - 1;
+ A68 (postulates) = NO_POSTULATE;
+ if (n != NO_MOID)
+ moid_to_string_2 (a, n, &w, idf, indicant_value);
+ else
+ a68_bufcat (a, "null", BUFFER_SIZE);
+ return a;
+#undef MAX_MTS
+}
--- /dev/null
+/* Mode table management.
+ Copyright (C) 2001-2023 J. Marcel van der Veer.
+ Copyright (C) 2025 Jose E. Marchesi.
+
+ Original implementation by J. Marcel van der Veer.
+ Adapted for GCC by Jose E. Marchesi.
+
+ GCC is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ GCC is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING3. If not see
+ <http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+/*
+ * Mode collection, equivalencing and derived modes.
+ */
+
+/* Few forward references. */
+
+static MOID_T *get_mode_from_declarer (NODE_T *p);
+
+/*
+ * Mode service routines.
+ */
+
+/* Count bounds in declarer in tree. */
+
+static int
+count_bounds (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return 0;
+ else
+ {
+ if (IS (p, BOUND))
+ return 1 + count_bounds (NEXT (p));
+ else
+ return count_bounds (NEXT (p)) + count_bounds (SUB (p));
+ }
+}
+
+/* Count number of SHORTs or LONGs. */
+
+static int
+count_sizety (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return 0;
+ else if (IS (p, LONGETY))
+ return count_sizety (SUB (p)) + count_sizety (NEXT (p));
+ else if (IS (p, SHORTETY))
+ return count_sizety (SUB (p)) + count_sizety (NEXT (p));
+ else if (IS (p, LONG_SYMBOL))
+ return 1;
+ else if (IS (p, SHORT_SYMBOL))
+ return -1;
+ else
+ return 0;
+}
+
+/* Count moids in a pack. */
+
+int
+a68_count_pack_members (PACK_T *u)
+{
+ int k = 0;
+
+ for (; u != NO_PACK; FORWARD (u))
+ k++;
+ return k;
+}
+
+/* Replace a mode by its equivalent mode. */
+
+static void
+resolve_equivalent (MOID_T **m)
+{
+ while ((*m) != NO_MOID
+ && EQUIVALENT ((*m)) != NO_MOID
+ && (*m) != EQUIVALENT (*m))
+ {
+ (*m) = EQUIVALENT (*m);
+ }
+}
+
+/* Reset moid. */
+
+static void
+reset_moid_tree (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ MOID (p) = NO_MOID;
+ reset_moid_tree (SUB (p));
+ }
+}
+
+/* Renumber moids. */
+
+void
+a68_renumber_moids (MOID_T *p, int n)
+{
+ if (p != NO_MOID)
+ {
+ NUMBER (p) = n;
+ a68_renumber_moids (NEXT (p), n + 1);
+ }
+}
+
+/* See whether a mode equivalent to the mode M exists in the global mode table,
+ and return it. Return NO_MOID if no equivalent mode is found. */
+
+MOID_T *
+a68_search_equivalent_mode (MOID_T *m)
+{
+ for (MOID_T *head = TOP_MOID (&A68_JOB); head != NO_MOID; FORWARD (head))
+ {
+ if (a68_prove_moid_equivalence (head, m))
+ return head;
+ }
+
+ return NO_MOID;
+}
+
+/* Register mode in the global mode table, if mode is unique. */
+
+MOID_T *
+a68_register_extra_mode (MOID_T **z, MOID_T *u)
+{
+ /* If we already know this mode, return the existing entry; otherwise link it
+ in. */
+ for (MOID_T *head = TOP_MOID (&A68_JOB); head != NO_MOID; FORWARD (head))
+ {
+ if (a68_prove_moid_equivalence (head, u))
+ return head;
+ }
+
+ /* Link to chain and exit. */
+ NUMBER (u) = A68 (mode_count)++;
+ NEXT (u) = (*z);
+ return *z = u;
+}
+
+/* Create a new mode. */
+
+MOID_T *
+a68_create_mode (int att, int dim, NODE_T *node, MOID_T *sub, PACK_T *pack)
+{
+ MOID_T *new_mode = a68_new_moid ();
+
+ if (sub == NO_MOID)
+ {
+ if (att == REF_SYMBOL
+ || att == FLEX_SYMBOL
+ || att == ROW_SYMBOL)
+ gcc_unreachable ();
+ }
+
+ USE (new_mode) = false;
+ ATTRIBUTE (new_mode) = att;
+ DIM (new_mode) = dim;
+ NODE (new_mode) = node;
+ HAS_ROWS (new_mode) = (att == ROW_SYMBOL);
+ SUB (new_mode) = sub;
+ PACK (new_mode) = pack;
+ NEXT (new_mode) = NO_MOID;
+ EQUIVALENT (new_mode) = NO_MOID;
+ SLICE (new_mode) = NO_MOID;
+ DEFLEXED (new_mode) = NO_MOID;
+ NAME (new_mode) = NO_MOID;
+ MULTIPLE (new_mode) = NO_MOID;
+ ROWED (new_mode) = NO_MOID;
+
+ return new_mode;
+}
+
+/* Create a new mode and add it to chain Z. */
+
+MOID_T *
+a68_add_mode (MOID_T **z, int att, int dim, NODE_T *node, MOID_T *sub, PACK_T *pack)
+{
+ MOID_T *new_mode = a68_create_mode (att, dim, node, sub, pack);
+ return a68_register_extra_mode (z, new_mode);
+}
+
+/* Contract a UNION. */
+
+void
+a68_contract_union (MOID_T *u)
+{
+ for (PACK_T *s = PACK (u); s != NO_PACK; FORWARD (s))
+ {
+ PACK_T *t = s;
+
+ while (t != NO_PACK)
+ {
+ if (NEXT (t) != NO_PACK && MOID (NEXT (t)) == MOID (s))
+ {
+ MOID (t) = MOID (t);
+ NEXT (t) = NEXT_NEXT (t);
+ }
+ else
+ FORWARD (t);
+ }
+ }
+}
+
+/* Absorb UNION pack. */
+
+PACK_T *
+a68_absorb_union_pack (PACK_T * u)
+{
+ PACK_T *z;
+ bool siga;
+
+ do
+ {
+ z = NO_PACK;
+ siga = false;
+ for (PACK_T *t = u; t != NO_PACK; FORWARD (t))
+ {
+ if (IS (MOID (t), UNION_SYMBOL))
+ {
+ siga = true;
+ for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s))
+ (void) a68_add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
+ }
+ else
+ {
+ (void) a68_add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
+ }
+ }
+ u = z;
+ }
+ while (siga);
+ return z;
+}
+
+/* Add row and its slices to chain, recursively. */
+
+static MOID_T *
+add_row (MOID_T **p, int dim, MOID_T *sub, NODE_T *n, bool derivate)
+{
+ MOID_T *q = a68_add_mode (p, ROW_SYMBOL, dim, n, sub, NO_PACK);
+
+ DERIVATE (q) |= derivate;
+ if (dim > 1)
+ SLICE (q) = add_row (&NEXT (q), dim - 1, sub, n, derivate);
+ else
+ SLICE (q) = sub;
+ return q;
+}
+
+/* Add a moid to a pack, maybe with a (field) name. */
+
+void
+a68_add_mode_to_pack (PACK_T **p, MOID_T *m, const char *text, NODE_T *node)
+{
+ PACK_T *z = a68_new_pack ();
+
+ MOID (z) = m;
+ TEXT (z) = text;
+ NODE (z) = node;
+ NEXT (z) = *p;
+ PREVIOUS (z) = NO_PACK;
+ if (NEXT (z) != NO_PACK)
+ PREVIOUS (NEXT (z)) = z;
+
+ /* Link in chain. */
+ *p = z;
+}
+
+/* Add a moid to a pack, maybe with a (field) name. */
+
+void
+a68_add_mode_to_pack_end (PACK_T **p, MOID_T *m, const char *text, NODE_T *node)
+{
+ PACK_T *z = a68_new_pack ();
+
+ MOID (z) = m;
+ TEXT (z) = text;
+ NODE (z) = node;
+ NEXT (z) = NO_PACK;
+ if (NEXT (z) != NO_PACK)
+ PREVIOUS (NEXT (z)) = z;
+
+ /* Link in chain. */
+ while ((*p) != NO_PACK)
+ p = &(NEXT (*p));
+ PREVIOUS (z) = (*p);
+ (*p) = z;
+}
+
+/* Absorb UNION members. */
+
+static void
+absorb_unions (MOID_T *m)
+{
+ /* UNION (A, UNION (B, C)) = UNION (A, B, C) or
+ UNION (A, UNION (A, B)) = UNION (A, B). */
+ for (; m != NO_MOID; FORWARD (m))
+ {
+ if (IS (m, UNION_SYMBOL))
+ PACK (m) = a68_absorb_union_pack (PACK (m));
+ }
+}
+
+/* Contract UNIONs. */
+
+static void
+contract_unions (MOID_T *m)
+{
+ /* UNION (A, B, A) -> UNION (A, B). */
+ for (; m != NO_MOID; FORWARD (m))
+ {
+ if (IS (m, UNION_SYMBOL) && EQUIVALENT (m) == NO_MOID)
+ a68_contract_union (m);
+ }
+}
+
+/*
+ * Routines to collect MOIDs from the program text.
+ */
+
+/* Search standard mode in standard environ. */
+
+static MOID_T *
+search_standard_mode (int sizety, NODE_T *indicant)
+{
+ /* Search standard mode. */
+ for (MOID_T *p = TOP_MOID (&A68_JOB); p != NO_MOID; FORWARD (p))
+ {
+ if (IS (p, STANDARD)
+ && DIM (p) == sizety
+ && NSYMBOL (NODE (p)) == NSYMBOL (indicant))
+ return p;
+ }
+
+ /* Map onto greater precision. */
+ if (sizety < 0)
+ return search_standard_mode (sizety + 1, indicant);
+ else if (sizety > 0)
+ return search_standard_mode (sizety - 1, indicant);
+ else
+ return NO_MOID;
+}
+
+/* Collect mode from STRUCT field. */
+
+static void
+get_mode_from_struct_field (NODE_T *p, PACK_T **u)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, IDENTIFIER))
+ {
+ ATTRIBUTE (p) = FIELD_IDENTIFIER;
+ (void) a68_add_mode_to_pack (u, NO_MOID, NSYMBOL (p), p);
+ }
+ else if (IS (p, DECLARER))
+ {
+ MOID_T *new_one = get_mode_from_declarer (p);
+
+ get_mode_from_struct_field (NEXT (p), u);
+ for (PACK_T *t = *u; t && MOID (t) == NO_MOID; FORWARD (t))
+ {
+ MOID (t) = new_one;
+ MOID (NODE (t)) = new_one;
+ }
+ }
+ else
+ {
+ get_mode_from_struct_field (NEXT (p), u);
+ get_mode_from_struct_field (SUB (p), u);
+ }
+ }
+}
+
+/* Collect MODE from formal pack. */
+
+static void
+get_mode_from_formal_pack (NODE_T *p, PACK_T **u)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, DECLARER))
+ {
+ get_mode_from_formal_pack (NEXT (p), u);
+ MOID_T *z = get_mode_from_declarer (p);
+ (void) a68_add_mode_to_pack (u, z, NO_TEXT, p);
+ }
+ else
+ {
+ get_mode_from_formal_pack (NEXT (p), u);
+ get_mode_from_formal_pack (SUB (p), u);
+ }
+ }
+}
+
+/* Collect MODE or VOID from formal UNION pack. */
+
+static void
+get_mode_from_union_pack (NODE_T *p, PACK_T **u)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, DECLARER) || IS (p, VOID_SYMBOL))
+ {
+ get_mode_from_union_pack (NEXT (p), u);
+ MOID_T *z = get_mode_from_declarer (p);
+ (void) a68_add_mode_to_pack (u, z, NO_TEXT, p);
+ }
+ else
+ {
+ get_mode_from_union_pack (NEXT (p), u);
+ get_mode_from_union_pack (SUB (p), u);
+ }
+ }
+}
+
+/* Collect mode from PROC, OP pack. */
+
+static void
+get_mode_from_routine_pack (NODE_T *p, PACK_T **u)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, IDENTIFIER))
+ (void) a68_add_mode_to_pack (u, NO_MOID, NO_TEXT, p);
+ else if (IS (p, DECLARER))
+ {
+ MOID_T *z = get_mode_from_declarer (p);
+
+ for (PACK_T *t = *u; t != NO_PACK && MOID (t) == NO_MOID; FORWARD (t))
+ {
+ MOID (t) = z;
+ MOID (NODE (t)) = z;
+ }
+ (void) a68_add_mode_to_pack (u, z, NO_TEXT, p);
+ }
+ else
+ {
+ get_mode_from_routine_pack (NEXT (p), u);
+ get_mode_from_routine_pack (SUB (p), u);
+ }
+ }
+}
+
+/* Collect MODE from DECLARER. */
+
+static MOID_T *
+get_mode_from_declarer (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return NO_MOID;
+ else
+ {
+ if (IS (p, DECLARER))
+ {
+ if (MOID (p) != NO_MOID)
+ return MOID (p);
+ else
+ return MOID (p) = get_mode_from_declarer (SUB (p));
+ }
+ else
+ {
+ if (IS (p, VOID_SYMBOL))
+ {
+ MOID (p) = M_VOID;
+ return MOID (p);
+ }
+ else if (IS (p, LONGETY))
+ {
+ if (a68_whether (p, LONGETY, INDICANT, STOP))
+ {
+ int k = count_sizety (SUB (p));
+ MOID (p) = search_standard_mode (k, NEXT (p));
+ return MOID (p);
+ }
+ else
+ {
+ return NO_MOID;
+ }
+ }
+ else if (IS (p, SHORTETY))
+ {
+ if (a68_whether (p, SHORTETY, INDICANT, STOP))
+ {
+ int k = count_sizety (SUB (p));
+ MOID (p) = search_standard_mode (k, NEXT (p));
+ return MOID (p);
+ }
+ else
+ return NO_MOID;
+ }
+ else if (IS (p, INDICANT))
+ {
+ MOID_T *q = search_standard_mode (0, p);
+ if (q != NO_MOID)
+ MOID (p) = q;
+ else
+ {
+ /* Position of definition tells indicants apart. */
+ TAG_T *y = a68_find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
+ if (y == NO_TAG)
+ a68_error ( p, "tag Z has not been declared properly", NSYMBOL (p));
+ else
+ MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), INDICANT, 0, NODE (y),
+ NO_MOID, NO_PACK);
+ }
+ return MOID (p);
+ }
+ else if (IS_REF (p))
+ {
+ MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+ MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK);
+ return MOID (p);
+ }
+ else if (IS_FLEX (p))
+ {
+ MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+ MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, p, new_one, NO_PACK);
+ SLICE (MOID (p)) = SLICE (new_one);
+ return MOID (p);
+ }
+ else if (IS (p, FORMAL_BOUNDS))
+ {
+ MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+ MOID (p) = add_row (&TOP_MOID (&A68_JOB),
+ 1 + a68_count_formal_bounds (SUB (p)), new_one, p, false);
+ return MOID (p);
+ }
+ else if (IS (p, BOUNDS))
+ {
+ MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+ MOID (p) = add_row (&TOP_MOID (&A68_JOB), count_bounds (SUB (p)), new_one, p, false);
+ return MOID (p);
+ }
+ else if (IS (p, STRUCT_SYMBOL))
+ {
+ PACK_T *u = NO_PACK;
+ get_mode_from_struct_field (NEXT (p), &u);
+ MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB),
+ STRUCT_SYMBOL, a68_count_pack_members (u), p, NO_MOID, u);
+ return MOID (p);
+ }
+ else if (IS (p, UNION_SYMBOL))
+ {
+ PACK_T *u = NO_PACK;
+ get_mode_from_union_pack (NEXT (p), &u);
+ MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB),
+ UNION_SYMBOL, a68_count_pack_members (u), p, NO_MOID, u);
+ return MOID (p);
+ }
+ else if (IS (p, PROC_SYMBOL))
+ {
+ NODE_T *save = p;
+ PACK_T *u = NO_PACK;
+ if (IS (NEXT (p), FORMAL_DECLARERS))
+ {
+ get_mode_from_formal_pack (SUB_NEXT (p), &u);
+ FORWARD (p);
+ }
+ MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+ MOID (p) =
+ a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (u), save, new_one, u);
+ MOID (save) = MOID (p);
+ return MOID (p);
+ }
+ else
+ return NO_MOID;
+ }
+ }
+}
+
+/* Collect MODEs from a routine-text header. */
+
+static MOID_T *
+get_mode_from_routine_text (NODE_T *p)
+{
+ PACK_T *u = NO_PACK;
+ NODE_T *q = p;
+
+ if (IS (p, PARAMETER_PACK))
+ {
+ get_mode_from_routine_pack (SUB (p), &u);
+ FORWARD (p);
+ }
+ MOID_T *n = get_mode_from_declarer (p);
+ return a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (u), q, n, u);
+}
+
+/* Collect modes from operator-plan. */
+
+static MOID_T *
+get_mode_from_operator (NODE_T *p)
+{
+ PACK_T *u = NO_PACK;
+ NODE_T *save = p;
+
+ if (IS (NEXT (p), FORMAL_DECLARERS))
+ {
+ get_mode_from_formal_pack (SUB_NEXT (p), &u);
+ FORWARD (p);
+ }
+ MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+ MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (u), save, new_one, u);
+ return MOID (p);
+}
+
+/* Collect mode from denotation. */
+
+static void
+get_mode_from_denotation (NODE_T *p, int sizety)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, ROW_CHAR_DENOTATION))
+ {
+ const char *s = NSYMBOL (p);
+ size_t len = strlen (s);
+
+ if (len == 1
+ || (len == 2 && s[0] == '\'')
+ || (len == 8 && s[0] == '\'' && s[1] == '(' && s[2] == 'u')
+ || (len == 12 && s[0] == '\'' && s[1] == '(' && s[2] == 'U'))
+ {
+ MOID (p) = M_CHAR;
+ }
+ else
+ MOID (p) = M_ROW_CHAR;
+ }
+ else if (IS (p, TRUE_SYMBOL) || IS (p, FALSE_SYMBOL))
+ {
+ MOID (p) = M_BOOL;
+ }
+ else if (IS (p, INT_DENOTATION))
+ {
+ if (sizety == -2)
+ MOID (p) = M_SHORT_SHORT_INT;
+ else if (sizety == -1)
+ MOID (p) = M_SHORT_INT;
+ else if (sizety == 0)
+ MOID (p) = M_INT;
+ else if (sizety == 1)
+ MOID (p) = M_LONG_INT;
+ else if (sizety == 2)
+ MOID (p) = M_LONG_LONG_INT;
+ else
+ MOID (p) = (sizety > 0 ? M_LONG_LONG_INT : M_INT);
+ }
+ else if (IS (p, REAL_DENOTATION))
+ {
+ if (sizety == 0)
+ MOID (p) = M_REAL;
+ else if (sizety == 1)
+ MOID (p) = M_LONG_REAL;
+ else if (sizety == 2)
+ MOID (p) = M_LONG_LONG_REAL;
+ else
+ MOID (p) = (sizety > 0 ? M_LONG_LONG_REAL : M_REAL);
+ }
+ else if (IS (p, BITS_DENOTATION))
+ {
+ if (sizety == -2)
+ MOID (p) = M_SHORT_SHORT_BITS;
+ else if (sizety == -1)
+ MOID (p) = M_SHORT_BITS;
+ else if (sizety == 0)
+ MOID (p) = M_BITS;
+ else if (sizety == 1)
+ MOID (p) = M_LONG_BITS;
+ else if (sizety == 2)
+ MOID (p) = M_LONG_LONG_BITS;
+ else
+ MOID (p) = (sizety > 0 ? M_LONG_LONG_BITS : M_BITS);
+ }
+ else if (IS (p, LONGETY) || IS (p, SHORTETY))
+ {
+ get_mode_from_denotation (NEXT (p), count_sizety (SUB (p)));
+ MOID (p) = MOID (NEXT (p));
+ }
+ else if (IS (p, EMPTY_SYMBOL))
+ {
+ MOID (p) = M_VOID;
+ }
+ }
+}
+
+/* Collect modes from the syntax tree. */
+
+static void
+get_modes_from_tree (NODE_T *p, int attribute)
+{
+ for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+ {
+ if (IS (q, VOID_SYMBOL))
+ MOID (q) = M_VOID;
+ else if (IS (q, DECLARER))
+ {
+ if (attribute == VARIABLE_DECLARATION)
+ {
+ MOID_T *new_one = get_mode_from_declarer (q);
+ MOID (q) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
+ }
+ else
+ MOID (q) = get_mode_from_declarer (q);
+ }
+ else if (IS (q, ROUTINE_TEXT))
+ {
+ MOID (q) = get_mode_from_routine_text (SUB (q));
+ }
+ else if (IS (q, OPERATOR_PLAN))
+ {
+ MOID (q) = get_mode_from_operator (SUB (q));
+ }
+ else if (a68_is_one_of (q, LOC_SYMBOL, HEAP_SYMBOL, STOP))
+ {
+ if (attribute == GENERATOR)
+ {
+ MOID_T *new_one = get_mode_from_declarer (NEXT (q));
+ MOID (NEXT (q)) = new_one;
+ MOID (q) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
+ }
+ }
+ else
+ {
+ if (attribute == DENOTATION)
+ get_mode_from_denotation (q, 0);
+ }
+ }
+
+ if (attribute != DENOTATION)
+ {
+ for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+ {
+ if (SUB (q) != NO_NODE)
+ get_modes_from_tree (SUB (q), ATTRIBUTE (q));
+ }
+ }
+}
+
+//! @brief Collect modes from proc variables.
+
+static void
+get_mode_from_proc_variables (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, PROCEDURE_VARIABLE_DECLARATION))
+ {
+ get_mode_from_proc_variables (SUB (p));
+ get_mode_from_proc_variables (NEXT (p));
+ }
+ else if (IS (p, QUALIFIER) || IS (p, PROC_SYMBOL) || IS (p, COMMA_SYMBOL))
+ {
+ get_mode_from_proc_variables (NEXT (p));
+ }
+ else if (IS (p, DEFINING_IDENTIFIER))
+ {
+ MOID_T *new_one = MOID (NEXT_NEXT (p));
+ MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK);
+ }
+ }
+}
+
+/* Collect modes from proc variable declarations. */
+
+static void
+get_mode_from_proc_var_declarations_tree (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ get_mode_from_proc_var_declarations_tree (SUB (p));
+
+ if (IS (p, PROCEDURE_VARIABLE_DECLARATION))
+ get_mode_from_proc_variables (p);
+ }
+}
+
+/*
+ * Various routines to test modes.
+ */
+
+/* Whether a mode declaration refers to self or relates to void.
+ This uses Lindsey's ying-yang algorithm. */
+
+static bool
+is_well_formed (MOID_T *def, MOID_T *z, bool yin, bool yang, bool video)
+{
+ if (z == NO_MOID)
+ return false;
+ else if (yin && yang)
+ return z == M_VOID ? video : true;
+ else if (z == M_VOID)
+ return video;
+ else if (IS (z, STANDARD))
+ return true;
+ else if (IS (z, INDICANT))
+ {
+ if (def == NO_MOID)
+ {
+ /* Check an applied indicant for relation to VOID. */
+ while (z != NO_MOID)
+ z = EQUIVALENT (z);
+ if (z == M_VOID)
+ return video;
+ else
+ return true;
+ }
+ else
+ {
+ if (z == def || USE (z))
+ return yin && yang;
+ else
+ {
+ USE (z) = true;
+ bool wwf = is_well_formed (def, EQUIVALENT (z), yin, yang, video);
+ USE (z) = false;
+ return wwf;
+ }
+ }
+ }
+ else if (IS_REF (z))
+ return is_well_formed (def, SUB (z), true, yang, false);
+ else if (IS (z, PROC_SYMBOL))
+ return PACK (z) != NO_PACK ? true : is_well_formed (def, SUB (z), true, yang, true);
+ else if (IS_ROW (z))
+ return is_well_formed (def, SUB (z), yin, yang, false);
+ else if (IS_FLEX (z))
+ return is_well_formed (def, SUB (z), yin, yang, false);
+ else if (IS (z, STRUCT_SYMBOL))
+ {
+ for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s))
+ {
+ if (!is_well_formed (def, MOID (s), yin, true, false))
+ return false;
+ }
+ return true;
+ }
+ else if (IS (z, UNION_SYMBOL))
+ {
+ for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s))
+ {
+ if (!is_well_formed (def, MOID (s), yin, yang, true))
+ return false;
+ }
+ return true;
+ }
+ else
+ {
+ return false;
+ }
+}
+
+/* Replace a mode by its equivalent mode (walk chain). */
+
+static void
+resolve_eq_members (MOID_T *q)
+{
+ resolve_equivalent (&SUB (q));
+ resolve_equivalent (&DEFLEXED (q));
+ resolve_equivalent (&MULTIPLE (q));
+ resolve_equivalent (&NAME (q));
+ resolve_equivalent (&SLICE (q));
+ resolve_equivalent (&TRIM (q));
+ resolve_equivalent (&ROWED (q));
+ for (PACK_T *p = PACK (q); p != NO_PACK; FORWARD (p))
+ resolve_equivalent (&MOID (p));
+}
+
+/* Track equivalent tags. */
+
+static void
+resolve_eq_tags (TAG_T *z)
+{
+ for (; z != NO_TAG; FORWARD (z))
+ {
+ if (MOID (z) != NO_MOID)
+ resolve_equivalent (&MOID (z));
+ }
+}
+
+/* Bind modes in syntax tree. */
+
+static void
+bind_modes (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ resolve_equivalent (&MOID (p));
+
+ if (SUB (p) != NO_NODE && a68_is_new_lexical_level (p))
+ {
+ TABLE_T *s = TABLE (SUB (p));
+ for (TAG_T *z = INDICANTS (s); z != NO_TAG; FORWARD (z))
+ {
+ if (NODE (z) != NO_NODE)
+ {
+ resolve_equivalent (&MOID (NEXT_NEXT (NODE (z))));
+ MOID (z) = MOID (NEXT_NEXT (NODE (z)));
+ MOID (NODE (z)) = MOID (z);
+ }
+ }
+ }
+ bind_modes (SUB (p));
+ }
+}
+
+/* Routines for calculating subordinates for selections, for instance selection
+ from REF STRUCT (A) yields REF A fields and selection from [] STRUCT (A)
+ yields [] A fields. */
+
+/* Make name pack.
+ Given a pack with modes: M1, M2, ...
+ Build a pack with modes: REF M1, REF M2, ... */
+
+static void
+make_name_pack (PACK_T *src, PACK_T **dst, MOID_T **p)
+{
+ if (src != NO_PACK)
+ {
+ make_name_pack (NEXT (src), dst, p);
+ MOID_T *z = a68_add_mode (p, REF_SYMBOL, 0, NO_NODE, MOID (src), NO_PACK);
+ (void) a68_add_mode_to_pack (dst, z, TEXT (src), NODE (src));
+ }
+}
+
+/* Make flex multiple row pack.
+ Given a pack with modes: M1, M2, ...
+ Build a pack with modes: []M1, []M2, ... */
+
+static void
+make_flex_multiple_row_pack (PACK_T *src, PACK_T **dst, MOID_T **p, int dim)
+{
+ if (src != NO_PACK)
+ {
+ make_flex_multiple_row_pack (NEXT (src), dst, p, dim);
+ MOID_T *z = add_row (p, dim, MOID (src), NO_NODE, false);
+ z = a68_add_mode (p, FLEX_SYMBOL, 0, NO_NODE, z, NO_PACK);
+ (void) a68_add_mode_to_pack (dst, z, TEXT (src), NODE (src));
+ }
+}
+
+/* Make name struct. */
+
+static MOID_T *
+make_name_struct (MOID_T *m, MOID_T **p)
+{
+ PACK_T *u = NO_PACK;
+ make_name_pack (PACK (m), &u, p);
+ return a68_add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
+}
+
+/* Make name row. */
+
+static MOID_T *
+make_name_row (MOID_T *m, MOID_T **p)
+{
+ if (SLICE (m) != NO_MOID)
+ return a68_add_mode (p, REF_SYMBOL, 0, NO_NODE, SLICE (m), NO_PACK);
+ else if (SUB (m) != NO_MOID)
+ return a68_add_mode (p, REF_SYMBOL, 0, NO_NODE, SUB (m), NO_PACK);
+ else
+ /* weird, FLEX INT or so ... */
+ return NO_MOID;
+}
+
+/* Make multiple row pack. */
+
+static void
+make_multiple_row_pack (PACK_T *src, PACK_T **dst, MOID_T **p, int dim)
+{
+ if (src != NO_PACK)
+ {
+ make_multiple_row_pack (NEXT (src), dst, p, dim);
+ (void) a68_add_mode_to_pack (dst, add_row (p, dim, MOID (src), NO_NODE, false),
+ TEXT (src), NODE (src));
+ }
+}
+
+/* Make flex multiple struct. */
+
+static MOID_T *
+make_flex_multiple_struct (MOID_T *m, MOID_T **p, int dim)
+{
+ PACK_T *u = NO_PACK;
+ make_flex_multiple_row_pack (PACK (m), &u, p, dim);
+ return a68_add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
+}
+
+/* Make multiple struct. */
+
+static MOID_T *
+make_multiple_struct (MOID_T *m, MOID_T **p, int dim)
+{
+ PACK_T *u = NO_PACK;
+ make_multiple_row_pack (PACK (m), &u, p, dim);
+ return a68_add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
+}
+
+/* Whether mode has row. */
+
+static bool
+is_mode_has_row (MOID_T *m)
+{
+ if (IS (m, STRUCT_SYMBOL) || IS (m, UNION_SYMBOL))
+ {
+ bool k = false;
+
+ for (PACK_T *p = PACK (m); p != NO_PACK && k == false; FORWARD (p))
+ {
+ HAS_ROWS (MOID (p)) = is_mode_has_row (MOID (p));
+ k |= (HAS_ROWS (MOID (p)));
+ }
+ return k;
+ }
+ else
+ return (HAS_ROWS (m) || IS_ROW (m) || IS_FLEX (m));
+}
+
+/* Compute derived modes. */
+
+static void
+compute_derived_modes (MODULE_T *mod)
+{
+ MOID_T *z;
+ int len = 0, nlen = 1;
+
+ /* UNION things. */
+ absorb_unions (TOP_MOID (mod));
+ contract_unions (TOP_MOID (mod));
+ /* The for-statement below prevents an endless loop. */
+ for (int k = 1; k <= 10 && len != nlen; k++)
+ {
+ /* Make deflexed modes. */
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (SUB (z) != NO_MOID)
+ {
+ if (IS_REF_FLEX (z) && DEFLEXED (SUB_SUB (z)) != NO_MOID)
+ DEFLEXED (z) = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z),
+ DEFLEXED (SUB_SUB (z)), NO_PACK);
+ else if (IS_REF (z) && DEFLEXED (SUB (z)) != NO_MOID)
+ DEFLEXED (z) = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z),
+ DEFLEXED (SUB (z)), NO_PACK);
+ else if (IS_ROW (z) && DEFLEXED (SUB (z)) != NO_MOID)
+ DEFLEXED (z) = a68_add_mode (&TOP_MOID (mod), ROW_SYMBOL, DIM (z), NODE (z),
+ DEFLEXED (SUB (z)), NO_PACK);
+ else if (IS_FLEX (z) && DEFLEXED (SUB (z)) != NO_MOID)
+ DEFLEXED (z) = DEFLEXED (SUB (z));
+ else if (IS_FLEX (z))
+ DEFLEXED (z) = SUB (z);
+ else
+ DEFLEXED (z) = z;
+ }
+ }
+
+ /* Derived modes for stowed modes. */
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (NAME (z) == NO_MOID && IS_REF (z))
+ {
+ if (IS (SUB (z), STRUCT_SYMBOL))
+ NAME (z) = make_name_struct (SUB (z), &TOP_MOID (mod));
+ else if (IS_ROW (SUB (z)))
+ NAME (z) = make_name_row (SUB (z), &TOP_MOID (mod));
+ else if (IS_FLEX (SUB (z)) && SUB_SUB (z) != NO_MOID)
+ NAME (z) = make_name_row (SUB_SUB (z), &TOP_MOID (mod));
+ }
+
+ if (MULTIPLE (z) != NO_MOID)
+ ;
+ else if (IS_REF (z))
+ {
+ if (MULTIPLE (SUB (z)) != NO_MOID)
+ MULTIPLE (z) = make_name_struct (MULTIPLE (SUB (z)), &TOP_MOID (mod));
+ }
+ else if (IS_ROW (z))
+ {
+ if (IS (SUB (z), STRUCT_SYMBOL))
+ MULTIPLE (z) = make_multiple_struct (SUB (z), &TOP_MOID (mod), DIM (z));
+ }
+ }
+
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (TRIM (z) == NO_MOID && IS_FLEX (z))
+ TRIM (z) = SUB (z);
+ if (TRIM (z) == NO_MOID && IS_REF_FLEX (z))
+ TRIM (z) = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), SUB_SUB (z), NO_PACK);
+ }
+
+ /* Fill out stuff for rows, f.i. inverse relations. */
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (IS_ROW (z) && DIM (z) > 0 && SUB (z) != NO_MOID && !DERIVATE (z))
+ (void) add_row (&TOP_MOID (mod), DIM (z) + 1, SUB (z), NODE (z), true);
+ else if (IS_REF (z) && IS (SUB (z), ROW_SYMBOL) && !DERIVATE (SUB (z)))
+ {
+ MOID_T *x = add_row (&TOP_MOID (mod), DIM (SUB (z)) + 1, SUB_SUB (z), NODE (SUB (z)), true);
+ MOID_T *y = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), x, NO_PACK);
+ NAME (y) = z;
+ }
+ }
+
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (IS_ROW (z) && SLICE (z) != NO_MOID)
+ ROWED (SLICE (z)) = z;
+ if (IS_REF (z))
+ {
+ MOID_T *y = SUB (z);
+ if (SLICE (y) != NO_MOID && IS_ROW (SLICE (y)) && NAME (z) != NO_MOID)
+ ROWED (NAME (z)) = z;
+ }
+ }
+
+ bind_modes (TOP_NODE (mod));
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (IS (z, INDICANT) && NODE (z) != NO_NODE)
+ EQUIVALENT (z) = MOID (NODE (z));
+ }
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ resolve_eq_members (z);
+ resolve_eq_tags (INDICANTS (A68_STANDENV));
+ resolve_eq_tags (IDENTIFIERS (A68_STANDENV));
+ resolve_eq_tags (OPERATORS (A68_STANDENV));
+ resolve_equivalent (&M_STRING);
+ resolve_equivalent (&M_COMPLEX);
+ resolve_equivalent (&M_LONG_COMPLEX);
+ resolve_equivalent (&M_LONG_LONG_COMPLEX);
+ resolve_equivalent (&M_SEMA);
+ /* UNION members could be resolved. */
+ absorb_unions (TOP_MOID (mod));
+ contract_unions (TOP_MOID (mod));
+ /* FLEX INDICANT could be resolved. */
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (IS_FLEX (z) && SUB (z) != NO_MOID)
+ {
+ if (SUB_SUB (z) != NO_MOID && IS (SUB_SUB (z), STRUCT_SYMBOL))
+ MULTIPLE (z) = make_flex_multiple_struct (SUB_SUB (z), &TOP_MOID (mod), DIM (SUB (z)));
+ }
+ }
+ /* See what new known modes we have generated by resolving.. */
+ for (z = TOP_MOID (mod); z != STANDENV_MOID (&A68_JOB); FORWARD (z))
+ {
+ MOID_T *v;
+
+ for (v = NEXT (z); v != NO_MOID; FORWARD (v))
+ {
+ if (a68_prove_moid_equivalence (z, v))
+ {
+ EQUIVALENT (z) = v;
+ EQUIVALENT (v) = NO_MOID;
+ }
+ }
+ }
+
+ /* Count the modes to check self consistency. */
+ len = nlen;
+ for (nlen = 0, z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ nlen++;
+ }
+
+ gcc_assert (M_STRING == M_FLEX_ROW_CHAR);
+
+ /* Find out what modes contain rows. */
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ HAS_ROWS (z) = is_mode_has_row (z);
+
+ /* Check flexible modes. */
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (IS_FLEX (z) && !IS (SUB (z), ROW_SYMBOL))
+ a68_error (NODE (z), "M does not specify a well formed mode", z);
+ }
+
+ /* Check on fields in structured modes f.i. STRUCT (REAL x, INT n, REAL x) is
+ wrong. */
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (IS (z, STRUCT_SYMBOL) && EQUIVALENT (z) == NO_MOID)
+ {
+ PACK_T *s = PACK (z);
+
+ for (; s != NO_PACK; FORWARD (s))
+ {
+ PACK_T *t = NEXT (s);
+ bool x = true;
+
+ for (t = NEXT (s); t != NO_PACK && x; FORWARD (t))
+ {
+ if (TEXT (s) == TEXT (t))
+ {
+ a68_error (NODE (z), "multiple declaration of field S");
+ while (NEXT (s) != NO_PACK && TEXT (NEXT (s)) == TEXT (t))
+ FORWARD (s);
+ x = false;
+ }
+ }
+ }
+ }
+ }
+
+ /* Various union test. */
+ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (IS (z, UNION_SYMBOL) && EQUIVALENT (z) == NO_MOID)
+ {
+ PACK_T *s = PACK (z);
+ /* Discard unions with one member. */
+ if (a68_count_pack_members (s) == 1)
+ a68_error (NODE (z), "M must have at least two components", z);
+ /* Discard incestuous unions with firmly related modes. */
+ for (; s != NO_PACK; FORWARD (s))
+ {
+ PACK_T *t;
+
+ for (t = NEXT (s); t != NO_PACK; FORWARD (t))
+ {
+ if (MOID (t) != MOID (s))
+ {
+ if (a68_is_firm (MOID (s), MOID (t)))
+ a68_error (NODE (z), "M has firmly related components", z);
+ }
+ }
+ }
+
+ /* Discard incestuous unions with firmly related subsets. */
+ for (s = PACK (z); s != NO_PACK; FORWARD (s))
+ {
+ MOID_T *n = a68_depref_completely (MOID (s));
+
+ if (IS (n, UNION_SYMBOL) && a68_is_subset (n, z, NO_DEFLEXING))
+ a68_error (NODE (z), "M has firmly related subset M", z, n);
+ }
+ }
+ }
+
+ /* Wrap up and exit. */
+ a68_free_postulate_list (A68 (top_postulate), NO_POSTULATE);
+ A68 (top_postulate) = NO_POSTULATE;
+}
+
+/* Make list of all modes in the program. */
+
+void
+a68_make_moid_list (MODULE_T *mod)
+{
+ bool cont = true;
+
+ /* Collect modes from the syntax tree. */
+ reset_moid_tree (TOP_NODE (mod));
+ get_modes_from_tree (TOP_NODE (mod), STOP);
+ get_mode_from_proc_var_declarations_tree (TOP_NODE (mod));
+
+ /* Connect indicants to their declarers. */
+ for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (IS (z, INDICANT))
+ {
+ NODE_T *u = NODE (z);
+ gcc_assert (NEXT (u) != NO_NODE);
+ gcc_assert (NEXT_NEXT (u) != NO_NODE);
+ gcc_assert (MOID (NEXT_NEXT (u)) != NO_MOID);
+ EQUIVALENT (z) = MOID (NEXT_NEXT (u));
+ }
+ }
+
+ /* Checks on wrong declarations. */
+ for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ USE (z) = false;
+
+ for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID)
+ {
+ if (!is_well_formed (z, EQUIVALENT (z), false, false, true))
+ {
+ a68_error (NODE (z), "M does not specify a well formed mode", z);
+ cont = false;
+ }
+ }
+ }
+
+ for (MOID_T *z = TOP_MOID (mod); cont && z != NO_MOID; FORWARD (z))
+ {
+ if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID)
+ ;
+ else if (NODE (z) != NO_NODE)
+ {
+ if (!is_well_formed (NO_MOID, z, false, false, true))
+ a68_error (NODE (z), "M does not specify a well formed mode", z);
+ }
+ }
+
+ for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+ {
+ if (USE (z))
+ gcc_unreachable ();
+ }
+
+ if (ERROR_COUNT (mod) != 0)
+ return;
+
+ compute_derived_modes (mod);
+ a68_init_postulates ();
+}
--- /dev/null
+/* Mode checker routines.
+ Copyright (C) 2001-2023 J. Marcel van der Veer.
+ Copyright (C) 2025 Jose E. Marchesi.
+
+ Original implementation by J. Marcel van der Veer.
+ Adapted for GCC and fixes by Jose E. Marchesi.
+
+ GCC is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ GCC is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING3. If not see
+ <http://www.gnu.org/licenses/>. */
+
+/* ALGOL 68 contexts are SOFT, WEAK, MEEK, FIRM and STRONG.
+ These contexts are increasing in strength:
+
+ SOFT: Deproceduring
+
+ WEAK: Dereferencing to REF [] or REF STRUCT
+
+ MEEK: Deproceduring and dereferencing
+
+ FIRM: MEEK followed by uniting
+
+ STRONG: FIRM followed by rowing, widening or voiding
+
+ Furthermore you will see in this file next switches:
+
+ (1) FORCE_DEFLEXING allows assignment compatibility between FLEX and non FLEX
+ rows. This can only be the case when there is no danger of altering bounds of a
+ non FLEX row.
+
+ (2) ALIAS_DEFLEXING prohibits aliasing a FLEX row to a non FLEX row (vice versa
+ is no problem) so that one cannot alter the bounds of a non FLEX row by
+ aliasing it to a FLEX row. This is particularly the case when passing names as
+ parameters to procedures:
+
+ PROC x = (REF STRING s) VOID: ..., PROC y = (REF [] CHAR c) VOID: ...;
+
+ x (LOC STRING); # OK #
+
+ x (LOC [10] CHAR); # Not OK, suppose x changes bounds of s! #
+
+ y (LOC STRING); # OK #
+
+ y (LOC [10] CHAR); # OK #
+
+ (3) SAFE_DEFLEXING sets FLEX row apart from non FLEX row. This holds for names,
+ not for values, so common things are not rejected, for instance
+
+ STRING x = read string;
+
+ [] CHAR y = read string
+
+ (4) NO_DEFLEXING sets FLEX row apart from non FLEX row. */
+
+/*
+ In the RR grammar:
+
+ SORT: strong; firm; weak; meek; soft.
+ SORT MOID serial clause;
+ strong void unit, go on token, SORT MOID serial clause;
+ declaration, go on token, SORT MOID serial clause;
+ SORT MOID unit
+
+ And it is the SORT MOID sequence of metanotions, which shall evaluate the
+ same in the complete rule, that control the balancing! o_O
+
+ Also, it denotes how the SORT MOID of the serial clause gets "passed" to the
+ last unit in the serial clause. Other units have SOID `strong void'.
+
+ It is used to pass down the required mode on whatever context. Like,
+ PARTICULAR_PROGRAM evaluates in strong context and requires VOID.
+
+ The ATTRIBUTE in the soid is used to pass down the kind of construct that
+ introduces the context+required mode. This is used in
+ a68_determine_unique_mode in order to know whether balancing shall be
+ performed or not.
+*/
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+/* Forward declarations of some of the functions defined below. */
+
+static void mode_check_enclosed (NODE_T *p, SOID_T *x, SOID_T *y);
+static void mode_check_unit (NODE_T *p, SOID_T *x, SOID_T *y);
+static void mode_check_formula (NODE_T *p, SOID_T *x, SOID_T *y);
+static void mode_check_module_declaration (NODE_T *p);
+static void mode_check_module_text (NODE_T *p);
+static void mode_check_module_declaration (NODE_T *p);
+
+/* Driver for mode checker. */
+
+void
+a68_mode_checker (NODE_T *p)
+{
+ if (IS (p, PACKET))
+ {
+ p = SUB (p);
+
+ if (IS (p, PARTICULAR_PROGRAM))
+ {
+ A68 (top_soid_list) = NO_SOID;
+ SOID_T x, y;
+ a68_make_soid (&x, STRONG, M_VOID, 0);
+ mode_check_enclosed (SUB (p), &x, &y);
+ MOID (p) = MOID (&y);
+ }
+ else if (IS (p, PRELUDE_PACKET))
+ mode_check_module_declaration (SUB (p));
+ }
+}
+
+/* Mode check on bounds. */
+
+static void
+mode_check_bounds (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, UNIT))
+ {
+ SOID_T x, y;
+ a68_make_soid (&x, STRONG, M_INT, 0);
+ mode_check_unit (p, &x, &y);
+ if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+ a68_cannot_coerce (p, MOID (&y), M_INT, MEEK, SAFE_DEFLEXING, UNIT);
+ mode_check_bounds (NEXT (p));
+ }
+ else
+ {
+ mode_check_bounds (SUB (p));
+ mode_check_bounds (NEXT (p));
+ }
+}
+
+/* Mode check declarer. */
+
+static void
+mode_check_declarer (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, BOUNDS))
+ {
+ mode_check_bounds (SUB (p));
+ mode_check_declarer (NEXT (p));
+ }
+ else
+ {
+ mode_check_declarer (SUB (p));
+ mode_check_declarer (NEXT (p));
+ }
+}
+
+/* Mode check identity declaration. */
+
+static void
+mode_check_identity_declaration (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ switch (ATTRIBUTE (p))
+ {
+ case DECLARER:
+ mode_check_declarer (SUB (p));
+ mode_check_identity_declaration (NEXT (p));
+ break;
+ case DEFINING_IDENTIFIER:
+ {
+ SOID_T x, y;
+ a68_make_soid (&x, STRONG, MOID (p), 0);
+ mode_check_unit (NEXT_NEXT (p), &x, &y);
+ if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+ a68_cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT);
+ else if (MOID (&x) != MOID (&y))
+ /* Check for instance, REF INT i = LOC REF INT. */
+ a68_semantic_pitfall (NEXT_NEXT (p), MOID (&x), IDENTITY_DECLARATION, GENERATOR);
+ break;
+ }
+ default:
+ mode_check_identity_declaration (SUB (p));
+ mode_check_identity_declaration (NEXT (p));
+ break;
+ }
+ }
+}
+
+/* Mode check variable declaration. */
+
+static void
+mode_check_variable_declaration (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ switch (ATTRIBUTE (p))
+ {
+ case DECLARER:
+ mode_check_declarer (SUB (p));
+ mode_check_variable_declaration (NEXT (p));
+ break;
+ case DEFINING_IDENTIFIER:
+ if (a68_whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP))
+ {
+ SOID_T x, y;
+ a68_make_soid (&x, STRONG, SUB_MOID (p), 0);
+ mode_check_unit (NEXT_NEXT (p), &x, &y);
+ if (!a68_is_coercible_in_context (&y, &x, FORCE_DEFLEXING))
+ a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, FORCE_DEFLEXING, UNIT);
+ else if (SUB_MOID (&x) != MOID (&y))
+ /* Check for instance, REF INT i = LOC REF INT. */
+ a68_semantic_pitfall (NEXT_NEXT (p), MOID (&x), VARIABLE_DECLARATION, GENERATOR);
+ }
+ break;
+ default:
+ mode_check_variable_declaration (SUB (p));
+ mode_check_variable_declaration (NEXT (p));
+ break;
+ }
+ }
+}
+
+/* Mode check routine text. */
+
+static void
+mode_check_routine_text (NODE_T *p, SOID_T *y)
+{
+ SOID_T w;
+
+ if (IS (p, PARAMETER_PACK))
+ {
+ mode_check_declarer (SUB (p));
+ FORWARD (p);
+ }
+
+ mode_check_declarer (SUB (p));
+ a68_make_soid (&w, STRONG, MOID (p), 0);
+ mode_check_unit (NEXT_NEXT (p), &w, y);
+ if (!a68_is_coercible_in_context (y, &w, FORCE_DEFLEXING))
+ a68_cannot_coerce (NEXT_NEXT (p), MOID (y), MOID (&w), STRONG, FORCE_DEFLEXING, UNIT);
+}
+
+/* Mode check proc declaration. */
+
+static void
+mode_check_proc_declaration (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, ROUTINE_TEXT))
+ {
+ SOID_T x, y;
+ a68_make_soid (&x, STRONG, NO_MOID, 0);
+ mode_check_routine_text (SUB (p), &y);
+ }
+ else
+ {
+ mode_check_proc_declaration (SUB (p));
+ mode_check_proc_declaration (NEXT (p));
+ }
+}
+
+/* Mode check brief op declaration. */
+
+static void
+mode_check_brief_op_declaration (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, DEFINING_OPERATOR))
+ {
+ SOID_T y;
+
+ if (MOID (p) != MOID (NEXT_NEXT (p)))
+ {
+ SOID_T y2, x;
+ a68_make_soid (&y2, NO_SORT, MOID (NEXT_NEXT (p)), 0);
+ a68_make_soid (&x, NO_SORT, MOID (p), 0);
+ a68_cannot_coerce (NEXT_NEXT (p), MOID (&y2), MOID (&x), STRONG, SKIP_DEFLEXING, ROUTINE_TEXT);
+ }
+ mode_check_routine_text (SUB (NEXT_NEXT (p)), &y);
+ }
+ else
+ {
+ mode_check_brief_op_declaration (SUB (p));
+ mode_check_brief_op_declaration (NEXT (p));
+ }
+}
+
+/* Mode check op declaration. */
+
+static void
+mode_check_op_declaration (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, DEFINING_OPERATOR))
+ {
+ SOID_T y, x;
+ a68_make_soid (&x, STRONG, MOID (p), 0);
+ mode_check_unit (NEXT_NEXT (p), &x, &y);
+ if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+ a68_cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT);
+ }
+ else
+ {
+ mode_check_op_declaration (SUB (p));
+ mode_check_op_declaration (NEXT (p));
+ }
+}
+
+/* Mode check declaration list. */
+
+static void
+mode_check_declaration_list (NODE_T * p)
+{
+ if (p != NO_NODE)
+ {
+ switch (ATTRIBUTE (p))
+ {
+ case IDENTITY_DECLARATION:
+ mode_check_identity_declaration (SUB (p));
+ break;
+ case VARIABLE_DECLARATION:
+ mode_check_variable_declaration (SUB (p));
+ break;
+ case MODE_DECLARATION:
+ mode_check_declarer (SUB (p));
+ break;
+ case PROCEDURE_DECLARATION:
+ case PROCEDURE_VARIABLE_DECLARATION:
+ mode_check_proc_declaration (SUB (p));
+ break;
+ case BRIEF_OPERATOR_DECLARATION:
+ mode_check_brief_op_declaration (SUB (p));
+ break;
+ case OPERATOR_DECLARATION:
+ mode_check_op_declaration (SUB (p));
+ break;
+ default:
+ mode_check_declaration_list (SUB (p));
+ mode_check_declaration_list (NEXT (p));
+ break;
+ }
+ }
+}
+
+/* Mode check serial clause. */
+
+static void
+mode_check_serial (SOID_T **r, NODE_T *p, SOID_T *x, bool k)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, INITIALISER_SERIES))
+ {
+ mode_check_serial (r, SUB (p), x, false);
+ mode_check_serial (r, NEXT (p), x, k);
+ }
+ else if (IS (p, DECLARATION_LIST))
+ mode_check_declaration_list (SUB (p));
+ else if (a68_is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP))
+ mode_check_serial (r, NEXT (p), x, k);
+ else if (a68_is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP))
+ {
+ if (NEXT (p) != NO_NODE)
+ {
+ if (IS (NEXT (p), EXIT_SYMBOL) || IS (NEXT (p), END_SYMBOL) || IS (NEXT (p), CLOSE_SYMBOL))
+ mode_check_serial (r, SUB (p), x, true);
+ else
+ mode_check_serial (r, SUB (p), x, false);
+ mode_check_serial (r, NEXT (p), x, k);
+ }
+ else
+ mode_check_serial (r, SUB (p), x, true);
+ }
+ else if (IS (p, LABELED_UNIT))
+ mode_check_serial (r, SUB (p), x, k);
+ else if (IS (p, UNIT))
+ {
+ SOID_T y;
+
+ if (k)
+ mode_check_unit (p, x, &y);
+ else
+ {
+ SOID_T w;
+ a68_make_soid (&w, STRONG, M_VOID, 0);
+ mode_check_unit (p, &w, &y);
+ }
+ if (NEXT (p) != NO_NODE)
+ mode_check_serial (r, NEXT (p), x, k);
+ else
+ {
+ if (k)
+ a68_add_to_soid_list (r, p, &y);
+ }
+ }
+}
+
+/* Mode check serial clause units. */
+
+static void
+mode_check_serial_units (NODE_T *p, SOID_T *x, SOID_T *y,
+ int att __attribute__((unused)))
+{
+ SOID_T *top_sl = NO_SOID;
+
+ mode_check_serial (&top_sl, SUB (p), x, true);
+ if (a68_is_balanced (p, top_sl, SORT (x)))
+ {
+ MOID_T *result = a68_pack_soids_in_moid (top_sl, SERIES_MODE);
+ a68_make_soid (y, SORT (x), result, SERIAL_CLAUSE);
+ }
+ else
+ a68_make_soid (y, SORT (x), (MOID (x) != NO_MOID ? MOID (x) : M_ERROR), 0);
+
+ a68_free_soid_list (top_sl);
+}
+
+/* Mode check unit list. */
+
+static void
+mode_check_unit_list (SOID_T **r, NODE_T *p, SOID_T *x)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, UNIT_LIST))
+ {
+ mode_check_unit_list (r, SUB (p), x);
+ mode_check_unit_list (r, NEXT (p), x);
+ }
+ else if (IS (p, COMMA_SYMBOL))
+ mode_check_unit_list (r, NEXT (p), x);
+ else if (IS (p, UNIT))
+ {
+ SOID_T y;
+ mode_check_unit (p, x, &y);
+ a68_add_to_soid_list (r, p, &y);
+ mode_check_unit_list (r, NEXT (p), x);
+ }
+}
+
+/* Mode check struct display. */
+
+static void
+mode_check_struct_display (SOID_T **r, NODE_T *p, PACK_T **fields)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, UNIT_LIST))
+ {
+ mode_check_struct_display (r, SUB (p), fields);
+ mode_check_struct_display (r, NEXT (p), fields);
+ }
+ else if (IS (p, COMMA_SYMBOL))
+ mode_check_struct_display (r, NEXT (p), fields);
+ else if (IS (p, UNIT))
+ {
+ SOID_T x, y;
+
+ if (*fields != NO_PACK)
+ {
+ a68_make_soid (&x, STRONG, MOID (*fields), 0);
+ FORWARD (*fields);
+ }
+ else
+ a68_make_soid (&x, STRONG, NO_MOID, 0);
+ mode_check_unit (p, &x, &y);
+ a68_add_to_soid_list (r, p, &y);
+ mode_check_struct_display (r, NEXT (p), fields);
+ }
+}
+
+/* Mode check get specified moids. */
+
+static void
+mode_check_get_specified_moids (NODE_T *p, MOID_T *u)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (a68_is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP))
+ mode_check_get_specified_moids (SUB (p), u);
+ else if (IS (p, SPECIFIER))
+ {
+ MOID_T *m = MOID (NEXT_SUB (p));
+ a68_add_mode_to_pack (&(PACK (u)), m, NO_TEXT, NODE (m));
+ }
+ }
+}
+
+/* Mode check specified unit list. */
+
+void
+mode_check_specified_unit_list (SOID_T **r, NODE_T *p, SOID_T *x, MOID_T *u)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (a68_is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP))
+ mode_check_specified_unit_list (r, SUB (p), x, u);
+ else if (IS (p, SPECIFIER))
+ {
+ MOID_T *m = MOID (NEXT_SUB (p));
+ if (u != NO_MOID && !a68_is_unitable (m, u, SAFE_DEFLEXING))
+ a68_error (p, "M is neither component nor subset of M", m, u);
+
+ }
+ else if (IS (p, UNIT))
+ {
+ SOID_T y;
+ mode_check_unit (p, x, &y);
+ a68_add_to_soid_list (r, p, &y);
+ }
+ }
+}
+
+/* Mode check united case parts. */
+
+static void
+mode_check_united_case_parts (SOID_T **ry, NODE_T *p, SOID_T *x)
+{
+ SOID_T enq_expct, enq_yield;
+ MOID_T *u = NO_MOID, *v = NO_MOID, *w = NO_MOID;
+ /* Check the CASE part and deduce the united mode. */
+ a68_make_soid (&enq_expct, MEEK, NO_MOID, 0);
+ mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
+ /* Deduce the united mode from the enquiry clause.
+ This requires balancing. */
+ u = MOID (&enq_yield);
+ a68_absorb_series_pack (&u);
+ DIM (u) = a68_count_pack_members (PACK (u));
+ if (DIM (u) == 1)
+ u = MOID (PACK (u));
+ else
+ {
+ MOID_T *united, *balanced;
+ united = a68_make_united_mode (u);
+ balanced = a68_get_balanced_mode_or_no_mode (united,
+ STRONG, A68_NO_DEPREF,
+ SAFE_DEFLEXING);
+ if (balanced != NO_MOID)
+ u = balanced;
+ }
+ u = a68_depref_completely (u);
+ /* Also deduce the united mode from the specifiers. */
+ v = a68_new_moid ();
+ ATTRIBUTE (v) = SERIES_MODE;
+ mode_check_get_specified_moids (NEXT_SUB (NEXT (p)), v);
+ v = a68_make_united_mode (v);
+ /* Determine a resulting union. */
+ if (u == M_HIP)
+ w = v;
+ else
+ {
+ if (IS (u, UNION_SYMBOL))
+ {
+ bool uv, vu, some;
+ a68_investigate_firm_relations (PACK (u), PACK (v), &uv, &some);
+ a68_investigate_firm_relations (PACK (v), PACK (u), &vu, &some);
+ if (uv && vu)
+ {
+ /* Every component has a specifier. */
+ w = u;
+ }
+ else if (!uv && !vu)
+ {
+ /* Hmmmm ... let the coercer sort it out. */
+ w = u;
+ }
+ else
+ {
+ /* This is all the balancing we allow here for the moment. Firmly
+ related subsets are not valid so we absorb them. If this
+ doesn't solve it then we get a coercion-error later. */
+ w = a68_absorb_related_subsets (u);
+ }
+ }
+ else
+ {
+ a68_error (NEXT_SUB (p), "M is not a united mode", u);
+ return;
+ }
+ }
+ MOID (SUB (p)) = w;
+ FORWARD (p);
+ /* Check the IN part. */
+ mode_check_specified_unit_list (ry, NEXT_SUB (p), x, w);
+ /* OUSE, OUT, ESAC. */
+ if ((FORWARD (p)) != NO_NODE)
+ {
+ if (a68_is_one_of (p, OUT_PART, CHOICE, STOP))
+ mode_check_serial (ry, NEXT_SUB (p), x, true);
+ else if (a68_is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP))
+ mode_check_united_case_parts (ry, SUB (p), x);
+ }
+}
+
+/* Mode check united case. */
+
+static void
+mode_check_united_case (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ SOID_T *top_sl = NO_SOID;
+
+ mode_check_united_case_parts (&top_sl, p, x);
+ if (!a68_is_balanced (p, top_sl, SORT (x)))
+ {
+ if (MOID (x) != NO_MOID)
+ a68_make_soid (y, SORT (x), MOID (x), CONFORMITY_CLAUSE);
+ else
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ else
+ {
+ MOID_T *z = a68_pack_soids_in_moid (top_sl, SERIES_MODE);
+ a68_make_soid (y, SORT (x), z, CONFORMITY_CLAUSE);
+ }
+ a68_free_soid_list (top_sl);
+}
+
+/* Mode check unit list 2. */
+
+static void
+mode_check_unit_list_2 (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ SOID_T *top_sl = NO_SOID;
+
+ if (MOID (x) != NO_MOID)
+ {
+ if (IS_FLEX (MOID (x)))
+ {
+ SOID_T y2;
+ a68_make_soid (&y2, SORT (x), SLICE (SUB_MOID (x)), 0);
+ mode_check_unit_list (&top_sl, SUB (p), &y2);
+ }
+ else if (IS_ROW (MOID (x)))
+ {
+ SOID_T y2;
+ a68_make_soid (&y2, SORT (x), SLICE (MOID (x)), 0);
+ mode_check_unit_list (&top_sl, SUB (p), &y2);
+ }
+ else if (IS (MOID (x), STRUCT_SYMBOL))
+ {
+ PACK_T *y2 = PACK (MOID (x));
+ mode_check_struct_display (&top_sl, SUB (p), &y2);
+ }
+ else
+ mode_check_unit_list (&top_sl, SUB (p), x);
+ }
+ else
+ mode_check_unit_list (&top_sl, SUB (p), x);
+
+ a68_make_soid (y, STRONG, a68_pack_soids_in_moid (top_sl, STOWED_MODE), 0);
+ a68_free_soid_list (top_sl);
+}
+
+/* Mode check access. */
+
+static void
+mode_check_access (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+ {
+ if (IS (q, ENCLOSED_CLAUSE))
+ {
+ mode_check_enclosed (q, x, y);
+ MOID (p) = MOID (y);
+ }
+ }
+}
+
+/* Mode check closed. */
+
+static void
+mode_check_closed (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, SERIAL_CLAUSE))
+ mode_check_serial_units (p, x, y, SERIAL_CLAUSE);
+ else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP))
+ mode_check_closed (NEXT (p), x, y);
+ MOID (p) = MOID (y);
+}
+
+/* Mode check collateral. */
+
+void
+mode_check_collateral (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ if (p == NO_NODE)
+ return;
+ else if (a68_whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP)
+ || a68_whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))
+ {
+ if (SORT (x) == STRONG)
+ {
+ if (MOID (x) == NO_MOID)
+ a68_error (p, "vacuum cannot have row elements (use a Y generator)",
+ "REF MODE");
+ else if (IS_FLEXETY_ROW (MOID (x)))
+ a68_make_soid (y, STRONG, M_VACUUM, 0);
+ else
+ {
+ /* The syntax only allows vacuums in strong contexts with rowed
+ modes. See rule 33d. */
+ a68_error (p, "a vacuum is not a valid M", MOID (x));
+ a68_make_soid (y, STRONG, M_ERROR, 0);
+ }
+ }
+ else
+ a68_make_soid (y, STRONG, M_UNDEFINED, 0);
+ }
+ else
+ {
+ if (IS (p, UNIT_LIST))
+ mode_check_unit_list_2 (p, x, y);
+ else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP))
+ mode_check_collateral (NEXT (p), x, y);
+ MOID (p) = MOID (y);
+ }
+}
+
+/* Mode check conditional 2. */
+
+static void
+mode_check_conditional_2 (SOID_T **ry, NODE_T *p, SOID_T *x)
+{
+ SOID_T enq_expct, enq_yield;
+
+ a68_make_soid (&enq_expct, MEEK, M_BOOL, 0);
+ mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
+ if (!a68_is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING))
+ a68_cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
+ FORWARD (p);
+ mode_check_serial (ry, NEXT_SUB (p), x, true);
+ if ((FORWARD (p)) != NO_NODE)
+ {
+ if (a68_is_one_of (p, ELSE_PART, CHOICE, STOP))
+ mode_check_serial (ry, NEXT_SUB (p), x, true);
+ else if (a68_is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP))
+ mode_check_conditional_2 (ry, SUB (p), x);
+ }
+}
+
+/* Mode check conditional. */
+
+static void
+mode_check_conditional (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ SOID_T *top_sl = NO_SOID;
+ mode_check_conditional_2 (&top_sl, p, x);
+ if (!a68_is_balanced (p, top_sl, SORT (x)))
+ {
+ if (MOID (x) != NO_MOID)
+ a68_make_soid (y, SORT (x), MOID (x), CONDITIONAL_CLAUSE);
+ else
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ else
+ {
+ MOID_T *z = a68_pack_soids_in_moid (top_sl, SERIES_MODE);
+ a68_make_soid (y, SORT (x), z, CONDITIONAL_CLAUSE);
+ }
+ a68_free_soid_list (top_sl);
+}
+
+/* Mode check int case 2. */
+
+static void
+mode_check_int_case_2 (SOID_T **ry, NODE_T *p, SOID_T *x)
+{
+ SOID_T enq_expct, enq_yield;
+ a68_make_soid (&enq_expct, MEEK, M_INT, 0);
+ mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
+ if (!a68_is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING))
+ a68_cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
+ FORWARD (p);
+ mode_check_unit_list (ry, NEXT_SUB (p), x);
+ if ((FORWARD (p)) != NO_NODE)
+ {
+ if (a68_is_one_of (p, OUT_PART, CHOICE, STOP))
+ mode_check_serial (ry, NEXT_SUB (p), x, true);
+ else if (a68_is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP))
+ mode_check_int_case_2 (ry, SUB (p), x);
+ }
+}
+
+/* Mode check int case. */
+
+static void
+mode_check_int_case (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ SOID_T *top_sl = NO_SOID;
+ mode_check_int_case_2 (&top_sl, p, x);
+ if (!a68_is_balanced (p, top_sl, SORT (x)))
+ {
+ if (MOID (x) != NO_MOID)
+ a68_make_soid (y, SORT (x), MOID (x), CASE_CLAUSE);
+ else
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ else
+ {
+ MOID_T *z = a68_pack_soids_in_moid (top_sl, SERIES_MODE);
+ a68_make_soid (y, SORT (x), z, CASE_CLAUSE);
+ }
+ a68_free_soid_list (top_sl);
+}
+
+/* Mode check loop 2. */
+
+static void
+mode_check_loop_2 (NODE_T *p, SOID_T *y)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, FOR_PART))
+ mode_check_loop_2 (NEXT (p), y);
+ else if (a68_is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP))
+ {
+ SOID_T ix, iy;
+ a68_make_soid (&ix, STRONG, M_INT, 0);
+ mode_check_unit (NEXT_SUB (p), &ix, &iy);
+ if (!a68_is_coercible_in_context (&iy, &ix, SAFE_DEFLEXING))
+ a68_cannot_coerce (NEXT_SUB (p), MOID (&iy), M_INT, MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
+ mode_check_loop_2 (NEXT (p), y);
+ }
+ else if (IS (p, WHILE_PART))
+ {
+ SOID_T enq_expct, enq_yield;
+ a68_make_soid (&enq_expct, MEEK, M_BOOL, 0);
+ mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
+ if (!a68_is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING))
+ a68_cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
+ mode_check_loop_2 (NEXT (p), y);
+ }
+ else if (a68_is_one_of (p, DO_PART, ALT_DO_PART, STOP))
+ {
+ SOID_T *z = NO_SOID;
+ NODE_T *do_p = NEXT_SUB (p);
+ SOID_T ix;
+ a68_make_soid (&ix, STRONG, M_VOID, 0);
+ if (IS (do_p, SERIAL_CLAUSE))
+ mode_check_serial (&z, do_p, &ix, true);
+ a68_free_soid_list (z);
+ }
+}
+
+/* Mode check loop. */
+
+static void
+mode_check_loop (NODE_T *p, SOID_T *y)
+{
+ SOID_T *z = NO_SOID;
+ mode_check_loop_2 (p, z);
+ a68_make_soid (y, STRONG, M_VOID, 0);
+}
+
+/* Mode check enclosed. */
+
+static void
+mode_check_enclosed (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, ENCLOSED_CLAUSE))
+ mode_check_enclosed (SUB (p), x, y);
+ else if (IS (p, CLOSED_CLAUSE))
+ mode_check_closed (SUB (p), x, y);
+ else if (IS (p, ACCESS_CLAUSE))
+ mode_check_access (SUB (p), x, y);
+ else if (IS (p, PARALLEL_CLAUSE))
+ {
+ mode_check_collateral (SUB (NEXT_SUB (p)), x, y);
+ a68_make_soid (y, STRONG, M_VOID, 0);
+ MOID (NEXT_SUB (p)) = M_VOID;
+ }
+ else if (IS (p, COLLATERAL_CLAUSE))
+ mode_check_collateral (SUB (p), x, y);
+ else if (IS (p, CONDITIONAL_CLAUSE))
+ mode_check_conditional (SUB (p), x, y);
+ else if (IS (p, CASE_CLAUSE))
+ mode_check_int_case (SUB (p), x, y);
+ else if (IS (p, CONFORMITY_CLAUSE))
+ mode_check_united_case (SUB (p), x, y);
+ else if (IS (p, LOOP_CLAUSE))
+ mode_check_loop (SUB (p), y);
+
+ MOID (p) = MOID (y);
+}
+
+/* Search table for operator. */
+
+static TAG_T *
+search_table_for_operator (TAG_T *t, const char *n, MOID_T *x, MOID_T *y)
+{
+ if (a68_is_mode_isnt_well (x))
+ return A68_PARSER (error_tag);
+ else if (y != NO_MOID && a68_is_mode_isnt_well (y))
+ return A68_PARSER (error_tag);
+
+ for (; t != NO_TAG; FORWARD (t))
+ {
+ if (NSYMBOL (NODE (t)) == n || strcmp (NSYMBOL (NODE (t)), n) == 0)
+ {
+ PACK_T *p = PACK (MOID (t));
+ if (a68_is_coercible (x, MOID (p), FIRM, ALIAS_DEFLEXING))
+ {
+ FORWARD (p);
+ if (p == NO_PACK && y == NO_MOID)
+ /* Matched in case of a monadic. */
+ return t;
+ else if (p != NO_PACK && y != NO_MOID
+ && a68_is_coercible (y, MOID (p), FIRM, ALIAS_DEFLEXING))
+ /* Matched in case of a dyadic. */
+ return t;
+ }
+ }
+ }
+ return NO_TAG;
+}
+
+/* Search chain of symbol tables and return matching operator "x n y" or
+ "n x". */
+
+static TAG_T *
+search_table_chain_for_operator (TABLE_T *s, const char *n, MOID_T *x, MOID_T *y)
+{
+ if (a68_is_mode_isnt_well (x))
+ return A68_PARSER (error_tag);
+ else if (y != NO_MOID && a68_is_mode_isnt_well (y))
+ return A68_PARSER (error_tag);
+
+ while (s != NO_TABLE)
+ {
+ TAG_T *z = search_table_for_operator (OPERATORS (s), n, x, y);
+ if (z != NO_TAG)
+ return z;
+ BACKWARD (s);
+ }
+ return NO_TAG;
+}
+
+/* Return a matching operator "x n y". */
+
+static TAG_T *
+find_operator (TABLE_T *s, const char *n, MOID_T *x, MOID_T *y)
+{
+ /* Coercions to operand modes are FIRM. */
+ MOID_T *u, *v; TAG_T *z;
+ /* (A) Catch exceptions first. */
+ if (x == NO_MOID && y == NO_MOID)
+ return NO_TAG;
+ else if (a68_is_mode_isnt_well (x))
+ return A68_PARSER (error_tag);
+ else if (y != NO_MOID && a68_is_mode_isnt_well (y))
+ return A68_PARSER (error_tag);
+
+ /* (B) MONADs. */
+ if (x != NO_MOID && y == NO_MOID)
+ {
+ z = search_table_chain_for_operator (s, n, x, NO_MOID);
+ if (z != NO_TAG)
+ return z;
+ else
+ {
+ /* (B.2) A little trick to allow - (0, 1) or ABS (1, long pi). */
+ if (a68_is_coercible (x, M_COMPLEX, STRONG, SAFE_DEFLEXING))
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, NO_MOID);
+ if (z != NO_TAG)
+ return z;
+ }
+ if (a68_is_coercible (x, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING))
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, NO_MOID);
+ if (z != NO_TAG)
+ return z;
+ }
+ if (a68_is_coercible (x, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING))
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, NO_MOID);
+ }
+ return NO_TAG;
+ }
+ /* (C) DYADs. */
+ z = search_table_chain_for_operator (s, n, x, y);
+ if (z != NO_TAG)
+ return z;
+ /* (C.2) Vector and matrix "strong coercions" in standard environ. */
+ u = DEFLEX (a68_depref_completely (x));
+ v = DEFLEX (a68_depref_completely (y));
+ if ((u == M_ROW_REAL || u == M_ROW_ROW_REAL)
+ || (v == M_ROW_REAL || v == M_ROW_ROW_REAL)
+ || (u == M_ROW_COMPLEX || u == M_ROW_ROW_COMPLEX)
+ || (v == M_ROW_COMPLEX || v == M_ROW_ROW_COMPLEX))
+ {
+ if (u == M_INT)
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, y);
+ if (z != NO_TAG)
+ return z;
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y);
+ if (z != NO_TAG)
+ return z;
+ }
+ else if (v == M_INT)
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_REAL);
+ if (z != NO_TAG)
+ return z;
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX);
+ if (z != NO_TAG)
+ return z;
+ }
+ else if (u == M_REAL)
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y);
+ if (z != NO_TAG)
+ return z;
+ }
+ else if (v == M_REAL)
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX);
+ if (z != NO_TAG)
+ return z;
+ }
+ }
+ /* (C.3) Look in standenv for an appropriate cross-term. */
+ u = a68_make_series_from_moids (x, y);
+ u = a68_make_united_mode (u);
+ v = a68_get_balanced_mode (u, STRONG, A68_NO_DEPREF, SAFE_DEFLEXING);
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, v, v);
+ if (z != NO_TAG)
+ return z;
+ if (a68_is_coercible_series (u, M_REAL, STRONG, SAFE_DEFLEXING))
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, M_REAL);
+ if (z != NO_TAG)
+ return z;
+ }
+ if (a68_is_coercible_series (u, M_LONG_REAL, STRONG, SAFE_DEFLEXING))
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_REAL, M_LONG_REAL);
+ if (z != NO_TAG)
+ return z;
+ }
+ if (a68_is_coercible_series (u, M_LONG_LONG_REAL, STRONG, SAFE_DEFLEXING))
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_REAL, M_LONG_LONG_REAL);
+ if (z != NO_TAG)
+ return z;
+ }
+ if (a68_is_coercible_series (u, M_COMPLEX, STRONG, SAFE_DEFLEXING))
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, M_COMPLEX);
+ if (z != NO_TAG)
+ return z;
+ }
+ if (a68_is_coercible_series (u, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING))
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, M_LONG_COMPLEX);
+ if (z != NO_TAG)
+ return z;
+ }
+ if (a68_is_coercible_series (u, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING))
+ {
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX);
+ if (z != NO_TAG)
+ return z;
+ }
+ /* (C.4) Now allow for depreffing for REF REAL +:= INT and alike. */
+ v = a68_get_balanced_mode (u, STRONG, A68_DEPREF, SAFE_DEFLEXING);
+ z = search_table_for_operator (OPERATORS (A68_STANDENV), n, v, v);
+ if (z != NO_TAG)
+ return z;
+ return NO_TAG;
+}
+
+/* Mode check monadic operator. */
+
+static void
+mode_check_monadic_operator (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ if (p != NO_NODE)
+ {
+ TAG_T *t;
+ MOID_T *u = a68_determine_unique_mode (y, SAFE_DEFLEXING);
+ if (a68_is_mode_isnt_well (u))
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ else if (u == M_HIP)
+ {
+ a68_error (NEXT (p), "M construct is an invalid operand", u);
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ else
+ {
+ if (strchr (NOMADS, *(NSYMBOL (p))) != NO_TEXT)
+ {
+ t = NO_TAG;
+ a68_error (p, "monadic S cannot start with a character from Z", NOMADS);
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ else
+ {
+ t = find_operator (TABLE (p), NSYMBOL (p), u, NO_MOID);
+ if (t == NO_TAG)
+ {
+ a68_error (p, "monadic operator S O has not been declared", u);
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ }
+ if (t != NO_TAG)
+ MOID (p) = MOID (t);
+ TAX (p) = t;
+ if (t != NO_TAG && t != A68_PARSER (error_tag))
+ {
+ MOID (p) = MOID (t);
+ a68_make_soid (y, SORT (x), SUB_MOID (t), 0);
+ }
+ else
+ {
+ MOID (p) = M_ERROR;
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ }
+ }
+}
+
+/* Mode check monadic formula. */
+
+static void
+mode_check_monadic_formula (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ SOID_T e;
+ a68_make_soid (&e, FIRM, NO_MOID, 0);
+ mode_check_formula (NEXT (p), &e, y);
+ mode_check_monadic_operator (p, &e, y);
+ a68_make_soid (y, SORT (x), MOID (y), 0);
+}
+
+/* Mode check formula. */
+
+static void
+mode_check_formula (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ SOID_T ls;
+ if (IS (p, MONADIC_FORMULA))
+ mode_check_monadic_formula (SUB (p), x, &ls);
+ else if (IS (p, FORMULA))
+ mode_check_formula (SUB (p), x, &ls);
+ else if (IS (p, SECONDARY))
+ {
+ SOID_T e;
+ a68_make_soid (&e, FIRM, NO_MOID, 0);
+ mode_check_unit (SUB (p), &e, &ls);
+ }
+ MOID_T *u = a68_determine_unique_mode (&ls, SAFE_DEFLEXING);
+ MOID (p) = u;
+ SOID_T rs;
+ if (NEXT (p) == NO_NODE)
+ a68_make_soid (y, SORT (x), u, 0);
+ else
+ {
+ NODE_T *q = NEXT_NEXT (p);
+ if (IS (q, MONADIC_FORMULA))
+ mode_check_monadic_formula (SUB (NEXT_NEXT (p)), x, &rs);
+ else if (IS (q, FORMULA))
+ mode_check_formula (SUB (NEXT_NEXT (p)), x, &rs);
+ else if (IS (q, SECONDARY))
+ {
+ SOID_T e;
+ a68_make_soid (&e, FIRM, NO_MOID, 0);
+ mode_check_unit (SUB (q), &e, &rs);
+ }
+ MOID_T *v = a68_determine_unique_mode (&rs, SAFE_DEFLEXING);
+ MOID (q) = v;
+ if (a68_is_mode_isnt_well (u) || a68_is_mode_isnt_well (v))
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ else if (u == M_HIP)
+ {
+ a68_error (p, "M construct is an invalid operand", u);
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ else if (v == M_HIP)
+ {
+ a68_error (q, "M construct is an invalid operand", u);
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ else
+ {
+ TAG_T *op = find_operator (TABLE (NEXT (p)), NSYMBOL (NEXT (p)), u, v);
+ if (op == NO_TAG)
+ {
+ a68_error (NEXT (p), "dyadic operator O S O has not been declared", u, v);
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ if (op != NO_TAG)
+ MOID (NEXT (p)) = MOID (op);
+ TAX (NEXT (p)) = op;
+ if (op != NO_TAG && op != A68_PARSER (error_tag))
+ a68_make_soid (y, SORT (x), SUB_MOID (op), 0);
+ else
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ }
+}
+
+/* Mode check assignation. */
+
+static void
+mode_check_assignation (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ /* Get destination mode. */
+ SOID_T name, tmp, value;
+ a68_make_soid (&name, SOFT, NO_MOID, 0);
+ mode_check_unit (SUB (p), &name, &tmp);
+ /* SOFT coercion. */
+ MOID_T *ori = a68_determine_unique_mode (&tmp, SAFE_DEFLEXING);
+ MOID_T *name_moid = a68_deproc_completely (ori);
+ if (ATTRIBUTE (name_moid) != REF_SYMBOL)
+ {
+ if (A68_IF_MODE_IS_WELL (name_moid))
+ a68_error (p, "M A does not yield a name", ori, ATTRIBUTE (SUB (p)));
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ return;
+ }
+ MOID (p) = name_moid;
+ /* Get source mode. */
+ a68_make_soid (&name, STRONG, SUB (name_moid), 0);
+ mode_check_unit (NEXT_NEXT (p), &name, &value);
+ if (!a68_is_coercible_in_context (&value, &name, FORCE_DEFLEXING))
+ {
+ a68_cannot_coerce (p, MOID (&value), MOID (&name), STRONG, FORCE_DEFLEXING, UNIT);
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ else
+ a68_make_soid (y, SORT (x), name_moid, 0);
+}
+
+/* Mode check identity relation. */
+
+static void
+mode_check_identity_relation (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ NODE_T *ln = p, *rn = NEXT_NEXT (p);
+ SOID_T e, l, r;
+ a68_make_soid (&e, SOFT, NO_MOID, 0);
+ mode_check_unit (SUB (ln), &e, &l);
+ mode_check_unit (SUB (rn), &e, &r);
+ /* SOFT coercion. */
+ MOID_T *oril = a68_determine_unique_mode (&l, SAFE_DEFLEXING);
+ MOID_T *orir = a68_determine_unique_mode (&r, SAFE_DEFLEXING);
+ MOID_T *lhs = a68_deproc_completely (oril);
+ MOID_T *rhs = a68_deproc_completely (orir);
+ if (A68_IF_MODE_IS_WELL (lhs) && lhs != M_HIP && ATTRIBUTE (lhs) != REF_SYMBOL)
+ {
+ a68_error (ln, "M A does not yield a name", oril, ATTRIBUTE (SUB (ln)));
+ lhs = M_ERROR;
+ }
+ if (A68_IF_MODE_IS_WELL (rhs) && rhs != M_HIP && ATTRIBUTE (rhs) != REF_SYMBOL)
+ {
+ a68_error (rn, "M A does not yield a name", orir, ATTRIBUTE (SUB (rn)));
+ rhs = M_ERROR;
+ }
+ if (lhs == M_HIP && rhs == M_HIP)
+ a68_error (p, "construct has no unique mode");
+
+ if (a68_is_coercible (lhs, rhs, STRONG, SAFE_DEFLEXING))
+ lhs = rhs;
+ else if (a68_is_coercible (rhs, lhs, STRONG, SAFE_DEFLEXING))
+ rhs = lhs;
+ else
+ {
+ a68_cannot_coerce (NEXT (p), rhs, lhs, SOFT, SKIP_DEFLEXING, TERTIARY);
+ lhs = rhs = M_ERROR;
+ }
+ MOID (ln) = lhs;
+ MOID (rn) = rhs;
+ a68_make_soid (y, SORT (x), M_BOOL, 0);
+}
+
+/* Mode check bool functions ANDF and ORF. */
+
+static void
+mode_check_bool_function (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ SOID_T e, l, r;
+ NODE_T *ln = p, *rn = NEXT_NEXT (p);
+ a68_make_soid (&e, STRONG, M_BOOL, 0);
+ mode_check_unit (SUB (ln), &e, &l);
+ if (!a68_is_coercible_in_context (&l, &e, SAFE_DEFLEXING))
+ a68_cannot_coerce (ln, MOID (&l), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY);
+ mode_check_unit (SUB (rn), &e, &r);
+ if (!a68_is_coercible_in_context (&r, &e, SAFE_DEFLEXING))
+ a68_cannot_coerce (rn, MOID (&r), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY);
+ MOID (ln) = M_BOOL;
+ MOID (rn) = M_BOOL;
+ a68_make_soid (y, SORT (x), M_BOOL, 0);
+}
+
+/* Mode check cast. */
+
+static void
+mode_check_cast (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ SOID_T w;
+ mode_check_declarer (p);
+ a68_make_soid (&w, STRONG, MOID (p), 0);
+ CAST (&w) = true;
+ mode_check_enclosed (SUB_NEXT (p), &w, y);
+ if (!a68_is_coercible_in_context (y, &w, SAFE_DEFLEXING))
+ a68_cannot_coerce (NEXT (p), MOID (y), MOID (&w), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
+ a68_make_soid (y, SORT (x), MOID (p), 0);
+}
+
+/* Mode check assertion. */
+
+static void
+mode_check_assertion (NODE_T *p)
+{
+ SOID_T w, y;
+ a68_make_soid (&w, STRONG, M_BOOL, 0);
+ mode_check_enclosed (SUB_NEXT (p), &w, &y);
+ SORT (&y) = SORT (&w);
+ if (!a68_is_coercible_in_context (&y, &w, NO_DEFLEXING))
+ a68_cannot_coerce (NEXT (p), MOID (&y), MOID (&w), MEEK, NO_DEFLEXING, ENCLOSED_CLAUSE);
+}
+
+/* Mode check argument list. */
+
+static void
+mode_check_argument_list (SOID_T **r, NODE_T *p, PACK_T **x, PACK_T **v, PACK_T **w)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, GENERIC_ARGUMENT_LIST))
+ ATTRIBUTE (p) = ARGUMENT_LIST;
+
+ if (IS (p, ARGUMENT_LIST))
+ mode_check_argument_list (r, SUB (p), x, v, w);
+ else if (IS (p, UNIT))
+ {
+ SOID_T y, z;
+ if (*x != NO_PACK)
+ {
+ a68_make_soid (&z, STRONG, MOID (*x), 0);
+ a68_add_mode_to_pack_end (v, MOID (*x), NO_TEXT, p);
+ FORWARD (*x);
+ }
+ else
+ a68_make_soid (&z, STRONG, NO_MOID, 0);
+ mode_check_unit (p, &z, &y);
+ a68_add_to_soid_list (r, p, &y);
+ }
+ else if (IS (p, TRIMMER))
+ {
+ SOID_T z;
+ if (SUB (p) != NO_NODE)
+ {
+ a68_error (p, "syntax error detected in A", ARGUMENT);
+ a68_make_soid (&z, STRONG, M_ERROR, 0);
+ a68_add_mode_to_pack_end (v, M_VOID, NO_TEXT, p);
+ a68_add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p);
+ FORWARD (*x);
+ }
+ else if (*x != NO_PACK)
+ {
+ a68_make_soid (&z, STRONG, MOID (*x), 0);
+ a68_add_mode_to_pack_end (v, M_VOID, NO_TEXT, p);
+ a68_add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p);
+ FORWARD (*x);
+ }
+ else
+ a68_make_soid (&z, STRONG, NO_MOID, 0);
+ a68_add_to_soid_list (r, p, &z);
+ }
+ else if (IS (p, SUB_SYMBOL) && !OPTION_BRACKETS (&A68_JOB))
+ a68_error (p, "syntax error detected in A", CALL);
+ }
+}
+
+/* Mode check argument list 2. */
+
+static void
+mode_check_argument_list_2 (NODE_T *p, PACK_T *x, SOID_T *y, PACK_T **v, PACK_T **w)
+{
+ SOID_T *top_sl = NO_SOID;
+ mode_check_argument_list (&top_sl, SUB (p), &x, v, w);
+ a68_make_soid (y, STRONG, a68_pack_soids_in_moid (top_sl, STOWED_MODE), 0);
+ a68_free_soid_list (top_sl);
+}
+
+/* Mode check meek int. */
+
+static void
+mode_check_meek_int (NODE_T *p)
+{
+ SOID_T x, y;
+ a68_make_soid (&x, MEEK, M_INT, 0);
+ mode_check_unit (p, &x, &y);
+ if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+ a68_cannot_coerce (p, MOID (&y), MOID (&x), MEEK, SAFE_DEFLEXING, 0);
+}
+
+/* Mode check trimmer. */
+
+static void
+mode_check_trimmer (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, TRIMMER))
+ mode_check_trimmer (SUB (p));
+ else if (IS (p, UNIT))
+ {
+ mode_check_meek_int (p);
+ mode_check_trimmer (NEXT (p));
+ }
+ else
+ mode_check_trimmer (NEXT (p));
+}
+
+/* Mode check indexer. */
+
+static void
+mode_check_indexer (NODE_T *p, int *subs, int *trims)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, TRIMMER))
+ {
+ (*trims)++;
+ mode_check_trimmer (SUB (p));
+ }
+ else if (IS (p, UNIT))
+ {
+ (*subs)++;
+ mode_check_meek_int (p);
+ }
+ else
+ {
+ mode_check_indexer (SUB (p), subs, trims);
+ mode_check_indexer (NEXT (p), subs, trims);
+ }
+}
+
+/* Mode check call. */
+
+static void
+mode_check_call (NODE_T *p, MOID_T *n, SOID_T *x, SOID_T *y)
+{
+ MOID (p) = n;
+ /* "partial_locale" is the mode of the locale. */
+ PARTIAL_LOCALE (GINFO (p)) = a68_new_moid ();
+ ATTRIBUTE (PARTIAL_LOCALE (GINFO (p))) = PROC_SYMBOL;
+ PACK (PARTIAL_LOCALE (GINFO (p))) = NO_PACK;
+ SUB (PARTIAL_LOCALE (GINFO (p))) = SUB (n);
+ /* "partial_proc" is the mode of the resulting proc. */
+ PARTIAL_PROC (GINFO (p)) = a68_new_moid ();
+ ATTRIBUTE (PARTIAL_PROC (GINFO (p))) = PROC_SYMBOL;
+ PACK (PARTIAL_PROC (GINFO (p))) = NO_PACK;
+ SUB (PARTIAL_PROC (GINFO (p))) = SUB (n);
+ /* Check arguments and construct modes. */
+ SOID_T d;
+ mode_check_argument_list_2 (NEXT (p), PACK (n), &d, &PACK (PARTIAL_LOCALE (GINFO (p))),
+ &PACK (PARTIAL_PROC (GINFO (p))));
+ DIM (PARTIAL_PROC (GINFO (p))) = a68_count_pack_members (PACK (PARTIAL_PROC (GINFO (p))));
+ DIM (PARTIAL_LOCALE (GINFO (p))) = a68_count_pack_members (PACK (PARTIAL_LOCALE (GINFO (p))));
+ PARTIAL_PROC (GINFO (p)) = a68_register_extra_mode (&TOP_MOID (&A68_JOB), PARTIAL_PROC (GINFO (p)));
+ PARTIAL_LOCALE (GINFO (p)) = a68_register_extra_mode (&TOP_MOID (&A68_JOB), PARTIAL_LOCALE (GINFO (p)));
+ if (DIM (MOID (&d)) != DIM (n))
+ {
+ a68_error (p, "incorrect number of arguments for M", n);
+ a68_make_soid (y, SORT (x), SUB (n), 0);
+ /* a68_make_soid (y, SORT (x), M_ERROR, 0);. */
+ }
+ else
+ {
+ if (!a68_is_coercible (MOID (&d), n, STRONG, ALIAS_DEFLEXING))
+ a68_cannot_coerce (p, MOID (&d), n, STRONG, ALIAS_DEFLEXING, ARGUMENT);
+ if (DIM (PARTIAL_PROC (GINFO (p))) == 0)
+ a68_make_soid (y, SORT (x), SUB (n), 0);
+ else
+ {
+ a68_warning (NEXT (p), OPT_Wextensions, "@ is an extension");
+ a68_make_soid (y, SORT (x), PARTIAL_PROC (GINFO (p)), 0);
+ }
+ }
+}
+
+/* Mode check slice. */
+
+static void
+mode_check_slice (NODE_T *p, MOID_T *ori, SOID_T *x, SOID_T *y)
+{
+ MOID_T *m = a68_depref_completely (ori), *n = ori;
+ /* WEAK coercion. */
+ while ((IS_REF (n) && !a68_is_ref_row (n)) || (IS (n, PROC_SYMBOL) && PACK (n) == NO_PACK))
+ n = a68_depref_once (n);
+
+ if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || a68_is_ref_row (n)))
+ {
+ if (A68_IF_MODE_IS_WELL (n))
+ a68_error (p, "M A does not yield a row or procedure",
+ n, ATTRIBUTE (SUB (p)));
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+
+ MOID (p) = n;
+ int dim = 0, subs = 0, trims = 0;
+ mode_check_indexer (SUB_NEXT (p), &subs, &trims);
+ bool is_ref;
+ if ((is_ref = a68_is_ref_row (n)) != 0)
+ dim = DIM (DEFLEX (SUB (n)));
+ else
+ dim = DIM (DEFLEX (n));
+
+ if ((subs + trims) != dim)
+ {
+ a68_error (p, "incorrect number of indexers for M", n);
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ }
+ else
+ {
+ if (subs > 0 && trims == 0)
+ {
+ ANNOTATION (NEXT (p)) = SLICE;
+ m = n;
+ }
+ else
+ {
+ ANNOTATION (NEXT (p)) = TRIMMER;
+ m = n;
+ }
+ while (subs > 0)
+ {
+ if (is_ref)
+ m = NAME (m);
+ else
+ {
+ if (IS_FLEX (m))
+ m = SUB (m);
+ m = SLICE (m);
+ }
+ gcc_assert (m != NO_MOID);
+ subs--;
+ }
+ /* A trim cannot be but deflexed. */
+ if (ANNOTATION (NEXT (p)) == TRIMMER && TRIM (m) != NO_MOID)
+ {
+ gcc_assert (TRIM (m) != NO_MOID);
+ a68_make_soid (y, SORT (x), TRIM (m), 0);
+ }
+ else
+ a68_make_soid (y, SORT (x), m, 0);
+ }
+}
+
+/* Mode check specification. */
+
+static enum a68_attribute
+mode_check_specification (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ SOID_T w, d;
+ a68_make_soid (&w, WEAK, NO_MOID, 0);
+ mode_check_unit (SUB (p), &w, &d);
+ MOID_T *ori = a68_determine_unique_mode (&d, SAFE_DEFLEXING);
+ MOID_T *m = a68_depref_completely (ori);
+ if (IS (m, PROC_SYMBOL))
+ {
+ /* Assume CALL. */
+ mode_check_call (p, m, x, y);
+ return CALL;
+ }
+ else if (IS_ROW (m) || IS_FLEX (m))
+ {
+ /* Assume SLICE. */
+ mode_check_slice (p, ori, x, y);
+ return SLICE;
+ }
+ else
+ {
+ if (m != M_ERROR)
+ a68_error (p, "M construct must yield a routine or a row value", m);
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ return PRIMARY;
+ }
+}
+
+/* Mode check selection. */
+
+static void
+mode_check_selection (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ bool deflex = false;
+ NODE_T *secondary = SUB_NEXT (p);
+ SOID_T w, d;
+ a68_make_soid (&w, WEAK, NO_MOID, 0);
+ mode_check_unit (secondary, &w, &d);
+ MOID_T *n, *ori;
+ n = ori = a68_determine_unique_mode (&d, SAFE_DEFLEXING);
+ PACK_T *t = NO_PACK, *t_2 = NO_PACK;
+ bool coerce = true;
+ while (coerce)
+ {
+ if (IS (n, STRUCT_SYMBOL))
+ {
+ coerce = false;
+ t = PACK (n);
+ }
+ else if (IS_REF (n) && (IS_ROW (SUB (n)) || IS_FLEX (SUB (n))) && MULTIPLE (n) != NO_MOID)
+ {
+ coerce = false;
+ deflex = true;
+ t = PACK (MULTIPLE (n));
+ }
+ else if ((IS_ROW (n) || IS_FLEX (n)) && MULTIPLE (n) != NO_MOID)
+ {
+ coerce = false;
+ deflex = true;
+ t = PACK (MULTIPLE (n));
+ }
+ else if (IS_REF (n) && a68_is_name_struct (n))
+ {
+ coerce = false;
+ t = PACK (NAME (n));
+ }
+ else if (a68_is_deprefable (n))
+ {
+ coerce = true;
+ n = SUB (n);
+ t = NO_PACK;
+ }
+ else
+ {
+ coerce = false;
+ t = NO_PACK;
+ }
+ }
+ if (t == NO_PACK)
+ {
+ if (A68_IF_MODE_IS_WELL (MOID (&d)))
+ a68_error (secondary, "M A does not yield a structured value", ori, ATTRIBUTE (secondary));
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+ return;
+ }
+
+ MOID (NEXT (p)) = n;
+ const char *fs = NSYMBOL (SUB (p));
+ MOID_T *str = n;
+ while (IS_REF (str))
+ str = SUB (str);
+ if (IS_FLEX (str))
+ str = SUB (str);
+ if (IS_ROW (str))
+ str = SUB (str);
+ t_2 = PACK (str);
+ while (t != NO_PACK && t_2 != NO_PACK)
+ {
+ if (TEXT (t) == fs || strcmp (TEXT (t), fs) == 0)
+ {
+ MOID_T *ret = MOID (t);
+ if (deflex && TRIM (ret) != NO_MOID)
+ ret = TRIM (ret);
+ a68_make_soid (y, SORT (x), ret, 0);
+ MOID (p) = ret;
+ NODE_PACK (SUB (p)) = t_2;
+ return;
+ }
+ FORWARD (t);
+ FORWARD (t_2);
+ }
+ a68_make_soid (&d, NO_SORT, n, 0);
+ a68_error (p, "M has no field Z", str, fs);
+ a68_make_soid (y, SORT (x), M_ERROR, 0);
+}
+
+/* Mode check format text. */
+
+static void
+mode_check_format_text (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ mode_check_format_text (SUB (p));
+ if (IS (p, FORMAT_PATTERN))
+ {
+ SOID_T x, y;
+ a68_make_soid (&x, STRONG, M_FORMAT, 0);
+ mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
+ if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+ a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
+ }
+ else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE)
+ {
+ SOID_T x, y;
+ a68_make_soid (&x, STRONG, M_ROW_INT, 0);
+ mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
+ if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+ a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
+ }
+ else if (IS (p, DYNAMIC_REPLICATOR))
+ {
+ SOID_T x, y;
+ a68_make_soid (&x, STRONG, M_INT, 0);
+ mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
+ if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+ a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
+ }
+ }
+}
+
+/* Mode check unit. */
+
+static void
+mode_check_unit (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+ if (p == NO_NODE)
+ return;
+ else if (a68_is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP))
+ mode_check_unit (SUB (p), x, y);
+ /* Ex primary. */
+ else if (IS (p, SPECIFICATION))
+ {
+ ATTRIBUTE (p) = mode_check_specification (SUB (p), x, y);
+ a68_warn_for_voiding (p, x, y, ATTRIBUTE (p));
+ }
+ else if (IS (p, CAST))
+ {
+ mode_check_cast (SUB (p), x, y);
+ a68_warn_for_voiding (p, x, y, CAST);
+ }
+ else if (IS (p, DENOTATION))
+ {
+ a68_make_soid (y, SORT (x), MOID (SUB (p)), 0);
+ a68_warn_for_voiding (p, x, y, DENOTATION);
+ }
+ else if (IS (p, IDENTIFIER))
+ {
+ if ((TAX (p) == NO_TAG) && (MOID (p) == NO_MOID))
+ {
+ int att = a68_first_tag_global (TABLE (p), NSYMBOL (p));
+ if (att == STOP)
+ {
+ (void) a68_add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
+ a68_error (p, "tag S has not been declared properly");
+ MOID (p) = M_ERROR;
+ }
+ else
+ {
+ TAG_T *z = a68_find_tag_global (TABLE (p), att, NSYMBOL (p));
+ if (att == IDENTIFIER && z != NO_TAG)
+ MOID (p) = MOID (z);
+ else
+ {
+ (void) a68_add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
+ a68_error (p, "tag S has not been declared properly");
+ MOID (p) = M_ERROR;
+ }
+ }
+ }
+ a68_make_soid (y, SORT (x), MOID (p), 0);
+ a68_warn_for_voiding (p, x, y, IDENTIFIER);
+ }
+ else if (IS (p, ENCLOSED_CLAUSE))
+ mode_check_enclosed (SUB (p), x, y);
+ else if (IS (p, FORMAT_TEXT))
+ {
+ mode_check_format_text (p);
+ a68_make_soid (y, SORT (x), M_FORMAT, 0);
+ a68_warn_for_voiding (p, x, y, FORMAT_TEXT);
+ /* Ex secondary. */
+ }
+ else if (IS (p, GENERATOR))
+ {
+ mode_check_declarer (SUB (p));
+ a68_make_soid (y, SORT (x), MOID (SUB (p)), 0);
+ a68_warn_for_voiding (p, x, y, GENERATOR);
+ }
+ else if (IS (p, SELECTION))
+ {
+ mode_check_selection (SUB (p), x, y);
+ a68_warn_for_voiding (p, x, y, SELECTION);
+ /* Ex tertiary. */
+ }
+ else if (IS (p, NIHIL))
+ a68_make_soid (y, STRONG, M_HIP, 0);
+ else if (IS (p, FORMULA))
+ {
+ mode_check_formula (p, x, y);
+ if (!IS_REF (MOID (y)))
+ a68_warn_for_voiding (p, x, y, FORMULA);
+ }
+ else if (a68_is_one_of (p, JUMP, SKIP, STOP))
+ {
+ if (SORT (x) != STRONG)
+ a68_warning (p, 0, "@ should not be in C context", SORT (x));
+ /* a68_make_soid (y, STRONG, M_HIP, 0); */
+ a68_make_soid (y, SORT (x), M_HIP, 0);
+ }
+ else if (IS (p, ASSIGNATION))
+ mode_check_assignation (SUB (p), x, y);
+ else if (IS (p, IDENTITY_RELATION))
+ {
+ mode_check_identity_relation (SUB (p), x, y);
+ a68_warn_for_voiding (p, x, y, IDENTITY_RELATION);
+ }
+ else if (IS (p, ROUTINE_TEXT))
+ {
+ mode_check_routine_text (SUB (p), y);
+ a68_make_soid (y, SORT (x), MOID (p), 0);
+ a68_warn_for_voiding (p, x, y, ROUTINE_TEXT);
+ }
+ else if (IS (p, ASSERTION))
+ {
+ mode_check_assertion (SUB (p));
+ a68_make_soid (y, STRONG, M_VOID, 0);
+ }
+ else if (IS (p, AND_FUNCTION))
+ {
+ mode_check_bool_function (SUB (p), x, y);
+ a68_warn_for_voiding (p, x, y, AND_FUNCTION);
+ }
+ else if (IS (p, OR_FUNCTION))
+ {
+ mode_check_bool_function (SUB (p), x, y);
+ a68_warn_for_voiding (p, x, y, OR_FUNCTION);
+ }
+
+ MOID (p) = MOID (y);
+}
+
+/* Mode check a module text. */
+
+static void
+mode_check_module_text (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, DEF_PART) || IS (p, POSTLUDE_PART))
+ {
+ /* XXX unde def is an enquiry clause */
+ SOID_T *z = NO_SOID;
+ SOID_T ix;
+ a68_make_soid (&ix, STRONG, M_VOID, 0);
+ mode_check_serial (&z, NEXT_SUB (p), &ix, true);
+ a68_free_soid_list (z);
+ }
+ }
+}
+
+/* Mode check a module declaration. */
+
+static void
+mode_check_module_declaration (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, MODULE_TEXT))
+ mode_check_module_text (SUB (p));
+ else
+ mode_check_module_declaration (SUB (p));
+ }
+}
--- /dev/null
+/* Mode coercion driver.
+ Copyright (C) 2001-2023 J. Marcel van der Veer.
+ Copyright (C) 2025 Jose E. Marchesi.
+
+ Original implementation by J. Marcel van der Veer.
+ Adapted for GCC by Jose E. Marchesi.
+
+ GCC is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ GCC is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING3. If not see
+ <http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+#define A68_INSERT_COERCIONS(n, p, q) a68_make_strong ((n), (p), MOID (q))
+
+/* A few forward references of functions defined below. */
+
+static void coerce_unit (NODE_T *p, SOID_T *q);
+static void coerce_formula (NODE_T *p, SOID_T *q __attribute__ ((unused)));
+static void coerce_operand (NODE_T *p, SOID_T *q);
+static void coerce_enclosed (NODE_T *p, SOID_T *q);
+
+/* Coerce bounds. */
+
+static void
+coerce_bounds (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, UNIT))
+ {
+ SOID_T q;
+ a68_make_soid (&q, MEEK, M_INT, 0);
+ coerce_unit (p, &q);
+ }
+ else
+ coerce_bounds (SUB (p));
+ }
+}
+
+/* Coerce declarer. */
+
+static void
+coerce_declarer (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, BOUNDS))
+ coerce_bounds (SUB (p));
+ else
+ coerce_declarer (SUB (p));
+ }
+}
+
+/* Coerce identity declaration. */
+
+static void
+coerce_identity_declaration (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ switch (ATTRIBUTE (p))
+ {
+ case DECLARER:
+ coerce_declarer (SUB (p));
+ coerce_identity_declaration (NEXT (p));
+ break;
+ case DEFINING_IDENTIFIER:
+ {
+ SOID_T q;
+ a68_make_soid (&q, STRONG, MOID (p), 0);
+ coerce_unit (NEXT_NEXT (p), &q);
+ break;
+ }
+ default:
+ coerce_identity_declaration (SUB (p));
+ coerce_identity_declaration (NEXT (p));
+ break;
+ }
+ }
+}
+
+/* Coerce variable declaration. */
+
+static void
+coerce_variable_declaration (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ switch (ATTRIBUTE (p))
+ {
+ case DECLARER:
+ coerce_declarer (SUB (p));
+ coerce_variable_declaration (NEXT (p));
+ break;
+ case DEFINING_IDENTIFIER:
+ if (a68_whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP))
+ {
+ SOID_T q;
+ a68_make_soid (&q, STRONG, SUB_MOID (p), 0);
+ coerce_unit (NEXT_NEXT (p), &q);
+ break;
+ }
+ /* Fallthrough. */
+ default:
+ coerce_variable_declaration (SUB (p));
+ coerce_variable_declaration (NEXT (p));
+ break;
+ }
+ }
+}
+
+/* Coerce routine text. */
+
+static void
+coerce_routine_text (NODE_T *p)
+{
+ if (IS (p, PARAMETER_PACK))
+ FORWARD (p);
+ SOID_T w;
+ a68_make_soid (&w, STRONG, MOID (p), 0);
+ coerce_unit (NEXT_NEXT (p), &w);
+}
+
+/* Coerce proc declaration. */
+
+static void
+coerce_proc_declaration (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, ROUTINE_TEXT))
+ coerce_routine_text (SUB (p));
+ else
+ {
+ coerce_proc_declaration (SUB (p));
+ coerce_proc_declaration (NEXT (p));
+ }
+}
+
+/* Coerce_op_declaration. */
+
+static void
+coerce_op_declaration (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, DEFINING_OPERATOR))
+ {
+ SOID_T q;
+ a68_make_soid (&q, STRONG, MOID (p), 0);
+ coerce_unit (NEXT_NEXT (p), &q);
+ }
+ else
+ {
+ coerce_op_declaration (SUB (p));
+ coerce_op_declaration (NEXT (p));
+ }
+}
+
+/* Coerce brief op declaration. */
+
+static void
+coerce_brief_op_declaration (NODE_T *p)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, DEFINING_OPERATOR))
+ coerce_routine_text (SUB (NEXT_NEXT (p)));
+ else
+ {
+ coerce_brief_op_declaration (SUB (p));
+ coerce_brief_op_declaration (NEXT (p));
+ }
+}
+
+/* Coerce declaration list. */
+
+static void
+coerce_declaration_list (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ switch (ATTRIBUTE (p))
+ {
+ case IDENTITY_DECLARATION:
+ coerce_identity_declaration (SUB (p));
+ break;
+ case VARIABLE_DECLARATION:
+ coerce_variable_declaration (SUB (p));
+ break;
+ case MODE_DECLARATION:
+ coerce_declarer (SUB (p));
+ break;
+ case PROCEDURE_DECLARATION:
+ case PROCEDURE_VARIABLE_DECLARATION:
+ coerce_proc_declaration (SUB (p));
+ break;
+ case BRIEF_OPERATOR_DECLARATION:
+ coerce_brief_op_declaration (SUB (p));
+ break;
+ case OPERATOR_DECLARATION:
+ coerce_op_declaration (SUB (p));
+ break;
+ default:
+ coerce_declaration_list (SUB (p));
+ coerce_declaration_list (NEXT (p));
+ break;
+ }
+ }
+}
+
+/* Coerce serial. */
+
+static void
+coerce_serial (NODE_T *p, SOID_T *q, bool k)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, INITIALISER_SERIES))
+ {
+ coerce_serial (SUB (p), q, false);
+ coerce_serial (NEXT (p), q, k);
+ }
+ else if (IS (p, DECLARATION_LIST))
+ coerce_declaration_list (SUB (p));
+ else if (a68_is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP))
+ coerce_serial (NEXT (p), q, k);
+ else if (a68_is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP))
+ {
+ NODE_T *z = NEXT (p);
+ if (z != NO_NODE)
+ {
+ if (IS (z, EXIT_SYMBOL) || IS (z, END_SYMBOL) || IS (z, CLOSE_SYMBOL))
+ coerce_serial (SUB (p), q, true);
+ else
+ coerce_serial (SUB (p), q, false);
+ }
+ else
+ coerce_serial (SUB (p), q, true);
+ coerce_serial (NEXT (p), q, k);
+ }
+ else if (IS (p, LABELED_UNIT))
+ coerce_serial (SUB (p), q, k);
+ else if (IS (p, UNIT))
+ {
+ if (k)
+ coerce_unit (p, q);
+ else
+ {
+ SOID_T strongvoid;
+ a68_make_soid (&strongvoid, STRONG, M_VOID, 0);
+ coerce_unit (p, &strongvoid);
+ }
+ }
+}
+
+/* Coerce closed. */
+
+static void
+coerce_closed (NODE_T *p, SOID_T *q)
+{
+ if (IS (p, SERIAL_CLAUSE))
+ coerce_serial (p, q, true);
+ else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP))
+ coerce_closed (NEXT (p), q);
+}
+
+/* Coerce access clause. */
+
+static void
+coerce_access (NODE_T *p, SOID_T *q)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, ENCLOSED_CLAUSE))
+ coerce_enclosed (p, q);
+ }
+}
+
+/* Coerce conditional. */
+
+static void
+coerce_conditional (NODE_T *p, SOID_T *q)
+{
+ SOID_T w;
+ a68_make_soid (&w, MEEK, M_BOOL, 0);
+ coerce_serial (NEXT_SUB (p), &w, true);
+ FORWARD (p);
+ coerce_serial (NEXT_SUB (p), q, true);
+ if ((FORWARD (p)) != NO_NODE)
+ {
+ if (a68_is_one_of (p, ELSE_PART, CHOICE, STOP))
+ coerce_serial (NEXT_SUB (p), q, true);
+ else if (a68_is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP))
+ coerce_conditional (SUB (p), q);
+ }
+}
+
+/* Coerce unit list. */
+
+static void
+coerce_unit_list (NODE_T *p, SOID_T *q)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, UNIT_LIST))
+ {
+ coerce_unit_list (SUB (p), q);
+ coerce_unit_list (NEXT (p), q);
+ }
+ else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP))
+ coerce_unit_list (NEXT (p), q);
+ else if (IS (p, UNIT))
+ {
+ coerce_unit (p, q);
+ coerce_unit_list (NEXT (p), q);
+ }
+}
+
+/* Coerce int case. */
+
+static void
+coerce_int_case (NODE_T *p, SOID_T *q)
+{
+ SOID_T w;
+ a68_make_soid (&w, MEEK, M_INT, 0);
+ coerce_serial (NEXT_SUB (p), &w, true);
+ FORWARD (p);
+ coerce_unit_list (NEXT_SUB (p), q);
+ if ((FORWARD (p)) != NO_NODE)
+ {
+ if (a68_is_one_of (p, OUT_PART, CHOICE, STOP))
+ coerce_serial (NEXT_SUB (p), q, true);
+ else if (a68_is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP))
+ coerce_int_case (SUB (p), q);
+ }
+}
+
+/* Coerce spec unit list. */
+
+static void
+coerce_spec_unit_list (NODE_T *p, SOID_T *q)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (a68_is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP))
+ coerce_spec_unit_list (SUB (p), q);
+ else if (IS (p, UNIT))
+ coerce_unit (p, q);
+ }
+}
+
+/* Coerce united case. */
+
+static void
+coerce_united_case (NODE_T *p, SOID_T *q)
+{
+ SOID_T w;
+ a68_make_soid (&w, MEEK, MOID (SUB (p)), 0);
+ coerce_serial (NEXT_SUB (p), &w, true);
+ FORWARD (p);
+ coerce_spec_unit_list (NEXT_SUB (p), q);
+ if ((FORWARD (p)) != NO_NODE)
+ {
+ if (a68_is_one_of (p, OUT_PART, CHOICE, STOP))
+ coerce_serial (NEXT_SUB (p), q, true);
+ else if (a68_is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP))
+ coerce_united_case (SUB (p), q);
+ }
+}
+
+/* Coerce loop. */
+
+static void
+coerce_loop (NODE_T *p)
+{
+ if (IS (p, FOR_PART))
+ coerce_loop (NEXT (p));
+ else if (a68_is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP))
+ {
+ SOID_T w;
+ a68_make_soid (&w, MEEK, M_INT, 0);
+ coerce_unit (NEXT_SUB (p), &w);
+ coerce_loop (NEXT (p));
+ }
+ else if (IS (p, WHILE_PART))
+ {
+ SOID_T w;
+ a68_make_soid (&w, MEEK, M_BOOL, 0);
+ coerce_serial (NEXT_SUB (p), &w, true);
+ coerce_loop (NEXT (p));
+ }
+ else if (a68_is_one_of (p, DO_PART, ALT_DO_PART, STOP))
+ {
+ SOID_T w;
+ NODE_T *do_p = NEXT_SUB (p);
+ a68_make_soid (&w, STRONG, M_VOID, 0);
+ coerce_serial (do_p, &w, true);
+ }
+}
+
+/* Coerce struct display. */
+
+static void
+coerce_struct_display (PACK_T **r, NODE_T *p)
+{
+ if (p == NO_NODE)
+ return;
+ else if (IS (p, UNIT_LIST))
+ {
+ coerce_struct_display (r, SUB (p));
+ coerce_struct_display (r, NEXT (p));
+ }
+ else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP))
+ coerce_struct_display (r, NEXT (p));
+ else if (IS (p, UNIT))
+ {
+ SOID_T s;
+ a68_make_soid (&s, STRONG, MOID (*r), 0);
+ coerce_unit (p, &s);
+ FORWARD (*r);
+ coerce_struct_display (r, NEXT (p));
+ }
+}
+
+/* Coerce collateral. */
+
+static void
+coerce_collateral (NODE_T *p, SOID_T *q)
+{
+ if (!(a68_whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP)
+ || a68_whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP)))
+ {
+ if (IS (MOID (q), STRUCT_SYMBOL))
+ {
+ PACK_T *t = PACK (MOID (q));
+ coerce_struct_display (&t, p);
+ }
+ else if (IS_FLEX (MOID (q)))
+ {
+ SOID_T w;
+ a68_make_soid (&w, STRONG, SLICE (SUB_MOID (q)), 0);
+ coerce_unit_list (p, &w);
+ }
+ else if (IS_ROW (MOID (q)))
+ {
+ SOID_T w;
+ a68_make_soid (&w, STRONG, SLICE (MOID (q)), 0);
+ coerce_unit_list (p, &w);
+ }
+ else
+ {
+ /* if (MOID (q) != M_VOID). */
+ coerce_unit_list (p, q);
+ }
+ }
+}
+
+/* Coerce_enclosed. */
+
+static void
+coerce_enclosed (NODE_T *p, SOID_T *q)
+{
+ if (IS (p, ENCLOSED_CLAUSE))
+ coerce_enclosed (SUB (p), q);
+ else if (IS (p, CLOSED_CLAUSE))
+ coerce_closed (SUB (p), q);
+ else if (IS (p, COLLATERAL_CLAUSE))
+ coerce_collateral (SUB (p), q);
+ else if (IS (p, ACCESS_CLAUSE))
+ coerce_access (SUB (p), q);
+ else if (IS (p, PARALLEL_CLAUSE))
+ coerce_collateral (SUB (NEXT_SUB (p)), q);
+ else if (IS (p, CONDITIONAL_CLAUSE))
+ coerce_conditional (SUB (p), q);
+ else if (IS (p, CASE_CLAUSE))
+ coerce_int_case (SUB (p), q);
+ else if (IS (p, CONFORMITY_CLAUSE))
+ coerce_united_case (SUB (p), q);
+ else if (IS (p, LOOP_CLAUSE))
+ coerce_loop (SUB (p));
+
+ MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+}
+
+/* Get monad moid. */
+
+static MOID_T *
+get_monad_moid (NODE_T *p)
+{
+ if (TAX (p) != NO_TAG && TAX (p) != A68_PARSER (error_tag))
+ {
+ MOID (p) = MOID (TAX (p));
+ return MOID (PACK (MOID (p)));
+ }
+ else
+ return M_ERROR;
+}
+
+/* Coerce monad oper. */
+
+static void
+coerce_monad_oper (NODE_T *p, SOID_T *q)
+{
+ if (p != NO_NODE)
+ {
+ SOID_T z;
+ a68_make_soid (&z, FIRM, MOID (PACK (MOID (TAX (p)))), 0);
+ A68_INSERT_COERCIONS (NEXT (p), MOID (q), &z);
+ }
+}
+
+/* Coerce monad formula. */
+
+static void
+coerce_monad_formula (NODE_T *p)
+{
+ SOID_T e;
+ a68_make_soid (&e, STRONG, get_monad_moid (p), 0);
+ coerce_operand (NEXT (p), &e);
+ coerce_monad_oper (p, &e);
+}
+
+/* Coerce operand. */
+
+static void
+coerce_operand (NODE_T *p, SOID_T *q)
+{
+ if (IS (p, MONADIC_FORMULA))
+ {
+ coerce_monad_formula (SUB (p));
+ if (MOID (p) != MOID (q))
+ {
+ a68_make_sub (p, p, FORMULA);
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ a68_make_sub (p, p, TERTIARY);
+ }
+ MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+ }
+ else if (IS (p, FORMULA))
+ {
+ coerce_formula (SUB (p), q);
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+ }
+ else if (IS (p, SECONDARY))
+ {
+ coerce_unit (SUB (p), q);
+ MOID (p) = MOID (SUB (p));
+ }
+}
+
+/* Coerce formula. */
+
+static void
+coerce_formula (NODE_T *p, SOID_T *q __attribute__ ((unused)))
+{
+ if (IS (p, MONADIC_FORMULA) && NEXT (p) == NO_NODE)
+ coerce_monad_formula (SUB (p));
+ else
+ {
+ if (TAX (NEXT (p)) != NO_TAG && TAX (NEXT (p)) != A68_PARSER (error_tag))
+ {
+ SOID_T s;
+ NODE_T *op = NEXT (p), *nq = NEXT_NEXT (p);
+ MOID_T *w = MOID (op);
+ MOID_T *u = MOID (PACK (w)), *v = MOID (NEXT (PACK (w)));
+ a68_make_soid (&s, STRONG, u, 0);
+ coerce_operand (p, &s);
+ a68_make_soid (&s, STRONG, v, 0);
+ coerce_operand (nq, &s);
+ }
+ }
+}
+
+/* Coerce assignation. */
+
+static void
+coerce_assignation (NODE_T *p)
+{
+ SOID_T w;
+ a68_make_soid (&w, SOFT, MOID (p), 0);
+ coerce_unit (SUB (p), &w);
+ a68_make_soid (&w, STRONG, SUB_MOID (p), 0);
+ coerce_unit (NEXT_NEXT (p), &w);
+}
+
+/* Coerce relation. */
+
+static void
+coerce_relation (NODE_T *p)
+{
+ SOID_T w;
+ a68_make_soid (&w, STRONG, MOID (p), 0);
+ coerce_unit (SUB (p), &w);
+ a68_make_soid (&w, STRONG, MOID (NEXT_NEXT (p)), 0);
+ coerce_unit (SUB (NEXT_NEXT (p)), &w);
+}
+
+/* Coerce bool function. */
+
+static void
+coerce_bool_function (NODE_T *p)
+{
+ SOID_T w;
+ a68_make_soid (&w, STRONG, M_BOOL, 0);
+ coerce_unit (SUB (p), &w);
+ coerce_unit (SUB (NEXT_NEXT (p)), &w);
+}
+
+/* Coerce assertion. */
+
+static void
+coerce_assertion (NODE_T *p)
+{
+ SOID_T w;
+ a68_make_soid (&w, MEEK, M_BOOL, 0);
+ coerce_enclosed (SUB_NEXT (p), &w);
+}
+
+/* Coerce selection. */
+
+static void
+coerce_selection (NODE_T * p)
+{
+ SOID_T w;
+ a68_make_soid (&w, STRONG, MOID (NEXT (p)), 0);
+ coerce_unit (SUB_NEXT (p), &w);
+}
+
+/* Coerce cast. */
+
+static void
+coerce_cast (NODE_T * p)
+{
+ coerce_declarer (p);
+ SOID_T w;
+ a68_make_soid (&w, STRONG, MOID (p), 0);
+ coerce_enclosed (NEXT (p), &w);
+}
+
+/* Coerce argument list. */
+
+static void
+coerce_argument_list (PACK_T **r, NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, ARGUMENT_LIST))
+ coerce_argument_list (r, SUB (p));
+ else if (IS (p, UNIT))
+ {
+ SOID_T s;
+ a68_make_soid (&s, STRONG, MOID (*r), 0);
+ coerce_unit (p, &s);
+ FORWARD (*r);
+ }
+ else if (IS (p, TRIMMER))
+ FORWARD (*r);
+ }
+}
+
+/* Coerce call. */
+
+static void
+coerce_call (NODE_T *p)
+{
+ MOID_T *proc = MOID (p);
+ SOID_T w;
+ a68_make_soid (&w, MEEK, proc, 0);
+ coerce_unit (SUB (p), &w);
+ FORWARD (p);
+ PACK_T *t = PACK (proc);
+ coerce_argument_list (&t, SUB (p));
+}
+
+/* Coerce meek int. */
+
+static void
+coerce_meek_int (NODE_T *p)
+{
+ SOID_T x;
+ a68_make_soid (&x, MEEK, M_INT, 0);
+ coerce_unit (p, &x);
+}
+
+/* Coerce trimmer. */
+
+static void
+coerce_trimmer (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, UNIT))
+ {
+ coerce_meek_int (p);
+ coerce_trimmer (NEXT (p));
+ }
+ else
+ coerce_trimmer (NEXT (p));
+ }
+}
+
+/* Coerce indexer. */
+
+static void
+coerce_indexer (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, TRIMMER))
+ coerce_trimmer (SUB (p));
+ else if (IS (p, UNIT))
+ coerce_meek_int (p);
+ else
+ {
+ coerce_indexer (SUB (p));
+ coerce_indexer (NEXT (p));
+ }
+ }
+}
+
+/* Coerce_slice. */
+
+static void
+coerce_slice (NODE_T *p)
+{
+ SOID_T w;
+ MOID_T *row = MOID (p);
+ a68_make_soid (&w, STRONG, row, 0);
+ coerce_unit (SUB (p), &w);
+ coerce_indexer (SUB_NEXT (p));
+}
+
+/* Coerce format text. */
+
+static void
+coerce_format_text (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ coerce_format_text (SUB (p));
+ if (IS (p, FORMAT_PATTERN))
+ {
+ SOID_T x;
+ a68_make_soid (&x, STRONG, M_FORMAT, 0);
+ coerce_enclosed (SUB (NEXT_SUB (p)), &x);
+ }
+ else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE)
+ {
+ SOID_T x;
+ a68_make_soid (&x, STRONG, M_ROW_INT, 0);
+ coerce_enclosed (SUB (NEXT_SUB (p)), &x);
+ }
+ else if (IS (p, DYNAMIC_REPLICATOR))
+ {
+ SOID_T x;
+ a68_make_soid (&x, STRONG, M_INT, 0);
+ coerce_enclosed (SUB (NEXT_SUB (p)), &x);
+ }
+ }
+}
+
+/* Coerce unit. */
+
+static void
+coerce_unit (NODE_T *p, SOID_T *q)
+{
+ if (p == NO_NODE)
+ return;
+ else if (a68_is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP))
+ {
+ coerce_unit (SUB (p), q);
+ MOID (p) = MOID (SUB (p));
+ /* Ex primary. */
+ }
+ else if (IS (p, CALL))
+ {
+ coerce_call (SUB (p));
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ }
+ else if (IS (p, SLICE))
+ {
+ coerce_slice (SUB (p));
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ }
+ else if (IS (p, CAST))
+ {
+ coerce_cast (SUB (p));
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ }
+ else if (a68_is_one_of (p, DENOTATION, IDENTIFIER, STOP))
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ else if (IS (p, FORMAT_TEXT))
+ {
+ coerce_format_text (SUB (p));
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ }
+ else if (IS (p, ENCLOSED_CLAUSE))
+ {
+ coerce_enclosed (p, q);
+ /* Ex secondary. */
+ }
+ else if (IS (p, SELECTION))
+ {
+ coerce_selection (SUB (p));
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ }
+ else if (IS (p, GENERATOR))
+ {
+ coerce_declarer (SUB (p));
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ /* Ex tertiary. */
+ }
+ else if (IS (p, NIHIL))
+ {
+ if (ATTRIBUTE (MOID (q)) != REF_SYMBOL && MOID (q) != M_VOID)
+ a68_error (p, "context does not require a name");
+ MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+ }
+ else if (IS (p, FORMULA))
+ {
+ coerce_formula (SUB (p), q);
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ }
+ else if (IS (p, JUMP))
+ {
+ if (MOID (q) == M_PROC_VOID)
+ a68_make_sub (p, p, PROCEDURING);
+ MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+ }
+ else if (IS (p, SKIP))
+ MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+ else if (IS (p, ASSIGNATION))
+ {
+ coerce_assignation (SUB (p));
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+ }
+ else if (IS (p, IDENTITY_RELATION))
+ {
+ coerce_relation (SUB (p));
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ }
+ else if (IS (p, ROUTINE_TEXT))
+ {
+ coerce_routine_text (SUB (p));
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ }
+ else if (a68_is_one_of (p, AND_FUNCTION, OR_FUNCTION, STOP))
+ {
+ coerce_bool_function (SUB (p));
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ }
+ else if (IS (p, ASSERTION))
+ {
+ coerce_assertion (SUB (p));
+ A68_INSERT_COERCIONS (p, MOID (p), q);
+ }
+}
+
+/* Coerce module text. */
+
+static void
+coerce_module_text (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, DEF_PART) || IS (p, POSTLUDE_PART))
+ {
+ SOID_T w;
+ a68_make_soid (&w, STRONG, M_VOID, 0);
+ coerce_serial (NEXT_SUB (p), &w, true);
+ }
+ }
+}
+
+/* Coerce module declaration. */
+
+static void
+coerce_module_declaration (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, MODULE_TEXT))
+ coerce_module_text (SUB (p));
+ else
+ coerce_module_declaration (SUB (p));
+ }
+}
+
+/* Driver for coercion insertions. */
+
+void
+a68_coercion_inserter (NODE_T *p)
+{
+ if (IS (p, PACKET))
+ {
+ p = SUB (p);
+ if (IS (p, PARTICULAR_PROGRAM))
+ {
+ SOID_T q;
+ a68_make_soid (&q, STRONG, M_VOID, 0);
+ coerce_enclosed (SUB (p), &q);
+ }
+ else if (IS (p, PRELUDE_PACKET))
+ coerce_module_declaration (SUB (p));
+ }
+}
--- /dev/null
+/* Prove equivalence of modes.
+ Copyright (C) 2001-2023 J. Marcel van der Veer.
+ Copyright (C) 2025 Jose E. Marchesi.
+
+ Original implementation by J. Marcel van der Veer.
+ Adapted for GCC by Jose E. Marchesi.
+
+ GCC is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ GCC is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING3. If not see
+ <http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+/* Routines for establishing equivalence of modes.
+ After I made this mode equivalencer (in 1993), I found:
+
+ Algol Bulletin 30.3.3 C.H.A. Koster: On infinite modes, 86-89 [1969],
+
+ which essentially concurs with this test on mode equivalence I wrote.
+ It is elementary logic anyway: prove equivalence, assuming equivalence. */
+
+/* Forward declarations of some of the functions defined below. */
+
+static bool are_modes_equivalent (MOID_T * a, MOID_T * b);
+
+/* Whether packs are equivalent, same sequence of equivalence modes. */
+
+static bool
+are_packs_equivalent (PACK_T *s, PACK_T *t,
+ bool compare_names = true)
+{
+ for (; s != NO_PACK && t != NO_PACK; s = s->next, t = t->next)
+ {
+ if (!are_modes_equivalent (MOID (s), MOID (t)))
+ return false;
+ if (compare_names)
+ {
+ if (TEXT (s) != TEXT (t)
+ && TEXT (s) != NO_TEXT
+ && TEXT (t) != NO_TEXT
+ && strcmp (TEXT (s), TEXT (t)) != 0)
+ return false;
+ }
+ }
+
+ return s == NO_PACK && t == NO_PACK;
+}
+
+/* Whether packs are subsets. */
+
+static bool
+is_united_subset (PACK_T *s, PACK_T *t)
+{
+ /* For all modes in 's' there must be an equivalent in 't'. */
+ for (PACK_T *p = s; p != NO_PACK; p = p->next)
+ {
+ bool f = false;
+ for (PACK_T *q = t; q != NO_PACK && !f; q = q->next)
+ f = are_modes_equivalent (MOID (p), MOID (q));
+
+ if (!f)
+ return false;
+ }
+
+ return true;
+}
+
+/* Whether packs are subsets. */
+
+static bool
+are_united_packs_equivalent (PACK_T *s, PACK_T *t)
+{
+ return is_united_subset (s, t) && is_united_subset (t, s);
+}
+
+/* Whether moids A and B are structurally equivalent. */
+
+static bool
+are_modes_equivalent (MOID_T * a, MOID_T * b)
+{
+ /* First lets try some cheap heuristics. */
+
+ if (a == NO_MOID || b == NO_MOID)
+ /* Modes can be NO_MOID in partial argument lists. */
+ return false;
+ else if (a == M_ERROR || b == M_ERROR)
+ return false;
+ else if (a == b)
+ return true;
+ else if (ATTRIBUTE (a) != ATTRIBUTE (b))
+ return false;
+ else if (DIM (a) != DIM (b))
+ return false;
+ else if (IS (a, STANDARD))
+ return (a == b);
+ else if (EQUIVALENT (a) == b || EQUIVALENT (b) == a)
+ return true;
+ else if (a68_is_postulated_pair (A68 (top_postulate), a, b)
+ || a68_is_postulated_pair (A68 (top_postulate), b, a))
+ return true;
+ else if (IS (a, INDICANT))
+ {
+ if (NODE (a) == NO_NODE || NODE (b) == NO_NODE)
+ return false;
+ else
+ return (NODE (a) == NODE (b)
+ || strcmp (NSYMBOL (NODE (a)), NSYMBOL (NODE (b))) == 0);
+ }
+
+ /* Investigate structure. */
+
+ /* We now know that 'a' and 'b' have same attribute, dimension, ... */
+ if (IS (a, REF_SYMBOL))
+ /* REF MODE */
+ return are_modes_equivalent (a->sub, b->sub);
+ else if (IS (a, ROW_SYMBOL))
+ /* [] MODE */
+ return are_modes_equivalent (a->sub, b->sub);
+ else if (IS (a, FLEX_SYMBOL))
+ /* FLEX [...] MODE */
+ return are_modes_equivalent (a->sub, b->sub);
+ else if (IS (a, STRUCT_SYMBOL))
+ {
+ /* STRUCT (...) */
+ POSTULATE_T *save = A68 (top_postulate);
+ a68_make_postulate (&A68 (top_postulate), a, b);
+ bool z = are_packs_equivalent (PACK (a), PACK (b));
+ a68_free_postulate_list (A68 (top_postulate), save);
+ A68 (top_postulate) = save;
+ return z;
+ }
+ else if (IS (a, UNION_SYMBOL))
+ /* UNION (...) */
+ return are_united_packs_equivalent (PACK (a), PACK (b));
+ else if (IS (a, PROC_SYMBOL) && PACK (a) == NO_PACK && PACK (b) == NO_PACK)
+ /* PROC MOID */
+ return are_modes_equivalent (a->sub, b->sub);
+ else if (IS (a, PROC_SYMBOL) && PACK (a) != NO_PACK && PACK (b) != NO_PACK)
+ {
+ /* PROC (...) MOID */
+ POSTULATE_T *save = A68 (top_postulate);
+ a68_make_postulate (&A68 (top_postulate), a, b);
+ bool z = are_modes_equivalent (a->sub, b->sub);
+ if (z)
+ z = are_packs_equivalent (PACK (a), PACK (b),
+ false /* compare_names */);
+ a68_free_postulate_list (A68 (top_postulate), save);
+ A68 (top_postulate) = save;
+ return z;
+ }
+ else if (IS (a, SERIES_MODE) || IS (a, STOWED_MODE))
+ /* Modes occurring in displays. */
+ return are_packs_equivalent (PACK (a), PACK (b));
+
+ return false;
+}
+
+//! @brief Whether two modes are structurally equivalent.
+
+bool
+a68_prove_moid_equivalence (MOID_T *p, MOID_T *q)
+{
+// Prove two modes to be equivalent under assumption that they indeed are.
+ POSTULATE_T *save = A68 (top_postulate);
+ bool z = are_modes_equivalent (p, q);
+ a68_free_postulate_list (A68 (top_postulate), save);
+ A68 (top_postulate) = save;
+ return z;
+}
--- /dev/null
+/* Postulates needed for improving equivalence of modes.
+ Copyright (C) 2001-2023 J. Marcel van der Veer.
+ Copyright (C) 2025 Jose E. Marchesi.
+
+ Original implementation by J. Marcel van der Veer.
+ Adapted for GCC by Jose E. Marchesi.
+
+ GCC is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ GCC is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+ License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING3. If not see
+ <http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+/* Initialise use of postulate-lists. */
+
+void
+a68_init_postulates (void)
+{
+ A68 (top_postulate) = NO_POSTULATE;
+ A68 (top_postulate_list) = NO_POSTULATE;
+}
+
+/* Make old postulates available for new use. */
+
+void
+a68_free_postulate_list (POSTULATE_T *start, POSTULATE_T *stop)
+{
+ if (start == stop)
+ return;
+
+ POSTULATE_T *last = start;
+ for (; NEXT (last) != stop; FORWARD (last))
+ ;
+
+ NEXT (last) = A68 (top_postulate_list);
+ A68 (top_postulate_list) = start;
+}
+
+/* Add postulates to postulate-list. */
+
+void
+a68_make_postulate (POSTULATE_T **p, MOID_T *a, MOID_T *b)
+{
+ POSTULATE_T *new_one;
+
+ if (A68 (top_postulate_list) != NO_POSTULATE)
+ {
+ new_one = A68 (top_postulate_list);
+ A68 (top_postulate_list) = A68 (top_postulate_list)->next;
+ }
+ else
+ {
+ new_one = (POSTULATE_T *) ggc_cleared_alloc<POSTULATE_T> ();
+ A68 (new_postulates)++;
+ }
+
+ new_one->a = a;
+ new_one->b = b;
+ new_one->next = *p;
+ *p = new_one;
+}
+
+/* Where postulates are in the list. */
+
+POSTULATE_T
+*a68_is_postulated_pair (POSTULATE_T *p, MOID_T *a, MOID_T *b)
+{
+ for (; p != NO_POSTULATE; p = p->next)
+ {
+ if (p->a == a && p->b == b)
+ return p;
+ }
+
+ return NO_POSTULATE;
+}
+
+/* Where postulate is in the list. */
+
+POSTULATE_T
+*a68_is_postulated (POSTULATE_T *p, MOID_T *a)
+{
+ for (; p != NO_POSTULATE; p = p->next)
+ {
+ if (p->a == a)
+ return p;
+ }
+
+ return NO_POSTULATE;
+}
projects / gcc.git / commitdiff