diff options
author | ebotcazou <ebotcazou@138bc75d-0d04-0410-961f-82ee72b054a4> | 2006-09-15 18:32:24 +0000 |
---|---|---|
committer | ebotcazou <ebotcazou@138bc75d-0d04-0410-961f-82ee72b054a4> | 2006-09-15 18:32:24 +0000 |
commit | 6828c3bf75744ce70389277df09119d137c47e5c (patch) | |
tree | 713ceb7365b457e0afcdc02615f5bdf6950ed678 /gcc | |
parent | 066cf272d866816a638ffa7af8e05a38b0901031 (diff) | |
download | gcc-6828c3bf75744ce70389277df09119d137c47e5c.tar.gz |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@116981 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/ChangeLog | 9 | ||||
-rw-r--r-- | gcc/ada/decl.c | 63 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
-rw-r--r-- | gcc/testsuite/gnat.dg/specs/double_record_extension1.ads | 11 | ||||
-rw-r--r-- | gcc/testsuite/gnat.dg/specs/double_record_extension2.ads | 15 |
5 files changed, 93 insertions, 10 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e23e39a32bf..a2b1cb9767c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 6d70a159f3d..c49e834bf49 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -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. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d2cb97d59c3..dc96411dda4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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 diff --git a/gcc/testsuite/gnat.dg/specs/double_record_extension1.ads b/gcc/testsuite/gnat.dg/specs/double_record_extension1.ads new file mode 100644 index 00000000000..7efd3ea1ea0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/double_record_extension1.ads @@ -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; diff --git a/gcc/testsuite/gnat.dg/specs/double_record_extension2.ads b/gcc/testsuite/gnat.dg/specs/double_record_extension2.ads new file mode 100644 index 00000000000..d0dca0c0a04 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/double_record_extension2.ads @@ -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; |