File : bc-support-unbounded.adb
-- Copyright (C) 1994-1999 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-unbounded.adb,v 1.9.2.1 1999/06/20 06:44:27 simon Exp $
with Ada.Unchecked_Deallocation;
with BC.Support.Exceptions;
with System.Address_To_Access_Conversions;
package body BC.Support.Unbounded is
package BSE renames BC.Support.Exceptions;
procedure Assert
is new BSE.Assert ("BC.Support.Unbounded");
-- We can't take 'Access of components of constant (in parameter)
-- objects; but we need to be able to do this so that we can update the
-- cache (which doesn't violate the abstraction, just the Ada
-- restriction). This technique is due to Matthew Heaney.
package Allow_Access
is new System.Address_To_Access_Conversions (Unb_Node);
use type Nodes.Node_Ref;
procedure Delete_Node is new
Ada.Unchecked_Deallocation (Nodes.Node, Nodes.Node_Ref);
procedure Delete_Unb_Node is new
Ada.Unchecked_Deallocation (Unb_Node, Unb_Node_Ref);
procedure Update_Cache (Obj : in out Unb_Node; Index : Positive) is
begin
Assert (Index <= Obj.Size,
BC.Range_Error'Identity,
"Update_Cache",
BSE.Invalid_Index);
if Obj.Cache /= null then
if Index = Obj.Cache_Index then
return;
elsif Index = Obj.Cache_Index + 1 then
Obj.Cache := Obj.Cache.Next;
Obj.Cache_Index := Index;
return;
elsif Index = Obj.Cache_Index - 1 then
Obj.Cache := Obj.Cache.Previous;
Obj.Cache_Index := Index;
return;
end if;
end if;
declare
Ptr : Nodes.Node_Ref := Obj.Rep;
begin
for I in 1 .. Index - 1 loop
Ptr := Ptr.Next;
end loop;
Obj.Cache := Ptr;
Obj.Cache_Index := Index;
end;
end Update_Cache;
function Create (From : Unb_Node) return Unb_Node_Ref is
Obj : Unb_Node_Ref := new Unb_Node;
Tmp : Nodes.Node_Ref := From.Last;
begin
Obj.Size := From.Size;
if Tmp /= null then
Obj.Last := Nodes.Create (Tmp.Element, Previous => null, Next => null);
Obj.Rep := Obj.Last;
Tmp := Tmp.Previous; -- move to previous node from orig list
while Tmp /= null loop
Obj.Rep := Nodes.Create (Tmp.Element,
Previous => null,
Next => Obj.Rep);
Tmp := Tmp.Previous;
end loop;
end if;
return Obj;
end Create;
function "=" (Left, Right : in Unb_Node) return Boolean is
begin
if Left.Size = Right.Size then
declare
Temp_L : Nodes.Node_Ref := Left.Rep;
Temp_R : Nodes.Node_Ref := Right.Rep;
begin
while Temp_L /= null loop
if Temp_L.Element /= Temp_R.Element then
return False;
end if;
Temp_L := Temp_L.Next;
Temp_R := Temp_R.Next;
end loop;
return True;
end;
else
return False;
end if;
end "=";
procedure Clear (Obj : in out Unb_Node) is
Empty_Node : Unb_Node;
Ptr : Nodes.Node_Ref;
begin
while Obj.Rep /= null loop
Ptr := Obj.Rep;
Obj.Rep := Obj.Rep.Next;
Delete_Node (Ptr);
end loop;
Obj := Empty_Node;
end Clear;
procedure Insert (Obj : in out Unb_Node; Elem : Item) is
begin
Obj.Rep := Nodes.Create (Elem, Previous => null, Next => Obj.Rep);
if Obj.Last = null then
Obj.Last := Obj.Rep;
end if;
Obj.Size := Obj.Size + 1;
Obj.Cache := Obj.Rep;
Obj.Cache_Index := 1;
end Insert;
procedure Insert (Obj : in out Unb_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
declare
Temp_Node : Nodes.Node_Ref;
begin
Update_Cache (Obj, Before);
Temp_Node := Nodes.Create (Elem,
Previous => Obj.Cache.Previous,
Next => Obj.Cache);
if Temp_Node.Previous = null then
Obj.Rep := Temp_Node;
end if;
Obj.Size := Obj.Size + 1;
Obj.Cache := Temp_Node;
end;
end if;
end Insert;
procedure Append (Obj : in out Unb_Node; Elem : Item) is
begin
Obj.Last := Nodes.Create (Elem, Previous => Obj.Last, Next => null);
if Obj.Last.Previous /= null then
Obj.Last.Previous.Next := Obj.Last;
end if;
if Obj.Rep = null then
Obj.Rep := Obj.Last;
end if;
Obj.Size := Obj.Size + 1;
Obj.Cache := Obj.Last;
Obj.Cache_Index := Obj.Size;
end Append;
procedure Append (Obj : in out Unb_Node; Elem : Item; After : Positive) is
begin
Assert (After <= Obj.Size,
BC.Range_Error'Identity,
"Append",
BSE.Invalid_Index);
if Obj.Size = 0 then
Append(Obj, Elem);
else
declare
Temp_Node : Nodes.Node_Ref;
begin
Update_Cache (Obj, After);
Temp_Node := Nodes.Create (Elem,
Previous => Obj.Cache,
Next => Obj.Cache.Next);
if Temp_Node.Previous /= null then
Temp_Node.Previous.Next := Temp_Node;
end if;
if Temp_Node.Next = null then
Obj.Last := Temp_Node;
end if;
Obj.Size := Obj.Size + 1;
Obj.Cache := Temp_Node;
Obj.Cache_Index := Obj.Cache_Index + 1;
end;
end if;
end Append;
procedure Remove (Obj : in out Unb_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
declare
Ptr : Nodes.Node_Ref;
begin
Update_Cache (Obj, From);
Ptr := Obj.Cache;
if Ptr.Previous = null then
Obj.Rep := Ptr.Next;
else
Ptr.Previous.Next := Ptr.Next;
end if;
if Ptr.Next = null then
Obj.Last := Ptr.Previous;
else
Ptr.Next.Previous := Ptr.Previous;
end if;
Obj.Size := Obj.Size - 1;
if Ptr.Next /= null then
Obj.Cache := Ptr.Next;
elsif Ptr.Previous /= null then
Obj.Cache := Ptr.Previous;
Obj.Cache_Index := Obj.Cache_Index - 1;
else
Obj.Cache := null;
Obj.Cache_Index := 0;
end if;
Delete_Node (Ptr);
end;
end if;
end Remove;
procedure Replace (Obj : in out Unb_Node; Index : Positive; Elem : Item) is
begin
Assert (Index <= Obj.Size,
BC.Range_Error'Identity,
"Replace",
BSE.Invalid_Index);
if not ((Obj.Cache /= null) and then (Index = Obj.Cache_Index)) then
declare
Ptr : Nodes.Node_Ref := Obj.Rep;
begin
for I in 1 .. Obj.Size loop
if I = Index then
Obj.Cache := Ptr;
Obj.Cache_Index := I;
exit;
else
Ptr := Ptr.Next;
end if;
end loop;
end;
end if;
Obj.Cache.Element := Elem;
end Replace;
function Length (Obj : Unb_Node) return Natural is
begin
return Obj.Size;
end Length;
function First (Obj : Unb_Node) return Item is
begin
Assert (Obj.Size > 0,
BC.Underflow'Identity,
"First",
BSE.Empty);
return Obj.Rep.Element;
end First;
function First (Obj : Unb_Node) return Item_Ptr is
begin
Assert (Obj.Size > 0,
BC.Underflow'Identity,
"First",
BSE.Empty);
return Obj.Rep.Element'access;
end First;
function Last (Obj : Unb_Node) return Item is
begin
Assert (Obj.Size > 0,
BC.Underflow'Identity,
"Last",
BSE.Empty);
return Obj.Last.Element;
end ;
function Last (Obj : Unb_Node) return Item_Ptr is
begin
Assert (Obj.Size > 0,
BC.Underflow'Identity,
"Last",
BSE.Empty);
return Obj.Last.Element'access;
end ;
function Item_At (Obj : Unb_Node; Index : Positive) return Item is
Tmp : Item_Ptr;
begin
Assert (Index <= Obj.Size,
BC.Range_Error'Identity,
"Item_At",
BSE.Invalid_Index);
Tmp := Item_At (Obj, Index);
return Tmp.all;
end Item_At;
function Item_At (Obj : Unb_Node; Index : Positive) return Item_Ptr is
U : Allow_Access.Object_Pointer := Allow_Access.To_Pointer (Obj'Address);
-- Note, although (GNAT 3.11p) the value in Obj is successfully updated
-- via U, the optimiser can get fooled; when we return next/previous
-- cache hits, we must return via U. I don't think this is a bug; the
-- pointer aliasing is a nasty trick, after all.
begin
Assert (Index <= Obj.Size,
BC.Range_Error'Identity,
"Item_At",
BSE.Invalid_Index);
Update_Cache (U.all, Index);
return U.Cache.Element'Access;
end Item_At;
function Location (Obj : Unb_Node; Elem : Item; Start : Positive := 1)
return Natural is
Ptr : Nodes.Node_Ref := Obj.Rep;
U : Allow_Access.Object_Pointer := Allow_Access.To_Pointer (Obj'Address);
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);
if (Start = Obj.Cache_Index) and then (Elem = Obj.Cache.Element) then
return Obj.Cache_Index;
end if;
for I in 1 .. Start - 1 loop
Ptr := Ptr.Next; -- advance to Start point
end loop;
for I in Start..Obj.Size loop
if Ptr.Element = Elem then
U.Cache := Ptr;
U.Cache_Index := I;
return I;
else
Ptr := Ptr.Next;
end if;
end loop;
return 0;
end Location;
procedure Free (Obj : in out Unb_Node_Ref) is
Ptr : Nodes.Node_Ref;
begin
-- code to delete Rep copied from Clear()
while Obj.Rep /= null loop
Ptr := Obj.Rep;
Obj.Rep := Obj.Rep.Next;
Delete_Node (Ptr);
end loop;
Delete_Unb_Node (Obj);
end Free;
end BC.Support.Unbounded;