[Ada] Crash with private types and renamed discriminants

This patch fixes a compiler abort on an object declaration whose type
is a private type with discriminants, and whose full view is a derived
type that renames some discriminant of its parent.

2018-05-22  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch3.adb (Search_Derivation_Levels): Whenever a parent type is
	private, use the full view if available, because it may include renamed
	discriminants whose values are stored in the corresponding
	Stored_Constraint.

gcc/testsuite/

	* gnat.dg/discr49.adb, gnat.dg/discr49_rec1.adb,
	gnat.dg/discr49_rec1.ads, gnat.dg/discr49_rec2.adb,
	gnat.dg/discr49_rec2.ads: New testcase.

From-SVN: r260521

8 files changed, 66 insertions, 1 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 37615e9..c0b1989 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,12 @@
 2018-05-22  Ed Schonberg  <schonberg@adacore.com>
 
+	* sem_ch3.adb (Search_Derivation_Levels): Whenever a parent type is
+	private, use the full view if available, because it may include renamed
+	discriminants whose values are stored in the corresponding
+	Stored_Constraint.
+
+2018-05-22  Ed Schonberg  <schonberg@adacore.com>
+
 	* einfo.ads, einfo.adb: New attribute Hidden_In_Formal_Instance,
 	defined on packages that are actuals for formal packages, in order to
 	set/reset the visibility of the formals of a formal package with given
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 2f8af66..994562d 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -17977,9 +17977,19 @@ package body Sem_Ch3 is
               Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True);
          else
             declare
-               Td : constant Entity_Id := Etype (Ti);
+               Td : Entity_Id := Etype (Ti);
 
             begin
+
+               --  If the parent type is private, the full view may include
+               --  renamed discriminants, and it is those stored values
+               --  that may be needed (the partial view never has more
+               --  information than the full view).
+
+               if Is_Private_Type (Td) and then Present (Full_View (Td)) then
+                  Td := Full_View (Td);
+               end if;
+
                if Td = Ti then
                   Result := Discriminant;
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a0a5722..74b4d34 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,11 @@
 2018-05-22  Ed Schonberg  <schonberg@adacore.com>
 
+	* gnat.dg/discr49.adb, gnat.dg/discr49_rec1.adb,
+	gnat.dg/discr49_rec1.ads, gnat.dg/discr49_rec2.adb,
+	gnat.dg/discr49_rec2.ads: New testcase.
+
+2018-05-22  Ed Schonberg  <schonberg@adacore.com>
+
 	* gnat.dg/gen_formal_pkg.adb, gnat.dg/gen_formal_pkg_a.ads,
 	gnat.dg/gen_formal_pkg_b.ads, gnat.dg/gen_formal_pkg_w.ads: New
 	testcase.
diff --git a/gcc/testsuite/gnat.dg/discr49.adb b/gcc/testsuite/gnat.dg/discr49.adb
new file mode 100644
index 0000000..6274c42
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr49.adb
@@ -0,0 +1,12 @@
+--  { dg-do run }
+
+with Discr49_Rec2; use Discr49_Rec2;
+
+procedure Discr49 is
+   Obj : Child (True);
+   I : Integer := Value (Obj) + Boolean'Pos (Obj.Discr);
+begin
+   if I /= 125 then
+      raise Program_Error;
+   end if;
+end Discr49;
diff --git a/gcc/testsuite/gnat.dg/discr49_rec1.adb b/gcc/testsuite/gnat.dg/discr49_rec1.adb
new file mode 100644
index 0000000..c7ffa1e
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr49_rec1.adb
@@ -0,0 +1,6 @@
+package body Discr49_Rec1 is
+   function Value (Obj : Parent) return Integer is
+   begin
+      return Obj.V + Boolean'Pos (Obj.Discr_1);
+   end;
+end Discr49_Rec1;
diff --git a/gcc/testsuite/gnat.dg/discr49_rec1.ads b/gcc/testsuite/gnat.dg/discr49_rec1.ads
new file mode 100644
index 0000000..0a29b2a
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr49_rec1.ads
@@ -0,0 +1,8 @@
+package Discr49_Rec1 is
+   type Parent (Discr_1 : Boolean; Discr_2 : Boolean) is private;
+   function Value (Obj : Parent) return Integer;
+private
+   type Parent (Discr_1 : Boolean; Discr_2 : Boolean) is record
+      V : Integer := 123;
+   end record;
+end Discr49_Rec1;
diff --git a/gcc/testsuite/gnat.dg/discr49_rec2.adb b/gcc/testsuite/gnat.dg/discr49_rec2.adb
new file mode 100644
index 0000000..9a0fe7a
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr49_rec2.adb
@@ -0,0 +1,6 @@
+package body Discr49_Rec2 is
+   function Value (Obj : Child) return Integer is
+   begin
+      return Value (Parent (Obj));
+   end;
+end Discr49_Rec2;
diff --git a/gcc/testsuite/gnat.dg/discr49_rec2.ads b/gcc/testsuite/gnat.dg/discr49_rec2.ads
new file mode 100644
index 0000000..4979bfb
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr49_rec2.ads
@@ -0,0 +1,10 @@
+with Discr49_Rec1; use Discr49_Rec1;
+
+package Discr49_Rec2 is
+   type Child (Discr : Boolean) is private;
+   function Value (Obj : Child) return Integer;
+
+private
+   type Child (Discr : Boolean) is
+     new Parent (Discr_1 => Discr, Discr_2 => True);
+end Discr49_Rec2;