[COMMITTED] algol68: implement united specs in conformity clauses
Jose E. Marchesi
jemarch@gnu.org
Sun May 11 15:18:01 GMT 2025
---
gcc/algol68/a68-lang.cc | 2 +-
gcc/algol68/a68-low-clauses.cc | 75 +++++++++++++++----
gcc/algol68/a68-low-unions.cc | 64 +++++++++++++++-
gcc/algol68/a68.h | 2 +
.../algol68/execute/conformity-clause-9.a68 | 10 +++
gcc/testsuite/algol68/execute/mcts/clau02.a68 | 35 +++++----
6 files changed, 154 insertions(+), 34 deletions(-)
create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-9.a68
diff --git a/gcc/algol68/a68-lang.cc b/gcc/algol68/a68-lang.cc
index 546e608d2ee..a307f0ee77c 100644
--- a/gcc/algol68/a68-lang.cc
+++ b/gcc/algol68/a68-lang.cc
@@ -681,7 +681,7 @@ a68_types_compatible_p (tree x, tree y)
MOID_T *mode_y = a68_type_moid (y);
if (mode_x != NO_MOID && mode_y != NO_MOID)
- return a68_is_equal_modes (mode_x, mode_y, true);
+ return a68_is_equal_modes (mode_x, mode_y, SAFE_DEFLEXING);
return false;
}
diff --git a/gcc/algol68/a68-low-clauses.cc b/gcc/algol68/a68-low-clauses.cc
index d59158dce4f..76366e0021c 100644
--- a/gcc/algol68/a68-low-clauses.cc
+++ b/gcc/algol68/a68-low-clauses.cc
@@ -520,17 +520,66 @@ lower_unite_case_unit (NODE_T *p,
if (IS (spec_identifier, IDENTIFIER))
specifier_identifier_name = NSYMBOL (spec_identifier);
- // XXX we should handle cases with IS_UNION (spec_moid) and
- // is_unitable (enquiry_mode, spec_mode). In that case the
- // identifier is a stack allocated union which is a subset of the
- // union enquiry_mode and we cannot use a68_united_mode_index. But
- // the cunion type of the newly allocated union shall be the same
- // than enquiry mode! (what about the ordering???)
+ tree overhead = a68_union_overhead (enquiry);
+ tree spec_value = NULL_TREE;
+ tree entry_selected = NULL_TREE;
if (IS_UNION (spec_moid))
- gcc_unreachable ();
+ {
+ /* The spec_moid is an united mode, which must be unitable to the
+ enquiry_mode. */
+ gcc_assert (a68_is_unitable (spec_moid, enquiry_mode,
+ SAFE_DEFLEXING));
- tree overhead = a68_union_overhead (enquiry);
- int index = a68_united_mode_index (enquiry_mode, spec_moid);
+ /* Build the entry_selected expression.
+
+ For each mode in spec_moid, determine the corresponding index
+ in enquiry_mode and add a check for it to the expression. */
+ for (PACK_T *pack = PACK (spec_moid); pack != NO_PACK; FORWARD (pack))
+ {
+ int index = a68_united_mode_index (enquiry_mode, MOID (pack));
+ tree expr = fold_build2 (EQ_EXPR,
+ boolean_type_node,
+ overhead,
+ build_int_cst (TREE_TYPE (overhead), index));
+ if (entry_selected == NULL_TREE)
+ entry_selected = expr;
+ else
+ entry_selected = fold_build2 (TRUTH_OR_EXPR,
+ boolean_type_node,
+ entry_selected,
+ expr);
+ }
+
+ /* The spec_value is an union of mode spec_moid, with the
+ overhead translated from enquiry_mode. */
+ tree spec_overhead
+ = a68_union_translate_overhead (enquiry_mode, overhead, spec_moid);
+ a68_push_range (spec_moid);
+ spec_value = a68_lower_tmpvar ("spec_value%",
+ CTYPE (spec_moid),
+ a68_get_skip_tree (spec_moid));
+ a68_add_stmt (a68_union_set_overhead (spec_value, spec_overhead));
+ tree from_cunion = a68_union_cunion (enquiry);
+ tree to_cunion = a68_union_cunion (spec_value);
+ a68_add_stmt (a68_lower_memcpy (fold_build1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (to_cunion)),
+ to_cunion),
+ fold_build1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (from_cunion)),
+ from_cunion),
+ size_in_bytes (TREE_TYPE (to_cunion))));
+ a68_add_stmt (spec_value);
+ spec_value = a68_pop_range ();
+ }
+ else
+ {
+ int index = a68_united_mode_index (enquiry_mode, spec_moid);
+ spec_value = a68_union_alternative (enquiry, index);
+ entry_selected = fold_build2 (EQ_EXPR,
+ TREE_TYPE (overhead),
+ overhead,
+ build_int_cst (TREE_TYPE (overhead), index));
+ }
a68_push_range (M_VOID);
{
@@ -540,8 +589,7 @@ lower_unite_case_unit (NODE_T *p,
if (specifier_identifier_name)
{
tree united_value = a68_lower_tmpvar (specifier_identifier_name,
- CTYPE (spec_moid),
- a68_union_alternative (enquiry, index));
+ CTYPE (spec_moid), spec_value);
TAX_TREE_DECL (TAX (spec_identifier)) = united_value;
}
@@ -559,10 +607,7 @@ lower_unite_case_unit (NODE_T *p,
/* IF index = overhead THEN process entry FI */
a68_add_stmt (fold_build3 (COND_EXPR,
a68_void_type,
- fold_build2 (EQ_EXPR,
- TREE_TYPE (overhead),
- overhead,
- build_int_cst (TREE_TYPE (overhead), index)),
+ entry_selected,
process_entry,
a68_get_skip_tree (M_VOID)));
diff --git a/gcc/algol68/a68-low-unions.cc b/gcc/algol68/a68-low-unions.cc
index e80b774abec..f775877f327 100644
--- a/gcc/algol68/a68-low-unions.cc
+++ b/gcc/algol68/a68-low-unions.cc
@@ -56,6 +56,27 @@
values are built from either SKIP (for uninitialized UNION values) or as the
result of an uniting coercion. */
+/* Given an union mode P and a mode Q, return whether Q is a mode in P. */
+
+bool
+a68_union_contains_mode (MOID_T *p, MOID_T *q)
+{
+ while (EQUIVALENT (p) != NO_MOID)
+ p = EQUIVALENT (p);
+
+ for (PACK_T *pack = PACK (p); pack != NO_PACK; FORWARD (pack))
+ {
+ MOID_T *m = MOID (pack);
+
+ if (a68_is_equal_modes (q, m, SAFE_DEFLEXING)
+ || (m == M_STRING && IS_ROW (q) && SUB (q) == M_CHAR)
+ || (q == M_STRING && IS_ROW (m) && SUB (m) == M_CHAR))
+ return true;
+ }
+
+ return false;
+}
+
/* Given an union mode P and a mode Q, return an integer with the index of the
occurrence of Q in P. */
@@ -67,9 +88,11 @@ a68_united_mode_index (MOID_T *p, MOID_T *q)
p = EQUIVALENT (p);
for (PACK_T *pack = PACK (p); pack != NO_PACK; FORWARD (pack))
{
- if (a68_is_equal_modes (q, MOID (pack), true /* deflex */)
- || (MOID (pack) == M_STRING
- && IS_ROW (q) && SUB (q) == M_CHAR))
+ MOID_T *m = MOID (pack);
+
+ if (a68_is_equal_modes (q, m, SAFE_DEFLEXING)
+ || (m == M_STRING && IS_ROW (q) && SUB (q) == M_CHAR)
+ || (q == M_STRING && IS_ROW (m) && SUB (m) == M_CHAR))
return ret;
ret += 1;
}
@@ -79,6 +102,41 @@ a68_united_mode_index (MOID_T *p, MOID_T *q)
return 0;
}
+/* Given two united modes FROM and TO, and an overhead FROM_OVERHEAD in mode
+ FROM, return the corresponding overhead in mode TO.
+
+ This function assumes that the mode with FROM_OVERHEAD in mode FROM exists
+ in TO. */
+
+tree
+a68_union_translate_overhead (MOID_T *from, tree from_overhead,
+ MOID_T *to)
+{
+ /* Note that the initialization value for to_overhead should never be used.
+ XXX perhaps translate it to a run-time call to abort/compiler-error. */
+ tree to_overhead = size_int (0);
+
+ from_overhead = save_expr (from_overhead);
+
+ int i = 0;
+ for (PACK_T *pack = PACK (from); pack != NO_PACK; FORWARD (pack), ++i)
+ {
+ MOID_T *mode = MOID (pack);
+
+ if (a68_union_contains_mode (to, mode))
+ {
+ to_overhead = fold_build3 (COND_EXPR, sizetype,
+ fold_build2 (EQ_EXPR, boolean_type_node,
+ from_overhead,
+ size_int (i)),
+ size_int (a68_united_mode_index (to, mode)),
+ to_overhead);
+ }
+ }
+
+ return to_overhead;
+}
+
/* Get the overhead of a given united value EXP. */
tree
diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h
index 522498e1f78..1199cf25546 100644
--- a/gcc/algol68/a68.h
+++ b/gcc/algol68/a68.h
@@ -788,6 +788,8 @@ tree a68_union_set_overhead (tree exp, tree overhead);
tree a68_union_cunion (tree exp);
tree a68_union_alternative (tree exp, int index);
tree a68_union_value (MOID_T *mode, tree exp, MOID_T *exp_mode);
+tree a68_union_translate_overhead (MOID_T *from, tree from_overhead, MOID_T *to);
+bool a68_union_contains_mode (MOID_T *p, MOID_T *q);
/* a68-low-units.cc */
diff --git a/gcc/testsuite/algol68/execute/conformity-clause-9.a68 b/gcc/testsuite/algol68/execute/conformity-clause-9.a68
new file mode 100644
index 00000000000..55f1fc3eb88
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/conformity-clause-9.a68
@@ -0,0 +1,10 @@
+begin union (int, bool, string) foo = 666;
+ case foo
+ in (union(int,string) bar):
+ case bar
+ in (int i): assert (i = 666),
+ (string s): assert (false)
+ esac,
+ (bool baz): assert (false)
+ esac
+end
diff --git a/gcc/testsuite/algol68/execute/mcts/clau02.a68 b/gcc/testsuite/algol68/execute/mcts/clau02.a68
index d1478d4d6b2..185a36c1ba2 100644
--- a/gcc/testsuite/algol68/execute/mcts/clau02.a68
+++ b/gcc/testsuite/algol68/execute/mcts/clau02.a68
@@ -1,18 +1,23 @@
-# { dg-options "-fstropping=upper" } #
# Case conformity. #
-BEGIN MODE M = UNION ([]INT, BOOL, STRING);
- PROC prpm = REF PROC M: HEAP PROC M := M: "aap ";
+begin mode M = union ([]int, bool, string);
+ proc prpm = ref proc M: heap proc M := M: "aap ";
- FOR n TO 4
- DO CASE CASE n
- IN TRUE,
- IF FALSE THEN "aa" ELSE "b " FI,
+ int control := 0;
+ for n to 4
+ do case case n
+ in true,
+ if false then "aa" else "b " fi,
prpm
- OUT LOC[1:1]INT := 1
- ESAC
- IN (UNION(STRING, BOOL) sb): (sb | (BOOL b): ASSERT (b)),
- (REF[]INT i): ASSERT (i[1] = 1)
- OUT puts ("void")
- ESAC
- OD
-END
+ out loc[1:1]int := 1
+ esac
+ in (union(string, bool) sb):
+ (control +:= 1;
+ (sb | (bool b): assert (b), (string s): assert (s = "b "))),
+ (ref[]int i):
+ (control +:= 1;
+ assert (i[1] = 1))
+ out assert (false)
+ esac
+ od;
+ assert (control = 4)
+end
--
2.30.2
More information about the Algol68
mailing list