From fbb539954efc29574ff0a8399d88d6525a35c17a Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 22 May 2018 13:23:51 +0000 Subject: [PATCH] [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 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 | 7 +++++++ gcc/ada/sem_ch3.adb | 12 +++++++++++- gcc/testsuite/ChangeLog | 6 ++++++ gcc/testsuite/gnat.dg/discr49.adb | 12 ++++++++++++ gcc/testsuite/gnat.dg/discr49_rec1.adb | 6 ++++++ gcc/testsuite/gnat.dg/discr49_rec1.ads | 8 ++++++++ gcc/testsuite/gnat.dg/discr49_rec2.adb | 6 ++++++ gcc/testsuite/gnat.dg/discr49_rec2.ads | 10 ++++++++++ 8 files changed, 66 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gnat.dg/discr49.adb create mode 100644 gcc/testsuite/gnat.dg/discr49_rec1.adb create mode 100644 gcc/testsuite/gnat.dg/discr49_rec1.ads create mode 100644 gcc/testsuite/gnat.dg/discr49_rec2.adb create mode 100644 gcc/testsuite/gnat.dg/discr49_rec2.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 37615e9fd06..c0b19899f6d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-05-22 Ed Schonberg + + * 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 * 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 2f8af6662a7..994562d8a10 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 a0a57222bc6..74b4d34704d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2018-05-22 Ed Schonberg + + * 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 * 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 index 00000000000..6274c423df1 --- /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 00000000000..c7ffa1eabf7 --- /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 00000000000..0a29b2aa479 --- /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 00000000000..9a0fe7ac514 --- /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 00000000000..4979bfb64cd --- /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; -- 2.30.2