This patch corrects the transient object machinery to treat the renamed result
of a controlled function call as a finalizable transient when the context is an
expression with actions. If this was a different context, the lifetime of the
result would be considered extended and not finalized.
------------
-- Source --
------------
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Ctrl is new Limited_Controlled with record
Val : Integer := 0;
end record;
function F1 (Obj : Ctrl) return Integer;
function F2 (Val : Integer) return Ctrl'Class;
procedure Finalize (Obj : in out Ctrl);
procedure Test (Flag : Boolean; Obj : Ctrl);
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
procedure Finalize (Obj : in out Ctrl) is
begin
Put_Line ("fin" & Obj.Val'Img);
end Finalize;
function F1 (Obj : Ctrl) return Integer is
begin
return Obj.Val + 1;
end F1;
function F2 (Val : Integer) return Ctrl'Class is
begin
Put_Line ("ini" & Val'Img);
return Ctrl'(Limited_Controlled with Val => Val);
end F2;
procedure Test (Flag : Boolean; Obj : Ctrl) is
begin
if Flag and then F2 (F1 (Obj)).Val = 42 then
raise Program_Error;
end if;
end Test;
end Types;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Types; use Types;
procedure Main is
begin
declare
Obj : Ctrl;
begin
Obj.Val := 1;
Test (True, Obj);
exception
when others =>
Put_Line ("ERROR: unexpected exception 1");
end;
declare
Obj : Ctrl;
begin
Obj.Val := 41;
Test (True, Obj);
Put_Line ("ERROR: exception not raised");
exception
when Program_Error =>
null;
when others =>
Put_Line ("ERROR: unexpected exception 2");
end;
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q main.adb
$ ./main
ini 2
fin 2
fin 1
ini 42
fin 42
fin 41
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-16 Hristian Kirtchev <kirtc...@adacore.com>
* exp_ch4.ads, exp_ch4.adb (Find_Hook_Context): Relocated to Exp_Util.
* exp_ch7.adb (Process_Declarations): There is no need to check
that a transient object being hooked is controlled as it would
not have been hooked in the first place.
* exp_ch9.adb Remove with and use clause for Exp_Ch4.
* exp_util.adb (Find_Hook_Context): Relocated from Exp_Ch4.
(Is_Aliased): A renaming of a transient controlled object is
not considered aliasing when it occurs within an expression
with actions.
(Requires_Cleanup_Actions): There is no need to
check that a transient object being hooked is controlled as it
would not have been hooked in the first place.
* exp_util.ads (Find_Hook_Context): Relocated from Exp_Ch4.
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 212640)
+++ exp_ch7.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1825,8 +1825,6 @@
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
N_Object_Declaration
- and then Is_Finalizable_Transient
- (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
then
Processing_Actions (Has_No_Init => True);
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 212640)
+++ exp_util.adb (working copy)
@@ -2598,6 +2598,145 @@
raise Program_Error;
end Find_Protection_Type;
+ -----------------------
+ -- Find_Hook_Context --
+ -----------------------
+
+ function Find_Hook_Context (N : Node_Id) return Node_Id is
+ Par : Node_Id;
+ Top : Node_Id;
+
+ Wrapped_Node : Node_Id;
+ -- Note: if we are in a transient scope, we want to reuse it as
+ -- the context for actions insertion, if possible. But if N is itself
+ -- part of the stored actions for the current transient scope,
+ -- then we need to insert at the appropriate (inner) location in
+ -- the not as an action on Node_To_Be_Wrapped.
+
+ In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
+
+ begin
+ -- When the node is inside a case/if expression, the lifetime of any
+ -- temporary controlled object is extended. Find a suitable insertion
+ -- node by locating the topmost case or if expressions.
+
+ if In_Cond_Expr then
+ Par := N;
+ Top := N;
+ while Present (Par) loop
+ if Nkind_In (Original_Node (Par), N_Case_Expression,
+ N_If_Expression)
+ then
+ Top := Par;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ -- The topmost case or if expression is now recovered, but it may
+ -- still not be the correct place to add generated code. Climb to
+ -- find a parent that is part of a declarative or statement list,
+ -- and is not a list of actuals in a call.
+
+ Par := Top;
+ while Present (Par) loop
+ if Is_List_Member (Par)
+ and then not Nkind_In (Par, N_Component_Association,
+ N_Discriminant_Association,
+ N_Parameter_Association,
+ N_Pragma_Argument_Association)
+ and then not Nkind_In
+ (Parent (Par), N_Function_Call,
+ N_Procedure_Call_Statement,
+ N_Entry_Call_Statement)
+
+ then
+ return Par;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return Par;
+
+ else
+ Par := N;
+ while Present (Par) loop
+
+ -- Keep climbing past various operators
+
+ if Nkind (Parent (Par)) in N_Op
+ or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
+ then
+ Par := Parent (Par);
+ else
+ exit;
+ end if;
+ end loop;
+
+ Top := Par;
+
+ -- The node may be located in a pragma in which case return the
+ -- pragma itself:
+
+ -- pragma Precondition (... and then Ctrl_Func_Call ...);
+
+ -- Similar case occurs when the node is related to an object
+ -- declaration or assignment:
+
+ -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
+
+ -- Another case to consider is when the node is part of a return
+ -- statement:
+
+ -- return ... and then Ctrl_Func_Call ...;
+
+ -- Another case is when the node acts as a formal in a procedure
+ -- call statement:
+
+ -- Proc (... and then Ctrl_Func_Call ...);
+
+ if Scope_Is_Transient then
+ Wrapped_Node := Node_To_Be_Wrapped;
+ else
+ Wrapped_Node := Empty;
+ end if;
+
+ while Present (Par) loop
+ if Par = Wrapped_Node
+ or else Nkind_In (Par, N_Assignment_Statement,
+ N_Object_Declaration,
+ N_Pragma,
+ N_Procedure_Call_Statement,
+ N_Simple_Return_Statement)
+ then
+ return Par;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ -- Return the topmost short circuit operator
+
+ return Top;
+ end if;
+ end Find_Hook_Context;
+
----------------------
-- Force_Evaluation --
----------------------
@@ -4423,7 +4562,18 @@
elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
Ren_Obj := Find_Renamed_Object (Stmt);
- if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
+ if Present (Ren_Obj)
+ and then Ren_Obj = Trans_Id
+
+ -- When the related context is an expression with actions,
+ -- both the transient controlled object and its renaming are
+ -- bound by the "scope" of the expression with actions. In
+ -- other words, the two cannot be visible outside the scope,
+ -- therefore the lifetime of the transient object is not
+ -- really extended by the renaming.
+
+ and then Nkind (Rel_Node) /= N_Expression_With_Actions
+ then
return True;
end if;
end if;
@@ -7193,9 +7343,7 @@
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
- N_Object_Declaration
- and then Is_Finalizable_Transient
- (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
+ N_Object_Declaration
then
return True;
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 212640)
+++ exp_util.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -445,6 +445,13 @@
-- Given a protected type or its corresponding record, find the type of
-- field _object.
+ function Find_Hook_Context (N : Node_Id) return Node_Id;
+ -- Determine a suitable node on which to attach actions related to N that
+ -- need to be elaborated unconditionally. In general this is the topmost
+ -- expression of which N is a subexpression, which in turn may or may not
+ -- be evaluated, for example if N is the right operand of a short circuit
+ -- operator.
+
procedure Force_Evaluation
(Exp : Node_Id;
Name_Req : Boolean := False);
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 212645)
+++ exp_ch9.adb (working copy)
@@ -29,7 +29,6 @@
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch4; use Exp_Ch4;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 212645)
+++ exp_ch4.adb (working copy)
@@ -11390,145 +11390,6 @@
Adjust_Result_Type (N, Typ);
end Expand_Short_Circuit_Operator;
- -----------------------
- -- Find_Hook_Context --
- -----------------------
-
- function Find_Hook_Context (N : Node_Id) return Node_Id is
- Par : Node_Id;
- Top : Node_Id;
-
- Wrapped_Node : Node_Id;
- -- Note: if we are in a transient scope, we want to reuse it as
- -- the context for actions insertion, if possible. But if N is itself
- -- part of the stored actions for the current transient scope,
- -- then we need to insert at the appropriate (inner) location in
- -- the not as an action on Node_To_Be_Wrapped.
-
- In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
-
- begin
- -- When the node is inside a case/if expression, the lifetime of any
- -- temporary controlled object is extended. Find a suitable insertion
- -- node by locating the topmost case or if expressions.
-
- if In_Cond_Expr then
- Par := N;
- Top := N;
- while Present (Par) loop
- if Nkind_In (Original_Node (Par), N_Case_Expression,
- N_If_Expression)
- then
- Top := Par;
-
- -- Prevent the search from going too far
-
- elsif Is_Body_Or_Package_Declaration (Par) then
- exit;
- end if;
-
- Par := Parent (Par);
- end loop;
-
- -- The topmost case or if expression is now recovered, but it may
- -- still not be the correct place to add generated code. Climb to
- -- find a parent that is part of a declarative or statement list,
- -- and is not a list of actuals in a call.
-
- Par := Top;
- while Present (Par) loop
- if Is_List_Member (Par)
- and then not Nkind_In (Par, N_Component_Association,
- N_Discriminant_Association,
- N_Parameter_Association,
- N_Pragma_Argument_Association)
- and then not Nkind_In
- (Parent (Par), N_Function_Call,
- N_Procedure_Call_Statement,
- N_Entry_Call_Statement)
-
- then
- return Par;
-
- -- Prevent the search from going too far
-
- elsif Is_Body_Or_Package_Declaration (Par) then
- exit;
- end if;
-
- Par := Parent (Par);
- end loop;
-
- return Par;
-
- else
- Par := N;
- while Present (Par) loop
-
- -- Keep climbing past various operators
-
- if Nkind (Parent (Par)) in N_Op
- or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
- then
- Par := Parent (Par);
- else
- exit;
- end if;
- end loop;
-
- Top := Par;
-
- -- The node may be located in a pragma in which case return the
- -- pragma itself:
-
- -- pragma Precondition (... and then Ctrl_Func_Call ...);
-
- -- Similar case occurs when the node is related to an object
- -- declaration or assignment:
-
- -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
-
- -- Another case to consider is when the node is part of a return
- -- statement:
-
- -- return ... and then Ctrl_Func_Call ...;
-
- -- Another case is when the node acts as a formal in a procedure
- -- call statement:
-
- -- Proc (... and then Ctrl_Func_Call ...);
-
- if Scope_Is_Transient then
- Wrapped_Node := Node_To_Be_Wrapped;
- else
- Wrapped_Node := Empty;
- end if;
-
- while Present (Par) loop
- if Par = Wrapped_Node
- or else Nkind_In (Par, N_Assignment_Statement,
- N_Object_Declaration,
- N_Pragma,
- N_Procedure_Call_Statement,
- N_Simple_Return_Statement)
- then
- return Par;
-
- -- Prevent the search from going too far
-
- elsif Is_Body_Or_Package_Declaration (Par) then
- exit;
- end if;
-
- Par := Parent (Par);
- end loop;
-
- -- Return the topmost short circuit operator
-
- return Top;
- end if;
- end Find_Hook_Context;
-
-------------------------------------
-- Fixup_Universal_Fixed_Operation --
-------------------------------------
Index: exp_ch4.ads
===================================================================
--- exp_ch4.ads (revision 212645)
+++ exp_ch4.ads (working copy)
@@ -103,11 +103,4 @@
-- have special circuitry in Expand_N_Type_Conversion to promote both of
-- the operands to type Integer.
- function Find_Hook_Context (N : Node_Id) return Node_Id;
- -- Determine a suitable node on which to attach actions related to N
- -- that need to be elaborated unconditionally (i.e. in general the topmost
- -- expression of which N is a subexpression, which may or may not be
- -- evaluated, for example if N is the right operand of a short circuit
- -- operator).
-
end Exp_Ch4;
