OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR ada/15802 (ICE at expr.c:6764 (placeholder mechanism))

Browse Source 
PR ada/15802
	* decl.c (same_discriminant_p): New static function.
	(gnat_to_gnu_entity) <E_Record_Type>: When there is a parent
	subtype and we have discriminants, fix up the COMPONENT_REFs
	for the discriminants to make them reference the corresponding
	fields of the parent subtype after it has been built.

From-SVN: r116981
This commit is contained in:
Eric Botcazou 2006-09-15 18:32:24 +00:00 committed by Eric Botcazou
parent 7ee51a34b8
commit 41d9adc7fa
5 changed files with 93 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/ada/ChangeLog
View File

@ -1,3 +1,12 @@
2006-09-15 Eric Botcazou <ebotcazou@adacore.com>
PR ada/15802
* decl.c (same_discriminant_p): New static function.
(gnat_to_gnu_entity) <E_Record_Type>: When there is a parent
subtype and we have discriminants, fix up the COMPONENT_REFs
for the discriminants to make them reference the corresponding
fields of the parent subtype after it has been built.
2006-09-15 Roger Sayle <roger@eyesopen.com>
PR ada/18817

63
gcc/ada/decl.c
View File

@ -90,6 +90,7 @@ static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree,
bool, bool);
static tree make_packable_type (tree);
static tree gnat_to_gnu_field (Entity_Id, tree, int, bool);
static bool same_discriminant_p (Entity_Id, Entity_Id);
static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
bool, bool, bool, bool);
static int compare_field_bitpos (const PTR, const PTR);
@ -2429,16 +2430,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
this record has rep clauses, force the position to zero. */
if (Present (Parent_Subtype (gnat_entity)))
{
Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
tree gnu_parent;
/* A major complexity here is that the parent subtype will
reference our discriminants. But those must reference
the parent component of this record. So here we will
initialize each of those components to a COMPONENT_REF.
The first operand of that COMPONENT_REF is another
COMPONENT_REF which will be filled in below, once
the parent type can be safely built. */
reference our discriminants in its Discriminant_Constraint
list. But those must reference the parent component of this
record which is of the parent subtype we have not built yet!
To break the circle we first build a dummy COMPONENT_REF which
represents the "get to the parent" operation and initialize
each of those discriminants to a COMPONENT_REF of the above
dummy parent referencing the corresponding discrimant of the
base type of the parent subtype. */
gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
build0 (PLACEHOLDER_EXPR, gnu_type),
build_decl (FIELD_DECL, NULL_TREE,
@ -2460,8 +2463,35 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
NULL_TREE),
true);
gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity));
/* Then we build the parent subtype. */
gnu_parent = gnat_to_gnu_type (gnat_parent);
/* Finally we fix up both kinds of twisted COMPONENT_REF we have
initially built. The discriminants must reference the fields
of the parent subtype and not those of its base type for the
placeholder machinery to properly work. */
if (Has_Discriminants (gnat_entity))
for (gnat_field = First_Stored_Discriminant (gnat_entity);
Present (gnat_field);
gnat_field = Next_Stored_Discriminant (gnat_field))
if (Present (Corresponding_Discriminant (gnat_field)))
{
Entity_Id field = Empty;
for (field = First_Stored_Discriminant (gnat_parent);
Present (field);
field = Next_Stored_Discriminant (field))
if (same_discriminant_p (gnat_field, field))
break;
gcc_assert (Present (field));
TREE_OPERAND (get_gnu_tree (gnat_field), 1)
= gnat_to_gnu_field_decl (field);
}
/* The "get to the parent" COMPONENT_REF must be given its
proper type... */
TREE_TYPE (gnu_get_parent) = gnu_parent;
/* ...and reference the _parent field of this record. */
gnu_field_list
= create_field_decl (get_identifier
(Get_Name_String (Name_uParent)),
@ -2469,8 +2499,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
has_rep ? TYPE_SIZE (gnu_parent) : 0,
has_rep ? bitsize_zero_node : 0, 1);
DECL_INTERNAL_P (gnu_field_list) = 1;
TREE_TYPE (gnu_get_parent) = gnu_parent;
TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
}
@ -4291,6 +4319,21 @@ gnat_to_gnu_field_decl (Entity_Id gnat_entity)
return gnu_field;
}
/* Return true if DISCR1 and DISCR2 represent the same discriminant. */
static
bool same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
{
while (Present (Corresponding_Discriminant (discr1)))
discr1 = Corresponding_Discriminant (discr1);
while (Present (Corresponding_Discriminant (discr2)))
discr2 = Corresponding_Discriminant (discr2);
return
Original_Record_Component (discr1) == Original_Record_Component (discr2);
}
/* Given GNAT_ENTITY, elaborate all expressions that are required to
be elaborated at the point of its definition, but do nothing else. */

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2006-09-15 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/specs/double_record_extension1.ads: New test.
* gnat.dg/specs/double_record_extension2.ads: Likewise.
2006-09-15 Paul Thomas <pault@gcc.gnu.org>
PR fortran/29051

11
gcc/testsuite/gnat.dg/specs/double_record_extension1.ads Normal file
View File

@ -0,0 +1,11 @@
package double_record_extension1 is
type T1(n: natural) is tagged record
s1: string (1..n);
end record;
type T2(j,k: natural) is new T1(j) with record
s2: string (1..k);
end record;
type T3 is new T2 (10, 10) with null record;
end double_record_extension1;

15
gcc/testsuite/gnat.dg/specs/double_record_extension2.ads Normal file
View File

@ -0,0 +1,15 @@
package double_record_extension2 is
type Base_Message_Type (Num_Bytes : Positive) is tagged record
Data_Block : String (1..Num_Bytes);
end record;
type Extended_Message_Type (Num_Bytes1 : Positive; Num_Bytes2 : Positive) is new Base_Message_Type (Num_Bytes1) with record
A: String (1..Num_Bytes2);
end record;
type Final_Message_Type is new Extended_Message_Type with record
B : Integer;
end record;
end double_record_extension2;