[Ada] Missing finalization of generalized indexed element

[Arnaud Charlet <charlet at adacore dot com>]

This patch modifies the finalization mechanism to recognize a heavily expanded
generalized indexing where the element type requires finalization actions.

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

--  types.ads

with Ada.Finalization; use Ada.Finalization;

package Types is
   type Element is new Controlled with record
      Id : Natural := 0;
   end record;

   procedure Adjust (Obj : in out Element);
   procedure Finalize (Obj : in out Element);
   procedure Initialize (Obj : In out Element);

   subtype Index is Integer range 1 .. 3;
   type Collection is array (Index) of Element;

   type Vector is new Controlled with record
      Id       : Natural := 0;
      Elements : Collection;
   end record
     with Constant_Indexing => Element_At;

   procedure Adjust (Obj : in out Vector);
   procedure Finalize (Obj : in out Vector);
   procedure Initialize (Obj : In out Vector);

   function Element_At
     (Obj : Vector;
      Pos : Index) return Element'Class;

   function Make_Vector return Vector'Class;
end Types;

--  types.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Types is
   Id_Gen : Natural := 10;

   procedure Adjust (Obj : in out Element) is
      Old_Id : constant Natural := Obj.Id;
      New_Id : constant Natural := Old_Id + 1;

   begin
      if Old_Id = 0 then
         Put_Line ("  Element adj ERROR");
      else
         Put_Line ("  Element adj" & Old_Id'Img & " ->" & New_Id'Img);
         Obj.Id := New_Id;
      end if;
   end Adjust;

   procedure Adjust (Obj : in out Vector) is
      Old_Id : constant Natural := Obj.Id;
      New_Id : constant Natural := Old_Id + 1;

   begin
      if Old_Id = 0 then
         Put_Line ("  Vector  adj ERROR");
      else
         Put_Line ("  Vector  adj" & Old_Id'Img & " ->" & New_Id'Img);
         Obj.Id := New_Id;
      end if;
   end Adjust;

   function Element_At
     (Obj : Vector;
      Pos : Index) return Element'Class
   is
   begin
      return Obj.Elements (Pos);
   end Element_At;

   procedure Finalize (Obj : in out Element) is
   begin
      if Obj.Id = 0 then
         Put_Line ("  Element fin ERROR");
      else
         Put_Line ("  Element fin" & Obj.Id'Img);
         Obj.Id := 0;
      end if;
   end Finalize;

   procedure Finalize (Obj : in out Vector) is
   begin
      if Obj.Id = 0 then
         Put_Line ("  Vector  fin ERROR");
      else
         Put_Line ("  Vector  fin" & Obj.Id'Img);
         Obj.Id := 0;
      end if;
   end Finalize;

   procedure Initialize (Obj : In out Element) is
   begin
      Obj.Id := Id_Gen;
      Id_Gen := Id_Gen + 10;
      Put_Line ("  Element ini" & Obj.Id'Img);
   end Initialize;

   procedure Initialize (Obj : In out Vector) is
   begin
      Obj.Id := Id_Gen;
      Id_Gen := Id_Gen + 10;
      Put_Line ("  Vector  ini" & Obj.Id'Img);
   end Initialize;

   function Make_Vector return Vector'Class is
      Result : Vector;
   begin
      return Result;
   end Make_Vector;
end Types;

--  main.adb

with Ada.Text_IO; use Ada.Text_IO;
with Types;      use Types;

procedure Main is
begin
   Put_Line ("Main");

   declare
      Vec  : Vector'Class  := Make_Vector;
      Elem : Element'Class := Vec (1);
   begin
      Put_Line ("Main middle");
   end;

   Put_Line ("Main end");
end Main;

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

$ gnatmake -q main.adb
$ ./main.adb
Main
  Element ini 10
  Element ini 20
  Element ini 30
  Vector  ini 40
  Element adj 10 -> 11
  Element adj 20 -> 21
  Element adj 30 -> 31
  Vector  adj 40 -> 41
  Vector  fin 40
  Element fin 30
  Element fin 20
  Element fin 10
  Element adj 11 -> 12
  Element adj 21 -> 22
  Element adj 31 -> 32
  Vector  adj 41 -> 42
  Vector  fin 41
  Element fin 31
  Element fin 21
  Element fin 11
  Element adj 12 -> 13
  Element adj 13 -> 14
  Element fin 13
Main middle
  Element fin 14
  Vector  fin 42
  Element fin 32
  Element fin 22
  Element fin 12
Main end

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

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

	* exp_util.adb (Is_Controlled_Indexing): New routine.
	(Is_Displace_Call): Use routine Strip to remove indirections.
	(Is_Displacement_Of_Object_Or_Function_Result): Code clean up. Add a
	missing case of controlled generalized indexing.
	(Is_Source_Object): Use routine Strip to remove indirections.
	(Strip): New routine.

Attachment: difs
Description: Text document