ADDED src/natools-indefinite_holders.adb Index: src/natools-indefinite_holders.adb ================================================================== --- src/natools-indefinite_holders.adb +++ src/natools-indefinite_holders.adb @@ -0,0 +1,147 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013, 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.Indefinite_Vectors is an implementation of a subset of Ada 2012 -- +-- Containers.Indefinite_Holders, compatible with Ada 2005. -- +------------------------------------------------------------------------------ + +package body Natools.Indefinite_Holders is + + function "=" (Left, Right : Holder) return Boolean is + begin + if Left.Ref = Right.Ref then + return True; + elsif Left.Ref = null or Right.Ref = null then + return False; + else + return Left.Ref.all = Right.Ref.all; + end if; + end "="; + + + function To_Holder (New_Item : Element_Type) return Holder is + begin + return Holder'(Ada.Finalization.Controlled with + Ref => new Element_Type'(New_Item)); + end To_Holder; + + + function Is_Empty (Container : Holder) return Boolean is + begin + return Container.Ref = null; + end Is_Empty; + + + procedure Clear (Container : in out Holder) is + begin + Free (Container.Ref); + end Clear; + + + function Element (Container : Holder) return Element_Type is + begin + if Container.Ref = null then + raise Constraint_Error with "Element called with an empty holder"; + else + return Container.Ref.all; + end if; + end Element; + + + procedure Replace_Element (Container : in out Holder; + New_Item : in Element_Type) is + begin + Free (Container.Ref); + Container.Ref := new Element_Type'(New_Item); + end Replace_Element; + + + procedure Query_Element + (Container : in Holder; + Process : not null access procedure (Element : in Element_Type)) is + begin + if Container.Ref = null then + raise Constraint_Error + with "Query_Element called with an empty holder"; + else + Process.all (Container.Ref.all); + end if; + end Query_Element; + + + procedure Update_Element + (Container : in out Holder; + Process : not null access procedure (Element : in out Element_Type)) is + begin + if Container.Ref = null then + raise Constraint_Error + with "Update_Element called with an empty holder"; + else + Process.all (Container.Ref.all); + end if; + end Update_Element; + + + function Reference (Container : Holder) return access Element_Type is + begin + return Container.Ref; + end Reference; + + + procedure Assign (Target : in out Holder; Source : in Holder) is + begin + Free (Target.Ref); + if Source.Ref /= null then + Target.Ref := new Element_Type'(Source.Ref.all); + end if; + end Assign; + + + function Copy (Source : Holder) return Holder is + Result : Holder; + begin + if Source.Ref /= null then + Result.Ref := new Element_Type'(Source.Ref.all); + end if; + + return Result; + end Copy; + + + procedure Move (Target : in out Holder; Source : in out Holder) is + begin + Free (Target.Ref); + Target.Ref := Source.Ref; + Source.Ref := null; + end Move; + + overriding procedure Adjust (Object : in out Holder) is + New_Ref : Element_Access := null; + begin + if Object.Ref /= null then + New_Ref := new Element_Type'(Object.Ref.all); + Object.Ref := New_Ref; + end if; + end Adjust; + + + overriding procedure Finalize (Object : in out Holder) is + begin + Free (Object.Ref); + end Finalize; + +end Natools.Indefinite_Holders; ADDED src/natools-indefinite_holders.ads Index: src/natools-indefinite_holders.ads ================================================================== --- src/natools-indefinite_holders.ads +++ src/natools-indefinite_holders.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013, 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.Indefinite_Holders is an implementation of a subset of Ada 2012 -- +-- Containers.Indefinite_Holders, compatible with Ada 2005. -- +-- -- +-- WARNING: tampering checks are not implemented yet. -- +------------------------------------------------------------------------------ + +private with Ada.Finalization; +private with Ada.Unchecked_Deallocation; + +generic + type Element_Type (<>) is private; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Natools.Indefinite_Holders is + pragma Preelaborate (Indefinite_Holders); + -- pragma Remote_Types (Indefinite_Holders); is not supported yet. + + type Holder is tagged private; + pragma Preelaborable_Initialization (Holder); + + Empty_Holder : constant Holder; + + function "=" (Left, Right : Holder) return Boolean; + + function To_Holder (New_Item : Element_Type) return Holder; + + function Is_Empty (Container : Holder) return Boolean; + + procedure Clear (Container : in out Holder); + function Element (Container : Holder) return Element_Type; + + procedure Replace_Element (Container : in out Holder; + New_Item : in Element_Type); + + procedure Query_Element + (Container : in Holder; + Process : not null access procedure (Element : in Element_Type)); + + procedure Update_Element + (Container : in out Holder; + Process : not null access procedure (Element : in out Element_Type)); + + function Reference (Container : Holder) return access Element_Type; + + procedure Assign (Target : in out Holder; Source : in Holder); + + function Copy (Source : Holder) return Holder; + + procedure Move (Target : in out Holder; Source : in out Holder); + +private + + type Element_Access is access Element_Type; + + procedure Free is new Ada.Unchecked_Deallocation + (Element_Type, Element_Access); + + type Holder is new Ada.Finalization.Controlled with record + Ref : Element_Access := null; + end record; + + overriding procedure Adjust (Object : in out Holder); + overriding procedure Finalize (Object : in out Holder); + + Empty_Holder : constant Holder := (Ada.Finalization.Controlled with null); + +end Natools.Indefinite_Holders;