diff options
author | Hristian Kirtchev <kirtchev@adacore.com> | 2018-05-24 13:05:26 +0000 |
---|---|---|
committer | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2018-05-24 13:05:26 +0000 |
commit | fa3717c173192eb04440734a3ee110982f31e592 (patch) | |
tree | cc31ee41442c6c152781125628426dd0b51a799e | |
parent | 36e7d49f8afc9bde0ef5691fc5a3ce4330fd3063 (diff) | |
download | gcc-fa3717c173192eb04440734a3ee110982f31e592.zip gcc-fa3717c173192eb04440734a3ee110982f31e592.tar.gz gcc-fa3717c173192eb04440734a3ee110982f31e592.tar.bz2 |
[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 <kirtchev@adacore.com>
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
-rw-r--r-- | gcc/ada/ChangeLog | 6 | ||||
-rw-r--r-- | gcc/ada/exp_util.adb | 48 |
2 files changed, 39 insertions, 15 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6707a1a..bf69dbf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-05-24 Hristian Kirtchev <kirtchev@adacore.com> + + * 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 <squirek@adacore.com> * 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 5ede9a6..8ae2d2b 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; -------------------------------- |