This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Ada] Fix ICE with 2nd extension of discriminated tagged records


It happens when the first level extension is declared as private.  The fix is 
self-explanatory.

Tested on i586-suse-linux, applied on the mainline.


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>

	* 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.


-- 
Eric Botcazou
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c	(revision 148124)
+++ gcc-interface/decl.c	(working copy)
@@ -2899,22 +2899,33 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	       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;
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;
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;
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;
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;

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]