Commit fa3717c1 by Hristian Kirtchev Committed by Pierre-Marie de Rodat

[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
parent 36e7d49f
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> 2018-05-24 Justin Squirek <squirek@adacore.com>
* sem_res.adb (Resolve_Entity_Name): Add guard to protect against * sem_res.adb (Resolve_Entity_Name): Add guard to protect against
......
...@@ -10580,26 +10580,44 @@ package body Exp_Util is ...@@ -10580,26 +10580,44 @@ package body Exp_Util is
(CW_Typ : Entity_Id; (CW_Typ : Entity_Id;
N : Node_Id) return Entity_Id N : Node_Id) return Entity_Id
is is
Res : constant Entity_Id := Create_Itype (E_Void, N); Res : constant Entity_Id := Create_Itype (E_Void, N);
Res_Name : constant Name_Id := Chars (Res);
Res_Scope : constant Entity_Id := Scope (Res); -- 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 begin
Copy_Node (CW_Typ, Res); Copy_Node (CW_Typ, Res);
Set_Comes_From_Source (Res, False);
Set_Sloc (Res, Sloc (N)); -- Restore the relevant attributes of the class-wide subtype
Set_Is_Itype (Res);
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_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_Public_Status (Res);
Set_Chars (Res, Res_Name);
Set_Scope (Res, Res_Scope); return Res;
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);
end New_Class_Wide_Subtype; end New_Class_Wide_Subtype;
-------------------------------- --------------------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment