This patch corrects the mechanism which determines whether a construct appears
at the library level. This in turn allows for proper detection of cases where
a Finalize_Storage_Only object appears in a nested scope and requires
finalization.
------------
-- Source --
------------
-- main.adb
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
procedure Main is
generic
package Memory_File is
File : Unbounded_String;
procedure Add_String (S : String);
procedure Add_New_Line;
end Memory_File;
package body Memory_File is
procedure Add_String (S : String) is
begin
Append (File, S);
end Add_String;
procedure Add_New_Line is
begin
Add_String (ASCII.CR & ASCII.LF);
end Add_New_Line;
end Memory_File;
function Leak return String is
package Mem is new Memory_File;
use Mem;
begin
Add_String ("This is a test");
Add_New_Line;
return To_String (File);
end Leak;
begin
for Index in 1 .. 100 loop
declare
Result : String := Leak;
pragma Warnings (Off, Result);
begin
null;
end;
end loop;
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q main.adb -largs -lgmem
$ ./main
$ gnatmem ./main
$ Global information
$ ------------------
$ Total number of allocations : 100
$ Total number of deallocations : 100
$ Final Water Mark (non freed mem) : 0 Bytes
$ High Water Mark : 48 Bytes
Tested on x86_64-pc-linux-gnu, committed on trunk
2012-04-26 Hristian Kirtchev <kirtc...@adacore.com>
* exp_ch7.adb (Expand_Cleanup_Actions): Update the call to
Requires_Cleanup_Actions.
* exp_util.adb (Requires_Cleanup_Actions (List_Id; Boolean;
Boolean)): Rename formal parameter For_Package to Lib_Level to
better reflect its purpose. Update the related comment and all
occurrences of For_Package in the body.
(Requires_Cleanup_Actions
(Node_Id; Boolean)): Add new formal parameter Lib_Level. Add
local constant At_Lib_Level to keep monitor whether the path
taken from the top-most context to the current construct involves
package constructs. Update all calls to Requires_Cleanup_Actions.
* exp_util.ads (Requires_Cleanup_Actions): Add new formal
parameter Lib_Level and associated comment.
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 186860)
+++ exp_ch7.adb (working copy)
@@ -3599,7 +3599,7 @@
and then VM_Target = No_VM;
Actions_Required : constant Boolean :=
- Requires_Cleanup_Actions (N)
+ Requires_Cleanup_Actions (N, True)
or else Is_Asynchronous_Call
or else Is_Master
or else Is_Protected_Body
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 186860)
+++ exp_util.adb (working copy)
@@ -150,16 +150,16 @@
function Requires_Cleanup_Actions
(L : List_Id;
- For_Package : Boolean;
+ Lib_Level : Boolean;
Nested_Constructs : Boolean) return Boolean;
-- Given a list L, determine whether it contains one of the following:
--
-- 1) controlled objects
-- 2) library-level tagged types
--
- -- Flag For_Package should be set when the list comes from a package spec
- -- or body. Flag Nested_Constructs should be set when any nested packages
- -- declared in L must be processed.
+ -- Flag Lib_Level should be set when the list comes from a construct at
+ -- the library level. Flag Nested_Constructs should be set when any nested
+ -- packages declared in L must be processed.
-------------------------------------
-- Activate_Atomic_Synchronization --
@@ -7038,9 +7038,14 @@
-- Requires_Cleanup_Actions --
------------------------------
- function Requires_Cleanup_Actions (N : Node_Id) return Boolean is
- For_Pkg : constant Boolean :=
- Nkind_In (N, N_Package_Body, N_Package_Specification);
+ function Requires_Cleanup_Actions
+ (N : Node_Id;
+ Lib_Level : Boolean) return Boolean
+ is
+ At_Lib_Level : constant Boolean := Lib_Level and then
+ Nkind_In (N, N_Package_Body, N_Package_Specification);
+ -- N is at the library level if the top-most context is a package and
+ -- the path taken to reach N does not inlcude non-package constructs.
begin
case Nkind (N) is
@@ -7052,20 +7057,20 @@
N_Subprogram_Body |
N_Task_Body =>
return
- Requires_Cleanup_Actions (Declarations (N), For_Pkg, True)
+ Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
or else
(Present (Handled_Statement_Sequence (N))
and then
Requires_Cleanup_Actions (Statements
- (Handled_Statement_Sequence (N)), For_Pkg, True));
+ (Handled_Statement_Sequence (N)), At_Lib_Level, True));
when N_Package_Specification =>
return
Requires_Cleanup_Actions
- (Visible_Declarations (N), For_Pkg, True)
+ (Visible_Declarations (N), At_Lib_Level, True)
or else
Requires_Cleanup_Actions
- (Private_Declarations (N), For_Pkg, True);
+ (Private_Declarations (N), At_Lib_Level, True);
when others =>
return False;
@@ -7078,7 +7083,7 @@
function Requires_Cleanup_Actions
(L : List_Id;
- For_Package : Boolean;
+ Lib_Level : Boolean;
Nested_Constructs : Boolean) return Boolean
is
Decl : Node_Id;
@@ -7125,9 +7130,7 @@
-- finalization disabled. This applies only to objects at the
-- library level.
- if For_Package
- and then Finalize_Storage_Only (Obj_Typ)
- then
+ if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
null;
-- Transient variables are treated separately in order to minimize
@@ -7203,9 +7206,7 @@
-- finalization disabled. This applies only to objects at the
-- library level.
- if For_Package
- and then Finalize_Storage_Only (Obj_Typ)
- then
+ if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
null;
-- Return object of a build-in-place function. This case is
@@ -7257,7 +7258,7 @@
(Is_Type (Typ)
and then Needs_Finalization (Typ)))
and then Requires_Cleanup_Actions
- (Actions (Decl), For_Package, Nested_Constructs)
+ (Actions (Decl), Lib_Level, Nested_Constructs)
then
return True;
end if;
@@ -7274,7 +7275,8 @@
end if;
if Ekind (Pack_Id) /= E_Generic_Package
- and then Requires_Cleanup_Actions (Specification (Decl))
+ and then Requires_Cleanup_Actions
+ (Specification (Decl), Lib_Level)
then
return True;
end if;
@@ -7287,7 +7289,7 @@
Pack_Id := Corresponding_Spec (Decl);
if Ekind (Pack_Id) /= E_Generic_Package
- and then Requires_Cleanup_Actions (Decl)
+ and then Requires_Cleanup_Actions (Decl, Lib_Level)
then
return True;
end if;
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 186860)
+++ exp_util.ads (working copy)
@@ -744,14 +744,17 @@
-- terms is scalar. This is true for scalars in the Ada sense, and for
-- packed arrays which are represented by a scalar (modular) type.
- function Requires_Cleanup_Actions (N : Node_Id) return Boolean;
+ function Requires_Cleanup_Actions
+ (N : Node_Id;
+ Lib_Level : Boolean) return Boolean;
-- Given a node N, determine whether its declarative and/or statement list
-- contains one of the following:
--
-- 1) controlled objects
-- 2) library-level tagged types
--
- -- The above cases require special actions on scope exit.
+ -- The above cases require special actions on scope exit. Flag Lib_Level
+ -- is used to track whether a construct is at the library level.
function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean;
-- Given the node for an N_Unchecked_Type_Conversion, return True if this
