File : bc-support-bounded.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-bounded.adb,v 1.3.4.1 1999/06/20 06:39:24 simon Exp $
with Ada.Unchecked_Deallocation;
with BC.Support.Exceptions;
with System.Address_To_Access_Conversions;
package body BC.Support.Bounded is
package BSE renames BC.Support.Exceptions;
procedure Assert
is new BSE.Assert ("BC.Support.Bounded");
-- 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 return
-- pointers to individual elements. This technique is due to Matthew
-- Heaney.
package Allow_Access
is new System.Address_To_Access_Conversions (Elem_Array);
function Create (Obj : in Bnd_Node) return Bnd_Node_Ref is
begin
return new Bnd_Node'(Elems => Obj.Elems, Size => Obj.Size);
end Create;
procedure Clear (Obj : in out Bnd_Node) is
begin
Obj.Size := 0;
end Clear;
procedure Insert (Obj : in out Bnd_Node; Elem : Item) is
begin
Assert (Obj.Size < Max_Size,
BC.Overflow'Identity,
"Insert",
BSE.Full);
Obj.Elems (2 .. Obj.Size + 1) := Obj.Elems (1 .. Obj.Size);
Obj.Elems (1) := Elem;
Obj.Size := Obj.Size + 1;
end Insert;
procedure Insert (Obj : in out Bnd_Node; Elem : Item; Before : Positive) is
begin
Assert (Obj.Size < Max_Size,
BC.Overflow'Identity,
"Insert",
BSE.Full);
if Obj.Size = 0 or else Before = 1 then
Insert (Obj, Elem);
else
Obj.Elems (Before + 1 .. Obj.Size + 1) := Obj.Elems (Before .. Obj.Size);
Obj.Elems (Before) := Elem;
Obj.Size := Obj.Size + 1;
end if;
end Insert;
procedure Append (Obj : in out Bnd_Node; Elem : Item) is
begin
Assert (Obj.Size < Max_Size,
BC.Overflow'Identity,
"Append",
BSE.Full);
Obj.Size := Obj.Size + 1;
Obj.Elems (Obj.Size) := Elem;
end Append;
procedure Append (Obj : in out Bnd_Node; Elem : Item; After : Positive) is
begin
Assert (After <= Obj.Size,
BC.Range_Error'Identity,
"Append",
BSE.Invalid_Index);
Assert (Obj.Size < Max_Size,
BC.Overflow'Identity,
"Append",
BSE.Full);
if After = Obj.Size then
Obj.Size := Obj.Size + 1;
Obj.Elems (Obj.Size) := Elem;
else
Obj.Elems (After + 2 .. Obj.Size + 1) := Obj.Elems (After + 1 .. Obj.Size);
Obj.Size := Obj.Size + 1;
Obj.Elems (After + 1) := Elem;
end if;
end Append;
procedure Remove (Obj : in out Bnd_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.Elems (From .. Obj.Size - 1) := Obj.Elems (From + 1 .. Obj.Size);
Obj.Size := Obj.Size - 1;
end if;
end Remove;
procedure Replace (Obj : in out Bnd_Node; Index : Positive; Elem : Item) is
begin
Assert (Index <= Obj.Size,
BC.Range_Error'Identity,
"Replace",
BSE.Invalid_Index);
Obj.Elems (Index) := Elem;
end Replace;
function Available (Obj: Bnd_Node) return Natural is
begin
return Max_Size - Obj.Size;
end Available;
function Length (Obj : Bnd_Node) return Natural is
begin
return Obj.Size;
end Length;
function First (Obj : Bnd_Node) return Item is
begin
Assert (Obj.Size > 0,
BC.Underflow'Identity,
"First",
BSE.Empty);
return Obj.Elems (1);
end First;
function First (Obj : Bnd_Node) return Item_Ptr is
E : Allow_Access.Object_Pointer
:= Allow_Access.To_Pointer (Obj.Elems'Address);
begin
Assert (Obj.Size > 0,
BC.Underflow'Identity,
"First",
BSE.Empty);
return E (1)'Access;
end First;
function Last (Obj : Bnd_Node) return Item is
begin
Assert (Obj.Size > 0,
BC.Underflow'Identity,
"Last",
BSE.Empty);
return Obj.Elems(Obj.Size);
end Last;
function Last (Obj : Bnd_Node) return Item_Ptr is
E : Allow_Access.Object_Pointer
:= Allow_Access.To_Pointer (Obj.Elems'Address);
begin
Assert (Obj.Size > 0,
BC.Underflow'Identity,
"Last",
BSE.Empty);
return E (Obj.Size)'Access;
end Last;
function Item_At (Obj : Bnd_Node; Index : Positive) return Item is
begin
Assert (Index in 1 .. Obj.Size,
BC.Range_Error'Identity,
"Item_At",
BSE.Invalid_Index);
return Obj.Elems (Index);
end Item_At;
function Item_At (Obj : Bnd_Node; Index : Positive) return Item_Ptr is
E : Allow_Access.Object_Pointer
:= Allow_Access.To_Pointer (Obj.Elems'Address);
begin
Assert (Index in 1 .. Obj.Size,
BC.Range_Error'Identity,
"Item_At",
BSE.Invalid_Index);
return E (Index)'Access;
end Item_At;
function Location (Obj : Bnd_Node;
Elem : Item;
Start : Natural := 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,
"Start",
BSE.Invalid_Index);
for I in Start .. Obj.Size loop
if Obj.Elems (I) = Elem then
return I;
end if;
end loop;
return 0;
end Location;
procedure Free (Obj : in out Bnd_Node_Ref) is
procedure Delete_Node is
new Ada.Unchecked_Deallocation (Bnd_Node, Bnd_Node_Ref);
begin
Delete_Node (Obj);
end Free;
end BC.Support.Bounded;