[Ada] Missing finalization call of interface class-wide object

[Arnaud Charlet <charlet at adacore dot com>]

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

	* exp_util.adb (Initialized_By_Ctrl_Function): Add code to
	process the case when a function call appears in object.operation
	format.

Attachment: difs
Description: Text document