File : asgc-ordered-vector-expandable_managed.adb


-- The Ada Structured Library - A set of container classes and general
--   tools for use with Ada95.
-- Copyright (C) 1998-1999  Corey Minyard (minyard@acm.org)
--
-- This library is free software; you can redistribute it and/or modify it
-- under the terms of the GNU General Public License as published by the
-- Free Software Foundation; either version 2 of the License, or (at your
-- option) any later version.
--
-- This library is distributed in the hope that it will be useful, but
-- WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-- General Public License for more details.
--
-- You should have received a copy of the GNU General Public License along
-- with this library; if not, write to the Free Software Foundation, Inc.,
-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
--
-- As a special exception, if other files instantiate generics from this
-- unit, or you link this unit with other files to produce an executable,
-- this unit does not by itself cause the resulting executable to be
-- covered by the GNU General Public License.  This exception does not
-- however invalidate any other reasons why the executable file might be
-- covered by the GNU Public License.
--

with Ada.Unchecked_Deallocation;

package body Asgc.Ordered.Vector.Expandable_Managed is

   -- A vector is simply a variable-sized array that conforms to the
   -- container class interface.

   procedure Free_Iterator is new Ada.Unchecked_Deallocation (Iterator,
                                                              Iterator_Ptr);

   procedure Free is new Ada.Unchecked_Deallocation (Vector_Array,
                                                     Vector_Array_Ptr);

   -- Increase the size of an expandable vector.
   procedure Increase_Vector_Size (O : in out Object'Class) is
      New_Vector : Vector_Array_Ptr;
   begin
      if (O.Increment = 0) then
         raise Container_Full;
      end if;

      New_Vector := new Vector_Array(1 .. O.The_Vector'Last + O.Increment);
      New_Vector.all(1 .. O.The_Vector'Last) := O.The_Vector.all;
      Free(O.The_Vector);
      O.The_Vector := New_Vector;
   end Increase_Vector_Size;


   ------------------------------------------------------------------------
   -- Check that an object is valid, that is has not been freed.  This is
   -- not a perfect check, but will hopefully help find some bugs.
   procedure Check_Object (O : in Object'Class) is
   begin
      if (O.Is_Free) then
         raise Object_Free;
      end if;
   end Check_Object;


   ------------------------------------------------------------------------
   -- Check that an iterator is valid.  It must not have been freed, it
   -- must be initialized, its object must be valid, and it must not have
   -- been modified since the last time the iterator was positioned.
   procedure Check_Iterator (Iter : in Iterator'Class) is
   begin
      if (Iter.Is_Free) then
         raise Iterator_Free;
      end if;

      if (Iter.Robj = null) then
         raise Invalid_Iterator;
      end if;

      Check_Object(Iter.Robj.all);

      if (Iter.Update /= Iter.Robj.Update) then
         raise Object_Updated;
      end if;

      if ((Iter.Pos = 0) or (Iter.Pos > Iter.Robj.Last)) then
         raise Invalid_Iterator;
      end if;
   end Check_Iterator;


   ------------------------------------------------------------------------
   -- Check that an iterator is valid.  It must not have been freed, it
   -- must be initialized, its object must be valid, and it must not have
   -- been modified since the last time the iterator was positioned.
   -- This routine allows the object to be empty.
   procedure Check_Iterator_Empty_Ok (Iter : in Iterator'Class) is
   begin
      if (Iter.Is_Free) then
         raise Iterator_Free;
      end if;

      if (Iter.Robj = null) then
         raise Invalid_Iterator;
      end if;

      Check_Object(Iter.Robj.all);

      if (Iter.Update /= Iter.Robj.Update) then
         raise Object_Updated;
      end if;

      if (Iter.Pos > Iter.Robj.Last) then
         raise Invalid_Iterator;
      end if;
   end Check_Iterator_Empty_Ok;


   ------------------------------------------------------------------------
   -- Check an iterator, but don't bother checking its positions.  This is
   -- primarily for methods that set some the position of the iterator.
   procedure Check_Iterator_No_Pos (Iter : in Iterator) is
   begin
      if (Iter.Is_Free) then
         raise Iterator_Free;
      end if;

      if (Iter.Robj = null) then
         raise Invalid_Iterator;
      end if;

      Check_Object(Iter.Robj.all);
   end Check_Iterator_No_Pos;


   ------------------------------------------------------------------------
   -- This is a controlled type, so we have those methods to handle.


   ------------------------------------------------------------------------
   procedure Initialize (O : in out Object) is
   begin
      null;
   end Initialize;


   ------------------------------------------------------------------------
   procedure Adjust (O : in out Object) is
      Old_Vector : Vector_Array_Ptr := O.The_Vector;
   begin
      O.The_Vector := new Vector_Array(Old_Vector.all'Range);
      O.The_Vector.all(1 .. O.Last) := Old_Vector(1 .. O.Last);

      if (O.Cb /= null) then
         for I in 1 .. O.Last loop
            Copied(O.Cb, O, O.The_Vector(I));
         end loop;
      end if;
   end Adjust;


   ------------------------------------------------------------------------
   procedure Finalize (O : in out Object) is
   begin
      O.Is_Free := True;
      if (O.Cb /= null) then
         for I in 1 .. O.Last loop
            Deleted(O.Cb, O, O.The_Vector(I));
         end loop;
      end if;
      Free(O.The_Vector);
   end Finalize;


   ------------------------------------------------------------------------
   procedure Finalize (Iter : in out Iterator) is
   begin
      Iter.Is_Free := True;
   end Finalize;


   ------------------------------------------------------------------------
   -- The functions that follow are defined as abstract in previous
   -- packages.  See those packages for descriptions of what these
   -- methods do.


   ------------------------------------------------------------------------
   function "=" (O1, O2 : in Object) return Boolean is
   begin
      if (O1.Last /= O2.Last) then
         return False;
      else
         for I in 1 .. O1.Last loop
            if (O1.The_Vector(I) /= O2.The_Vector(I)) then
               return False;
            end if;
         end loop;
      end if;

      return True;
   end "=";


   ------------------------------------------------------------------------
   procedure Verify_Integrity (O : in Object) is
   begin
      -- Integrity of a vector doesn't really apply.
      Check_Object(O);
   end Verify_Integrity;


   ------------------------------------------------------------------------
   function Copy (O : in Object) return Asgc.Object_Class is
      Retval : Object_Ptr;
   begin
      Retval := new Object(Initial_Size => O.Initial_Size,
                           Increment    => O.Increment);
      Retval.all := O;

      return Asgc.Object_Class(Retval);
   end Copy;


   ------------------------------------------------------------------------
   function Member_Count (O : in Object) return Natural is
   begin
      return O.Last;
   end Member_Count;


   ------------------------------------------------------------------------
   procedure Add_At (O   : in out Object;
                     Loc : in Positive;
                     Val : in Contained_Type) is
   begin
      Check_Object(O);

      if (Loc > O.Last + 1) then
         raise Constraint_Error;
      end if;

      if (O.Last = O.The_Vector'Last) then
         Increase_Vector_Size(O);
      end if;

      for I in reverse Loc .. O.Last loop
         O.The_Vector(I+1) := O.The_Vector(I);
      end loop;

      O.The_Vector(Loc) := Val;
      O.Last := O.Last + 1;

      if (O.Cb /= null) then
         Added(O.Cb, O, O.The_Vector(Loc));
      end if;
   end Add_At;


   ------------------------------------------------------------------------
   procedure Set_At (O   : in out Object;
                     Loc : in Positive;
                     Val : in Contained_Type) is
      Old_Val : Contained_Type;
   begin
      Check_Object(O);

      if (Loc > O.Last) then
         raise Constraint_Error;
      end if;

      Old_Val := O.The_Vector(Loc);
      O.The_Vector(Loc) := Val;

      -- Add then delete the values in case these are the same value.  This
      -- can avoid some nasty side effects.
      if (O.Cb /= null) then
         Added(O.Cb, O, O.The_Vector(Loc));
      end if;

      if (O.Cb /= null) then
         Deleted(O.Cb, O, Old_Val);
      end if;
   end Set_At;


   ------------------------------------------------------------------------
   function Get_At (O   : in Object;
                    Loc : in Positive)
                    return Contained_Type is
   begin
      Check_Object(O);

      if (Loc > O.Last) then
         raise Constraint_Error;
      end if;

      return O.The_Vector(Loc);
   end Get_At;


   ------------------------------------------------------------------------
   procedure Swap_At (O          : in out Object;
                      Loc1, Loc2 : in Positive) is
      Tmp : Contained_Type;
   begin
      Check_Object(O);

      if ((Loc1 > O.Last) or (Loc2 > O.Last)) then
         raise Constraint_Error;
      end if;

      Tmp := O.The_Vector(Loc1);
      O.The_Vector(Loc1) := O.The_Vector(Loc2);
      O.The_Vector(Loc2) := Tmp;
   end Swap_At;


   ------------------------------------------------------------------------
   procedure Delete_At (O   : in out Object;
                        Loc : in Positive) is
      Deleted_Val : Contained_Type;
   begin
      Check_Object(O);

      if (Loc > O.Last) then
         raise Constraint_Error;
      end if;

      Deleted_Val := O.The_Vector(Loc);
      for I in Loc .. O.Last - 1 loop
         O.The_Vector(I) := O.The_Vector(I+1);
      end loop;

      O.Last := O.Last - 1;
      O.Update := O.Update + 1;

      if (O.Cb /= null) then
         Deleted(O.Cb, O, Deleted_Val);
      end if;
   end Delete_At;


   ------------------------------------------------------------------------
   procedure Delete (O   : in out Object;
                     Val : in Contained_Type) is
   begin
      Check_Object(O);

      for I in O.The_Vector'First .. O.Last loop
         if (O.The_Vector(I) = Val) then
            Delete_At(O, I);
            return;
         end if;
      end loop;

      raise Item_Not_Found;
   end Delete;


   ------------------------------------------------------------------------
   function Value_Exists (O   : in Object;
                          Val : in Contained_Type)
                          return Boolean is
   begin
      Check_Object(O);

      for I in O.The_Vector'First .. O.Last loop
         if (O.The_Vector(I) = Val) then
            return True;
         end if;
      end loop;

      return False;
   end Value_Exists;


   ------------------------------------------------------------------------
   procedure Push (O   : in out Object;
                   Val : in Contained_Type) is
   begin
      Add_At(O, 1, Val);
   end Push;


   ------------------------------------------------------------------------
   procedure Pop (O   : in out Object;
                  Val : out Contained_Type) is
   begin
      Val := Get_At(O, 1);
      Delete_At(O, 1);
   end Pop;


   ------------------------------------------------------------------------
   procedure Enqueue (O   : in out Object;
                      Val : in Contained_Type) is
   begin
      Add_At(O, O.Last+1, Val);
   end Enqueue;


   ------------------------------------------------------------------------
   procedure Dequeue (O   : in out Object;
                      Val : out Contained_Type) is
   begin
      Val := Get_At(O, 1);
      Delete_At(O, 1);
   end Dequeue;


   ------------------------------------------------------------------------
   function New_Iterator (O : access Object) return Asgc.Iterator_Class is
      Retval : Iterator_Ptr;
   begin
      Check_Object(O.all);

      Retval := new Iterator;
      Retval.Robj := Object_Class(O);

      return Asgc.Iterator_Class(Retval);
   end New_Iterator;


   ------------------------------------------------------------------------
   function New_Iterator (O : in Object_class) return Iterator is
      Retval : Iterator;
   begin
      Retval.Robj := O;

      return Retval;
   end New_Iterator;


   ------------------------------------------------------------------------
   procedure Free (Iter : access Iterator) is
      To_Free : Iterator_Ptr := Iterator_Ptr(Iter);
   begin
      if (Iter.Is_Free) then
         raise Iterator_Free;
      end if;

      Free_Iterator(To_Free);
   end Free;


   ------------------------------------------------------------------------
   procedure Set_Container (Iter : in out Iterator;
                            O    : in Asgc.Object_Class) is
   begin
      Check_Object(Object'Class(O.all));

      Iter.Robj := Object_Class(O);
      Iter.Update := Invalid_Update;
   end Set_Container;


   ------------------------------------------------------------------------
   procedure First (Iter : in out Iterator; Is_End : out End_Marker) is
   begin
      Check_Iterator_No_Pos(Iter);

      Iter.Update := Iter.Robj.Update;
      if (Iter.Robj.Last = 0) then
         Iter.Pos := 0;
         Is_End := Past_End;
      else
         Iter.Pos := 1;
         Is_End := Not_Past_End;
      end if;
   end First;


   ------------------------------------------------------------------------
   procedure Next (Iter : in out Iterator; Is_End : out End_Marker) is
   begin
      Check_Iterator(Iter);

      if (Iter.Pos = Iter.Robj.Last) then
         Is_End := Past_End;
      else
         Iter.Pos := Iter.Pos + 1;
         Is_End := Not_Past_End;
      end if;
   end Next;


   ------------------------------------------------------------------------
   procedure Delete (Iter : in out Iterator; Is_End : out End_Marker) is
      Deleted_Val : Contained_Type;
   begin
      Check_Iterator(Iter);

      Deleted_Val := Iter.Robj.The_Vector(Iter.Pos);
      for I in Iter.Pos .. Iter.Robj.Last - 1 loop
         Iter.Robj.The_Vector(I) := Iter.Robj.The_Vector(I+1);
      end loop;

      Iter.Robj.Last := Iter.Robj.Last - 1;
      Iter.Robj.Update := Iter.Robj.Update + 1;
      if (Iter.Robj.Last <= Iter.Pos) then
         Iter.Update := Iter.Robj.Update;
         Is_End := Not_Past_End;
      else
         -- If we delete the last item, we invalidate the iterator by not
         -- updating the Update.
         Is_End := Past_End;
      end if;

      if (Iter.Robj.Cb /= null) then
         Deleted(Iter.Robj.Cb, Iter.Robj.all, Deleted_Val);
      end if;
   end Delete;


   ------------------------------------------------------------------------
   function Is_Same (Iter1, Iter2 : in Iterator) return Boolean is
   begin
      Check_Iterator_Empty_Ok(Iter1);
      Check_Iterator_Empty_Ok(Iter2);

      if (Iter1.Robj /= Iter2.Robj) then
         raise Iterator_Mismatch;
      end if;

      return (Iter1.Pos = Iter2.Pos);
   end Is_Same;


   ------------------------------------------------------------------------
   function Get (Iter : in Iterator) return Contained_Type is
   begin
      Check_Iterator(Iter);

      return Iter.Robj.The_Vector(Iter.Pos);
   end Get;


   ------------------------------------------------------------------------
   procedure Get_Incr (Iter   : in out Iterator;
                       Val    : out Contained_Type;
                       Is_End : out End_Marker) is
   begin
      Check_Iterator(Iter);

      Val := Iter.Robj.The_Vector(Iter.Pos);
      if (Iter.Pos = Iter.Robj.Last) then
         Is_End := Past_End;

         -- Invalidate the iterator if we go past the end;
         Iter.Update := Iter.Update - 1;
      else
         Iter.Pos := Iter.Pos + 1;
         Is_End := Not_Past_End;
      end if;
   end Get_Incr;


   ------------------------------------------------------------------------
   function "=" (Iter1, Iter2 : in Iterator) return Boolean is
   begin
      Check_Iterator(Iter1);
      Check_Iterator(Iter2);

      return (Iter1.Robj.The_Vector(Iter1.Pos)
              = Iter2.Robj.The_Vector(Iter2.Pos));
   end "=";


   ------------------------------------------------------------------------
   function "=" (Iter : in Iterator; Val : in Contained_Type) return Boolean is
   begin
      Check_Iterator(Iter);

      return (Iter.Robj.The_Vector(Iter.Pos) = Val);
   end "=";


   ------------------------------------------------------------------------
   function "=" (Val : in Contained_Type; Iter : in Iterator) return Boolean is
   begin
      Check_Iterator(Iter);

      return (Iter.Robj.The_Vector(Iter.Pos) = Val);
   end "=";


   ------------------------------------------------------------------------
   procedure Last (Iter : in out Iterator; Is_End : out End_Marker) is
   begin
      Check_Iterator_No_Pos(Iter);

      Iter.Update := Iter.Robj.Update;
      if (Iter.Robj.Last = 0) then
         Iter.Pos := 0;
         Is_End := Past_End;
      else
         Iter.Pos := Iter.Robj.Last;
         Is_End := Not_Past_End;
      end if;
   end Last;


   ------------------------------------------------------------------------
   procedure Prev (Iter : in out Iterator; Is_End : out End_Marker) is
   begin
      Check_Iterator(Iter);

      if (Iter.Pos = 1) then
         Is_End := Past_End;
      else
         Is_End := Not_Past_End;
         Iter.Pos := Iter.Pos - 1;
      end if;
   end Prev;


   ------------------------------------------------------------------------
   procedure Set_Loc (Iter : out Iterator; Loc : in Positive) is
   begin
      Check_Iterator_No_Pos(Iter);

      if (Loc > Iter.Robj.Last) then
         raise Constraint_Error;
      end if;

      Iter.Update := Iter.Robj.Update;
      Iter.Pos := Loc;
   end Set_Loc;


   ------------------------------------------------------------------------
   function Get_Loc (Iter : in Iterator) return Natural is
   begin
      Check_Iterator_Empty_Ok(Iter);

      return Iter.Pos;
   end Get_Loc;


   ------------------------------------------------------------------------
   function Is_After (Iter1, Iter2 : in Iterator) return Boolean is
   begin
      Check_Iterator_Empty_Ok(Iter1);
      Check_Iterator_Empty_Ok(Iter2);

      if (Iter1.Robj /= Iter2.Robj) then
         raise Iterator_Mismatch;
      end if;

      return (Iter1.Pos > Iter2.Pos);
   end Is_After;


   ------------------------------------------------------------------------
   function Is_Before (Iter1, Iter2 : in Iterator) return Boolean is
   begin
      Check_Iterator_Empty_Ok(Iter1);
      Check_Iterator_Empty_Ok(Iter2);

      if (Iter1.Robj /= Iter2.Robj) then
         raise Iterator_Mismatch;
      end if;

      return (Iter1.Pos < Iter2.Pos);
   end Is_Before;


   ------------------------------------------------------------------------
   function "+" (Iter : in Iterator; Offset : in Integer)
                 return Iterator is
      New_Iterator : Iterator;
   begin
      Check_Iterator_Empty_Ok(Iter);

      if (Offset >= 0) then
         if (Iter.Pos + Offset > Iter.Robj.Last) then
            raise Constraint_Error;
         end if;
      else
         if (Iter.Pos <= -Offset) then
            raise Constraint_Error;
         end if;
      end if;
      New_Iterator.Robj := Iter.Robj;
      New_Iterator.Update := New_Iterator.Robj.Update;
      New_Iterator.Pos := Iter.Pos + Offset;

      return New_Iterator;
   end "+";


   ------------------------------------------------------------------------
   function "-" (Iter : in Iterator; Offset : in Integer)
                 return Iterator is
   begin
      return (Iter + (-Offset));
   end "-";


   ------------------------------------------------------------------------
   procedure Swap (Iter1, Iter2 : in out Iterator) is
      Tmp1 : Contained_Type;
      Tmp2 : Contained_Type;
   begin
      Check_Iterator(Iter1);
      Check_Iterator(Iter2);

      Tmp1 := Iter1.Robj.The_Vector(Iter1.Pos);
      Tmp2 := Iter2.Robj.The_Vector(Iter2.Pos);
      Iter1.Robj.The_Vector(Iter1.Pos) := Tmp2;
      Iter2.Robj.The_Vector(Iter2.Pos) := Tmp1;

      -- If we are moving items between different containers, we need to be
      -- sure to call added and deleted on them for the specified
      -- containers.  As usual, added is called first and deleted is call
      -- last.
      if (Iter1.Robj /= Iter2.Robj) then
         if (Iter1.Robj.Cb /= null) then
            Added(Iter1.Robj.Cb,
                  Iter1.Robj.all,
                  Iter1.Robj.The_Vector(Iter1.Pos));
         end if;
         if (Iter2.Robj.Cb /= null) then
            Added(Iter2.Robj.Cb,
                  Iter2.Robj.all,
                  Iter2.Robj.The_Vector(Iter2.Pos));
         end if;
         if (Iter1.Robj.Cb /= null) then
            Deleted(Iter1.Robj.Cb, Iter1.Robj.all, Tmp1);
         end if;
         if (Iter2.Robj.Cb /= null) then
            Deleted(Iter2.Robj.Cb, Iter2.Robj.all, Tmp2);
         end if;
      end if;
   end Swap;


   ------------------------------------------------------------------------
   procedure Add_After (Iter : in out Iterator; Val : in Contained_Type) is
   begin
      Check_Iterator_Empty_Ok(Iter);

      if (Iter.Robj.Last = Iter.Robj.The_Vector'Last) then
         Increase_Vector_Size(Iter.Robj.all);
      end if;

      for I in reverse Iter.Pos+1 .. Iter.Robj.Last loop
         Iter.Robj.The_Vector(I+1) := Iter.Robj.The_Vector(I);
      end loop;

      Iter.Robj.The_Vector(Iter.Pos + 1) := Val;
      Iter.Robj.Last := Iter.Robj.Last + 1;
      Iter.Robj.Update := Iter.Robj.Update + 1;
      Iter.Update := Iter.Robj.Update;
      Iter.Pos := Iter.Pos + 1;

      if (Iter.Robj.Cb /= null) then
         Added(Iter.Robj.Cb, Iter.Robj.all, Iter.Robj.The_Vector(Iter.Pos));
      end if;
   end Add_After;


   ------------------------------------------------------------------------
   procedure Add_Before (Iter : in out Iterator; Val : in Contained_Type) is
   begin
      Check_Iterator_Empty_Ok(Iter);

      if (Iter.Robj.Last = Iter.Robj.The_Vector'Last) then
         Increase_Vector_Size(Iter.Robj.all);
      end if;

      if (Iter.Pos = 0) then
         Iter.Pos := 1;
      end if;

      for I in reverse Iter.Pos .. Iter.Robj.Last loop
         Iter.Robj.The_Vector(I+1) := Iter.Robj.The_Vector(I);
      end loop;

      Iter.Robj.The_Vector(Iter.Pos) := Val;
      Iter.Robj.Last := Iter.Robj.Last + 1;
      Iter.Robj.Update := Iter.Robj.Update + 1;
      Iter.Update := Iter.Robj.Update;

      if (Iter.Robj.Cb /= null) then
         Added(Iter.Robj.Cb, Iter.Robj.all, Iter.Robj.The_Vector(Iter.Pos));
      end if;
   end Add_Before;


   ------------------------------------------------------------------------
   procedure Set (Iter : in Iterator; Val : in Contained_Type) is
      Old_Val : Contained_Type;
   begin
      Check_Iterator(Iter);

      Old_Val := Iter.Robj.The_Vector(Iter.Pos);
      Iter.Robj.The_Vector(Iter.Pos) := Val;

      -- Add then delete the values in case these are the same value.  This
      -- can avoid some nasty side effects.
      if (Iter.Robj.Cb /= null) then
         Added(Iter.Robj.Cb, Iter.Robj.all, Iter.Robj.The_Vector(Iter.Pos));
      end if;

      if (Iter.Robj.Cb /= null) then
         Deleted(Iter.Robj.Cb, Iter.Robj.all, Old_Val);
      end if;
   end Set;


   ------------------------------------------------------------------------
   procedure Get_Decr (Iter   : in out Iterator;
                       Val    : out Contained_Type;
                       Is_End : out End_Marker) is
   begin
      Check_Iterator(Iter);

      Val := Iter.Robj.The_Vector(Iter.Pos);
      if (Iter.Pos = 1) then
         Is_End := Past_End;

         -- Invalidate the iterator if we go past the end;
         Iter.Update := Iter.Update - 1;
      else
         Iter.Pos := Iter.Pos - 1;
         Is_End := Not_Past_End;
      end if;
   end Get_Decr;


end Asgc.Ordered.Vector.Expandable_Managed;