File : bc-support-dynamic.adb


-- Copyright (C) 1994-1998 Grady Booch, David Weller and Simon Wright.
-- All Rights Reserved.
--
--      This program is free software; you can redistribute it
--      and/or modify it under the terms of the Ada Community
--      License which comes with this Library.
--
--      This program 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 Ada Community License for more details.
--      You should have received a copy of the Ada Community
--      License with this library, in the file named "Ada Community
--      License" or "ACL". If not, contact the author of this library
--      for a copy.
--

-- $Id: bc-support-dynamic.adb,v 1.6 1999/04/10 14:38:21 simon Exp $

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

package body BC.Support.Dynamic is

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

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

  function Create (From : Dyn_Node) return Dyn_Node_Ref is
    New_Node: Dyn_Node_Ref :=
        new Dyn_Node'(Ada.Finalization.Controlled with
                      Ref => new Dyn_Arr (1 .. From.Size + From.Chunk_Size),
                      Size => From.Size,
                      Chunk_Size => From.Chunk_Size);
  begin
    New_Node.Ref (1 .. New_Node.Size) := From.Ref (1 .. From.Size);
    return New_Node;
  end Create;

  function Create (Size : Positive := 10) return Dyn_Node_Ref is
  begin
    return new Dyn_Node'(Ada.Finalization.Controlled with
                         Ref => new Dyn_Arr (1 .. Size),
                         Size => 0,
                         Chunk_Size => Size);
  end Create;

  function "=" (Left, Right : Dyn_Node) return Boolean is
  begin
    if Left.Size /= Right.Size then
      return False;
    else
      return Left.Ref (1 .. Left.Size) = Right.Ref (1 .. Left.Size);
    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 First (Obj : Dyn_Node) return Item_Ptr is
  begin
    Assert (Obj.Size > 0,
            BC.Underflow'Identity,
            "First",
            BSE.Empty);
    return Obj.Ref (1)'access;
  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 Last (Obj : Dyn_Node) return Item_Ptr is
  begin
    Assert (Obj.Size > 0,
            BC.Underflow'Identity,
            "Last",
            BSE.Empty);
    return Obj.Ref (Obj.Size)'access;
  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 Obj.Ref (Index)'access;
  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 := 10) 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 Free (Obj : in out Dyn_Node_Ref) is
  begin
    Delete_Node (Obj);
  end Free;

  procedure Initialize (D : in out Dyn_Node) is
  begin
    D.Ref := new Dyn_Arr (1 .. 10);
    D.Size := 0;
    D.Chunk_Size := 10;
  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;

end BC.Support.Dynamic;