Fix PR ada/15802

[Eric Botcazou <ebotcazou at adacore dot com>]

It's an old PR submitted by the Debian folks and we happen to have a very 
localized fix in our tree for several months.

There is a major complexity when a record type derived from a discriminated
record type is being built by Gigi: it inherits a parent subtype whose base
type is the discriminated record type and which references the discriminants
of the record type in its Discriminant_Constraint list.  But those must
reference the parent component of this record which is of the parent subtype!

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.

But afterwards we must fix up both kinds of twisted COMPONENT_REF because the
discriminants must reference the fields of the parent subtype and not those
of its base type for the placeholder machinery to properly work.

Bootstrapped/regtested on i586-suse-linux, applied to the mainline.


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  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat.dg/specs/double_record_extension1.ads: New test.
	* gnat.dg/specs/double_record_extension2.ads: Likewise.


-- 
Eric Botcazou

Index: decl.c
===================================================================
--- decl.c	(revision 116928)
+++ decl.c	(working copy)
@@ -90,6 +90,7 @@ static tree elaborate_expression_1 (Node
 				    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_entit
 	   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_entit
 			     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_entit
 				   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_e
 
   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.  */

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;

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;