This patch updates freezing to ensure that freeze nodes are inserted
into the tree when the entity being frozen is non-Ghost, and the context
is an ignored Ghost spec expression.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-12-11 Hristian Kirtchev <kirtc...@adacore.com>
gcc/ada/
* exp_util.adb (Insert_Action): Add new formal parameter
Spec_Expr_OK.
(Insert_Actions): Add new formal parameter Spec_Expr_OK. Update
all calls to Insert_Actions where relevant. Honour an insertion
from a spec expression context when requested by the caller.
* exp_util.ads (Insert_Action): Add new formal parameter
Spec_Expr_OK.
(Insert_Actions): Add new formal parameter Spec_Expr_OK.
* freeze.adb (Add_To_Result): Force the insertion of the freeze
node even when the context is a spec expression.
gcc/testsuite/
* gnat.dg/ghost2.adb, gnat.dg/ghost2.ads: New testcase.--- gcc/ada/exp_util.adb
+++ gcc/ada/exp_util.adb
@@ -6702,20 +6702,34 @@ package body Exp_Util is
-- Insert_Action --
-------------------
- procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
+ procedure Insert_Action
+ (Assoc_Node : Node_Id;
+ Ins_Action : Node_Id;
+ Spec_Expr_OK : Boolean := False)
+ is
begin
if Present (Ins_Action) then
- Insert_Actions (Assoc_Node, New_List (Ins_Action));
+ Insert_Actions
+ (Assoc_Node => Assoc_Node,
+ Ins_Actions => New_List (Ins_Action),
+ Spec_Expr_OK => Spec_Expr_OK);
end if;
end Insert_Action;
-- Version with check(s) suppressed
procedure Insert_Action
- (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
+ (Assoc_Node : Node_Id;
+ Ins_Action : Node_Id;
+ Suppress : Check_Id;
+ Spec_Expr_OK : Boolean := False)
is
begin
- Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
+ Insert_Actions
+ (Assoc_Node => Assoc_Node,
+ Ins_Actions => New_List (Ins_Action),
+ Suppress => Suppress,
+ Spec_Expr_OK => Spec_Expr_OK);
end Insert_Action;
-------------------------
@@ -6734,7 +6748,11 @@ package body Exp_Util is
-- Insert_Actions --
--------------------
- procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
+ procedure Insert_Actions
+ (Assoc_Node : Node_Id;
+ Ins_Actions : List_Id;
+ Spec_Expr_OK : Boolean := False)
+ is
N : Node_Id;
P : Node_Id;
@@ -6745,14 +6763,20 @@ package body Exp_Util is
return;
end if;
+ -- Insert the action when the context is "Handling of Default and Per-
+ -- Object Expressions" only when requested by the caller.
+
+ if Spec_Expr_OK then
+ null;
+
-- Ignore insert of actions from inside default expression (or other
-- similar "spec expression") in the special spec-expression analyze
-- mode. Any insertions at this point have no relevance, since we are
-- only doing the analyze to freeze the types of any static expressions.
- -- See section "Handling of Default Expressions" in the spec of package
- -- Sem for further details.
+ -- See section "Handling of Default and Per-Object Expressions" in the
+ -- spec of package Sem for further details.
- if In_Spec_Expression then
+ elsif In_Spec_Expression then
return;
end if;
@@ -7429,9 +7453,10 @@ package body Exp_Util is
-- Version with check(s) suppressed
procedure Insert_Actions
- (Assoc_Node : Node_Id;
- Ins_Actions : List_Id;
- Suppress : Check_Id)
+ (Assoc_Node : Node_Id;
+ Ins_Actions : List_Id;
+ Suppress : Check_Id;
+ Spec_Expr_OK : Boolean := False)
is
begin
if Suppress = All_Checks then
@@ -7439,7 +7464,7 @@ package body Exp_Util is
Sva : constant Suppress_Array := Scope_Suppress.Suppress;
begin
Scope_Suppress.Suppress := (others => True);
- Insert_Actions (Assoc_Node, Ins_Actions);
+ Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
Scope_Suppress.Suppress := Sva;
end;
@@ -7448,7 +7473,7 @@ package body Exp_Util is
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress.Suppress (Suppress) := True;
- Insert_Actions (Assoc_Node, Ins_Actions);
+ Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
--- gcc/ada/exp_util.ads
+++ gcc/ada/exp_util.ads
@@ -89,39 +89,54 @@ package Exp_Util is
-- calls, and this guarantee is preserved for the special cases above.
procedure Insert_Action
- (Assoc_Node : Node_Id;
- Ins_Action : Node_Id);
+ (Assoc_Node : Node_Id;
+ Ins_Action : Node_Id;
+ Spec_Expr_OK : Boolean := False);
-- Insert the action Ins_Action at the appropriate point as described
-- above. The action is analyzed using the default checks after it is
-- inserted. Assoc_Node is the node with which the action is associated.
+ -- When flag Spec_Expr_OK is set, insertions triggered in the context of
+ -- spec expressions are honoured, even though they contradict "Handling
+ -- of Default and Per-Object Expressions".
procedure Insert_Action
- (Assoc_Node : Node_Id;
- Ins_Action : Node_Id;
- Suppress : Check_Id);
+ (Assoc_Node : Node_Id;
+ Ins_Action : Node_Id;
+ Suppress : Check_Id;
+ Spec_Expr_OK : Boolean := False);
-- Insert the action Ins_Action at the appropriate point as described
-- above. The action is analyzed using the default checks as modified
-- by the given Suppress argument after it is inserted. Assoc_Node is
- -- the node with which the action is associated.
+ -- the node with which the action is associated. When flag Spec_Expr_OK
+ -- is set, insertions triggered in the context of spec expressions are
+ -- honoured, even though they contradict "Handling of Default and Per-
+ -- Object Expressions".
procedure Insert_Actions
- (Assoc_Node : Node_Id;
- Ins_Actions : List_Id);
+ (Assoc_Node : Node_Id;
+ Ins_Actions : List_Id;
+ Spec_Expr_OK : Boolean := False);
-- Insert the list of action Ins_Actions at the appropriate point as
-- described above. The actions are analyzed using the default checks
-- after they are inserted. Assoc_Node is the node with which the actions
-- are associated. Ins_Actions may be No_List, in which case the call has
- -- no effect.
+ -- no effect. When flag Spec_Expr_OK is set, insertions triggered in the
+ -- context of spec expressions are honoured, even though they contradict
+ -- "Handling of Default and Per-Object Expressions".
procedure Insert_Actions
- (Assoc_Node : Node_Id;
- Ins_Actions : List_Id;
- Suppress : Check_Id);
+ (Assoc_Node : Node_Id;
+ Ins_Actions : List_Id;
+ Suppress : Check_Id;
+ Spec_Expr_OK : Boolean := False);
-- Insert the list of action Ins_Actions at the appropriate point as
-- described above. The actions are analyzed using the default checks
-- as modified by the given Suppress argument after they are inserted.
- -- Assoc_Node is the node with which the actions are associated.
+ -- Assoc_Node is the node with which the actions are associated. List
-- Ins_Actions may be No_List, in which case the call has no effect.
+ -- When flag Spec_Expr_OK is set, insertions triggered in the context of
+ -- spec expressions are honoured, even though they contradict "Handling
+ -- of Default and Per-Object Expressions".
procedure Insert_Action_After
(Assoc_Node : Node_Id;
--- gcc/ada/freeze.adb
+++ gcc/ada/freeze.adb
@@ -2245,13 +2245,19 @@ package body Freeze is
-- entity being frozen is living. Insert the freezing action prior
-- to the start of the enclosing ignored Ghost region. As a result
-- the freezeing action will be preserved when the ignored Ghost
- -- context is eliminated.
+ -- context is eliminated. The insertion must take place even when
+ -- the context is a spec expression, otherwise "Handling of Default
+ -- and Per-Object Expressions" will suppress the insertion, and the
+ -- freeze node will be dropped on the floor.
if Saved_GM = Ignore
and then Ghost_Mode /= Ignore
and then Present (Ignored_Ghost_Region)
then
- Insert_Action (Ignored_Ghost_Region, Fnod);
+ Insert_Action
+ (Assoc_Node => Ignored_Ghost_Region,
+ Ins_Action => Fnod,
+ Spec_Expr_OK => True);
-- Otherwise add the freezing action to the result list
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/ghost2.adb
@@ -0,0 +1,5 @@
+-- { dg-do compile }
+
+package body Ghost2 is
+ procedure Set is null;
+end Ghost2;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/ghost2.ads
@@ -0,0 +1,14 @@
+package Ghost2 is
+ type Val_Entry is (A, B, C, D);
+
+ function Transition_Valid (L : Val_Entry; R : Val_Entry) return Boolean
+ is ((L = B and R = C) or
+ (L = C and R = C) or
+ (L = C and R = D) or
+ (L = D and R = B))
+ with Ghost;
+
+ procedure Set;
+
+ type Val_Array is array (1 .. 5) of Val_Entry;
+end Ghost2;
