-- 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-bounded.adb,v $
-- $Revision: 1.17.2.4 $
-- $Date: 2002/12/26 14:48:04 $
-- $Author: simon $
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 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 Clear (Obj : in out Bnd_Node) is
begin
Obj.Start := 1;
Obj.Size := 0;
end Clear;
procedure Insert (Obj : in out Bnd_Node; Elem : Item) is
begin
Assert (Obj.Size < Obj.Maximum_Size,
BC.Overflow'Identity,
"Insert",
BSE.Full);
Obj.Start := ((Obj.Start - 2) mod Obj.Maximum_Size) + 1;
Obj.Size := Obj.Size + 1;
Obj.Elems (Obj.Start) := Elem;
end Insert;
procedure Insert (Obj : in out Bnd_Node; Elem : Item; Before : Positive) is
begin
Assert (Before <= Obj.Size,
BC.Range_Error'Identity,
"Insert",
BSE.Invalid_Index);
Assert (Obj.Size < Obj.Maximum_Size,
BC.Overflow'Identity,
"Insert",
BSE.Full);
if Obj.Size = 0 or else Before = 1 then
Insert (Obj, Elem);
else
-- We are inserting in the middle.
--
-- In the comments below, 'left' means the part of Elems
-- before the element which the new entry is to be inserted
-- before (indexed by Actual), 'right' means the part after.
declare
Start : Elem_Range renames Obj.Start;
Actual : constant Elem_Range
:= ((Start - 1 + Before - 1) mod Obj.Maximum_Size) + 1;
Last : constant Elem_Range
:= ((Start - 1 + Obj.Size - 1) mod Obj.Maximum_Size) + 1;
begin
if Start = 1 or else Start > Actual then
-- the left part is wedged, shift the right part up
Obj.Elems (Actual + 1 .. Last + 1)
:= Obj.Elems (Actual .. Last);
Obj.Elems (Actual) := Elem;
elsif (Last = Obj.Elems'Last or else Last < Actual) then
-- the right part is wedged, shift the left part down
Obj.Elems (Start - 1 .. Actual - 2)
:= Obj.Elems (Start .. Actual - 1);
Start := Start - 1;
Obj.Elems (Actual - 1) := Elem;
elsif Before < Obj.Size / 2 then
-- the left part is shorter, shift it down
Obj.Elems (Start - 1 .. Actual - 2)
:= Obj.Elems (Start .. Actual - 1);
Start := Start - 1;
Obj.Elems (Actual - 1) := Elem;
else
-- the right part is shorter, shift it up
Obj.Elems (Actual + 1 .. Last + 1)
:= Obj.Elems (Actual .. Last);
Obj.Elems (Actual) := Elem;
end if;
Obj.Size := Obj.Size + 1;
end;
end if;
end Insert;
procedure Append (Obj : in out Bnd_Node; Elem : Item) is
begin
Assert (Obj.Size < Obj.Maximum_Size,
BC.Overflow'Identity,
"Append",
BSE.Full);
Obj.Size := Obj.Size + 1;
Obj.Elems (((Obj.Start - 1 + Obj.Size - 1) mod Obj.Maximum_Size) + 1)
:= 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 < Obj.Maximum_Size,
BC.Overflow'Identity,
"Append",
BSE.Full);
if Obj.Size = 0 or else After = Obj.Size then
Append (Obj, Elem);
else
Insert (Obj, Elem, Before => After + 1);
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);
-- XXX can this ever happen, given the test above?
Assert (Obj.Size > 0,
BC.Underflow'Identity,
"Remove",
BSE.Empty);
if Obj.Size = 1 then
Clear (Obj);
elsif From = 1 then
Obj.Start := (Obj.Start mod Obj.Maximum_Size) + 1;
Obj.Size := Obj.Size - 1;
elsif From = Obj.Size then
Obj.Size := Obj.Size - 1;
else
-- We are removing from the middle.
--
-- In the comments below, 'left' means the part of Elems
-- before the element to be removed (indexed by Actual),
-- 'right' means the part after.
declare
Start : Elem_Range renames Obj.Start;
Actual : constant Elem_Range
:= ((Start - 1 + From - 1) mod Obj.Maximum_Size) + 1;
Last : constant Elem_Range
:= ((Start - 1 + Obj.Size - 1) mod Obj.Maximum_Size) + 1;
begin
if Start > Actual then
-- the left part wraps round; shift the right part down
Obj.Elems (Actual .. Last - 1)
:= Obj.Elems (Actual + 1 .. Last);
elsif Actual > Last then
-- the right part wraps round; shift the left part up
Obj.Elems (Start + 1 .. Actual)
:= Obj.Elems (Start .. Actual - 1);
Start := Start + 1;
elsif Obj.Maximum_Size > 1 and then From < Obj.Size / 2 then
-- the left part is shorter
Obj.Elems (Start + 1 .. Actual)
:= Obj.Elems (Start .. Actual - 1);
Start := Start + 1;
else
-- the right part is shorter
Obj.Elems (Actual .. Last - 1)
:= Obj.Elems (Actual + 1 .. Last);
end if;
Obj.Size := Obj.Size - 1;
end;
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 (((Obj.Start - 1 + Index - 1) mod Obj.Maximum_Size) + 1)
:= Elem;
end Replace;
function Available (Obj : Bnd_Node) return Natural is
begin
return Obj.Maximum_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 (Obj.Start);
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.Start - 1 + Obj.Size - 1) mod Obj.Maximum_Size) + 1);
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
(((Obj.Start - 1 + Index - 1) mod Obj.Maximum_Size) + 1);
end Item_At;
function Item_At (Obj : Bnd_Node; Index : Positive) return Item_Ptr is
-- 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.
begin
Assert (Index in 1 .. Obj.Size,
BC.Range_Error'Identity,
"Item_At",
BSE.Invalid_Index);
return Item_Ptr
(Allow_Element_Access.To_Pointer
(Obj.Elems (((Obj.Start - 1 + Index - 1) mod Obj.Maximum_Size) + 1)
'Address));
end Item_At;
function Location (Obj : Bnd_Node;
Elem : Item;
Start : Positive := 1) return Natural is
begin
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 (((Obj.Start - 1 + I - 1) mod Obj.Maximum_Size) + 1)
= Elem then
return I;
end if;
end loop;
return 0;
end Location;
-- OA wants this to be after Item_At, so it can inline it.
function "=" (Left, Right : Bnd_Node) return Boolean is
begin
if Left.Size /= Right.Size then
return False;
else
for I in 1 .. Left.Size loop
if Item'(Item_At (Left, I)) /= Item'(Item_At (Right, I)) then
return False;
end if;
end loop;
return True;
end if;
end "=";
procedure Write_Bnd_Node
(Stream : access Ada.Streams.Root_Stream_Type'Class;
Obj : Bnd_Node) is
begin
Integer'Write (Stream, Obj.Maximum_Size);
Integer'Write (Stream, Obj.Size);
for I in 1 .. Obj.Size loop
Item'Output (Stream, Item_At (Obj, I));
end loop;
end Write_Bnd_Node;
procedure Read_Bnd_Node
(Stream : access Ada.Streams.Root_Stream_Type'Class;
Obj : out Bnd_Node) is
Count : Integer;
begin
Integer'Read (Stream, Count);
declare
Result : Bnd_Node (Count);
begin
Integer'Read (Stream, Count);
for I in 1 .. Count loop
declare
Elem : constant Item := Item'Input (Stream);
begin
Append (Result, Elem);
end;
end loop;
Obj := Result;
end;
end Read_Bnd_Node;
end BC.Support.Bounded;
syntax highlighted by Code2HTML, v. 0.9.1