From: James Bohl Date: Thu, 12 Feb 2026 03:42:20 +0000 (-0500) Subject: algol68: Fix assignment of union overhead values [PR algol68/124049] X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=3593e79a9fbe4266589cb5408cf47583a2cb1ca1;p=thirdparty%2Fgcc.git algol68: Fix assignment of union overhead values [PR algol68/124049] 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 gcc/algol68/ChangeLog PR algol68/124049 * Make-lang.in (ALGOL68_OBJS): Add algol68/a68-moids-sorting.o. * a68.h: Add prototype for a68_sort_union_packs. * a68-moids-sorting.cc: New file. * a68-parser-modes.cc (a68_make_moid_list): Call a68_sort_union_packs. * ga68-exports.pk (ga68_mode_64): Add comment on union mode ordering. 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. --- diff --git a/gcc/algol68/Make-lang.in b/gcc/algol68/Make-lang.in index 54b5381cb81..392818b6cb7 100644 --- a/gcc/algol68/Make-lang.in +++ b/gcc/algol68/Make-lang.in @@ -61,6 +61,7 @@ ALGOL68_OBJS = algol68/a68-lang.o \ algol68/a68-unistr.o \ algol68/a68-moids-diagnostics.o \ algol68/a68-moids-misc.o \ + algol68/a68-moids-sorting.o \ algol68/a68-moids-to-string.o \ algol68/a68-postulates.o \ algol68/a68-diagnostics.o \ diff --git a/gcc/algol68/a68-moids-sorting.cc b/gcc/algol68/a68-moids-sorting.cc new file mode 100644 index 00000000000..6579fbd2cc1 --- /dev/null +++ b/gcc/algol68/a68-moids-sorting.cc @@ -0,0 +1,187 @@ +/* MOID sorting routines. + Copyright (C) 2026 James Bohl. + + This file is part of GCC. + + 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 ordering modes. + */ + +/* Forward references. */ + +static int mode_ordering (MOID_T *a,MOID_T *b); +static PACK_T * sort_union_pack (PACK_T *u); + +/* 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)); + } +} diff --git a/gcc/algol68/a68-parser-modes.cc b/gcc/algol68/a68-parser-modes.cc index 5842d1325f0..ed010ded774 100644 --- a/gcc/algol68/a68-parser-modes.cc +++ b/gcc/algol68/a68-parser-modes.cc @@ -1349,4 +1349,5 @@ a68_make_moid_list (MODULE_T *mod) compute_derived_modes (mod); a68_init_postulates (); + a68_sort_union_packs(TOP_MOID (mod)); } diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h index 2492aea6e2a..17c419a6881 100644 --- a/gcc/algol68/a68.h +++ b/gcc/algol68/a68.h @@ -483,6 +483,10 @@ bool a68_is_c_mode (MOID_T *m, int level = 0); #define A68_IF_MODE_IS_WELL(n) (! ((n) == M_ERROR || (n) == M_UNDEFINED)) +/* a68-moids-sorting.cc */ + +void a68_sort_union_packs (MOID_T* m); + /* a68-parser-scope.cc */ void a68_scope_checker (NODE_T *p); diff --git a/gcc/algol68/ga68-exports.pk b/gcc/algol68/ga68-exports.pk index 233c6987def..aeb527326d8 100644 --- a/gcc/algol68/ga68-exports.pk +++ b/gcc/algol68/ga68-exports.pk @@ -175,6 +175,83 @@ type ga68_mode_64 = field[nfields] fields; } sct : kind == GA68_MODE_STRUCT; + /* When assigning overhead values to union modes, the list of + united modes is ordered so that overhead values are assigned + consistently across compilation units. Overhead values are + assigned to the modes in the ordered list in ascending order + starting from zero. + + Modes are ordered in the following order: + + UNION + STRUCT + STANDARD + ROWS + REF + PROC + FLEX + + A STANDARD mode is one of the following: (VOID, STRING, REAL, + INT, COMPL, CHAR, BYTES, BOOL, BITS) + + When two modes occupy the same row in the list above, the + ordering is determined as follows: + + UNION: + + The union with greater number of united modes is ordered + first. Unions having an equal number of united modes are + ordered based on the ordering of their first non-equivalent + mode. + + STRUCT: + + The struct with the largest number of fields is ordered first. + Structs having an equal number of fields are ordered based + on the first field that has non-equivalent modes or + non-matching field selectors. If the modes are not equivalent, + the structs are ordered in the ordering of those modes. + Otherwise, the struct are ordered in the lexicographical + order of the field selectors. + + STANDARD: + + The mode with the greatest size of longsety and smaller size + of shortsety is ordered first. If the size of shortsety and + longsety are equal, the modes are ordered as follows: + + VOID + STRING + REAL + INT + COMPL + CHAR + BYTES + BOOL + BITS + + ROWS: + + The mode with greater number of dimensions is ordered first. + Otherwise, the ordering of the modes of the elements is used. + + REF: + + The ordering is the ordering of the referred mode. + + PROC: + + The ordering is the ordering of the mode of the value yielded + by the procedure. If the procedure yields values of the the + same mode, the procedure with greater number of arguments is + ordered first. If the number of arguments is equal, the + ordering is the ordering of the modes of the first arguments + having non-equivalent modes. + + FLEX: + + The ordering is the ordering of the referred mode. */ + struct { uint<8> nmodes; 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