File : pragmarc-list_bounded_unprotected.adb
-- PragmAda Reusable Component (PragmARC)
-- Copyright (C) 2002 by PragmAda Software Engineering. All rights reserved.
-- **************************************************************************
--
-- History:
-- 2002 Oct 01 J. Carter V1.1--Added Context to Iterate; protected list IDs; use mode out to allow scalars
-- 2002 May 01 J. Carter V1.0--Initial release
--
with System;
package body PragmARC.List_Bounded_Unprotected is
Invalid_Pos : constant Position := (ID => Invalid_ID, Pos => Null_Position);
procedure Assign (To : out Handle; From : in Handle) is
From_Pos : Natural := From.Head;
To_Pos : Natural := To.Storage'First;
begin -- Assign
if To.ID = From.ID then -- These are the same list
return;
end if;
if To.Max_Size < Length (From) then
raise Too_Short;
end if;
Clear (List => To);
Copy : loop
exit Copy when From_Pos = Null_Position;
Assign (To => To.Storage (To_Pos).Value, From => From.Storage (From_Pos).Value );
To.Storage (To_Pos).Prev := To_Pos - 1;
To.Storage (To_Pos).ID := To.ID;
if To_Pos /= To.Storage'First then
To.Storage (To_Pos - 1).Next := To_Pos;
end if;
To.Storage (To_Pos).Next := Null_Position;
if To_Pos = To.Storage'First then
To.Head := To_Pos;
end if;
To_Pos := To_Pos + 1;
From_Pos := From.Storage (From_Pos).Next;
end loop Copy;
To.Tail := To_Pos - 1;
To.Free := To_Pos;
end Assign;
protected ID_Supply is
pragma Priority (System.Priority'Last);
procedure Get (ID : out List_ID);
private -- ID_Supply
Last_ID : List_ID := Invalid_ID;
end ID_Supply;
procedure Clear (List : in out Handle) is
-- null;
begin -- Clear
List.Head := Null_Position;
List.Tail := Null_Position;
List.Free := List.Storage'First;
if List.ID = Invalid_ID then
ID_Supply.Get (ID => List.ID);
end if;
Clear_Storage : for I in List.Storage'range loop
List.Storage (I).Prev := Null_Position;
List.Storage (I).Next := I + 1;
List.Storage (I).ID := Invalid_ID;
end loop Clear_Storage;
List.Storage (List.Storage'Last).Next := Null_Position;
end Clear;
function First (List : Handle) return Position is
-- null;
begin -- First
return (ID => List.ID, Pos => List.Head);
end First;
function Last (List : Handle) return Position is
-- null;
begin -- Last
return (ID => List.ID, Pos => List.Tail);
end Last;
function Off_List (List : Handle) return Position is
-- null;
begin -- Off_List
return (ID => List.ID, Pos => Null_Position);
end Off_List;
function Next (Pos : Position; List : Handle) return Position is
-- null;
begin -- Next
if Pos.ID /= List.ID then
raise Invalid_Position;
end if;
if Pos.Pos = Null_Position then
return (ID => List.ID, Pos => List.Head);
else
return (ID => List.ID, Pos => List.Storage (Pos.Pos).Next);
end if;
end Next;
function Prev (Pos : Position; List : Handle) return Position is
-- null;
begin -- Prev
if Pos.ID /= List.ID then
raise Invalid_Position;
end if;
if Pos.Pos = Null_Position then
return (ID => List.ID, Pos => List.Tail);
else
return (ID => List.ID, Pos => List.Storage (Pos.Pos).Prev);
end if;
end Prev;
procedure Insert (Into : in out Handle; Item : in Element; Before : in Position; New_Pos : out Position) is
Prev : Natural;
begin -- Insert
if Into.Free = Null_Position then
raise Full;
end if;
-- Special case: Into is empty; Before must be Off_List
if Into.Head = Null_Position then
if Before /= (ID => Into.ID, Pos => Null_Position) then
raise Invalid_Position;
end if;
New_Pos := (ID => Into.ID, Pos => Into.Free);
Into.Free := Into.Storage (Into.Free).Next;
Assign (To => Into.Storage (New_Pos.Pos).Value, From => Item);
Into.Head := New_Pos.Pos;
Into.Tail := New_Pos.Pos;
Into.Storage (New_Pos.Pos).Prev := Null_Position;
Into.Storage (New_Pos.Pos).Next := Null_Position;
Into.Storage (New_Pos.Pos).ID := Into.ID;
return;
end if;
if Before = (ID => Into.ID, Pos => Null_Position) then -- Same as Append after Last
Append (Into => Into, Item => Item, After => (ID => Into.ID, Pos => Into.Tail), New_Pos => New_Pos);
return;
end if;
if Before.ID /= Into.ID or Before.Pos not in Into.Storage'range then
raise Invalid_Position;
end if;
New_Pos := (ID => Into.ID, Pos => Into.Free);
Into.Free := Into.Storage (Into.Free).Next;
Assign (To => Into.Storage (New_Pos.Pos).Value, From => Item);
Into.Storage (New_Pos.Pos).Next := Before.Pos;
Into.Storage (New_Pos.Pos).Prev := Into.Storage (Before.Pos).Prev;
Into.Storage (Before.Pos).Prev := New_Pos.Pos;
Into.Storage (New_Pos.Pos).ID := Into.ID;
Prev := Into.Storage (New_Pos.Pos).Prev;
if Prev = Null_Position then
Into.Head := New_Pos.Pos;
else
Into.Storage (Prev).Next := New_Pos.Pos;
end if;
if Into.Storage (New_Pos.Pos).Next = Null_Position then
Into.Tail := New_Pos.Pos;
end if;
end Insert;
procedure Append (Into : in out Handle; Item : in Element; After : in Position; New_Pos : out Position) is
Next : Natural;
begin -- Append
if Into.Free = Null_Position then
raise Full;
end if;
-- Special case: Into is empty; same as Insert
if Into.Head = Null_Position then
Insert (Into => Into, Item => Item, Before => After, New_Pos => New_Pos);
return;
end if;
if After = (ID => Into.ID, Pos => Null_Position) then -- Same as Insert before First
Insert (Into => Into, Item => Item, Before => (ID => Into.ID, Pos => Into.Head), New_Pos => New_Pos);
return;
end if;
if After.ID /= Into.ID or After.Pos not in Into.Storage'range then
raise Invalid_Position;
end if;
New_Pos := (ID => Into.ID, Pos => Into.Free);
Into.Free := Into.Storage (Into.Free).Next;
Assign (To => Into.Storage (New_Pos.Pos).Value, From => Item);
Into.Storage (New_Pos.Pos).Prev := After.Pos;
Into.Storage (New_Pos.Pos).Next := Into.Storage (After.Pos).Next;
Into.Storage (After.Pos).Next := New_Pos.Pos;
Into.Storage (New_Pos.Pos).ID := Into.ID;
Next := Into.Storage (New_Pos.Pos).Next;
if Next = Null_Position then
Into.Tail := New_Pos.Pos;
else
Into.Storage (Next).Prev := New_Pos.Pos;
end if;
if Into.Storage (New_Pos.Pos).Prev = Null_Position then
Into.Head := New_Pos.Pos;
end if;
end Append;
procedure Delete (From : in out Handle; Pos : in out Position) is
Prev : Natural;
Next : Natural;
begin -- Delete
if Pos.ID /= From.ID or (Pos.Pos not in From.Storage'range or else From.Storage (Pos.Pos).ID /= From.ID) then
raise Invalid_Position;
end if;
Prev := From.Storage (Pos.Pos).Prev;
Next := From.Storage (Pos.Pos).Next;
if From.Head = Pos.Pos then
From.Head := Next;
end if;
if From.Head = Null_Position then -- List is now empty
Clear (List => From);
else
if From.Tail = Pos.Pos then
From.Tail := Prev;
end if;
if Prev /= Null_Position then
From.Storage (Prev).Next := Next;
end if;
if Next /= Null_Position then
From.Storage (Next).Prev := Prev;
end if;
From.Storage (Pos.Pos).Prev := Null_Position;
From.Storage (Pos.Pos).Next := From.Free;
From.Storage (Pos.Pos).ID := Invalid_ID;
From.Free := Pos.Pos;
end if;
Pos := Invalid_Pos;
end Delete;
function Get (From : Handle; Pos : Position) return Element is
-- null;
begin -- Get
if Pos.ID /= From.ID or (Pos.Pos not in From.Storage'range or else From.Storage (Pos.Pos).ID /= From.ID) then
raise Invalid_Position;
end if;
return From.Storage (Pos.Pos).Value;
end Get;
procedure Put (Into : in out Handle; Pos : in Position; Item : in Element) is
-- null;
begin -- Put
if Pos.ID /= Into.ID or (Pos.Pos not in Into.Storage'range or else Into.Storage (Pos.Pos).ID /= Into.ID) then
raise Invalid_Position;
end if;
Assign (To => Into.Storage (Pos.Pos).Value, From => Item);
end Put;
function Is_Empty (List : Handle) return Boolean is
-- null;
begin -- Is_Empty
return List.Head = Null_Position;
end Is_Empty;
function Is_Full (List : Handle) return Boolean is
-- null;
begin -- Is_Full
return List.Free = Null_Position;
end Is_Full;
function Length (List : Handle) return Natural is
Result : Natural := 0;
Pos : Natural := List.Head;
begin -- Length
Count : loop
exit Count when Pos = Null_Position;
Result := Result + 1;
Pos := List.Storage (Pos).Next;
end loop Count;
return Result;
end Length;
procedure Iterate (Over : in out Handle; Context : in out Context_Data) is
Pos : Natural := Over.Head;
Continue : Boolean;
begin
All_Nodes : loop
exit All_Nodes when Pos = Null_Position;
Action (Item => Over.Storage (Pos).Value, Context => Context, Pos => (ID => Over.ID, Pos => Pos), Continue => Continue);
exit All_Nodes when not Continue;
Pos := Over.Storage (Pos).Next;
end loop All_Nodes;
end Iterate;
procedure Initialize (Object : in out Handle) renames Clear;
protected body ID_Supply is
procedure Get (ID : out List_ID) is
-- null;
begin -- Get
Last_ID := Last_ID + 1;
if Last_ID = Invalid_ID then
Last_ID := Invalid_ID + 1;
end if;
ID := Last_ID;
end Get;
end ID_Supply;
end PragmARC.List_Bounded_Unprotected;
--
-- This 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 software is distributed in the hope that it will be useful, but WITH
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-- for more details. 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