File : asgc-list-dynamic_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.List.Dynamic_Managed is

   procedure Free_Node is new Ada.Unchecked_Deallocation(Node,
                                                         Node_Ptr);

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



   ------------------------------------------------------------------------
   -- Allocate a free node for the list.
   procedure Alloc_Node (O    : in out Object'Class;
                         Item : out Node_Ptr) is
   begin
      Item := new Node;
   end Alloc_Node;


   ------------------------------------------------------------------------
   -- Free a node for the list.
   procedure Free_Node (O    : in out Object'Class;
                        Item : in out Node_Ptr) is
   begin
      Free_Node(Item);
   end Free_Node;


   ------------------------------------------------------------------------
   -- 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 = null) then
         raise Invalid_Iterator;
      end if;
   end Check_Iterator;


   ------------------------------------------------------------------------
   -- 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_Null_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;
   end Check_Iterator_Null_Ok;


   ------------------------------------------------------------------------
   -- Search the list for the given position.  Return the value that is
   -- previous to the found entry and the found entry if found.  The Prev
   -- value will be null if the found value is first in the list.
   procedure Local_Search(O      : in Object;
                          Val    : in Contained_Type;
                          Prev   : out Node_Ptr;
                          Curr   : out Node_Ptr;
                          Found  : out Boolean) is
      LPrev : Node_Ptr;
      LCurr : Node_Ptr;
   begin
      LCurr := O.Head;
      LPrev := null;
      while ((LCurr /= null)
             and then (LCurr.Val /= Val))
      loop
         Prev := LCurr;
         LCurr := LCurr.Next;
      end loop;
      if (LCurr = null) then
         Found := False;
      else
         Found := True;
         Curr := LCurr;
         Prev := LPrev;
      end if;
   end Local_Search;


   ------------------------------------------------------------------------
   -- 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
      New_List : Node_Ptr := null;
      New_Curr : Node_Ptr;
      Old_Curr : Node_Ptr := O.Head;
   begin
      if (O.Head = null) then
         O.Head := null;
         O.Tail := null;
      else
         -- Copy the list.
         New_List := new Node;
         New_List.Val := Old_Curr.Val;

         New_Curr := New_List;
         while (Old_Curr.Next /= null) loop
            New_Curr.Next := new Node;
            New_Curr.Next.Val := Old_Curr.Next.Val;
            Old_Curr := Old_Curr.Next;
            New_Curr := New_Curr.Next;
         end loop;
         O.Head := New_List;
         O.Tail := New_Curr;
      end if;

      -- Call the Copied callback method for every item in the new list.
      if (O.Cb /= null) then
         New_Curr := O.Head;
         while (New_Curr /= null) loop
            Copied(O.Cb, O, New_Curr.Val);
            New_Curr := New_Curr.Next;
         end loop;
      end if;
   end Adjust;


   ------------------------------------------------------------------------
   procedure Finalize (O : in out Object) is
      Curr    : Node_Ptr := O.Head;
      Temp    : Node_Ptr;
   begin
      while (Curr /= null) loop
         if (O.Cb /= null) then
            Deleted(O.Cb, O, Curr.Val);
         end if;
         Temp := Curr.Next;
         Free_Node(Curr);
         Curr := Temp;
      end loop;

      O.Is_Free := True;
   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.


   ------------------------------------------------------------------------
   procedure Delete (O   : in out Object;
                     Val : in Contained_Type) is
      To_Free  : Node_Ptr;
      Next_Val : Node_Ptr;
      Prev     : Node_Ptr;
      Found    : Boolean;
   begin
      Check_Object(O);

      Local_Search(O, Val, Prev, To_Free, Found);
      if (not Found) then
         raise Item_Not_Found;
      end if;

      Next_Val := To_Free.Next;
      if (Prev /= null) then
         -- Not deleting the first item, modify the prev's next ref.
         Prev.Next := Next_Val;
      else
         -- Deleting the first item, change the head.
         O.Head := Next_Val;
         if (Next_Val = null) then
            -- Deleting the only item.
            O.Tail := null;
         end if;
      end if;
      O.Count := O.Count - 1;
      O.Update := O.Update + 1;

      if (O.Cb /= null) then
         Deleted(O.Cb,O, To_Free.Val);
      end if;

      Free_Node(O, To_Free);
   end Delete;


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

      Local_Search(O, Val, Prev, Curr, Found);
      return Found;
   end Value_Exists;


   ------------------------------------------------------------------------
   procedure Add_Head (O : in out Object; Val : in Contained_Type) is
      New_Node : Node_Ptr;
   begin
      Check_Object(O);

      Alloc_Node(O, New_Node);
      New_Node.Val := Val;
      New_Node.Next := O.Head;
      O.Head := New_Node;
      if (O.Tail = null) then
         O.Tail := New_Node;
      end if;

      O.Count := O.Count + 1;
      O.Update := O.Update + 1;

      if (O.Cb /= null) then
         Added(O.Cb, O, New_Node.Val);
      end if;
   end Add_Head;


   ------------------------------------------------------------------------
   procedure Add_Tail (O : in out Object; Val : in Contained_Type) is
      New_Node : Node_Ptr;
   begin
      Check_Object(O);

      Alloc_Node(O, New_Node);
      New_Node.Val := Val;
      New_Node.Next := null;
      if (O.Tail = null) then
         O.Head := New_Node;
      else
         O.Tail.Next := New_Node;
      end if;
      O.Tail := New_Node;

      O.Count := O.Count + 1;
      O.Update := O.Update + 1;

      if (O.Cb /= null) then
         Added(O.Cb, O, New_Node.Val);
      end if;
   end Add_Tail;


   ------------------------------------------------------------------------
   function "=" (O1, O2 : in Object) return Boolean is
      Curr1 : Node_Ptr;
      Curr2 : Node_Ptr;
   begin
      Check_Object(O1);
      Check_Object(O2);

      if (O1.Count /= O2.Count) then
         return False;
      else
         Curr1 := O1.Head;
         Curr2 := O2.Head;
         while (Curr1 /= null) loop
            if (Curr2 = null) then
               raise Internal_List_Error;
            end if;

            if (Curr1.Val /= Curr2.Val) then
               return False;
            end if;

            Curr1 := Curr1.Next;
            Curr2 := Curr2.Next;
         end loop;

         if (Curr2 /= null) then
            raise Internal_List_Error;
         end if;

         return True;
      end if;
   end "=";


   ------------------------------------------------------------------------
   function Member_Count (O : in Object)
                          return Natural is
   begin
      Check_Object(O);

      return O.Count;
   end Member_Count;


   ------------------------------------------------------------------------
   procedure Verify_Integrity (O : in Object) is
      Curr  : Node_Ptr;
      Count : Natural;
   begin
      Check_Object(O);

      if (O.Count = 0) then
         if ((O.Head /= null) or (O.Tail /= null)) then
            raise Internal_List_Error;
         end if;
      else
         Curr := O.Head;
         Count := 1;
         while (Curr.Next /= null) loop
            if (Count > O.Count) then
               raise Internal_List_Error;
            end if;
            Curr := Curr.Next;
            Count := Count + 1;
         end loop;
         if (Count /= O.Count) then
            raise Internal_List_Error;
         end if;
         if (Curr /= O.Tail) then
            raise Internal_List_Error;
         end if;
      end if;
   end Verify_Integrity;


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

      return Asgc.Object_Class(Retval);
   end Copy;


   ------------------------------------------------------------------------
   procedure Add_Before (Iter : in out Iterator; Val : in Contained_Type) is
      New_Node : Node_Ptr;
   begin
      Check_Iterator_Null_Ok(Iter);

      Alloc_Node(Iter.Robj.all, New_Node);
      New_Node.Val := Val;
      New_Node.Next := Iter.Pos;
      if (Iter.Robj.Tail = null) then
         -- The list is empty, this becomes the only member.
         Iter.Robj.Head := New_Node;
         Iter.Robj.Tail := New_Node;
      elsif (Iter.Robj.Head = Iter.Pos) then
         -- If we are at the head, the new item becomes the new head.
         Iter.Robj.Head := New_Node;
      else
         Iter.Prev.Next := New_Node;
      end if;
      Iter.Pos := New_Node;

      Iter.Robj.Count := Iter.Robj.Count + 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,
               New_Node.Val);
      end if;
   end Add_Before;


   ------------------------------------------------------------------------
   procedure Add_After (Iter : in out Iterator; Val : in Contained_Type) is
      New_Node : Node_Ptr;
   begin
      Check_Iterator_Null_Ok(Iter);

      Alloc_Node(Iter.Robj.all, New_Node);
      New_Node.Val := Val;
      if (Iter.Robj.Tail = null) then
         -- The list is empty, this becomes the only member.
         Iter.Robj.Head := New_Node;
         Iter.Robj.Tail := New_Node;
      else
         New_Node.Next := Iter.Pos.Next;
         Iter.Pos.Next := New_Node;
         if (Iter.Robj.Tail = Iter.Pos) then
            -- If we are at the tail, the new item becomes the new tail.
            Iter.Robj.Tail := New_Node;
         end if;
      end if;
      Iter.Prev := Iter.Pos;
      Iter.Pos := New_Node;

      Iter.Robj.Count := Iter.Robj.Count + 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,
               New_Node.Val);
      end if;
   end Add_After;


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

      Iter.Pos.Val := Val;
   end Set;


   ------------------------------------------------------------------------
   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);
      Retval.Update := Invalid_Update;

      return Asgc.Iterator_Class(Retval);
   end New_Iterator;


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

      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 Add (Iter : in out Iterator;
                  Val  : in Contained_Type) is
      New_Node : Node_Ptr;
   begin
      Check_Iterator_Null_Ok(Iter);

      Alloc_Node(Iter.Robj.all, New_Node);
      New_Node.Val := Val;

      Iter.Prev := Iter.Robj.Tail;
      if (Iter.Robj.Tail = null) then
         -- The list is empty, this becomes the only member.
         Iter.Robj.Head := New_Node;
         Iter.Robj.Tail := New_Node;
      else
         -- Add it on to the end of the list.
         New_Node.Next := null;
         Iter.Robj.Tail.Next := New_Node;
         Iter.Robj.Tail := New_Node;
      end if;
      Iter.Pos := New_Node;

      Iter.Robj.Count := Iter.Robj.Count + 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,
               New_Node.Val);
      end if;
   end Add;


   ------------------------------------------------------------------------
   procedure First (Iter : in out Iterator; Is_End : out End_Marker) is
   begin
      Check_Object(Iter.Robj.all);

      Iter.Pos := Iter.Robj.Head;
      Iter.Prev := null;
      Iter.Update := Iter.Robj.Update;
      if (Iter.Pos = null) then
         Is_End := Past_End;
      else
         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.Next = null) then
         Is_End := Past_End;
      else
         Iter.Prev := Iter.Pos;
         Iter.Pos := Iter.Pos.Next;
         Is_End := Not_Past_End;
      end if;
   end Next;


   ------------------------------------------------------------------------
   procedure Delete (Iter : in out Iterator; Is_End : out End_Marker) is
      To_Free  : Node_Ptr;
      Next_Val : Node_Ptr;
   begin
      Check_Iterator(Iter);

      To_Free := Iter.Pos;
      Next_Val := To_Free.Next;
      if (Iter.Prev /= null) then
         -- Not deleting the first item, modify the prev's next ref.
         Iter.Prev.Next := Next_Val;
      else
         -- Deleting the first item, change the head.
         Iter.Robj.Head := Next_Val;
         if (Next_Val = null) then
            -- Deleting the only item.
            Iter.Robj.Tail := null;
         end if;
      end if;
      Iter.Robj.Count := Iter.Robj.Count - 1;
      Iter.Robj.Update := Iter.Robj.Update + 1;
      if (Next_Val = null) then
         -- If we delete the last value, we invalidate the iterator by not
         -- updating it.
         Iter.Robj.Tail := Iter.Prev;
         Iter.Pos := null;
      else
         Iter.Update := Iter.Robj.Update;
         Iter.Pos := Next_Val;
         Is_End := Not_Past_End;
      end if;

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

      Free_Node(Iter.Robj.all, To_Free);
   end Delete;


   ------------------------------------------------------------------------
   function Is_Same (Iter1, Iter2 : in Iterator) return Boolean is
   begin
      Check_Iterator(Iter1);
      Check_Iterator(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.Pos.Val;
   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.Pos.Val;
      Next(Iter, Is_End);
   end Get_Incr;


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

      return (Iter1.Pos.Val = Iter2.Pos.Val);
   end "=";


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

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


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

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

end Asgc.List.Dynamic_Managed;