[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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 37615e9fd069773e012892275765cf766ee77089..c0b19899f6d892b63554ffb6d6150e6a8ae2741e 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+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,

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 2f8af6662a7a5b7ce230c2bf0afb1ac9bac82e5b..994562d8a106f353bf64823e9e5daa999ae115bb 100644 (file)
--- 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 a0a57222bc6b2c78f44a100435aea736940a7a1a..74b4d34704d9d4d00e223cc0b793556f7ac12b89 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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,

diff --git a/gcc/testsuite/gnat.dg/discr49.adb b/gcc/testsuite/gnat.dg/discr49.adb
new file mode 100644 (file)
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 (file)
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 (file)
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 (file)
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 (file)
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;