Index: natools.gpr ================================================================== --- natools.gpr +++ natools.gpr @@ -1,10 +1,10 @@ project Natools is type Build_Type is ("Release", "Coverage"); Mode : Build_Type := external ("MODE", "Release"); - type Task_Safety is ("None"); + type Task_Safety is ("None", "Portable"); Safety : Task_Safety := external ("TASK_SAFETY", "None"); Prefix := ""; Extra_Switches := (); @@ -72,8 +72,13 @@ when "None" => for spec ("Natools.References") use "natools-references__unsafe.ads"; for body ("Natools.References") use "natools-references__unsafe.adb"; + when "Portable" => + for spec ("Natools.References") + use "natools-references__protected.ads"; + for body ("Natools.References") + use "natools-references__protected.adb"; end case; end Naming; end Natools; ADDED src/natools-references__protected.adb Index: src/natools-references__protected.adb ================================================================== --- src/natools-references__protected.adb +++ src/natools-references__protected.adb @@ -0,0 +1,180 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013-2014, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body Natools.References is + + --------------------------------- + -- Low-level memory management -- + --------------------------------- + + overriding procedure Adjust (Object : in out Immutable_Reference) is + begin + if Object.Count /= null then + Object.Count.Increment; + end if; + end Adjust; + + + overriding procedure Finalize (Object : in out Immutable_Reference) is + procedure Free is + new Ada.Unchecked_Deallocation (Held_Data, Data_Access); + procedure Free is + new Ada.Unchecked_Deallocation (Counter, Counter_Access); + + Deallocate : Boolean; + begin + if Object.Count /= null then + Object.Count.Decrement (Deallocate); + + if Deallocate then + Free (Object.Count); + Free (Object.Data); + else + Object.Count := null; + Object.Data := null; + end if; + end if; + end Finalize; + + + + ----------------------------------------- + -- Object construction and destruction -- + ----------------------------------------- + + function Create + (Constructor : not null access function return Held_Data) + return Immutable_Reference is + begin + return (Ada.Finalization.Controlled with + Data => new Held_Data'(Constructor.all), + Count => new Counter); + end Create; + + + procedure Replace + (Ref : in out Immutable_Reference; + Constructor : not null access function return Held_Data) is + begin + Finalize (Ref); + Ref.Data := new Held_Data'(Constructor.all); + Ref.Count := new Counter; + end Replace; + + + function Create (Data : in Data_Access) return Immutable_Reference is + begin + if Data = null then + return Null_Immutable_Reference; + else + return (Ada.Finalization.Controlled with + Data => Data, + Count => new Counter); + end if; + end Create; + + + procedure Replace + (Ref : in out Immutable_Reference; + Data : in Data_Access) is + begin + Finalize (Ref); + + if Data /= null then + Ref.Data := Data; + Ref.Count := new Counter; + end if; + end Replace; + + + procedure Reset (Ref : in out Immutable_Reference) is + begin + Finalize (Ref); + end Reset; + + + function Is_Empty (Ref : Immutable_Reference) return Boolean is + begin + return Ref.Count = null; + end Is_Empty; + + + function "=" (Left, Right : Immutable_Reference) return Boolean is + begin + return Left.Data = Right.Data; + end "="; + + + + ---------------------- + -- Dereferenciation -- + ---------------------- + + function Query (Ref : in Immutable_Reference) return Accessor is + begin + return Accessor'(Data => Ref.Data, Parent => Ref); + end Query; + + + function Update (Ref : in Reference) return Mutator is + begin + return Mutator'(Data => Ref.Data, Parent => Ref); + end Update; + + + procedure Query + (Ref : in Immutable_Reference; + Process : not null access procedure (Object : in Held_Data)) is + begin + Process.all (Ref.Data.all); + end Query; + + + procedure Update + (Ref : in Reference; + Process : not null access procedure (Object : in out Held_Data)) is + begin + Process.all (Ref.Data.all); + end Update; + + + + ------------------------ + -- Counter Management -- + ------------------------ + + protected body Counter is + procedure Increment is + begin + Value := Value + 1; + end Increment; + + procedure Decrement (Zero : out Boolean) is + begin + Value := Value - 1; + Zero := Value = 0; + end Decrement; + + function Get_Value return Natural is + begin + return Value; + end Get_Value; + end Counter; + +end Natools.References; + ADDED src/natools-references__protected.ads Index: src/natools-references__protected.ads ================================================================== --- src/natools-references__protected.ads +++ src/natools-references__protected.ads @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013-2014, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.References implements reference-counted smart pointer to any -- +-- type of objects. -- +-- This is a basic implementation that does not support weak references, -- +-- but uses protected counters to ensure task safe operations. -- +-- Beware though that there is still no guarantee on the task-safety of the -- +-- operations performed on the referred objects. -- +------------------------------------------------------------------------------ + +with Ada.Finalization; +with System.Storage_Pools; + +generic + type Held_Data (<>) is limited private; + Counter_Pool : in out System.Storage_Pools.Root_Storage_Pool'Class; + Data_Pool : in out System.Storage_Pools.Root_Storage_Pool'Class; + +package Natools.References is + pragma Preelaborate (References); + + type Accessor (Data : not null access constant Held_Data) is + limited private; + type Mutator (Data : not null access Held_Data) is + limited private; + + type Data_Access is access Held_Data; + for Data_Access'Storage_Pool use Data_Pool; + + + type Immutable_Reference is new Ada.Finalization.Controlled with private; + + function Create + (Constructor : not null access function return Held_Data) + return Immutable_Reference; + -- Create a new held object and return a reference to it + + procedure Replace + (Ref : in out Immutable_Reference; + Constructor : not null access function return Held_Data); + -- Replace the object held in Ref with a newly created object + + function Create (Data : in Data_Access) return Immutable_Reference; + -- Create a new reference from Data. + -- From this point the referred object is owned by this + -- package and must NOT be freed or changed or accessed. + + procedure Replace (Ref : in out Immutable_Reference; Data : in Data_Access); + -- Integrate Data into Ref. + -- From this point the referred object is owned by this + -- package and must NOT be freed or changed or accessed. + + procedure Reset (Ref : in out Immutable_Reference); + -- Empty Ref + + function Is_Empty (Ref : Immutable_Reference) return Boolean; + -- Check whether Ref refers to an actual object + + function "=" (Left, Right : Immutable_Reference) return Boolean; + -- Check whether Left and Right refer to the same object + + function Query (Ref : in Immutable_Reference) return Accessor; + pragma Inline (Query); + -- Return a derefenciable constant access to the held object + + procedure Query + (Ref : in Immutable_Reference; + Process : not null access procedure (Object : in Held_Data)); + -- Call Process with the held object + + Null_Immutable_Reference : constant Immutable_Reference; + + + type Reference is new Immutable_Reference with private; + + function Update (Ref : in Reference) return Mutator; + pragma Inline (Update); + -- Return a ereferenciable mutable access to the held object + + procedure Update + (Ref : in Reference; + Process : not null access procedure (Object : in out Held_Data)); + -- Call Process with the held object + + Null_Reference : constant Reference; + +private + + protected type Counter is + procedure Increment; + procedure Decrement (Zero : out Boolean); + function Get_Value return Natural; + private + Value : Natural := 1; + end Counter; + + type Counter_Access is access Counter; + for Counter_Access'Storage_Pool use Counter_Pool; + + type Immutable_Reference is new Ada.Finalization.Controlled with record + Count : Counter_Access := null; + Data : Data_Access := null; + end record; + + overriding procedure Adjust (Object : in out Immutable_Reference); + -- Increate reference counter + + overriding procedure Finalize (Object : in out Immutable_Reference); + -- Decrease reference counter and release memory if needed + + type Reference is new Immutable_Reference with null record; + + type Accessor (Data : not null access constant Held_Data) is limited record + Parent : Immutable_Reference; + end record; + + type Mutator (Data : not null access Held_Data) is limited record + Parent : Reference; + end record; + + Null_Immutable_Reference : constant Immutable_Reference + := (Ada.Finalization.Controlled with Count => null, Data => null); + + Null_Reference : constant Reference + := (Null_Immutable_Reference with null record); + +end Natools.References; Index: tests.gpr ================================================================== --- tests.gpr +++ tests.gpr @@ -18,8 +18,11 @@ package Naming is case Natools.Safety is when "None" => for body ("Natools.References.Tools") use "natools-references-tools__unsafe.adb"; + when "Portable" => + for body ("Natools.References.Tools") + use "natools-references-tools__protected.adb"; end case; end Naming; end Tests; ADDED tests/natools-references-tools__protected.adb Index: tests/natools-references-tools__protected.adb ================================================================== --- tests/natools-references-tools__protected.adb +++ tests/natools-references-tools__protected.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013-2014, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +package body Natools.References.Tools is + + function Is_Consistent (Left, Right : Reference) return Boolean is + begin + return (Left.Data = Right.Data) = (Left.Count = Right.Count); + end Is_Consistent; + + + function Is_Valid (Ref : Reference) return Boolean is + begin + return (Ref.Data = null) = (Ref.Count = null); + end Is_Valid; + + + function Count (Ref : Reference) return Natural is + begin + if Ref.Count /= null then + return Ref.Count.Get_Value; + else + return 0; + end if; + end Count; + +end Natools.References.Tools;