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

	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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index e23e39a32bf0f8042c2b511e14ddf4dcf579c7a2..a2b1cb9767c7a88509ea60c13bb706848c50b7cb 100644 (file)
--- 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 6d70a159f3d1fb4c46547e61e34787f8f43847a8..c49e834bf49fc1632cce915cb46ece83359fdd89 100644 (file)
--- 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);
+}
 \f
 /* 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 d2cb97d59c33f206951ac3e8e254c70ceaea9e6d..dc96411dda402d4a62871bb532c96a265baa6f2a 100644 (file)
--- 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 (file)
index 0000000..7efd3ea
--- /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 (file)
index 0000000..d0dca0c
--- /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;