From: Jose E. Marchesi Date: Sat, 11 Oct 2025 17:49:23 +0000 (+0200) Subject: a68: parser: parsing of modes X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=942dff65c0c566d4d3a9ab9481f4c461ff22059e;p=thirdparty%2Fgcc.git a68: parser: parsing of modes Signed-off-by: Jose E. Marchesi Co-authored-by: Marcel van der Veer --- diff --git a/gcc/algol68/a68-moids-diagnostics.cc b/gcc/algol68/a68-moids-diagnostics.cc new file mode 100644 index 00000000000..a984fbc868f --- /dev/null +++ b/gcc/algol68/a68-moids-diagnostics.cc @@ -0,0 +1,281 @@ +/* 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 + . */ + +#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); +} diff --git a/gcc/algol68/a68-moids-misc.cc b/gcc/algol68/a68-moids-misc.cc new file mode 100644 index 00000000000..349c13fd656 --- /dev/null +++ b/gcc/algol68/a68-moids-misc.cc @@ -0,0 +1,1396 @@ +/* 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 + . */ + +#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 (); + 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); +} diff --git a/gcc/algol68/a68-moids-to-string.cc b/gcc/algol68/a68-moids-to-string.cc new file mode 100644 index 00000000000..9140329db8d --- /dev/null +++ b/gcc/algol68/a68-moids-to-string.cc @@ -0,0 +1,417 @@ +/* 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 + . */ + +#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 ? "%%" : "%%"; + const char *strop_simplout = supper_stropping ? "%%" : "%%"; + const char *strop_rows = supper_stropping ? "%%" : "%%"; + const char *strop_vacuum = supper_stropping ? "%%" : "%%"; + 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 +} diff --git a/gcc/algol68/a68-parser-modes.cc b/gcc/algol68/a68-parser-modes.cc new file mode 100644 index 00000000000..4a0128667ca --- /dev/null +++ b/gcc/algol68/a68-parser-modes.cc @@ -0,0 +1,1325 @@ +/* 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 + . */ + +#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 (); +} diff --git a/gcc/algol68/a68-parser-moids-check.cc b/gcc/algol68/a68-parser-moids-check.cc new file mode 100644 index 00000000000..a7b02cb1957 --- /dev/null +++ b/gcc/algol68/a68-parser-moids-check.cc @@ -0,0 +1,1878 @@ +/* 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 + . */ + +/* 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)); + } +} diff --git a/gcc/algol68/a68-parser-moids-coerce.cc b/gcc/algol68/a68-parser-moids-coerce.cc new file mode 100644 index 00000000000..3e127c909f1 --- /dev/null +++ b/gcc/algol68/a68-parser-moids-coerce.cc @@ -0,0 +1,925 @@ +/* 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 + . */ + +#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)); + } +} diff --git a/gcc/algol68/a68-parser-moids-equivalence.cc b/gcc/algol68/a68-parser-moids-equivalence.cc new file mode 100644 index 00000000000..c022f9cb673 --- /dev/null +++ b/gcc/algol68/a68-parser-moids-equivalence.cc @@ -0,0 +1,183 @@ +/* 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 + . */ + +#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; +} diff --git a/gcc/algol68/a68-postulates.cc b/gcc/algol68/a68-postulates.cc new file mode 100644 index 00000000000..f291205114d --- /dev/null +++ b/gcc/algol68/a68-postulates.cc @@ -0,0 +1,103 @@ +/* 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 + . */ + +#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 (); + 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; +}