[Ada] Missing finalization of cursor in "of" iterator loop

[Arnaud Charlet <charlet at adacore dot com>]

This patch modifies the finalization machinery to ensure that the cursor of an
"of" iterator loop is properly finalized at the end of the loop. Previously it
was incorrectly assumed that such a cursor will never need finalization
ctions.

------------
-- Source --
------------

--  leak.adb

pragma Warnings (Off);

with Ada.Unchecked_Deallocation;
with Ada.Finalization;
with Ada.Iterator_Interfaces;
with Ada.Text_IO; use Ada.Text_IO;

procedure Leak is
   type El is tagged null record;

   type Integer_Access is access all Integer;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Integer, Integer_Access);

   type Cursor is new Ada.Finalization.Controlled with record
      Count : Integer_Access := new Integer'(1);
   end record;

   overriding procedure Adjust (C : in out Cursor);
   overriding procedure Finalize (C : in out Cursor);

   overriding procedure Adjust (C : in out Cursor) is
   begin
      C.Count.all := C.Count.all + 1;
      Put_Line ("Adjust   Cursor.   Count = " & C.Count.all'Img);
   end Adjust;

   overriding procedure Finalize (C : in out Cursor) is
   begin
      C.Count.all := C.Count.all - 1;
      Put_Line ("Finalize Cursor.   Count = " & C.Count.all'Img);
      if C.Count.all = 0 then
         Unchecked_Free (C.Count);
      end if;
   end Finalize;

   function Has_Element (C : Cursor) return Boolean is (False);

   package Child is
      package Iterators is new Ada.Iterator_Interfaces
        (Cursor       => Cursor,
         Has_Element  => Has_Element);

      type Iterator is
        new Ada.Finalization.Controlled
          and Iterators.Forward_Iterator
      with record
         Count : Integer_Access := new Integer'(1);
      end record;

      overriding function First (I : Iterator) return Cursor
      is (Ada.Finalization.Controlled with others => <>);

      overriding function Next (I : Iterator; C : Cursor) return Cursor
      is (Ada.Finalization.Controlled with others => <>);

      overriding procedure Adjust (I : in out Iterator);

      end Child;

   package body Child is
      overriding procedure Adjust (I : in out Iterator) is
      begin
         I.Count.all := I.Count.all + 1;
         Put_Line ("Adjust   Iterator. Count = " & I.Count.all'Img);
      end Adjust;

      overriding procedure Finalize (I : in out Iterator) is
      begin
         I.Count.all := I.Count.all - 1;
         Put_Line ("Finalize Iterator. Count = " & I.Count.all'Img);
         if I.Count.all = 0 then
            Unchecked_Free (I.Count);
         end if;
      end Finalize;
   end Child;

   type Iterable is tagged null record
     with Default_Iterator  => Iterate,
          Iterator_Element  => El'Class,
          Constant_Indexing => El_At;

   function Iterate
     (O : Iterable) return Child.Iterators.Forward_Iterator'Class
   is (Child.Iterator'(Ada.Finalization.Controlled with others => <>));

   function El_At (Self : Iterable; Pos : Cursor'Class) return El'Class
   is (El'(others => <>));

   Seq : Iterable;

begin
   Put_Line ("START");
   for V of Seq loop
      null;
   end loop;
   Put_Line ("END");
end Leak;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q leak.adb -largs -lgmem
$ ./leak
$ gnatmem ./leak > leaks.txt
$ grep -c "Number of non freed allocations" leaks.txt
START
Adjust   Iterator. Count =  2
Finalize Iterator. Count =  1
Adjust   Cursor.   Count =  2
Finalize Cursor.   Count =  1
Adjust   Cursor.   Count =  2
Finalize Cursor.   Count =  1
Finalize Cursor.   Count =  0
Finalize Iterator. Count =  0
END
0

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

2017-09-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.adb (Status_Flag_Or_Transient_Decl): The attribute is now
	allowed on loop parameters.
	(Set_Status_Flag_Or_Transient_Decl): The attribute is now allowed
	on loop parameters.
	(Write_Field15_Name): Update the output for
	Status_Flag_Or_Transient_Decl.
	* einfo.ads: Attribute Status_Flag_Or_Transient_Decl now applies
	to loop parameters. Update the documentation of the attribute
	and the E_Loop_Parameter entity.
	* exp_ch7.adb (Process_Declarations): Remove the bogus guard
	which assumes that cursors can never be controlled.
	* exp_util.adb (Requires_Cleanup_Actions): Remove the bogus
	guard which assumes that cursors can never be controlled.

Attachment: difs
Description: Text document