--  Copyright 1994 Grady Booch
--  Copyright 1994-1997 David Weller
--  Copyright 1998-2002 Simon Wright <simon@pushface.org>

--  This package is free software; you can redistribute it and/or
--  modify it under terms of the GNU General Public License as
--  published by the Free Software Foundation; either version 2, or
--  (at your option) any later version. This package 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 distributed with this package; see file COPYING.  If not,
--  write to the Free Software Foundation, 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.

--  $RCSfile: bc-support-dynamic.adb,v $
--  $Revision: 1.14.2.1 $
--  $Date: 2002/12/26 14:48:09 $
--  $Author: simon $

with Ada.Unchecked_Deallocation;
with BC.Support.Exceptions;
with System.Address_To_Access_Conversions;

package body BC.Support.Dynamic is

   package BSE renames BC.Support.Exceptions;
   procedure Assert
   is new BSE.Assert ("BC.Support.Dynamic");

   --  We can't take 'Access of non-aliased components. But if we
   --  alias discriminated objects they become constrained - even if
   --  the discriminant has a default.
   package Allow_Element_Access
   is new System.Address_To_Access_Conversions (Item);

   procedure Delete_Arr is
      new Ada.Unchecked_Deallocation (Dyn_Arr, Dyn_Arr_Ref);

   procedure Extend (Obj : in out Dyn_Node);

   function "=" (Left, Right : Dyn_Node) return Boolean is
   begin
      if Left.Size /= Right.Size then
         return False;
      else
         --  We have to compare element-by-element; LRM 4.5.2(24)
         for I in 1 .. Left.Size loop
            if Left.Ref (I) /= Right.Ref (I) then
               return False;
            end if;
         end loop;
         return True;
      end if;
   end "=";

   procedure Clear (Obj : in out Dyn_Node) is
   begin
      Delete_Arr (Obj.Ref);
      Preallocate (Obj);
      Obj.Size := 0;
   end Clear;

   procedure Extend (Obj : in out Dyn_Node) is
      Temp : Dyn_Arr_Ref;
   begin
      Temp := new Dyn_Arr (1 .. Obj.Ref'Last + Obj.Chunk_Size);
      Temp (1 .. Obj.Size) := Obj.Ref (1 .. Obj.Size);
      Delete_Arr (Obj.Ref);
      Obj.Ref := Temp;
   end Extend;

   procedure Insert (Obj : in out Dyn_Node; Elem : Item) is
   begin
      if Obj.Size = Obj.Ref'Last then
         Extend (Obj);
      end if;
      Obj.Ref (2 .. Obj.Size + 1) := Obj.Ref (1 .. Obj.Size);
      Obj.Ref (1) := Elem;
      Obj.Size := Obj.Size + 1;
   end Insert;

   procedure Insert (Obj : in out Dyn_Node; Elem : Item; Before : Positive) is
   begin
      Assert (Before <= Obj.Size,
              BC.Range_Error'Identity,
              "Insert",
              BSE.Invalid_Index);
      if Obj.Size = 0 or else Before = 1 then
         Insert (Obj, Elem);
      else
         if Obj.Size = Obj.Ref'Last then
            Extend (Obj);
         end if;
         Obj.Ref (Before + 1 .. Obj.Size + 1) := Obj.Ref (Before .. Obj.Size);
         Obj.Ref (Before) := Elem;
         Obj.Size := Obj.Size + 1;
      end if;
   end Insert;

   procedure Append (Obj : in out Dyn_Node; Elem : Item) is
   begin
      if Obj.Size >= Obj.Ref'Last then
         Extend (Obj);
      end if;
      Obj.Size := Obj.Size + 1;
      Obj.Ref (Obj.Size) := Elem;
   end Append;

   procedure Append (Obj : in out Dyn_Node; Elem : Item; After : Positive) is
   begin
      Assert (After <= Obj.Size,
              BC.Range_Error'Identity,
              "Append",
              BSE.Invalid_Index);
      if Obj.Size = Obj.Ref'Last then
         Extend (Obj);
      end if;
      if After = Obj.Size then
         Obj.Size := Obj.Size + 1;
         Obj.Ref (Obj.Size) := Elem;
      else
         Obj.Ref (After + 2 .. Obj.Size + 1) :=
           Obj.Ref (After + 1 .. Obj.Size);
         Obj.Size := Obj.Size + 1;
         Obj.Ref (After + 1) := Elem;
      end if;
   end Append;

   procedure Remove (Obj : in out Dyn_Node; From : Positive) is
   begin
      Assert (From <= Obj.Size,
              BC.Range_Error'Identity,
              "Remove",
              BSE.Invalid_Index);
      Assert (Obj.Size > 0,
              BC.Underflow'Identity,
              "Remove",
              BSE.Empty);
      if Obj.Size = 1 then
         Clear (Obj);
      else
         Obj.Ref (From .. Obj.Size - 1) := Obj.Ref (From + 1 .. Obj.Size);
         Obj.Size := Obj.Size - 1;
      end if;
   end Remove;

   procedure Replace (Obj : in out Dyn_Node; Index : Positive; Elem : Item) is
   begin
      Assert (Index <= Obj.Size,
              BC.Range_Error'Identity,
              "Replace",
              BSE.Invalid_Index);
      Obj.Ref (Index) := Elem;
   end Replace;

   function Length (Obj : Dyn_Node) return Natural is
   begin
      return Obj.Size;
   end Length;

   function First (Obj : Dyn_Node) return Item is
   begin
      Assert (Obj.Size > 0,
              BC.Underflow'Identity,
              "First",
              BSE.Empty);
      return Obj.Ref (1);
   end First;

   function Last (Obj : Dyn_Node) return Item is
   begin
      Assert (Obj.Size > 0,
              BC.Underflow'Identity,
              "Last",
              BSE.Empty);
      return Obj.Ref (Obj.Size);
   end Last;

   function Item_At (Obj : Dyn_Node; Index : Positive) return Item is
   begin
      Assert (Index <= Obj.Size,
              BC.Range_Error'Identity,
              "Item_At",
              BSE.Invalid_Index);
      return Obj.Ref (Index);
   end Item_At;

   function Item_At (Obj : Dyn_Node; Index : Positive) return Item_Ptr is
   begin
      Assert (Index <= Obj.Size,
              BC.Range_Error'Identity,
              "Item_At",
              BSE.Invalid_Index);
      return Item_Ptr
        (Allow_Element_Access.To_Pointer (Obj.Ref (Index)'Address));
   end Item_At;

   function Location (Obj : Dyn_Node; Elem : Item; Start : Positive := 1)
                     return Natural is
   begin
      --  XXX the C++ (which indexes from 0) nevertheless checks
      --  "start <= count". We have to special-case the empty Node; the
      --  C++ indexes from 0, so it can legally start with index 0
      --  when the Node is empty.
      if Obj.Size = 0 then
         return 0;
      end if;
      Assert (Start <= Obj.Size,
              BC.Range_Error'Identity,
              "Location",
              BSE.Invalid_Index);
      for I in Start .. Obj.Size loop
         if Obj.Ref (I) = Elem then
            return I;
         end if;
      end loop;
      return 0;  -- Not located
   end Location;

   procedure Preallocate (Obj : in out Dyn_Node;
                          New_Length : Natural := Initial_Size) is
      Temp : Dyn_Arr_Ref;
      Last : Natural;
   begin
      --  XXX I don't think this algorithm is very clever! we really
      --  shouldn't have to allocate a temporary and then delete it ..
      if Obj.Ref /= null then
         Temp := new Dyn_Arr (1 .. Obj.Ref'Last);
         Temp (1 .. Obj.Ref'Last) := Obj.Ref.all;
         Last := Obj.Ref'Last;
         Delete_Arr (Obj.Ref);
      else
         Last := 0;
      end if;
      Obj.Ref := new Dyn_Arr (1 .. Last + New_Length);
      if Last /= 0 then -- something was in the array already
         Obj.Ref (1 .. Obj.Size) := Temp (1 .. Obj.Size);
         Delete_Arr (Temp);
      end if;
   end Preallocate;

   procedure Set_Chunk_Size (Obj : in out Dyn_Node; Size : Natural) is
   begin
      Obj.Chunk_Size := Size;
   end Set_Chunk_Size;

   function Chunk_Size (Obj : in Dyn_Node) return Natural is
   begin
      return Obj.Chunk_Size;
   end Chunk_Size;

   procedure Initialize (D : in out Dyn_Node) is
   begin
      D.Ref := new Dyn_Arr (1 .. Initial_Size);
      D.Size := 0;
      D.Chunk_Size := Initial_Size;
   end Initialize;

   procedure Adjust (D : in out Dyn_Node) is
      Tmp : Dyn_Arr_Ref := new Dyn_Arr (1 .. D.Ref'Last);
   begin
      Tmp (1 .. D.Size) := D.Ref (1 .. D.Size);
      D.Ref := Tmp;
   end Adjust;

   procedure Finalize (D : in out Dyn_Node) is
   begin
      if D.Ref /= null then
         Delete_Arr (D.Ref);
         D.Ref := null;
      end if;
   end Finalize;

   procedure Write_Dyn_Node
     (Stream : access Ada.Streams.Root_Stream_Type'Class;
      Obj : Dyn_Node) is
   begin
      Integer'Write (Stream, Obj.Size);
      for I in 1 .. Obj.Size loop
         Item'Output (Stream, Obj.Ref (I));
      end loop;
   end Write_Dyn_Node;

   procedure Read_Dyn_Node
     (Stream : access Ada.Streams.Root_Stream_Type'Class;
      Obj : out Dyn_Node) is
      Count : Integer;
   begin
      Clear (Obj);
      Integer'Read (Stream, Count);
      for I in 1 .. Count loop
         declare
            Elem : constant Item := Item'Input (Stream);
         begin
            Append (Obj, Elem);
         end;
      end loop;
   end Read_Dyn_Node;

end BC.Support.Dynamic;