[Ada] Abort while processing "of" container loop

[Arnaud Charlet <charlet at adacore dot com>]

This patch classifies an "of" loop parameter as never needing finalization
actions.

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

--  vectors.ads

with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with System;

generic
   type Element_Type is private;
   Small_Vector_Capacity : Natural := 0;

package Vectors is
   type Elements_Array is array (Natural) of Element_Type;
   type Elements_Array_Access is access all Elements_Array;

   function To_Pointer is
     new Ada.Unchecked_Conversion (System.Address, Elements_Array_Access);

   procedure Free is new Ada.Unchecked_Deallocation
     (Elements_Array, Elements_Array_Access);

   type Small_Array_Type
   is array (0 .. Small_Vector_Capacity - 1) of Element_Type;

   type Vector is private
     with Iterable =>
       (First       => First_Index,
        Next        => Next,
        Has_Element => Has_Element,
        Element     => Get);

   procedure Append (Self : in out Vector; Element : Element_Type);
   pragma Inline_Always (Append);

   function Get (Self : Vector; Index : Natural) return Element_Type;
   pragma Inline_Always (Get);

   procedure Destroy (Self : in out Vector);
   pragma Inline_Always (Destroy);

   procedure Clear (Self : in out Vector);
   pragma Inline_Always (Clear);

   function First_Element (Self : Vector) return Element_Type;

   function Last_Element (Self : Vector) return Element_Type;

   function Length (Self : Vector) return Natural;
   pragma Inline_Always (Length);

   function First_Index (Self : Vector) return Natural is (0);
   pragma Inline_Always (First_Index);

   function Last_Index (Self : Vector) return Integer
     is (Length (Self) - 1);
   pragma Inline_Always (Last_Index);

   function Next (Self : Vector; N : Natural) return Natural is (N + 1);
   pragma Inline_Always (Next);

   function Has_Element (Self : Vector; N : Natural) return Boolean;
   pragma Inline_Always (Has_Element);

private
   type Vector is record
      E        : Elements_Array_Access := null;
      Size     : Natural := 0;
      Capacity : Natural := Small_Vector_Capacity;
      SV       : Small_Array_Type;
   end record;

   procedure Reserve (Self : in out Vector; Capacity : Positive);
   pragma Inline_Always (Reserve);

   function Has_Element (Self : Vector; N : Natural) return Boolean
     is (N < Self.Size);
end Vectors;

--  vectors.adb

with System; use type System.Address;
use System;
with System.Memory; use System.Memory;

package body Vectors is
   El_Size : constant size_t := Elements_Array'Component_Size / Storage_Unit;

   procedure Reserve (Self : in out Vector; Capacity : Positive) is
      Siz : constant size_t :=
        size_t (Capacity) * El_Size;
   begin
      if Small_Vector_Capacity > 0 then
         if Self.Capacity = Small_Vector_Capacity then
            Self.E := To_Pointer (Alloc (Siz));
            for I in 0 .. Self.Size - 1 loop
               Self.E.all (I) := Self.SV (I);
            end loop;
         else
            Self.E := To_Pointer (Realloc (Self.E.all'Address, Siz));
         end if;
      else
         if Self.E /= null then
            Self.E := To_Pointer (Realloc (Self.E.all'Address, Siz));
         else
            Self.E := To_Pointer (Alloc (Siz));
         end if;
      end if;
      Self.Capacity := Capacity;
   end Reserve;

   procedure Append (Self : in out Vector; Element : Element_Type) is
   begin
      if Self.Capacity = Self.Size then
         Reserve (Self, (Self.Capacity * 2) + 1);
      end if;

      if Small_Vector_Capacity = 0 then
         Self.E.all (Self.Size) := Element;
      else
         if Self.Capacity = Small_Vector_Capacity then
            Self.SV (Self.Size) := Element;
         else
            Self.E.all (Self.Size) := Element;
         end if;
      end if;

      Self.Size := Self.Size + 1;
   end Append;

   function Get (Self : Vector; Index : Natural) return Element_Type is
   begin
      if Small_Vector_Capacity = 0 then
         return Self.E (Index);
      else
         if Self.Capacity = Small_Vector_Capacity then
            return Self.SV (Index);
         else
            return Self.E (Index);
         end if;
      end if;
   end Get;

   procedure Destroy (Self : in out Vector) is
   begin
      Free (Self.E);
   end Destroy;

   procedure Clear (Self : in out Vector) is
   begin
      Self.Size := 0;
   end Clear;

   function Last_Element (Self : Vector) return Element_Type
     is (Get (Self, Self.Size - 1));

   function First_Element (Self : Vector) return Element_Type
     is (Get (Self, 0));

   function Length (Self : Vector) return Natural is (Self.Size);
end Vectors;

--  ast.ads

with Vectors;

package AST is
   type AST_Node_Type is abstract tagged null record;
   type AST_Node is access all AST_Node_Type'Class;

   function Image (Node : access AST_Node_Type) return String is abstract;

   generic
      type Node_Type is abstract new AST_Node_Type with private;
      type Node_Access is access all Node_Type'Class;

   package List is
      package Node_Vectors is new Vectors
        (Element_Type => Node_Access, Small_Vector_Capacity => 1);

      type List_Type is new AST_Node_Type with record
         Vec : Node_Vectors.Vector;
      end record;

      overriding
      function Image (Node : access List_Type) return String;
   end List;
end AST;

--  ast.adb

package body AST is
   package body List is
      procedure Ignore (S : String) is
      begin
         null;
      end Ignore;

      overriding
      function Image (Node : access List_Type) return String is
      begin
         for El of Node.Vec loop
            Ignore (El.Image);
         end loop;
         return "";
      end Image;
   end List;
end AST;

-----------------
-- Compilation --
-----------------

$ gcc -c ast.adb

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

2015-10-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Process_Declarations): A loop
	parameter does not require finalization actions.

Attachment: difs
Description: Text document