decl.c (gnat_to_gnu_entity): For a derived untagged type that renames discriminants...

	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: For a
	derived untagged type that renames discriminants, be prepared for
	a type derived from a private discriminated type when changing the
	type of the stored discriminants.

From-SVN: r217153

5 files changed, 57 insertions, 3 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 7e8e9a1..72c0313 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,12 @@
 2014-11-05  Eric Botcazou  <ebotcazou@adacore.com>
 
+	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: For a
+	derived untagged type that renames discriminants, be prepared for
+	a type derived from a private discriminated type when changing the
+	type of the stored discriminants.
+
+2014-11-05  Eric Botcazou  <ebotcazou@adacore.com>
+
 	* gcc-interface/trans.c (Handled_Sequence_Of_Statements_to_gnu): Set
 	the SLOC of the node on the call to set_jmpbuf_address_soft emitted
 	on block entry with SJLJ.
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 05be419..2ed68d4 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -3056,7 +3056,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 		     gnat_field = Next_Stored_Discriminant (gnat_field))
 		  if (Present (Corresponding_Discriminant (gnat_field)))
 		    {
-		      Entity_Id field = Empty;
+		      Entity_Id field;
 		      for (field = First_Stored_Discriminant (gnat_parent);
 			   Present (field);
 			   field = Next_Stored_Discriminant (field))
@@ -3138,8 +3138,30 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 		&& Ekind (Entity (Node (gnat_constr))) == E_Discriminant)
 	      {
 		Entity_Id gnat_discr = Entity (Node (gnat_constr));
-		tree gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr));
-		tree gnu_ref
+		tree gnu_discr_type, gnu_ref;
+
+		/* If the scope of the discriminant is not the record type,
+		   this means that we're processing the implicit full view
+		   of a type derived from a private discriminated type: in
+		   this case, the Stored_Constraint list is simply copied
+		   from the partial view, see Build_Derived_Private_Type.
+		   So we need to retrieve the corresponding discriminant
+		   of the implicit full view, otherwise we will abort.  */
+		if (Scope (gnat_discr) != gnat_entity)
+		  {
+		    Entity_Id field;
+		    for (field = First_Entity (gnat_entity);
+			 Present (field);
+			 field = Next_Entity (field))
+		      if (Ekind (field) == E_Discriminant
+			  && same_discriminant_p (gnat_discr, field))
+			break;
+		    gcc_assert (Present (field));
+		    gnat_discr = field;
+		  }
+
+		gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr));
+		gnu_ref
 		  = gnat_to_gnu_entity (Original_Record_Component (gnat_discr),
 					NULL_TREE, 0);
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d227828..913b5c7 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2014-11-05  Eric Botcazou  <ebotcazou@adacore.com>
 
+	* gnat.dg/specs/private2.ads: New test.
+	* gnat.dg/specs/private2_pkg.ads: New helper.
+
+2014-11-05  Eric Botcazou  <ebotcazou@adacore.com>
+
 	* gnat.dg/inline1.adb: New test.
 	* gnat.dg/inline1_pkg.ad[sb]: New helper.
 	* gnat.dg/inline2.adb: New test.
diff --git a/gcc/testsuite/gnat.dg/specs/private2.ads b/gcc/testsuite/gnat.dg/specs/private2.ads
new file mode 100644
index 0000000..d6fff38
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/private2.ads
@@ -0,0 +1,9 @@
+-- { dg-do compile }
+
+with Private2_Pkg; use Private2_Pkg;
+
+package Private2 is
+
+   type R is new Rec2;
+
+end Private2;
diff --git a/gcc/testsuite/gnat.dg/specs/private2_pkg.ads b/gcc/testsuite/gnat.dg/specs/private2_pkg.ads
new file mode 100644
index 0000000..468d239
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/private2_pkg.ads
@@ -0,0 +1,11 @@
+package Private2_Pkg is

+

+   type Rec2 (D : Natural) is private;

+

+private

+

+   type Rec1 (D : Natural) is null record;

+

+   type Rec2 (D : Natural) is new Rec1 (D);

+

+end Private2_Pkg;