From fa3717c173192eb04440734a3ee110982f31e592 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Thu, 24 May 2018 13:05:26 +0000 Subject: [PATCH] [Ada] Crash on function in Ghost subunit This patch modifies the creation of class-wide subtypes to preserve vital attributes related to Ghost code. The subtype is created by copying the contents of a class-wide type into a newly created itype. When the itype is created within a Ghost region, the act of copying destroys Ghost code related attributes. As a result, if the now living class-wide subtype is frozen within an ignored Ghost region, its freeze node is hoisted prior to the start of the region, howeve the subtype is still eliminated from the tree. ------------ -- Source -- ------------ -- pack.ads with Ada.Finalization; use Ada.Finalization; package Pack is type Ctrl is new Controlled with null record; function Make_Ctrl return Ctrl; package Nested with Ghost is procedure Proc; end Nested; end Pack; -- pack.adb package body Pack is function Make_Ctrl return Ctrl is begin return Result : Ctrl; end Make_Ctrl; package body Nested is separate; end Pack; -- pack-nested.adb separate (Pack) package body Nested is procedure Proc is Res : constant Ctrl'Class := Make_Ctrl; begin null; end Proc; end Nested; ----------------- -- Compilation -- ----------------- $ gcc -c pack.adb 2018-05-24 Hristian Kirtchev gcc/ada/ * exp_util.adb (New_Class_Wide_Subtype): Capture and restore relevant Ghost-related attributes of the class-wide subtype because the copy clobbers them. From-SVN: r260653 --- gcc/ada/ChangeLog | 6 ++++++ gcc/ada/exp_util.adb | 48 ++++++++++++++++++++++++++++++-------------- 2 files changed, 39 insertions(+), 15 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6707a1aef04..bf69dbf2d79 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-05-24 Hristian Kirtchev + + * exp_util.adb (New_Class_Wide_Subtype): Capture and restore relevant + Ghost-related attributes of the class-wide subtype because the copy + clobbers them. + 2018-05-24 Justin Squirek * sem_res.adb (Resolve_Entity_Name): Add guard to protect against diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 5ede9a68958..8ae2d2ba7da 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -10580,26 +10580,44 @@ package body Exp_Util is (CW_Typ : Entity_Id; N : Node_Id) return Entity_Id is - Res : constant Entity_Id := Create_Itype (E_Void, N); - Res_Name : constant Name_Id := Chars (Res); - Res_Scope : constant Entity_Id := Scope (Res); + Res : constant Entity_Id := Create_Itype (E_Void, N); + + -- Capture relevant attributes of the class-wide subtype which must be + -- restored after the copy. + + Res_Chars : constant Name_Id := Chars (Res); + Res_Is_CGE : constant Boolean := Is_Checked_Ghost_Entity (Res); + Res_Is_IGE : constant Boolean := Is_Ignored_Ghost_Entity (Res); + Res_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Res); + Res_Scope : constant Entity_Id := Scope (Res); begin Copy_Node (CW_Typ, Res); - Set_Comes_From_Source (Res, False); - Set_Sloc (Res, Sloc (N)); - Set_Is_Itype (Res); + + -- Restore the relevant attributes of the class-wide subtype + + Set_Chars (Res, Res_Chars); + Set_Is_Checked_Ghost_Entity (Res, Res_Is_CGE); + Set_Is_Ignored_Ghost_Entity (Res, Res_Is_IGE); + Set_Is_Ignored_Ghost_Node (Res, Res_Is_IGN); + Set_Scope (Res, Res_Scope); + + -- Decorate the class-wide subtype + Set_Associated_Node_For_Itype (Res, N); - Set_Is_Public (Res, False); -- By default, may be changed below. + Set_Comes_From_Source (Res, False); + Set_Ekind (Res, E_Class_Wide_Subtype); + Set_Etype (Res, Base_Type (CW_Typ)); + Set_Freeze_Node (Res, Empty); + Set_Is_Frozen (Res, False); + Set_Is_Itype (Res); + Set_Is_Public (Res, False); + Set_Next_Entity (Res, Empty); + Set_Sloc (Res, Sloc (N)); + Set_Public_Status (Res); - Set_Chars (Res, Res_Name); - Set_Scope (Res, Res_Scope); - Set_Ekind (Res, E_Class_Wide_Subtype); - Set_Next_Entity (Res, Empty); - Set_Etype (Res, Base_Type (CW_Typ)); - Set_Is_Frozen (Res, False); - Set_Freeze_Node (Res, Empty); - return (Res); + + return Res; end New_Class_Wide_Subtype; -------------------------------- -- 2.30.2