Signed-off-by: Jose E. Marchesi <[email protected]>
gcc/ChangeLog
* algol68/a68-low-multiples.cc: New file.
* algol68/a68-low-structs.cc: Likewise.
* algol68/a68-low-unions.cc: Likewise.
---
gcc/algol68/a68-low-multiples.cc | 1097 ++++++++++++++++++++++++++++++
gcc/algol68/a68-low-structs.cc | 63 ++
gcc/algol68/a68-low-unions.cc | 279 ++++++++
3 files changed, 1439 insertions(+)
create mode 100644 gcc/algol68/a68-low-multiples.cc
create mode 100644 gcc/algol68/a68-low-structs.cc
create mode 100644 gcc/algol68/a68-low-unions.cc
diff --git a/gcc/algol68/a68-low-multiples.cc b/gcc/algol68/a68-low-multiples.cc
new file mode 100644
index 00000000000..ce5996c9249
--- /dev/null
+++ b/gcc/algol68/a68-low-multiples.cc
@@ -0,0 +1,1097 @@
+/* Lowering routines for all things related to multiples.
+ Copyright (C) 2025 Jose E. Marchesi.
+
+ Written 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
+ <http://www.gnu.org/licenses/>. */
+
+#define INCLUDE_MEMORY
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "tree.h"
+#include "fold-const.h"
+#include "diagnostic.h"
+#include "langhooks.h"
+#include "tm.h"
+#include "function.h"
+#include "cgraph.h"
+#include "toplev.h"
+#include "varasm.h"
+#include "predict.h"
+#include "stor-layout.h"
+#include "tree-iterator.h"
+#include "stringpool.h"
+#include "print-tree.h"
+#include "gimplify.h"
+#include "dumpfile.h"
+#include "convert.h"
+
+#include "a68.h"
+
+/* Algol 68 multiples are multi-dimensional and dynamically sized. They have a
+ static part and a dynamic part. The static part is conformed by a
+ "descriptor", which contains information about each of the dimensions, and a
+ pointer to the actual elements stored in the multiple. The dynamic part are
+ the elements, which are stored in column order. Both the descriptor and the
+ elements may reside on the stack, data section, or the heap. The mode of a
+ multiple is a "row".
+
+ Schematically, the descriptor contains:
+
+ triplets%
+ lb% ub% stride%
+ ...
+ elements%
+ elements_size%
+
+ Where elements_size% is the size of the buffer pointed by elements%, in
+ bytes.
+
+ There is a triplet per dimension in the multiple. The number of dimensions
+ in a row mode is static and is determined at compile-time.
+
+ The infomation stored for each triplet is:
+
+ lb% is the lower bound of the dimension.
+ ub% is the upper bound of the dimension.
+ stride% is the stride of the dimension.
+
+ The stride of each dimension is the number of bytes to skip in order to
+ access the next element in that dimension. They express the layout of the
+ multiple in memory.
+
+ Algol 68 multi-dimensional multiples are stored in row-major (generalized,
+ lexicographical) order:
+
+ [1:3,1:2]AMODE = ((e1, e2, e3),
+ (e4, e5, e6))
+
+ is stored as:
+
+ 1 2 3
+ 1 e1 e2 e3 | stride 2S -> stride 1S
+ 2 e4 e5 e6 v
+
+ Where S is the size in bytes of a single element. That means that for two
+ dimensional multiples, the column stride is always 1S and the row stride is
+ the column size.
+
+ In general, given a mode with number of elements N1, N2, N3, ...:
+
+ [N1,N2,N3...,Nn]AMODE
+
+ the strides of the dimensions are:
+
+ S1 = N2 * S2
+ S2 = N3 * S3
+ S3 = N4 * S4
+ ...
+ Si = N1 * N2 * ... * Ni-1
+
+ Indexing is then performed by a dot-product of an element coordinate and the
+ strides:
+
+ (i1,i2,i3) . (S1,S2,S3) = offset + i1*S1 + i2*S2 + i3*S3 = index in
elements array.
+
+ Note that the number of elements in each dimension can be easily derived
+ from the bounds and there is no need to store them explicitly, save for
+ performance reasons. Descriptors are bulky enough and often they they are
+ stored on the stack, so we prefer to pay in performance and save in
+ storage. */
+
+/* Return a tree with the yielding of SKIP for the given row mode, a
+ multiple. */
+
+tree
+a68_get_multiple_skip_tree (MOID_T *m)
+{
+ tree res = NULL_TREE;
+ int dim = DIM (m);
+ tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+ tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+ tree ssize_one_node = fold_convert (ssizetype, size_one_node);
+ tree ssize_zero_node = fold_convert (ssizetype, size_zero_node);
+ for (int i = 0; i < dim; ++i)
+ {
+ lower_bounds[i] = ssize_one_node;
+ upper_bounds[i] = ssize_zero_node;
+ }
+ res = a68_row_value (CTYPE (m), dim,
+ build_int_cst (build_pointer_type (void_type_node), 0),
+ size_zero_node, /* elements_size */
+ lower_bounds, upper_bounds);
+ free (lower_bounds);
+ free (upper_bounds);
+ return res;
+}
+
+/* Return the number of dimensions of the multiple EXP as an integer
+ constant. */
+
+tree
+a68_multiple_dimensions (tree exp)
+{
+ gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+ /* triplets% is the first field in the descriptor. */
+ tree triplets_field = TYPE_FIELDS (TREE_TYPE (exp));
+ return array_type_nelts_top (TREE_TYPE (triplets_field));
+}
+
+/* Return an expression that evaluates to the total number of elements stored
+ in a multiple as a sizetype. */
+
+tree
+a68_multiple_num_elems (tree exp)
+{
+ /* We have to calculate the number of elements based on the dimension
+ triplets in the array type. The number of dimensions is known at compile
+ time, so we don't really need a loop. */
+
+ tree num_dimensions_tree = a68_multiple_dimensions (exp);
+ gcc_assert (TREE_CODE (num_dimensions_tree) == INTEGER_CST);
+ int num_dimensions = tree_to_shwi (num_dimensions_tree);
+
+ tree size = NULL_TREE;
+ for (int dim = 0; dim < num_dimensions; ++dim)
+ {
+ tree size_dim = size_int (dim);
+ tree lower_bound = a68_multiple_lower_bound (exp, size_dim);
+ tree upper_bound = a68_multiple_upper_bound (exp, size_dim);
+ tree dim_size = fold_build2 (PLUS_EXPR, sizetype,
+ fold_convert (sizetype, fold_build2
(MINUS_EXPR,
+
ssizetype,
+
upper_bound,
+
lower_bound)),
+ size_one_node);
+
+ if (size == NULL_TREE)
+ size = dim_size;
+ else
+ size = fold_build2 (MULT_EXPR, sizetype, size, dim_size);
+ }
+
+ return size;
+}
+
+/* Return a size expression that evaluates to the total size, in bytes, of the
+ elements stored in the multiple. */
+
+tree
+a68_multiple_elements_size (tree exp)
+{
+ tree type = TREE_TYPE (exp);
+ gcc_assert (A68_ROW_TYPE_P (type));
+
+ /* elements_size% is the third field in the descriptor. */
+ tree elements_size_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (type)));
+ return fold_build3 (COMPONENT_REF, TREE_TYPE (elements_size_field),
+ exp, elements_size_field, NULL_TREE);
+}
+
+/* Return the triplet for dimension DIM in the multiple EXP. */
+
+static tree
+multiple_triplet (tree exp, tree dim)
+{
+ gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+ /* triplets% is the first field in the descriptor. */
+ tree triplets_field = TYPE_FIELDS (TREE_TYPE (exp));
+ tree triplets = fold_build3 (COMPONENT_REF,
+ TREE_TYPE (triplets_field),
+ exp,
+ triplets_field,
+ NULL_TREE);
+
+ /* Get the triplet for the given dimension. */
+ return build4 (ARRAY_REF,
+ TREE_TYPE (TREE_TYPE (triplets)),
+ triplets,
+ dim,
+ NULL_TREE,
+ NULL_TREE);
+}
+
+/* Return the lower bound of dimension DIM of the multiple EXP. The returned
+ value is a ssizetype. */
+
+tree
+a68_multiple_lower_bound (tree exp, tree dim)
+{
+ gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+ /* lb% is the first field in the triplet. */
+ tree triplet = multiple_triplet (exp, dim);
+ tree lower_bound_field = TYPE_FIELDS (TREE_TYPE (triplet));
+ return fold_build3 (COMPONENT_REF,
+ TREE_TYPE (lower_bound_field),
+ triplet,
+ lower_bound_field,
+ NULL_TREE);
+}
+
+/* Return an expression that sets the lower bound of dimension DIM of the
+ multiple EXP to BOUND. */
+
+tree
+a68_multiple_set_lower_bound (tree exp, tree dim, tree bound)
+{
+ gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+ return fold_build2 (MODIFY_EXPR,
+ TREE_TYPE (bound),
+ a68_multiple_lower_bound (exp, dim),
+ bound);
+}
+
+/* Return the upper bound of dimension DIM of the multiple EXP. The returned
+ value is a ssizetype. */
+
+tree
+a68_multiple_upper_bound (tree exp, tree dim)
+{
+ gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+ /* ub% is the second field in the triplet. */
+ tree triplet = multiple_triplet (exp, dim);
+ tree upper_bound_field = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (triplet)));
+ return fold_build3 (COMPONENT_REF,
+ TREE_TYPE (upper_bound_field),
+ triplet,
+ upper_bound_field,
+ NULL_TREE);
+}
+
+/* Return an expression that sets the upper bound of dimension DIM of the
+ multiple EXP to BOUND. */
+
+tree
+a68_multiple_set_upper_bound (tree exp, tree dim, tree bound)
+{
+ gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+ return fold_build2 (MODIFY_EXPR,
+ TREE_TYPE (bound),
+ a68_multiple_upper_bound (exp, dim),
+ bound);
+}
+
+/* Return the stride of dimension DIM of the multiple EXP. */
+
+tree
+a68_multiple_stride (tree exp, tree dim)
+{
+ gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+ /* stride% is the third field in the triplet. */
+ tree triplet = multiple_triplet (exp, dim);
+ tree stride_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE
(triplet))));
+ return fold_build3 (COMPONENT_REF,
+ TREE_TYPE (stride_field),
+ triplet,
+ stride_field,
+ NULL_TREE);
+}
+
+/* Return an expression that sets the stride of dimension DIM of the multiple
+ EXP to STRIDE.
+
+ STRIDE must be a sizetype. */
+
+tree
+a68_multiple_set_stride (tree exp, tree dim, tree stride)
+{
+ gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+ return fold_build2 (MODIFY_EXPR,
+ TREE_TYPE (stride),
+ a68_multiple_stride (exp, dim),
+ stride);
+}
+
+/* Return the triplets of the multiple EXP. */
+
+tree
+a68_multiple_triplets (tree exp)
+{
+ gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+ /* triplets% is the first field in the descriptor. */
+ tree triplets_field = TYPE_FIELDS (TREE_TYPE (exp));
+ return fold_build3 (COMPONENT_REF,
+ TREE_TYPE (triplets_field),
+ exp,
+ triplets_field,
+ NULL_TREE);
+}
+
+/* Return the pointer to the elements of the multiple EXP. */
+
+tree
+a68_multiple_elements (tree exp)
+{
+ gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+ /* elements% is the second field in the descriptor. */
+ tree elements_field = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp)));
+ return fold_build3 (COMPONENT_REF,
+ TREE_TYPE (elements_field),
+ exp,
+ elements_field,
+ NULL_TREE);
+}
+
+/* Return an expression that sets the elements% field of EXP to ELEMENTS. */
+
+tree
+a68_multiple_set_elements (tree exp, tree elements)
+{
+ /* elements% is the second field in the descriptor. */
+ tree elements_field = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp)));
+ return fold_build2 (MODIFY_EXPR,
+ TREE_TYPE (elements_field),
+ fold_build3 (COMPONENT_REF,
+ TREE_TYPE (elements_field),
+ exp,
+ elements_field,
+ NULL_TREE),
+ elements);
+}
+
+/* Return an expression that sets the elements_size% field of EXP to
+ ELEMENTS_SIZE, which must be a sizetype. */
+
+tree
+a68_multiple_set_elements_size (tree exp, tree elements_size)
+{
+ /* elements_size% is the third field in the descriptor. */
+ tree elements_size_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE
(exp))));
+ return fold_build2 (MODIFY_EXPR,
+ TREE_TYPE (elements_size_field),
+ fold_build3 (COMPONENT_REF,
+ TREE_TYPE (elements_size_field),
+ exp,
+ elements_size_field,
+ NULL_TREE),
+ elements_size);
+}
+
+/* Given two arrays of LOWER_BOUNDs and UPPER_BOUNDs corresponding to DIM
+ dimensions of a multiple of type TYPE, fill in the strides in STRIDES, which
+ is assumed to be a buffer big enough to hold DIM tree nodes. The bounds
+ shall be of type ssizetype, and the calculated strides are of type sizetype,
+ i.e. unsigned. */
+
+void
+a68_multiple_compute_strides (tree type, size_t dim,
+ tree *lower_bounds, tree *upper_bounds,
+ tree *strides)
+{
+ tree stride = size_in_bytes (a68_row_elements_type (type));
+ for (ssize_t i = dim - 1; i >= 0; --i)
+ {
+ strides[i] = stride;
+
+ /* Calculate the stride for the previous dimension. */
+ tree dim_num_elems
+ = save_expr (fold_build2 (PLUS_EXPR,
+ sizetype,
+ fold_convert (sizetype,
+ fold_build2 (MINUS_EXPR,
ssizetype,
+ upper_bounds[i],
lower_bounds[i])),
+ size_one_node));
+ stride = fold_build2 (MULT_EXPR, sizetype, stride, dim_num_elems);
+ }
+}
+
+/* Return a constructor for a multiple of row type TYPE, using TRIPLETS and
+ ELEMENTS. ELEMENTS_SIZE is the size in bytes of the memory pointed by
+ ELEMENTS. */
+
+tree
+a68_row_value_raw (tree type, tree triplets,
+ tree elements, tree elements_size)
+{
+ tree triplets_field;
+ tree elements_field;
+ tree elements_size_field;
+ vec <constructor_elt, va_gc> *ce = NULL;
+
+ gcc_assert (A68_ROW_TYPE_P (type));
+ triplets_field = TYPE_FIELDS (type);
+ elements_field = TREE_CHAIN (triplets_field);
+ elements_size_field = TREE_CHAIN (elements_field);
+ CONSTRUCTOR_APPEND_ELT (ce, triplets_field, triplets);
+ CONSTRUCTOR_APPEND_ELT (ce, elements_field,
+ fold_build1 (CONVERT_EXPR ,TREE_TYPE
(elements_field), elements));
+ CONSTRUCTOR_APPEND_ELT (ce, elements_size_field, elements_size);
+ return build_constructor (type, ce);
+}
+
+/* Return a constructor for a multiple of row type TYPE, of DIM dimensions and
+ pointing to ELEMENTS.
+
+ ELEMENTS_SIZE contains the size in bytes of the memory pointed by ELEMENTS.
+
+ *LOWER_BOUND and *UPPER_BOUND are the bounds for the DIM dimensions.
+*/
+
+tree
+a68_row_value (tree type, size_t dim,
+ tree elements, tree elements_size,
+ tree *lower_bound, tree *upper_bound)
+{
+ tree triplets_field;
+ tree elements_field;
+ tree elements_size_field;
+ vec <constructor_elt, va_gc> *ce = NULL;
+
+ gcc_assert (A68_ROW_TYPE_P (type));
+ triplets_field = TYPE_FIELDS (type);
+ elements_field = TREE_CHAIN (triplets_field);
+ elements_size_field = TREE_CHAIN (elements_field);
+
+ tree triplet_type = TREE_TYPE (TREE_TYPE (triplets_field));
+ tree lower_bound_field = TYPE_FIELDS (triplet_type);
+ tree upper_bound_field = TREE_CHAIN (TYPE_FIELDS (triplet_type));
+ tree stride_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (triplet_type)));
+
+ /* Calculate strides. */
+ tree *strides = (tree *) xmalloc (sizeof (tree) * dim);
+ a68_multiple_compute_strides (type, dim, lower_bound, upper_bound, strides);
+
+ vec <constructor_elt, va_gc> *triplets_ce = NULL;
+ for (size_t i = 0; i < dim; ++i)
+ {
+ CONSTRUCTOR_APPEND_ELT (triplets_ce,
+ size_int (i),
+ build_constructor_va (triplet_type,
+ 3,
+ lower_bound_field,
lower_bound[i],
+ upper_bound_field,
upper_bound[i],
+ stride_field, strides[i]));
+ }
+ free (strides);
+ CONSTRUCTOR_APPEND_ELT (ce, triplets_field,
+ build_constructor (TREE_TYPE (triplets_field),
triplets_ce));
+ CONSTRUCTOR_APPEND_ELT (ce, elements_field,
+ fold_build1 (CONVERT_EXPR, TREE_TYPE
(elements_field), elements));
+ CONSTRUCTOR_APPEND_ELT (ce, elements_size_field,
+ elements_size ? elements_size : size_zero_node);
+ tree multiple = build_constructor (type, ce);
+ return multiple;
+}
+
+/* Build a tree to slice a multiple given a set of indexes.
+
+ P is the tree node corresponding to the slice. It is used as the source of
+ location information.
+
+ MULTIPLE is the multiple value being sliced. If SLICING_NAME is true, it
+ means the slicing operation is for a name and therefore it must yield a
+ name.
+
+ INDEXES is a list of NUM_INDEXES indexes, which are units.
+ NUM_INDEXES must match the dimension of the multiple. */
+
+tree
+a68_multiple_slice (NODE_T *p,
+ tree multiple, bool slicing_name,
+ int num_indexes, tree *indexes)
+{
+ tree slice = NULL_TREE;
+ tree bounds_check = NULL_TREE;
+
+ multiple = save_expr (multiple);
+ tree index = NULL_TREE;
+ for (int idx = 0; idx < num_indexes; ++idx)
+ {
+ tree lower_bound = a68_multiple_lower_bound (multiple, size_int (idx));
+ tree index_expr = save_expr (indexes[idx]);
+
+ /* Do run-time bound checking if requested. */
+ if (OPTION_BOUNDS_CHECKING (&A68_JOB))
+ {
+ tree upper_bound = a68_multiple_upper_bound (multiple, size_int
(idx));
+ unsigned int lineno = NUMBER (LINE (INFO (p)));
+ const char *filename_str = FILENAME (LINE (INFO (p)));
+ tree filename = build_string_literal (strlen (filename_str) + 1,
+ filename_str);
+ tree call = a68_build_libcall (A68_LIBCALL_ARRAYBOUNDS,
+ void_type_node, 5,
+ filename,
+ build_int_cst (unsigned_type_node,
lineno),
+ fold_convert (ssizetype, index_expr),
+ fold_convert (ssizetype, lower_bound),
+ fold_convert (ssizetype, upper_bound));
+ call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call,
boolean_false_node);
+
+ /* If LB > UB, the dimension contains no elements.
+ Otherwise, it must hold IDX >= LB && IDX <= UB */
+ tree dim_bounds_check = fold_build2 (TRUTH_AND_EXPR, sizetype,
+ fold_build2 (LE_EXPR, ssizetype,
+ lower_bound,
upper_bound),
+ fold_build2 (TRUTH_AND_EXPR,
+ boolean_type_node,
+ fold_build2
(GE_EXPR, ssizetype,
+
fold_convert (ssizetype,
+
index_expr),
+
lower_bound),
+ fold_build2
(LE_EXPR, ssizetype,
+
fold_convert (ssizetype,
+
index_expr),
+
upper_bound)));
+ dim_bounds_check = fold_build2_loc (a68_get_node_location (p),
+ TRUTH_ORIF_EXPR,
+ ssizetype,
+ dim_bounds_check, call);
+
+ /* bounds_check_ok || call_runtime_error */
+ if (bounds_check == NULL_TREE)
+ bounds_check = dim_bounds_check;
+ else
+ bounds_check = fold_build2 (TRUTH_ANDIF_EXPR,
+ ssizetype,
+ bounds_check,
+ dim_bounds_check);
+ }
+
+ /* Now add the effect of this dimension's subscript in the index. Note
+ that the stride is expressed in bytes. */
+ tree stride = a68_multiple_stride (multiple, size_int (idx));
+ tree adjusted_index
+ = fold_convert (sizetype, fold_build2 (MINUS_EXPR, ssizetype,
+ fold_convert (ssizetype,
index_expr),
+ lower_bound));
+ tree term = fold_build2 (MULT_EXPR, sizetype,
+ adjusted_index, stride);
+ if (index == NULL_TREE)
+ index = term;
+ else
+ index = fold_build2 (PLUS_EXPR, sizetype,
+ index, term);
+ }
+
+ tree elements = a68_multiple_elements (multiple);
+ tree element_pointer_type = TREE_TYPE (elements);
+ tree element_type = TREE_TYPE (element_pointer_type);
+
+ /* Now refer to the indexed element. In case we are slicing a ref to a
+ multiple, return the address of the element and not the element
+ itself. */
+ tree element_address = fold_build2 (POINTER_PLUS_EXPR,
+ element_pointer_type,
+ elements,
+ index);
+ if (slicing_name)
+ slice = element_address;
+ else
+ slice = fold_build2 (MEM_REF,
+ element_type,
+ fold_build2 (POINTER_PLUS_EXPR,
+ element_pointer_type,
+ elements,
+ index),
+ fold_convert (element_pointer_type,
+ integer_zero_node));
+
+ /* Prepend bounds checking code if necessary. */
+ if (bounds_check != NULL_TREE)
+ {
+ slice = fold_build2_loc (a68_get_node_location (p),
+ COMPOUND_EXPR,
+ TREE_TYPE (slice),
+ bounds_check,
+ slice);
+ }
+
+ return slice;
+}
+
+/* Auxiliary routine for a68_multiple_copy_elemens. */
+
+static tree
+copy_multiple_dimension_elems (size_t dim, size_t num_dimensions,
+ tree to, tree from,
+ tree to_elements, tree from_elements,
+ tree *to_offset, tree *from_offset,
+ tree *indexes)
+{
+ tree element_pointer_type = TREE_TYPE (from_elements);
+ tree element_type = TREE_TYPE (element_pointer_type);
+ tree upb = a68_multiple_upper_bound (from, size_int (dim));
+
+ char *name = xasprintf ("r%ld%%", dim);
+ indexes[dim] = a68_lower_tmpvar (name, ssizetype,
+ a68_multiple_lower_bound (from,
+ size_int (dim)));
+ free (name);
+
+ /* Loop body. */
+ a68_push_range (NULL);
+ {
+ /* if (indexes[dim] > upb) break; */
+ a68_add_stmt (fold_build1 (EXIT_EXPR, void_type_node,
+ fold_build2 (GT_EXPR, size_type_node,
+ indexes[dim], upb)));
+
+ /* Add this dimension's contribution to the offsets. */
+ tree index = fold_convert (sizetype,
+ fold_build2 (MINUS_EXPR, ssizetype,
+ upb, indexes[dim]));
+ *to_offset = fold_build2 (PLUS_EXPR, sizetype,
+ *to_offset,
+ fold_build2 (MULT_EXPR, sizetype,
+ index,
+ a68_multiple_stride (to, size_int
(dim))));
+ *from_offset = fold_build2 (PLUS_EXPR, sizetype,
+ *from_offset,
+ fold_build2 (MULT_EXPR, sizetype,
+ index,
+ a68_multiple_stride (from,
size_int (dim))));
+
+ if (dim == num_dimensions - 1)
+ {
+ /* Most inner loop, copy one element. */
+
+ tree to_off = a68_lower_tmpvar ("to_offset%", sizetype, *to_offset);
+ tree from_off = a68_lower_tmpvar ("from_offset%", sizetype,
*from_offset);
+
+ tree to_elem = fold_build2 (MEM_REF,
+ element_type,
+ fold_build2 (POINTER_PLUS_EXPR,
+ element_pointer_type,
+ to_elements,
+ to_off),
+ fold_convert (element_pointer_type,
+ integer_zero_node));
+ tree from_elem = fold_build2 (MEM_REF,
+ element_type,
+ fold_build2 (POINTER_PLUS_EXPR,
+ element_pointer_type,
+ from_elements,
+ from_off),
+ fold_convert (element_pointer_type,
+ integer_zero_node));
+
+ /* XXX
+ if may_overlap then modify only if dst_offset < src_offset */
+ a68_add_stmt (fold_build2 (MODIFY_EXPR, element_type,
+ to_elem, from_elem));
+ }
+ else
+ {
+ a68_add_stmt (copy_multiple_dimension_elems (dim + 1, num_dimensions,
+ to, from,
+ to_elements, from_elements,
+ to_offset, from_offset,
+ indexes));
+ }
+
+ /* indexes[dim]++ */
+ a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, ssizetype,
+ indexes[dim], ssize_int (1)));
+ }
+ tree loop_body = a68_pop_range ();
+
+ return fold_build1 (LOOP_EXPR, void_type_node, loop_body);
+}
+
+/* Copy the elements of a given multiple (string) FROM to the multiple (string)
+ TO.
+
+ The dimensions and bounds of both multiples are supposed to match, and they
+ are supposed to not be flat.
+
+ XXX simple cases with same strides may be done with a memcpy.
+ XXX compile this into a support routine to reduce code size. */
+
+tree
+a68_multiple_copy_elems (MOID_T *mode, tree to, tree from)
+{
+ gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (to))
+ && A68_ROW_TYPE_P (TREE_TYPE (from)));
+
+ /* Deflex modes as needed and determine dimension. */
+ if (IS_FLEX (mode))
+ mode = SUB (mode);
+ int num_dimensions = (mode == M_STRING ? 1 : DIM (mode));
+
+ a68_push_range (NULL);
+ to = a68_lower_tmpvar ("to%", TREE_TYPE (to), to);
+ from = a68_lower_tmpvar ("from%", TREE_TYPE (from), from);
+ tree from_elements = a68_multiple_elements (from);
+ tree element_pointer_type = TREE_TYPE (from_elements);
+ from_elements = a68_lower_tmpvar ("from_elements%", element_pointer_type,
+ from_elements);
+ tree to_elements = a68_lower_tmpvar ("to_elements%", element_pointer_type,
+ a68_multiple_elements (to));
+
+ tree *indexes = (tree *) xmalloc (num_dimensions * sizeof (tree));
+ tree to_offset = size_zero_node;
+ tree from_offset = size_zero_node;
+ a68_add_stmt (copy_multiple_dimension_elems (0 /* dim */, num_dimensions,
+ to, from,
+ to_elements, from_elements,
+ &to_offset, &from_offset,
+ indexes));
+ free (indexes);
+ return a68_pop_range ();
+}
+
+/* Given a rows type, return the number of dimensions. */
+
+tree
+a68_rows_dim (tree exp)
+{
+ gcc_assert (A68_ROWS_TYPE_P (TREE_TYPE (exp)));
+
+ /* dim% is the first field in the rows struct. */
+ tree dim_field = TYPE_FIELDS (TREE_TYPE (exp));
+ return fold_build3 (COMPONENT_REF,
+ TREE_TYPE (dim_field),
+ exp,
+ dim_field,
+ NULL_TREE);
+}
+
+/* Given a multiple value, create a rows value reflecting the multiple's
+ dimensions and triplets. */
+
+tree
+a68_rows_value (tree multiple)
+{
+ tree rows_type = CTYPE (M_ROWS);
+ tree dim_field = TYPE_FIELDS (rows_type);
+ tree triplets_field = TREE_CHAIN (dim_field);
+
+ tree dimensions = save_expr (a68_multiple_dimensions (multiple));
+ tree triplets = fold_build1 (ADDR_EXPR, TREE_TYPE (triplets_field),
+ a68_multiple_triplets (multiple));
+ return build_constructor_va (rows_type, 2,
+ dim_field, dimensions,
+ triplets_field, triplets);
+}
+
+/* Given a rows value and a dimension number, return the upper bound or the
+ lower of the given dimension. The returned bound is a ssizetype.
+
+ DIM must be a sizetype. */
+
+static tree
+rows_lower_or_upper_bound (tree rows, tree dim, bool upper)
+{
+ tree rows_type = TREE_TYPE (rows);
+ tree triplet_type = a68_triplet_type ();
+ tree triplet_pointer_type = build_pointer_type (triplet_type);
+ tree triplet_lb_field = TYPE_FIELDS (triplet_type);
+ tree triplet_ub_field = TREE_CHAIN (TYPE_FIELDS (triplet_type));
+ tree triplets_field = TREE_CHAIN (TYPE_FIELDS (rows_type));
+ tree triplets = fold_build3 (COMPONENT_REF, triplet_pointer_type,
+ rows, triplets_field, NULL_TREE);
+ tree triplet_offset = fold_build2 (MULT_EXPR, sizetype,
+ dim,
+ size_in_bytes (triplet_type));
+ tree bound = fold_build3 (COMPONENT_REF, ssizetype,
+ fold_build1 (INDIRECT_REF, triplet_type,
+ fold_build2 (POINTER_PLUS_EXPR,
+ triplet_pointer_type,
+ triplets,
+ triplet_offset)),
+ upper ? triplet_ub_field : triplet_lb_field,
+ NULL_TREE);
+
+ return bound;
+}
+
+/* Return the lower bound of dimension DIM of ROWS. */
+
+tree
+a68_rows_lower_bound (tree rows, tree dim)
+{
+ return rows_lower_or_upper_bound (rows, dim, false);
+}
+
+/* Return the upper bound of dimension DIM of ROWS. */
+
+tree
+a68_rows_upper_bound (tree rows, tree dim)
+{
+ return rows_lower_or_upper_bound (rows, dim, true);
+}
+
+/* Return a tree that checks that a given INDEX is correct given a multiple's
+ bounds in a given rank DIM.
+
+ If UPPER_BOUND is true then INDEX shall be less or equal than the multiple's
+ upper bound. Otherwise INDEX shall be bigger or equal than the multiple's
+ lower bound.
+
+ If the condition above doesn't hold then a call to a run-time function is
+ performed: if UPPER_BOUND is true then ARRAYUPPERBOUND is called. Otherwise
+ ARRAYLOWERBOUND is called. */
+
+tree
+a68_multiple_single_bound_check (NODE_T *p, tree dim,
+ tree multiple, tree index, bool upper_bound)
+{
+ index = save_expr (index);
+ multiple = save_expr (multiple);
+
+ tree bound = (upper_bound
+ ? a68_multiple_upper_bound (multiple, dim)
+ : a68_multiple_lower_bound (multiple, dim));
+ a68_libcall_fn libcall = (upper_bound
+ ? A68_LIBCALL_ARRAYUPPERBOUND
+ : A68_LIBCALL_ARRAYLOWERBOUND);
+
+ /* Build the call to ARRAY*BOUNDS. */
+ unsigned int lineno = NUMBER (LINE (INFO (p)));
+ const char *filename_str = FILENAME (LINE (INFO (p)));
+ tree filename = build_string_literal (strlen (filename_str) + 1,
+ filename_str);
+ tree call = a68_build_libcall (libcall,
+ void_type_node, 4,
+ filename,
+ build_int_cst (unsigned_type_node, lineno),
+ fold_convert (ssizetype, index),
+ fold_convert (ssizetype, bound));
+ call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node);
+
+ tree bounds_check = fold_build2 (upper_bound ? LE_EXPR : GE_EXPR,
+ ssizetype,
+ fold_convert (ssizetype, index),
+ bound);
+ return fold_build2_loc (a68_get_node_location (p),
+ TRUTH_ORIF_EXPR,
+ ssizetype,
+ bounds_check, call);
+}
+
+/* Return a tree that checks whether the given DIM is a valid dimension/rank of
+ a boundable object with dimension BOUNDABLE_DIM. If the provided DIM is not
+ a valid dimention then a call to the run-time function ARRAYDIM is
+ performed.
+
+ BOUNDABLE_DIM and DIM must be of type sizetype. They are both one-based.
+
+ The parse tree node P is used as the source for the filename and line number
+ passed to the run-time function. */
+
+static tree
+a68_boundable_dim_check (NODE_T *p, tree boundable_dim, tree dim)
+{
+ boundable_dim = save_expr (boundable_dim);
+ dim = save_expr (dim);
+
+ /* Build the call to ARRAYDIM. */
+ unsigned int lineno = NUMBER (LINE (INFO (p)));
+ const char *filename_str = FILENAME (LINE (INFO (p)));
+ tree filename = build_string_literal (strlen (filename_str) + 1,
+ filename_str);
+ tree call = a68_build_libcall (A68_LIBCALL_ARRAYDIM,
+ void_type_node, 4,
+ filename,
+ build_int_cst (unsigned_type_node, lineno),
+ boundable_dim, dim);
+ call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node);
+
+ tree dim_check = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ fold_build2 (GT_EXPR, boolean_type_node, dim,
size_zero_node),
+ fold_build2 (LE_EXPR, boolean_type_node, dim,
boundable_dim));
+ return fold_build2_loc (a68_get_node_location (p),
+ TRUTH_ORIF_EXPR,
+ ssizetype,
+ dim_check, call);
+}
+
+/* Return a tree that checks whether the given DIM is a valid dimension/rank of
+ the given rows value ROWS.
+
+ DIM is a sizetype.
+ The parse tree node P is used as the source for the filename and line
+ number. */
+
+tree
+a68_rows_dim_check (NODE_T *p, tree rows, tree dim)
+{
+ return a68_boundable_dim_check (p, a68_rows_dim (rows), dim);
+}
+
+/* Return a tree that checks whether the given DIM is a valid dimension/rank of
+ the given multiple value MULTIPLE.
+
+ DIM is a sizetype.
+ The parse tree node P is used as the source for the filename and line
+ number. */
+
+tree
+a68_multiple_dim_check (NODE_T *p, tree multiple, tree dim)
+{
+ return a68_boundable_dim_check (p, a68_multiple_dimensions (multiple), dim);
+}
+
+/* Return a tree that checks whether the given INDEX falls within the bounds of
+ MULTIPLE in the rank DIM. If the provided index is out of bounds then a
+ call to the run-time function ARRAYBOUNDS is performed.
+
+ DIM must be a sizetype.
+ MULTIPLE must be a multiple value.
+ INDEX must be a ssizetype.
+
+ The parse tree node P is used as the source for the filename and line number
+ passed to the run-time function. */
+
+tree
+a68_multiple_bounds_check (NODE_T *p, tree dim,
+ tree multiple, tree index)
+{
+ index = save_expr (index);
+ multiple = save_expr (multiple);
+
+ tree upper_bound = a68_multiple_upper_bound (multiple, dim);
+ tree lower_bound = a68_multiple_lower_bound (multiple, dim);
+
+ /* Build the call to ARRAYBOUNDS. */
+ unsigned int lineno = NUMBER (LINE (INFO (p)));
+ const char *filename_str = FILENAME (LINE (INFO (p)));
+ tree filename = build_string_literal (strlen (filename_str) + 1,
+ filename_str);
+ tree call = a68_build_libcall (A68_LIBCALL_ARRAYBOUNDS,
+ void_type_node, 5,
+ filename,
+ build_int_cst (unsigned_type_node, lineno),
+ fold_convert (ssizetype, index),
+ fold_convert (ssizetype, lower_bound),
+ fold_convert (ssizetype, upper_bound));
+ call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node);
+
+ /* If LB > UB, the dimension contains no elements.
+ Otherwise, it must hold IDX >= LB && IDX <= UB */
+ tree bounds_check = fold_build2 (TRUTH_AND_EXPR, sizetype,
+ fold_build2 (LE_EXPR, ssizetype,
+ lower_bound, upper_bound),
+ fold_build2 (TRUTH_AND_EXPR,
+ boolean_type_node,
+ fold_build2 (GE_EXPR, ssizetype,
+ fold_convert
(ssizetype,
+
index),
+ lower_bound),
+ fold_build2 (LE_EXPR, ssizetype,
+ fold_convert
(ssizetype,
+
index),
+ upper_bound)));
+ return fold_build2_loc (a68_get_node_location (p),
+ TRUTH_ORIF_EXPR,
+ ssizetype,
+ bounds_check, call);
+}
+
+/* Emit a run-time error if the bounds of M1 and M2 are not the same. Both
+ multiples are assumed to have the same type and therefore feature the same
+ number of dimensions. */
+
+tree
+a68_multiple_bounds_check_equal (NODE_T *p, tree m1, tree m2)
+{
+ m1 = save_expr (m1);
+ m2 = save_expr (m2);
+
+ /* First determine the rank of the multiples and check they match. */
+ tree m1_dimensions = a68_multiple_dimensions (m1);
+ tree m2_dimensions = a68_multiple_dimensions (m2);
+ gcc_assert (TREE_CODE (m1_dimensions) == INTEGER_CST
+ && TREE_CODE (m2_dimensions) == INTEGER_CST);
+
+ int dim1 = tree_to_shwi (m1_dimensions);
+ int dim2 = tree_to_shwi (m2_dimensions);
+ gcc_assert (dim1 == dim2);
+
+ a68_push_range (NULL /* VOID */);
+
+ /* For each dimension, check that bounds are the same in both multiples. */
+ int i;
+ for (i = 0; i < dim1; ++i)
+ {
+ tree dim_tree = build_int_cst (ssizetype, i);
+ tree dim_plus_one = fold_build2 (PLUS_EXPR, ssizetype,
+ dim_tree,
+ fold_convert (ssizetype, size_one_node));
+
+ tree lb1 = save_expr (a68_multiple_lower_bound (m1, dim_tree));
+ tree lb2 = save_expr (a68_multiple_lower_bound (m2, dim_tree));
+
+ tree ub1 = save_expr (a68_multiple_upper_bound (m1, dim_tree));
+ tree ub2 = save_expr (a68_multiple_upper_bound (m2, dim_tree));
+
+ tree bounds_equal = fold_build2 (TRUTH_AND_EXPR,
+ boolean_type_node,
+ fold_build2 (EQ_EXPR, boolean_type_node,
+ lb1, lb2),
+ fold_build2 (EQ_EXPR, boolean_type_node,
+ ub1, ub2));
+
+ unsigned int lineno = NUMBER (LINE (INFO (p)));
+ const char *filename_str = FILENAME (LINE (INFO (p)));
+ tree filename = build_string_literal (strlen (filename_str) + 1,
+ filename_str);
+ tree call = a68_build_libcall (A68_LIBCALL_ARRAYBOUNDSMISMATCH,
+ void_type_node, 7,
+ filename,
+ build_int_cst (unsigned_type_node, lineno),
+ dim_plus_one,
+ lb1, ub1, lb2, ub2);
+ call = fold_build2 (COMPOUND_EXPR, boolean_type_node, call,
boolean_false_node);
+
+ tree check = fold_build2_loc (a68_get_node_location (p),
+ TRUTH_ORIF_EXPR, boolean_type_node,
+ bounds_equal,
+ call);
+ a68_add_stmt (check);
+ }
+
+ return a68_pop_range ();
+}
+
+/* Allocate a multiple on the heap.
+
+ M is the mode the multiple to allocate.
+ DIM is the number of dimensions of the multiple.
+ ELEMS is a pointer to the elements of the multiple.
+ ELEMS_SIZE is the size in bytes of ELEMS.
+ *LOWER_BOUND and *UPPER_BOUND are the bounds for the DIM dimensions. */
+
+tree
+a68_row_malloc (tree type, int dim, tree elems, tree elems_size,
+ tree *lower_bound, tree *upper_bound)
+{
+ tree ptr_to_type = build_pointer_type (type);
+
+ a68_push_range (NULL);
+
+ /* Allocate space for the descriptor. */
+ tree ptr_to_multiple = a68_lower_tmpvar ("ptr_to_multiple%", ptr_to_type,
+ a68_lower_malloc (type,
size_in_bytes (type)));
+ tree multiple = a68_row_value (type, dim,
+ elems, elems_size,
+ lower_bound, upper_bound);
+ a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node,
+ fold_build1 (INDIRECT_REF, type, ptr_to_multiple),
+ multiple));
+ a68_add_stmt (ptr_to_multiple);
+ tree res = a68_pop_range ();
+ TREE_TYPE (res) = ptr_to_type;
+ return res;
+}
diff --git a/gcc/algol68/a68-low-structs.cc b/gcc/algol68/a68-low-structs.cc
new file mode 100644
index 00000000000..12bb6192fb4
--- /dev/null
+++ b/gcc/algol68/a68-low-structs.cc
@@ -0,0 +1,63 @@
+/* Lowering routines for all things related to structs.
+ Copyright (C) 2025 Jose E. Marchesi.
+
+ Written 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
+ <http://www.gnu.org/licenses/>. */
+
+#define INCLUDE_MEMORY
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "tree.h"
+#include "fold-const.h"
+#include "diagnostic.h"
+#include "langhooks.h"
+#include "tm.h"
+#include "function.h"
+#include "cgraph.h"
+#include "toplev.h"
+#include "varasm.h"
+#include "predict.h"
+#include "stor-layout.h"
+#include "tree-iterator.h"
+#include "stringpool.h"
+#include "print-tree.h"
+#include "gimplify.h"
+#include "dumpfile.h"
+#include "convert.h"
+
+#include "a68.h"
+
+/* Return a tree with the yielding of SKIP for the given structured mode. */
+
+tree
+a68_get_struct_skip_tree (MOID_T *m)
+{
+ /* Build a constructor that assigns SKIPs to each field in the struct
+ type. */
+
+ vec <constructor_elt, va_gc> *ve = NULL;
+ tree field = TYPE_FIELDS (CTYPE (m));
+ for (PACK_T *elem = PACK (m); elem; FORWARD (elem))
+ {
+ gcc_assert (field != NULL_TREE);
+ CONSTRUCTOR_APPEND_ELT (ve, field, a68_get_skip_tree (MOID (elem)));
+ field = DECL_CHAIN (field);
+ }
+
+ return build_constructor (CTYPE (m), ve);
+}
diff --git a/gcc/algol68/a68-low-unions.cc b/gcc/algol68/a68-low-unions.cc
new file mode 100644
index 00000000000..f775877f327
--- /dev/null
+++ b/gcc/algol68/a68-low-unions.cc
@@ -0,0 +1,279 @@
+/* Lowering routines for all things related to unions.
+ Copyright (C) 2025 Jose E. Marchesi.
+
+ Written 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
+ <http://www.gnu.org/licenses/>. */
+
+#define INCLUDE_MEMORY
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "tree.h"
+#include "fold-const.h"
+#include "diagnostic.h"
+#include "langhooks.h"
+#include "tm.h"
+#include "function.h"
+#include "cgraph.h"
+#include "toplev.h"
+#include "varasm.h"
+#include "predict.h"
+#include "stor-layout.h"
+#include "tree-iterator.h"
+#include "stringpool.h"
+#include "print-tree.h"
+#include "gimplify.h"
+#include "dumpfile.h"
+#include "convert.h"
+
+#include "a68.h"
+
+/* Algol 68 unions are implemented in this front-end as a data structure
+ consisting of an overhead followed by a value:
+
+ overhead%
+ value%
+
+ Where overhead% is an index that identifies the kind of object currently
+ united, and value% is a GENERIC union. The value currently united in the
+ union is the overhead%-th field in value%.
+
+ At the language level there are no values of union modes in Algol 68. All
+ 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. */
+
+int
+a68_united_mode_index (MOID_T *p, MOID_T *q)
+{
+ int ret = 0;
+ 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 ret;
+ ret += 1;
+ }
+
+ /* Not found. Shouldn't happen. */
+ gcc_unreachable ();
+ 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
+a68_union_overhead (tree exp)
+{
+ tree type = TREE_TYPE (exp);
+ tree overhead_field = TYPE_FIELDS (type);
+ return fold_build3 (COMPONENT_REF,
+ TREE_TYPE (overhead_field),
+ exp,
+ overhead_field,
+ NULL_TREE);
+}
+
+/* Set the overhead of a given united value EXP to OVERHEAD. */
+
+tree
+a68_union_set_overhead (tree exp, tree overhead)
+{
+ tree type = TREE_TYPE (exp);
+ tree overhead_field = TYPE_FIELDS (type);
+ return fold_build2 (MODIFY_EXPR,
+ TREE_TYPE (overhead),
+ fold_build3 (COMPONENT_REF,
+ TREE_TYPE (overhead_field),
+ exp,
+ overhead_field,
+ NULL_TREE),
+ overhead);
+}
+
+/* Get the cunion in the given union EXP. */
+
+tree
+a68_union_cunion (tree exp)
+{
+ tree type = TREE_TYPE (exp);
+ tree value_field = TREE_CHAIN (TYPE_FIELDS (type));
+ return fold_build3 (COMPONENT_REF,
+ TREE_TYPE (value_field),
+ exp,
+ value_field,
+ NULL_TREE);
+}
+
+/* Build a SKIP value for a given union mode M.
+
+ The SKIP value computed is:
+
+ overhead% refers to the first united mode in the union
+ value% is the SKIP for the first united mode in the union
+*/
+
+tree
+a68_get_union_skip_tree (MOID_T *m)
+{
+ tree type = CTYPE (m);
+ tree overhead_field = TYPE_FIELDS (type);
+ tree value_field = TREE_CHAIN (TYPE_FIELDS (type));
+
+ /* Overhead selects the first union alternative. */
+ tree overhead = size_zero_node;
+ /* First union alternative.
+
+ Note that the first union alternative corresponds to the last alternative
+ in the mode as written in the source program. */
+ tree value_type = TREE_TYPE (value_field);
+ tree first_alternative_field = TYPE_FIELDS (value_type);
+ tree value = build_constructor_va (TREE_TYPE (value_field),
+ 1,
+ first_alternative_field,
+ a68_get_skip_tree (MOID (PACK (m))));
+ return build_constructor_va (CTYPE (m),
+ 2,
+ overhead_field, overhead,
+ value_field, value);
+}
+
+/* Return the alternative (value) at the index INDEX in the united value
+ EXP. */
+
+tree
+a68_union_alternative (tree exp, int index)
+{
+ tree type = TREE_TYPE (exp);
+ tree value_field = TREE_CHAIN (TYPE_FIELDS (type));
+ tree value = fold_build3 (COMPONENT_REF,
+ TREE_TYPE (value_field),
+ exp,
+ value_field,
+ NULL_TREE);
+
+ /* Get the current alternative in the value union. */
+ tree value_type = TREE_TYPE (value_field);
+ tree alternative_field = TYPE_FIELDS (value_type);
+ for (int i = 0; i < index; ++i)
+ {
+ gcc_assert (TREE_CHAIN (alternative_field));
+ alternative_field = TREE_CHAIN (alternative_field);
+ }
+
+ /* Get the current alternative from the value. */
+ return fold_build3 (COMPONENT_REF,
+ TREE_TYPE (alternative_field),
+ value,
+ alternative_field,
+ NULL_TREE);
+}
+
+/* Return a constructor for an union of mode MODE, holding the value in EXP
+ which is of mode EXP_MODE. */
+
+tree
+a68_union_value (MOID_T *mode, tree exp, MOID_T *exp_mode)
+{
+ tree type = CTYPE (mode);
+ tree overhead_field = TYPE_FIELDS (type);
+ tree value_field = TREE_CHAIN (TYPE_FIELDS (type));
+
+ int alternative_index = a68_united_mode_index (mode, exp_mode);
+ tree overhead = build_int_cst (sizetype, alternative_index);
+
+ /* Get the field for the alternative corresponding to alternative_index. */
+ tree value_type = TREE_TYPE (value_field);
+ tree alternative_field = TYPE_FIELDS (value_type);
+ for (int i = 0; i < alternative_index; ++i)
+ {
+ gcc_assert (TREE_CHAIN (alternative_field));
+ alternative_field = TREE_CHAIN (alternative_field);
+ }
+
+ tree value = build_constructor_va (TREE_TYPE (value_field),
+ 1,
+ alternative_field,
+ a68_consolidate_ref (exp_mode, exp));
+ return build_constructor_va (type,
+ 2,
+ overhead_field, overhead,
+ value_field, value);
+}
--
2.30.2
