[Ada] Missing finalization of transient result with exception

[Arnaud Charlet <charlet at adacore dot com>]

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  <kirtchev@adacore.com>

	* 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.

Attachment: difs
Description: Text document