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 <[email protected]> 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
