@@ -52,6 +52,24 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
-- Resize the underlying array if needed so that it can contain one more
-- element.
+ function Elements (C : Container) return Element_Array_Access is
+ (C.Controlled_Base.Base.Elements)
+ with
+ Global => null,
+ Pre =>
+ C.Controlled_Base.Base /= null
+ and then C.Controlled_Base.Base.Elements /= null;
+
+ function Get
+ (C_E : Element_Array_Access;
+ I : Count_Type)
+ return Element_Access
+ is
+ (C_E (I).Ref.E_Access)
+ with
+ Global => null,
+ Pre => C_E /= null and then C_E (I).Ref /= null;
+
---------
-- "=" --
---------
@@ -61,9 +79,8 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
if C1.Length /= C2.Length then
return False;
end if;
-
for I in 1 .. C1.Length loop
- if C1.Base.Elements (I).all /= C2.Base.Elements (I).all then
+ if Get (Elements (C1), I).all /= Get (Elements (C2), I).all then
return False;
end if;
end loop;
@@ -78,7 +95,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
function "<=" (C1 : Container; C2 : Container) return Boolean is
begin
for I in 1 .. C1.Length loop
- if Find (C2, C1.Base.Elements (I)) = 0 then
+ if Find (C2, Get (Elements (C1), I)) = 0 then
return False;
end if;
end loop;
@@ -95,50 +112,138 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
I : Index_Type;
E : Element_Type) return Container
is
+ C_B : Array_Base_Access renames C.Controlled_Base.Base;
begin
- if To_Count (I) = C.Length + 1 and then C.Length = C.Base.Max_Length then
- Resize (C.Base);
- C.Base.Max_Length := C.Base.Max_Length + 1;
- C.Base.Elements (C.Base.Max_Length) := new Element_Type'(E);
+ if To_Count (I) = C.Length + 1 and then C.Length = C_B.Max_Length then
+ Resize (C_B);
+ C_B.Max_Length := C_B.Max_Length + 1;
+ C_B.Elements (C_B.Max_Length) := Element_Init (E);
- return Container'(Length => C.Base.Max_Length, Base => C.Base);
+ return Container'(Length => C_B.Max_Length,
+ Controlled_Base => C.Controlled_Base);
else
declare
- A : constant Array_Base_Access := Content_Init (C.Length);
+ A : constant Array_Base_Controlled_Access :=
+ Content_Init (C.Length);
P : Count_Type := 0;
begin
- A.Max_Length := C.Length + 1;
+ A.Base.Max_Length := C.Length + 1;
for J in 1 .. C.Length + 1 loop
if J /= To_Count (I) then
P := P + 1;
- A.Elements (J) := C.Base.Elements (P);
+ A.Base.Elements (J) := C_B.Elements (P);
else
- A.Elements (J) := new Element_Type'(E);
+ A.Base.Elements (J) := Element_Init (E);
end if;
end loop;
- return Container'(Length => A.Max_Length,
- Base => A);
+ return Container'(Length => A.Base.Max_Length,
+ Controlled_Base => A);
end;
end if;
end Add;
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Controlled_Base : in out Array_Base_Controlled_Access) is
+ C_B : Array_Base_Access renames Controlled_Base.Base;
+ begin
+ if C_B /= null then
+ C_B.Reference_Count := C_B.Reference_Count + 1;
+ end if;
+ end Adjust;
+
+ procedure Adjust (Ctrl_E : in out Controlled_Element_Access) is
+ begin
+ if Ctrl_E.Ref /= null then
+ Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count + 1;
+ end if;
+ end Adjust;
+
------------------
-- Content_Init --
------------------
- function Content_Init (L : Count_Type := 0) return Array_Base_Access
+ function Content_Init
+ (L : Count_Type := 0) return Array_Base_Controlled_Access
is
Max_Init : constant Count_Type := 100;
Size : constant Count_Type :=
(if L < Count_Type'Last - Max_Init then L + Max_Init
else Count_Type'Last);
+
+ -- The Access in the array will be initialized to null
+
Elements : constant Element_Array_Access :=
new Element_Array'(1 .. Size => <>);
+ B : constant Array_Base_Access :=
+ new Array_Base'(Reference_Count => 1,
+ Max_Length => 0,
+ Elements => Elements);
begin
- return new Array_Base'(Max_Length => 0, Elements => Elements);
+ return (Ada.Finalization.Controlled with Base => B);
end Content_Init;
+ ------------------
+ -- Element_Init --
+ ------------------
+
+ function Element_Init (E : Element_Type) return Controlled_Element_Access
+ is
+ Refcounted_E : constant Refcounted_Element_Access :=
+ new Refcounted_Element'(Reference_Count => 1,
+ E_Access => new Element_Type'(E));
+ begin
+ return (Ada.Finalization.Controlled with Ref => Refcounted_E);
+ end Element_Init;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Controlled_Base : in out Array_Base_Controlled_Access)
+ is
+ procedure Unchecked_Free_Base is new Ada.Unchecked_Deallocation
+ (Object => Array_Base,
+ Name => Array_Base_Access);
+ procedure Unchecked_Free_Array is new Ada.Unchecked_Deallocation
+ (Object => Element_Array,
+ Name => Element_Array_Access);
+
+ C_B : Array_Base_Access renames Controlled_Base.Base;
+ begin
+ if C_B /= null then
+ C_B.Reference_Count := C_B.Reference_Count - 1;
+ if C_B.Reference_Count = 0 then
+ Unchecked_Free_Array (Controlled_Base.Base.Elements);
+ Unchecked_Free_Base (Controlled_Base.Base);
+ end if;
+ C_B := null;
+ end if;
+ end Finalize;
+
+ procedure Finalize (Ctrl_E : in out Controlled_Element_Access) is
+ procedure Unchecked_Free_Ref is new Ada.Unchecked_Deallocation
+ (Object => Refcounted_Element,
+ Name => Refcounted_Element_Access);
+
+ procedure Unchecked_Free_Element is new Ada.Unchecked_Deallocation
+ (Object => Element_Type,
+ Name => Element_Access);
+
+ begin
+ if Ctrl_E.Ref /= null then
+ Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count - 1;
+ if Ctrl_E.Ref.Reference_Count = 0 then
+ Unchecked_Free_Element (Ctrl_E.Ref.E_Access);
+ Unchecked_Free_Ref (Ctrl_E.Ref);
+ end if;
+ Ctrl_E.Ref := null;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
@@ -146,7 +251,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
function Find (C : Container; E : access Element_Type) return Count_Type is
begin
for I in 1 .. C.Length loop
- if C.Base.Elements (I).all = E.all then
+ if Get (Elements (C), I).all = E.all then
return I;
end if;
end loop;
@@ -162,7 +267,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
---------
function Get (C : Container; I : Index_Type) return Element_Type is
- (C.Base.Elements (To_Count (I)).all);
+ (Get (Elements (C), To_Count (I)).all);
------------------
-- Intersection --
@@ -170,19 +275,19 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
function Intersection (C1 : Container; C2 : Container) return Container is
L : constant Count_Type := Num_Overlaps (C1, C2);
- A : constant Array_Base_Access := Content_Init (L);
+ A : constant Array_Base_Controlled_Access := Content_Init (L);
P : Count_Type := 0;
begin
- A.Max_Length := L;
+ A.Base.Max_Length := L;
for I in 1 .. C1.Length loop
- if Find (C2, C1.Base.Elements (I)) > 0 then
+ if Find (C2, Get (Elements (C1), I)) > 0 then
P := P + 1;
- A.Elements (P) := C1.Base.Elements (I);
+ A.Base.Elements (P) := Elements (C1) (I);
end if;
end loop;
- return Container'(Length => P, Base => A);
+ return Container'(Length => P, Controlled_Base => A);
end Intersection;
------------
@@ -199,7 +304,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
begin
for I in 1 .. C1.Length loop
- if Find (C2, C1.Base.Elements (I)) > 0 then
+ if Find (C2, Get (Elements (C1), I)) > 0 then
P := P + 1;
end if;
end loop;
@@ -214,21 +319,23 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
function Remove (C : Container; I : Index_Type) return Container is
begin
if To_Count (I) = C.Length then
- return Container'(Length => C.Length - 1, Base => C.Base);
+ return Container'(Length => C.Length - 1,
+ Controlled_Base => C.Controlled_Base);
else
declare
- A : constant Array_Base_Access := Content_Init (C.Length - 1);
+ A : constant Array_Base_Controlled_Access
+ := Content_Init (C.Length - 1);
P : Count_Type := 0;
begin
- A.Max_Length := C.Length - 1;
+ A.Base.Max_Length := C.Length - 1;
for J in 1 .. C.Length loop
if J /= To_Count (I) then
P := P + 1;
- A.Elements (P) := C.Base.Elements (J);
+ A.Base.Elements (P) := Elements (C) (J);
end if;
end loop;
- return Container'(Length => C.Length - 1, Base => A);
+ return Container'(Length => C.Length - 1, Controlled_Base => A);
end;
end if;
end Remove;
@@ -277,13 +384,14 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
E : Element_Type) return Container
is
Result : constant Container :=
- Container'(Length => C.Length,
- Base => Content_Init (C.Length));
+ Container'(Length => C.Length,
+ Controlled_Base => Content_Init (C.Length));
+ R_Base : Array_Base_Access renames Result.Controlled_Base.Base;
begin
- Result.Base.Max_Length := C.Length;
- Result.Base.Elements (1 .. C.Length) := C.Base.Elements (1 .. C.Length);
- Result.Base.Elements (To_Count (I)) := new Element_Type'(E);
+ R_Base.Max_Length := C.Length;
+ R_Base.Elements (1 .. C.Length) := Elements (C) (1 .. C.Length);
+ R_Base.Elements (To_Count (I)) := Element_Init (E);
return Result;
end Set;
@@ -305,20 +413,19 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
declare
L : constant Count_Type := Length (C1) - N + Length (C2);
- A : constant Array_Base_Access := Content_Init (L);
+ A : constant Array_Base_Controlled_Access := Content_Init (L);
P : Count_Type := Length (C1);
-
begin
- A.Max_Length := L;
- A.Elements (1 .. C1.Length) := C1.Base.Elements (1 .. C1.Length);
+ A.Base.Max_Length := L;
+ A.Base.Elements (1 .. C1.Length) := Elements (C1) (1 .. C1.Length);
for I in 1 .. C2.Length loop
- if Find (C1, C2.Base.Elements (I)) = 0 then
+ if Find (C1, Get (Elements (C2), I)) = 0 then
P := P + 1;
- A.Elements (P) := C2.Base.Elements (I);
+ A.Base.Elements (P) := Elements (C2) (I);
end if;
end loop;
- return Container'(Length => L, Base => A);
+ return Container'(Length => L, Controlled_Base => A);
end;
end Union;
@@ -34,6 +34,10 @@
pragma Ada_2012;
+-- To allow reference counting on the base container
+
+private with Ada.Finalization;
+
private generic
type Index_Type is (<>);
-- To avoid Constraint_Error being raised at run time, Index_Type'Base
@@ -98,33 +102,97 @@ package Ada.Containers.Functional_Base with SPARK_Mode => Off is
private
+ -- Theoretically, each operation on a functional container implies the
+ -- creation of a new container i.e. the copy of the array itself and all
+ -- the elements in it. In the implementation, most of these copies are
+ -- avoided by sharing between the containers.
+ --
+ -- A container stores its last used index. So, when adding an
+ -- element at the end of the container, the exact same array can be reused.
+ -- As a functionnal container cannot be modifed once created, there is no
+ -- risk of unwanted modifications.
+ --
+ -- _1_2_3_
+ -- S : end => [1, 2, 3]
+ -- |
+ -- |1|2|3|4|.|.|
+ -- |
+ -- Add (S, 4, 4) : end => [1, 2, 3, 4]
+ --
+ -- The elements are also shared between containers as much as possible. For
+ -- example, when something is added in the middle, the array is changed but
+ -- the elementes are reused.
+ --
+ -- _1_2_3_4_
+ -- S : |1|2|3|4| => [1, 2, 3, 4]
+ -- | \ \ \
+ -- Add (S, 2, 5) : |1|5|2|3|4| => [1, 5, 2, 3, 4]
+ --
+ -- To make this sharing possible, both the elements and the arrays are
+ -- stored inside dynamically allocated access types which shall be
+ -- deallocated when they are no longer used. The memory is managed using
+ -- reference counting both at the array and at the element level.
+
subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
+ type Reference_Count_Type is new Natural;
+
type Element_Access is access all Element_Type;
+ type Refcounted_Element is record
+ Reference_Count : Reference_Count_Type;
+ E_Access : Element_Access;
+ end record;
+
+ type Refcounted_Element_Access is access Refcounted_Element;
+
+ type Controlled_Element_Access is new Ada.Finalization.Controlled
+ with record
+ Ref : Refcounted_Element_Access := null;
+ end record;
+
+ function Element_Init (E : Element_Type) return Controlled_Element_Access;
+ -- Use to initialize a refcounted element
+
type Element_Array is
- array (Positive_Count_Type range <>) of Element_Access;
+ array (Positive_Count_Type range <>) of Controlled_Element_Access;
type Element_Array_Access_Base is access Element_Array;
- subtype Element_Array_Access is not null Element_Array_Access_Base;
-
- Empty_Element_Array_Access : constant Element_Array_Access :=
- new Element_Array'(1 .. 0 => null);
+ subtype Element_Array_Access is Element_Array_Access_Base;
type Array_Base is record
- Max_Length : Count_Type;
- Elements : Element_Array_Access;
+ Reference_Count : Reference_Count_Type;
+ Max_Length : Count_Type;
+ Elements : Element_Array_Access;
+ end record;
+
+ type Array_Base_Access is access Array_Base;
+
+ type Array_Base_Controlled_Access is new Ada.Finalization.Controlled
+ with record
+ Base : Array_Base_Access;
end record;
- type Array_Base_Access is not null access Array_Base;
+ overriding procedure Adjust
+ (Controlled_Base : in out Array_Base_Controlled_Access);
+
+ overriding procedure Finalize
+ (Controlled_Base : in out Array_Base_Controlled_Access);
+
+ overriding procedure Adjust
+ (Ctrl_E : in out Controlled_Element_Access);
+
+ overriding procedure Finalize
+ (Ctrl_E : in out Controlled_Element_Access);
- function Content_Init (L : Count_Type := 0) return Array_Base_Access;
+ function Content_Init (L : Count_Type := 0)
+ return Array_Base_Controlled_Access;
-- Used to initialize the content of an array base with length L
type Container is record
- Length : Count_Type := 0;
- Base : Array_Base_Access := Content_Init;
+ Length : Count_Type := 0;
+ Controlled_Base : Array_Base_Controlled_Access := Content_Init;
end record;
end Ada.Containers.Functional_Base;