Natools

File src/natools-indefinite_holders.adb from the latest check-in

------------------------------------------------------------------------------
-- 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;