[PATCH] algol68: Fix assignment of union overhead values [PR algol68/124049]
James Bohl
bohlj47@gmail.com
Tue Feb 10 03:20:33 GMT 2026
This patch sorts union packs in the a68-parser function so that
equivalent unions defined in different packets are assigned the same
mapping of mode to overhead value.
Signed-off-by: James Bohl <bohlj47@gmail.com>
gcc/algol68/ChangeLog
PR algol68/124049
* a68.h: Prototype for a68_sort_union_packs.
* a68-parser-modes.cc (packs_ordering): New function.
(mode_ordering): Likewise.
(add_mode_to_pack_sorted): Likewise.
(sort_union_pack): Likewise.
(a68_sort_union_packs): Likewise.
* a68-parser.cc (a68_parser): Call a68_sort_union_packs.
gcc/testsuite/ChangeLog
PR algol68/124049
* algol68/execute/modules/program-25.a68: New test.
* algol68/execute/modules/module25a.a68: New file.
* algol68/execute/modules/module25b.a68: New file.
---
gcc/algol68/a68-parser-modes.cc | 156 ++++++++++++++++++
gcc/algol68/a68-parser.cc | 7 +
gcc/algol68/a68.h | 1 +
.../algol68/execute/modules/module25a.a68 | 10 ++
.../algol68/execute/modules/module25b.a68 | 10 ++
.../algol68/execute/modules/program-25.a68 | 9 +
6 files changed, 193 insertions(+)
create mode 100644 gcc/testsuite/algol68/execute/modules/module25a.a68
create mode 100644 gcc/testsuite/algol68/execute/modules/module25b.a68
create mode 100644 gcc/testsuite/algol68/execute/modules/program-25.a68
diff --git a/gcc/algol68/a68-parser-modes.cc b/gcc/algol68/a68-parser-modes.cc
index 5842d1325f0..09b88ad15c9 100644
--- a/gcc/algol68/a68-parser-modes.cc
+++ b/gcc/algol68/a68-parser-modes.cc
@@ -32,6 +32,8 @@
/* Few forward references. */
static MOID_T *get_mode_from_declarer (NODE_T *p);
+static int mode_ordering (MOID_T *a,MOID_T *b);
+static PACK_T * sort_union_pack (PACK_T *u);
/*
* Mode service routines.
@@ -198,6 +200,160 @@ a68_add_mode (MOID_T **z, int att, int dim, NODE_T *node, MOID_T *sub, PACK_T *p
return a68_register_extra_mode (z, new_mode);
}
+/* Returns a negative value if 'a' should be ordered after 'b'.
+ Returns a positive value if 'a' should be ordered before 'b'.
+ Returns zero if 'a' and 'b' are equivalent. */
+
+static int
+packs_ordering (PACK_T *a, PACK_T *b, bool compare_names = true)
+{
+ for (; a != NO_PACK && b != NO_PACK; FORWARD (a), FORWARD (b))
+ {
+ int order = mode_ordering (MOID (a), MOID (b));
+ if (order != 0)
+ return order;
+ if (compare_names)
+ {
+ if (TEXT (a) != TEXT (b))
+ {
+ if (TEXT (a) == NO_TEXT)
+ return 1;
+ if (TEXT (b) == NO_TEXT)
+ return -1;
+ return strcmp (TEXT (a), TEXT (b));
+ }
+ }
+ }
+ return 0;
+}
+
+/* Returns a negative value if 'a' should be ordered after 'b'.
+ Returns a positive value if 'a' should be ordered before 'b'.
+ Returns zero if 'a' and 'b' are equivalent. */
+
+static int
+mode_ordering (MOID_T *a, MOID_T *b)
+{
+ if (a == b)
+ return 0;
+ int r = ATTRIBUTE (a) - ATTRIBUTE (b);
+ if (r != 0)
+ return r;
+ r = DIM (a) - DIM (b);
+ if (r != 0)
+ return r;
+ if (IS (a, STANDARD))
+ return strcmp (NSYMBOL (NODE (a)), NSYMBOL (NODE (b)));
+ else if (EQUIVALENT (a) == b || EQUIVALENT (b) == a)
+ return 0;
+ else if (a68_is_postulated_pair (A68 (top_postulate), a, b)
+ || a68_is_postulated_pair (A68 (top_postulate), b, a))
+ return 0;
+ else if (IS (a, INDICANT))
+ {
+ if (NODE (a) == NO_NODE)
+ return 1;
+ if (NODE (b) == NO_NODE)
+ return -1;
+ if (NODE (a) == NODE (b))
+ return 0;
+ return strcmp (NSYMBOL (NODE (a)), NSYMBOL (NODE (b)));
+ }
+ else if (IS (a, REF_SYMBOL))
+ return mode_ordering (SUB (a), SUB (b));
+ else if (IS (a, ROW_SYMBOL))
+ return mode_ordering (SUB (a), SUB (b));
+ else if (IS (a, FLEX_SYMBOL))
+ return mode_ordering (SUB (a), SUB (b));
+ else if (IS (a, STRUCT_SYMBOL))
+ {
+ POSTULATE_T *save = A68 (top_postulate);
+ a68_make_postulate (&A68 (top_postulate), a, b);
+ r = packs_ordering (PACK (a), PACK (b));
+ a68_free_postulate_list (A68 (top_postulate), save);
+ A68 (top_postulate) = save;
+ return r;
+ }
+ else if (IS (a, UNION_SYMBOL))
+ {
+ PACK (a) = sort_union_pack (PACK (a));
+ PACK (b) = sort_union_pack (PACK (b));
+ return packs_ordering (PACK (a), PACK (b), false);
+ }
+ else if (IS (a, PROC_SYMBOL))
+ {
+ POSTULATE_T *save = A68 (top_postulate);
+ a68_make_postulate (&A68 (top_postulate), a, b);
+ r = mode_ordering (SUB (a), SUB (b));
+ if (r == 0)
+ r = packs_ordering (PACK (a), PACK (b), false);
+ a68_free_postulate_list (A68 (top_postulate), save);
+ A68 (top_postulate) = save;
+ return r;
+ }
+ else if (IS (a, SERIES_MODE) || IS (a, STOWED_MODE))
+ return packs_ordering (PACK (a), PACK (b), false);
+ return 0;
+}
+
+/* Add a moid to a sorted pack, maybe with a (field) name. */
+
+static void
+add_mode_to_pack_sorted (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;
+
+ PACK_T *next = (*p);
+ PACK_T *previous = NO_PACK;
+ while (next != NO_PACK)
+ {
+ int order = mode_ordering (m,MOID (next));
+ if (order > 0)
+ break;
+ previous = next;
+ FORWARD (next);
+ }
+ NEXT (z) = next;
+ PREVIOUS (z) = previous;
+
+ if (previous == NO_PACK)
+ *p = z;
+ else
+ NEXT (previous) = z;
+
+ if (next != NO_PACK)
+ PREVIOUS (next) = z;
+}
+
+/* Sort modes in a UNION pack. */
+
+static PACK_T *
+sort_union_pack (PACK_T *u)
+{
+ PACK_T *z = NO_PACK;
+ for (PACK_T *t = u; t != NO_PACK; FORWARD (t))
+ {
+ (void) add_mode_to_pack_sorted (&z, MOID (t), NO_TEXT, NODE (t));
+ }
+ return z;
+}
+
+/* Sort modes in UNION packs. */
+
+void
+a68_sort_union_packs (MOID_T *m)
+{
+ for (; m != NO_MOID; FORWARD (m))
+ {
+ if (IS (m, UNION_SYMBOL))
+ PACK (m) = sort_union_pack (PACK (m));
+ }
+}
+
/* Contract a UNION. */
void
diff --git a/gcc/algol68/a68-parser.cc b/gcc/algol68/a68-parser.cc
index 885b5f524d9..4070d3fa323 100644
--- a/gcc/algol68/a68-parser.cc
+++ b/gcc/algol68/a68-parser.cc
@@ -599,6 +599,13 @@ a68_parser (const char *filename)
a68_serial_dsa (TOP_NODE (&A68_JOB));
}
+ /* Sort union packs so overhead values are assigned in the same order for
+ equivalent unions in different packets. */
+ if (ERROR_COUNT (&A68_JOB) == 0)
+ {
+ a68_sort_union_packs (TOP_MOID (&A68_JOB));
+ }
+
/* Finalise syntax tree. */
if (ERROR_COUNT (&A68_JOB) == 0)
{
diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h
index 2492aea6e2a..565d1a4c72f 100644
--- a/gcc/algol68/a68.h
+++ b/gcc/algol68/a68.h
@@ -410,6 +410,7 @@ PACK_T *a68_absorb_union_pack (PACK_T * u);
void a68_add_mode_to_pack (PACK_T **p, MOID_T *m, const char *text, NODE_T *node);
void a68_add_mode_to_pack_end (PACK_T **p, MOID_T *m, const char *text, NODE_T *node);
void a68_make_moid_list (MODULE_T *mod);
+void a68_sort_union_packs (MOID_T* m);
void a68_renumber_moids (MOID_T *p, int n);
diff --git a/gcc/testsuite/algol68/execute/modules/module25a.a68 b/gcc/testsuite/algol68/execute/modules/module25a.a68
new file mode 100644
index 00000000000..95950ba1c1c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/modules/module25a.a68
@@ -0,0 +1,10 @@
+module Module_25a =
+def
+ pub mode Union_a = union (int,real);
+ pub proc union_a_string = (Union_a x) string:
+ case x
+ in (int): "int",
+ (real): "real"
+ esac;
+ skip
+fed
diff --git a/gcc/testsuite/algol68/execute/modules/module25b.a68 b/gcc/testsuite/algol68/execute/modules/module25b.a68
new file mode 100644
index 00000000000..9a05b2ae0dc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/modules/module25b.a68
@@ -0,0 +1,10 @@
+module Module_25b =
+def
+ pub mode Union_b = union (real,int);
+ pub proc union_b_string = (Union_b x) string:
+ case x
+ in (int): "int",
+ (real): "real"
+ esac;
+ skip
+fed
diff --git a/gcc/testsuite/algol68/execute/modules/program-25.a68 b/gcc/testsuite/algol68/execute/modules/program-25.a68
new file mode 100644
index 00000000000..4a62a6fbcb1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/modules/program-25.a68
@@ -0,0 +1,9 @@
+{ dg-modules "module25a module25b" }
+access Module_25a,Module_25b begin
+ Union_a a = 1;
+ Union_b b = 1;
+ assert(union_a_string(a) = "int");
+ assert(union_a_string(b) = "int");
+ assert(union_b_string(a) = "int");
+ assert(union_b_string(b) = "int")
+end
--
2.52.0
More information about the Algol68
mailing list