[Ada] Intermediate build-in-place result not finalized

Message ID 20100910151140.GA12264@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Sept. 10, 2010, 3:11 p.m.
This patch ensures that intermediate results of limited controlled function
calls are finalized after their respective master is left. Example:

with Ada.Finalization; use Ada.Finalization;
with Ada.Text_IO;      use Ada.Text_IO;

procedure Test1 is
   type Lim_Rec is new Limited_Controlled with record
      Component : Natural := 123;
   end record;

   procedure Finalize (Obj : in out Lim_Rec) is
      Put_Line ("Component =" & Obj.Component'Img);
   end Finalize;

   function New_Lim_Rec return Lim_Rec is
      return Result : Lim_Rec do
         Result.Component := 456;
      end return;
   end New_Lim_Rec;

   Value : Natural;

   Put_Line ("Before master");
   Value := New_Lim_Rec.Component;
   Put_Line ("After master");

end Test1;

Compilation and execution:

gnatmake -gnat05 test1.adb
Before master
Component = 456
After master

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-09-10  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb, exp_ch6.adb (Expand_Call): Establish a transient scope
	for a controlled build-in-place function call which appears in an
	anonymous context. The transient scope ensures that the intermediate
	function result is cleaned up after the master is left.
	(Make_Build_In_Place_Call_In_Anonymous_Context): Remove the creation
	of the transient scope. This is now done in Exand_Call which covers
	additional cases other than secondary stack release.


Index: exp_ch6.adb
--- exp_ch6.adb	(revision 164171)
+++ exp_ch6.adb	(working copy)
@@ -3100,14 +3100,30 @@  package body Exp_Ch6 is
       --  To prevent a double attachment, check that the current call is
       --  not a rewriting of a protected function call.
-      if Needs_Finalization (Etype (Subp))
-        and then not Is_Inherently_Limited_Type (Etype (Subp))
-        and then
-          (No (First_Formal (Subp))
-            or else
-              not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
-      then
-         Expand_Ctrl_Function_Call (N);
+      if Needs_Finalization (Etype (Subp)) then
+         if not Is_Inherently_Limited_Type (Etype (Subp))
+           and then
+             (No (First_Formal (Subp))
+                or else
+                  not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
+         then
+            Expand_Ctrl_Function_Call (N);
+         --  Build-in-place function calls which appear in anonymous contexts
+         --  need a transient scope to ensure the proper finalization of the
+         --  intermediate result after its use.
+         elsif Is_Build_In_Place_Function_Call (N)
+           and then Nkind_In (Parent (N), N_Attribute_Reference,
+                                          N_Function_Call,
+                                          N_Indexed_Component,
+                                          N_Object_Renaming_Declaration,
+                                          N_Procedure_Call_Statement,
+                                          N_Selected_Component,
+                                          N_Slice)
+         then
+            Establish_Transient_Scope (N, Sec_Stack => True);
+         end if;
       end if;
       --  Test for First_Optional_Parameter, and if so, truncate parameter list
@@ -5336,7 +5352,6 @@  package body Exp_Ch6 is
       --  scope is established to ensure eventual cleanup of the result.
          --  Pass an allocation parameter indicating that the function should
          --  allocate its result on the secondary stack.
@@ -5354,8 +5369,6 @@  package body Exp_Ch6 is
            (Func_Call, Function_Id, Empty);
-         Establish_Transient_Scope (Func_Call, Sec_Stack => True);
       end if;
    end Make_Build_In_Place_Call_In_Anonymous_Context;
Index: exp_ch7.adb
--- exp_ch7.adb	(revision 164167)
+++ exp_ch7.adb	(working copy)
@@ -1098,7 +1098,7 @@  package body Exp_Ch7 is
       --  releasing or some finalizations are needed or in the context
       --  of tasking
-      if Uses_Sec_Stack  (Current_Scope)
+      if Uses_Sec_Stack (Current_Scope)
         and then not Sec_Stack_Needed_For_Return (Current_Scope)