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:
parent
a6a29d0c39
commit
cdaa0e0b8c
gcc
ada
testsuite
@ -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.
|
||||
|
7
gcc/testsuite/gnat.dg/specs/root-level_1-level_2.ads
Normal file
7
gcc/testsuite/gnat.dg/specs/root-level_1-level_2.ads
Normal file
@ -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;
|
14
gcc/testsuite/gnat.dg/specs/root-level_1.ads
Normal file
14
gcc/testsuite/gnat.dg/specs/root-level_1.ads
Normal file
@ -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;
|
9
gcc/testsuite/gnat.dg/specs/root-level_2.ads
Normal file
9
gcc/testsuite/gnat.dg/specs/root-level_2.ads
Normal file
@ -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;
|
9
gcc/testsuite/gnat.dg/specs/root.ads
Normal file
9
gcc/testsuite/gnat.dg/specs/root.ads
Normal file
@ -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;
|
Loading…
x
Reference in New Issue
Block a user