This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] constrained discriminated records and SRA
- From: Eric Botcazou <ebotcazou at adacore dot com>
- To: gcc-patches at gcc dot gnu dot org
- Cc: Martin Jambor <mjambor at suse dot cz>
- Date: Tue, 29 Sep 2009 12:57:28 +0200
- Subject: [Ada] constrained discriminated records and SRA
The way gigi translates certain constrained discriminated record types is not
correct. Starting with
type Rec (D : Boolean) is record
case D is
when True => I : Integer;
when False => F : Float;
end case;
end record;
gigi translates the 3 constrained subtypes in
procedure P (B : Boolean) is
R1 : Rec (True);
R2 : Rec (False);
R3 : Rec (B);
begin
null;
end;
the same way, i.e. into flat RECORD_TYPEs. While that's correct for the
first 2 subtypes since they are statically constrained, that's wrong for the
third subtype since the constraint is not static: R3 can contain either I or
F depending on the value of B so the RECORD_TYPE is built with both fields at
the same offset. If SRA happens to break apart the RECORD_TYPE and you have
code like
if B then
R3.I := ...
else
R3.F := ...
end if;
then Bad Things can happen since this can be rewritten as
r3$i := R3.I;
r3$f := R3.F;
if B then
r3$i := ...
else
r3$f := ...
end if;
R3.I := r3$i;
R3.F := r3$f;
and R3.I will not be changed even if B is true.
The attached patch implements a correct approach, which is to build a nest of
variants using QUAL_UNION_TYPE, modeled on that of the type, if the subtype
is not statically constrained.
Martin, this should make it possible to get rid of
/* Some ADA records are half-unions, treat all of them the same. */
for (fld = TYPE_FIELDS (type); fld; fld = TREE_CHAIN (fld))
and the associated special handling in the new SRA pass.
Tested on i586-suse-linux, applied on the mainline.
2009-09-29 Eric Botcazou <ebotcazou@adacore.com>
* decl.c (gnat_to_gnu_entity) <E_Record_Subtype>: Rewrite the handling
of constrained discriminated record subtypes.
(components_to_record): Declare the type of the variants and of the
qualified union.
(build_subst_list): Move around.
(compute_field_positions): Rename into...
(build_position_list): ...this. Return a TREE_VEC.
(annotate_rep): Adjust for above renaming.
(build_variant_list): New static function.
(create_field_decl_from): Likewise.
(get_rep_part): Likewise.
(get_variant_part): Likewise.
(create_variant_part_from): Likewise.
(copy_and_substitute_in_size): Likewise.
--
Eric Botcazou
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c (revision 152264)
+++ gcc-interface/decl.c (working copy)
@@ -122,7 +122,6 @@ enum alias_set_op
static void relate_alias_sets (tree, tree, enum alias_set_op);
-static tree build_subst_list (Entity_Id, Entity_Id, bool);
static bool allocatable_size_p (tree, bool);
static void prepend_one_attribute_to (struct attrib **,
enum attr_type, tree, tree, Node_Id);
@@ -142,14 +141,21 @@ static void components_to_record (tree,
bool, bool, bool, bool, bool);
static Uint annotate_value (tree);
static void annotate_rep (Entity_Id, tree);
-static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
+static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
+static tree build_subst_list (Entity_Id, Entity_Id, bool);
+static tree build_variant_list (tree, tree, tree);
static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
static void set_rm_size (Uint, tree, Entity_Id);
static tree make_type_from_size (tree, tree, bool);
static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
static void check_ok_for_atomic (tree, Entity_Id, bool);
-static int compatible_signatures_p (tree ftype1, tree ftype2);
+static int compatible_signatures_p (tree, tree);
+static tree create_field_decl_from (tree, tree, tree, tree, tree, tree);
+static tree get_rep_part (tree);
+static tree get_variant_part (tree);
+static tree create_variant_part_from (tree, tree, tree, tree, tree);
+static void copy_and_substitute_in_size (tree, tree, tree);
static void rest_of_type_decl_compilation_no_defer (tree);
/* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
@@ -3085,9 +3091,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
}
/* When the subtype has discriminants and these discriminants affect
- the initial shape it has inherited, factor them in. But for the
- of an Unchecked_Union (it must be an Itype), just return the type.
-
+ the initial shape it has inherited, factor them in. But for an
+ Unchecked_Union (it must be an Itype), just return the type.
We can't just test Is_Constrained because private subtypes without
discriminants of types with discriminants with default expressions
are Is_Constrained but aren't constrained! */
@@ -3101,43 +3106,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
{
tree gnu_subst_list
= build_subst_list (gnat_entity, gnat_base_type, definition);
- tree gnu_pos_list, gnu_field_list = NULL_TREE;
- tree gnu_unpad_base_type, t;
+ tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
+ tree gnu_variant_list, gnu_pos_list, gnu_field_list = NULL_TREE;
+ bool selected_variant = false;
Entity_Id gnat_field;
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = gnu_entity_name;
/* Set the size, alignment and alias set of the new type to
- match that of the old one, doing required substitutions.
- We do it this early because we need the size of the new
- type below to discard old fields if necessary. */
- TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
- TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
- SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
- TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
- relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
-
- if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
- for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
- TYPE_SIZE (gnu_type)
- = substitute_in_expr (TYPE_SIZE (gnu_type),
- TREE_PURPOSE (t),
- TREE_VALUE (t));
-
- if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
- for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
- TYPE_SIZE_UNIT (gnu_type)
- = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
- TREE_PURPOSE (t),
- TREE_VALUE (t));
-
- if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
- for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
- SET_TYPE_ADA_SIZE
- (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
- TREE_PURPOSE (t),
- TREE_VALUE (t)));
+ match that of the old one, doing required substitutions. */
+ copy_and_substitute_in_size (gnu_type, gnu_base_type,
+ gnu_subst_list);
if (TREE_CODE (gnu_base_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_base_type))
@@ -3145,10 +3125,57 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
else
gnu_unpad_base_type = gnu_base_type;
+ /* Look for a REP part in the base type. */
+ gnu_rep_part = get_rep_part (gnu_unpad_base_type);
+
+ /* Look for a variant part in the base type. */
+ gnu_variant_part = get_variant_part (gnu_unpad_base_type);
+
+ /* If there is a variant part, we must compute whether the
+ constraints statically select a particular variant. If
+ so, we simply drop the qualified union and flatten the
+ list of fields. Otherwise we'll build a new qualified
+ union for the variants that are still relevant. */
+ if (gnu_variant_part)
+ {
+ gnu_variant_list
+ = build_variant_list (TREE_TYPE (gnu_variant_part),
+ gnu_subst_list, NULL_TREE);
+
+ /* If all the qualifiers are unconditionally true, the
+ innermost variant is statically selected. */
+ selected_variant = true;
+ for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
+ if (!integer_onep (TREE_VEC_ELT (TREE_VALUE (t), 1)))
+ {
+ selected_variant = false;
+ break;
+ }
+
+ /* Otherwise, create the new variants. */
+ if (!selected_variant)
+ for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
+ {
+ tree old_variant = TREE_PURPOSE (t);
+ tree new_variant = make_node (RECORD_TYPE);
+ TYPE_NAME (new_variant)
+ = DECL_NAME (TYPE_NAME (old_variant));
+ copy_and_substitute_in_size (new_variant, old_variant,
+ gnu_subst_list);
+ TREE_VEC_ELT (TREE_VALUE (t), 2) = new_variant;
+ }
+ }
+ else
+ {
+ gnu_variant_list = NULL_TREE;
+ selected_variant = false;
+ }
+
gnu_pos_list
- = compute_field_positions (gnu_unpad_base_type, NULL_TREE,
- size_zero_node, bitsize_zero_node,
- BIGGEST_ALIGNMENT);
+ = build_position_list (gnu_unpad_base_type,
+ gnu_variant_list && !selected_variant,
+ size_zero_node, bitsize_zero_node,
+ BIGGEST_ALIGNMENT, NULL_TREE);
for (gnat_field = First_Entity (gnat_entity);
Present (gnat_field);
@@ -3166,16 +3193,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
= Original_Record_Component (gnat_field);
tree gnu_old_field
= gnat_to_gnu_field_decl (gnat_old_field);
- tree gnu_offset
- = TREE_VALUE
- (purpose_member (gnu_old_field, gnu_pos_list));
- tree gnu_pos = TREE_PURPOSE (gnu_offset);
- tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
- tree gnu_field, gnu_field_type, gnu_size, gnu_new_pos;
- tree gnu_last = NULL_TREE;
- unsigned int offset_align
- = tree_low_cst
- (TREE_PURPOSE (TREE_VALUE (gnu_offset)), 1);
+ tree gnu_context = DECL_CONTEXT (gnu_old_field);
+ tree gnu_field, gnu_field_type, gnu_size;
+ tree gnu_cont_type, gnu_last = NULL_TREE;
/* If the type is the same, retrieve the GCC type from the
old field to take into account possible adjustments. */
@@ -3219,67 +3239,50 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
else
gnu_size = TYPE_SIZE (gnu_field_type);
- if (CONTAINS_PLACEHOLDER_P (gnu_pos))
- for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
- gnu_pos = substitute_in_expr (gnu_pos,
- TREE_PURPOSE (t),
- TREE_VALUE (t));
-
- /* If the position is now a constant, we can set it as the
- position of the field when we make it. Otherwise, we
- need to deal with it specially below. */
- if (TREE_CONSTANT (gnu_pos))
+ /* If the context of the old field is the base type or its
+ REP part (if any), put the field directly in the new
+ type; otherwise look up the context in the variant list
+ and put the field either in the new type if there is a
+ selected variant or in one of the new variants. */
+ if (gnu_context == gnu_unpad_base_type
+ || (gnu_rep_part
+ && gnu_context == TREE_TYPE (gnu_rep_part)))
+ gnu_cont_type = gnu_type;
+ else
{
- gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
-
- /* Discard old fields that are outside the new type.
- This avoids confusing code scanning it to decide
- how to pass it to functions on some platforms. */
- if (TREE_CODE (gnu_new_pos) == INTEGER_CST
- && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST
- && !integer_zerop (gnu_size)
- && !tree_int_cst_lt (gnu_new_pos,
- TYPE_SIZE (gnu_type)))
+ t = purpose_member (gnu_context, gnu_variant_list);
+ if (t)
+ {
+ if (selected_variant)
+ gnu_cont_type = gnu_type;
+ else
+ gnu_cont_type = TREE_VEC_ELT (TREE_VALUE (t), 2);
+ }
+ else
+ /* The front-end may pass us "ghost" components if
+ it fails to recognize that a constrained subtype
+ is statically constrained. Discard them. */
continue;
}
- else
- gnu_new_pos = NULL_TREE;
+ /* Now create the new field modeled on the old one. */
gnu_field
- = create_field_decl
- (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
- DECL_PACKED (gnu_old_field), gnu_size, gnu_new_pos,
- !DECL_NONADDRESSABLE_P (gnu_old_field));
+ = create_field_decl_from (gnu_old_field, gnu_field_type,
+ gnu_cont_type, gnu_size,
+ gnu_pos_list, gnu_subst_list);
- if (!TREE_CONSTANT (gnu_pos))
+ /* Put it in one of the new variants directly. */
+ if (gnu_cont_type != gnu_type)
{
- normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
- DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
- DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
- SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
- DECL_SIZE (gnu_field) = gnu_size;
- DECL_SIZE_UNIT (gnu_field)
- = convert (sizetype,
- size_binop (CEIL_DIV_EXPR, gnu_size,
- bitsize_unit_node));
- layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
+ TREE_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
+ TYPE_FIELDS (gnu_cont_type) = gnu_field;
}
- DECL_INTERNAL_P (gnu_field)
- = DECL_INTERNAL_P (gnu_old_field);
- SET_DECL_ORIGINAL_FIELD
- (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field)
- ? DECL_ORIGINAL_FIELD (gnu_old_field)
- : gnu_old_field));
- DECL_DISCRIMINANT_NUMBER (gnu_field)
- = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
- TREE_THIS_VOLATILE (gnu_field)
- = TREE_THIS_VOLATILE (gnu_old_field);
-
/* To match the layout crafted in components_to_record,
if this is the _Tag or _Parent field, put it before
any other fields. */
- if (gnat_name == Name_uTag || gnat_name == Name_uParent)
+ else if (gnat_name == Name_uTag
+ || gnat_name == Name_uParent)
gnu_field_list = chainon (gnu_field_list, gnu_field);
/* Similarly, if this is the _Controller field, put
@@ -3304,6 +3307,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
save_gnu_tree (gnat_field, gnu_field, false);
}
+ /* If there is a variant list and no selected variant, we need
+ to create the nest of variant parts from the old nest. */
+ if (gnu_variant_list && !selected_variant)
+ {
+ tree new_variant_part
+ = create_variant_part_from (gnu_variant_part,
+ gnu_variant_list, gnu_type,
+ gnu_pos_list, gnu_subst_list);
+ TREE_CHAIN (new_variant_part) = gnu_field_list;
+ gnu_field_list = new_variant_part;
+ }
+
/* Now go through the entities again looking for Itypes that
we have not elaborated but should (e.g., Etypes of fields
that have Original_Components). */
@@ -3318,11 +3333,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
gnu_field_list = nreverse (gnu_field_list);
finish_record_type (gnu_type, gnu_field_list, 2, true);
- /* Finalize size and mode. */
- TYPE_SIZE (gnu_type) = variable_size (TYPE_SIZE (gnu_type));
- TYPE_SIZE_UNIT (gnu_type)
- = variable_size (TYPE_SIZE_UNIT (gnu_type));
-
/* See the E_Record_Type case for the rationale. */
if (Is_Tagged_Type (gnat_entity)
|| Is_Limited_Record (gnat_entity))
@@ -5549,37 +5559,6 @@ relate_alias_sets (tree gnu_new_type, tr
record_component_aliases (gnu_new_type);
}
-/* Return a TREE_LIST describing the substitutions needed to reflect the
- discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
- be in any order. TREE_PURPOSE gives the tree for the discriminant and
- TREE_VALUE is the replacement value. They are in the form of operands
- to substitute_in_expr. DEFINITION is true if this is for a definition
- of GNAT_SUBTYPE. */
-
-static tree
-build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
-{
- tree gnu_list = NULL_TREE;
- Entity_Id gnat_discrim;
- Node_Id gnat_value;
-
- for (gnat_discrim = First_Stored_Discriminant (gnat_type),
- gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
- Present (gnat_discrim);
- gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
- gnat_value = Next_Elmt (gnat_value))
- /* Ignore access discriminants. */
- if (!Is_Access_Type (Etype (Node (gnat_value))))
- gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
- elaborate_expression
- (Node (gnat_value), gnat_subtype,
- get_entity_name (gnat_discrim), definition,
- true, false),
- gnu_list);
-
- return gnu_list;
-}
-
/* Return true if the size represented by GNU_SIZE can be handled by an
allocation. If STATIC_P is true, consider only what can be done with a
static allocation. */
@@ -6959,6 +6938,8 @@ components_to_record (tree gnu_record_ty
otherwise, the union type definition will be lacking
the fields associated with these empty variants. */
rest_of_record_type_compilation (gnu_variant_type);
+ create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
+ NULL, true, debug_info_p, gnat_component_list);
gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
gnu_union_type, field_packed,
@@ -7005,6 +6986,9 @@ components_to_record (tree gnu_record_ty
return;
}
+ create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
+ NULL, true, debug_info_p, gnat_component_list);
+
/* Deal with packedness like in gnat_to_gnu_field. */
union_field_packed
= adjust_packed (gnu_union_type, gnu_record_type, packed);
@@ -7310,8 +7294,9 @@ annotate_rep (Entity_Id gnat_entity, tre
/* We operate by first making a list of all fields and their position (we
can get the size easily) and then update all the sizes in the tree. */
- gnu_list = compute_field_positions (gnu_type, NULL_TREE, size_zero_node,
- bitsize_zero_node, BIGGEST_ALIGNMENT);
+ gnu_list
+ = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
+ BIGGEST_ALIGNMENT, NULL_TREE);
for (gnat_field = First_Entity (gnat_entity);
Present (gnat_field);
@@ -7346,9 +7331,8 @@ annotate_rep (Entity_Id gnat_entity, tre
(gnat_field,
annotate_value
(size_binop (PLUS_EXPR,
- bit_from_pos (TREE_PURPOSE (TREE_VALUE (t)),
- TREE_VALUE (TREE_VALUE
- (TREE_VALUE (t)))),
+ bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
+ TREE_VEC_ELT (TREE_VALUE (t), 2)),
parent_offset)));
Set_Esize (gnat_field,
@@ -7368,17 +7352,17 @@ annotate_rep (Entity_Id gnat_entity, tre
}
}
-/* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
- FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
- position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
- placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
- to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
- the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
- so far. */
+/* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
+ the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
+ value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
+ of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
+ is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
+ bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
+ pre-existing list to be chained to the newly created entries. */
static tree
-compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
- tree gnu_bitpos, unsigned int offset_align)
+build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
+ tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
{
tree gnu_field;
@@ -7392,20 +7376,109 @@ compute_field_positions (tree gnu_type,
DECL_FIELD_OFFSET (gnu_field));
unsigned int our_offset_align
= MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
+ tree v = make_tree_vec (3);
- gnu_list
- = tree_cons (gnu_field,
- tree_cons (gnu_our_offset,
- tree_cons (size_int (our_offset_align),
- gnu_our_bitpos, NULL_TREE),
- NULL_TREE),
- gnu_list);
+ TREE_VEC_ELT (v, 0) = gnu_our_offset;
+ TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
+ TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
+ gnu_list = tree_cons (gnu_field, v, gnu_list);
+ /* Recurse on internal fields, flattening the nested fields except for
+ those in the variant part, if requested. */
if (DECL_INTERNAL_P (gnu_field))
- gnu_list
- = compute_field_positions (TREE_TYPE (gnu_field), gnu_list,
+ {
+ tree gnu_field_type = TREE_TYPE (gnu_field);
+ if (do_not_flatten_variant
+ && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
+ gnu_list
+ = build_position_list (gnu_field_type, do_not_flatten_variant,
+ size_zero_node, bitsize_zero_node,
+ BIGGEST_ALIGNMENT, gnu_list);
+ else
+ gnu_list
+ = build_position_list (gnu_field_type, do_not_flatten_variant,
gnu_our_offset, gnu_our_bitpos,
- our_offset_align);
+ our_offset_align, gnu_list);
+ }
+ }
+
+ return gnu_list;
+}
+
+/* Return a TREE_LIST describing the substitutions needed to reflect the
+ discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
+ be in any order. TREE_PURPOSE gives the tree for the discriminant and
+ TREE_VALUE is the replacement value. They are in the form of operands
+ to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for a definition
+ of GNAT_SUBTYPE. */
+
+static tree
+build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
+{
+ tree gnu_list = NULL_TREE;
+ Entity_Id gnat_discrim;
+ Node_Id gnat_value;
+
+ for (gnat_discrim = First_Stored_Discriminant (gnat_type),
+ gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
+ Present (gnat_discrim);
+ gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
+ gnat_value = Next_Elmt (gnat_value))
+ /* Ignore access discriminants. */
+ if (!Is_Access_Type (Etype (Node (gnat_value))))
+ gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
+ elaborate_expression
+ (Node (gnat_value), gnat_subtype,
+ get_entity_name (gnat_discrim), definition,
+ true, false),
+ gnu_list);
+
+ return gnu_list;
+}
+
+/* Scan all fields in QUAL_UNION_TYPE and return a TREE_LIST describing the
+ variants of QUAL_UNION_TYPE that are still relevant after applying the
+ substitutions described in SUBST_LIST. TREE_PURPOSE is the type of the
+ variant and TREE_VALUE is a TREE_VEC containing the field, the new value
+ of the qualifier and NULL_TREE respectively. GNU_LIST is a pre-existing
+ list to be chained to the newly created entries. */
+
+static tree
+build_variant_list (tree qual_union_type, tree subst_list, tree gnu_list)
+{
+ tree gnu_field;
+
+ for (gnu_field = TYPE_FIELDS (qual_union_type);
+ gnu_field;
+ gnu_field = TREE_CHAIN (gnu_field))
+ {
+ tree t, qual = DECL_QUALIFIER (gnu_field);
+
+ for (t = subst_list; t; t = TREE_CHAIN (t))
+ qual = SUBSTITUTE_IN_EXPR (qual, TREE_PURPOSE (t), TREE_VALUE (t));
+
+ /* If the new qualifier is not unconditionally false, its variant may
+ still be accessed. */
+ if (!integer_zerop (qual))
+ {
+ tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
+ tree v = make_tree_vec (3);
+ TREE_VEC_ELT (v, 0) = gnu_field;
+ TREE_VEC_ELT (v, 1) = qual;
+ TREE_VEC_ELT (v, 2) = NULL_TREE;
+ gnu_list = tree_cons (variant_type, v, gnu_list);
+
+ /* Recurse on the variant subpart of the variant, if any. */
+ variant_subpart = get_variant_part (variant_type);
+ if (variant_subpart)
+ gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
+ subst_list, gnu_list);
+
+ /* If the new qualifier is unconditionally true, the subsequent
+ variants cannot be accessed. */
+ if (integer_onep (qual))
+ break;
+ }
}
return gnu_list;
@@ -7916,6 +7989,253 @@ compatible_signatures_p (tree ftype1, tr
return 1;
}
+/* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
+ and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
+ specified size for this field. POS_LIST is a position list describing
+ the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
+ to this layout. */
+
+static tree
+create_field_decl_from (tree old_field, tree field_type, tree record_type,
+ tree size, tree pos_list, tree subst_list)
+{
+ tree t = TREE_VALUE (purpose_member (old_field, pos_list));
+ tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
+ unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
+ tree new_pos, new_field;
+
+ if (CONTAINS_PLACEHOLDER_P (pos))
+ for (t = subst_list; t; t = TREE_CHAIN (t))
+ pos = SUBSTITUTE_IN_EXPR (pos, TREE_PURPOSE (t), TREE_VALUE (t));
+
+ /* If the position is now a constant, we can set it as the position of the
+ field when we make it. Otherwise, we need to deal with it specially. */
+ if (TREE_CONSTANT (pos))
+ new_pos = bit_from_pos (pos, bitpos);
+ else
+ new_pos = NULL_TREE;
+
+ new_field
+ = create_field_decl (DECL_NAME (old_field), field_type, record_type,
+ DECL_PACKED (old_field), size, new_pos,
+ !DECL_NONADDRESSABLE_P (old_field));
+
+ if (!new_pos)
+ {
+ normalize_offset (&pos, &bitpos, offset_align);
+ DECL_FIELD_OFFSET (new_field) = pos;
+ DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
+ SET_DECL_OFFSET_ALIGN (new_field, offset_align);
+ DECL_SIZE (new_field) = size;
+ DECL_SIZE_UNIT (new_field)
+ = convert (sizetype,
+ size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
+ layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
+ }
+
+ DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
+ t = DECL_ORIGINAL_FIELD (old_field);
+ SET_DECL_ORIGINAL_FIELD (new_field, t ? t : old_field);
+ DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
+ TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
+
+ return new_field;
+}
+
+/* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
+
+static tree
+get_rep_part (tree record_type)
+{
+ tree field = TYPE_FIELDS (record_type);
+
+ /* The REP part is the first field, internal, another record, and its name
+ doesn't start with an underscore (i.e. is not generated by the FE). */
+ if (DECL_INTERNAL_P (field)
+ && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
+ && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
+ return field;
+
+ return NULL_TREE;
+}
+
+/* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
+
+static tree
+get_variant_part (tree record_type)
+{
+ tree field;
+
+ /* The variant part is the only internal field that is a qualified union. */
+ for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
+ if (DECL_INTERNAL_P (field)
+ && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
+ return field;
+
+ return NULL_TREE;
+}
+
+/* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
+ the list of variants to be used and RECORD_TYPE is the type of the parent.
+ POS_LIST is a position list describing the layout of fields present in
+ OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
+ layout. */
+
+static tree
+create_variant_part_from (tree old_variant_part, tree variant_list,
+ tree record_type, tree pos_list, tree subst_list)
+{
+ tree offset = DECL_FIELD_OFFSET (old_variant_part);
+ tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
+ tree old_union_type = TREE_TYPE (old_variant_part);
+ tree new_union_type, new_variant_part, t;
+ tree union_field_list = NULL_TREE;
+
+ /* First create the type of the variant part from that of the old one. */
+ new_union_type = make_node (QUAL_UNION_TYPE);
+ TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
+
+ /* If the position of the variant part is constant, subtract it from the
+ size of the type of the parent to get the new size. This manual CSE
+ reduces the code size when not optimizing. */
+ if (TREE_CODE (offset) == INTEGER_CST && TREE_CODE (bitpos) == INTEGER_CST)
+ {
+ tree first_bit = bit_from_pos (offset, bitpos);
+ TYPE_SIZE (new_union_type)
+ = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
+ TYPE_SIZE_UNIT (new_union_type)
+ = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
+ byte_from_pos (offset, bitpos));
+ SET_TYPE_ADA_SIZE (new_union_type,
+ size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
+ first_bit));
+ TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
+ relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
+ }
+ else
+ copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
+
+ /* Now finish up the new variants and populate the union type. */
+ for (t = variant_list; t; t = TREE_CHAIN (t))
+ {
+ tree old_field = TREE_VEC_ELT (TREE_VALUE (t), 0), new_field;
+ tree old_variant, old_variant_subpart, new_variant, field_list;
+
+ /* Skip variants that don't belong to this nesting level. */
+ if (DECL_CONTEXT (old_field) != old_union_type)
+ continue;
+
+ /* Retrieve the list of fields already added to the new variant. */
+ new_variant = TREE_VEC_ELT (TREE_VALUE (t), 2);
+ field_list = TYPE_FIELDS (new_variant);
+
+ /* If the old variant had a variant subpart, we need to create a new
+ variant subpart and add it to the field list. */
+ old_variant = TREE_PURPOSE (t);
+ old_variant_subpart = get_variant_part (old_variant);
+ if (old_variant_subpart)
+ {
+ tree new_variant_subpart
+ = create_variant_part_from (old_variant_subpart, variant_list,
+ new_variant, pos_list, subst_list);
+ TREE_CHAIN (new_variant_subpart) = field_list;
+ field_list = new_variant_subpart;
+ }
+
+ /* Finish up the new variant and create the field. */
+ finish_record_type (new_variant, nreverse (field_list), 2, true);
+ compute_record_mode (new_variant);
+ rest_of_record_type_compilation (new_variant);
+
+ /* No need for debug info thanks to the XVS type. */
+ create_type_decl (TYPE_NAME (new_variant), new_variant, NULL,
+ true, false, Empty);
+
+ new_field
+ = create_field_decl_from (old_field, new_variant, new_union_type,
+ TYPE_SIZE (new_variant),
+ pos_list, subst_list);
+ DECL_QUALIFIER (new_field) = TREE_VEC_ELT (TREE_VALUE (t), 1);
+ DECL_INTERNAL_P (new_field) = 1;
+ TREE_CHAIN (new_field) = union_field_list;
+ union_field_list = new_field;
+ }
+
+ /* Finish up the union type and create the variant part. */
+ finish_record_type (new_union_type, union_field_list, 2, true);
+ compute_record_mode (new_union_type);
+ rest_of_record_type_compilation (new_union_type);
+
+ /* No need for debug info thanks to the XVS type. */
+ create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL,
+ true, false, Empty);
+
+ new_variant_part
+ = create_field_decl_from (old_variant_part, new_union_type, record_type,
+ TYPE_SIZE (new_union_type),
+ pos_list, subst_list);
+ DECL_INTERNAL_P (new_variant_part) = 1;
+
+ /* With multiple discriminants it is possible for an inner variant to be
+ statically selected while outer ones are not; in this case, the list
+ of fields of the inner variant is not flattened and we end up with a
+ qualified union with a single member. Drop the useless container. */
+ if (!TREE_CHAIN (union_field_list))
+ {
+ DECL_CONTEXT (union_field_list) = record_type;
+ DECL_FIELD_OFFSET (union_field_list)
+ = DECL_FIELD_OFFSET (new_variant_part);
+ DECL_FIELD_BIT_OFFSET (union_field_list)
+ = DECL_FIELD_BIT_OFFSET (new_variant_part);
+ SET_DECL_OFFSET_ALIGN (union_field_list,
+ DECL_OFFSET_ALIGN (new_variant_part));
+ new_variant_part = union_field_list;
+ }
+
+ return new_variant_part;
+}
+
+/* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
+ which are both RECORD_TYPE, after applying the substitutions described
+ in SUBST_LIST. */
+
+static void
+copy_and_substitute_in_size (tree new_type, tree old_type, tree subst_list)
+{
+ tree t;
+
+ TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
+ TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
+ SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
+ TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
+ relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
+
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
+ for (t = subst_list; t; t = TREE_CHAIN (t))
+ TYPE_SIZE (new_type)
+ = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
+ TREE_PURPOSE (t),
+ TREE_VALUE (t));
+
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
+ for (t = subst_list; t; t = TREE_CHAIN (t))
+ TYPE_SIZE_UNIT (new_type)
+ = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
+ TREE_PURPOSE (t),
+ TREE_VALUE (t));
+
+ if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
+ for (t = subst_list; t; t = TREE_CHAIN (t))
+ SET_TYPE_ADA_SIZE
+ (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
+ TREE_PURPOSE (t),
+ TREE_VALUE (t)));
+
+ /* Finalize the size. */
+ TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
+ TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
+}
+
/* Given a type T, a FIELD_DECL F, and a replacement value R, return a
type with all size expressions that contain F in a PLACEHOLDER_EXPR
updated by replacing F with R.