[Ada] Crash with private types and renamed discriminants

[Pierre-Marie de Rodat]

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.

Tested on x86_64-pc-linux-gnu, committed on trunk

2018-05-22  Ed Schonberg  <schonb...@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.
--- gcc/ada/sem_ch3.adb
+++ 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;
 

--- /dev/null
new file mode 100644
+++ 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;

--- /dev/null
new file mode 100644
+++ 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;

--- /dev/null
new file mode 100644
+++ 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;

--- /dev/null
new file mode 100644
+++ 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;

--- /dev/null
new file mode 100644
+++ 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;