This patch corrects the code which detects whether an interface class-wide
object has been initialized by a controlled function call.
------------
-- Source --
------------
-- element.ads
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Holders;
package Element is
type I_Interface is interface;
procedure Add (I : in out I_Interface) is abstract;
function "=" (Left, Right : I_Interface) return Boolean is abstract;
procedure Clear (Self : in out I_Interface'Class);
package Interface_Holder is new Ada.Containers.Indefinite_Holders
(Element_Type => I_Interface'Class,
"=" => "=");
function Create return I_Interface'Class;
type T_Abstract_Element is abstract tagged null record;
function "=" (Left, Right : T_Abstract_Element) return Boolean;
type T_Concrete_Element is new T_Abstract_Element with null record;
package Element_Collection is
new Ada.Containers.Indefinite_Doubly_Linked_Lists
(Element_Type => T_Abstract_Element'Class);
type T_Class is new I_Interface with record
Attributs : Element_Collection.List;
end record;
overriding procedure Add (I : in out T_Class);
overriding function "=" (Left, Right : T_Class) return Boolean is (True);
end Element;
-- element.adb
package body Element is
function Create return I_Interface'Class is
begin
return T_Class'(Attributs => Element_Collection.Empty_List);
end Create;
overriding procedure Add (I : in out T_Class) is
begin
I.Attributs.Append (T_Concrete_Element'(null record));
end Add;
function "=" (Left, Right : T_Abstract_Element) return Boolean is
begin
return False;
end "=";
procedure Clear (Self : in out I_Interface'Class) is
Elmt : T_Class := T_Class (Self);
begin
Elmt.Attributs.Clear;
end Clear;
end Element;
-- main.adb
with Element; use type Element.I_Interface;
procedure Main is
Holder : Element.Interface_Holder.Holder :=
Element.Interface_Holder.To_Holder (Element.Create);
begin
for I in 1 .. 100 loop
declare
Object : Element.I_Interface'Class := Holder.Element;
begin
Object.Add;
Holder.Replace_Element (Object);
end;
end loop;
end Main;
-------------------------------------
-- Compilation and expected output --
-------------------------------------
$ gnatmake -q -gnat12 main.adb -largs -lgmem
$ ./main
$ gnatmem ./main
$ Global information
$ ------------------
$ Total number of allocations :30203
$ Total number of deallocations :30203
$ Final Water Mark (non freed mem) : 0 Bytes
$ High Water Mark : 13.98 Kilobytes
Tested on x86_64-pc-linux-gnu, committed on trunk
2012-03-15 Hristian Kirtchev <kirtc...@adacore.com>
* exp_util.adb (Initialized_By_Ctrl_Function): Add code to
process the case when a function call appears in object.operation
format.
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 185390)
+++ exp_util.adb (working copy)
@@ -3960,11 +3960,28 @@
----------------------------------
function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean is
- Expr : constant Node_Id := Original_Node (Expression (N));
+ Expr : Node_Id := Original_Node (Expression (N));
+
begin
+ if Nkind (Expr) = N_Function_Call then
+ Expr := Name (Expr);
+ end if;
+
+ -- The function call may appear in object.operation format. Strip
+ -- all prefixes and retrieve the function name.
+
+ loop
+ if Nkind (Expr) = N_Selected_Component then
+ Expr := Selector_Name (Expr);
+ else
+ exit;
+ end if;
+ end loop;
+
return
- Nkind (Expr) = N_Function_Call
- and then Needs_Finalization (Etype (Expr));
+ Nkind_In (Expr, N_Expanded_Name, N_Identifier)
+ and then Ekind (Entity (Expr)) = E_Function
+ and then Needs_Finalization (Etype (Entity (Expr)));
end Initialized_By_Ctrl_Function;
----------------------
