[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

gcc/ada/ChangeLog

 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

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;
 

gcc/testsuite/ChangeLog

 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.

gcc/testsuite/gnat.dg/discr49.adb

+--  { 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;

gcc/testsuite/gnat.dg/discr49_rec1.adb

+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;

gcc/testsuite/gnat.dg/discr49_rec1.ads

+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;

gcc/testsuite/gnat.dg/discr49_rec2.adb

+package body Discr49_Rec2 is
+   function Value (Obj : Child) return Integer is
+   begin
+      return Value (Parent (Obj));
+   end;
+end Discr49_Rec2;

gcc/testsuite/gnat.dg/discr49_rec2.ads

+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;