This patch corrects the finalization machinery to ensure that a controlled
transient result is finalized when the related context raises an exception.
------------
-- Source --
------------
-- pack.ads
with Ada.Finalization; use Ada.Finalization;
package Pack is
type Ctrl is new Controlled with record
Id : Natural;
end record;
procedure Adjust (Obj : in out Ctrl);
procedure Finalize (Obj : in out Ctrl);
procedure Initialize (Obj : in out Ctrl);
function Bomb (Val : Ctrl) return Boolean;
function Exists (Val : Ctrl) return Boolean;
function Is_Even (Val : Natural) return Boolean;
function New_Ctrl return Ctrl;
end Pack;
-- pack.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Pack is
Id_Gen : Natural := 0;
function Next_Id return Natural;
procedure Adjust (Obj : in out Ctrl) is
Old_Id : constant Natural := Obj.Id;
New_Id : constant Natural := Old_Id * 100;
begin
Put_Line (" adj" & Old_Id'Img & " ->" & New_Id'Img);
Obj.Id := New_Id;
end Adjust;
function Bomb (Val : Ctrl) return Boolean is
pragma Unreferenced (Val);
begin
raise Program_Error;
return False;
end Bomb;
function Exists (Val : Ctrl) return Boolean is
begin
return Val.Id > 0;
end Exists;
procedure Finalize (Obj : in out Ctrl) is
begin
Put_Line (" fin" & Obj.Id'Img);
Obj.Id := 0;
end Finalize;
procedure Initialize (Obj : in out Ctrl) is
begin
Obj.Id := Next_Id;
Put_Line (" ini" & Obj.Id'Img);
end Initialize;
function Is_Even (Val : Natural) return Boolean is
begin
return Val / 2 = 0;
end Is_Even;
function Next_Id return Natural is
begin
Id_Gen := Id_Gen + 1;
return Id_Gen;
end Next_Id;
function New_Ctrl return Ctrl is
Result : Ctrl;
begin
return Result;
end New_Ctrl;
end Pack;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Pack; use Pack;
procedure Main is
function Factorial (Val : Natural) return Natural is
begin
if Val > 1 then
return Factorial (Val - 1) * Val;
else
return 1;
end if;
end Factorial;
begin
Put_Line ("Normal execution");
if Is_Even (Factorial (2)) or Exists (New_Ctrl) then
Put_Line ("Normal execution -> True");
else
Put_Line ("Normal execition -> False");
end if;
Put_Line ("Exception");
begin
if Is_Even (Factorial (3)) or Bomb (New_Ctrl) then
Put_Line ("ERROR");
else
Put_Line ("ERROR");
end if;
exception
when Program_Error => null;
when others => Put_Line ("ERROR");
end;
Put_Line ("End");
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q main.adb
$ ./main
Normal execution
ini 1
adj 1 -> 100
fin 1
fin 100
Normal execution -> True
Exception
ini 2
adj 2 -> 200
fin 2
fin 200
End
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-01-20 Hristian Kirtchev <[email protected]>
* exp_ch7.adb (Is_Subprogram_Call): New routine.
(Process_Transient_Objects): Make variable Must_Hook global with
respect to all locally declared subprograms. Search the context
for at least one subprogram call.
(Requires_Hooking): Removed.
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 206805)
+++ exp_ch7.adb (working copy)
@@ -4480,33 +4480,45 @@
Last_Object : Node_Id;
Related_Node : Node_Id)
is
- function Requires_Hooking return Boolean;
- -- Determine whether the context requires transient variable export
- -- to the outer finalizer. This scenario arises when the context may
- -- raise an exception.
+ Must_Hook : Boolean := False;
+ -- Flag denoting whether the context requires transient variable
+ -- export to the outer finalizer.
- ----------------------
- -- Requires_Hooking --
- ----------------------
+ function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
+ -- Determine whether an arbitrary node denotes a subprogram call
- function Requires_Hooking return Boolean is
+ ------------------------
+ -- Is_Subprogram_Call --
+ ------------------------
+
+ function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
begin
- -- The context is either a procedure or function call or an object
- -- declaration initialized by a function call. Note that in the
- -- latter case, a function call that returns on the secondary
- -- stack is usually rewritten into something else. Its proper
- -- detection requires examination of the original initialization
- -- expression.
+ -- A regular procedure or function call
- return Nkind (N) in N_Subprogram_Call
- or else (Nkind (N) = N_Object_Declaration
- and then Nkind (Original_Node (Expression (N))) =
- N_Function_Call);
- end Requires_Hooking;
+ if Nkind (N) in N_Subprogram_Call then
+ Must_Hook := True;
+ return Abandon;
+ -- Detect a call to a function that returns on the secondary stack
+
+ elsif Nkind (N) = N_Object_Declaration
+ and then Nkind (Original_Node (Expression (N))) = N_Function_Call
+ then
+ Must_Hook := True;
+ return Abandon;
+
+ -- Keep searching
+
+ else
+ return OK;
+ end if;
+ end Is_Subprogram_Call;
+
+ procedure Detect_Subprogram_Call is
+ new Traverse_Proc (Is_Subprogram_Call);
+
-- Local variables
- Must_Hook : constant Boolean := Requires_Hooking;
Built : Boolean := False;
Desig_Typ : Entity_Id;
Fin_Block : Node_Id;
@@ -4525,6 +4537,12 @@
-- Start of processing for Process_Transient_Objects
begin
+ -- Search the context for at least one subprogram call. If found, the
+ -- machinery exports all transient objects to the enclosing finalizer
+ -- due to the possibility of abnormal call termination.
+
+ Detect_Subprogram_Call (N);
+
-- Examine all objects in the list First_Object .. Last_Object
Stmt := First_Object;
