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 <kirtc...@adacore.com>
* exp_ch7.adb (Process_Declarations): A loop
parameter does not require finalization actions.
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 229049)
+++ exp_ch7.adb (working copy)
@@ -1837,6 +1837,15 @@
elsif Is_Ignored_Ghost_Entity (Obj_Id) then
null;
+ -- The expansion of iterator loops generates an object
+ -- declaration where the Ekind is explicitly set to loop
+ -- parameter. This is to ensure that the loop parameter behaves
+ -- as a constant from user code point of view. Such object are
+ -- never controlled and do not require finalization.
+
+ elsif Ekind (Obj_Id) = E_Loop_Parameter then
+ null;
+
-- The object is of the form:
-- Obj : Typ [:= Expr];
