decl.c (gnat_to_gnu_entity): When adjusting the discriminant nodes in an extension...

* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: When
	adjusting the discriminant nodes in an extension, use the full view
	of the parent subtype if it is of a private kind.

From-SVN: r148125
This commit is contained in:
Eric Botcazou 2009-06-03 10:52:40 +00:00 committed by Eric Botcazou
parent a6a29d0c39
commit cdaa0e0b8c
7 changed files with 76 additions and 13 deletions

@ -1,3 +1,9 @@
2009-06-03 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: When
adjusting the discriminant nodes in an extension, use the full view
of the parent subtype if it is of a private kind.
2009-06-03 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: Add the

@ -2899,22 +2899,33 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
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)))
{
/* The actual parent subtype is the full view. */
if (IN (Ekind (gnat_parent), Private_Kind))
{
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);
if (Present (Full_View (gnat_parent)))
gnat_parent = Full_View (gnat_parent);
else
gnat_parent = Underlying_Full_View (gnat_parent);
}
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;

@ -1,3 +1,10 @@
2009-06-03 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/specs/root.ads: New test.
* gnat.dg/specs/root-level_1.ads: Likewise.
* gnat.dg/specs/root-level_2.ads: Likewise.
* gnat.dg/specs/root-level_1-level_2.ads: Likewise.
2009-06-02 Mark Mitchell <mark@codesourcery.com>
* g++.dg/init/ref15.C: Require unwrapped targets.

@ -0,0 +1,7 @@
package Root.Level_1.Level_2 is
type Level_2_Type (First : Natural;
Second : Natural) is new
Level_1.Level_1_Type (First => First, Second => Second) with null record;
end Root.Level_1.Level_2;

@ -0,0 +1,14 @@
package Root.Level_1 is
type Level_1_Type (First : Natural;
Second : Natural) is new Root_Type with private;
private
type Level_1_Type (First : Natural;
Second : Natural) is new Root_Type (First => First)
with record
Buffer_1 : Buffer_Type (1 .. Second);
end record;
end Root.Level_1;

@ -0,0 +1,9 @@
with Root.Level_1;
package Root.Level_2 is
type Level_2_Type (First : Natural;
Second : Natural) is new
Level_1.Level_1_Type (First => First, Second => Second) with null record;
end Root.Level_2;

@ -0,0 +1,9 @@
package Root is
type Buffer_Type is array (Positive range <>) of Natural;
type Root_Type (First : Natural) is abstract tagged record
Buffer_Root : Buffer_Type (1 .. First);
end record;
end Root;