-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.DOUBLY_LINKED_LISTS --
+-- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- Local Subprograms --
-----------------------
- procedure Delete_Node
- (Container : in out List;
- Node : in out Node_Access);
-
procedure Insert_Internal
(Container : in out List;
Before : Node_Access;
------------
procedure Adjust (Container : in out List) is
- Src : Node_Access := Container.First;
- Length : constant Count_Type := Container.Length;
+ Src : Node_Access := Container.First;
begin
if Src = null then
pragma Assert (Container.Last = null);
- pragma Assert (Length = 0);
+ pragma Assert (Container.Length = 0);
+ pragma Assert (Container.Busy = 0);
+ pragma Assert (Container.Lock = 0);
return;
end if;
pragma Assert (Container.First.Prev = null);
pragma Assert (Container.Last.Next = null);
- pragma Assert (Length > 0);
+ pragma Assert (Container.Length > 0);
Container.First := null;
Container.Last := null;
Container.Length := 0;
+ Container.Busy := 0;
+ Container.Lock := 0;
Container.First := new Node_Type'(Src.Element, null, null);
-
Container.Last := Container.First;
- loop
- Container.Length := Container.Length + 1;
- Src := Src.Next;
- exit when Src = null;
+ Container.Length := 1;
+
+ Src := Src.Next;
+
+ while Src /= null loop
Container.Last.Next := new Node_Type'(Element => Src.Element,
Prev => Container.Last,
Next => null);
Container.Last := Container.Last.Next;
- end loop;
+ Container.Length := Container.Length + 1;
- pragma Assert (Container.Length = Length);
+ Src := Src.Next;
+ end loop;
end Adjust;
------------
procedure Append
(Container : in out List;
New_Item : Element_Type;
- Count : Count_Type := 1)
- is
+ Count : Count_Type := 1) is
begin
Insert (Container, No_Element, New_Item, Count);
end Append;
-----------
procedure Clear (Container : in out List) is
+ X : Node_Access;
+
begin
- Delete_Last (Container, Count => Container.Length);
+ if Container.Length = 0 then
+ pragma Assert (Container.First = null);
+ pragma Assert (Container.Last = null);
+ pragma Assert (Container.Busy = 0);
+ pragma Assert (Container.Lock = 0);
+ return;
+ end if;
+
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ while Container.Length > 1 loop
+ X := Container.First;
+ pragma Assert (X.Next.Prev = Container.First);
+
+ Container.First := X.Next;
+ X.Next := null; -- prevent mischief
+
+ Container.First.Prev := null;
+ Container.Length := Container.Length - 1;
+
+ Free (X);
+ end loop;
+
+ X := Container.First;
+ pragma Assert (X = Container.Last);
+
+ Container.First := null;
+ Container.Last := null;
+ Container.Length := 0;
+
+ Free (X);
end Clear;
--------------
function Contains
(Container : List;
- Item : Element_Type) return Boolean
- is
+ Item : Element_Type) return Boolean is
begin
return Find (Container, Item) /= No_Element;
end Contains;
Position : in out Cursor;
Count : Count_Type := 1)
is
+ X : Node_Access;
+
begin
- if Position = No_Element then
- return;
+ if Position.Node = null then
+ pragma Assert (Position.Container = null);
+ raise Constraint_Error;
end if;
if Position.Container /= List_Access'(Container'Unchecked_Access) then
raise Program_Error;
end if;
+ pragma Assert (Container.Length > 0);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Container.Last);
+
+ if Position.Node = Container.First then
+ Delete_First (Container, Count);
+ Position := First (Container);
+ return;
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
for Index in 1 .. Count loop
- Delete_Node (Container, Position.Node);
+ X := Position.Node;
+ Container.Length := Container.Length - 1;
- if Position.Node = null then
- Position.Container := null;
+ if X = Container.Last then
+ Position := No_Element;
+
+ Container.Last := X.Prev;
+ Container.Last.Next := null;
+
+ X.Prev := null; -- prevent mischief
+ Free (X);
return;
end if;
+
+ Position.Node := X.Next;
+
+ X.Next.Prev := X.Prev;
+ X.Prev.Next := X.Next;
+
+ X.Next := null;
+ X.Prev := null;
+ Free (X);
end loop;
end Delete;
(Container : in out List;
Count : Count_Type := 1)
is
- Node : Node_Access := Container.First;
+ X : Node_Access;
+
begin
- for J in 1 .. Count_Type'Min (Count, Container.Length) loop
- Delete_Node (Container, Node);
+ if Count >= Container.Length then
+ Clear (Container);
+ return;
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ for I in 1 .. Count loop
+ X := Container.First;
+ pragma Assert (X.Next.Prev = Container.First);
+
+ Container.First := X.Next;
+ Container.First.Prev := null;
+
+ Container.Length := Container.Length - 1;
+
+ X.Next := null; -- prevent mischief
+ Free (X);
end loop;
end Delete_First;
(Container : in out List;
Count : Count_Type := 1)
is
- Node : Node_Access;
- begin
- for J in 1 .. Count_Type'Min (Count, Container.Length) loop
- Node := Container.Last;
- Delete_Node (Container, Node);
- end loop;
- end Delete_Last;
-
- -----------------
- -- Delete_Node --
- -----------------
-
- procedure Delete_Node
- (Container : in out List;
- Node : in out Node_Access)
- is
- X : Node_Access := Node;
+ X : Node_Access;
begin
- Node := X.Next;
- Container.Length := Container.Length - 1;
+ if Count >= Container.Length then
+ Clear (Container);
+ return;
+ end if;
- if X = Container.First then
- Container.First := X.Next;
+ if Count = 0 then
+ return;
+ end if;
- if X = Container.Last then
- pragma Assert (Container.First = null);
- pragma Assert (Container.Length = 0);
- Container.Last := null;
- else
- pragma Assert (Container.Length > 0);
- Container.First.Prev := null;
- end if;
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
- elsif X = Container.Last then
- pragma Assert (Container.Length > 0);
+ for I in 1 .. Count loop
+ X := Container.Last;
+ pragma Assert (X.Prev.Next = Container.Last);
Container.Last := X.Prev;
Container.Last.Next := null;
- else
- pragma Assert (Container.Length > 0);
+ Container.Length := Container.Length - 1;
- X.Next.Prev := X.Prev;
- X.Prev.Next := X.Next;
- end if;
-
- Free (X);
- end Delete_Node;
+ X.Prev := null; -- prevent mischief
+ Free (X);
+ end loop;
+ end Delete_Last;
-------------
-- Element --
function Element (Position : Cursor) return Element_Type is
begin
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
return Position.Node.Element;
end Element;
begin
if Node = null then
Node := Container.First;
- elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
- raise Program_Error;
+ else
+ if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Container.Length > 0);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Container.Last);
end if;
while Node /= null loop
return Container.First.Element;
end First_Element;
- -------------------
- -- Generic_Merge --
- -------------------
+ ---------------------
+ -- Generic_Sorting --
+ ---------------------
- procedure Generic_Merge
- (Target : in out List;
- Source : in out List)
- is
- LI : Cursor := First (Target);
- RI : Cursor := First (Source);
+ package body Generic_Sorting is
- begin
- if Target'Address = Source'Address then
- return;
- end if;
+ ---------------
+ -- Is_Sorted --
+ ---------------
- while RI.Node /= null loop
- if LI.Node = null then
- Splice (Target, No_Element, Source);
+ function Is_Sorted (Container : List) return Boolean is
+ Node : Node_Access := Container.First;
+
+ begin
+ for I in 2 .. Container.Length loop
+ if Node.Next.Element < Node.Element then
+ return False;
+ end if;
+
+ Node := Node.Next;
+ end loop;
+
+ return True;
+ end Is_Sorted;
+
+ -----------
+ -- Merge --
+ -----------
+
+ procedure Merge
+ (Target : in out List;
+ Source : in out List)
+ is
+ LI : Cursor := First (Target);
+ RI : Cursor := First (Source);
+
+ begin
+ if Target'Address = Source'Address then
return;
end if;
- if RI.Node.Element < LI.Node.Element then
- declare
- RJ : constant Cursor := RI;
- begin
- RI.Node := RI.Node.Next;
- Splice (Target, LI, Source, RJ);
- end;
-
- else
- LI.Node := LI.Node.Next;
+ if Target.Busy > 0
+ or else Source.Busy > 0
+ then
+ raise Program_Error;
end if;
- end loop;
- end Generic_Merge;
- ------------------
- -- Generic_Sort --
- ------------------
+ while RI.Node /= null loop
+ if LI.Node = null then
+ Splice (Target, No_Element, Source);
+ return;
+ end if;
+
+ if RI.Node.Element < LI.Node.Element then
+ declare
+ RJ : Cursor := RI;
+ begin
+ RI.Node := RI.Node.Next;
+ Splice (Target, LI, Source, RJ);
+ end;
+
+ else
+ LI.Node := LI.Node.Next;
+ end if;
+ end loop;
+ end Merge;
- procedure Generic_Sort (Container : in out List) is
+ ----------
+ -- Sort --
+ ----------
- procedure Partition
- (Pivot : in Node_Access;
- Back : in Node_Access);
+ procedure Sort (Container : in out List) is
- procedure Sort (Front, Back : Node_Access);
+ procedure Partition
+ (Pivot : in Node_Access;
+ Back : in Node_Access);
- ---------------
- -- Partition --
- ---------------
+ procedure Sort (Front, Back : Node_Access);
- procedure Partition
- (Pivot : Node_Access;
- Back : Node_Access)
- is
- Node : Node_Access := Pivot.Next;
+ ---------------
+ -- Partition --
+ ---------------
- begin
- while Node /= Back loop
- if Node.Element < Pivot.Element then
- declare
- Prev : constant Node_Access := Node.Prev;
- Next : constant Node_Access := Node.Next;
+ procedure Partition
+ (Pivot : Node_Access;
+ Back : Node_Access)
+ is
+ Node : Node_Access := Pivot.Next;
- begin
- Prev.Next := Next;
+ begin
+ while Node /= Back loop
+ if Node.Element < Pivot.Element then
+ declare
+ Prev : constant Node_Access := Node.Prev;
+ Next : constant Node_Access := Node.Next;
- if Next = null then
- Container.Last := Prev;
- else
- Next.Prev := Prev;
- end if;
+ begin
+ Prev.Next := Next;
- Node.Next := Pivot;
- Node.Prev := Pivot.Prev;
+ if Next = null then
+ Container.Last := Prev;
+ else
+ Next.Prev := Prev;
+ end if;
- Pivot.Prev := Node;
+ Node.Next := Pivot;
+ Node.Prev := Pivot.Prev;
- if Node.Prev = null then
- Container.First := Node;
- else
- Node.Prev.Next := Node;
- end if;
+ Pivot.Prev := Node;
- Node := Next;
- end;
+ if Node.Prev = null then
+ Container.First := Node;
+ else
+ Node.Prev.Next := Node;
+ end if;
+
+ Node := Next;
+ end;
+ else
+ Node := Node.Next;
+ end if;
+ end loop;
+ end Partition;
+
+ ----------
+ -- Sort --
+ ----------
+
+ procedure Sort (Front, Back : Node_Access) is
+ Pivot : Node_Access;
+
+ begin
+ if Front = null then
+ Pivot := Container.First;
else
- Node := Node.Next;
+ Pivot := Front.Next;
end if;
- end loop;
- end Partition;
- ----------
- -- Sort --
- ----------
+ if Pivot /= Back then
+ Partition (Pivot, Back);
+ Sort (Front, Pivot);
+ Sort (Pivot, Back);
+ end if;
+ end Sort;
- procedure Sort (Front, Back : Node_Access) is
- Pivot : Node_Access;
+ -- Start of processing for Sort
begin
- if Front = null then
- Pivot := Container.First;
- else
- Pivot := Front.Next;
+ if Container.Length <= 1 then
+ return;
end if;
- if Pivot /= Back then
- Partition (Pivot, Back);
- Sort (Front, Pivot);
- Sort (Pivot, Back);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ if Container.Busy > 0 then
+ raise Program_Error;
end if;
- end Sort;
- -- Start of processing for Generic_Sort
+ Sort (Front => null, Back => null);
- begin
- Sort (Front => null, Back => null);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+ end Sort;
- pragma Assert (Container.Length = 0
- or else
- (Container.First.Prev = null
- and then Container.Last.Next = null));
- end Generic_Sort;
+ end Generic_Sorting;
-----------------
-- Has_Element --
function Has_Element (Position : Cursor) return Boolean is
begin
- return Position.Container /= null and then Position.Node /= null;
+ if Position.Node = null then
+ pragma Assert (Position.Container = null);
+ return False;
+ end if;
+
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
+ return True;
end Has_Element;
------------
New_Node : Node_Access;
begin
- if Before.Container /= null
- and then Before.Container /= List_Access'(Container'Unchecked_Access)
- then
- raise Program_Error;
+ if Before.Node /= null then
+ if Before.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Container.Length > 0);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ pragma Assert (Before.Node.Prev = null
+ or else Before.Node.Prev.Next = Before.Node);
+ pragma Assert (Before.Node.Next = null
+ or else Before.Node.Next.Prev = Before.Node);
+ pragma Assert (Before.Node.Prev /= null
+ or else Before.Node = Container.First);
+ pragma Assert (Before.Node.Next /= null
+ or else Before.Node = Container.Last);
end if;
if Count = 0 then
return;
end if;
+ if Container.Length > Count_Type'Last - Count then
+ raise Constraint_Error;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
New_Node := new Node_Type'(New_Item, null, null);
Insert_Internal (Container, Before.Node, New_Node);
- Position := Cursor'(Before.Container, New_Node);
+ Position := Cursor'(Container'Unchecked_Access, New_Node);
for J in Count_Type'(2) .. Count loop
New_Node := new Node_Type'(New_Item, null, null);
New_Node : Node_Access;
begin
- if Before.Container /= null
- and then Before.Container /= List_Access'(Container'Unchecked_Access)
- then
- raise Program_Error;
+ if Before.Node /= null then
+ if Before.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Container.Length > 0);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ pragma Assert (Before.Node.Prev = null
+ or else Before.Node.Prev.Next = Before.Node);
+ pragma Assert (Before.Node.Next = null
+ or else Before.Node.Next.Prev = Before.Node);
+ pragma Assert (Before.Node.Prev /= null
+ or else Before.Node = Container.First);
+ pragma Assert (Before.Node.Next /= null
+ or else Before.Node = Container.Last);
end if;
if Count = 0 then
return;
end if;
+ if Container.Length > Count_Type'Last - Count then
+ raise Constraint_Error;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
New_Node := new Node_Type;
Insert_Internal (Container, Before.Node, New_Node);
- Position := Cursor'(Before.Container, New_Node);
+ Position := Cursor'(Container'Unchecked_Access, New_Node);
for J in Count_Type'(2) .. Count loop
New_Node := new Node_Type;
(Container : List;
Process : not null access procedure (Position : Cursor))
is
+ C : List renames Container'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+
Node : Node_Access := Container.First;
+
begin
- while Node /= null loop
- Process (Cursor'(Container'Unchecked_Access, Node));
- Node := Node.Next;
- end loop;
+ B := B + 1;
+
+ begin
+ while Node /= null loop
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ Node := Node.Next;
+ end loop;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
----------
return;
end if;
- if Target.Length > 0 then
- raise Constraint_Error;
+ if Source.Busy > 0 then
+ raise Program_Error;
end if;
+ Clear (Target);
+
Target.First := Source.First;
Source.First := null;
procedure Next (Position : in out Cursor) is
begin
if Position.Node = null then
+ pragma Assert (Position.Container = null);
return;
end if;
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
Position.Node := Position.Node.Next;
if Position.Node = null then
function Next (Position : Cursor) return Cursor is
begin
if Position.Node = null then
+ pragma Assert (Position.Container = null);
return No_Element;
end if;
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
declare
Next_Node : constant Node_Access := Position.Node.Next;
begin
procedure Previous (Position : in out Cursor) is
begin
if Position.Node = null then
+ pragma Assert (Position.Container = null);
return;
end if;
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
Position.Node := Position.Node.Prev;
if Position.Node = null then
function Previous (Position : Cursor) return Cursor is
begin
if Position.Node = null then
+ pragma Assert (Position.Container = null);
return No_Element;
end if;
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
declare
Prev_Node : constant Node_Access := Position.Node.Prev;
begin
(Position : Cursor;
Process : not null access procedure (Element : in Element_Type))
is
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
+ E : Element_Type renames Position.Node.Element;
+
+ C : List renames Position.Container.all'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+
begin
- Process (Position.Node.Element);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Query_Element;
----------
X : Node_Access;
begin
- Clear (Item); -- ???
+ Clear (Item);
Count_Type'Base'Read (Stream, N);
if N = 0 then
(Position : Cursor;
By : Element_Type)
is
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
+ E : Element_Type renames Position.Node.Element;
+
begin
- Position.Node.Element := By;
+ if Position.Container.Lock > 0 then
+ raise Program_Error;
+ end if;
+
+ E := By;
end Replace_Element;
------------------
begin
if Node = null then
Node := Container.Last;
- elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
- raise Program_Error;
+ else
+ if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Container.Length > 0);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Container.Last);
end if;
while Node /= null loop
(Container : List;
Process : not null access procedure (Position : Cursor))
is
+ C : List renames Container'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+
Node : Node_Access := Container.Last;
+
begin
- while Node /= null loop
- Process (Cursor'(Container'Unchecked_Access, Node));
- Node := Node.Prev;
- end loop;
+ B := B + 1;
+
+ begin
+ while Node /= null loop
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ Node := Node.Prev;
+ end loop;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
------------------
return;
end if;
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
Container.First := J;
Container.Last := I;
loop
Source : in out List)
is
begin
- if Before.Container /= null
- and then Before.Container /= List_Access'(Target'Unchecked_Access)
- then
- raise Program_Error;
+ if Before.Node /= null then
+ if Before.Container /= List_Access'(Target'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Target.Length >= 1);
+ pragma Assert (Target.First.Prev = null);
+ pragma Assert (Target.Last.Next = null);
+
+ pragma Assert (Before.Node.Prev = null
+ or else Before.Node.Prev.Next = Before.Node);
+ pragma Assert (Before.Node.Next = null
+ or else Before.Node.Next.Prev = Before.Node);
+ pragma Assert (Before.Node.Prev /= null
+ or else Before.Node = Target.First);
+ pragma Assert (Before.Node.Next /= null
+ or else Before.Node = Target.Last);
end if;
if Target'Address = Source'Address
return;
end if;
+ pragma Assert (Source.First.Prev = null);
+ pragma Assert (Source.Last.Next = null);
+
+ if Target.Length > Count_Type'Last - Source.Length then
+ raise Constraint_Error;
+ end if;
+
+ if Target.Busy > 0
+ or else Source.Busy > 0
+ then
+ raise Program_Error;
+ end if;
+
if Target.Length = 0 then
+ pragma Assert (Target.First = null);
+ pragma Assert (Target.Last = null);
pragma Assert (Before = No_Element);
Target.First := Source.First;
Target.First := Source.First;
else
+ pragma Assert (Target.Length >= 2);
+
Before.Node.Prev.Next := Source.First;
Source.First.Prev := Before.Node.Prev;
Before : Cursor;
Position : Cursor)
is
- X : Node_Access := Position.Node;
-
begin
- if Before.Container /= null
- and then Before.Container /= List_Access'(Target'Unchecked_Access)
- then
- raise Program_Error;
+ if Before.Node /= null then
+ if Before.Container /= List_Access'(Target'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Target.Length >= 1);
+ pragma Assert (Target.First.Prev = null);
+ pragma Assert (Target.Last.Next = null);
+
+ pragma Assert (Before.Node.Prev = null
+ or else Before.Node.Prev.Next = Before.Node);
+ pragma Assert (Before.Node.Next = null
+ or else Before.Node.Next.Prev = Before.Node);
+ pragma Assert (Before.Node.Prev /= null
+ or else Before.Node = Target.First);
+ pragma Assert (Before.Node.Next /= null
+ or else Before.Node = Target.Last);
end if;
- if Position.Container /= null
- and then Position.Container /= List_Access'(Target'Unchecked_Access)
- then
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= List_Access'(Target'Unchecked_Access) then
raise Program_Error;
end if;
- if X = null
- or else X = Before.Node
- or else X.Next = Before.Node
+ pragma Assert (Target.Length >= 1);
+ pragma Assert (Target.First.Prev = null);
+ pragma Assert (Target.Last.Next = null);
+
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Target.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Target.Last);
+
+ if Position.Node = Before.Node
+ or else Position.Node.Next = Before.Node
then
return;
end if;
- pragma Assert (Target.Length > 0);
+ pragma Assert (Target.Length >= 2);
+
+ if Target.Busy > 0 then
+ raise Program_Error;
+ end if;
if Before.Node = null then
- pragma Assert (X /= Target.Last);
+ pragma Assert (Position.Node /= Target.Last);
- if X = Target.First then
- Target.First := X.Next;
+ if Position.Node = Target.First then
+ Target.First := Position.Node.Next;
Target.First.Prev := null;
else
- X.Prev.Next := X.Next;
- X.Next.Prev := X.Prev;
+ Position.Node.Prev.Next := Position.Node.Next;
+ Position.Node.Next.Prev := Position.Node.Prev;
end if;
- Target.Last.Next := X;
- X.Prev := Target.Last;
+ Target.Last.Next := Position.Node;
+ Position.Node.Prev := Target.Last;
- Target.Last := X;
+ Target.Last := Position.Node;
Target.Last.Next := null;
return;
end if;
if Before.Node = Target.First then
- pragma Assert (X /= Target.First);
+ pragma Assert (Position.Node /= Target.First);
- if X = Target.Last then
- Target.Last := X.Prev;
+ if Position.Node = Target.Last then
+ Target.Last := Position.Node.Prev;
Target.Last.Next := null;
else
- X.Prev.Next := X.Next;
- X.Next.Prev := X.Prev;
+ Position.Node.Prev.Next := Position.Node.Next;
+ Position.Node.Next.Prev := Position.Node.Prev;
end if;
- Target.First.Prev := X;
- X.Next := Target.First;
+ Target.First.Prev := Position.Node;
+ Position.Node.Next := Target.First;
- Target.First := X;
+ Target.First := Position.Node;
Target.First.Prev := null;
return;
end if;
- if X = Target.First then
- Target.First := X.Next;
+ if Position.Node = Target.First then
+ Target.First := Position.Node.Next;
Target.First.Prev := null;
- elsif X = Target.Last then
- Target.Last := X.Prev;
+ elsif Position.Node = Target.Last then
+ Target.Last := Position.Node.Prev;
Target.Last.Next := null;
else
- X.Prev.Next := X.Next;
- X.Next.Prev := X.Prev;
+ Position.Node.Prev.Next := Position.Node.Next;
+ Position.Node.Next.Prev := Position.Node.Prev;
end if;
- Before.Node.Prev.Next := X;
- X.Prev := Before.Node.Prev;
+ Before.Node.Prev.Next := Position.Node;
+ Position.Node.Prev := Before.Node.Prev;
+
+ Before.Node.Prev := Position.Node;
+ Position.Node.Next := Before.Node;
- Before.Node.Prev := X;
- X.Next := Before.Node;
+ pragma Assert (Target.First.Prev = null);
+ pragma Assert (Target.Last.Next = null);
end Splice;
procedure Splice
(Target : in out List;
Before : Cursor;
Source : in out List;
- Position : Cursor)
+ Position : in out Cursor)
is
- X : Node_Access := Position.Node;
-
begin
if Target'Address = Source'Address then
Splice (Target, Before, Position);
return;
end if;
- if Before.Container /= null
- and then Before.Container /= List_Access'(Target'Unchecked_Access)
- then
- raise Program_Error;
+ if Before.Node /= null then
+ if Before.Container /= List_Access'(Target'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Target.Length >= 1);
+ pragma Assert (Target.First.Prev = null);
+ pragma Assert (Target.Last.Next = null);
+
+ pragma Assert (Before.Node.Prev = null
+ or else Before.Node.Prev.Next = Before.Node);
+ pragma Assert (Before.Node.Next = null
+ or else Before.Node.Next.Prev = Before.Node);
+ pragma Assert (Before.Node.Prev /= null
+ or else Before.Node = Target.First);
+ pragma Assert (Before.Node.Next /= null
+ or else Before.Node = Target.Last);
end if;
- if Position.Container /= null
- and then Position.Container /= List_Access'(Source'Unchecked_Access)
- then
- raise Program_Error;
+ if Position.Node = null then
+ raise Constraint_Error;
end if;
- if X = null then
- return;
+ if Position.Container /= List_Access'(Source'Unchecked_Access) then
+ raise Program_Error;
end if;
- pragma Assert (Source.Length > 0);
+ pragma Assert (Source.Length >= 1);
pragma Assert (Source.First.Prev = null);
pragma Assert (Source.Last.Next = null);
- if X = Source.First then
- Source.First := X.Next;
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Source.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Source.Last);
+
+ if Target.Length = Count_Type'Last then
+ raise Constraint_Error;
+ end if;
+
+ if Target.Busy > 0
+ or else Source.Busy > 0
+ then
+ raise Program_Error;
+ end if;
+
+ if Position.Node = Source.First then
+ Source.First := Position.Node.Next;
Source.First.Prev := null;
- if X = Source.Last then
+ if Position.Node = Source.Last then
pragma Assert (Source.First = null);
pragma Assert (Source.Length = 1);
Source.Last := null;
end if;
- elsif X = Source.Last then
- Source.Last := X.Prev;
+ elsif Position.Node = Source.Last then
+ pragma Assert (Source.Length >= 2);
+ Source.Last := Position.Node.Prev;
Source.Last.Next := null;
else
- X.Prev.Next := X.Next;
- X.Next.Prev := X.Prev;
+ pragma Assert (Source.Length >= 3);
+ Position.Node.Prev.Next := Position.Node.Next;
+ Position.Node.Next.Prev := Position.Node.Prev;
end if;
if Target.Length = 0 then
- pragma Assert (Before = No_Element);
pragma Assert (Target.First = null);
pragma Assert (Target.Last = null);
+ pragma Assert (Before = No_Element);
- Target.First := X;
- Target.Last := X;
+ Target.First := Position.Node;
+ Target.Last := Position.Node;
+
+ Target.First.Prev := null;
+ Target.Last.Next := null;
elsif Before.Node = null then
- Target.Last.Next := X;
- X.Next := Target.Last;
+ pragma Assert (Target.Last.Next = null);
+ Target.Last.Next := Position.Node;
+ Position.Node.Prev := Target.Last;
- Target.Last := X;
+ Target.Last := Position.Node;
Target.Last.Next := null;
elsif Before.Node = Target.First then
- Target.First.Prev := X;
- X.Next := Target.First;
+ pragma Assert (Target.First.Prev = null);
+ Target.First.Prev := Position.Node;
+ Position.Node.Next := Target.First;
- Target.First := X;
+ Target.First := Position.Node;
Target.First.Prev := null;
else
- Before.Node.Prev.Next := X;
- X.Prev := Before.Node.Prev;
+ pragma Assert (Target.Length >= 2);
+ Before.Node.Prev.Next := Position.Node;
+ Position.Node.Prev := Before.Node.Prev;
- Before.Node.Prev := X;
- X.Next := Before.Node;
+ Before.Node.Prev := Position.Node;
+ Position.Node.Next := Before.Node;
end if;
Target.Length := Target.Length + 1;
Source.Length := Source.Length - 1;
+
+ Position.Container := Target'Unchecked_Access;
end Splice;
----------
-- Swap --
----------
- -- Is this defined when I and J designate elements in different containers,
- -- or should it raise an exception (Program_Error)???
-
- procedure Swap (I, J : in Cursor) is
- EI : constant Element_Type := I.Node.Element;
+ procedure Swap (I, J : Cursor) is
begin
- I.Node.Element := J.Node.Element;
- J.Node.Element := EI;
+ if I.Container = null
+ or else J.Container = null
+ then
+ raise Constraint_Error;
+ end if;
+
+ if I.Container /= J.Container then
+ raise Program_Error;
+ end if;
+
+ declare
+ C : List renames I.Container.all;
+ begin
+ pragma Assert (C.Length >= 1);
+ pragma Assert (C.First.Prev = null);
+ pragma Assert (C.Last.Next = null);
+
+ pragma Assert (I.Node /= null);
+ pragma Assert (I.Node.Prev = null
+ or else I.Node.Prev.Next = I.Node);
+ pragma Assert (I.Node.Next = null
+ or else I.Node.Next.Prev = I.Node);
+ pragma Assert (I.Node.Prev /= null
+ or else I.Node = C.First);
+ pragma Assert (I.Node.Next /= null
+ or else I.Node = C.Last);
+
+ if I.Node = J.Node then
+ return;
+ end if;
+
+ pragma Assert (C.Length >= 2);
+ pragma Assert (J.Node /= null);
+ pragma Assert (J.Node.Prev = null
+ or else J.Node.Prev.Next = J.Node);
+ pragma Assert (J.Node.Next = null
+ or else J.Node.Next.Prev = J.Node);
+ pragma Assert (J.Node.Prev /= null
+ or else J.Node = C.First);
+ pragma Assert (J.Node.Next /= null
+ or else J.Node = C.Last);
+
+ if C.Lock > 0 then
+ raise Program_Error;
+ end if;
+
+ declare
+ EI : Element_Type renames I.Node.Element;
+ EJ : Element_Type renames J.Node.Element;
+
+ EI_Copy : constant Element_Type := EI;
+ begin
+ EI := EJ;
+ EJ := EI_Copy;
+ end;
+ end;
end Swap;
----------------
procedure Swap_Links
(Container : in out List;
- I, J : Cursor)
- is
+ I, J : Cursor) is
begin
- if I = No_Element
- or else J = No_Element
+ if I.Container = null
+ or else J.Container = null
then
raise Constraint_Error;
end if;
end if;
pragma Assert (Container.Length >= 1);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ pragma Assert (I.Node /= null);
+ pragma Assert (I.Node.Prev = null
+ or else I.Node.Prev.Next = I.Node);
+ pragma Assert (I.Node.Next = null
+ or else I.Node.Next.Prev = I.Node);
+ pragma Assert (I.Node.Prev /= null
+ or else I.Node = Container.First);
+ pragma Assert (I.Node.Next /= null
+ or else I.Node = Container.Last);
if I.Node = J.Node then
return;
pragma Assert (Container.Length >= 2);
+ pragma Assert (J.Node /= null);
+ pragma Assert (J.Node.Prev = null
+ or else J.Node.Prev.Next = J.Node);
+ pragma Assert (J.Node.Next = null
+ or else J.Node.Next.Prev = J.Node);
+ pragma Assert (J.Node.Prev /= null
+ or else J.Node = Container.First);
+ pragma Assert (J.Node.Next /= null
+ or else J.Node = Container.Last);
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
declare
I_Next : constant Cursor := Next (I);
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type)) is
+
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length >= 1);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
+ E : Element_Type renames Position.Node.Element;
+
+ C : List renames Position.Container.all'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+
begin
- Process (Position.Node.Element);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Update_Element;
-----------
end Write;
end Ada.Containers.Doubly_Linked_Lists;
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.DOUBLY_LINKED_LISTS --
+-- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
Count : Count_Type := 1);
generic
- with function "<" (Left, Right : Element_Type)
- return Boolean is <>;
- procedure Generic_Sort (Container : in out List);
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ package Generic_Sorting is
- generic
- with function "<" (Left, Right : Element_Type)
- return Boolean is <>;
- procedure Generic_Merge (Target : in out List; Source : in out List);
+ function Is_Sorted (Container : List) return Boolean;
+
+ procedure Sort (Container : in out List);
+
+ procedure Merge (Target, Source : in out List);
+
+ end Generic_Sorting;
procedure Reverse_List (Container : in out List);
- procedure Swap (I, J : in Cursor);
+ procedure Swap (I, J : Cursor);
procedure Swap_Links
(Container : in out List;
(Target : in out List;
Before : Cursor;
Source : in out List;
- Position : Cursor);
+ Position : in out Cursor);
function First (Container : List) return Cursor;
type Node_Access is access Node_Type;
type Node_Type is
- record
+ limited record
Element : Element_Type;
Next : Node_Access;
Prev : Node_Access;
end record;
- function "=" (L, R : Node_Type) return Boolean is abstract;
-
use Ada.Finalization;
type List is
First : Node_Access;
Last : Node_Access;
Length : Count_Type := 0;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
end record;
procedure Adjust (Container : in out List);
for List'Write use Write;
- Empty_List : constant List := List'(Controlled with null, null, 0);
+ Empty_List : constant List := (Controlled with null, null, 0, 0, 0);
type List_Access is access constant List;
for List_Access'Storage_Size use 0;
No_Element : constant Cursor := Cursor'(null, null);
end Ada.Containers.Doubly_Linked_Lists;
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS --
+-- A D A . C O N T A I N E R S . --
+-- H A S H _ T A B L E S . G E N E R I C _ K E Y S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
--------------------------
procedure Delete_Key_Sans_Free
- (HT : in out HT_Type;
+ (HT : in out Hash_Table_Type;
Key : Key_Type;
X : out Node_Access)
is
begin
if HT.Length = 0 then
- X := Null_Node;
+ X := null;
return;
end if;
Indx := Index (HT, Key);
X := HT.Buckets (Indx);
- if X = Null_Node then
+ if X = null then
return;
end if;
if Equivalent_Keys (Key, X) then
+ if HT.Busy > 0 then
+ raise Program_Error;
+ end if;
HT.Buckets (Indx) := Next (X);
HT.Length := HT.Length - 1;
return;
Prev := X;
X := Next (Prev);
- if X = Null_Node then
+ if X = null then
return;
end if;
if Equivalent_Keys (Key, X) then
+ if HT.Busy > 0 then
+ raise Program_Error;
+ end if;
Set_Next (Node => Prev, Next => Next (X));
HT.Length := HT.Length - 1;
return;
----------
function Find
- (HT : HT_Type;
+ (HT : Hash_Table_Type;
Key : Key_Type) return Node_Access is
Indx : Hash_Type;
begin
if HT.Length = 0 then
- return Null_Node;
+ return null;
end if;
Indx := Index (HT, Key);
Node := HT.Buckets (Indx);
- while Node /= Null_Node loop
+ while Node /= null loop
if Equivalent_Keys (Key, Node) then
return Node;
end if;
Node := Next (Node);
end loop;
- return Null_Node;
+ return null;
end Find;
--------------------------------
--------------------------------
procedure Generic_Conditional_Insert
- (HT : in out HT_Type;
- Key : Key_Type;
- Node : out Node_Access;
- Success : out Boolean)
+ (HT : in out Hash_Table_Type;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Inserted : out Boolean)
is
Indx : constant Hash_Type := Index (HT, Key);
B : Node_Access renames HT.Buckets (Indx);
subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1;
begin
- if B = Null_Node then
+ if B = null then
+ if HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+
declare
Length : constant Length_Subtype := HT.Length;
begin
- Node := New_Node (Next => Null_Node);
- Success := True;
+ Node := New_Node (Next => null);
+ Inserted := True;
B := Node;
HT.Length := Length + 1;
Node := B;
loop
if Equivalent_Keys (Key, Node) then
- Success := False;
+ Inserted := False;
return;
end if;
Node := Next (Node);
- exit when Node = Null_Node;
+ exit when Node = null;
end loop;
+ if HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+
declare
Length : constant Length_Subtype := HT.Length;
begin
Node := New_Node (Next => B);
- Success := True;
+ Inserted := True;
B := Node;
HT.Length := Length + 1;
-----------
function Index
- (HT : HT_Type;
+ (HT : Hash_Table_Type;
Key : Key_Type) return Hash_Type is
begin
return Hash (Key) mod HT.Buckets'Length;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS --
+-- A D A . C O N T A I N E R S . --
+-- H A S H _ T A B L E S . G E N E R I C _ K E Y S --
-- --
-- S p e c --
-- --
--- This specification is adapted from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT 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. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; 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. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
generic
with package HT_Types is
new Generic_Hash_Table_Types (<>);
- type HT_Type is new HT_Types.Hash_Table_Type with private;
-
use HT_Types;
- Null_Node : Node_Access;
-
with function Next (Node : Node_Access) return Node_Access;
with procedure Set_Next
pragma Preelaborate;
function Index
- (HT : HT_Type;
+ (HT : Hash_Table_Type;
Key : Key_Type) return Hash_Type;
pragma Inline (Index);
procedure Delete_Key_Sans_Free
- (HT : in out HT_Type;
+ (HT : in out Hash_Table_Type;
Key : Key_Type;
X : out Node_Access);
- function Find (HT : HT_Type; Key : Key_Type) return Node_Access;
+ function Find (HT : Hash_Table_Type; Key : Key_Type) return Node_Access;
generic
with function New_Node
(Next : Node_Access) return Node_Access;
procedure Generic_Conditional_Insert
- (HT : in out HT_Type;
- Key : Key_Type;
- Node : out Node_Access;
- Success : out Boolean);
+ (HT : in out Hash_Table_Type;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Inserted : out Boolean);
end Ada.Containers.Hash_Tables.Generic_Keys;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS --
+-- A D A . C O N T A I N E R S . --
+-- H A S H _ T A B L E S . G E N E R I C _ O P E R A T I O N S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
end if;
HT.Buckets := new Buckets_Type (Src_Buckets'Range);
+ -- TODO: allocate minimum size req'd. (See note below.)
+ -- NOTE: see note below about these comments.
-- Probably we have to duplicate the Size (Src), too, in order
-- to guarantee that
-- If we relax the requirement that the hash value must be the
-- same, then of course we can't guarantee that following
-- assignment that Dst = Src is true ???
+ --
+ -- NOTE: 17 Apr 2005
+ -- What I said above is no longer true. The semantics of (map) equality
+ -- changed, such that we use key in the left map to look up the
+ -- equivalent key in the right map, and then compare the elements (using
+ -- normal equality) of the equivalent keys. So it doesn't matter that
+ -- the maps have different capacities (i.e. the hash tables have
+ -- different lengths), since we just look up the key, irrespective of
+ -- its map's hash table length. All the RM says we're required to do
+ -- it arrange for the target map to "=" the source map following an
+ -- assignment (that is, following an Adjust), so it doesn't matter
+ -- what the capacity of the target map is. What I'll probably do is
+ -- allocate a new hash table that has the minimum size necessary,
+ -- instead of allocating a new hash table whose size exactly matches
+ -- that of the source. (See the assignment that immediately precedes
+ -- these comments.) What we really need is a special Assign operation
+ -- (not unlike what we have already for Vector) that allows the user to
+ -- choose the capacity of the target.
+ -- END NOTE.
for Src_Index in Src_Buckets'Range loop
Src_Node := Src_Buckets (Src_Index);
- if Src_Node /= Null_Node then
+ if Src_Node /= null then
declare
Dst_Node : constant Node_Access := Copy_Node (Src_Node);
end;
Src_Node := Next (Src_Node);
- while Src_Node /= Null_Node loop
+ while Src_Node /= null loop
declare
Dst_Node : constant Node_Access := Copy_Node (Src_Node);
Node : Node_Access;
begin
+ if HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+
while HT.Length > 0 loop
- while HT.Buckets (Index) = Null_Node loop
+ while HT.Buckets (Index) = null loop
Index := Index + 1;
end loop;
Bucket := Next (Bucket);
HT.Length := HT.Length - 1;
Free (Node);
- exit when Bucket = Null_Node;
+ exit when Bucket = null;
end loop;
end;
end loop;
(HT : in out Hash_Table_Type;
X : Node_Access)
is
- pragma Assert (X /= Null_Node);
+ pragma Assert (X /= null);
Indx : Hash_Type;
Prev : Node_Access;
Indx := Index (HT, X);
Prev := HT.Buckets (Indx);
- if Prev = Null_Node then
+ if Prev = null then
raise Program_Error;
end if;
loop
Curr := Next (Prev);
- if Curr = Null_Node then
+ if Curr = null then
raise Program_Error;
end if;
end loop;
end Delete_Node_Sans_Free;
- ---------------------
- -- Ensure_Capacity --
- ---------------------
-
- procedure Ensure_Capacity
- (HT : in out Hash_Table_Type;
- N : Count_Type)
- is
- NN : Hash_Type;
-
- begin
- if N = 0 then
- if HT.Length = 0 then
- Free (HT.Buckets);
-
- elsif HT.Length < HT.Buckets'Length then
- NN := Prime_Numbers.To_Prime (HT.Length);
-
- -- ASSERT: NN >= HT.Length
-
- if NN < HT.Buckets'Length then
- Rehash (HT, Size => NN);
- end if;
- end if;
-
- return;
- end if;
-
- if HT.Buckets = null then
- NN := Prime_Numbers.To_Prime (N);
-
- -- ASSERT: NN >= N
-
- Rehash (HT, Size => NN);
- return;
- end if;
-
- if N <= HT.Length then
- if HT.Length >= HT.Buckets'Length then
- return;
- end if;
-
- NN := Prime_Numbers.To_Prime (HT.Length);
-
- -- ASSERT: NN >= HT.Length
-
- if NN < HT.Buckets'Length then
- Rehash (HT, Size => NN);
- end if;
-
- return;
- end if;
-
- -- ASSERT: N > HT.Length
-
- if N = HT.Buckets'Length then
- return;
- end if;
-
- NN := Prime_Numbers.To_Prime (N);
-
- -- ASSERT: NN >= N
- -- ASSERT: NN > HT.Length
-
- if NN /= HT.Buckets'Length then
- Rehash (HT, Size => NN);
- end if;
- end Ensure_Capacity;
-
--------------
-- Finalize --
--------------
begin
if HT.Length = 0 then
- return Null_Node;
+ return null;
end if;
Indx := HT.Buckets'First;
loop
- if HT.Buckets (Indx) /= Null_Node then
+ if HT.Buckets (Indx) /= null then
return HT.Buckets (Indx);
end if;
end if;
for J in Buckets'Range loop
- while Buckets (J) /= Null_Node loop
+ while Buckets (J) /= null loop
Node := Buckets (J);
Buckets (J) := Next (Node);
Free (Node);
loop
L_Node := L.Buckets (L_Index);
- exit when L_Node /= Null_Node;
+ exit when L_Node /= null;
L_Index := L_Index + 1;
end loop;
L_Node := Next (L_Node);
- if L_Node = Null_Node then
+ if L_Node = null then
if N = 0 then
return True;
end if;
loop
L_Index := L_Index + 1;
L_Node := L.Buckets (L_Index);
- exit when L_Node /= Null_Node;
+ exit when L_Node /= null;
end loop;
end if;
end loop;
-----------------------
procedure Generic_Iteration (HT : Hash_Table_Type) is
- Node : Node_Access;
+ Busy : Natural renames HT'Unrestricted_Access.all.Busy;
begin
- if HT.Buckets = null
- or else HT.Length = 0
- then
+ if HT.Length = 0 then
return;
end if;
- for Indx in HT.Buckets'Range loop
- Node := HT.Buckets (Indx);
- while Node /= Null_Node loop
- Process (Node);
- Node := Next (Node);
+ Busy := Busy + 1;
+
+ declare
+ Node : Node_Access;
+ begin
+ for Indx in HT.Buckets'Range loop
+ Node := HT.Buckets (Indx);
+ while Node /= null loop
+ Process (Node);
+ Node := Next (Node);
+ end loop;
end loop;
- end loop;
+ exception
+ when others =>
+ Busy := Busy - 1;
+ raise;
+ end;
+
+ Busy := Busy - 1;
end Generic_Iteration;
------------------
N, M : Count_Type'Base;
begin
- -- As with the sorted set, it's not clear whether read is allowed to
- -- have side effect if it fails. For now, we assume side effects are
- -- allowed since it simplifies the algorithm ???
- --
Clear (HT);
declare
Hash_Type'Read (Stream, Last);
+ -- TODO: don't immediately deallocate the buckets array we
+ -- already have. Instead, allocate a new buckets array only
+ -- if it needs to expanded because of the value of Last.
+
if Last /= 0 then
HT.Buckets := new Buckets_Type (0 .. Last);
end if;
while N > 0 loop
Hash_Type'Read (Stream, I);
pragma Assert (I in HT.Buckets'Range);
- pragma Assert (HT.Buckets (I) = Null_Node);
+ pragma Assert (HT.Buckets (I) = null);
Count_Type'Base'Read (Stream, M);
pragma Assert (M >= 1);
pragma Assert (M <= N);
HT.Buckets (I) := New_Node (Stream);
- pragma Assert (HT.Buckets (I) /= Null_Node);
- pragma Assert (Next (HT.Buckets (I)) = Null_Node);
+ pragma Assert (HT.Buckets (I) /= null);
+ pragma Assert (Next (HT.Buckets (I)) = null);
Y := HT.Buckets (I);
for J in Count_Type range 2 .. M loop
X := New_Node (Stream);
- pragma Assert (X /= Null_Node);
- pragma Assert (Next (X) = Null_Node);
+ pragma Assert (X /= null);
+ pragma Assert (Next (X) = null);
Set_Next (Node => Y, Next => X);
Y := X;
for Indx in HT.Buckets'Range loop
X := HT.Buckets (Indx);
- if X /= Null_Node then
+ if X /= null then
M := 1;
loop
X := Next (X);
- exit when X = Null_Node;
+ exit when X = null;
M := M + 1;
end loop;
X := Next (X);
end loop;
- pragma Assert (X = Null_Node);
+ pragma Assert (X = null);
end if;
end loop;
end Generic_Write;
return;
end if;
- if Target.Length > 0 then
- raise Constraint_Error;
+ if Source.Busy > 0 then
+ raise Program_Error;
end if;
- Free (Target.Buckets);
+ Clear (Target);
- Target.Buckets := Source.Buckets;
- Source.Buckets := null;
+ declare
+ Buckets : constant Buckets_Access := Target.Buckets;
+ begin
+ Target.Buckets := Source.Buckets;
+ Source.Buckets := Buckets;
+ end;
Target.Length := Source.Length;
Source.Length := 0;
Result : Node_Access := Next (Node);
begin
- if Result /= Null_Node then
+ if Result /= null then
return Result;
end if;
for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
Result := HT.Buckets (Indx);
- if Result /= Null_Node then
+ if Result /= null then
return Result;
end if;
end loop;
- return Null_Node;
+ return null;
end Next;
------------
declare
Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
begin
- while Src_Bucket /= Null_Node loop
+ while Src_Bucket /= null loop
declare
Src_Node : constant Node_Access := Src_Bucket;
Dst_Index : constant Hash_Type :=
exception
when others =>
+ -- NOTE: see todo below.
-- Not clear that we can deallocate the nodes,
-- because they may be designated by outstanding
-- iterators. Which means they're now lost... ???
-- Dst : Node_Access renames NB (J);
-- X : Node_Access;
-- begin
- -- while Dst /= Null_Node loop
+ -- while Dst /= null loop
-- X := Dst;
-- Dst := Succ (Dst);
-- Free (X);
-- end;
-- end loop;
+ -- TODO: 17 Apr 2005
+ -- What I should do instead is go ahead and deallocate the
+ -- nodes, since when assertions are enabled, we vet the
+ -- cursors, and we modify the state of a node enough when
+ -- it is deallocated in order to detect mischief.
+ -- END TODO.
Free (Dst_Buckets);
- raise;
+ raise; -- TODO: raise Program_Error instead
end;
-- exit when L = 0;
Free (Src_Buckets);
end Rehash;
-end Ada.Containers.Hash_Tables.Generic_Operations;
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ procedure Reserve_Capacity
+ (HT : in out Hash_Table_Type;
+ N : Count_Type)
+ is
+ NN : Hash_Type;
+
+ begin
+ if N = 0 then
+ if HT.Length = 0 then
+ Free (HT.Buckets);
+
+ elsif HT.Length < HT.Buckets'Length then
+ NN := Prime_Numbers.To_Prime (HT.Length);
+
+ -- ASSERT: NN >= HT.Length
+
+ if NN < HT.Buckets'Length then
+ if HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ Rehash (HT, Size => NN);
+ end if;
+ end if;
+
+ return;
+ end if;
+
+ if HT.Buckets = null then
+ NN := Prime_Numbers.To_Prime (N);
+
+ -- ASSERT: NN >= N
+
+ Rehash (HT, Size => NN);
+ return;
+ end if;
+
+ if N <= HT.Length then
+ if HT.Length >= HT.Buckets'Length then
+ return;
+ end if;
+
+ NN := Prime_Numbers.To_Prime (HT.Length);
+
+ -- ASSERT: NN >= HT.Length
+
+ if NN < HT.Buckets'Length then
+ if HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ Rehash (HT, Size => NN);
+ end if;
+
+ return;
+ end if;
+ -- ASSERT: N > HT.Length
+
+ if N = HT.Buckets'Length then
+ return;
+ end if;
+
+ NN := Prime_Numbers.To_Prime (N);
+
+ -- ASSERT: NN >= N
+ -- ASSERT: NN > HT.Length
+
+ if NN /= HT.Buckets'Length then
+ if HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ Rehash (HT, Size => NN);
+ end if;
+ end Reserve_Capacity;
+
+end Ada.Containers.Hash_Tables.Generic_Operations;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS --
+-- A D A . C O N T A I N E R S . --
+-- H A S H _ T A B L E S . G E N E R I C _ O P E R A T I O N S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
--- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
with package HT_Types is
new Generic_Hash_Table_Types (<>);
- type Hash_Table_Type is new HT_Types.Hash_Table_Type with private;
-
use HT_Types;
- Null_Node : in Node_Access;
-
with function Hash_Node (Node : Node_Access) return Hash_Type;
with function Next (Node : Node_Access) return Node_Access;
function Capacity (HT : Hash_Table_Type) return Count_Type;
- procedure Ensure_Capacity
+ procedure Reserve_Capacity
(HT : in out Hash_Table_Type;
N : Count_Type);
HT : out Hash_Table_Type);
end Ada.Containers.Hash_Tables.Generic_Operations;
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS --
+-- A D A . C O N T A I N E R S . --
+-- I N D E F I N I T E _ D O U B L Y _ L I N K E D _ L I S T S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- Local Subprograms --
-----------------------
- procedure Delete_Node
- (Container : in out List;
- Node : in out Node_Access);
-
procedure Insert_Internal
(Container : in out List;
Before : Node_Access;
L := Left.First;
R := Right.First;
for J in 1 .. Left.Length loop
- if L.Element = null then
- if R.Element /= null then
- return False;
- end if;
-
- elsif R.Element = null then
- return False;
-
- elsif L.Element.all /= R.Element.all then
+ if L.Element.all /= R.Element.all then
return False;
end if;
if Src = null then
pragma Assert (Container.Last = null);
pragma Assert (Container.Length = 0);
+ pragma Assert (Container.Busy = 0);
+ pragma Assert (Container.Lock = 0);
return;
end if;
Container.First := null;
Container.Last := null;
Container.Length := 0;
+ Container.Busy := 0;
+ Container.Lock := 0;
- Dst := new Node_Type'(null, null, null);
+ declare
+ Element : Element_Access := new Element_Type'(Src.Element.all);
+ begin
+ Dst := new Node_Type'(Element, null, null);
+ exception
+ when others =>
+ Free (Element);
+ raise;
+ end;
- if Src.Element /= null then
+ Container.First := Dst;
+ Container.Last := Dst;
+ Container.Length := 1;
+
+ Src := Src.Next;
+ while Src /= null loop
+ declare
+ Element : Element_Access := new Element_Type'(Src.Element.all);
begin
- Dst.Element := new Element_Type'(Src.Element.all);
+ Dst := new Node_Type'(Element, null, Prev => Container.Last);
exception
when others =>
- Free (Dst);
+ Free (Element);
raise;
end;
- end if;
-
- Container.First := Dst;
-
- Container.Last := Dst;
- loop
- Container.Length := Container.Length + 1;
- Src := Src.Next;
- exit when Src = null;
-
- Dst := new Node_Type'(null, Prev => Container.Last, Next => null);
-
- if Src.Element /= null then
- begin
- Dst.Element := new Element_Type'(Src.Element.all);
- exception
- when others =>
- Free (Dst);
- raise;
- end;
- end if;
Container.Last.Next := Dst;
Container.Last := Dst;
+ Container.Length := Container.Length + 1;
+
+ Src := Src.Next;
end loop;
end Adjust;
-----------
procedure Clear (Container : in out List) is
+ X : Node_Access;
+
begin
- Delete_Last (Container, Count => Container.Length);
+ if Container.Length = 0 then
+ pragma Assert (Container.First = null);
+ pragma Assert (Container.Last = null);
+ pragma Assert (Container.Busy = 0);
+ pragma Assert (Container.Lock = 0);
+ return;
+ end if;
+
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ while Container.Length > 1 loop
+ X := Container.First;
+ pragma Assert (X.Next.Prev = Container.First);
+
+ Container.First := X.Next;
+ Container.First.Prev := null;
+ Container.Length := Container.Length - 1;
+
+ X.Next := null; -- prevent mischief
+
+ begin
+ Free (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ Free (X);
+ raise;
+ end;
+
+ Free (X);
+ end loop;
+
+ X := Container.First;
+ pragma Assert (X = Container.Last);
+
+ Container.First := null;
+ Container.Last := null;
+ Container.Length := 0;
+
+ begin
+ Free (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ Free (X);
+ raise;
+ end;
+
+ Free (X);
end Clear;
--------------
Position : in out Cursor;
Count : Count_Type := 1)
is
+ X : Node_Access;
+
begin
- if Position = No_Element then
- return;
+ if Position.Node = null then
+ raise Constraint_Error;
end if;
if Position.Container /= List_Access'(Container'Unchecked_Access) then
raise Program_Error;
end if;
+ pragma Assert (Container.Length > 0);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Container.Last);
+
+ if Position.Node = Container.First then
+ Delete_First (Container, Count);
+ Position := First (Container);
+ return;
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
for Index in 1 .. Count loop
- Delete_Node (Container, Position.Node);
+ X := Position.Node;
+ Container.Length := Container.Length - 1;
+
+ if X = Container.Last then
+ Position := No_Element;
- if Position.Node = null then
- Position.Container := null;
+ Container.Last := X.Prev;
+ Container.Last.Next := null;
+
+ X.Prev := null; -- prevent mischief
+
+ begin
+ Free (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ Free (X);
+ raise;
+ end;
+
+ Free (X);
return;
end if;
+
+ Position.Node := X.Next;
+
+ X.Next.Prev := X.Prev;
+ X.Prev.Next := X.Next;
+
+ X.Prev := null;
+ X.Next := null;
+
+ begin
+ Free (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ Free (X);
+ raise;
+ end;
+
+ Free (X);
end loop;
end Delete;
(Container : in out List;
Count : Count_Type := 1)
is
- Node : Node_Access := Container.First;
+ X : Node_Access;
+
begin
- for J in 1 .. Count_Type'Min (Count, Container.Length) loop
- Delete_Node (Container, Node);
+ if Count >= Container.Length then
+ Clear (Container);
+ return;
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ for I in 1 .. Count loop
+ X := Container.First;
+ pragma Assert (X.Next.Prev = Container.First);
+
+ Container.First := X.Next;
+ Container.First.Prev := null;
+
+ Container.Length := Container.Length - 1;
+
+ X.Next := null; -- prevent mischief
+
+ begin
+ Free (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ Free (X);
+ raise;
+ end;
+
+ Free (X);
end loop;
end Delete_First;
(Container : in out List;
Count : Count_Type := 1)
is
- Node : Node_Access;
- begin
- for J in 1 .. Count_Type'Min (Count, Container.Length) loop
- Node := Container.Last;
- Delete_Node (Container, Node);
- end loop;
- end Delete_Last;
-
- -----------------
- -- Delete_Node --
- -----------------
-
- procedure Delete_Node
- (Container : in out List;
- Node : in out Node_Access)
- is
- X : Node_Access := Node;
+ X : Node_Access;
begin
- Node := X.Next;
- Container.Length := Container.Length - 1;
+ if Count >= Container.Length then
+ Clear (Container);
+ return;
+ end if;
- if X = Container.First then
- Container.First := X.Next;
+ if Count = 0 then
+ return;
+ end if;
- if X = Container.Last then
- pragma Assert (Container.First = null);
- pragma Assert (Container.Length = 0);
- Container.Last := null;
- else
- pragma Assert (Container.Length > 0);
- Container.First.Prev := null;
- end if;
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
- elsif X = Container.Last then
- pragma Assert (Container.Length > 0);
+ for I in 1 .. Count loop
+ X := Container.Last;
+ pragma Assert (X.Prev.Next = Container.Last);
Container.Last := X.Prev;
Container.Last.Next := null;
- else
- pragma Assert (Container.Length > 0);
+ Container.Length := Container.Length - 1;
- X.Next.Prev := X.Prev;
- X.Prev.Next := X.Next;
+ X.Prev := null; -- prevent mischief
- end if;
+ begin
+ Free (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ Free (X);
+ raise;
+ end;
- Free (X.Element);
- Free (X);
- end Delete_Node;
+ Free (X);
+ end loop;
+ end Delete_Last;
-------------
-- Element --
function Element (Position : Cursor) return Element_Type is
begin
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node /= null);
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
return Position.Node.Element.all;
end Element;
begin
if Node = null then
Node := Container.First;
- elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
- raise Program_Error;
+
+ else
+ if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Container.Length > 0);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Container.Last);
end if;
while Node /= null loop
- if Node.Element /= null
- and then Node.Element.all = Item
- then
+ if Node.Element.all = Item then
return Cursor'(Container'Unchecked_Access, Node);
end if;
return Container.First.Element.all;
end First_Element;
- -------------------
- -- Generic_Merge --
- -------------------
+ ---------------------
+ -- Generic_Sorting --
+ ---------------------
- procedure Generic_Merge
- (Target : in out List;
- Source : in out List)
- is
- LI : Cursor;
- RI : Cursor;
+ package body Generic_Sorting is
- begin
- if Target'Address = Source'Address then
- return;
- end if;
+ ---------------
+ -- Is_Sorted --
+ ---------------
+
+ function Is_Sorted (Container : List) return Boolean is
+ Node : Node_Access := Container.First;
+
+ begin
+ for I in 2 .. Container.Length loop
+ if Node.Next.Element.all < Node.Element.all then
+ return False;
+ end if;
+
+ Node := Node.Next;
+ end loop;
+
+ return True;
+ end Is_Sorted;
+
+ -----------
+ -- Merge --
+ -----------
- LI := First (Target);
- RI := First (Source);
- while RI.Node /= null loop
- if LI.Node = null then
- Splice (Target, No_Element, Source);
+ procedure Merge
+ (Target : in out List;
+ Source : in out List)
+ is
+ LI : Cursor;
+ RI : Cursor;
+
+ begin
+ if Target'Address = Source'Address then
return;
end if;
- if LI.Node.Element = null then
- LI.Node := LI.Node.Next;
-
- elsif RI.Node.Element = null
- or else RI.Node.Element.all < LI.Node.Element.all
+ if Target.Busy > 0
+ or else Source.Busy > 0
then
- declare
- RJ : constant Cursor := RI;
- begin
- RI.Node := RI.Node.Next;
- Splice (Target, LI, Source, RJ);
- end;
-
- else
- LI.Node := LI.Node.Next;
+ raise Program_Error;
end if;
- end loop;
- end Generic_Merge;
- ------------------
- -- Generic_Sort --
- ------------------
+ LI := First (Target);
+ RI := First (Source);
+ while RI.Node /= null loop
+ if LI.Node = null then
+ Splice (Target, No_Element, Source);
+ return;
+ end if;
- procedure Generic_Sort (Container : in out List) is
- procedure Partition (Pivot : Node_Access; Back : Node_Access);
+ if RI.Node.Element.all < LI.Node.Element.all then
+ declare
+ RJ : Cursor := RI;
+ begin
+ RI.Node := RI.Node.Next;
+ Splice (Target, LI, Source, RJ);
+ end;
- procedure Sort (Front, Back : Node_Access);
+ else
+ LI.Node := LI.Node.Next;
+ end if;
+ end loop;
+ end Merge;
- ---------------
- -- Partition --
- ---------------
+ ----------
+ -- Sort --
+ ----------
- procedure Partition (Pivot : Node_Access; Back : Node_Access) is
- Node : Node_Access := Pivot.Next;
+ procedure Sort (Container : in out List) is
+ procedure Partition (Pivot : Node_Access; Back : Node_Access);
- begin
- while Node /= Back loop
- if Pivot.Element = null then
- Node := Node.Next;
+ procedure Sort (Front, Back : Node_Access);
- elsif Node.Element = null
- or else Node.Element.all < Pivot.Element.all
- then
- declare
- Prev : constant Node_Access := Node.Prev;
- Next : constant Node_Access := Node.Next;
- begin
- Prev.Next := Next;
+ ---------------
+ -- Partition --
+ ---------------
- if Next = null then
- Container.Last := Prev;
- else
- Next.Prev := Prev;
- end if;
+ procedure Partition (Pivot : Node_Access; Back : Node_Access) is
+ Node : Node_Access := Pivot.Next;
- Node.Next := Pivot;
- Node.Prev := Pivot.Prev;
+ begin
+ while Node /= Back loop
+ if Node.Element.all < Pivot.Element.all then
+ declare
+ Prev : constant Node_Access := Node.Prev;
+ Next : constant Node_Access := Node.Next;
+ begin
+ Prev.Next := Next;
+
+ if Next = null then
+ Container.Last := Prev;
+ else
+ Next.Prev := Prev;
+ end if;
+
+ Node.Next := Pivot;
+ Node.Prev := Pivot.Prev;
+
+ Pivot.Prev := Node;
+
+ if Node.Prev = null then
+ Container.First := Node;
+ else
+ Node.Prev.Next := Node;
+ end if;
+
+ Node := Next;
+ end;
- Pivot.Prev := Node;
+ else
+ Node := Node.Next;
+ end if;
+ end loop;
+ end Partition;
- if Node.Prev = null then
- Container.First := Node;
- else
- Node.Prev.Next := Node;
- end if;
+ ----------
+ -- Sort --
+ ----------
- Node := Next;
- end;
+ procedure Sort (Front, Back : Node_Access) is
+ Pivot : Node_Access;
+ begin
+ if Front = null then
+ Pivot := Container.First;
else
- Node := Node.Next;
+ Pivot := Front.Next;
end if;
- end loop;
- end Partition;
- ----------
- -- Sort --
- ----------
+ if Pivot /= Back then
+ Partition (Pivot, Back);
+ Sort (Front, Pivot);
+ Sort (Pivot, Back);
+ end if;
+ end Sort;
- procedure Sort (Front, Back : Node_Access) is
- Pivot : Node_Access;
+ -- Start of processing for Sort
begin
- if Front = null then
- Pivot := Container.First;
- else
- Pivot := Front.Next;
+ if Container.Length <= 1 then
+ return;
end if;
- if Pivot /= Back then
- Partition (Pivot, Back);
- Sort (Front, Pivot);
- Sort (Pivot, Back);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ if Container.Busy > 0 then
+ raise Program_Error;
end if;
- end Sort;
- -- Start of processing for Generic_Sort
+ Sort (Front => null, Back => null);
- begin
- Sort (Front => null, Back => null);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+ end Sort;
- pragma Assert (Container.Length = 0
- or else (Container.First.Prev = null
- and Container.Last.Next = null));
- end Generic_Sort;
+ end Generic_Sorting;
-----------------
-- Has_Element --
function Has_Element (Position : Cursor) return Boolean is
begin
- return Position.Container /= null and then Position.Node /= null;
+ if Position.Node = null then
+ pragma Assert (Position.Container = null);
+ return False;
+ end if;
+
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
+ return True;
end Has_Element;
------------
New_Node : Node_Access;
begin
- if Before.Container /= null
- and then Before.Container /= List_Access'(Container'Unchecked_Access)
- then
- raise Program_Error;
+ if Before.Node /= null then
+ if Before.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Container.Length > 0);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ pragma Assert (Before.Node.Element /= null);
+ pragma Assert (Before.Node.Prev = null
+ or else Before.Node.Prev.Next = Before.Node);
+ pragma Assert (Before.Node.Next = null
+ or else Before.Node.Next.Prev = Before.Node);
+ pragma Assert (Before.Node.Prev /= null
+ or else Before.Node = Container.First);
+ pragma Assert (Before.Node.Next /= null
+ or else Before.Node = Container.Last);
end if;
if Count = 0 then
return;
end if;
+ if Container.Length > Count_Type'Last - Count then
+ raise Constraint_Error;
+ end if;
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
declare
Element : Element_Access := new Element_Type'(New_Item);
begin
end;
Insert_Internal (Container, Before.Node, New_Node);
- Position := Cursor'(Before.Container, New_Node);
+ Position := Cursor'(Container'Unchecked_Access, New_Node);
for J in Count_Type'(2) .. Count loop
(Container : List;
Process : not null access procedure (Position : in Cursor))
is
+ C : List renames Container'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+
Node : Node_Access := Container.First;
+
begin
- while Node /= null loop
- Process (Cursor'(Container'Unchecked_Access, Node));
- Node := Node.Next;
- end loop;
+ B := B + 1;
+
+ begin
+ while Node /= null loop
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ Node := Node.Next;
+ end loop;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
----------
return;
end if;
- if Target.Length > 0 then
- raise Constraint_Error;
+ if Source.Busy > 0 then
+ raise Program_Error;
end if;
+ Clear (Target);
+
Target.First := Source.First;
Source.First := null;
procedure Next (Position : in out Cursor) is
begin
if Position.Node = null then
+ pragma Assert (Position.Container = null);
return;
end if;
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
Position.Node := Position.Node.Next;
if Position.Node = null then
function Next (Position : Cursor) return Cursor is
begin
if Position.Node = null then
+ pragma Assert (Position.Container = null);
return No_Element;
end if;
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
declare
Next_Node : constant Node_Access := Position.Node.Next;
begin
procedure Previous (Position : in out Cursor) is
begin
if Position.Node = null then
+ pragma Assert (Position.Container = null);
return;
end if;
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
Position.Node := Position.Node.Prev;
if Position.Node = null then
function Previous (Position : Cursor) return Cursor is
begin
if Position.Node = null then
+ pragma Assert (Position.Container = null);
return No_Element;
end if;
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
declare
Prev_Node : constant Node_Access := Position.Node.Prev;
begin
(Position : Cursor;
Process : not null access procedure (Element : in Element_Type))
is
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node /= null);
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
+ E : Element_Type renames Position.Node.Element.all;
+
+ C : List renames Position.Container.all'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+
begin
- Process (Position.Node.Element.all);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Query_Element;
----------
(Stream : access Root_Stream_Type'Class;
Item : out List)
is
- N : Count_Type'Base;
- X : Node_Access;
+ N : Count_Type'Base;
+ Dst : Node_Access;
begin
- Clear (Item); -- ???
+ Clear (Item);
Count_Type'Base'Read (Stream, N);
return;
end if;
- X := new Node_Type;
-
+ declare
+ Element : Element_Access :=
+ new Element_Type'(Element_Type'Input (Stream));
begin
- X.Element := new Element_Type'(Element_Type'Input (Stream));
+ Dst := new Node_Type'(Element, null, null);
exception
when others =>
- Free (X);
+ Free (Element);
raise;
end;
- Item.First := X;
-
- Item.Last := X;
- loop
- Item.Length := Item.Length + 1;
- exit when Item.Length = N;
-
- X := new Node_Type;
+ Item.First := Dst;
+ Item.Last := Dst;
+ Item.Length := 1;
+ while Item.Length < N loop
+ declare
+ Element : Element_Access :=
+ new Element_Type'(Element_Type'Input (Stream));
begin
- X.Element := new Element_Type'(Element_Type'Input (Stream));
+ Dst := new Node_Type'(Element, Next => null, Prev => Item.Last);
exception
when others =>
- Free (X);
+ Free (Element);
raise;
end;
- X.Prev := Item.Last;
- Item.Last.Next := X;
- Item.Last := X;
+ Item.Last.Next := Dst;
+ Item.Last := Dst;
+ Item.Length := Item.Length + 1;
end loop;
end Read;
(Position : Cursor;
By : Element_Type)
is
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node /= null);
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
X : Element_Access := Position.Node.Element;
+
begin
+ if Position.Container.Lock > 0 then
+ raise Program_Error;
+ end if;
+
Position.Node.Element := new Element_Type'(By);
Free (X);
end Replace_Element;
begin
if Node = null then
Node := Container.Last;
- elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
- raise Program_Error;
+
+ else
+ if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Container.Length > 0);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Container.Last);
end if;
while Node /= null loop
- if Node.Element /= null
- and then Node.Element.all = Item
- then
+ if Node.Element.all = Item then
return Cursor'(Container'Unchecked_Access, Node);
end if;
(Container : List;
Process : not null access procedure (Position : in Cursor))
is
+ C : List renames Container'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+
Node : Node_Access := Container.Last;
begin
- while Node /= null loop
- Process (Cursor'(Container'Unchecked_Access, Node));
- Node := Node.Prev;
- end loop;
+ B := B + 1;
+
+ begin
+ while Node /= null loop
+ Process (Cursor'(Container'Unchecked_Access, Node));
+ Node := Node.Prev;
+ end loop;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
------------------
return;
end if;
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
Container.First := J;
Container.Last := I;
loop
Source : in out List)
is
begin
- if Before.Container /= null
- and then Before.Container /= List_Access'(Target'Unchecked_Access)
- then
- raise Program_Error;
+ if Before.Node /= null then
+ if Before.Container /= List_Access'(Target'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Target.Length >= 1);
+ pragma Assert (Target.First.Prev = null);
+ pragma Assert (Target.Last.Next = null);
+
+ pragma Assert (Before.Node.Element /= null);
+ pragma Assert (Before.Node.Prev = null
+ or else Before.Node.Prev.Next = Before.Node);
+ pragma Assert (Before.Node.Next = null
+ or else Before.Node.Next.Prev = Before.Node);
+ pragma Assert (Before.Node.Prev /= null
+ or else Before.Node = Target.First);
+ pragma Assert (Before.Node.Next /= null
+ or else Before.Node = Target.Last);
end if;
if Target'Address = Source'Address
return;
end if;
+ pragma Assert (Source.First.Prev = null);
+ pragma Assert (Source.Last.Next = null);
+
+ if Target.Length > Count_Type'Last - Source.Length then
+ raise Constraint_Error;
+ end if;
+
+ if Target.Busy > 0
+ or else Source.Busy > 0
+ then
+ raise Program_Error;
+ end if;
+
if Target.Length = 0 then
pragma Assert (Before = No_Element);
+ pragma Assert (Target.First = null);
+ pragma Assert (Target.Last = null);
Target.First := Source.First;
Target.Last := Source.Last;
Target.First := Source.First;
else
+ pragma Assert (Target.Length >= 2);
Before.Node.Prev.Next := Source.First;
Source.First.Prev := Before.Node.Prev;
Before : Cursor;
Position : Cursor)
is
- X : Node_Access := Position.Node;
-
begin
- if Before.Container /= null
- and then Before.Container /= List_Access'(Target'Unchecked_Access)
- then
- raise Program_Error;
+ if Before.Node /= null then
+ if Before.Container /= List_Access'(Target'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Target.Length >= 1);
+ pragma Assert (Target.First.Prev = null);
+ pragma Assert (Target.Last.Next = null);
+
+ pragma Assert (Before.Node.Element /= null);
+ pragma Assert (Before.Node.Prev = null
+ or else Before.Node.Prev.Next = Before.Node);
+ pragma Assert (Before.Node.Next = null
+ or else Before.Node.Next.Prev = Before.Node);
+ pragma Assert (Before.Node.Prev /= null
+ or else Before.Node = Target.First);
+ pragma Assert (Before.Node.Next /= null
+ or else Before.Node = Target.Last);
end if;
- if Position.Container /= null
- and then Position.Container /= List_Access'(Target'Unchecked_Access)
- then
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= List_Access'(Target'Unchecked_Access) then
raise Program_Error;
end if;
- if X = null
- or else X = Before.Node
- or else X.Next = Before.Node
+ pragma Assert (Target.Length >= 1);
+ pragma Assert (Target.First.Prev = null);
+ pragma Assert (Target.Last.Next = null);
+
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Target.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Target.Last);
+
+ if Position.Node = Before.Node
+ or else Position.Node.Next = Before.Node
then
return;
end if;
- pragma Assert (Target.Length > 0);
+ pragma Assert (Target.Length >= 2);
+
+ if Target.Busy > 0 then
+ raise Program_Error;
+ end if;
if Before.Node = null then
- pragma Assert (X /= Target.Last);
+ pragma Assert (Position.Node /= Target.Last);
- if X = Target.First then
- Target.First := X.Next;
+ if Position.Node = Target.First then
+ Target.First := Position.Node.Next;
Target.First.Prev := null;
else
- X.Prev.Next := X.Next;
- X.Next.Prev := X.Prev;
+ Position.Node.Prev.Next := Position.Node.Next;
+ Position.Node.Next.Prev := Position.Node.Prev;
end if;
- Target.Last.Next := X;
- X.Prev := Target.Last;
+ Target.Last.Next := Position.Node;
+ Position.Node.Prev := Target.Last;
- Target.Last := X;
+ Target.Last := Position.Node;
Target.Last.Next := null;
return;
end if;
if Before.Node = Target.First then
- pragma Assert (X /= Target.First);
+ pragma Assert (Position.Node /= Target.First);
- if X = Target.Last then
- Target.Last := X.Prev;
+ if Position.Node = Target.Last then
+ Target.Last := Position.Node.Prev;
Target.Last.Next := null;
else
- X.Prev.Next := X.Next;
- X.Next.Prev := X.Prev;
+ Position.Node.Prev.Next := Position.Node.Next;
+ Position.Node.Next.Prev := Position.Node.Prev;
end if;
- Target.First.Prev := X;
- X.Next := Target.First;
+ Target.First.Prev := Position.Node;
+ Position.Node.Next := Target.First;
- Target.First := X;
+ Target.First := Position.Node;
Target.First.Prev := null;
return;
end if;
- if X = Target.First then
- Target.First := X.Next;
+ if Position.Node = Target.First then
+ Target.First := Position.Node.Next;
Target.First.Prev := null;
- elsif X = Target.Last then
- Target.Last := X.Prev;
+ elsif Position.Node = Target.Last then
+ Target.Last := Position.Node.Prev;
Target.Last.Next := null;
else
- X.Prev.Next := X.Next;
- X.Next.Prev := X.Prev;
+ Position.Node.Prev.Next := Position.Node.Next;
+ Position.Node.Next.Prev := Position.Node.Prev;
end if;
- Before.Node.Prev.Next := X;
- X.Prev := Before.Node.Prev;
+ Before.Node.Prev.Next := Position.Node;
+ Position.Node.Prev := Before.Node.Prev;
+
+ Before.Node.Prev := Position.Node;
+ Position.Node.Next := Before.Node;
- Before.Node.Prev := X;
- X.Next := Before.Node;
+ pragma Assert (Target.First.Prev = null);
+ pragma Assert (Target.Last.Next = null);
end Splice;
procedure Splice
(Target : in out List;
Before : Cursor;
Source : in out List;
- Position : Cursor)
+ Position : in out Cursor)
is
- X : Node_Access := Position.Node;
-
begin
if Target'Address = Source'Address then
Splice (Target, Before, Position);
return;
end if;
- if Before.Container /= null
- and then Before.Container /= List_Access'(Target'Unchecked_Access)
- then
- raise Program_Error;
+ if Before.Node /= null then
+ if Before.Container /= List_Access'(Target'Unchecked_Access) then
+ raise Program_Error;
+ end if;
+
+ pragma Assert (Target.Length >= 1);
+ pragma Assert (Target.First.Prev = null);
+ pragma Assert (Target.Last.Next = null);
+
+ pragma Assert (Before.Node.Element /= null);
+ pragma Assert (Before.Node.Prev = null
+ or else Before.Node.Prev.Next = Before.Node);
+ pragma Assert (Before.Node.Next = null
+ or else Before.Node.Next.Prev = Before.Node);
+ pragma Assert (Before.Node.Prev /= null
+ or else Before.Node = Target.First);
+ pragma Assert (Before.Node.Next /= null
+ or else Before.Node = Target.Last);
end if;
- if Position.Container /= null
- and then Position.Container /= List_Access'(Source'Unchecked_Access)
- then
- raise Program_Error;
+ if Position.Node = null then
+ raise Constraint_Error;
end if;
- if X = null then
- return;
+ if Position.Container /= List_Access'(Source'Unchecked_Access) then
+ raise Program_Error;
end if;
- pragma Assert (Source.Length > 0);
+ pragma Assert (Source.Length >= 1);
pragma Assert (Source.First.Prev = null);
pragma Assert (Source.Last.Next = null);
- if X = Source.First then
- Source.First := X.Next;
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Source.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Source.Last);
+
+ if Target.Length = Count_Type'Last then
+ raise Constraint_Error;
+ end if;
+
+ if Target.Busy > 0
+ or else Source.Busy > 0
+ then
+ raise Program_Error;
+ end if;
+
+ if Position.Node = Source.First then
+ Source.First := Position.Node.Next;
Source.First.Prev := null;
- if X = Source.Last then
+ if Position.Node = Source.Last then
pragma Assert (Source.First = null);
pragma Assert (Source.Length = 1);
Source.Last := null;
end if;
- elsif X = Source.Last then
- Source.Last := X.Prev;
+ elsif Position.Node = Source.Last then
+ pragma Assert (Source.Length >= 2);
+ Source.Last := Position.Node.Prev;
Source.Last.Next := null;
else
- X.Prev.Next := X.Next;
- X.Next.Prev := X.Prev;
+ pragma Assert (Source.Length >= 3);
+ Position.Node.Prev.Next := Position.Node.Next;
+ Position.Node.Next.Prev := Position.Node.Prev;
end if;
if Target.Length = 0 then
pragma Assert (Target.First = null);
pragma Assert (Target.Last = null);
- Target.First := X;
- Target.Last := X;
+ Target.First := Position.Node;
+ Target.Last := Position.Node;
+
+ Target.First.Prev := null;
+ Target.Last.Next := null;
elsif Before.Node = null then
- Target.Last.Next := X;
- X.Next := Target.Last;
+ pragma Assert (Target.Last.Next = null);
+ Target.Last.Next := Position.Node;
+ Position.Node.Prev := Target.Last;
- Target.Last := X;
+ Target.Last := Position.Node;
Target.Last.Next := null;
elsif Before.Node = Target.First then
- Target.First.Prev := X;
- X.Next := Target.First;
+ pragma Assert (Target.First.Prev = null);
+ Target.First.Prev := Position.Node;
+ Position.Node.Next := Target.First;
- Target.First := X;
+ Target.First := Position.Node;
Target.First.Prev := null;
else
- Before.Node.Prev.Next := X;
- X.Prev := Before.Node.Prev;
+ pragma Assert (Target.Length >= 2);
+ Before.Node.Prev.Next := Position.Node;
+ Position.Node.Prev := Before.Node.Prev;
- Before.Node.Prev := X;
- X.Next := Before.Node;
+ Before.Node.Prev := Position.Node;
+ Position.Node.Next := Before.Node;
end if;
Target.Length := Target.Length + 1;
Source.Length := Source.Length - 1;
+
+ Position.Container := Target'Unchecked_Access;
end Splice;
----------
----------
procedure Swap (I, J : Cursor) is
+ begin
+ if I.Container = null
+ or else J.Container = null
+ then
+ raise Constraint_Error;
+ end if;
- -- Is this op legal when I and J designate elements in different
- -- containers, or should it raise an exception (e.g. Program_Error).
+ if I.Container /= J.Container then
+ raise Program_Error;
+ end if;
- EI : constant Element_Access := I.Node.Element;
+ declare
+ C : List renames I.Container.all;
+ begin
+ pragma Assert (C.Length > 0);
+ pragma Assert (C.First.Prev = null);
+ pragma Assert (C.Last.Next = null);
+
+ pragma Assert (I.Node /= null);
+ pragma Assert (I.Node.Element /= null);
+ pragma Assert (I.Node.Prev = null
+ or else I.Node.Prev.Next = I.Node);
+ pragma Assert (I.Node.Next = null
+ or else I.Node.Next.Prev = I.Node);
+ pragma Assert (I.Node.Prev /= null
+ or else I.Node = C.First);
+ pragma Assert (I.Node.Next /= null
+ or else I.Node = C.Last);
+
+ if I.Node = J.Node then
+ return;
+ end if;
- begin
- I.Node.Element := J.Node.Element;
- J.Node.Element := EI;
+ pragma Assert (C.Length > 1);
+ pragma Assert (J.Node /= null);
+ pragma Assert (J.Node.Element /= null);
+ pragma Assert (J.Node.Prev = null
+ or else J.Node.Prev.Next = J.Node);
+ pragma Assert (J.Node.Next = null
+ or else J.Node.Next.Prev = J.Node);
+ pragma Assert (J.Node.Prev /= null
+ or else J.Node = C.First);
+ pragma Assert (J.Node.Next /= null
+ or else J.Node = C.Last);
+
+ if C.Lock > 0 then
+ raise Program_Error;
+ end if;
+
+ declare
+ EI_Copy : constant Element_Access := I.Node.Element;
+ begin
+ I.Node.Element := J.Node.Element;
+ J.Node.Element := EI_Copy;
+ end;
+ end;
end Swap;
----------------
I, J : Cursor)
is
begin
- if I = No_Element
- or else J = No_Element
+ if I.Container = null
+ or else J.Container = null
then
raise Constraint_Error;
end if;
end if;
pragma Assert (Container.Length >= 1);
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
+
+ pragma Assert (I.Node /= null);
+ pragma Assert (I.Node.Element /= null);
+ pragma Assert (I.Node.Prev = null
+ or else I.Node.Prev.Next = I.Node);
+ pragma Assert (I.Node.Next = null
+ or else I.Node.Next.Prev = I.Node);
+ pragma Assert (I.Node.Prev /= null
+ or else I.Node = Container.First);
+ pragma Assert (I.Node.Next /= null
+ or else I.Node = Container.Last);
if I.Node = J.Node then
return;
end if;
pragma Assert (Container.Length >= 2);
+ pragma Assert (J.Node /= null);
+ pragma Assert (J.Node.Element /= null);
+ pragma Assert (J.Node.Prev = null
+ or else J.Node.Prev.Next = J.Node);
+ pragma Assert (J.Node.Next = null
+ or else J.Node.Next.Prev = J.Node);
+ pragma Assert (J.Node.Prev /= null
+ or else J.Node = Container.First);
+ pragma Assert (J.Node.Next /= null
+ or else J.Node = Container.Last);
+
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
declare
I_Next : constant Cursor := Next (I);
end;
end if;
end;
+
+ pragma Assert (Container.First.Prev = null);
+ pragma Assert (Container.Last.Next = null);
end Swap_Links;
--------------------
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
+ pragma Assert (Position.Container /= null);
+ pragma Assert (Position.Container.Length > 0);
+ pragma Assert (Position.Container.First.Prev = null);
+ pragma Assert (Position.Container.Last.Next = null);
+
+ pragma Assert (Position.Node /= null);
+ pragma Assert (Position.Node.Element /= null);
+ pragma Assert (Position.Node.Prev = null
+ or else Position.Node.Prev.Next = Position.Node);
+ pragma Assert (Position.Node.Next = null
+ or else Position.Node.Next.Prev = Position.Node);
+ pragma Assert (Position.Node.Prev /= null
+ or else Position.Node = Position.Container.First);
+ pragma Assert (Position.Node.Next /= null
+ or else Position.Node = Position.Container.Last);
+
+ E : Element_Type renames Position.Node.Element.all;
+
+ C : List renames Position.Container.all'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+
begin
- Process (Position.Node.Element.all);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Update_Element;
-----------
end Write;
end Ada.Containers.Indefinite_Doubly_Linked_Lists;
-
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS --
+-- A D A . C O N T A I N E R S . --
+-- I N D E F I N I T E _ D O U B L Y _ L I N K E D _ L I S T S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
Count : Count_Type := 1);
generic
- with function "<" (Left, Right : Element_Type)
- return Boolean is <>;
- procedure Generic_Sort (Container : in out List);
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ package Generic_Sorting is
- generic
- with function "<" (Left, Right : Element_Type)
- return Boolean is <>;
- procedure Generic_Merge
- (Target : in out List;
- Source : in out List);
+ function Is_Sorted (Container : List) return Boolean;
+
+ procedure Sort (Container : in out List);
+
+ procedure Merge (Target, Source : in out List);
+
+ end Generic_Sorting;
procedure Reverse_List (Container : in out List);
(Target : in out List;
Before : Cursor;
Source : in out List;
- Position : Cursor);
+ Position : in out Cursor);
function First (Container : List) return Cursor;
type Element_Access is access Element_Type;
type Node_Type is
- record
+ limited record
Element : Element_Access;
Next : Node_Access;
Prev : Node_Access;
end record;
- function "=" (L, R : Node_Type) return Boolean is abstract;
-
use Ada.Finalization;
type List is
First : Node_Access;
Last : Node_Access;
Length : Count_Type := 0;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
end record;
procedure Adjust (Container : in out List);
for List'Write use Write;
- Empty_List : constant List := List'(Controlled with null, null, 0);
+ Empty_List : constant List := List'(Controlled with null, null, 0, 0, 0);
type List_Access is access constant List;
for List_Access'Storage_Size use 0;
No_Element : constant Cursor := Cursor'(null, null);
end Ada.Containers.Indefinite_Doubly_Linked_Lists;
-
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS --
+-- A D A . C O N T A I N E R S . --
+-- I N D E F I N I T E _ H A S H E D _ M A P S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package body Ada.Containers.Indefinite_Hashed_Maps is
- type Key_Access is access Key_Type;
- type Element_Access is access Element_Type;
-
- type Node_Type is limited record
- Key : Key_Access;
- Element : Element_Access;
- Next : Node_Access;
- end record;
-
procedure Free_Key is
new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
function Copy_Node (Node : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
- function Equivalent_Keys
+ function Equivalent_Key_Node
(Key : Key_Type;
Node : Node_Access) return Boolean;
- pragma Inline (Equivalent_Keys);
+ pragma Inline (Equivalent_Key_Node);
function Find_Equal_Key
- (R_Map : Map;
+ (R_HT : Hash_Table_Type;
L_Node : Node_Access) return Boolean;
procedure Free (X : in out Node_Access);
- pragma Inline (Free);
+ -- pragma Inline (Free);
function Hash_Node (Node : Node_Access) return Hash_Type;
pragma Inline (Hash_Node);
procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next);
+ function Vet (Position : Cursor) return Boolean;
+
procedure Write_Node
(Stream : access Root_Stream_Type'Class;
Node : Node_Access);
package HT_Ops is
new Ada.Containers.Hash_Tables.Generic_Operations
(HT_Types => HT_Types,
- Hash_Table_Type => Map,
- Null_Node => null,
Hash_Node => Hash_Node,
Next => Next,
Set_Next => Set_Next,
package Key_Ops is
new Hash_Tables.Generic_Keys
(HT_Types => HT_Types,
- HT_Type => Map,
- Null_Node => null,
Next => Next,
Set_Next => Set_Next,
Key_Type => Key_Type,
Hash => Hash,
- Equivalent_Keys => Equivalent_Keys);
+ Equivalent_Keys => Equivalent_Key_Node);
---------
-- "=" --
function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
- function "=" (Left, Right : Map) return Boolean renames Is_Equal;
+ function "=" (Left, Right : Map) return Boolean is
+ begin
+ return Is_Equal (Left.HT, Right.HT);
+ end "=";
------------
-- Adjust --
------------
- procedure Adjust (Container : in out Map) renames HT_Ops.Adjust;
+ procedure Adjust (Container : in out Map) is
+ begin
+ HT_Ops.Adjust (Container.HT);
+ end Adjust;
--------------
-- Capacity --
--------------
- function Capacity (Container : Map)
- return Count_Type renames HT_Ops.Capacity;
+ function Capacity (Container : Map) return Count_Type is
+ begin
+ return HT_Ops.Capacity (Container.HT);
+ end Capacity;
-----------
-- Clear --
-----------
- procedure Clear (Container : in out Map) renames HT_Ops.Clear;
+ procedure Clear (Container : in out Map) is
+ begin
+ HT_Ops.Clear (Container.HT);
+ end Clear;
--------------
-- Contains --
X : Node_Access;
begin
- Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+ Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
if X = null then
raise Constraint_Error;
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
- if Position = No_Element then
+ if Position.Node = null then
+ raise Constraint_Error;
return;
end if;
raise Program_Error;
end if;
- HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
- Free (Position.Node);
+ pragma Assert (Position.Node.Next /= Position.Node);
+ pragma Assert (Position.Node.Key /= null);
+ pragma Assert (Position.Node.Element /= null);
+
+ if Container.HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
+ Free (Position.Node);
Position.Container := null;
end Delete;
function Element (Position : Cursor) return Element_Type is
begin
+ pragma Assert (Vet (Position));
return Position.Node.Element.all;
end Element;
- ---------------------
- -- Equivalent_Keys --
- ---------------------
+ -------------------------
+ -- Equivalent_Key_Node --
+ -------------------------
- function Equivalent_Keys
+ function Equivalent_Key_Node
(Key : Key_Type;
Node : Node_Access) return Boolean
is
begin
return Equivalent_Keys (Key, Node.Key.all);
- end Equivalent_Keys;
+ end Equivalent_Key_Node;
+
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
function Equivalent_Keys (Left, Right : Cursor) return Boolean is
begin
+ pragma Assert (Vet (Left));
+ pragma Assert (Vet (Right));
return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
end Equivalent_Keys;
Right : Key_Type) return Boolean
is
begin
+ pragma Assert (Vet (Left));
return Equivalent_Keys (Left.Node.Key.all, Right);
end Equivalent_Keys;
Right : Cursor) return Boolean
is
begin
+ pragma Assert (Vet (Right));
return Equivalent_Keys (Left, Right.Node.Key.all);
end Equivalent_Keys;
procedure Exclude (Container : in out Map; Key : Key_Type) is
X : Node_Access;
begin
- Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+ Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
Free (X);
end Exclude;
-- Finalize --
--------------
- procedure Finalize (Container : in out Map) renames HT_Ops.Finalize;
+ procedure Finalize (Container : in out Map) is
+ begin
+ HT_Ops.Finalize (Container.HT);
+ end Finalize;
----------
-- Find --
----------
function Find (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Node_Access := Key_Ops.Find (Container, Key);
+ Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
begin
if Node = null then
--------------------
function Find_Equal_Key
- (R_Map : Map;
+ (R_HT : Hash_Table_Type;
L_Node : Node_Access) return Boolean
is
- R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key.all);
- R_Node : Node_Access := R_Map.Buckets (R_Index);
+ R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key.all);
+ R_Node : Node_Access := R_HT.Buckets (R_Index);
begin
while R_Node /= null loop
-----------
function First (Container : Map) return Cursor is
- Node : constant Node_Access := HT_Ops.First (Container);
+ Node : constant Node_Access := HT_Ops.First (Container.HT);
begin
if Node = null then
return No_Element;
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
- if X /= null then
+ if X = null then
+ return;
+ end if;
+
+ X.Next := X; -- detect mischief (in Vet)
+
+ begin
Free_Key (X.Key);
+ exception
+ when others =>
+ X.Key := null;
+
+ begin
+ Free_Element (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ end;
+
+ Deallocate (X);
+ raise;
+ end;
+
+ begin
Free_Element (X.Element);
- Deallocate (X);
- end if;
+ exception
+ when others =>
+ X.Element := null;
+
+ Deallocate (X);
+ raise;
+ end;
+
+ Deallocate (X);
end Free;
-----------------
function Has_Element (Position : Cursor) return Boolean is
begin
- return Position /= No_Element;
+ if Position.Node = null then
+ pragma Assert (Position.Container = null);
+ return False;
+ end if;
+
+ pragma Assert (Vet (Position));
+ return True;
end Has_Element;
---------------
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
+ if Container.HT.Lock > 0 then
+ raise Program_Error;
+ end if;
+
K := Position.Node.Key;
E := Position.Node.Element;
Position.Node.Key := new Key_Type'(Key);
- Position.Node.Element := new Element_Type'(New_Item);
+
+ begin
+ Position.Node.Element := new Element_Type'(New_Item);
+ exception
+ when others =>
+ Free_Key (K);
+ raise;
+ end;
Free_Key (K);
Free_Element (E);
raise;
end New_Node;
+ HT : Hash_Table_Type renames Container.HT;
+
-- Start of processing for Insert
begin
- HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
- Insert (Container, Key, Position.Node, Inserted);
+ if HT.Length >= HT_Ops.Capacity (HT) then
+ -- TODO: see note in a-cohama.adb.
+ HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
+ end if;
+
+ Insert (HT, Key, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
function Is_Empty (Container : Map) return Boolean is
begin
- return Container.Length = 0;
+ return Container.HT.Length = 0;
end Is_Empty;
-------------
-- Start of processing Iterate
begin
- Iterate (Container);
+ Iterate (Container.HT);
end Iterate;
---------
function Key (Position : Cursor) return Key_Type is
begin
+ pragma Assert (Vet (Position));
return Position.Node.Key.all;
end Key;
function Length (Container : Map) return Count_Type is
begin
- return Container.Length;
+ return Container.HT.Length;
end Length;
----------
procedure Move
(Target : in out Map;
- Source : in out Map) renames HT_Ops.Move;
+ Source : in out Map)
+ is
+ begin
+ HT_Ops.Move (Target => Target.HT, Source => Source.HT);
+ end Move;
----------
-- Next --
function Next (Position : Cursor) return Cursor is
begin
- if Position = No_Element then
+ if Position.Node = null then
+ pragma Assert (Position.Container = null);
return No_Element;
end if;
declare
- M : Map renames Position.Container.all;
- Node : constant Node_Access := HT_Ops.Next (M, Position.Node);
+ pragma Assert (Vet (Position));
+ HT : Hash_Table_Type renames Position.Container.HT;
+ Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
begin
if Node = null then
procedure Query_Element
(Position : Cursor;
- Process : not null access procedure (Element : Element_Type))
+ Process : not null access procedure (Key : Key_Type;
+ Element : Element_Type))
is
+ pragma Assert (Vet (Position));
+
+ K : Key_Type renames Position.Node.Key.all;
+ E : Element_Type renames Position.Node.Element.all;
+
+ M : Map renames Position.Container.all;
+ HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+
begin
- Process (Position.Node.Key.all, Position.Node.Element.all);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Query_Element;
----------
procedure Read
(Stream : access Root_Stream_Type'Class;
- Container : out Map) renames Read_Nodes;
+ Container : out Map)
+ is
+ begin
+ Read_Nodes (Stream, Container.HT);
+ end Read;
---------------
-- Read_Node --
Key : Key_Type;
New_Item : Element_Type)
is
- Node : constant Node_Access := Key_Ops.Find (Container, Key);
+ Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
K : Key_Access;
E : Element_Access;
raise Constraint_Error;
end if;
+ if Container.HT.Lock > 0 then
+ raise Program_Error;
+ end if;
+
K := Node.Key;
E := Node.Element;
Node.Key := new Key_Type'(Key);
- Node.Element := new Element_Type'(New_Item);
+
+ begin
+ Node.Element := new Element_Type'(New_Item);
+ exception
+ when others =>
+ Free_Key (K);
+ raise;
+ end;
Free_Key (K);
Free_Element (E);
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
+ pragma Assert (Vet (Position));
X : Element_Access := Position.Node.Element;
begin
+ if Position.Container.HT.Lock > 0 then
+ raise Program_Error;
+ end if;
+
Position.Node.Element := new Element_Type'(By);
Free_Element (X);
end Replace_Element;
procedure Reserve_Capacity
(Container : in out Map;
- Capacity : Count_Type) renames HT_Ops.Ensure_Capacity;
+ Capacity : Count_Type)
+ is
+ begin
+ HT_Ops.Reserve_Capacity (Container.HT, Capacity);
+ end Reserve_Capacity;
--------------
-- Set_Next --
procedure Update_Element
(Position : Cursor;
- Process : not null access procedure (Element : in out Element_Type))
+ Process : not null access procedure (Key : Key_Type;
+ Element : in out Element_Type))
is
+ pragma Assert (Vet (Position));
+
+ K : Key_Type renames Position.Node.Key.all;
+ E : Element_Type renames Position.Node.Element.all;
+
+ M : Map renames Position.Container.all;
+ HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+
begin
- Process (Position.Node.Key.all, Position.Node.Element.all);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Update_Element;
+ ---------
+ -- Vet --
+ ---------
+
+ function Vet (Position : Cursor) return Boolean is
+ begin
+ if Position.Node = null then
+ return False;
+ end if;
+
+ if Position.Node.Next = Position.Node then
+ return False;
+ end if;
+
+ if Position.Node.Key = null then
+ return False;
+ end if;
+
+ if Position.Node.Element = null then
+ return False;
+ end if;
+
+ declare
+ HT : Hash_Table_Type renames Position.Container.HT;
+ X : Node_Access;
+ begin
+ if HT.Length = 0 then
+ return False;
+ end if;
+
+ if HT.Buckets = null then
+ return False;
+ end if;
+
+ X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all));
+
+ for J in 1 .. HT.Length loop
+ if X = Position.Node then
+ return True;
+ end if;
+
+ if X = null then
+ return False;
+ end if;
+
+ if X = X.Next then -- weird
+ return False;
+ end if;
+
+ X := X.Next;
+ end loop;
+
+ return False;
+ end;
+ end Vet;
+
-----------
-- Write --
-----------
procedure Write
(Stream : access Root_Stream_Type'Class;
- Container : Map) renames Write_Nodes;
+ Container : Map)
+ is
+ begin
+ Write_Nodes (Stream, Container.HT);
+ end Write;
----------------
-- Write_Node --
end Write_Node;
end Ada.Containers.Indefinite_Hashed_Maps;
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS --
+-- A D A . C O N T A I N E R S . --
+-- I N D E F I N I T E _ H A S H E D _ M A P S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Containers.Hash_Tables;
with Ada.Streams;
+with Ada.Finalization;
generic
type Key_Type (<>) is private;
procedure Clear (Container : in out Map);
+ function Key (Position : Cursor) return Key_Type;
+
function Element (Position : Cursor) return Element_Type;
procedure Query_Element
(Container : in out Map;
Key : Key_Type);
- procedure Exclude
- (Container : in out Map;
- Key : Key_Type);
-
procedure Delete
(Container : in out Map;
Position : in out Cursor);
+ procedure Exclude
+ (Container : in out Map;
+ Key : Key_Type);
+
function Contains
(Container : Map;
Key : Key_Type) return Boolean;
(Container : Map;
Key : Key_Type) return Element_Type;
- function Capacity (Container : Map) return Count_Type;
-
- procedure Reserve_Capacity
- (Container : in out Map;
- Capacity : Count_Type);
-
function First (Container : Map) return Cursor;
function Next (Position : Cursor) return Cursor;
function Has_Element (Position : Cursor) return Boolean;
- function Key (Position : Cursor) return Key_Type;
-
function Equivalent_Keys (Left, Right : Cursor)
return Boolean;
(Container : Map;
Process : not null access procedure (Position : Cursor));
+ function Capacity (Container : Map) return Count_Type;
+
+ procedure Reserve_Capacity
+ (Container : in out Map;
+ Capacity : Count_Type);
+
private
+ pragma Inline ("=");
+ pragma Inline (Length);
+ pragma Inline (Is_Empty);
+ pragma Inline (Clear);
+ pragma Inline (Key);
+ pragma Inline (Element);
+ pragma Inline (Move);
+ pragma Inline (Contains);
+ pragma Inline (Capacity);
+ pragma Inline (Reserve_Capacity);
+ pragma Inline (Has_Element);
+ pragma Inline (Equivalent_Keys);
+
type Node_Type;
type Node_Access is access Node_Type;
- package HT_Types is
- new Hash_Tables.Generic_Hash_Table_Types (Node_Access);
+ type Key_Access is access Key_Type;
+ type Element_Access is access Element_Type;
- use HT_Types;
+ type Node_Type is limited record
+ Key : Key_Access;
+ Element : Element_Access;
+ Next : Node_Access;
+ end record;
+
+ package HT_Types is new Hash_Tables.Generic_Hash_Table_Types
+ (Node_Type,
+ Node_Access);
+
+ type Map is new Ada.Finalization.Controlled with record
+ HT : HT_Types.Hash_Table_Type;
+ end record;
- type Map is new Hash_Table_Type with null record;
+ use HT_Types;
+ use Ada.Finalization;
procedure Adjust (Container : in out Map);
for Map'Read use Read;
- Empty_Map : constant Map := (Hash_Table_Type with null record);
+ Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0));
end Ada.Containers.Indefinite_Hashed_Maps;
-
-
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_HASHED_SETS --
+-- A D A . C O N T A I N E R S . --
+-- I N D E F I N I T E _ H A S H E D _ S E T S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Containers.Prime_Numbers;
-with Ada.Finalization; use Ada.Finalization;
-
package body Ada.Containers.Indefinite_Hashed_Sets is
- type Element_Access is access Element_Type;
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- type Node_Type is
- limited record
- Element : Element_Access;
- Next : Node_Access;
- end record;
+ function Copy_Node (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
- function Hash_Node
- (Node : Node_Access) return Hash_Type;
- pragma Inline (Hash_Node);
+ function Equivalent_Keys
+ (Key : Element_Type;
+ Node : Node_Access) return Boolean;
+ pragma Inline (Equivalent_Keys);
- function Hash_Node
- (Node : Node_Access) return Hash_Type is
- begin
- return Hash (Node.Element.all);
- end Hash_Node;
+ function Find_Equal_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean;
- function Next
- (Node : Node_Access) return Node_Access;
- pragma Inline (Next);
+ function Find_Equivalent_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean;
- function Next
- (Node : Node_Access) return Node_Access is
- begin
- return Node.Next;
- end Next;
+ procedure Free (X : in out Node_Access);
- procedure Set_Next
- (Node : Node_Access;
- Next : Node_Access);
- pragma Inline (Set_Next);
+ function Hash_Node (Node : Node_Access) return Hash_Type;
+ pragma Inline (Hash_Node);
- procedure Set_Next
- (Node : Node_Access;
- Next : Node_Access) is
- begin
- Node.Next := Next;
- end Set_Next;
+ function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean;
+ pragma Inline (Is_In);
- function Equivalent_Keys
- (Key : Element_Type;
- Node : Node_Access) return Boolean;
- pragma Inline (Equivalent_Keys);
+ function Next (Node : Node_Access) return Node_Access;
+ pragma Inline (Next);
- function Equivalent_Keys
- (Key : Element_Type;
- Node : Node_Access) return Boolean is
- begin
- return Equivalent_Keys (Key, Node.Element.all);
- end Equivalent_Keys;
+ function Read_Node (Stream : access Root_Stream_Type'Class)
+ return Node_Access;
+ pragma Inline (Read_Node);
- function Copy_Node
- (Source : Node_Access) return Node_Access;
- pragma Inline (Copy_Node);
+ procedure Replace_Element
+ (HT : in out Hash_Table_Type;
+ Node : Node_Access;
+ Element : Element_Type);
- function Copy_Node
- (Source : Node_Access) return Node_Access is
+ procedure Set_Next (Node : Node_Access; Next : Node_Access);
+ pragma Inline (Set_Next);
- Target : constant Node_Access :=
- new Node_Type'(Element => Source.Element,
- Next => null);
- begin
- return Target;
- end Copy_Node;
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+ pragma Inline (Write_Node);
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
procedure Free_Element is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
- procedure Free (X : in out Node_Access);
-
- procedure Free (X : in out Node_Access) is
- procedure Deallocate is
- new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
- begin
- if X /= null then
- Free_Element (X.Element);
- Deallocate (X);
- end if;
- end Free;
-
package HT_Ops is
new Hash_Tables.Generic_Operations
- (HT_Types => HT_Types,
- Hash_Table_Type => Set,
- Null_Node => null,
- Hash_Node => Hash_Node,
- Next => Next,
- Set_Next => Set_Next,
- Copy_Node => Copy_Node,
- Free => Free);
+ (HT_Types => HT_Types,
+ Hash_Node => Hash_Node,
+ Next => Next,
+ Set_Next => Set_Next,
+ Copy_Node => Copy_Node,
+ Free => Free);
package Element_Keys is
new Hash_Tables.Generic_Keys
(HT_Types => HT_Types,
- HT_Type => Set,
- Null_Node => null,
Next => Next,
Set_Next => Set_Next,
Key_Type => Element_Type,
Hash => Hash,
Equivalent_Keys => Equivalent_Keys);
+ function Is_Equal is
+ new HT_Ops.Generic_Equal (Find_Equal_Key);
- procedure Adjust (Container : in out Set) renames HT_Ops.Adjust;
-
- procedure Finalize (Container : in out Set) renames HT_Ops.Finalize;
-
-
- function Find_Equal_Key
- (R_Set : Set;
- L_Node : Node_Access) return Boolean;
+ function Is_Equivalent is
+ new HT_Ops.Generic_Equal (Find_Equivalent_Key);
- function Find_Equal_Key
- (R_Set : Set;
- L_Node : Node_Access) return Boolean is
+ procedure Read_Nodes is
+ new HT_Ops.Generic_Read (Read_Node);
- R_Index : constant Hash_Type :=
- Element_Keys.Index (R_Set, L_Node.Element.all);
+ procedure Write_Nodes is
+ new HT_Ops.Generic_Write (Write_Node);
- R_Node : Node_Access := R_Set.Buckets (R_Index);
+ ---------
+ -- "=" --
+ ---------
+ function "=" (Left, Right : Set) return Boolean is
begin
+ return Is_Equal (Left.HT, Right.HT);
+ end "=";
- loop
-
- if R_Node = null then
- return False;
- end if;
-
- if L_Node.Element.all = R_Node.Element.all then
- return True;
- end if;
-
- R_Node := Next (R_Node);
-
- end loop;
-
- end Find_Equal_Key;
-
- function Is_Equal is
- new HT_Ops.Generic_Equal (Find_Equal_Key);
+ ------------
+ -- Adjust --
+ ------------
- function "=" (Left, Right : Set) return Boolean renames Is_Equal;
+ procedure Adjust (Container : in out Set) is
+ begin
+ HT_Ops.Adjust (Container.HT);
+ end Adjust;
+ --------------
+ -- Capacity --
+ --------------
- function Length (Container : Set) return Count_Type is
+ function Capacity (Container : Set) return Count_Type is
begin
- return Container.Length;
- end Length;
+ return HT_Ops.Capacity (Container.HT);
+ end Capacity;
+ -----------
+ -- Clear --
+ -----------
- function Is_Empty (Container : Set) return Boolean is
+ procedure Clear (Container : in out Set) is
begin
- return Container.Length = 0;
- end Is_Empty;
+ HT_Ops.Clear (Container.HT);
+ end Clear;
+ --------------
+ -- Contains --
+ --------------
- procedure Clear (Container : in out Set) renames HT_Ops.Clear;
+ function Contains (Container : Set; Item : Element_Type) return Boolean is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+ ---------------
+ -- Copy_Node --
+ ---------------
- function Element (Position : Cursor) return Element_Type is
+ function Copy_Node (Source : Node_Access) return Node_Access is
+ E : Element_Access := new Element_Type'(Source.Element.all);
begin
- return Position.Node.Element.all;
- end Element;
+ return new Node_Type'(Element => E, Next => null);
+ exception
+ when others =>
+ Free_Element (E);
+ raise;
+ end Copy_Node;
+ ------------
+ -- Delete --
+ ------------
- procedure Query_Element
- (Position : in Cursor;
- Process : not null access procedure (Element : in Element_Type)) is
- begin
- Process (Position.Node.Element.all);
- end Query_Element;
+ procedure Delete
+ (Container : in out Set;
+ Item : Element_Type)
+ is
+ X : Node_Access;
+ begin
+ Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
--- TODO:
--- procedure Replace_Element (Container : in out Set;
--- Position : in Node_Access;
--- By : in Element_Type);
+ if X = null then
+ raise Constraint_Error;
+ end if;
--- procedure Replace_Element (Container : in out Set;
--- Position : in Node_Access;
--- By : in Element_Type) is
+ Free (X);
+ end Delete;
--- Node : Node_Access := Position;
+ procedure Delete
+ (Container : in out Set;
+ Position : in out Cursor)
+ is
+ begin
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
--- begin
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
--- if Equivalent_Keys (Node.Element.all, By) then
+ if Container.HT.Busy > 0 then
+ raise Program_Error;
+ end if;
--- declare
--- X : Element_Access := Node.Element;
--- begin
--- Node.Element := new Element_Type'(By);
--- --
--- -- NOTE: If there's an exception here, then just
--- -- let it propagate. We haven't modified the
--- -- state of the container, so there's nothing else
--- -- we need to do.
+ HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
--- Free_Element (X);
--- end;
+ Free (Position.Node);
--- return;
+ Position.Container := null;
+ end Delete;
--- end if;
+ ----------------
+ -- Difference --
+ ----------------
--- HT_Ops.Delete_Node_Sans_Free (Container, Node);
+ procedure Difference
+ (Target : in out Set;
+ Source : Set)
+ is
+ Tgt_Node : Node_Access;
--- begin
--- Free_Element (Node.Element);
--- exception
--- when others =>
--- Node.Element := null; -- don't attempt to dealloc X.E again
--- Free (Node);
--- raise;
--- end;
+ begin
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
--- begin
--- Node.Element := new Element_Type'(By);
--- exception
--- when others =>
--- Free (Node);
--- raise;
--- end;
+ if Source.Length = 0 then
+ return;
+ end if;
--- declare
--- function New_Node (Next : Node_Access) return Node_Access;
--- pragma Inline (New_Node);
+ if Target.HT.Busy > 0 then
+ raise Program_Error;
+ end if;
--- function New_Node (Next : Node_Access) return Node_Access is
--- begin
--- Node.Next := Next;
--- return Node;
--- end New_Node;
+ -- TODO: This can be written in terms of a loop instead as
+ -- active-iterator style, sort of like a passive iterator.
--- procedure Insert is
--- new Element_Keys.Generic_Conditional_Insert (New_Node);
+ Tgt_Node := HT_Ops.First (Target.HT);
+ while Tgt_Node /= null loop
+ if Is_In (Source.HT, Tgt_Node) then
+ declare
+ X : Node_Access := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
+ Free (X);
+ end;
--- Result : Node_Access;
--- Success : Boolean;
--- begin
--- Insert
--- (HT => Container,
--- Key => Node.Element.all,
--- Node => Result,
--- Success => Success);
+ else
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+ end if;
+ end loop;
+ end Difference;
--- if not Success then
--- Free (Node);
--- raise Program_Error;
--- end if;
+ function Difference (Left, Right : Set) return Set is
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
--- pragma Assert (Result = Node);
--- end;
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
--- end Replace_Element;
+ if Left.Length = 0 then
+ return Empty_Set;
+ end if;
+ if Right.Length = 0 then
+ return Left;
+ end if;
--- procedure Replace_Element (Container : in out Set;
--- Position : in Cursor;
--- By : in Element_Type) is
--- begin
+ declare
+ Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
--- if Position.Container = null then
--- raise Constraint_Error;
--- end if;
+ Length := 0;
--- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
--- raise Program_Error;
--- end if;
+ Iterate_Left : declare
+ procedure Process (L_Node : Node_Access);
--- Replace_Element (Container, Position.Node, By);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
--- end Replace_Element;
+ -------------
+ -- Process --
+ -------------
+ procedure Process (L_Node : Node_Access) is
+ begin
+ if not Is_In (Right.HT, L_Node) then
+ declare
+ Indx : constant Hash_Type :=
+ Hash (L_Node.Element.all) mod Buckets'Length;
- procedure Move (Target : in out Set;
- Source : in out Set) renames HT_Ops.Move;
+ Bucket : Node_Access renames Buckets (Indx);
+ begin
+ Bucket := new Node_Type'(L_Node.Element, Bucket);
+ end;
- procedure Insert (Container : in out Set;
- New_Item : in Element_Type;
- Position : out Cursor;
- Inserted : out Boolean) is
+ Length := Length + 1;
+ end if;
+ end Process;
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
+ -- Start of processing for Iterate_Left
- function New_Node (Next : Node_Access) return Node_Access is
- Element : Element_Access := new Element_Type'(New_Item);
begin
- return new Node_Type'(Element, Next);
+ Iterate (Left.HT);
exception
when others =>
- Free_Element (Element);
+ HT_Ops.Free_Hash_Table (Buckets);
raise;
- end New_Node;
+ end Iterate_Left;
- procedure Insert is
- new Element_Keys.Generic_Conditional_Insert (New_Node);
+ return (Controlled with HT => (Buckets, Length, 0, 0));
+ end Difference;
+
+ -------------
+ -- Element --
+ -------------
+ function Element (Position : Cursor) return Element_Type is
begin
+ return Position.Node.Element.all;
+ end Element;
- HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
- Insert (Container, New_Item, Position.Node, Inserted);
- Position.Container := Container'Unchecked_Access;
+ ---------------------
+ -- Equivalent_Sets --
+ ---------------------
- end Insert;
+ function Equivalent_Sets (Left, Right : Set) return Boolean is
+ begin
+ return Is_Equivalent (Left.HT, Right.HT);
+ end Equivalent_Sets;
+ -------------------------
+ -- Equivalent_Elements --
+ -------------------------
- procedure Insert (Container : in out Set;
- New_Item : in Element_Type) is
+ function Equivalent_Elements (Left, Right : Cursor)
+ return Boolean is
+ begin
+ return Equivalent_Elements
+ (Left.Node.Element.all,
+ Right.Node.Element.all);
+ end Equivalent_Elements;
- Position : Cursor;
- Inserted : Boolean;
+ function Equivalent_Elements (Left : Cursor; Right : Element_Type)
+ return Boolean is
+ begin
+ return Equivalent_Elements (Left.Node.Element.all, Right);
+ end Equivalent_Elements;
+ function Equivalent_Elements (Left : Element_Type; Right : Cursor)
+ return Boolean is
begin
+ return Equivalent_Elements (Left, Right.Node.Element.all);
+ end Equivalent_Elements;
- Insert (Container, New_Item, Position, Inserted);
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
- if not Inserted then
- raise Constraint_Error;
- end if;
+ function Equivalent_Keys (Key : Element_Type; Node : Node_Access)
+ return Boolean is
+ begin
+ return Equivalent_Elements (Key, Node.Element.all);
+ end Equivalent_Keys;
- end Insert;
+ -------------
+ -- Exclude --
+ -------------
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type)
+ is
+ X : Node_Access;
+ begin
+ Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
+ Free (X);
+ end Exclude;
- procedure Replace (Container : in out Set;
- New_Item : in Element_Type) is
+ --------------
+ -- Finalize --
+ --------------
- Node : constant Node_Access :=
- Element_Keys.Find (Container, New_Item);
+ procedure Finalize (Container : in out Set) is
+ begin
+ HT_Ops.Finalize (Container.HT);
+ end Finalize;
- X : Element_Access;
+ ----------
+ -- Find --
+ ----------
- begin
+ function Find
+ (Container : Set;
+ Item : Element_Type) return Cursor
+ is
+ Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
+ begin
if Node = null then
- raise Constraint_Error;
+ return No_Element;
end if;
- X := Node.Element;
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
- Node.Element := new Element_Type'(New_Item);
+ --------------------
+ -- Find_Equal_Key --
+ --------------------
- Free_Element (X);
+ function Find_Equal_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean
+ is
+ R_Index : constant Hash_Type :=
+ Element_Keys.Index (R_HT, L_Node.Element.all);
- end Replace;
+ R_Node : Node_Access := R_HT.Buckets (R_Index);
+ begin
+ loop
+ if R_Node = null then
+ return False;
+ end if;
- procedure Include (Container : in out Set;
- New_Item : in Element_Type) is
+ if L_Node.Element.all = R_Node.Element.all then
+ return True;
+ end if;
- Position : Cursor;
- Inserted : Boolean;
+ R_Node := Next (R_Node);
+ end loop;
+ end Find_Equal_Key;
- X : Element_Access;
+ -------------------------
+ -- Find_Equivalent_Key --
+ -------------------------
+
+ function Find_Equivalent_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean
+ is
+ R_Index : constant Hash_Type :=
+ Element_Keys.Index (R_HT, L_Node.Element.all);
+
+ R_Node : Node_Access := R_HT.Buckets (R_Index);
begin
+ loop
+ if R_Node = null then
+ return False;
+ end if;
- Insert (Container, New_Item, Position, Inserted);
+ if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
+ return True;
+ end if;
- if not Inserted then
+ R_Node := Next (R_Node);
+ end loop;
+ end Find_Equivalent_Key;
- X := Position.Node.Element;
+ -----------
+ -- First --
+ -----------
- Position.Node.Element := new Element_Type'(New_Item);
-
- Free_Element (X);
+ function First (Container : Set) return Cursor is
+ Node : constant Node_Access := HT_Ops.First (Container.HT);
+ begin
+ if Node = null then
+ return No_Element;
end if;
- end Include;
-
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end First;
- procedure Delete (Container : in out Set;
- Item : in Element_Type) is
+ ----------
+ -- Free --
+ ----------
- X : Node_Access;
+ procedure Free (X : in out Node_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
-
- Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
-
if X = null then
- raise Constraint_Error;
+ return;
end if;
- Free (X);
+ begin
+ Free_Element (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ Deallocate (X);
+ raise;
+ end;
- end Delete;
+ Deallocate (X);
+ end Free;
+ -----------------
+ -- Has_Element --
+ -----------------
- procedure Exclude (Container : in out Set;
- Item : in Element_Type) is
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ if Position.Node = null then
+ pragma Assert (Position.Container = null);
+ return False;
+ end if;
- X : Node_Access;
+ return True;
+ end Has_Element;
+ ---------------
+ -- Hash_Node --
+ ---------------
+
+ function Hash_Node (Node : Node_Access) return Hash_Type is
begin
+ return Hash (Node.Element.all);
+ end Hash_Node;
- Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
- Free (X);
+ -------------
+ -- Include --
+ -------------
- end Exclude;
+ procedure Include
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+ X : Element_Access;
- procedure Delete (Container : in out Set;
- Position : in out Cursor) is
begin
+ Insert (Container, New_Item, Position, Inserted);
- if Position = No_Element then
- return;
- end if;
+ if not Inserted then
+ if Container.HT.Lock > 0 then
+ raise Program_Error;
+ end if;
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
- raise Program_Error;
- end if;
+ X := Position.Node.Element;
- HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
- Free (Position.Node);
+ Position.Node.Element := new Element_Type'(New_Item);
- Position.Container := null;
+ Free_Element (X);
+ end if;
+ end Include;
- end Delete;
+ ------------
+ -- Insert --
+ ------------
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
- procedure Union (Target : in out Set;
- Source : in Set) is
+ --------------
+ -- New_Node --
+ --------------
- procedure Process (Src_Node : in Node_Access);
+ function New_Node (Next : Node_Access) return Node_Access is
+ Element : Element_Access := new Element_Type'(New_Item);
- procedure Process (Src_Node : in Node_Access) is
+ begin
+ return new Node_Type'(Element, Next);
+ exception
+ when others =>
+ Free_Element (Element);
+ raise;
+ end New_Node;
- Src : Element_Type renames Src_Node.Element.all;
+ HT : Hash_Table_Type renames Container.HT;
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
+ -- Start of processing for Insert
- function New_Node (Next : Node_Access) return Node_Access is
- Tgt : Element_Access := new Element_Type'(Src);
- begin
- return new Node_Type'(Tgt, Next);
- exception
- when others =>
- Free_Element (Tgt);
- raise;
- end New_Node;
+ begin
+ if HT.Length >= HT_Ops.Capacity (HT) then
+ -- TODO: optimize this (see a-cohase.adb)
+ HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
+ end if;
- procedure Insert is
- new Element_Keys.Generic_Conditional_Insert (New_Node);
+ Insert (HT, New_Item, Position.Node, Inserted);
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
- Tgt_Node : Node_Access;
- Success : Boolean;
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
- begin
+ begin
+ Insert (Container, New_Item, Position, Inserted);
- Insert (Target, Src, Tgt_Node, Success);
+ if not Inserted then
+ raise Constraint_Error;
+ end if;
+ end Insert;
- end Process;
+ ------------------
+ -- Intersection --
+ ------------------
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ procedure Intersection
+ (Target : in out Set;
+ Source : Set)
+ is
+ Tgt_Node : Node_Access;
begin
-
if Target'Address = Source'Address then
return;
end if;
- HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
-
- Iterate (Source);
+ if Source.Length = 0 then
+ Clear (Target);
+ return;
+ end if;
- end Union;
+ if Target.HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+ -- TODO: optimize this to use an explicit
+ -- loop instead of an active iterator
+ -- (similar to how a passive iterator is
+ -- implemented).
+ --
+ -- Another possibility is to test which
+ -- set is smaller, and iterate over the
+ -- smaller set.
+ Tgt_Node := HT_Ops.First (Target.HT);
+ while Tgt_Node /= null loop
+ if Is_In (Source.HT, Tgt_Node) then
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
- function Union (Left, Right : Set) return Set is
+ else
+ declare
+ X : Node_Access := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
+ Free (X);
+ end;
+ end if;
+ end loop;
+ end Intersection;
+ function Intersection (Left, Right : Set) return Set is
Buckets : HT_Types.Buckets_Access;
Length : Count_Type;
begin
-
if Left'Address = Right'Address then
return Left;
end if;
- if Right.Length = 0 then
- return Left;
- end if;
+ Length := Count_Type'Min (Left.Length, Right.Length);
- if Left.Length = 0 then
- return Right;
+ if Length = 0 then
+ return Empty_Set;
end if;
declare
- Size : constant Hash_Type :=
- Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
begin
Buckets := new Buckets_Type (0 .. Size - 1);
end;
- declare
+ Length := 0;
+
+ Iterate_Left : declare
procedure Process (L_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (L_Node : Node_Access) is
- I : constant Hash_Type :=
- Hash (L_Node.Element.all) mod Buckets'Length;
begin
- Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
+ if Is_In (Right.HT, L_Node) then
+ declare
+ Indx : constant Hash_Type :=
+ Hash (L_Node.Element.all) mod Buckets'Length;
+
+ Bucket : Node_Access renames Buckets (Indx);
+
+ begin
+ Bucket := new Node_Type'(L_Node.Element, Bucket);
+ end;
+
+ Length := Length + 1;
+ end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ -- Start of processing for Iterate_Left
+
begin
- Iterate (Left);
+ Iterate (Left.HT);
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
raise;
- end;
+ end Iterate_Left;
- Length := Left.Length;
+ return (Controlled with HT => (Buckets, Length, 0, 0));
+ end Intersection;
- declare
- procedure Process (Src_Node : Node_Access);
+ --------------
+ -- Is_Empty --
+ --------------
- procedure Process (Src_Node : Node_Access) is
+ function Is_Empty (Container : Set) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
- Src : Element_Type renames Src_Node.Element.all;
+ -----------
+ -- Is_In --
+ -----------
- I : constant Hash_Type :=
- Hash (Src) mod Buckets'Length;
+ function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
+ begin
+ return Element_Keys.Find (HT, Key.Element.all) /= null;
+ end Is_In;
- Tgt_Node : Node_Access := Buckets (I);
+ ---------------
+ -- Is_Subset --
+ ---------------
- begin
+ function Is_Subset
+ (Subset : Set;
+ Of_Set : Set) return Boolean
+ is
+ Subset_Node : Node_Access;
- while Tgt_Node /= null loop
+ begin
+ if Subset'Address = Of_Set'Address then
+ return True;
+ end if;
- if Equivalent_Keys (Src, Tgt_Node.Element.all) then
- return;
- end if;
+ if Subset.Length > Of_Set.Length then
+ return False;
+ end if;
- Tgt_Node := Next (Tgt_Node);
+ -- TODO: rewrite this to loop in the
+ -- style of a passive iterator.
- end loop;
+ Subset_Node := HT_Ops.First (Subset.HT);
+ while Subset_Node /= null loop
+ if not Is_In (Of_Set.HT, Subset_Node) then
+ return False;
+ end if;
- declare
- Tgt : Element_Access := new Element_Type'(Src);
- begin
- Buckets (I) := new Node_Type'(Tgt, Buckets (I));
- exception
- when others =>
- Free_Element (Tgt);
- raise;
- end;
+ Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
+ end loop;
- Length := Length + 1;
+ return True;
+ end Is_Subset;
- end Process;
+ -------------
+ -- Iterate --
+ -------------
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
- begin
- Iterate (Right);
- exception
- when others =>
- HT_Ops.Free_Hash_Table (Buckets);
- raise;
- end;
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
- return (Controlled with Buckets, Length);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process_Node);
- end Union;
+ ------------------
+ -- Process_Node --
+ ------------------
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ end Process_Node;
- function Is_In
- (HT : Set;
- Key : Node_Access) return Boolean;
- pragma Inline (Is_In);
+ HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
+ B : Natural renames HT.Busy;
+
+ -- Start of processing for Iterate
- function Is_In
- (HT : Set;
- Key : Node_Access) return Boolean is
begin
- return Element_Keys.Find (HT, Key.Element.all) /= null;
- end Is_In;
+ B := B + 1;
+ begin
+ Iterate (HT);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
- procedure Intersection (Target : in out Set;
- Source : in Set) is
+ B := B - 1;
+ end Iterate;
- Tgt_Node : Node_Access;
+ ------------
+ -- Length --
+ ------------
+ function Length (Container : Set) return Count_Type is
begin
+ return Container.HT.Length;
+ end Length;
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Source.Length = 0 then
- Clear (Target);
- return;
- end if;
-
- -- TODO: optimize this to use an explicit
- -- loop instead of an active iterator
- -- (similar to how a passive iterator is
- -- implemented).
- --
- -- Another possibility is to test which
- -- set is smaller, and iterate over the
- -- smaller set.
-
- Tgt_Node := HT_Ops.First (Target);
+ ----------
+ -- Move --
+ ----------
- while Tgt_Node /= null loop
+ procedure Move (Target : in out Set; Source : in out Set) is
+ begin
+ HT_Ops.Move (Target => Target.HT, Source => Source.HT);
+ end Move;
- if Is_In (Source, Tgt_Node) then
+ ----------
+ -- Next --
+ ----------
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ function Next (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Next;
+ end Next;
- else
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position.Node = null then
+ pragma Assert (Position.Container = null);
+ return No_Element;
+ end if;
- declare
- X : Node_Access := Tgt_Node;
- begin
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target, X);
- Free (X);
- end;
+ declare
+ HT : Hash_Table_Type renames Position.Container.HT;
+ Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
+ begin
+ if Node = null then
+ return No_Element;
end if;
- end loop;
-
- end Intersection;
+ return Cursor'(Position.Container, Node);
+ end;
+ end Next;
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
- function Intersection (Left, Right : Set) return Set is
+ -------------
+ -- Overlap --
+ -------------
- Buckets : HT_Types.Buckets_Access;
- Length : Count_Type;
+ function Overlap (Left, Right : Set) return Boolean is
+ Left_Node : Node_Access;
begin
+ if Right.Length = 0 then
+ return False;
+ end if;
if Left'Address = Right'Address then
- return Left;
+ return True;
end if;
- Length := Count_Type'Min (Left.Length, Right.Length);
-
- if Length = 0 then
- return Empty_Set;
- end if;
+ Left_Node := HT_Ops.First (Left.HT);
+ while Left_Node /= null loop
+ if Is_In (Right.HT, Left_Node) then
+ return True;
+ end if;
- declare
- Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
- begin
- Buckets := new Buckets_Type (0 .. Size - 1);
- end;
+ Left_Node := HT_Ops.Next (Left.HT, Left_Node);
+ end loop;
- Length := 0;
+ return False;
+ end Overlap;
- declare
- procedure Process (L_Node : Node_Access);
+ -------------------
+ -- Query_Element --
+ -------------------
- procedure Process (L_Node : Node_Access) is
- begin
- if Is_In (Right, L_Node) then
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ E : Element_Type renames Position.Node.Element.all;
- declare
- I : constant Hash_Type :=
- Hash (L_Node.Element.all) mod Buckets'Length;
- begin
- Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
- end;
+ HT : Hash_Table_Type renames
+ Position.Container'Unrestricted_Access.all.HT;
- Length := Length + 1;
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
- end if;
- end Process;
+ begin
+ B := B + 1;
+ L := L + 1;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
begin
- Iterate (Left);
+ Process (E);
exception
when others =>
- HT_Ops.Free_Hash_Table (Buckets);
+ L := L - 1;
+ B := B - 1;
raise;
end;
- return (Controlled with Buckets, Length);
-
- end Intersection;
+ L := L - 1;
+ B := B - 1;
+ end Query_Element;
+ ----------
+ -- Read --
+ ----------
- procedure Difference (Target : in out Set;
- Source : in Set) is
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set)
+ is
+ begin
+ Read_Nodes (Stream, Container.HT);
+ end Read;
+ ---------------
+ -- Read_Node --
+ ---------------
- Tgt_Node : Node_Access;
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access
+ is
+ X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
begin
+ return new Node_Type'(X, null);
+ exception
+ when others =>
+ Free_Element (X);
+ raise;
+ end Read_Node;
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
+ -------------
+ -- Replace --
+ -------------
- if Source.Length = 0 then
- return;
- end if;
+ procedure Replace
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access :=
+ Element_Keys.Find (Container.HT, New_Item);
- -- TODO: As I noted above, this can be
- -- written in terms of a loop instead as
- -- active-iterator style, sort of like a
- -- passive iterator.
+ X : Element_Access;
- Tgt_Node := HT_Ops.First (Target);
+ begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
- while Tgt_Node /= null loop
+ if Container.HT.Lock > 0 then
+ raise Program_Error;
+ end if;
- if Is_In (Source, Tgt_Node) then
+ X := Node.Element;
- declare
- X : Node_Access := Tgt_Node;
- begin
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target, X);
- Free (X);
- end;
+ Node.Element := new Element_Type'(New_Item);
- else
+ Free_Element (X);
+ end Replace;
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (HT : in out Hash_Table_Type;
+ Node : Node_Access;
+ Element : Element_Type)
+ is
+ begin
+ if Equivalent_Elements (Node.Element.all, Element) then
+ pragma Assert (Hash (Node.Element.all) = Hash (Element));
+ if HT.Lock > 0 then
+ raise Program_Error;
end if;
- end loop;
+ declare
+ X : Element_Access := Node.Element;
+ begin
+ Node.Element := new Element_Type'(Element); -- OK if fails
+ Free_Element (X);
+ end;
- end Difference;
+ return;
+ end if;
+ if HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+ HT_Ops.Delete_Node_Sans_Free (HT, Node);
- function Difference (Left, Right : Set) return Set is
+ Insert_New_Element : declare
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
- Buckets : HT_Types.Buckets_Access;
- Length : Count_Type;
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
- begin
+ ------------------------
+ -- Insert_New_Element --
+ ------------------------
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
+ function New_Node (Next : Node_Access) return Node_Access is
+ begin
+ Node.Element := new Element_Type'(Element); -- OK if fails
+ Node.Next := Next;
+ return Node;
+ end New_Node;
- if Left.Length = 0 then
- return Empty_Set;
- end if;
+ Result : Node_Access;
+ Inserted : Boolean;
- if Right.Length = 0 then
- return Left;
- end if;
+ X : Element_Access := Node.Element;
+
+ -- Start of processing for Insert_New_Element
- declare
- Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
- end;
+ Attempt_Insert : begin
+ Insert
+ (HT => HT,
+ Key => Element,
+ Node => Result,
+ Inserted => Inserted);
+ exception
+ when others =>
+ Inserted := False; -- Assignment failed
+ end Attempt_Insert;
- Length := 0;
+ if Inserted then
+ pragma Assert (Result = Node);
+ Free_Element (X); -- Just propagate if fails
+ return;
+ end if;
+ end Insert_New_Element;
+ Reinsert_Old_Element :
declare
- procedure Process (L_Node : Node_Access);
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
- procedure Process (L_Node : Node_Access) is
- begin
- if not Is_In (Right, L_Node) then
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
- declare
- I : constant Hash_Type :=
- Hash (L_Node.Element.all) mod Buckets'Length;
- begin
- Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
- end;
+ --------------
+ -- New_Node --
+ --------------
- Length := Length + 1;
+ function New_Node (Next : Node_Access) return Node_Access is
+ begin
+ Node.Next := Next;
+ return Node;
+ end New_Node;
- end if;
- end Process;
+ Result : Node_Access;
+ Inserted : Boolean;
+
+ -- Start of processing for Reinsert_Old_Element
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
begin
- Iterate (Left);
+ Insert
+ (HT => HT,
+ Key => Node.Element.all,
+ Node => Result,
+ Inserted => Inserted);
exception
when others =>
- HT_Ops.Free_Hash_Table (Buckets);
- raise;
- end;
+ null;
+ end Reinsert_Old_Element;
- return (Controlled with Buckets, Length);
+ raise Program_Error;
+ end Replace_Element;
- end Difference;
+ procedure Replace_Element
+ (Container : Set;
+ Position : Cursor;
+ By : Element_Type)
+ is
+ HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
+
+ begin
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+ if Position.Container /= Set_Access'(Container'Unrestricted_Access) then
+ raise Program_Error;
+ end if;
+
+ Replace_Element (HT, Position.Node, By);
+ end Replace_Element;
+
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ procedure Reserve_Capacity
+ (Container : in out Set;
+ Capacity : Count_Type)
+ is
+ begin
+ HT_Ops.Reserve_Capacity (Container.HT, Capacity);
+ end Reserve_Capacity;
+ --------------
+ -- Set_Next --
+ --------------
- procedure Symmetric_Difference (Target : in out Set;
- Source : in Set) is
+ procedure Set_Next (Node : Node_Access; Next : Node_Access) is
begin
+ Node.Next := Next;
+ end Set_Next;
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Symmetric_Difference
+ (Target : in out Set;
+ Source : Set)
+ is
+ begin
if Target'Address = Source'Address then
Clear (Target);
return;
end if;
- HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
+ if Target.HT.Busy > 0 then
+ raise Program_Error;
+ end if;
- if Target.Length = 0 then
+ declare
+ N : constant Count_Type := Target.Length + Source.Length;
+ begin
+ if N > HT_Ops.Capacity (Target.HT) then
+ HT_Ops.Reserve_Capacity (Target.HT, N);
+ end if;
+ end;
- declare
+ if Target.Length = 0 then
+ Iterate_Source_When_Empty_Target : declare
procedure Process (Src_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (Src_Node : Node_Access) is
E : Element_Type renames Src_Node.Element.all;
- B : Buckets_Type renames Target.Buckets.all;
- I : constant Hash_Type := Hash (E) mod B'Length;
- N : Count_Type renames Target.Length;
+ B : Buckets_Type renames Target.HT.Buckets.all;
+ J : constant Hash_Type := Hash (E) mod B'Length;
+ N : Count_Type renames Target.HT.Length;
+
begin
declare
X : Element_Access := new Element_Type'(E);
begin
- B (I) := new Node_Type'(X, B (I));
+ B (J) := new Node_Type'(X, B (J));
exception
when others =>
Free_Element (X);
N := N + 1;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ -- Start of processing for Iterate_Source_When_Empty_Target
+
begin
- Iterate (Source);
- end;
+ Iterate (Source.HT);
+ end Iterate_Source_When_Empty_Target;
else
-
- declare
+ Iterate_Source : declare
procedure Process (Src_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (Src_Node : Node_Access) is
E : Element_Type renames Src_Node.Element.all;
- B : Buckets_Type renames Target.Buckets.all;
- I : constant Hash_Type := Hash (E) mod B'Length;
- N : Count_Type renames Target.Length;
- begin
- if B (I) = null then
+ B : Buckets_Type renames Target.HT.Buckets.all;
+ J : constant Hash_Type := Hash (E) mod B'Length;
+ N : Count_Type renames Target.HT.Length;
+ begin
+ if B (J) = null then
declare
X : Element_Access := new Element_Type'(E);
begin
- B (I) := new Node_Type'(X, null);
+ B (J) := new Node_Type'(X, null);
exception
when others =>
Free_Element (X);
N := N + 1;
- elsif Equivalent_Keys (E, B (I).Element.all) then
-
+ elsif Equivalent_Elements (E, B (J).Element.all) then
declare
- X : Node_Access := B (I);
+ X : Node_Access := B (J);
begin
- B (I) := B (I).Next;
+ B (J) := B (J).Next;
N := N - 1;
Free (X);
end;
else
-
declare
- Prev : Node_Access := B (I);
+ Prev : Node_Access := B (J);
Curr : Node_Access := Prev.Next;
+
begin
while Curr /= null loop
- if Equivalent_Keys (E, Curr.Element.all) then
+ if Equivalent_Elements (E, Curr.Element.all) then
Prev.Next := Curr.Next;
N := N - 1;
Free (Curr);
declare
X : Element_Access := new Element_Type'(E);
begin
- B (I) := new Node_Type'(X, B (I));
+ B (J) := new Node_Type'(X, B (J));
exception
when others =>
Free_Element (X);
N := N + 1;
end;
-
end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
- begin
- Iterate (Source);
- end;
+ -- Start of processing for Iterate_Source
+ begin
+ Iterate (Source.HT);
+ end Iterate_Source;
end if;
-
end Symmetric_Difference;
-
function Symmetric_Difference (Left, Right : Set) return Set is
-
Buckets : HT_Types.Buckets_Access;
Length : Count_Type;
begin
-
if Left'Address = Right'Address then
return Empty_Set;
end if;
declare
Size : constant Hash_Type :=
- Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ Prime_Numbers.To_Prime (Left.Length + Right.Length);
begin
Buckets := new Buckets_Type (0 .. Size - 1);
end;
Length := 0;
- declare
+ Iterate_Left : declare
procedure Process (L_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (L_Node : Node_Access) is
begin
- if not Is_In (Right, L_Node) then
+ if not Is_In (Right.HT, L_Node) then
declare
E : Element_Type renames L_Node.Element.all;
- I : constant Hash_Type := Hash (E) mod Buckets'Length;
- begin
+ J : constant Hash_Type := Hash (E) mod Buckets'Length;
+ begin
declare
X : Element_Access := new Element_Type'(E);
begin
- Buckets (I) := new Node_Type'(X, Buckets (I));
+ Buckets (J) := new Node_Type'(X, Buckets (J));
exception
when others =>
Free_Element (X);
end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ -- Start of processing for Iterate_Left
+
begin
- Iterate (Left);
+ Iterate (Left.HT);
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
raise;
- end;
+ end Iterate_Left;
- declare
+ Iterate_Right : declare
procedure Process (R_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (R_Node : Node_Access) is
begin
- if not Is_In (Left, R_Node) then
+ if not Is_In (Left.HT, R_Node) then
declare
E : Element_Type renames R_Node.Element.all;
- I : constant Hash_Type := Hash (E) mod Buckets'Length;
- begin
+ J : constant Hash_Type := Hash (E) mod Buckets'Length;
+ begin
declare
X : Element_Access := new Element_Type'(E);
begin
- Buckets (I) := new Node_Type'(X, Buckets (I));
+ Buckets (J) := new Node_Type'(X, Buckets (J));
exception
when others =>
Free_Element (X);
end;
Length := Length + 1;
-
end;
end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ -- Start of processing for Iterate_Right
+
begin
- Iterate (Right);
+ Iterate (Right.HT);
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
raise;
- end;
-
- return (Controlled with Buckets, Length);
+ end Iterate_Right;
+ return (Controlled with HT => (Buckets, Length, 0, 0));
end Symmetric_Difference;
+ -----------
+ -- Union --
+ -----------
- function Is_Subset (Subset : Set;
- Of_Set : Set) return Boolean is
-
- Subset_Node : Node_Access;
-
- begin
-
- if Subset'Address = Of_Set'Address then
- return True;
- end if;
-
- if Subset.Length > Of_Set.Length then
- return False;
- end if;
-
- -- TODO: rewrite this to loop in the
- -- style of a passive iterator.
-
- Subset_Node := HT_Ops.First (Subset);
-
- while Subset_Node /= null loop
- if not Is_In (Of_Set, Subset_Node) then
- return False;
- end if;
-
- Subset_Node := HT_Ops.Next (Subset, Subset_Node);
- end loop;
-
- return True;
-
- end Is_Subset;
-
-
- function Overlap (Left, Right : Set) return Boolean is
-
- Left_Node : Node_Access;
-
- begin
-
- if Right.Length = 0 then
- return False;
- end if;
-
- if Left'Address = Right'Address then
- return True;
- end if;
-
- Left_Node := HT_Ops.First (Left);
-
- while Left_Node /= null loop
- if Is_In (Right, Left_Node) then
- return True;
- end if;
-
- Left_Node := HT_Ops.Next (Left, Left_Node);
- end loop;
-
- return False;
-
- end Overlap;
-
-
- function Find (Container : Set;
- Item : Element_Type) return Cursor is
-
- Node : constant Node_Access := Element_Keys.Find (Container, Item);
-
- begin
+ procedure Union
+ (Target : in out Set;
+ Source : Set)
+ is
+ procedure Process (Src_Node : Node_Access);
- if Node = null then
- return No_Element;
- end if;
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
- return Cursor'(Container'Unchecked_Access, Node);
+ -------------
+ -- Process --
+ -------------
- end Find;
+ procedure Process (Src_Node : Node_Access) is
+ Src : Element_Type renames Src_Node.Element.all;
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
- function Contains (Container : Set;
- Item : Element_Type) return Boolean is
- begin
- return Find (Container, Item) /= No_Element;
- end Contains;
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
+ --------------
+ -- New_Node --
+ --------------
+ function New_Node (Next : Node_Access) return Node_Access is
+ Tgt : Element_Access := new Element_Type'(Src);
- function First (Container : Set) return Cursor is
- Node : constant Node_Access := HT_Ops.First (Container);
- begin
- if Node = null then
- return No_Element;
- end if;
+ begin
+ return new Node_Type'(Tgt, Next);
+ exception
+ when others =>
+ Free_Element (Tgt);
+ raise;
+ end New_Node;
- return Cursor'(Container'Unchecked_Access, Node);
- end First;
+ Tgt_Node : Node_Access;
+ Success : Boolean;
+ -- Start of processing for Process
--- function First_Element (Container : Set) return Element_Type is
--- Node : constant Node_Access := HT_Ops.First (Container);
--- begin
--- return Node.Element;
--- end First_Element;
+ begin
+ Insert (Target.HT, Src, Tgt_Node, Success);
+ end Process;
+ -- Start of processing for Union
- function Next (Position : Cursor) return Cursor is
begin
- if Position.Container = null
- or else Position.Node = null
- then
- return No_Element;
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.HT.Busy > 0 then
+ raise Program_Error;
end if;
declare
- S : Set renames Position.Container.all;
- Node : constant Node_Access := HT_Ops.Next (S, Position.Node);
+ N : constant Count_Type := Target.Length + Source.Length;
begin
- if Node = null then
- return No_Element;
+ if N > HT_Ops.Capacity (Target.HT) then
+ HT_Ops.Reserve_Capacity (Target.HT, N);
end if;
-
- return Cursor'(Position.Container, Node);
end;
- end Next;
-
- procedure Next (Position : in out Cursor) is
- begin
- Position := Next (Position);
- end Next;
+ Iterate (Source.HT);
+ end Union;
+ function Union (Left, Right : Set) return Set is
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
- function Has_Element (Position : Cursor) return Boolean is
begin
- if Position.Container = null then
- return False;
+ if Left'Address = Right'Address then
+ return Left;
end if;
- if Position.Node = null then
- return False;
+ if Right.Length = 0 then
+ return Left;
end if;
- return True;
- end Has_Element;
-
+ if Left.Length = 0 then
+ return Right;
+ end if;
- function Equivalent_Keys (Left, Right : Cursor)
- return Boolean is
- begin
- return Equivalent_Keys (Left.Node.Element.all, Right.Node.Element.all);
- end Equivalent_Keys;
+ declare
+ Size : constant Hash_Type :=
+ Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
+ Iterate_Left : declare
+ procedure Process (L_Node : Node_Access);
- function Equivalent_Keys (Left : Cursor;
- Right : Element_Type)
- return Boolean is
- begin
- return Equivalent_Keys (Left.Node.Element.all, Right);
- end Equivalent_Keys;
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ -------------
+ -- Process --
+ -------------
- function Equivalent_Keys (Left : Element_Type;
- Right : Cursor)
- return Boolean is
- begin
- return Equivalent_Keys (Left, Right.Node.Element.all);
- end Equivalent_Keys;
+ procedure Process (L_Node : Node_Access) is
+ J : constant Hash_Type :=
+ Hash (L_Node.Element.all) mod Buckets'Length;
+ Bucket : Node_Access renames Buckets (J);
- procedure Iterate
- (Container : in Set;
- Process : not null access procedure (Position : in Cursor)) is
+ begin
+ Bucket := new Node_Type'(L_Node.Element, Bucket);
+ end Process;
- procedure Process_Node (Node : in Node_Access);
- pragma Inline (Process_Node);
+ -- Start of processing for Process
- procedure Process_Node (Node : in Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
- end Process_Node;
-
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process_Node);
- begin
- Iterate (Container);
- end Iterate;
+ Iterate (Left.HT);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end Iterate_Left;
+ Length := Left.Length;
- function Capacity (Container : Set) return Count_Type
- renames HT_Ops.Capacity;
+ Iterate_Right : declare
+ procedure Process (Src_Node : Node_Access);
- procedure Reserve_Capacity
- (Container : in out Set;
- Capacity : in Count_Type)
- renames HT_Ops.Ensure_Capacity;
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ -------------
+ -- Process --
+ -------------
- procedure Write_Node
- (Stream : access Root_Stream_Type'Class;
- Node : in Node_Access);
- pragma Inline (Write_Node);
+ procedure Process (Src_Node : Node_Access) is
+ Src : Element_Type renames Src_Node.Element.all;
+ Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
- procedure Write_Node
- (Stream : access Root_Stream_Type'Class;
- Node : in Node_Access) is
- begin
- Element_Type'Output (Stream, Node.Element.all);
- end Write_Node;
+ Tgt_Node : Node_Access := Buckets (Idx);
- procedure Write_Nodes is
- new HT_Ops.Generic_Write (Write_Node);
+ begin
+ while Tgt_Node /= null loop
+ if Equivalent_Elements (Src, Tgt_Node.Element.all) then
+ return;
+ end if;
+ Tgt_Node := Next (Tgt_Node);
+ end loop;
- procedure Write
- (Stream : access Root_Stream_Type'Class;
- Container : in Set) renames Write_Nodes;
+ declare
+ Tgt : Element_Access := new Element_Type'(Src);
+ begin
+ Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx));
+ exception
+ when others =>
+ Free_Element (Tgt);
+ raise;
+ end;
+ Length := Length + 1;
+ end Process;
- function Read_Node (Stream : access Root_Stream_Type'Class)
- return Node_Access;
- pragma Inline (Read_Node);
+ -- Start of processing for Iterate_Right
- function Read_Node (Stream : access Root_Stream_Type'Class)
- return Node_Access is
+ begin
+ Iterate (Right.HT);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end Iterate_Right;
- X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
- begin
- return new Node_Type'(X, null);
- exception
- when others =>
- Free_Element (X);
- raise;
- end Read_Node;
+ return (Controlled with HT => (Buckets, Length, 0, 0));
+ end Union;
- procedure Read_Nodes is
- new HT_Ops.Generic_Read (Read_Node);
+ -----------
+ -- Write --
+ -----------
- procedure Read
+ procedure Write
(Stream : access Root_Stream_Type'Class;
- Container : out Set) renames Read_Nodes;
+ Container : Set)
+ is
+ begin
+ Write_Nodes (Stream, Container.HT);
+ end Write;
+ ----------------
+ -- Write_Node --
+ ----------------
- package body Generic_Keys is
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access)
+ is
+ begin
+ Element_Type'Output (Stream, Node.Element.all);
+ end Write_Node;
- function Equivalent_Keys (Left : Cursor;
- Right : Key_Type)
- return Boolean is
- begin
- return Equivalent_Keys (Right, Left.Node.Element.all);
- end Equivalent_Keys;
+ package body Generic_Keys is
- function Equivalent_Keys (Left : Key_Type;
- Right : Cursor)
- return Boolean is
- begin
- return Equivalent_Keys (Left, Right.Node.Element.all);
- end Equivalent_Keys;
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- function Equivalent_Keys
+ function Equivalent_Key_Node
(Key : Key_Type;
Node : Node_Access) return Boolean;
- pragma Inline (Equivalent_Keys);
+ pragma Inline (Equivalent_Key_Node);
- function Equivalent_Keys
- (Key : Key_Type;
- Node : Node_Access) return Boolean is
- begin
- return Equivalent_Keys (Key, Node.Element.all);
- end Equivalent_Keys;
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
package Key_Keys is
new Hash_Tables.Generic_Keys
(HT_Types => HT_Types,
- HT_Type => Set,
- Null_Node => null,
Next => Next,
Set_Next => Set_Next,
Key_Type => Key_Type,
Hash => Hash,
- Equivalent_Keys => Equivalent_Keys);
+ Equivalent_Keys => Equivalent_Key_Node);
+ --------------
+ -- Contains --
+ --------------
- function Find (Container : Set;
- Key : Key_Type)
- return Cursor is
-
- Node : constant Node_Access :=
- Key_Keys.Find (Container, Key);
-
+ function Contains
+ (Container : Set;
+ Key : Key_Type) return Boolean
+ is
begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
- if Node = null then
- return No_Element;
- end if;
-
- return Cursor'(Container'Unchecked_Access, Node);
-
- end Find;
+ ------------
+ -- Delete --
+ ------------
+ procedure Delete
+ (Container : in out Set;
+ Key : Key_Type)
+ is
+ X : Node_Access;
- function Contains (Container : Set;
- Key : Key_Type) return Boolean is
begin
- return Find (Container, Key) /= No_Element;
- end Contains;
+ Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
+
+ if X = null then
+ raise Constraint_Error;
+ end if;
+ Free (X);
+ end Delete;
- function Element (Container : Set;
- Key : Key_Type)
- return Element_Type is
+ -------------
+ -- Element --
+ -------------
- Node : constant Node_Access := Key_Keys.Find (Container, Key);
+ function Element
+ (Container : Set;
+ Key : Key_Type) return Element_Type
+ is
+ Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
begin
return Node.Element.all;
end Element;
+ -------------------------
+ -- Equivalent_Key_Node --
+ -------------------------
- function Key (Position : Cursor) return Key_Type is
+ function Equivalent_Key_Node
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean is
begin
- return Key (Position.Node.Element.all);
- end Key;
-
-
--- TODO:
--- procedure Replace (Container : in out Set;
--- Key : in Key_Type;
--- New_Item : in Element_Type) is
-
--- Node : constant Node_Access :=
--- Key_Keys.Find (Container, Key);
-
--- begin
-
--- if Node = null then
--- raise Constraint_Error;
--- end if;
+ return Equivalent_Keys (Key, Node.Element.all);
+ end Equivalent_Key_Node;
--- Replace_Element (Container, Node, New_Item);
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
--- end Replace;
+ function Equivalent_Keys
+ (Left : Cursor;
+ Right : Key_Type) return Boolean
+ is
+ begin
+ return Equivalent_Keys (Right, Left.Node.Element.all);
+ end Equivalent_Keys;
+ function Equivalent_Keys
+ (Left : Key_Type;
+ Right : Cursor) return Boolean
+ is
+ begin
+ return Equivalent_Keys (Left, Right.Node.Element.all);
+ end Equivalent_Keys;
- procedure Delete (Container : in out Set;
- Key : in Key_Type) is
+ -------------
+ -- Exclude --
+ -------------
+ procedure Exclude
+ (Container : in out Set;
+ Key : Key_Type)
+ is
X : Node_Access;
-
begin
+ Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
+ Free (X);
+ end Exclude;
- Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
+ ----------
+ -- Find --
+ ----------
- if X = null then
- raise Constraint_Error;
+ function Find
+ (Container : Set;
+ Key : Key_Type) return Cursor
+ is
+ Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
end if;
- Free (X);
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
- end Delete;
+ ---------
+ -- Key --
+ ---------
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Key (Position.Node.Element.all);
+ end Key;
- procedure Exclude (Container : in out Set;
- Key : in Key_Type) is
+ -------------
+ -- Replace --
+ -------------
- X : Node_Access;
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container.HT, Key);
begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
- Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
- Free (X);
-
- end Exclude;
-
+ Replace_Element (Container.HT, Node, New_Item);
+ end Replace;
- procedure Checked_Update_Element
+ procedure Update_Element_Preserving_Key
(Container : in out Set;
Position : in Cursor;
Process : not null access
- procedure (Element : in out Element_Type)) is
+ procedure (Element : in out Element_Type))
+ is
+ HT : Hash_Table_Type renames Container.HT;
begin
-
- if Position.Container = null then
+ if Position.Node = null then
raise Constraint_Error;
end if;
end if;
declare
- Old_Key : Key_Type renames Key (Position.Node.Element.all);
- begin
- Process (Position.Node.Element.all);
-
- if Equivalent_Keys (Old_Key, Position.Node.Element.all) then
- return;
- end if;
- end;
-
- declare
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
-
- function New_Node (Next : Node_Access) return Node_Access is
- begin
- Position.Node.Next := Next;
- return Position.Node;
- end New_Node;
+ E : Element_Type renames Position.Node.Element.all;
+ K : Key_Type renames Key (E);
- procedure Insert is
- new Key_Keys.Generic_Conditional_Insert (New_Node);
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
- Result : Node_Access;
- Success : Boolean;
begin
- HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ B := B + 1;
+ L := L + 1;
- Insert
- (HT => Container,
- Key => Key (Position.Node.Element.all),
- Node => Result,
- Success => Success);
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
- if not Success then
- declare
- X : Node_Access := Position.Node;
- begin
- Free (X);
- end;
+ L := L - 1;
+ B := B - 1;
- raise Program_Error;
+ if Equivalent_Keys (K, E) then
+ pragma Assert (Hash (K) = Hash (E));
+ return;
end if;
+ end;
- pragma Assert (Result = Position.Node);
+ declare
+ X : Node_Access := Position.Node;
+ begin
+ HT_Ops.Delete_Node_Sans_Free (HT, X);
+ Free (X);
end;
- end Checked_Update_Element;
+ raise Program_Error;
+ end Update_Element_Preserving_Key;
end Generic_Keys;
end Ada.Containers.Indefinite_Hashed_Sets;
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
+-- A D A . C O N T A I N E R S . --
+-- I N D E F I N I T E _ O R D E R E D _ M A P S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Containers.Red_Black_Trees.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
-with System; use type System.Address;
-
package body Ada.Containers.Indefinite_Ordered_Maps is
- use Red_Black_Trees;
-
- type Key_Access is access Key_Type;
- type Element_Access is access Element_Type;
-
- type Node_Type is limited record
- Parent : Node_Access;
- Left : Node_Access;
- Right : Node_Access;
- Color : Red_Black_Trees.Color_Type := Red;
- Key : Key_Access;
- Element : Element_Access;
- end record;
-
-----------------------------
-- Node Access Subprograms --
-----------------------------
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
- function Copy_Tree (Source_Root : Node_Access) return Node_Access;
-
- procedure Delete_Tree (X : in out Node_Access);
-
procedure Free (X : in out Node_Access);
function Is_Equal_Node_Node
--------------------------
package Tree_Operations is
- new Red_Black_Trees.Generic_Operations
- (Tree_Types => Tree_Types,
- Null_Node => Node_Access'(null));
+ new Red_Black_Trees.Generic_Operations (Tree_Types);
+
+ procedure Delete_Tree is
+ new Tree_Operations.Generic_Delete_Tree (Free);
+
+ function Copy_Tree is
+ new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
use Tree_Operations;
function "=" (Left, Right : Map) return Boolean is
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
return Is_Equal (Left.Tree, Right.Tree);
end "=";
-- Adjust --
------------
- procedure Adjust (Container : in out Map) is
- Tree : Tree_Type renames Container.Tree;
-
- N : constant Count_Type := Tree.Length;
- X : constant Node_Access := Tree.Root;
+ procedure Adjust is
+ new Tree_Operations.Generic_Adjust (Copy_Tree);
+ procedure Adjust (Container : in out Map) is
begin
- if N = 0 then
- pragma Assert (X = null);
- return;
- end if;
-
- Tree := (Length => 0, others => null);
-
- Tree.Root := Copy_Tree (X);
- Tree.First := Min (Tree.Root);
- Tree.Last := Max (Tree.Root);
- Tree.Length := N;
+ Adjust (Container.Tree);
end Adjust;
-------------
if Node = null then
return No_Element;
else
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
end Ceiling;
-- Clear --
-----------
+ procedure Clear is
+ new Tree_Operations.Generic_Clear (Delete_Tree);
+
procedure Clear (Container : in out Map) is
- Tree : Tree_Type renames Container.Tree;
- Root : Node_Access := Tree.Root;
begin
- Tree := (Length => 0, others => null);
- Delete_Tree (Root);
+ Clear (Container.Tree);
end Clear;
-----------
---------------
function Copy_Node (Source : Node_Access) return Node_Access is
- Target : constant Node_Access :=
- new Node_Type'(Parent => null,
- Left => null,
- Right => null,
- Color => Source.Color,
- Key => Source.Key,
- Element => Source.Element);
- begin
- return Target;
- end Copy_Node;
-
- ---------------
- -- Copy_Tree --
- ---------------
-
- function Copy_Tree (Source_Root : Node_Access) return Node_Access is
- Target_Root : Node_Access := Copy_Node (Source_Root);
-
- P, X : Node_Access;
-
+ K : Key_Access := new Key_Type'(Source.Key.all);
+ E : Element_Access;
begin
- if Source_Root.Right /= null then
- Target_Root.Right := Copy_Tree (Source_Root.Right);
- Target_Root.Right.Parent := Target_Root;
- end if;
-
- P := Target_Root;
- X := Source_Root.Left;
- while X /= null loop
- declare
- Y : Node_Access := Copy_Node (X);
-
- begin
- P.Left := Y;
- Y.Parent := P;
-
- if X.Right /= null then
- Y.Right := Copy_Tree (X.Right);
- Y.Right.Parent := Y;
- end if;
-
- P := Y;
- X := X.Left;
- end;
- end loop;
-
- return Target_Root;
-
+ E := new Element_Type'(Source.Element.all);
+
+ return new Node_Type'(Parent => null,
+ Left => null,
+ Right => null,
+ Color => Source.Color,
+ Key => K,
+ Element => E);
exception
when others =>
- Delete_Tree (Target_Root);
+ Free_Key (K);
+ Free_Element (E);
raise;
- end Copy_Tree;
+ end Copy_Node;
------------
-- Delete --
Position : in out Cursor)
is
begin
- if Position = No_Element then
- return;
+ if Position.Node = null then
+ raise Constraint_Error;
end if;
- if Position.Container /= Map_Access'(Container'Unchecked_Access) then
+ if Position.Container /= Map_Access'(Container'Unrestricted_Access) then
raise Program_Error;
end if;
------------------
procedure Delete_First (Container : in out Map) is
- Position : Cursor := First (Container);
+ X : Node_Access := Container.Tree.First;
begin
- Delete (Container, Position);
+ if X /= null then
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end if;
end Delete_First;
-----------------
-----------------
procedure Delete_Last (Container : in out Map) is
- Position : Cursor := Last (Container);
- begin
- Delete (Container, Position);
- end Delete_Last;
-
- -----------------
- -- Delete_Tree --
- -----------------
-
- procedure Delete_Tree (X : in out Node_Access) is
- Y : Node_Access;
+ X : Node_Access := Container.Tree.Last;
begin
- while X /= null loop
- Y := X.Right;
- Delete_Tree (Y);
- Y := X.Left;
+ if X /= null then
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
- X := Y;
- end loop;
- end Delete_Tree;
+ end if;
+ end Delete_Last;
-------------
-- Element --
if Node = null then
return No_Element;
else
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
end Find;
if Container.Tree.First = null then
return No_Element;
else
- return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
end if;
end First;
if Node = null then
return No_Element;
else
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
end Floor;
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
- if X /= null then
+ if X = null then
+ return;
+ end if;
+
+ begin
Free_Key (X.Key);
+ exception
+ when others =>
+ X.Key := null;
+
+ begin
+ Free_Element (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ end;
+
+ Deallocate (X);
+ raise;
+ end;
+
+ begin
Free_Element (X.Element);
- Deallocate (X);
- end if;
+ exception
+ when others =>
+ X.Element := null;
+
+ Deallocate (X);
+ raise;
+ end;
+
+ Deallocate (X);
end Free;
-----------------
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
+ if Container.Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
+
K := Position.Node.Key;
E := Position.Node.Element;
Position.Node.Key := new Key_Type'(Key);
- Position.Node.Element := new Element_Type'(New_Item);
+
+ begin
+ Position.Node.Element := new Element_Type'(New_Item);
+ exception
+ when others =>
+ Free_Key (K);
+ raise;
+ end;
Free_Key (K);
Free_Element (E);
-- On exception, deallocate key and elem
- Free (Node);
+ Free (Node); -- Note that Free deallocates key and elem too
raise;
end New_Node;
Position.Node,
Inserted);
- Position.Container := Container'Unchecked_Access;
+ Position.Container := Container'Unrestricted_Access;
end Insert;
procedure Insert
function Is_Equal_Node_Node
(L, R : Node_Access) return Boolean is
begin
- return L.Element.all = R.Element.all;
+ if L.Key.all < R.Key.all then
+ return False;
+
+ elsif R.Key.all < L.Key.all then
+ return False;
+
+ else
+ return L.Element.all = R.Element.all;
+ end if;
end Is_Equal_Node_Node;
-------------------------
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
+
-- Start of processing for Iterate
begin
- Local_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Iterate (Container.Tree);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
---------
if Container.Tree.Last = null then
return No_Element;
else
- return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end if;
end Last;
-- Move --
----------
+ procedure Move is
+ new Tree_Operations.Generic_Move (Clear);
+
procedure Move (Target : in out Map; Source : in out Map) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Move (Target => Target.Tree, Source => Source.Tree);
end Move;
procedure Query_Element
(Position : Cursor;
- Process : not null access procedure (Element : Element_Type))
+ Process : not null access procedure (Key : Key_Type;
+ Element : Element_Type))
is
+ K : Key_Type renames Position.Node.Key.all;
+ E : Element_Type renames Position.Node.Element.all;
+
+ T : Tree_Type renames Position.Container.Tree;
+
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
begin
- Process (Position.Node.Key.all, Position.Node.Element.all);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Query_Element;
----------
(Stream : access Root_Stream_Type'Class;
Container : out Map)
is
- N : Count_Type'Base;
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access;
+ pragma Inline (Read_Node);
- function New_Node return Node_Access;
- pragma Inline (New_Node);
+ procedure Read is
+ new Tree_Operations.Generic_Read (Clear, Read_Node);
- procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
+ ---------------
+ -- Read_Node --
+ ---------------
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Node_Access is
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access
+ is
Node : Node_Access := new Node_Type;
-
begin
Node.Key := new Key_Type'(Key_Type'Input (Stream));
Node.Element := new Element_Type'(Element_Type'Input (Stream));
return Node;
-
exception
when others =>
-
- -- Deallocate key and elem too on exception
-
- Free (Node);
+ Free (Node); -- Note that Free deallocates key and elem too
raise;
- end New_Node;
+ end Read_Node;
-- Start of processing for Read
begin
- Clear (Container);
-
- Count_Type'Base'Read (Stream, N);
- pragma Assert (N >= 0);
-
- Local_Read (Container.Tree, N);
+ Read (Stream, Container.Tree);
end Read;
-------------
raise Constraint_Error;
end if;
+ if Container.Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
+
K := Node.Key;
E := Node.Element;
Node.Key := new Key_Type'(Key);
- Node.Element := new Element_Type'(New_Item);
+
+ begin
+ Node.Element := new Element_Type'(New_Item);
+ exception
+ when others =>
+ Free_Key (K);
+ raise;
+ end;
Free_Key (K);
Free_Element (E);
procedure Replace_Element (Position : Cursor; By : Element_Type) is
X : Element_Access := Position.Node.Element;
begin
+ if Position.Container.Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
+
Position.Node.Element := new Element_Type'(By);
Free_Element (X);
end Replace_Element;
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
+
-- Start of processing for Reverse_Iterate
begin
- Local_Reverse_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (Container.Tree);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
-----------
procedure Update_Element
(Position : Cursor;
- Process : not null access procedure (Element : in out Element_Type))
+ Process : not null access procedure (Key : Key_Type;
+ Element : in out Element_Type))
is
+ K : Key_Type renames Position.Node.Key.all;
+ E : Element_Type renames Position.Node.Element.all;
+
+ T : Tree_Type renames Position.Container.Tree;
+
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
begin
- Process (Position.Node.Key.all, Position.Node.Element.all);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Update_Element;
-----------
(Stream : access Root_Stream_Type'Class;
Container : Map)
is
- procedure Process (Node : Node_Access);
- pragma Inline (Process);
-
- procedure Iterate is
- new Tree_Operations.Generic_Iteration (Process);
-
- -------------
- -- Process --
- -------------
-
- procedure Process (Node : Node_Access) is
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+ pragma Inline (Write_Node);
+
+ procedure Write is
+ new Tree_Operations.Generic_Write (Write_Node);
+
+ ----------------
+ -- Write_Node --
+ ----------------
+
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access)
+ is
begin
Key_Type'Output (Stream, Node.Key.all);
Element_Type'Output (Stream, Node.Element.all);
- end Process;
+ end Write_Node;
-- Start of processing for Write
begin
- Count_Type'Base'Write (Stream, Container.Tree.Length);
- Iterate (Container.Tree);
+ Write (Stream, Container.Tree);
end Write;
end Ada.Containers.Indefinite_Ordered_Maps;
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
+-- A D A . C O N T A I N E R S . --
+-- I N D E F I N I T E _ O R D E R E D _ M A P S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
(Container : in out Map;
Key : Key_Type);
- procedure Exclude
- (Container : in out Map;
- Key : Key_Type);
-
procedure Delete
(Container : in out Map;
Position : in out Cursor);
procedure Delete_Last (Container : in out Map);
+ procedure Exclude
+ (Container : in out Map;
+ Key : Key_Type);
+
function Contains
(Container : Map;
Key : Key_Type) return Boolean;
function Next (Position : Cursor) return Cursor;
- function Previous (Position : Cursor) return Cursor;
-
procedure Next (Position : in out Cursor);
+ function Previous (Position : Cursor) return Cursor;
+
procedure Previous (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
type Node_Type;
type Node_Access is access Node_Type;
- package Tree_Types is
- new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+ type Key_Access is access Key_Type;
+ type Element_Access is access Element_Type;
- use Tree_Types;
- use Ada.Finalization;
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
+ Key : Key_Access;
+ Element : Element_Access;
+ end record;
- type Map is new Controlled with record
- Tree : Tree_Type := (Length => 0, others => null);
+ package Tree_Types is new Red_Black_Trees.Generic_Tree_Types
+ (Node_Type,
+ Node_Access);
+
+ type Map is new Ada.Finalization.Controlled with record
+ Tree : Tree_Types.Tree_Type;
end record;
procedure Adjust (Container : in out Map);
procedure Finalize (Container : in out Map) renames Clear;
- type Map_Access is access constant Map;
+ use Red_Black_Trees;
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Map_Access is access Map;
for Map_Access'Storage_Size use 0;
type Cursor is record
for Map'Read use Read;
Empty_Map : constant Map :=
- (Controlled with Tree => (Length => 0, others => null));
+ (Controlled with Tree => (First => null,
+ Last => null,
+ Root => null,
+ Length => 0,
+ Busy => 0,
+ Lock => 0));
end Ada.Containers.Indefinite_Ordered_Maps;
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS --
+-- A D A . C O N T A I N E R S . --
+-- I N D E F I N I T E _ O R D E R E D _ M U L T I S E T S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
-with System; use type System.Address;
-
package body Ada.Containers.Indefinite_Ordered_Multisets is
- use Red_Black_Trees;
-
- type Element_Access is access Element_Type;
-
- type Node_Type is limited record
- Parent : Node_Access;
- Left : Node_Access;
- Right : Node_Access;
- Color : Red_Black_Trees.Color_Type := Red;
- Element : Element_Access;
- end record;
-
-----------------------------
-- Node Access Subprograms --
-----------------------------
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
- function Copy_Tree (Source_Root : Node_Access) return Node_Access;
-
- procedure Delete_Tree (X : in out Node_Access);
-
procedure Free (X : in out Node_Access);
procedure Insert_With_Hint
function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
pragma Inline (Is_Less_Node_Node);
+ procedure Replace_Element
+ (Tree : in out Tree_Type;
+ Node : Node_Access;
+ Item : Element_Type);
+
--------------------------
-- Local Instantiations --
--------------------------
package Tree_Operations is
- new Red_Black_Trees.Generic_Operations
- (Tree_Types => Tree_Types,
- Null_Node => Node_Access'(null));
+ new Red_Black_Trees.Generic_Operations (Tree_Types);
+
+ procedure Delete_Tree is
+ new Tree_Operations.Generic_Delete_Tree (Free);
+
+ function Copy_Tree is
+ new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
use Tree_Operations;
-- "=" --
---------
- function "=" (Left, Right : Set) return Boolean is begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
+ function "=" (Left, Right : Set) return Boolean is
+ begin
return Is_Equal (Left.Tree, Right.Tree);
end "=";
-- Adjust --
------------
- procedure Adjust (Container : in out Set) is
- Tree : Tree_Type renames Container.Tree;
-
- N : constant Count_Type := Tree.Length;
- X : constant Node_Access := Tree.Root;
+ procedure Adjust is
+ new Tree_Operations.Generic_Adjust (Copy_Tree);
+ procedure Adjust (Container : in out Set) is
begin
- if N = 0 then
- pragma Assert (X = null);
- return;
- end if;
-
- Tree := (Length => 0, others => null);
-
- Tree.Root := Copy_Tree (X);
- Tree.First := Min (Tree.Root);
- Tree.Last := Max (Tree.Root);
- Tree.Length := N;
+ Adjust (Container.Tree);
end Adjust;
-------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Ceiling;
-----------
-- Clear --
-----------
+ procedure Clear is
+ new Tree_Operations.Generic_Clear (Delete_Tree);
+
procedure Clear (Container : in out Set) is
- Tree : Tree_Type renames Container.Tree;
- Root : Node_Access := Tree.Root;
begin
- Tree := (Length => 0, others => null);
- Delete_Tree (Root);
+ Clear (Container.Tree);
end Clear;
-----------
raise;
end Copy_Node;
- ---------------
- -- Copy_Tree --
- ---------------
-
- function Copy_Tree (Source_Root : Node_Access) return Node_Access is
- Target_Root : Node_Access := Copy_Node (Source_Root);
-
- P, X : Node_Access;
-
- begin
- if Source_Root.Right /= null then
- Target_Root.Right := Copy_Tree (Source_Root.Right);
- Target_Root.Right.Parent := Target_Root;
- end if;
-
- P := Target_Root;
- X := Source_Root.Left;
- while X /= null loop
- declare
- Y : Node_Access := Copy_Node (X);
-
- begin
- P.Left := Y;
- Y.Parent := P;
-
- if X.Right /= null then
- Y.Right := Copy_Tree (X.Right);
- Y.Right.Parent := Y;
- end if;
-
- P := Y;
- X := X.Left;
- end;
- end loop;
-
- return Target_Root;
-
- exception
- when others =>
- Delete_Tree (Target_Root);
- raise;
- end Copy_Tree;
-
------------
-- Delete --
------------
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
- if Position = No_Element then
- return;
+ if Position.Node = null then
+ raise Constraint_Error;
end if;
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
- Delete_Node_Sans_Free (Container.Tree, Position.Node);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
Free (Position.Node);
Position.Container := null;
Free (X);
end Delete_Last;
- -----------------
- -- Delete_Tree --
- -----------------
-
- procedure Delete_Tree (X : in out Node_Access) is
- Y : Node_Access;
- begin
- while X /= null loop
- Y := X.Right;
- Delete_Tree (Y);
- Y := X.Left;
- Free (X);
- X := Y;
- end loop;
- end Delete_Tree;
-
----------------
-- Difference --
----------------
procedure Difference (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
-
Set_Ops.Difference (Target.Tree, Source.Tree);
end Difference;
function Difference (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Difference (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Difference (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Difference;
-------------
return Position.Node.Element.all;
end Element;
+ ---------------------
+ -- Equivalent_Sets --
+ ---------------------
+
+ function Equivalent_Sets (Left, Right : Set) return Boolean is
+
+ function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Equivalent_Node_Node);
+
+ function Is_Equivalent is
+ new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
+
+ -----------------------------
+ -- Is_Equivalent_Node_Node --
+ -----------------------------
+
+ function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ if L.Element.all < R.Element.all then
+ return False;
+ elsif R.Element.all < L.Element.all then
+ return False;
+ else
+ return True;
+ end if;
+ end Is_Equivalent_Node_Node;
+
+ -- Start of processing for Equivalent_Sets
+
+ begin
+ return Is_Equivalent (Left.Tree, Right.Tree);
+ end Equivalent_Sets;
+
-------------
-- Exclude --
-------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
end First;
-------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
----------
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
- if X /= null then
- Free_Element (X.Element);
- Deallocate (X);
+ if X = null then
+ return;
end if;
+
+ begin
+ Free_Element (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ Deallocate (X);
+ raise;
+ end;
+
+ Deallocate (X);
end Free;
------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Ceiling;
- ----------------------------
- -- Checked_Update_Element --
- ----------------------------
-
- procedure Checked_Update_Element
- (Container : in out Set;
- Position : Cursor;
- Process : not null access procedure (Element : in out Element_Type))
- is
- begin
- if Position.Container = null then
- raise Constraint_Error;
- end if;
-
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
- raise Program_Error;
- end if;
-
- declare
- Old_Key : Key_Type renames Key (Position.Node.Element.all);
-
- begin
- Process (Position.Node.Element.all);
-
- if Old_Key < Position.Node.Element.all
- or else Old_Key > Position.Node.Element.all
- then
- null;
- else
- return;
- end if;
- end;
-
- Delete_Node_Sans_Free (Container.Tree, Position.Node);
-
- Do_Insert : declare
- Result : Node_Access;
-
- function New_Node return Node_Access;
- pragma Inline (New_Node);
-
- procedure Insert_Post is
- new Key_Keys.Generic_Insert_Post (New_Node);
-
- procedure Insert is
- new Key_Keys.Generic_Unconditional_Insert (Insert_Post);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Node_Access is
- begin
- return Position.Node;
- end New_Node;
-
- -- Start of processing for Do_Insert
-
- begin
- Insert
- (Tree => Container.Tree,
- Key => Key (Position.Node.Element.all),
- Node => Result);
-
- pragma Assert (Result = Position.Node);
- end Do_Insert;
- end Checked_Update_Element;
-
--------------
-- Contains --
--------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
-------------------------
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Iterate
begin
- Local_Iterate (Container.Tree, Key);
+ B := B + 1;
+
+ begin
+ Local_Iterate (T, Key);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
---------
return Key (Position.Node.Element.all);
end Key;
- -------------
- -- Replace --
- -------------
-
- -- In post-madision api: ???
-
--- procedure Replace
--- (Container : in out Set;
--- Key : Key_Type;
--- New_Item : Element_Type)
--- is
--- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
-
--- begin
--- if Node = null then
--- raise Constraint_Error;
--- end if;
-
--- Replace_Node (Container, Node, New_Item);
--- end Replace;
-
---------------------
-- Reverse_Iterate --
---------------------
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Reverse_Iterate
begin
- Local_Reverse_Iterate (Container.Tree, Key);
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (T, Key);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
+ -----------------------------------
+ -- Update_Element_Preserving_Key --
+ -----------------------------------
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ Tree : Tree_Type renames Container.Tree;
+
+ begin
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error;
+ end if;
+
+ declare
+ E : Element_Type renames Position.Node.Element.all;
+ K : Key_Type renames Key (E);
+
+ B : Natural renames Tree.Busy;
+ L : Natural renames Tree.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+
+ if K < E
+ or else K > E
+ then
+ null;
+ else
+ return;
+ end if;
+ end;
+
+ declare
+ X : Node_Access := Position.Node;
+ begin
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end;
+
+ raise Program_Error;
+ end Update_Element_Preserving_Key;
+
end Generic_Keys;
-----------------
New_Item,
Position.Node);
- Position.Container := Container'Unchecked_Access;
+ Position.Container := Container'Unrestricted_Access;
end Insert;
----------------------
procedure Intersection (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Set_Ops.Intersection (Target.Tree, Source.Tree);
end Intersection;
function Intersection (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Intersection (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Left;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Intersection (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Intersection;
--------------
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
begin
- if Subset'Address = Of_Set'Address then
- return True;
- end if;
-
return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
end Is_Subset;
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Iterate
begin
- Local_Iterate (Container.Tree, Item);
+ B := B + 1;
+
+ begin
+ Local_Iterate (T, Item);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
procedure Iterate
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Iterate
begin
- Local_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Iterate (T);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end Last;
------------------
-- Move --
----------
+ procedure Move is
+ new Tree_Operations.Generic_Move (Clear);
+
procedure Move (Target : in out Set; Source : in out Set) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Move (Target => Target.Tree, Source => Source.Tree);
end Move;
function Overlap (Left, Right : Set) return Boolean is
begin
- if Left'Address = Right'Address then
- return Left.Tree.Length /= 0;
- end if;
-
return Set_Ops.Overlap (Left.Tree, Right.Tree);
end Overlap;
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
+ E : Element_Type renames Position.Node.Element.all;
+
+ S : Set renames Position.Container.all;
+ T : Tree_Type renames S.Tree'Unrestricted_Access.all;
+
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
begin
- Process (Position.Node.Element.all);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Query_Element;
----------
(Stream : access Root_Stream_Type'Class;
Container : out Set)
is
- N : Count_Type'Base;
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access;
+ pragma Inline (Read_Node);
- function New_Node return Node_Access;
- pragma Inline (New_Node);
+ procedure Read is
+ new Tree_Operations.Generic_Read (Clear, Read_Node);
- procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
+ ---------------
+ -- Read_Node --
+ ---------------
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Node_Access is
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access
+ is
Node : Node_Access := new Node_Type;
-
begin
- begin
- Node.Element := new Element_Type'(Element_Type'Input (Stream));
- exception
- when others =>
- Free (Node);
- raise;
- end;
-
+ Node.Element := new Element_Type'(Element_Type'Input (Stream));
return Node;
- end New_Node;
+ exception
+ when others =>
+ Free (Node); -- Note that Free deallocates elem too
+ raise;
+ end Read_Node;
-- Start of processing for Read
begin
- Clear (Container);
+ Read (Stream, Container.Tree);
+ end Read;
- Count_Type'Base'Read (Stream, N);
- pragma Assert (N >= 0);
+ ---------------------
+ -- Replace_Element --
+ ---------------------
- Local_Read (Container.Tree, N);
- end Read;
+ procedure Replace_Element
+ (Tree : in out Tree_Type;
+ Node : Node_Access;
+ Item : Element_Type)
+ is
+ begin
+ if Item < Node.Element.all
+ or else Node.Element.all < Item
+ then
+ null;
+ else
+ if Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
- -------------
- -- Replace --
- -------------
+ declare
+ X : Element_Access := Node.Element;
+ begin
+ Node.Element := new Element_Type'(Item);
+ Free_Element (X);
+ end;
- -- NOTE: from post-madison api???
+ return;
+ end if;
--- procedure Replace
--- (Container : in out Set;
--- Position : Cursor;
--- By : Element_Type)
--- is
--- begin
--- if Position.Container = null then
--- raise Constraint_Error;
--- end if;
+ Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
--- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
--- raise Program_Error;
--- end if;
+ Insert_New_Item : declare
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
--- Replace_Node (Container, Position.Node, By);
--- end Replace;
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
- ------------------
- -- Replace_Node --
- ------------------
+ procedure Unconditional_Insert is
+ new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ Node.Element := new Element_Type'(Item); -- OK if fails
+ return Node;
+ end New_Node;
+
+ Result : Node_Access;
+
+ X : Element_Access := Node.Element;
- -- NOTE: from post-madison api???
-
--- procedure Replace_Node
--- (Container : in out Set;
--- Position : Node_Access;
--- By : Element_Type);
--- is
--- Tree : Tree_Type renames Container.Tree;
--- Node : Node_Access := Position;
-
--- begin
--- if By < Node.Element
--- or else Node.Element < By
--- then
--- null;
-
--- else
--- begin
--- Node.Element := By;
-
--- exception
--- when others =>
--- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
--- Free (Node);
--- raise;
--- end;
-
--- return;
--- end if;
-
--- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
-
--- begin
--- Node.Element := By;
-
--- exception
--- when others =>
--- Free (Node);
--- raise;
--- end;
-
--- declare
--- Result : Node_Access;
--- Success : Boolean;
-
--- function New_Node return Node_Access;
--- pragma Inline (New_Node);
-
--- procedure Insert_Post is
--- new Element_Keys.Generic_Insert_Post (New_Node);
-
--- procedure Insert is
--- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
-
--- --------------
--- -- New_Node --
--- --------------
---
--- function New_Node return Node_Access is
--- begin
--- return Node;
--- end New_Node;
-
--- -- Start of processing for Replace_Node
-
--- begin
--- Insert
--- (Tree => Tree,
--- Key => Node.Element,
--- Node => Result,
--- Success => Success);
-
--- if not Success then
--- Free (Node);
--- raise Program_Error;
--- end if;
-
--- pragma Assert (Result = Node);
--- end;
--- end Replace_Node;
+ -- Start of processing for Insert_New_Item
+
+ begin
+ Unconditional_Insert
+ (Tree => Tree,
+ Key => Item,
+ Node => Result);
+ pragma Assert (Result = Node);
+
+ Free_Element (X); -- OK if fails
+ end Insert_New_Item;
+ end Replace_Element;
+
+ procedure Replace_Element
+ (Container : Set;
+ Position : Cursor;
+ By : Element_Type)
+ is
+ Tree : Tree_Type renames Position.Container.Tree'Unrestricted_Access.all;
+
+ begin
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error;
+ end if;
+
+ Replace_Element (Tree, Position.Node, By);
+ end Replace_Element;
---------------------
-- Reverse_Iterate --
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Reverse_Iterate
begin
- Local_Reverse_Iterate (Container.Tree, Item);
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (T, Item);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
procedure Reverse_Iterate
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Reverse_Iterate
begin
- Local_Reverse_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (T);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
-----------
procedure Symmetric_Difference (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
-
Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
end Symmetric_Difference;
function Symmetric_Difference (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Symmetric_Difference;
-----------
procedure Union (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Set_Ops.Union (Target.Tree, Source.Tree);
end Union;
- function Union (Left, Right : Set) return Set is begin
- if Left'Address = Right'Address then
- return Left;
- end if;
-
- declare
- Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ function Union (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Union (Left.Tree, Right.Tree);
+ begin
+ return Set'(Controlled with Tree);
end Union;
-----------
(Stream : access Root_Stream_Type'Class;
Container : Set)
is
- procedure Process (Node : Node_Access);
- pragma Inline (Process);
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+ pragma Inline (Write_Node);
- procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
+ procedure Write is
+ new Tree_Operations.Generic_Write (Write_Node);
- -------------
- -- Process --
- -------------
+ ----------------
+ -- Write_Node --
+ ----------------
- procedure Process (Node : Node_Access) is
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access)
+ is
begin
Element_Type'Output (Stream, Node.Element.all);
- end Process;
+ end Write_Node;
-- Start of processing for Write
begin
- Count_Type'Base'Write (Stream, Container.Tree.Length);
- Iterate (Container.Tree);
+ Write (Stream, Container.Tree);
end Write;
end Ada.Containers.Indefinite_Ordered_Multisets;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS --
+-- A D A . C O N T A I N E R S . --
+-- I N D E F I N I T E _ O R D E R E D _ M U L T I S E T S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
function "=" (Left, Right : Set) return Boolean;
+ function Equivalent_Sets (Left, Right : Set) return Boolean;
+
function Length (Container : Set) return Count_Type;
function Is_Empty (Container : Set) return Boolean;
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
+ procedure Replace_Element
+ (Container : Set;
+ Position : Cursor;
+ By : Element_Type);
+
procedure Move (Target : in out Set; Source : in out Set);
procedure Insert
procedure Delete (Container : in out Set; Item : Element_Type);
- procedure Exclude (Container : in out Set; Item : Element_Type);
-
procedure Delete (Container : in out Set; Position : in out Cursor);
procedure Delete_First (Container : in out Set);
procedure Delete_Last (Container : in out Set);
-
- -- NOTE: The following operation is named Replace in the Madison API.
- -- However, it should be named Replace_Element ???
- --
- -- procedure Replace
- -- (Container : in out Set;
- -- Position : Cursor;
- -- By : Element_Type);
+ procedure Exclude (Container : in out Set; Item : Element_Type);
procedure Union (Target : in out Set;
Source : Set);
function Next (Position : Cursor) return Cursor;
- function Previous (Position : Cursor) return Cursor;
-
procedure Next (Position : in out Cursor);
+ function Previous (Position : Cursor) return Cursor;
+
procedure Previous (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
function Element (Container : Set; Key : Key_Type) return Element_Type;
- -- NOTE: in post-madison api ???
- -- procedure Replace
- -- (Container : in out Set;
- -- Key : Key_Type;
- -- New_Item : Element_Type);
-
procedure Delete (Container : in out Set; Key : Key_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
function ">" (Left : Key_Type; Right : Cursor) return Boolean;
- procedure Checked_Update_Element
+ procedure Update_Element_Preserving_Key
(Container : in out Set;
Position : Cursor;
Process : not null access
type Node_Type;
type Node_Access is access Node_Type;
- package Tree_Types is
- new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+ type Element_Access is access Element_Type;
- use Tree_Types;
- use Ada.Finalization;
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
+ Element : Element_Access;
+ end record;
- type Set is new Controlled with record
- Tree : Tree_Type := (Length => 0, others => null);
+ package Tree_Types is new Red_Black_Trees.Generic_Tree_Types
+ (Node_Type,
+ Node_Access);
+
+ type Set is new Ada.Finalization.Controlled with record
+ Tree : Tree_Types.Tree_Type;
end record;
procedure Adjust (Container : in out Set);
procedure Finalize (Container : in out Set) renames Clear;
- type Set_Access is access constant Set;
+ use Red_Black_Trees;
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
type Cursor is record
for Set'Read use Read;
Empty_Set : constant Set :=
- (Controlled with Tree => (Length => 0, others => null));
+ (Controlled with Tree => (First => null,
+ Last => null,
+ Root => null,
+ Length => 0,
+ Busy => 0,
+ Lock => 0));
end Ada.Containers.Indefinite_Ordered_Multisets;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS --
+-- A D A . C O N T A I N E R S . --
+-- I N D E F I N I T E _ O R D E R E D _ S E T S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Unchecked_Deallocation;
-with System; use type System.Address;
-
package body Ada.Containers.Indefinite_Ordered_Sets is
- type Element_Access is access Element_Type;
-
- use Red_Black_Trees;
-
- type Node_Type is limited record
- Parent : Node_Access;
- Left : Node_Access;
- Right : Node_Access;
- Color : Red_Black_Trees.Color_Type := Red;
- Element : Element_Access;
- end record;
-
-----------------------
-- Local Subprograms --
-----------------------
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
- function Copy_Tree (Source_Root : Node_Access) return Node_Access;
-
- procedure Delete_Tree (X : in out Node_Access);
-
procedure Free (X : in out Node_Access);
procedure Insert_With_Hint
function Parent (Node : Node_Access) return Node_Access;
pragma Inline (Parent);
+ procedure Replace_Element
+ (Tree : in out Tree_Type;
+ Node : Node_Access;
+ Item : Element_Type);
+
function Right (Node : Node_Access) return Node_Access;
pragma Inline (Right);
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
package Tree_Operations is
- new Red_Black_Trees.Generic_Operations
- (Tree_Types => Tree_Types,
- Null_Node => Node_Access'(null));
+ new Red_Black_Trees.Generic_Operations (Tree_Types);
+
+ procedure Delete_Tree is
+ new Tree_Operations.Generic_Delete_Tree (Free);
+
+ function Copy_Tree is
+ new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
use Tree_Operations;
-- Start of processing for "="
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
return Is_Equal (Left.Tree, Right.Tree);
end "=";
-
---------
-- ">" --
---------
-- Adjust --
------------
- procedure Adjust (Container : in out Set) is
- Tree : Tree_Type renames Container.Tree;
+ procedure Adjust is
+ new Tree_Operations.Generic_Adjust (Copy_Tree);
+ procedure Adjust (Container : in out Set) is
begin
- if Tree.Length = 0 then
- pragma Assert (Tree.Root = null);
- return;
- end if;
-
- begin
- Tree.Root := Copy_Tree (Tree.Root);
- exception
- when others =>
- Tree := (Length => 0, others => null);
- raise;
- end;
-
- Tree.First := Min (Tree.Root);
- Tree.Last := Max (Tree.Root);
+ Adjust (Container.Tree);
end Adjust;
-------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Ceiling;
-----------
-- Clear --
-----------
+ procedure Clear is
+ new Tree_Operations.Generic_Clear (Delete_Tree);
+
procedure Clear (Container : in out Set) is
- Tree : Tree_Type renames Container.Tree;
- Root : Node_Access := Tree.Root;
begin
- Tree := (Length => 0, others => null);
- Delete_Tree (Root);
+ Clear (Container.Tree);
end Clear;
-----------
function Copy_Node (Source : Node_Access) return Node_Access is
Element : Element_Access := new Element_Type'(Source.Element.all);
+
begin
return new Node_Type'(Parent => null,
Left => null,
raise;
end Copy_Node;
- ---------------
- -- Copy_Tree --
- ---------------
-
- function Copy_Tree (Source_Root : Node_Access) return Node_Access is
- Target_Root : Node_Access := Copy_Node (Source_Root);
- P, X : Node_Access;
-
- begin
- if Source_Root.Right /= null then
- Target_Root.Right := Copy_Tree (Source_Root.Right);
- Target_Root.Right.Parent := Target_Root;
- end if;
-
- P := Target_Root;
- X := Source_Root.Left;
-
- while X /= null loop
- declare
- Y : Node_Access := Copy_Node (X);
-
- begin
- P.Left := Y;
- Y.Parent := P;
-
- if X.Right /= null then
- Y.Right := Copy_Tree (X.Right);
- Y.Right.Parent := Y;
- end if;
-
- P := Y;
- X := X.Left;
- end;
- end loop;
-
- return Target_Root;
-
- exception
- when others =>
- Delete_Tree (Target_Root);
- raise;
- end Copy_Tree;
-
------------
-- Delete --
------------
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
- if Position = No_Element then
- return;
+ if Position.Node = null then
+ raise Constraint_Error;
end if;
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
- Delete_Node_Sans_Free (Container.Tree, Position.Node);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
Free (Position.Node);
-
Position.Container := null;
end Delete;
------------------
procedure Delete_First (Container : in out Set) is
- C : Cursor := First (Container);
+ Tree : Tree_Type renames Container.Tree;
+ X : Node_Access := Tree.First;
+
begin
- Delete (Container, C);
+ if X /= null then
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end if;
end Delete_First;
-----------------
-----------------
procedure Delete_Last (Container : in out Set) is
- C : Cursor := Last (Container);
- begin
- Delete (Container, C);
- end Delete_Last;
-
- -----------------
- -- Delete_Tree --
- -----------------
+ Tree : Tree_Type renames Container.Tree;
+ X : Node_Access := Tree.Last;
- procedure Delete_Tree (X : in out Node_Access) is
- Y : Node_Access;
begin
- while X /= null loop
- Y := X.Right;
- Delete_Tree (Y);
- Y := X.Left;
+ if X /= null then
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
Free (X);
- X := Y;
- end loop;
- end Delete_Tree;
+ end if;
+ end Delete_Last;
----------------
-- Difference --
procedure Difference (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
-
Set_Ops.Difference (Target.Tree, Source.Tree);
end Difference;
function Difference (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Difference (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Difference (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Difference;
-------------
return Position.Node.Element.all;
end Element;
+ ---------------------
+ -- Equivalent_Sets --
+ ---------------------
+
+ function Equivalent_Sets (Left, Right : Set) return Boolean is
+
+ function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Equivalent_Node_Node);
+
+ function Is_Equivalent is
+ new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
+
+ -----------------------------
+ -- Is_Equivalent_Node_Node --
+ -----------------------------
+
+ function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ if L.Element.all < R.Element.all then
+ return False;
+ elsif R.Element.all < L.Element.all then
+ return False;
+ else
+ return True;
+ end if;
+ end Is_Equivalent_Node_Node;
+
+ -- Start of processing for Equivalent_Sets
+
+ begin
+ return Is_Equivalent (Left.Tree, Right.Tree);
+ end Equivalent_Sets;
+
-------------
-- Exclude --
-------------
procedure Exclude (Container : in out Set; Item : Element_Type) is
X : Node_Access :=
Element_Keys.Find (Container.Tree, Item);
+
begin
if X /= null then
- Delete_Node_Sans_Free (Container.Tree, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end if;
end Exclude;
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
end First;
-------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
----------
----------
procedure Free (X : in out Node_Access) is
+
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
begin
- if X /= null then
- Free_Element (X.Element);
- Deallocate (X);
+ if X = null then
+ return;
end if;
+
+ begin
+ Free_Element (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ Deallocate (X);
+ raise;
+ end;
+
+ Deallocate (X);
end Free;
------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Ceiling;
- ----------------------------
- -- Checked_Update_Element --
- ----------------------------
-
- procedure Checked_Update_Element
- (Container : in out Set;
- Position : Cursor;
- Process : not null access
- procedure (Element : in out Element_Type))
- is
- begin
- if Position.Container = null then
- raise Constraint_Error;
- end if;
-
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
- raise Program_Error;
- end if;
-
- declare
- Old_Key : Key_Type renames Key (Position.Node.Element.all);
-
- begin
- Process (Position.Node.Element.all);
-
- if Old_Key < Position.Node.Element.all
- or else Old_Key > Position.Node.Element.all
- then
- null;
- else
- return;
- end if;
- end;
-
- declare
- Result : Node_Access;
- Success : Boolean;
-
- function New_Node return Node_Access;
- pragma Inline (New_Node);
-
- procedure Insert_Post is
- new Key_Keys.Generic_Insert_Post (New_Node);
-
- procedure Insert is
- new Key_Keys.Generic_Conditional_Insert (Insert_Post);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Node_Access is
- begin
- return Position.Node;
- end New_Node;
-
- -- Start of processing for Checked_Update_Element
-
- begin
- Delete_Node_Sans_Free (Container.Tree, Position.Node);
-
- Insert
- (Tree => Container.Tree,
- Key => Key (Position.Node.Element.all),
- Node => Result,
- Success => Success);
-
- if not Success then
- declare
- X : Node_Access := Position.Node;
- begin
- Free (X);
- end;
-
- raise Program_Error;
- end if;
-
- pragma Assert (Result = Position.Node);
- end;
- end Checked_Update_Element;
-
--------------
-- Contains --
--------------
raise Constraint_Error;
end if;
- Delete_Node_Sans_Free (Container.Tree, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end Delete;
-------------
function Element (Container : Set; Key : Key_Type) return Element_Type is
- C : constant Cursor := Find (Container, Key);
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container.Tree, Key);
+
begin
- return C.Node.Element.all;
+ return Node.Element.all;
end Element;
-------------
begin
if X /= null then
- Delete_Node_Sans_Free (Container.Tree, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end if;
end Exclude;
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
-------------------------
return Key (Position.Node.Element.all);
end Key;
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
+
+ Replace_Element (Container.Tree, Node, New_Item);
+ end Replace;
+
+ -----------------------------------
+ -- Update_Element_Preserving_Key --
+ -----------------------------------
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type))
+ is
+ Tree : Tree_Type renames Container.Tree;
+
+ begin
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error;
+ end if;
+
+ declare
+ E : Element_Type renames Position.Node.Element.all;
+ K : Key_Type renames Key (E);
+
+ B : Natural renames Tree.Busy;
+ L : Natural renames Tree.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+
+ if K < E
+ or else K > E
+ then
+ null;
+ else
+ return;
+ end if;
+ end;
+
+ declare
+ X : Node_Access := Position.Node;
+ begin
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end;
+
+ raise Program_Error;
+ end Update_Element_Preserving_Key;
+
end Generic_Keys;
-----------------
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
+ if Container.Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
+
X := Position.Node.Element;
Position.Node.Element := new Element_Type'(New_Item);
Free_Element (X);
Position.Node,
Inserted);
- Position.Container := Container'Unchecked_Access;
+ Position.Container := Container'Unrestricted_Access;
end Insert;
procedure Insert (Container : in out Set; New_Item : Element_Type) is
procedure Intersection (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Set_Ops.Intersection (Target.Tree, Source.Tree);
end Intersection;
function Intersection (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Intersection (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Left;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Intersection (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Intersection;
--------------
function Is_Empty (Container : Set) return Boolean is
begin
- return Length (Container) = 0;
+ return Container.Tree.Length = 0;
end Is_Empty;
-----------------------------
return Right.Element.all < Left;
end Is_Greater_Element_Node;
-
--------------------------
-- Is_Less_Element_Node --
--------------------------
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
begin
- if Subset'Address = Of_Set'Address then
- return True;
- end if;
-
return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
end Is_Subset;
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- -- Start of processing for Iterate
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
+ -- Start of prccessing for Iterate
begin
- Local_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Iterate (T);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end Last;
------------------
-- Move --
----------
+ procedure Move is
+ new Tree_Operations.Generic_Move (Clear);
+
procedure Move (Target : in out Set; Source : in out Set) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Move (Target => Target.Tree, Source => Source.Tree);
end Move;
declare
Node : constant Node_Access :=
- Tree_Operations.Next (Position.Node);
+ Tree_Operations.Next (Position.Node);
+
begin
if Node = null then
return No_Element;
function Overlap (Left, Right : Set) return Boolean is
begin
- if Left'Address = Right'Address then
- return Left.Tree.Length /= 0;
- end if;
-
return Set_Ops.Overlap (Left.Tree, Right.Tree);
end Overlap;
declare
Node : constant Node_Access :=
- Tree_Operations.Previous (Position.Node);
+ Tree_Operations.Previous (Position.Node);
+
begin
if Node = null then
return No_Element;
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
+ E : Element_Type renames Position.Node.Element.all;
+
+ S : Set renames Position.Container.all;
+ T : Tree_Type renames S.Tree'Unrestricted_Access.all;
+
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
begin
- Process (Position.Node.Element.all);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Query_Element;
----------
----------
procedure Read
- (Stream : access Ada.Streams.Root_Stream_Type'Class;
+ (Stream : access Root_Stream_Type'Class;
Container : out Set)
is
- N : Count_Type'Base;
-
- function New_Node return Node_Access;
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access;
+ pragma Inline (Read_Node);
procedure Read is
- new Tree_Operations.Generic_Read (New_Node);
+ new Tree_Operations.Generic_Read (Clear, Read_Node);
- --------------
- -- New_Node --
- --------------
+ ---------------
+ -- Read_Node --
+ ---------------
- function New_Node return Node_Access is
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access
+ is
Node : Node_Access := new Node_Type;
begin
exception
when others =>
- Free (Node);
+ Free (Node); -- Note that Free deallocates elem too
raise;
- end New_Node;
+ end Read_Node;
-- Start of processing for Read
begin
- Clear (Container);
- Count_Type'Base'Read (Stream, N);
- pragma Assert (N >= 0);
- Read (Container.Tree, N);
+ Read (Stream, Container.Tree);
end Read;
-------------
Free_Element (X);
end Replace;
--- TODO ???
--- procedure Replace
--- (Container : in out Set;
--- Key : Key_Type;
--- New_Item : Element_Type)
--- is
--- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
-
--- begin
--- if Node = null then
--- raise Constraint_Error;
--- end if;
-
--- Replace_Element (Container, Node, New_Item);
--- end Replace;
-
---------------------
-- Replace_Element --
---------------------
--- TODO: ???
--- procedure Replace_Element
--- (Container : in out Set;
--- Position : Node_Access;
--- By : Element_Type)
--- is
-
--- Node : Node_Access := Position;
-
--- begin
--- if By < Node.Element.all
--- or else Node.Element.all < By
--- then
--- null;
-
--- else
--- declare
--- X : Element_Access := Node.Element;
-
--- begin
--- Node.Element := new Element_Type'(By);
-
--- -- NOTE: If there's an exception here, then just
--- -- let it propagate. We haven't modified the
--- -- state of the container, so there's nothing else
--- -- we need to do.
-
--- Free_Element (X);
--- end;
-
--- return;
--- end if;
-
--- Delete_Node_Sans_Free (Container.Tree, Node);
-
--- begin
--- Free_Element (Node.Element);
--- exception
--- when others =>
--- Node.Element := null; -- don't attempt to dealloc X.E again
--- Free (Node);
--- raise;
--- end;
-
--- begin
--- Node.Element := new Element_Type'(By);
--- exception
--- when others =>
--- Free (Node);
--- raise;
--- end;
-
--- declare
--- function New_Node return Node_Access;
--- pragma Inline (New_Node);
-
--- function New_Node return Node_Access is
--- begin
--- return Node;
--- end New_Node;
-
--- procedure Insert_Post is
--- new Element_Keys.Generic_Insert_Post (New_Node);
-
--- procedure Insert is
--- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
-
--- Result : Node_Access;
--- Success : Boolean;
-
--- begin
--- Insert
--- (Tree => Container.Tree,
--- Key => Node.Element.all,
--- Node => Result,
--- Success => Success);
-
--- if not Success then
--- Free (Node);
--- raise Program_Error;
--- end if;
-
--- pragma Assert (Result = Node);
--- end;
--- end Replace_Element;
-
-
--- procedure Replace_Element
--- (Container : in out Set;
--- Position : Cursor;
--- By : Element_Type)
--- is
--- begin
--- if Position.Container = null then
--- raise Constraint_Error;
--- end if;
-
--- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
--- raise Program_Error;
--- end if;
-
--- Replace_Element (Container, Position.Node, By);
--- end Replace_Element;
+ procedure Replace_Element
+ (Tree : in out Tree_Type;
+ Node : Node_Access;
+ Item : Element_Type)
+ is
+ begin
+ if Item < Node.Element.all
+ or else Node.Element.all < Item
+ then
+ null;
+ else
+ if Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
+
+ declare
+ X : Element_Access := Node.Element;
+ begin
+ Node.Element := new Element_Type'(Item);
+ Free_Element (X);
+ end;
+
+ return;
+ end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
+
+ Insert_New_Item : declare
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ Node.Element := new Element_Type'(Item); -- OK if fails
+ return Node;
+ end New_Node;
+
+ Result : Node_Access;
+ Inserted : Boolean;
+
+ X : Element_Access := Node.Element;
+
+ -- Start of processing for Insert_New_Item
+
+ begin
+ Attempt_Insert : begin
+ Insert
+ (Tree => Tree,
+ Key => Item,
+ Node => Result,
+ Success => Inserted); -- TODO: change name of formal param
+ exception
+ when others =>
+ Inserted := False;
+ end Attempt_Insert;
+
+ if Inserted then
+ pragma Assert (Result = Node);
+ Free_Element (X); -- OK if fails
+ return;
+ end if;
+ end Insert_New_Item;
+
+ Reinsert_Old_Element : declare
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ return Node;
+ end New_Node;
+
+ Result : Node_Access;
+ Inserted : Boolean;
+
+ -- Start of processing for Reinsert_Old_Element
+
+ begin
+ Insert
+ (Tree => Tree,
+ Key => Node.Element.all,
+ Node => Result,
+ Success => Inserted); -- TODO: change name of formal param
+ exception
+ when others =>
+ null;
+ end Reinsert_Old_Element;
+
+ raise Program_Error;
+ end Replace_Element;
+
+ procedure Replace_Element
+ (Container : Set;
+ Position : Cursor;
+ By : Element_Type)
+ is
+ Tree : Tree_Type renames Position.Container.Tree'Unrestricted_Access.all;
+
+ begin
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error;
+ end if;
+
+ Replace_Element (Tree, Position.Node, By);
+ end Replace_Element;
---------------------
-- Reverse_Iterate --
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Reverse_Iterate
begin
- Local_Reverse_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (T);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
-----------
procedure Symmetric_Difference (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
-
Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
end Symmetric_Difference;
function Symmetric_Difference (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Symmetric_Difference;
-----------
procedure Union (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Set_Ops.Union (Target.Tree, Source.Tree);
end Union;
function Union (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Union (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Left;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Union (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Union;
-----------
-----------
procedure Write
- (Stream : access Ada.Streams.Root_Stream_Type'Class;
+ (Stream : access Root_Stream_Type'Class;
Container : Set)
is
- procedure Process (Node : Node_Access);
- pragma Inline (Process);
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+ pragma Inline (Write_Node);
- procedure Iterate is
- new Tree_Operations.Generic_Iteration (Process);
+ procedure Write is
+ new Tree_Operations.Generic_Write (Write_Node);
- -------------
- -- Process --
- -------------
+ ----------------
+ -- Write_Node --
+ ----------------
- procedure Process (Node : Node_Access) is
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access)
+ is
begin
Element_Type'Output (Stream, Node.Element.all);
- end Process;
+ end Write_Node;
-- Start of processing for Write
begin
- Count_Type'Base'Write (Stream, Container.Tree.Length);
- Iterate (Container.Tree);
+ Write (Stream, Container.Tree);
end Write;
end Ada.Containers.Indefinite_Ordered_Sets;
-
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS --
+-- A D A . C O N T A I N E R S . --
+-- I N D E F I N I T E _ O R D E R E D _ S E T S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
function "=" (Left, Right : Set) return Boolean;
+ function Equivalent_Sets (Left, Right : Set) return Boolean;
+
function Length (Container : Set) return Count_Type;
function Is_Empty (Container : Set) return Boolean;
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
- -- TODO: resolve in Atlanta???
- -- procedure Replace_Element
- -- (Container : in out Set;
- -- Position : Cursor;
- -- By : Element_Type);
+ procedure Replace_Element
+ (Container : Set; -- TODO: need ruling from ARG
+ Position : Cursor;
+ By : Element_Type);
procedure Move (Target : in out Set; Source : in out Set);
(Container : in out Set;
Item : Element_Type);
- procedure Exclude
- (Container : in out Set;
- Item : Element_Type);
-
procedure Delete
(Container : in out Set;
Position : in out Cursor);
procedure Delete_Last (Container : in out Set);
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type);
+
procedure Union (Target : in out Set; Source : Set);
function Union (Left, Right : Set) return Set;
function Next (Position : Cursor) return Cursor;
- function Previous (Position : Cursor) return Cursor;
-
procedure Next (Position : in out Cursor);
+ function Previous (Position : Cursor) return Cursor;
+
procedure Previous (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
(Container : Set;
Key : Key_Type) return Element_Type;
- -- TODO: resolve in Atlanta???
- -- procedure Replace
- -- (Container : in out Set;
- -- Key : Key_Type;
- -- New_Item : Element_Type);
+ procedure Replace
+ (Container : in out Set; -- TODO: need ruling from ARG
+ Key : Key_Type;
+ New_Item : Element_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
function ">" (Left : Key_Type; Right : Cursor) return Boolean;
- -- TODO: resolve name in Atlanta???
- procedure Checked_Update_Element
+ procedure Update_Element_Preserving_Key
(Container : in out Set;
Position : Cursor;
Process : not null access
type Node_Type;
type Node_Access is access Node_Type;
- package Tree_Types is
- new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+ type Element_Access is access Element_Type;
- use Tree_Types;
- use Ada.Finalization;
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
+ Element : Element_Access;
+ end record;
+
+ package Tree_Types is new Red_Black_Trees.Generic_Tree_Types
+ (Node_Type,
+ Node_Access);
- type Set is new Controlled with record
- Tree : Tree_Type := (Length => 0, others => null);
+ type Set is new Ada.Finalization.Controlled with record
+ Tree : Tree_Types.Tree_Type;
end record;
procedure Adjust (Container : in out Set);
procedure Finalize (Container : in out Set) renames Clear;
- type Set_Access is access constant Set;
+ use Red_Black_Trees;
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
type Cursor is record
for Set'Read use Read;
Empty_Set : constant Set :=
- (Controlled with Tree => (Length => 0, others => null));
+ (Controlled with Tree => (First => null,
+ Last => null,
+ Root => null,
+ Length => 0,
+ Busy => 0,
+ Lock => 0));
end Ada.Containers.Indefinite_Ordered_Sets;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.HASHED_MAPS --
+-- A D A . C O N T A I N E R S . H A S H E D _ M A P S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package body Ada.Containers.Hashed_Maps is
- type Node_Type is limited record
- Key : Key_Type;
- Element : Element_Type;
- Next : Node_Access;
- end record;
-
-----------------------
-- Local Subprograms --
-----------------------
(Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
- function Equivalent_Keys
+ function Equivalent_Key_Node
(Key : Key_Type;
Node : Node_Access) return Boolean;
- pragma Inline (Equivalent_Keys);
+ pragma Inline (Equivalent_Key_Node);
+
+ procedure Free (X : in out Node_Access);
function Find_Equal_Key
- (R_Map : Map;
+ (R_HT : Hash_Table_Type;
L_Node : Node_Access) return Boolean;
function Hash_Node (Node : Node_Access) return Hash_Type;
procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next);
+ function Vet (Position : Cursor) return Boolean;
+
procedure Write_Node
(Stream : access Root_Stream_Type'Class;
Node : Node_Access);
-- Local Instantiations --
--------------------------
- procedure Free is
- new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
-
package HT_Ops is
new Hash_Tables.Generic_Operations
(HT_Types => HT_Types,
- Hash_Table_Type => Map,
- Null_Node => null,
Hash_Node => Hash_Node,
Next => Next,
Set_Next => Set_Next,
package Key_Ops is
new Hash_Tables.Generic_Keys
(HT_Types => HT_Types,
- HT_Type => Map,
- Null_Node => null,
Next => Next,
Set_Next => Set_Next,
Key_Type => Key_Type,
Hash => Hash,
- Equivalent_Keys => Equivalent_Keys);
+ Equivalent_Keys => Equivalent_Key_Node);
function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
-- "=" --
---------
- function "=" (Left, Right : Map) return Boolean renames Is_Equal;
+ function "=" (Left, Right : Map) return Boolean is
+ begin
+ return Is_Equal (Left.HT, Right.HT);
+ end "=";
------------
-- Adjust --
------------
- procedure Adjust (Container : in out Map) renames HT_Ops.Adjust;
+ procedure Adjust (Container : in out Map) is
+ begin
+ HT_Ops.Adjust (Container.HT);
+ end Adjust;
--------------
-- Capacity --
--------------
- function Capacity (Container : Map) return Count_Type
- renames HT_Ops.Capacity;
+ function Capacity (Container : Map) return Count_Type is
+ begin
+ return HT_Ops.Capacity (Container.HT);
+ end Capacity;
-----------
-- Clear --
-----------
- procedure Clear (Container : in out Map) renames HT_Ops.Clear;
+ procedure Clear (Container : in out Map) is
+ begin
+ HT_Ops.Clear (Container.HT);
+ end Clear;
--------------
-- Contains --
X : Node_Access;
begin
- Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+ Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
if X = null then
raise Constraint_Error;
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
- if Position = No_Element then
- return;
+ if Position.Node = null then
+ raise Constraint_Error;
end if;
if Position.Container /= Map_Access'(Container'Unchecked_Access) then
raise Program_Error;
end if;
- HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
- Free (Position.Node);
+ pragma Assert (Position.Node.Next /= Position.Node);
+
+ if Container.HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+ HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
+
+ Free (Position.Node);
Position.Container := null;
end Delete;
function Element (Position : Cursor) return Element_Type is
begin
+ pragma Assert (Vet (Position));
return Position.Node.Element;
end Element;
- ---------------------
- -- Equivalent_Keys --
- ---------------------
+ -------------------------
+ -- Equivalent_Key_Node --
+ -------------------------
- function Equivalent_Keys
+ function Equivalent_Key_Node
(Key : Key_Type;
Node : Node_Access) return Boolean is
begin
return Equivalent_Keys (Key, Node.Key);
- end Equivalent_Keys;
+ end Equivalent_Key_Node;
---------------------
-- Equivalent_Keys --
function Equivalent_Keys (Left, Right : Cursor)
return Boolean is
begin
+ pragma Assert (Vet (Left));
+ pragma Assert (Vet (Right));
return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
end Equivalent_Keys;
function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
begin
+ pragma Assert (Vet (Left));
return Equivalent_Keys (Left.Node.Key, Right);
end Equivalent_Keys;
function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
begin
+ pragma Assert (Vet (Right));
return Equivalent_Keys (Left, Right.Node.Key);
end Equivalent_Keys;
procedure Exclude (Container : in out Map; Key : Key_Type) is
X : Node_Access;
begin
- Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+ Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
Free (X);
end Exclude;
-- Finalize --
--------------
- procedure Finalize (Container : in out Map) renames HT_Ops.Finalize;
+ procedure Finalize (Container : in out Map) is
+ begin
+ HT_Ops.Finalize (Container.HT);
+ end Finalize;
----------
-- Find --
----------
function Find (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Node_Access := Key_Ops.Find (Container, Key);
+ Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
begin
if Node = null then
--------------------
function Find_Equal_Key
- (R_Map : Map;
+ (R_HT : Hash_Table_Type;
L_Node : Node_Access) return Boolean
is
- R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key);
- R_Node : Node_Access := R_Map.Buckets (R_Index);
+ R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key);
+ R_Node : Node_Access := R_HT.Buckets (R_Index);
begin
while R_Node /= null loop
-----------
function First (Container : Map) return Cursor is
- Node : constant Node_Access := HT_Ops.First (Container);
+ Node : constant Node_Access := HT_Ops.First (Container.HT);
begin
if Node = null then
return Cursor'(Container'Unchecked_Access, Node);
end First;
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Node_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+ begin
+ if X /= null then
+ X.Next := X; -- detect mischief (in Vet)
+ Deallocate (X);
+ end if;
+ end Free;
+
-----------------
-- Has_Element --
-----------------
function Has_Element (Position : Cursor) return Boolean is
begin
- return Position /= No_Element;
+ if Position.Node = null then
+ pragma Assert (Position.Container = null);
+ return False;
+ end if;
+
+ pragma Assert (Vet (Position));
+ return True;
end Has_Element;
---------------
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
+ if Container.HT.Lock > 0 then
+ raise Program_Error;
+ end if;
+
Position.Node.Key := Key;
Position.Node.Element := New_Item;
end if;
raise;
end New_Node;
+ HT : Hash_Table_Type renames Container.HT;
+
-- Start of processing for Insert
begin
- HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
- Local_Insert (Container, Key, Position.Node, Inserted);
+ if HT.Length >= HT_Ops.Capacity (HT) then
+
+ -- TODO: 17 Apr 2005
+ -- We should defer the expansion until we're sure that the
+ -- element was successfully inserted. We can do that by
+ -- first performing the insertion attempt, and allowing the
+ -- invariant len <= cap to be violated temporarily. After
+ -- the insertion we can restore the invariant. The
+ -- worst that can happen is that the insertion succeeds
+ -- (new element is added to the map), but the
+ -- invariant is broken (len > cap). But it's only
+ -- broken by a little (since len = cap + 1), so the
+ -- effect is benign.
+ -- END TODO.
+
+ HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
+ end if;
+
+ Local_Insert (HT, Key, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
return Node;
end New_Node;
+ HT : Hash_Table_Type renames Container.HT;
+
-- Start of processing for Insert
begin
- HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
- Local_Insert (Container, Key, Position.Node, Inserted);
+ if HT.Length >= HT_Ops.Capacity (HT) then
+ -- TODO: see note above.
+ HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
+ end if;
+
+ Local_Insert (HT, Key, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
function Is_Empty (Container : Map) return Boolean is
begin
- return Container.Length = 0;
+ return Container.HT.Length = 0;
end Is_Empty;
-------------
-- Start of processing for Iterate
begin
- Local_Iterate (Container);
+ Local_Iterate (Container.HT);
end Iterate;
---------
function Key (Position : Cursor) return Key_Type is
begin
+ pragma Assert (Vet (Position));
return Position.Node.Key;
end Key;
function Length (Container : Map) return Count_Type is
begin
- return Container.Length;
+ return Container.HT.Length;
end Length;
----------
procedure Move
(Target : in out Map;
- Source : in out Map) renames HT_Ops.Move;
+ Source : in out Map)
+ is
+ begin
+ HT_Ops.Move (Target => Target.HT, Source => Source.HT);
+ end Move;
----------
-- Next --
function Next (Position : Cursor) return Cursor is
begin
- if Position = No_Element then
+ if Position.Node = null then
+ pragma Assert (Position.Container = null);
return No_Element;
end if;
declare
- M : Map renames Position.Container.all;
- Node : constant Node_Access := HT_Ops.Next (M, Position.Node);
+ pragma Assert (Vet (Position));
+ HT : Hash_Table_Type renames Position.Container.HT;
+ Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
begin
if Node = null then
procedure Query_Element
(Position : Cursor;
- Process : not null access procedure (Element : Element_Type))
+ Process : not null access
+ procedure (Key : Key_Type; Element : Element_Type))
+
is
+ pragma Assert (Vet (Position));
+
+ K : Key_Type renames Position.Node.Key;
+ E : Element_Type renames Position.Node.Element;
+
+ M : Map renames Position.Container.all;
+ HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+
begin
- Process (Position.Node.Key, Position.Node.Element);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Query_Element;
----------
procedure Read
(Stream : access Root_Stream_Type'Class;
- Container : out Map) renames Read_Nodes;
+ Container : out Map)
+ is
+ begin
+ Read_Nodes (Stream, Container.HT);
+ end Read;
---------------
-- Read_Node --
Key : Key_Type;
New_Item : Element_Type)
is
- Node : constant Node_Access := Key_Ops.Find (Container, Key);
+ Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
begin
if Node = null then
raise Constraint_Error;
end if;
+ if Container.HT.Lock > 0 then
+ raise Program_Error;
+ end if;
+
Node.Key := Key;
Node.Element := New_Item;
end Replace;
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
+ pragma Assert (Vet (Position));
+ E : Element_Type renames Position.Node.Element;
+
begin
- Position.Node.Element := By;
+ if Position.Container.HT.Lock > 0 then
+ raise Program_Error;
+ end if;
+
+ E := By;
end Replace_Element;
----------------------
procedure Reserve_Capacity
(Container : in out Map;
- Capacity : Count_Type) renames HT_Ops.Ensure_Capacity;
+ Capacity : Count_Type)
+ is
+ begin
+ HT_Ops.Reserve_Capacity (Container.HT, Capacity);
+ end Reserve_Capacity;
--------------
-- Set_Next --
procedure Update_Element
(Position : Cursor;
- Process : not null access procedure (Element : in out Element_Type))
+ Process : not null access procedure (Key : Key_Type;
+ Element : in out Element_Type))
is
+ pragma Assert (Vet (Position));
+
+ K : Key_Type renames Position.Node.Key;
+ E : Element_Type renames Position.Node.Element;
+
+ M : Map renames Position.Container.all;
+ HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+
begin
- Process (Position.Node.Key, Position.Node.Element);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Update_Element;
+ ---------
+ -- Vet --
+ ---------
+
+ function Vet (Position : Cursor) return Boolean is
+ begin
+ if Position.Node = null then
+ return False;
+ end if;
+
+ if Position.Node.Next = Position.Node then
+ return False;
+ end if;
+
+ if Position.Container = null then
+ return False;
+ end if;
+
+ declare
+ HT : Hash_Table_Type renames Position.Container.HT;
+ X : Node_Access;
+ begin
+ if HT.Length = 0 then
+ return False;
+ end if;
+
+ if HT.Buckets = null then
+ return False;
+ end if;
+
+-- NOTE: see notes in Insert.
+-- if HT.Length > HT.Buckets'Length then
+-- return False;
+-- end if;
+
+ X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key));
+
+ for J in 1 .. HT.Length loop
+ if X = Position.Node then
+ return True;
+ end if;
+
+ if X = null then
+ return False;
+ end if;
+
+ if X = X.Next then -- weird
+ return False;
+ end if;
+
+ X := X.Next;
+ end loop;
+
+ return False;
+ end;
+ end Vet;
+
-----------
-- Write --
-----------
procedure Write
(Stream : access Root_Stream_Type'Class;
- Container : Map) renames Write_Nodes;
+ Container : Map)
+ is
+ begin
+ Write_Nodes (Stream, Container.HT);
+ end Write;
----------------
-- Write_Node --
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.HASHED_MAPS --
+-- A D A . C O N T A I N E R S . H A S H E D _ M A P S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Containers.Hash_Tables;
with Ada.Streams;
+with Ada.Finalization;
generic
type Key_Type is private;
procedure Clear (Container : in out Map);
- function Element (Position : Cursor)
- return Element_Type;
+ function Key (Position : Cursor) return Key_Type;
+
+ function Element (Position : Cursor) return Element_Type;
procedure Query_Element
(Position : Cursor;
procedure Insert
(Container : in out Map;
Key : Key_Type;
- New_Item : Element_Type);
+ Position : out Cursor;
+ Inserted : out Boolean);
- procedure Include
+ procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
- procedure Replace
+ procedure Include
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
- procedure Insert
+ procedure Replace
(Container : in out Map;
Key : Key_Type;
- Position : out Cursor;
- Inserted : out Boolean);
+ New_Item : Element_Type);
procedure Delete (Container : in out Map; Key : Key_Type);
- procedure Exclude (Container : in out Map; Key : Key_Type);
-
procedure Delete (Container : in out Map; Position : in out Cursor);
+ procedure Exclude (Container : in out Map; Key : Key_Type);
+
function Contains (Container : Map; Key : Key_Type) return Boolean;
function Find (Container : Map; Key : Key_Type) return Cursor;
function Element (Container : Map; Key : Key_Type) return Element_Type;
- function Capacity (Container : Map) return Count_Type;
-
- procedure Reserve_Capacity (Container : in out Map;
- Capacity : Count_Type);
-
function First (Container : Map) return Cursor;
function Next (Position : Cursor) return Cursor;
function Has_Element (Position : Cursor) return Boolean;
- function Key (Position : Cursor) return Key_Type;
-
function Equivalent_Keys (Left, Right : Cursor) return Boolean;
function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean;
(Container : Map;
Process : not null access procedure (Position : Cursor));
+ function Capacity (Container : Map) return Count_Type;
+
+ procedure Reserve_Capacity (Container : in out Map;
+ Capacity : Count_Type);
+
private
+ pragma Inline ("=");
+ pragma Inline (Length);
+ pragma Inline (Is_Empty);
+ pragma Inline (Clear);
+ pragma Inline (Key);
+ pragma Inline (Element);
+ pragma Inline (Move);
+ pragma Inline (Contains);
+ pragma Inline (Capacity);
+ pragma Inline (Reserve_Capacity);
+ pragma Inline (Has_Element);
+ pragma Inline (Equivalent_Keys);
type Node_Type;
type Node_Access is access Node_Type;
- package HT_Types is new Hash_Tables.Generic_Hash_Table_Types (Node_Access);
+ type Node_Type is limited record
+ Key : Key_Type;
+ Element : Element_Type;
+ Next : Node_Access;
+ end record;
- use HT_Types;
+ package HT_Types is new Hash_Tables.Generic_Hash_Table_Types
+ (Node_Type,
+ Node_Access);
- type Map is new Hash_Table_Type with null record;
+ type Map is new Ada.Finalization.Controlled with record
+ HT : HT_Types.Hash_Table_Type;
+ end record;
+
+ use HT_Types;
+ use Ada.Finalization;
procedure Adjust (Container : in out Map);
for Map'Read use Read;
- Empty_Map : constant Map := (Hash_Table_Type with null record);
+ Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0));
type Map_Access is access constant Map;
for Map_Access'Storage_Size use 0;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.HASHED_SETS --
+-- A D A . C O N T A I N E R S . H A S H E D _ S E T S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Containers.Hash_Tables.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
-with System; use type System.Address;
-
with Ada.Containers.Prime_Numbers;
-with Ada.Finalization; use Ada.Finalization;
+with System; use type System.Address;
package body Ada.Containers.Hashed_Sets is
- type Node_Type is
- limited record
- Element : Element_Type;
- Next : Node_Access;
- end record;
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- function Hash_Node
- (Node : Node_Access) return Hash_Type;
- pragma Inline (Hash_Node);
+ function Copy_Node (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
- function Hash_Node
- (Node : Node_Access) return Hash_Type is
- begin
- return Hash (Node.Element);
- end Hash_Node;
+ function Equivalent_Keys
+ (Key : Element_Type;
+ Node : Node_Access) return Boolean;
+ pragma Inline (Equivalent_Keys);
- function Next
- (Node : Node_Access) return Node_Access;
- pragma Inline (Next);
+ function Find_Equal_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean;
- function Next
- (Node : Node_Access) return Node_Access is
- begin
- return Node.Next;
- end Next;
+ function Find_Equivalent_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean;
- procedure Set_Next
- (Node : Node_Access;
- Next : Node_Access);
- pragma Inline (Set_Next);
+ function Hash_Node (Node : Node_Access) return Hash_Type;
+ pragma Inline (Hash_Node);
- procedure Set_Next
- (Node : Node_Access;
- Next : Node_Access) is
- begin
- Node.Next := Next;
- end Set_Next;
+ function Is_In
+ (HT : Hash_Table_Type;
+ Key : Node_Access) return Boolean;
+ pragma Inline (Is_In);
- function Equivalent_Keys
- (Key : Element_Type;
- Node : Node_Access) return Boolean;
- pragma Inline (Equivalent_Keys);
+ function Next (Node : Node_Access) return Node_Access;
+ pragma Inline (Next);
- function Equivalent_Keys
- (Key : Element_Type;
- Node : Node_Access) return Boolean is
- begin
- return Equivalent_Keys (Key, Node.Element);
- end Equivalent_Keys;
+ function Read_Node (Stream : access Root_Stream_Type'Class)
+ return Node_Access;
+ pragma Inline (Read_Node);
- function Copy_Node
- (Source : Node_Access) return Node_Access;
- pragma Inline (Copy_Node);
+ procedure Replace_Element
+ (HT : in out Hash_Table_Type;
+ Node : Node_Access;
+ Element : Element_Type);
- function Copy_Node
- (Source : Node_Access) return Node_Access is
+ procedure Set_Next (Node : Node_Access; Next : Node_Access);
+ pragma Inline (Set_Next);
- Target : constant Node_Access :=
- new Node_Type'(Element => Source.Element,
- Next => null);
- begin
- return Target;
- end Copy_Node;
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+ pragma Inline (Write_Node);
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
procedure Free is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
package HT_Ops is
new Hash_Tables.Generic_Operations
- (HT_Types => HT_Types,
- Hash_Table_Type => Set,
- Null_Node => null,
- Hash_Node => Hash_Node,
- Next => Next,
- Set_Next => Set_Next,
- Copy_Node => Copy_Node,
- Free => Free);
+ (HT_Types => HT_Types,
+ Hash_Node => Hash_Node,
+ Next => Next,
+ Set_Next => Set_Next,
+ Copy_Node => Copy_Node,
+ Free => Free);
package Element_Keys is
new Hash_Tables.Generic_Keys
(HT_Types => HT_Types,
- HT_Type => Set,
- Null_Node => null,
Next => Next,
Set_Next => Set_Next,
Key_Type => Element_Type,
Hash => Hash,
Equivalent_Keys => Equivalent_Keys);
+ function Is_Equal is
+ new HT_Ops.Generic_Equal (Find_Equal_Key);
- procedure Adjust (Container : in out Set) renames HT_Ops.Adjust;
-
- procedure Finalize (Container : in out Set) renames HT_Ops.Finalize;
-
-
- function Find_Equal_Key
- (R_Set : Set;
- L_Node : Node_Access) return Boolean;
+ function Is_Equivalent is
+ new HT_Ops.Generic_Equal (Find_Equivalent_Key);
- function Find_Equal_Key
- (R_Set : Set;
- L_Node : Node_Access) return Boolean is
+ procedure Read_Nodes is
+ new HT_Ops.Generic_Read (Read_Node);
- R_Index : constant Hash_Type :=
- Element_Keys.Index (R_Set, L_Node.Element);
+ procedure Write_Nodes is
+ new HT_Ops.Generic_Write (Write_Node);
- R_Node : Node_Access := R_Set.Buckets (R_Index);
+ ---------
+ -- "=" --
+ ---------
+ function "=" (Left, Right : Set) return Boolean is
begin
+ return Is_Equal (Left.HT, Right.HT);
+ end "=";
- loop
+ ------------
+ -- Adjust --
+ ------------
- if R_Node = null then
- return False;
- end if;
+ procedure Adjust (Container : in out Set) is
+ begin
+ HT_Ops.Adjust (Container.HT);
+ end Adjust;
- if L_Node.Element = R_Node.Element then
- -- pragma Assert (Is_Equal_Key (L_Node.Element, R_Node.Element));
- return True;
- end if;
+ --------------
+ -- Capacity --
+ --------------
- R_Node := Next (R_Node);
+ function Capacity (Container : Set) return Count_Type is
+ begin
+ return HT_Ops.Capacity (Container.HT);
+ end Capacity;
- end loop;
+ -----------
+ -- Clear --
+ -----------
- end Find_Equal_Key;
+ procedure Clear (Container : in out Set) is
+ begin
+ HT_Ops.Clear (Container.HT);
+ end Clear;
- function Is_Equal is
- new HT_Ops.Generic_Equal (Find_Equal_Key);
+ --------------
+ -- Contains --
+ --------------
- function "=" (Left, Right : Set) return Boolean renames Is_Equal;
+ function Contains (Container : Set; Item : Element_Type) return Boolean is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+ ---------------
+ -- Copy_Node --
+ ---------------
- function Length (Container : Set) return Count_Type is
+ function Copy_Node (Source : Node_Access) return Node_Access is
begin
- return Container.Length;
- end Length;
+ return new Node_Type'(Element => Source.Element, Next => null);
+ end Copy_Node;
+ ------------
+ -- Delete --
+ ------------
- function Is_Empty (Container : Set) return Boolean is
- begin
- return Container.Length = 0;
- end Is_Empty;
+ procedure Delete
+ (Container : in out Set;
+ Item : Element_Type)
+ is
+ X : Node_Access;
+ begin
+ Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
- procedure Clear (Container : in out Set) renames HT_Ops.Clear;
+ if X = null then
+ raise Constraint_Error;
+ end if;
+ Free (X);
+ end Delete;
- function Element (Position : Cursor) return Element_Type is
+ procedure Delete
+ (Container : in out Set;
+ Position : in out Cursor)
+ is
begin
- return Position.Node.Element;
- end Element;
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+ if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ raise Program_Error;
+ end if;
- procedure Query_Element
- (Position : in Cursor;
- Process : not null access procedure (Element : in Element_Type)) is
- begin
- Process (Position.Node.Element);
- end Query_Element;
+ if Container.HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+ HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
--- TODO:
--- procedure Replace_Element (Container : in out Set;
--- Position : in Node_Access;
--- By : in Element_Type) is
+ Free (Position.Node);
--- Node : Node_Access := Position;
+ Position.Container := null;
+ end Delete;
--- begin
+ ----------------
+ -- Difference --
+ ----------------
--- if Equivalent_Keys (Node.Element, By) then
+ procedure Difference
+ (Target : in out Set;
+ Source : Set)
+ is
+ Tgt_Node : Node_Access;
--- begin
--- Node.Element := By;
--- exception
--- when others =>
--- HT_Ops.Delete_Node_Sans_Free (Container, Node);
--- Free (Node);
--- raise;
--- end;
+ begin
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
--- return;
+ if Source.Length = 0 then
+ return;
+ end if;
--- end if;
+ if Target.HT.Busy > 0 then
+ raise Program_Error;
+ end if;
--- HT_Ops.Delete_Node_Sans_Free (Container, Node);
+ -- TODO: This can be written in terms of a loop instead as
+ -- active-iterator style, sort of like a passive iterator.
--- begin
--- Node.Element := By;
--- exception
--- when others =>
--- Free (Node);
--- raise;
--- end;
+ Tgt_Node := HT_Ops.First (Target.HT);
+ while Tgt_Node /= null loop
+ if Is_In (Source.HT, Tgt_Node) then
+ declare
+ X : Node_Access := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
+ Free (X);
+ end;
--- declare
--- function New_Node (Next : Node_Access) return Node_Access;
--- pragma Inline (New_Node);
+ else
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+ end if;
+ end loop;
+ end Difference;
--- function New_Node (Next : Node_Access) return Node_Access is
--- begin
--- Node.Next := Next;
--- return Node;
--- end New_Node;
+ function Difference (Left, Right : Set) return Set is
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
--- procedure Insert is
--- new Element_Keys.Generic_Conditional_Insert (New_Node);
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
--- Result : Node_Access;
--- Success : Boolean;
--- begin
--- Insert
--- (HT => Container,
--- Key => Node.Element,
--- Node => Result,
--- Success => Success);
+ if Left.Length = 0 then
+ return Empty_Set;
+ end if;
--- if not Success then
--- Free (Node);
--- raise Program_Error;
--- end if;
+ if Right.Length = 0 then
+ return Left;
+ end if;
--- pragma Assert (Result = Node);
--- end;
+ declare
+ Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
--- end Replace_Element;
+ Length := 0;
+ Iterate_Left : declare
+ procedure Process (L_Node : Node_Access);
--- procedure Replace_Element (Container : in out Set;
--- Position : in Cursor;
--- By : in Element_Type) is
--- begin
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
--- if Position.Container = null then
--- raise Constraint_Error;
--- end if;
+ -------------
+ -- Process --
+ -------------
--- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
--- raise Program_Error;
--- end if;
+ procedure Process (L_Node : Node_Access) is
+ begin
+ if not Is_In (Right.HT, L_Node) then
+ declare
+ J : constant Hash_Type :=
+ Hash (L_Node.Element) mod Buckets'Length;
--- Replace_Element (Container, Position.Node, By);
+ Bucket : Node_Access renames Buckets (J);
--- end Replace_Element;
+ begin
+ Bucket := new Node_Type'(L_Node.Element, Bucket);
+ end;
+ Length := Length + 1;
+ end if;
+ end Process;
- procedure Move (Target : in out Set;
- Source : in out Set) renames HT_Ops.Move;
+ -- Start of processing for Iterate_Left
+ begin
+ Iterate (Left.HT);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end Iterate_Left;
- procedure Insert (Container : in out Set;
- New_Item : in Element_Type;
- Position : out Cursor;
- Inserted : out Boolean) is
+ return (Controlled with HT => (Buckets, Length, 0, 0));
+ end Difference;
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
+ -------------
+ -- Element --
+ -------------
- function New_Node (Next : Node_Access) return Node_Access is
- Node : constant Node_Access := new Node_Type'(New_Item, Next);
- begin
- return Node;
- end New_Node;
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Position.Node.Element;
+ end Element;
- procedure Insert is
- new Element_Keys.Generic_Conditional_Insert (New_Node);
+ ---------------------
+ -- Equivalent_Sets --
+ ---------------------
+ function Equivalent_Sets (Left, Right : Set) return Boolean is
begin
+ return Is_Equivalent (Left.HT, Right.HT);
+ end Equivalent_Sets;
- HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
- Insert (Container, New_Item, Position.Node, Inserted);
- Position.Container := Container'Unchecked_Access;
+ -------------------------
+ -- Equivalent_Elements --
+ -------------------------
- end Insert;
+ function Equivalent_Elements (Left, Right : Cursor)
+ return Boolean is
+ begin
+ return Equivalent_Elements (Left.Node.Element, Right.Node.Element);
+ end Equivalent_Elements;
+ function Equivalent_Elements (Left : Cursor; Right : Element_Type)
+ return Boolean is
+ begin
+ return Equivalent_Elements (Left.Node.Element, Right);
+ end Equivalent_Elements;
- procedure Insert (Container : in out Set;
- New_Item : in Element_Type) is
+ function Equivalent_Elements (Left : Element_Type; Right : Cursor)
+ return Boolean is
+ begin
+ return Equivalent_Elements (Left, Right.Node.Element);
+ end Equivalent_Elements;
- Position : Cursor;
- Inserted : Boolean;
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
+ function Equivalent_Keys (Key : Element_Type; Node : Node_Access)
+ return Boolean is
begin
+ return Equivalent_Elements (Key, Node.Element);
+ end Equivalent_Keys;
- Insert (Container, New_Item, Position, Inserted);
+ -------------
+ -- Exclude --
+ -------------
- if not Inserted then
- raise Constraint_Error;
- end if;
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type)
+ is
+ X : Node_Access;
+ begin
+ Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
+ Free (X);
+ end Exclude;
- end Insert;
+ --------------
+ -- Finalize --
+ --------------
+ procedure Finalize (Container : in out Set) is
+ begin
+ HT_Ops.Finalize (Container.HT);
+ end Finalize;
- procedure Replace (Container : in out Set;
- New_Item : in Element_Type) is
+ ----------
+ -- Find --
+ ----------
- X : Node_Access := Element_Keys.Find (Container, New_Item);
+ function Find
+ (Container : Set;
+ Item : Element_Type) return Cursor
+ is
+ Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
begin
-
- if X = null then
- raise Constraint_Error;
+ if Node = null then
+ return No_Element;
end if;
- X.Element := New_Item;
-
- end Replace;
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
+ --------------------
+ -- Find_Equal_Key --
+ --------------------
- procedure Include (Container : in out Set;
- New_Item : in Element_Type) is
+ function Find_Equal_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean
+ is
+ R_Index : constant Hash_Type :=
+ Element_Keys.Index (R_HT, L_Node.Element);
- Position : Cursor;
- Inserted : Boolean;
+ R_Node : Node_Access := R_HT.Buckets (R_Index);
begin
+ loop
+ if R_Node = null then
+ return False;
+ end if;
- Insert (Container, New_Item, Position, Inserted);
-
- if not Inserted then
- Position.Node.Element := New_Item;
- end if;
+ if L_Node.Element = R_Node.Element then
+ return True;
+ end if;
- end Include;
+ R_Node := Next (R_Node);
+ end loop;
+ end Find_Equal_Key;
+ -------------------------
+ -- Find_Equivalent_Key --
+ -------------------------
- procedure Delete (Container : in out Set;
- Item : in Element_Type) is
+ function Find_Equivalent_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean
+ is
+ R_Index : constant Hash_Type :=
+ Element_Keys.Index (R_HT, L_Node.Element);
- X : Node_Access;
+ R_Node : Node_Access := R_HT.Buckets (R_Index);
begin
+ loop
+ if R_Node = null then
+ return False;
+ end if;
- Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
+ if Equivalent_Elements (L_Node.Element, R_Node.Element) then
+ return True;
+ end if;
- if X = null then
- raise Constraint_Error;
- end if;
+ R_Node := Next (R_Node);
+ end loop;
+ end Find_Equivalent_Key;
- Free (X);
+ -----------
+ -- First --
+ -----------
- end Delete;
+ function First (Container : Set) return Cursor is
+ Node : constant Node_Access := HT_Ops.First (Container.HT);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
- procedure Exclude (Container : in out Set;
- Item : in Element_Type) is
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end First;
- X : Node_Access;
+ -----------------
+ -- Has_Element --
+ -----------------
+ function Has_Element (Position : Cursor) return Boolean is
begin
+ if Position.Node = null then
+ pragma Assert (Position.Container = null);
+ return False;
+ end if;
- Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
- Free (X);
-
- end Exclude;
+ return True;
+ end Has_Element;
+ ---------------
+ -- Hash_Node --
+ ---------------
- procedure Delete (Container : in out Set;
- Position : in out Cursor) is
+ function Hash_Node (Node : Node_Access) return Hash_Type is
begin
+ return Hash (Node.Element);
+ end Hash_Node;
- if Position = No_Element then
- return;
- end if;
+ -------------
+ -- Include --
+ -------------
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
- raise Program_Error;
+ procedure Include
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ if Container.HT.Lock > 0 then
+ raise Program_Error;
+ end if;
+
+ Position.Node.Element := New_Item;
end if;
+ end Include;
- HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
- Free (Position.Node);
+ ------------
+ -- Insert --
+ ------------
- Position.Container := null;
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
- end Delete;
+ procedure Local_Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
+ --------------
+ -- New_Node --
+ --------------
+ function New_Node (Next : Node_Access) return Node_Access is
+ Node : constant Node_Access := new Node_Type'(New_Item, Next);
+ begin
+ return Node;
+ end New_Node;
- procedure Union (Target : in out Set;
- Source : in Set) is
+ HT : Hash_Table_Type renames Container.HT;
- procedure Process (Src_Node : in Node_Access);
+ -- Start of processing for Insert
- procedure Process (Src_Node : in Node_Access) is
+ begin
+ if HT.Length >= HT_Ops.Capacity (HT) then
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
+ -- TODO:
+ -- Perform the insertion first, and then reserve
+ -- capacity, but only if the insertion succeeds and
+ -- the (new) length is greater then current capacity.
+ -- END TODO.
- function New_Node (Next : Node_Access) return Node_Access is
- Node : constant Node_Access :=
- new Node_Type'(Src_Node.Element, Next);
- begin
- return Node;
- end New_Node;
+ HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
+ end if;
- procedure Insert is
- new Element_Keys.Generic_Conditional_Insert (New_Node);
+ Local_Insert (HT, New_Item, Position.Node, Inserted);
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
- Tgt_Node : Node_Access;
- Success : Boolean;
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
- begin
+ begin
+ Insert (Container, New_Item, Position, Inserted);
- Insert (Target, Src_Node.Element, Tgt_Node, Success);
+ if not Inserted then
+ raise Constraint_Error;
+ end if;
+ end Insert;
- end Process;
+ ------------------
+ -- Intersection --
+ ------------------
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ procedure Intersection
+ (Target : in out Set;
+ Source : Set)
+ is
+ Tgt_Node : Node_Access;
begin
-
if Target'Address = Source'Address then
return;
end if;
- HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
-
- Iterate (Source);
+ if Source.Length = 0 then
+ Clear (Target);
+ return;
+ end if;
- end Union;
+ if Target.HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+ -- TODO: optimize this to use an explicit
+ -- loop instead of an active iterator
+ -- (similar to how a passive iterator is
+ -- implemented).
+ --
+ -- Another possibility is to test which
+ -- set is smaller, and iterate over the
+ -- smaller set.
+ Tgt_Node := HT_Ops.First (Target.HT);
+ while Tgt_Node /= null loop
+ if Is_In (Source.HT, Tgt_Node) then
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
- function Union (Left, Right : Set) return Set is
+ else
+ declare
+ X : Node_Access := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
+ Free (X);
+ end;
+ end if;
+ end loop;
+ end Intersection;
+ function Intersection (Left, Right : Set) return Set is
Buckets : HT_Types.Buckets_Access;
Length : Count_Type;
begin
-
if Left'Address = Right'Address then
return Left;
end if;
- if Right.Length = 0 then
- return Left;
- end if;
+ Length := Count_Type'Min (Left.Length, Right.Length);
- if Left.Length = 0 then
- return Right;
+ if Length = 0 then
+ return Empty_Set;
end if;
declare
- Size : constant Hash_Type :=
- Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
begin
Buckets := new Buckets_Type (0 .. Size - 1);
end;
- declare
- procedure Process (L_Node : Node_Access);
+ Length := 0;
- procedure Process (L_Node : Node_Access) is
- I : constant Hash_Type :=
- Hash (L_Node.Element) mod Buckets'Length;
- begin
- Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
- end Process;
+ Iterate_Left : declare
+ procedure Process (L_Node : Node_Access);
procedure Iterate is
new HT_Ops.Generic_Iteration (Process);
- begin
- Iterate (Left);
- exception
- when others =>
- HT_Ops.Free_Hash_Table (Buckets);
- raise;
- end;
-
- Length := Left.Length;
-
- declare
- procedure Process (Src_Node : Node_Access);
-
- procedure Process (Src_Node : Node_Access) is
-
- I : constant Hash_Type :=
- Hash (Src_Node.Element) mod Buckets'Length;
- Tgt_Node : Node_Access := Buckets (I);
+ -------------
+ -- Process --
+ -------------
+ procedure Process (L_Node : Node_Access) is
begin
+ if Is_In (Right.HT, L_Node) then
+ declare
+ J : constant Hash_Type :=
+ Hash (L_Node.Element) mod Buckets'Length;
- while Tgt_Node /= null loop
-
- if Equivalent_Keys (Src_Node.Element, Tgt_Node.Element) then
- return;
- end if;
-
- Tgt_Node := Next (Tgt_Node);
+ Bucket : Node_Access renames Buckets (J);
- end loop;
-
- Buckets (I) := new Node_Type'(Src_Node.Element, Buckets (I));
- Length := Length + 1;
+ begin
+ Bucket := new Node_Type'(L_Node.Element, Bucket);
+ end;
+ Length := Length + 1;
+ end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ -- Start of processing for Iterate_Left
+
begin
- Iterate (Right);
+ Iterate (Left.HT);
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
raise;
- end;
+ end Iterate_Left;
- return (Controlled with Buckets, Length);
+ return (Controlled with HT => (Buckets, Length, 0, 0));
+ end Intersection;
- end Union;
+ --------------
+ -- Is_Empty --
+ --------------
+ function Is_Empty (Container : Set) return Boolean is
+ begin
+ return Container.Length = 0;
+ end Is_Empty;
- function Is_In
- (HT : Set;
- Key : Node_Access) return Boolean;
- pragma Inline (Is_In);
+ -----------
+ -- Is_In --
+ -----------
- function Is_In
- (HT : Set;
- Key : Node_Access) return Boolean is
+ function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
begin
return Element_Keys.Find (HT, Key.Element) /= null;
end Is_In;
+ ---------------
+ -- Is_Subset --
+ ---------------
- procedure Intersection (Target : in out Set;
- Source : in Set) is
-
- Tgt_Node : Node_Access;
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
+ Subset_Node : Node_Access;
begin
-
- if Target'Address = Source'Address then
- return;
+ if Subset'Address = Of_Set'Address then
+ return True;
end if;
- if Source.Length = 0 then
- Clear (Target);
- return;
+ if Subset.Length > Of_Set.Length then
+ return False;
end if;
- -- TODO: optimize this to use an explicit
- -- loop instead of an active iterator
- -- (similar to how a passive iterator is
- -- implemented).
- --
- -- Another possibility is to test which
- -- set is smaller, and iterate over the
- -- smaller set.
+ -- TODO: rewrite this to loop in the
+ -- style of a passive iterator.
- Tgt_Node := HT_Ops.First (Target);
+ Subset_Node := HT_Ops.First (Subset.HT);
+ while Subset_Node /= null loop
+ if not Is_In (Of_Set.HT, Subset_Node) then
+ return False;
+ end if;
+ Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
+ end loop;
- while Tgt_Node /= null loop
+ return True;
+ end Is_Subset;
- if Is_In (Source, Tgt_Node) then
+ -------------
+ -- Iterate --
+ -------------
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
- else
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process_Node);
- declare
- X : Node_Access := Tgt_Node;
- begin
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target, X);
- Free (X);
- end;
+ ------------------
+ -- Process_Node --
+ ------------------
- end if;
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ end Process_Node;
- end loop;
+ HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
+ B : Natural renames HT.Busy;
- end Intersection;
+ -- Start of processing for Iterate
+ begin
+ B := B + 1;
- function Intersection (Left, Right : Set) return Set is
+ begin
+ Iterate (HT);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
- Buckets : HT_Types.Buckets_Access;
- Length : Count_Type;
+ B := B - 1;
+ end Iterate;
+
+ ------------
+ -- Length --
+ ------------
+ function Length (Container : Set) return Count_Type is
begin
+ return Container.HT.Length;
+ end Length;
- if Left'Address = Right'Address then
- return Left;
- end if;
+ ----------
+ -- Move --
+ ----------
- Length := Count_Type'Min (Left.Length, Right.Length);
+ procedure Move (Target : in out Set; Source : in out Set) is
+ begin
+ HT_Ops.Move (Target => Target.HT, Source => Source.HT);
+ end Move;
- if Length = 0 then
- return Empty_Set;
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Next;
+ end Next;
+
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position.Node = null then
+ pragma Assert (Position.Container = null);
+ return No_Element;
end if;
declare
- Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
+ HT : Hash_Table_Type renames Position.Container.HT;
+ Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
+
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
end;
+ end Next;
+
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
+
+ -------------
+ -- Overlap --
+ -------------
+
+ function Overlap (Left, Right : Set) return Boolean is
+ Left_Node : Node_Access;
+
+ begin
+ if Right.Length = 0 then
+ return False;
+ end if;
+
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ Left_Node := HT_Ops.First (Left.HT);
+ while Left_Node /= null loop
+ if Is_In (Right.HT, Left_Node) then
+ return True;
+ end if;
+ Left_Node := HT_Ops.Next (Left.HT, Left_Node);
+ end loop;
- Length := 0;
+ return False;
+ end Overlap;
- declare
- procedure Process (L_Node : Node_Access);
+ -------------------
+ -- Query_Element --
+ -------------------
- procedure Process (L_Node : Node_Access) is
- begin
- if Is_In (Right, L_Node) then
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ E : Element_Type renames Position.Node.Element;
- declare
- I : constant Hash_Type :=
- Hash (L_Node.Element) mod Buckets'Length;
- begin
- Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
- end;
+ HT : Hash_Table_Type renames Position.Container.HT;
- Length := Length + 1;
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
- end if;
- end Process;
+ begin
+ B := B + 1;
+ L := L + 1;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
begin
- Iterate (Left);
+ Process (E);
exception
when others =>
- HT_Ops.Free_Hash_Table (Buckets);
+ L := L - 1;
+ B := B - 1;
raise;
end;
- return (Controlled with Buckets, Length);
-
- end Intersection;
+ L := L - 1;
+ B := B - 1;
+ end Query_Element;
+ ----------
+ -- Read --
+ ----------
- procedure Difference (Target : in out Set;
- Source : in Set) is
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Set)
+ is
+ begin
+ Read_Nodes (Stream, Container.HT);
+ end Read;
+ ---------------
+ -- Read_Node --
+ ---------------
- Tgt_Node : Node_Access;
+ function Read_Node (Stream : access Root_Stream_Type'Class)
+ return Node_Access
+ is
+ Node : Node_Access := new Node_Type;
begin
+ Element_Type'Read (Stream, Node.Element);
+ return Node;
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end Read_Node;
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
-
- if Source.Length = 0 then
- return;
- end if;
-
- -- TODO: As I noted above, this can be
- -- written in terms of a loop instead as
- -- active-iterator style, sort of like a
- -- passive iterator.
+ -------------
+ -- Replace --
+ -------------
- Tgt_Node := HT_Ops.First (Target);
+ procedure Replace
+ (Container : in out Set; -- TODO: need ruling from ARG
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access :=
+ Element_Keys.Find (Container.HT, New_Item);
- while Tgt_Node /= null loop
+ begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
- if Is_In (Source, Tgt_Node) then
+ if Container.HT.Lock > 0 then
+ raise Program_Error;
+ end if;
- declare
- X : Node_Access := Tgt_Node;
- begin
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target, X);
- Free (X);
- end;
+ Node.Element := New_Item;
+ end Replace;
- else
+ ---------------------
+ -- Replace_Element --
+ ---------------------
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ procedure Replace_Element
+ (HT : in out Hash_Table_Type;
+ Node : Node_Access;
+ Element : Element_Type)
+ is
+ begin
+ if Equivalent_Elements (Node.Element, Element) then
+ pragma Assert (Hash (Node.Element) = Hash (Element));
+ if HT.Lock > 0 then
+ raise Program_Error;
end if;
- end loop;
-
- end Difference;
+ Node.Element := Element; -- Note that this assignment can fail
+ return;
+ end if;
+ if HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+ HT_Ops.Delete_Node_Sans_Free (HT, Node);
- function Difference (Left, Right : Set) return Set is
+ Insert_New_Element : declare
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
- Buckets : HT_Types.Buckets_Access;
- Length : Count_Type;
+ procedure Local_Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
- begin
+ --------------
+ -- New_Node --
+ --------------
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
+ function New_Node (Next : Node_Access) return Node_Access is
+ begin
+ Node.Element := Element; -- Note that this assignment can fail
+ Node.Next := Next;
+ return Node;
+ end New_Node;
- if Left.Length = 0 then
- return Empty_Set;
- end if;
+ Result : Node_Access;
+ Inserted : Boolean;
- if Right.Length = 0 then
- return Left;
- end if;
+ -- Start of processing for Insert_New_Element
- declare
- Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
- end;
+ Local_Insert
+ (HT => HT,
+ Key => Element,
+ Node => Result,
+ Inserted => Inserted);
+
+ if Inserted then
+ pragma Assert (Result = Node);
+ return;
+ end if;
+ exception
+ when others =>
+ null; -- Assignment must have failed
+ end Insert_New_Element;
- Length := 0;
+ Reinsert_Old_Element : declare
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
- declare
- procedure Process (L_Node : Node_Access);
+ procedure Local_Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
- procedure Process (L_Node : Node_Access) is
- begin
- if not Is_In (Right, L_Node) then
+ --------------
+ -- New_Node --
+ --------------
- declare
- I : constant Hash_Type :=
- Hash (L_Node.Element) mod Buckets'Length;
- begin
- Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
- end;
+ function New_Node (Next : Node_Access) return Node_Access is
+ begin
+ Node.Next := Next;
+ return Node;
+ end New_Node;
- Length := Length + 1;
+ Result : Node_Access;
+ Inserted : Boolean;
- end if;
- end Process;
+ -- Start of processing for Reinsert_Old_Element
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
begin
- Iterate (Left);
+ Local_Insert
+ (HT => HT,
+ Key => Node.Element,
+ Node => Result,
+ Inserted => Inserted);
exception
when others =>
- HT_Ops.Free_Hash_Table (Buckets);
- raise;
- end;
+ null;
+ end Reinsert_Old_Element;
- return (Controlled with Buckets, Length);
+ raise Program_Error;
+ end Replace_Element;
- end Difference;
+ procedure Replace_Element
+ (Container : Set;
+ Position : Cursor;
+ By : Element_Type)
+ is
+ HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
+
+ begin
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Set_Access'(Container'Unrestricted_Access) then
+ raise Program_Error;
+ end if;
+
+ Replace_Element (HT, Position.Node, By);
+ end Replace_Element;
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ procedure Reserve_Capacity
+ (Container : in out Set;
+ Capacity : Count_Type)
+ is
+ begin
+ HT_Ops.Reserve_Capacity (Container.HT, Capacity);
+ end Reserve_Capacity;
+ --------------
+ -- Set_Next --
+ --------------
- procedure Symmetric_Difference (Target : in out Set;
- Source : in Set) is
+ procedure Set_Next (Node : Node_Access; Next : Node_Access) is
begin
+ Node.Next := Next;
+ end Set_Next;
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Symmetric_Difference
+ (Target : in out Set;
+ Source : Set)
+ is
+ begin
if Target'Address = Source'Address then
Clear (Target);
return;
end if;
- HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
+ if Target.HT.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ declare
+ N : constant Count_Type := Target.Length + Source.Length;
+ begin
+ if N > HT_Ops.Capacity (Target.HT) then
+ HT_Ops.Reserve_Capacity (Target.HT, N);
+ end if;
+ end;
if Target.Length = 0 then
-
- declare
+ Iterate_Source_When_Empty_Target : declare
procedure Process (Src_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (Src_Node : Node_Access) is
E : Element_Type renames Src_Node.Element;
- B : Buckets_Type renames Target.Buckets.all;
- I : constant Hash_Type := Hash (E) mod B'Length;
- N : Count_Type renames Target.Length;
+ B : Buckets_Type renames Target.HT.Buckets.all;
+ J : constant Hash_Type := Hash (E) mod B'Length;
+ N : Count_Type renames Target.HT.Length;
+
begin
- B (I) := new Node_Type'(E, B (I));
+ B (J) := new Node_Type'(E, B (J));
N := N + 1;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ -- Start of processing for Iterate_Source_When_Empty_Target
+
begin
- Iterate (Source);
- end;
+ Iterate (Source.HT);
+ end Iterate_Source_When_Empty_Target;
else
-
- declare
+ Iterate_Source : declare
procedure Process (Src_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (Src_Node : Node_Access) is
E : Element_Type renames Src_Node.Element;
- B : Buckets_Type renames Target.Buckets.all;
- I : constant Hash_Type := Hash (E) mod B'Length;
- N : Count_Type renames Target.Length;
- begin
- if B (I) = null then
+ B : Buckets_Type renames Target.HT.Buckets.all;
+ J : constant Hash_Type := Hash (E) mod B'Length;
+ N : Count_Type renames Target.HT.Length;
- B (I) := new Node_Type'(E, null);
+ begin
+ if B (J) = null then
+ B (J) := new Node_Type'(E, null);
N := N + 1;
- elsif Equivalent_Keys (E, B (I).Element) then
-
+ elsif Equivalent_Elements (E, B (J).Element) then
declare
- X : Node_Access := B (I);
+ X : Node_Access := B (J);
begin
- B (I) := B (I).Next;
+ B (J) := B (J).Next;
N := N - 1;
Free (X);
end;
else
-
declare
- Prev : Node_Access := B (I);
+ Prev : Node_Access := B (J);
Curr : Node_Access := Prev.Next;
+
begin
while Curr /= null loop
- if Equivalent_Keys (E, Curr.Element) then
+ if Equivalent_Elements (E, Curr.Element) then
Prev.Next := Curr.Next;
N := N - 1;
Free (Curr);
Curr := Prev.Next;
end loop;
- B (I) := new Node_Type'(E, B (I));
+ B (J) := new Node_Type'(E, B (J));
N := N + 1;
end;
-
end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
- begin
- Iterate (Source);
- end;
+ -- Start of processing for Iterate_Source
+ begin
+ Iterate (Source.HT);
+ end Iterate_Source;
end if;
-
end Symmetric_Difference;
-
function Symmetric_Difference (Left, Right : Set) return Set is
-
Buckets : HT_Types.Buckets_Access;
Length : Count_Type;
begin
-
if Left'Address = Right'Address then
return Empty_Set;
end if;
declare
Size : constant Hash_Type :=
- Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ Prime_Numbers.To_Prime (Left.Length + Right.Length);
begin
Buckets := new Buckets_Type (0 .. Size - 1);
end;
Length := 0;
- declare
+ Iterate_Left : declare
procedure Process (L_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (L_Node : Node_Access) is
begin
- if not Is_In (Right, L_Node) then
+ if not Is_In (Right.HT, L_Node) then
declare
E : Element_Type renames L_Node.Element;
- I : constant Hash_Type := Hash (E) mod Buckets'Length;
+ J : constant Hash_Type := Hash (E) mod Buckets'Length;
+
begin
- Buckets (I) := new Node_Type'(E, Buckets (I));
+ Buckets (J) := new Node_Type'(E, Buckets (J));
Length := Length + 1;
end;
end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ -- Start of processing for Iterate_Left
+
begin
- Iterate (Left);
+ Iterate (Left.HT);
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
raise;
- end;
+ end Iterate_Left;
- declare
+ Iterate_Right : declare
procedure Process (R_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (R_Node : Node_Access) is
begin
- if not Is_In (Left, R_Node) then
+ if not Is_In (Left.HT, R_Node) then
declare
E : Element_Type renames R_Node.Element;
- I : constant Hash_Type := Hash (E) mod Buckets'Length;
+ J : constant Hash_Type := Hash (E) mod Buckets'Length;
+
begin
- Buckets (I) := new Node_Type'(E, Buckets (I));
+ Buckets (J) := new Node_Type'(E, Buckets (J));
Length := Length + 1;
end;
end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
- begin
- Iterate (Right);
- exception
- when others =>
- HT_Ops.Free_Hash_Table (Buckets);
- raise;
- end;
-
- return (Controlled with Buckets, Length);
-
- end Symmetric_Difference;
-
-
- function Is_Subset (Subset : Set;
- Of_Set : Set) return Boolean is
-
- Subset_Node : Node_Access;
-
- begin
-
- if Subset'Address = Of_Set'Address then
- return True;
- end if;
-
- if Subset.Length > Of_Set.Length then
- return False;
- end if;
-
- -- TODO: rewrite this to loop in the
- -- style of a passive iterator.
-
- Subset_Node := HT_Ops.First (Subset);
-
- while Subset_Node /= null loop
- if not Is_In (Of_Set, Subset_Node) then
- return False;
- end if;
-
- Subset_Node := HT_Ops.Next (Subset, Subset_Node);
- end loop;
-
- return True;
-
- end Is_Subset;
-
-
- function Overlap (Left, Right : Set) return Boolean is
-
- Left_Node : Node_Access;
-
- begin
-
- if Right.Length = 0 then
- return False;
- end if;
-
- if Left'Address = Right'Address then
- return True;
- end if;
-
- Left_Node := HT_Ops.First (Left);
-
- while Left_Node /= null loop
- if Is_In (Right, Left_Node) then
- return True;
- end if;
-
- Left_Node := HT_Ops.Next (Left, Left_Node);
- end loop;
-
- return False;
-
- end Overlap;
-
-
- function Find (Container : Set;
- Item : Element_Type) return Cursor is
+ -- Start of processing for Iterate_Right
- Node : constant Node_Access := Element_Keys.Find (Container, Item);
+ begin
+ Iterate (Right.HT);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end Iterate_Right;
- begin
+ return (Controlled with HT => (Buckets, Length, 0, 0));
+ end Symmetric_Difference;
- if Node = null then
- return No_Element;
- end if;
+ -----------
+ -- Union --
+ -----------
- return Cursor'(Container'Unchecked_Access, Node);
+ procedure Union
+ (Target : in out Set;
+ Source : Set)
+ is
+ procedure Process (Src_Node : Node_Access);
- end Find;
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ -------------
+ -- Process --
+ -------------
- function Contains (Container : Set;
- Item : Element_Type) return Boolean is
- begin
- return Find (Container, Item) /= No_Element;
- end Contains;
+ procedure Process (Src_Node : Node_Access) is
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
+ --------------
+ -- New_Node --
+ --------------
- function First (Container : Set) return Cursor is
- Node : constant Node_Access := HT_Ops.First (Container);
- begin
- if Node = null then
- return No_Element;
- end if;
+ function New_Node (Next : Node_Access) return Node_Access is
+ Node : constant Node_Access :=
+ new Node_Type'(Src_Node.Element, Next);
+ begin
+ return Node;
+ end New_Node;
- return Cursor'(Container'Unchecked_Access, Node);
- end First;
+ Tgt_Node : Node_Access;
+ Success : Boolean;
+ -- Start of processing for Process
--- function First_Element (Container : Set) return Element_Type is
--- Node : constant Node_Access := HT_Ops.First (Container);
--- begin
--- return Node.Element;
--- end First_Element;
+ begin
+ Insert (Target.HT, Src_Node.Element, Tgt_Node, Success);
+ end Process;
+ -- Start of processing for Union
- function Next (Position : Cursor) return Cursor is
begin
- if Position.Container = null
- or else Position.Node = null
- then
- return No_Element;
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.HT.Busy > 0 then
+ raise Program_Error;
end if;
declare
- S : Set renames Position.Container.all;
- Node : constant Node_Access := HT_Ops.Next (S, Position.Node);
+ N : constant Count_Type := Target.Length + Source.Length;
begin
- if Node = null then
- return No_Element;
+ if N > HT_Ops.Capacity (Target.HT) then
+ HT_Ops.Reserve_Capacity (Target.HT, N);
end if;
-
- return Cursor'(Position.Container, Node);
end;
- end Next;
-
- procedure Next (Position : in out Cursor) is
- begin
- Position := Next (Position);
- end Next;
+ Iterate (Source.HT);
+ end Union;
+ function Union (Left, Right : Set) return Set is
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
- function Has_Element (Position : Cursor) return Boolean is
begin
- if Position.Container = null then
- return False;
+ if Left'Address = Right'Address then
+ return Left;
end if;
- if Position.Node = null then
- return False;
+ if Right.Length = 0 then
+ return Left;
end if;
- return True;
- end Has_Element;
-
-
- function Equivalent_Keys (Left, Right : Cursor)
- return Boolean is
- begin
- return Equivalent_Keys (Left.Node.Element, Right.Node.Element);
- end Equivalent_Keys;
+ if Left.Length = 0 then
+ return Right;
+ end if;
+ declare
+ Size : constant Hash_Type :=
+ Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ begin
+ Buckets := new Buckets_Type (0 .. Size - 1);
+ end;
- function Equivalent_Keys (Left : Cursor;
- Right : Element_Type)
- return Boolean is
- begin
- return Equivalent_Keys (Left.Node.Element, Right);
- end Equivalent_Keys;
+ Iterate_Left : declare
+ procedure Process (L_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
- function Equivalent_Keys (Left : Element_Type;
- Right : Cursor)
- return Boolean is
- begin
- return Equivalent_Keys (Left, Right.Node.Element);
- end Equivalent_Keys;
+ -------------
+ -- Process --
+ -------------
+ procedure Process (L_Node : Node_Access) is
+ J : constant Hash_Type :=
+ Hash (L_Node.Element) mod Buckets'Length;
- procedure Iterate
- (Container : in Set;
- Process : not null access procedure (Position : in Cursor)) is
+ begin
+ Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J));
+ end Process;
- procedure Process_Node (Node : in Node_Access);
- pragma Inline (Process_Node);
+ -- Start of processing for Iterate_Left
- procedure Process_Node (Node : in Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
- end Process_Node;
-
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process_Node);
- begin
- Iterate (Container);
- end Iterate;
+ Iterate (Left.HT);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end Iterate_Left;
+ Length := Left.Length;
- function Capacity (Container : Set) return Count_Type
- renames HT_Ops.Capacity;
+ Iterate_Right : declare
+ procedure Process (Src_Node : Node_Access);
- procedure Reserve_Capacity
- (Container : in out Set;
- Capacity : in Count_Type)
- renames HT_Ops.Ensure_Capacity;
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ -------------
+ -- Process --
+ -------------
- procedure Write_Node
- (Stream : access Root_Stream_Type'Class;
- Node : in Node_Access);
- pragma Inline (Write_Node);
+ procedure Process (Src_Node : Node_Access) is
+ J : constant Hash_Type :=
+ Hash (Src_Node.Element) mod Buckets'Length;
- procedure Write_Node
- (Stream : access Root_Stream_Type'Class;
- Node : in Node_Access) is
- begin
- Element_Type'Write (Stream, Node.Element);
- end Write_Node;
+ Tgt_Node : Node_Access := Buckets (J);
- procedure Write_Nodes is
- new HT_Ops.Generic_Write (Write_Node);
+ begin
+ while Tgt_Node /= null loop
+ if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
+ return;
+ end if;
- procedure Write
- (Stream : access Root_Stream_Type'Class;
- Container : in Set) renames Write_Nodes;
+ Tgt_Node := Next (Tgt_Node);
+ end loop;
+ Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J));
+ Length := Length + 1;
+ end Process;
- function Read_Node (Stream : access Root_Stream_Type'Class)
- return Node_Access;
- pragma Inline (Read_Node);
+ -- Start of processing for Iterate_Right
- function Read_Node (Stream : access Root_Stream_Type'Class)
- return Node_Access is
+ begin
+ Iterate (Right.HT);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end Iterate_Right;
- Node : Node_Access := new Node_Type;
- begin
- Element_Type'Read (Stream, Node.Element);
- return Node;
- exception
- when others =>
- Free (Node);
- raise;
- end Read_Node;
+ return (Controlled with HT => (Buckets, Length, 0, 0));
+ end Union;
- procedure Read_Nodes is
- new HT_Ops.Generic_Read (Read_Node);
+ -----------
+ -- Write --
+ -----------
- procedure Read
+ procedure Write
(Stream : access Root_Stream_Type'Class;
- Container : out Set) renames Read_Nodes;
+ Container : Set)
+ is
+ begin
+ Write_Nodes (Stream, Container.HT);
+ end Write;
+ ----------------
+ -- Write_Node --
+ ----------------
- package body Generic_Keys is
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access)
+ is
+ begin
+ Element_Type'Write (Stream, Node.Element);
+ end Write_Node;
- function Equivalent_Keys (Left : Cursor;
- Right : Key_Type)
- return Boolean is
- begin
- return Equivalent_Keys (Right, Left.Node.Element);
- end Equivalent_Keys;
+ package body Generic_Keys is
- function Equivalent_Keys (Left : Key_Type;
- Right : Cursor)
- return Boolean is
- begin
- return Equivalent_Keys (Left, Right.Node.Element);
- end Equivalent_Keys;
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- function Equivalent_Keys
+ function Equivalent_Key_Node
(Key : Key_Type;
Node : Node_Access) return Boolean;
- pragma Inline (Equivalent_Keys);
+ pragma Inline (Equivalent_Key_Node);
- function Equivalent_Keys
- (Key : Key_Type;
- Node : Node_Access) return Boolean is
- begin
- return Equivalent_Keys (Key, Node.Element);
- end Equivalent_Keys;
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
package Key_Keys is
new Hash_Tables.Generic_Keys
(HT_Types => HT_Types,
- HT_Type => Set,
- Null_Node => null,
Next => Next,
Set_Next => Set_Next,
Key_Type => Key_Type,
Hash => Hash,
- Equivalent_Keys => Equivalent_Keys);
-
+ Equivalent_Keys => Equivalent_Key_Node);
- function Find (Container : Set;
- Key : Key_Type)
- return Cursor is
-
- Node : constant Node_Access :=
- Key_Keys.Find (Container, Key);
+ --------------
+ -- Contains --
+ --------------
+ function Contains
+ (Container : Set;
+ Key : Key_Type) return Boolean
+ is
begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
- if Node = null then
- return No_Element;
- end if;
+ ------------
+ -- Delete --
+ ------------
- return Cursor'(Container'Unchecked_Access, Node);
+ procedure Delete
+ (Container : in out Set;
+ Key : Key_Type)
+ is
+ X : Node_Access;
- end Find;
+ begin
+ Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
+ if X = null then
+ raise Constraint_Error;
+ end if;
- function Contains (Container : Set;
- Key : Key_Type) return Boolean is
- begin
- return Find (Container, Key) /= No_Element;
- end Contains;
+ Free (X);
+ end Delete;
+ -------------
+ -- Element --
+ -------------
- function Element (Container : Set;
- Key : Key_Type)
- return Element_Type is
+ function Element
+ (Container : Set;
+ Key : Key_Type) return Element_Type
+ is
+ Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
- Node : constant Node_Access := Key_Keys.Find (Container, Key);
begin
return Node.Element;
end Element;
+ -------------------------
+ -- Equivalent_Key_Node --
+ -------------------------
- function Key (Position : Cursor) return Key_Type is
+ function Equivalent_Key_Node
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean
+ is
begin
- return Key (Position.Node.Element);
- end Key;
-
-
--- TODO:
--- procedure Replace (Container : in out Set;
--- Key : in Key_Type;
--- New_Item : in Element_Type) is
-
--- Node : constant Node_Access :=
--- Key_Keys.Find (Container, Key);
-
--- begin
-
--- if Node = null then
--- raise Constraint_Error;
--- end if;
+ return Equivalent_Keys (Key, Node.Element);
+ end Equivalent_Key_Node;
--- Replace_Element (Container, Node, New_Item);
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
--- end Replace;
+ function Equivalent_Keys
+ (Left : Cursor;
+ Right : Key_Type) return Boolean is
+ begin
+ return Equivalent_Keys (Right, Left.Node.Element);
+ end Equivalent_Keys;
+ function Equivalent_Keys
+ (Left : Key_Type;
+ Right : Cursor) return Boolean is
+ begin
+ return Equivalent_Keys (Left, Right.Node.Element);
+ end Equivalent_Keys;
- procedure Delete (Container : in out Set;
- Key : in Key_Type) is
+ -------------
+ -- Exclude --
+ -------------
+ procedure Exclude
+ (Container : in out Set;
+ Key : Key_Type)
+ is
X : Node_Access;
-
begin
+ Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
+ Free (X);
+ end Exclude;
- Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
+ ----------
+ -- Find --
+ ----------
- if X = null then
- raise Constraint_Error;
+ function Find
+ (Container : Set;
+ Key : Key_Type) return Cursor
+ is
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container.HT, Key);
+
+ begin
+ if Node = null then
+ return No_Element;
end if;
- Free (X);
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
- end Delete;
+ ---------
+ -- Key --
+ ---------
+ function Key (Position : Cursor) return Key_Type is
+ begin
+ return Key (Position.Node.Element);
+ end Key;
- procedure Exclude (Container : in out Set;
- Key : in Key_Type) is
+ -------------
+ -- Replace --
+ -------------
- X : Node_Access;
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container.HT, Key);
begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
- Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
- Free (X);
-
- end Exclude;
+ Replace_Element (Container.HT, Node, New_Item);
+ end Replace;
+ -----------------------------------
+ -- Update_Element_Preserving_Key --
+ -----------------------------------
- procedure Checked_Update_Element
+ procedure Update_Element_Preserving_Key
(Container : in out Set;
- Position : in Cursor;
+ Position : Cursor;
Process : not null access
- procedure (Element : in out Element_Type)) is
+ procedure (Element : in out Element_Type))
+ is
+ HT : Hash_Table_Type renames Container.HT;
begin
-
- if Position.Container = null then
+ if Position.Node = null then
raise Constraint_Error;
end if;
end if;
declare
- Old_Key : Key_Type renames Key (Position.Node.Element);
- begin
- Process (Position.Node.Element);
-
- if Equivalent_Keys (Old_Key, Position.Node.Element) then
- return;
- end if;
- end;
-
- declare
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
+ E : Element_Type renames Position.Node.Element;
+ K : Key_Type renames Key (E);
- function New_Node (Next : Node_Access) return Node_Access is
- begin
- Position.Node.Next := Next;
- return Position.Node;
- end New_Node;
-
- procedure Insert is
- new Key_Keys.Generic_Conditional_Insert (New_Node);
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
- Result : Node_Access;
- Success : Boolean;
begin
- HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ B := B + 1;
+ L := L + 1;
- Insert
- (HT => Container,
- Key => Key (Position.Node.Element),
- Node => Result,
- Success => Success);
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
- if not Success then
- declare
- X : Node_Access := Position.Node;
- begin
- Free (X);
- end;
+ L := L - 1;
+ B := B - 1;
- raise Program_Error;
+ if Equivalent_Keys (K, E) then
+ pragma Assert (Hash (K) = Hash (E));
+ return;
end if;
+ end;
- pragma Assert (Result = Position.Node);
+ declare
+ X : Node_Access := Position.Node;
+ begin
+ HT_Ops.Delete_Node_Sans_Free (HT, X);
+ Free (X);
end;
- end Checked_Update_Element;
+ raise Program_Error;
+ end Update_Element_Preserving_Key;
end Generic_Keys;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.HASHED_SETS --
+-- A D A . C O N T A I N E R S . H A S H E D _ S E T S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Containers.Hash_Tables;
with Ada.Streams;
+with Ada.Finalization;
generic
type Element_Type is private;
with function Hash (Element : Element_Type) return Hash_Type;
- -- TODO: get a ruling from ARG in Atlanta re the name and
- -- order of these declarations. ???
- --
- with function Equivalent_Keys (Left, Right : Element_Type) return Boolean;
+ with function Equivalent_Elements (Left, Right : Element_Type)
+ return Boolean;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
function "=" (Left, Right : Set) return Boolean;
+ function Equivalent_Sets (Left, Right : Set) return Boolean;
+
function Length (Container : Set) return Count_Type;
function Is_Empty (Container : Set) return Boolean;
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
- -- TODO: resolve in atlanta
- -- procedure Replace_Element
- -- (Container : in out Set;
- -- Position : Cursor;
- -- By : Element_Type);
+ procedure Replace_Element
+ (Container : Set;
+ Position : Cursor;
+ By : Element_Type);
procedure Move (Target : in out Set; Source : in out Set);
procedure Delete (Container : in out Set; Item : Element_Type);
+ procedure Delete (Container : in out Set; Position : in out Cursor);
+
procedure Exclude (Container : in out Set; Item : Element_Type);
- procedure Delete (Container : in out Set; Position : in out Cursor);
+ function Contains (Container : Set; Item : Element_Type) return Boolean;
+
+ function Find
+ (Container : Set;
+ Item : Element_Type) return Cursor;
+
+ function First (Container : Set) return Cursor;
+
+ function Next (Position : Cursor) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ function Equivalent_Elements (Left, Right : Cursor) return Boolean;
+
+ function Equivalent_Elements
+ (Left : Cursor;
+ Right : Element_Type) return Boolean;
+
+ function Equivalent_Elements
+ (Left : Element_Type;
+ Right : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor));
procedure Union (Target : in out Set; Source : Set);
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
- function Contains (Container : Set; Item : Element_Type) return Boolean;
-
- function Find
- (Container : Set;
- Item : Element_Type) return Cursor;
-
function Capacity (Container : Set) return Count_Type;
procedure Reserve_Capacity
(Container : in out Set;
Capacity : Count_Type);
- function First (Container : Set) return Cursor;
-
- function Next (Position : Cursor) return Cursor;
-
- procedure Next (Position : in out Cursor);
-
- function Has_Element (Position : Cursor) return Boolean;
-
- function Equivalent_Keys (Left, Right : Cursor) return Boolean;
-
- function Equivalent_Keys
- (Left : Cursor;
- Right : Element_Type) return Boolean;
-
- function Equivalent_Keys
- (Left : Element_Type;
- Right : Cursor) return Boolean;
-
- procedure Iterate
- (Container : Set;
- Process : not null access procedure (Position : Cursor));
-
generic
type Key_Type (<>) is limited private;
function Element (Container : Set; Key : Key_Type) return Element_Type;
- -- TODO: resolve in atlanta
- -- procedure Replace
- -- (Container : in out Set;
- -- Key : Key_Type;
- -- New_Item : Element_Type);
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
- -- TODO: resolve name in atlanta: ???
- procedure Checked_Update_Element
+ procedure Update_Element_Preserving_Key
(Container : in out Set;
Position : Cursor;
Process : not null access
type Node_Type;
type Node_Access is access Node_Type;
- package HT_Types is
- new Hash_Tables.Generic_Hash_Table_Types (Node_Access);
+ type Node_Type is
+ limited record
+ Element : Element_Type;
+ Next : Node_Access;
+ end record;
- use HT_Types;
+ package HT_Types is new Hash_Tables.Generic_Hash_Table_Types
+ (Node_Type,
+ Node_Access);
- type Set is new Hash_Table_Type with null record;
+ type Set is new Ada.Finalization.Controlled with record
+ HT : HT_Types.Hash_Table_Type;
+ end record;
procedure Adjust (Container : in out Set);
procedure Finalize (Container : in out Set);
- type Set_Access is access constant Set;
+ use HT_Types;
+ use Ada.Finalization;
+
+ type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
- type Cursor is record
- Container : Set_Access;
- Node : Node_Access;
- end record;
+ type Cursor is
+ record
+ Container : Set_Access;
+ Node : Node_Access;
+ end record;
No_Element : constant Cursor := (Container => null, Node => null);
for Set'Read use Read;
- Empty_Set : constant Set := (Hash_Table_Type with null record);
+ Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0));
end Ada.Containers.Hashed_Sets;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.HASH_TABLES --
+-- A D A . C O N T A I N E R S . H A S H _ T A B L E S --
-- --
-- S p e c --
-- --
--- This specification is adapted from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT 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. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; 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. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with Ada.Finalization;
-
package Ada.Containers.Hash_Tables is
pragma Preelaborate;
generic
- type Node_Access is private;
+ type Node_Type (<>) is limited private;
+
+ type Node_Access is access Node_Type;
package Generic_Hash_Table_Types is
type Buckets_Type is array (Hash_Type range <>) of Node_Access;
type Buckets_Access is access Buckets_Type;
- type Hash_Table_Type is new Ada.Finalization.Controlled with record
+ type Hash_Table_Type is tagged record
Buckets : Buckets_Access;
Length : Count_Type := 0;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
end record;
end Generic_Hash_Table_Types;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_VECTORS --
+-- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
package body Ada.Containers.Indefinite_Vectors is
-
type Int is range System.Min_Int .. System.Max_Int;
procedure Free is
- new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
+ new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
procedure Free is
- new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
-
-
- procedure Adjust (Container : in out Vector) is
- begin
-
- if Container.Elements = null then
- return;
- end if;
-
- if Container.Elements'Length = 0
- or else Container.Last < Index_Type'First
- then
- Container.Elements := null;
- return;
- end if;
-
- declare
- E : Elements_Type renames Container.Elements.all;
- L : constant Index_Type := Container.Last;
- begin
-
- Container.Elements := null;
- Container.Last := Index_Type'Pred (Index_Type'First);
-
- Container.Elements := new Elements_Type (Index_Type'First .. L);
-
- for I in Container.Elements'Range loop
-
- if E (I) /= null then
- Container.Elements (I) := new Element_Type'(E (I).all);
- end if;
-
- Container.Last := I;
-
- end loop;
-
- end;
-
- end Adjust;
-
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
- procedure Finalize (Container : in out Vector) is
+ ---------
+ -- "&" --
+ ---------
- E : Elements_Access := Container.Elements;
- L : constant Index_Type'Base := Container.Last;
+ function "&" (Left, Right : Vector) return Vector is
+ LN : constant Count_Type := Length (Left);
+ RN : constant Count_Type := Length (Right);
begin
+ if LN = 0 then
+ if RN = 0 then
+ return Empty_Vector;
+ end if;
- Container.Elements := null;
- Container.Last := Index_Type'Pred (Index_Type'First);
-
- for I in Index_Type'First .. L loop
- Free (E (I));
- end loop;
-
- Free (E);
-
- end Finalize;
-
+ declare
+ RE : Elements_Type renames
+ Right.Elements (Index_Type'First .. Right.Last);
- procedure Write
- (Stream : access Root_Stream_Type'Class;
- Container : in Vector) is
+ Elements : Elements_Access :=
+ new Elements_Type (RE'Range);
- N : constant Count_Type := Length (Container);
+ begin
+ for I in Elements'Range loop
+ begin
+ if RE (I) /= null then
+ Elements (I) := new Element_Type'(RE (I).all);
+ end if;
+ exception
+ when others =>
+ for J in Index_Type'First .. Index_Type'Pred (I) loop
+ Free (Elements (J));
+ end loop;
- begin
+ Free (Elements);
+ raise;
+ end;
+ end loop;
- Count_Type'Base'Write (Stream, N);
+ return (Controlled with Elements, Right.Last, 0, 0);
+ end;
- if N = 0 then
- return;
end if;
- declare
- E : Elements_Type renames Container.Elements.all;
- begin
- for I in Index_Type'First .. Container.Last loop
-
- -- There's another way to do this. Instead a separate
- -- Boolean for each element, you could write a Boolean
- -- followed by a count of how many nulls or non-nulls
- -- follow in the array. Alternately you could use a
- -- signed integer, and use the sign as the indicator
- -- or null-ness.
-
- if E (I) = null then
- Boolean'Write (Stream, False);
- else
- Boolean'Write (Stream, True);
- Element_Type'Output (Stream, E (I).all);
- end if;
-
- end loop;
- end;
-
- end Write;
-
-
- procedure Read
- (Stream : access Root_Stream_Type'Class;
- Container : out Vector) is
-
- Length : Count_Type'Base;
- Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
-
- B : Boolean;
+ if RN = 0 then
+ declare
+ LE : Elements_Type renames
+ Left.Elements (Index_Type'First .. Left.Last);
- begin
+ Elements : Elements_Access :=
+ new Elements_Type (LE'Range);
- Clear (Container);
+ begin
+ for I in Elements'Range loop
+ begin
+ if LE (I) /= null then
+ Elements (I) := new Element_Type'(LE (I).all);
+ end if;
+ exception
+ when others =>
+ for J in Index_Type'First .. Index_Type'Pred (I) loop
+ Free (Elements (J));
+ end loop;
- Count_Type'Base'Read (Stream, Length);
+ Free (Elements);
+ raise;
+ end;
+ end loop;
- if Length > Capacity (Container) then
- Reserve_Capacity (Container, Capacity => Length);
+ return (Controlled with Elements, Left.Last, 0, 0);
+ end;
end if;
- for I in Count_Type range 1 .. Length loop
-
- Last := Index_Type'Succ (Last);
-
- Boolean'Read (Stream, B);
-
- if B then
- Container.Elements (Last) :=
- new Element_Type'(Element_Type'Input (Stream));
- end if;
-
- Container.Last := Last;
-
- end loop;
+ declare
+ Last_As_Int : constant Int'Base :=
+ Int (Index_Type'First) + Int (LN) + Int (RN) - 1;
- end Read;
+ Last : constant Index_Type := Index_Type (Last_As_Int);
+ LE : Elements_Type renames
+ Left.Elements (Index_Type'First .. Left.Last);
- function To_Vector (Length : Count_Type) return Vector is
- begin
+ RE : Elements_Type renames
+ Right.Elements (Index_Type'First .. Right.Last);
- if Length = 0 then
- return Empty_Vector;
- end if;
+ Elements : Elements_Access :=
+ new Elements_Type (Index_Type'First .. Last);
- declare
+ I : Index_Type'Base := Index_Type'Pred (Index_Type'First);
- First : constant Int := Int (Index_Type'First);
+ begin
+ for LI in LE'Range loop
+ I := Index_Type'Succ (I);
- Last_As_Int : constant Int'Base :=
- First + Int (Length) - 1;
+ begin
+ if LE (LI) /= null then
+ Elements (I) := new Element_Type'(LE (LI).all);
+ end if;
+ exception
+ when others =>
+ for J in Index_Type'First .. Index_Type'Pred (I) loop
+ Free (Elements (J));
+ end loop;
- Last : constant Index_Type :=
- Index_Type (Last_As_Int);
+ Free (Elements);
+ raise;
+ end;
+ end loop;
- Elements : constant Elements_Access :=
- new Elements_Type (Index_Type'First .. Last);
+ for RI in RE'Range loop
+ I := Index_Type'Succ (I);
- begin
+ begin
+ if RE (RI) /= null then
+ Elements (I) := new Element_Type'(RE (RI).all);
+ end if;
+ exception
+ when others =>
+ for J in Index_Type'First .. Index_Type'Pred (I) loop
+ Free (Elements (J));
+ end loop;
- return (Controlled with Elements, Last);
+ Free (Elements);
+ raise;
+ end;
+ end loop;
+ return (Controlled with Elements, Last, 0, 0);
end;
+ end "&";
- end To_Vector;
-
+ function "&" (Left : Vector; Right : Element_Type) return Vector is
+ LN : constant Count_Type := Length (Left);
+ begin
+ if LN = 0 then
+ declare
+ subtype Elements_Subtype is
+ Elements_Type (Index_Type'First .. Index_Type'First);
- function To_Vector
- (New_Item : Element_Type;
- Length : Count_Type) return Vector is
+ Elements : Elements_Access := new Elements_Subtype;
- begin
+ begin
+ begin
+ Elements (Elements'First) := new Element_Type'(Right);
+ exception
+ when others =>
+ Free (Elements);
+ raise;
+ end;
- if Length = 0 then
- return Empty_Vector;
+ return (Controlled with Elements, Index_Type'First, 0, 0);
+ end;
end if;
declare
-
- First : constant Int := Int (Index_Type'First);
-
Last_As_Int : constant Int'Base :=
- First + Int (Length) - 1;
+ Int (Index_Type'First) + Int (LN);
+
+ Last : constant Index_Type := Index_Type (Last_As_Int);
- Last : constant Index_Type :=
- Index_Type (Last_As_Int);
+ LE : Elements_Type renames
+ Left.Elements (Index_Type'First .. Left.Last);
Elements : Elements_Access :=
- new Elements_Type (Index_Type'First .. Last);
+ new Elements_Type (Index_Type'First .. Last);
begin
-
- for I in Elements'Range loop
-
+ for I in LE'Range loop
begin
- Elements (I) := new Element_Type'(New_Item);
+ if LE (I) /= null then
+ Elements (I) := new Element_Type'(LE (I).all);
+ end if;
exception
when others =>
for J in Index_Type'First .. Index_Type'Pred (I) loop
Free (Elements);
raise;
end;
-
end loop;
- return (Controlled with Elements, Last);
+ begin
+ Elements (Elements'Last) := new Element_Type'(Right);
+ exception
+ when others =>
+ declare
+ subtype J_Subtype is Index_Type'Base range
+ Index_Type'First .. Index_Type'Pred (Elements'Last);
+ begin
+ for J in J_Subtype loop
+ Free (Elements (J));
+ end loop;
+ end;
+
+ Free (Elements);
+ raise;
+ end;
+ return (Controlled with Elements, Last, 0, 0);
end;
+ end "&";
- end To_Vector;
-
+ function "&" (Left : Element_Type; Right : Vector) return Vector is
+ RN : constant Count_Type := Length (Right);
- function "=" (Left, Right : Vector) return Boolean is
begin
+ if RN = 0 then
+ declare
+ subtype Elements_Subtype is
+ Elements_Type (Index_Type'First .. Index_Type'First);
- if Left'Address = Right'Address then
- return True;
- end if;
+ Elements : Elements_Access := new Elements_Subtype;
+
+ begin
+ begin
+ Elements (Elements'First) := new Element_Type'(Left);
+ exception
+ when others =>
+ Free (Elements);
+ raise;
+ end;
+
+ return (Controlled with Elements, Index_Type'First, 0, 0);
+ end;
+ end if;
+
+ declare
+ Last_As_Int : constant Int'Base :=
+ Int (Index_Type'First) + Int (RN);
+
+ Last : constant Index_Type := Index_Type (Last_As_Int);
+
+ RE : Elements_Type renames
+ Right.Elements (Index_Type'First .. Right.Last);
+
+ Elements : Elements_Access :=
+ new Elements_Type (Index_Type'First .. Last);
+
+ I : Index_Type'Base := Index_Type'First;
+
+ begin
+ begin
+ Elements (I) := new Element_Type'(Left);
+ exception
+ when others =>
+ Free (Elements);
+ raise;
+ end;
+
+ for RI in RE'Range loop
+ I := Index_Type'Succ (I);
+
+ begin
+ if RE (RI) /= null then
+ Elements (I) := new Element_Type'(RE (RI).all);
+ end if;
+ exception
+ when others =>
+ for J in Index_Type'First .. Index_Type'Pred (I) loop
+ Free (Elements (J));
+ end loop;
+
+ Free (Elements);
+ raise;
+ end;
+ end loop;
+
+ return (Controlled with Elements, Last, 0, 0);
+ end;
+ end "&";
+
+ function "&" (Left, Right : Element_Type) return Vector is
+ subtype IT is Index_Type'Base range
+ Index_Type'First .. Index_Type'Succ (Index_Type'First);
+
+ Elements : Elements_Access := new Elements_Type (IT);
+
+ begin
+ begin
+ Elements (Elements'First) := new Element_Type'(Left);
+ exception
+ when others =>
+ Free (Elements);
+ raise;
+ end;
+
+ begin
+ Elements (Elements'Last) := new Element_Type'(Right);
+ exception
+ when others =>
+ Free (Elements (Elements'First));
+ Free (Elements);
+ raise;
+ end;
+
+ return (Controlled with Elements, Elements'Last, 0, 0);
+ end "&";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Vector) return Boolean is
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
if Left.Last /= Right.Last then
return False;
end if;
- for I in Index_Type'First .. Left.Last loop
-
+ for J in Index_Type'First .. Left.Last loop
-- NOTE:
-- I think it's a bounded error to read or otherwise manipulate
-- an "empty" element, which here means that it has the value
-- you have a contrary argument then let me know.
-- END NOTE.
- if Left.Elements (I) = null then
-
- if Right.Elements (I) /= null then
+ if Left.Elements (J) = null then
+ if Right.Elements (J) /= null then
return False;
end if;
- elsif Right.Elements (I) = null then
-
+ elsif Right.Elements (J) = null then
return False;
- elsif Left.Elements (I).all /= Right.Elements (I).all then
-
+ elsif Left.Elements (J).all /= Right.Elements (J).all then
return False;
end if;
-
end loop;
return True;
-
end "=";
+ ------------
+ -- Adjust --
+ ------------
- function Length (Container : Vector) return Count_Type is
-
- L : constant Int := Int (Container.Last);
- F : constant Int := Int (Index_Type'First);
-
- N : constant Int'Base := L - F + 1;
- begin
- return Count_Type (N);
- end Length;
-
-
- function Is_Empty (Container : Vector) return Boolean is
- begin
- return Container.Last < Index_Type'First;
- end Is_Empty;
-
-
- procedure Set_Length
- (Container : in out Vector;
- Length : in Count_Type) is
-
- N : constant Count_Type := Indefinite_Vectors.Length (Container);
-
+ procedure Adjust (Container : in out Vector) is
begin
-
- if Length = N then
+ if Container.Elements = null then
return;
end if;
- if Length = 0 then
- Clear (Container);
+ if Container.Elements'Length = 0
+ or else Container.Last < Index_Type'First
+ then
+ Container.Elements := null;
return;
end if;
declare
- Last_As_Int : constant Int'Base :=
- Int (Index_Type'First) + Int (Length) - 1;
-
- Last : constant Index_Type :=
- Index_Type (Last_As_Int);
+ E : Elements_Type renames Container.Elements.all;
+ L : constant Index_Type := Container.Last;
begin
+ Container.Elements := null;
+ Container.Last := No_Index;
+ Container.Busy := 0;
+ Container.Lock := 0;
- if Length > N then
+ Container.Elements := new Elements_Type (Index_Type'First .. L);
- if Length > Capacity (Container) then
- Reserve_Capacity (Container, Capacity => Length);
+ for I in Container.Elements'Range loop
+ if E (I) /= null then
+ Container.Elements (I) := new Element_Type'(E (I).all);
end if;
- Container.Last := Last;
-
- return;
-
- end if;
-
- for I in reverse Index_Type'Succ (Last) .. Container.Last loop
-
- declare
- X : Element_Access := Container.Elements (I);
- begin
- Container.Elements (I) := null;
- Container.Last := Index_Type'Pred (Container.Last);
- Free (X);
- end;
-
+ Container.Last := I;
end loop;
-
end;
+ end Adjust;
- end Set_Length;
-
+ ------------
+ -- Append --
+ ------------
- procedure Clear (Container : in out Vector) is
+ procedure Append (Container : in out Vector; New_Item : Vector) is
begin
+ if Is_Empty (New_Item) then
+ return;
+ end if;
- for I in reverse Index_Type'First .. Container.Last loop
-
- declare
- X : Element_Access := Container.Elements (I);
- begin
- Container.Elements (I) := null;
- Container.Last := Index_Type'Pred (I);
- Free (X);
- end;
-
- end loop;
-
- end Clear;
-
+ Insert
+ (Container,
+ Index_Type'Succ (Container.Last),
+ New_Item);
+ end Append;
- procedure Append (Container : in out Vector;
- New_Item : in Element_Type;
- Count : in Count_Type := 1) is
+ procedure Append
+ (Container : in out Vector;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
begin
if Count = 0 then
return;
Count);
end Append;
+ ------------
+ -- Assign --
+ ------------
- procedure Insert
- (Container : in out Vector;
- Before : in Extended_Index;
- New_Item : in Element_Type;
- Count : in Count_Type := 1) is
+ procedure Assign
+ (Target : in out Vector;
+ Source : Vector)
+ is
+ N : constant Count_Type := Length (Source);
- Old_Last_As_Int : constant Int := Int (Container.Last);
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
- N : constant Int := Int (Count);
+ Clear (Target);
- New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N;
+ if N = 0 then
+ return;
+ end if;
+
+ if N > Capacity (Target) then
+ Reserve_Capacity (Target, Capacity => N);
+ end if;
- New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int);
+ for J in Index_Type'First .. Source.Last loop
+ declare
+ EA : constant Element_Access := Source.Elements (J);
+ begin
+ if EA /= null then
+ Target.Elements (J) := new Element_Type'(EA.all);
+ end if;
+ end;
- Index : Index_Type;
+ Target.Last := J;
+ end loop;
+ end Assign;
- Dst_Last : Index_Type;
- Dst : Elements_Access;
+ --------------
+ -- Capacity --
+ --------------
+ function Capacity (Container : Vector) return Count_Type is
begin
+ if Container.Elements = null then
+ return 0;
+ end if;
- if Count = 0 then
- return;
+ return Container.Elements'Length;
+ end Capacity;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Vector) is
+ begin
+ if Container.Busy > 0 then
+ raise Program_Error;
end if;
- declare
- subtype Before_Subtype is Index_Type'Base range
- Index_Type'First .. Index_Type'Succ (Container.Last);
+ for J in reverse Index_Type'First .. Container.Last loop
+ declare
+ X : Element_Access := Container.Elements (J);
+ begin
+ Container.Elements (J) := null;
+ Container.Last := Index_Type'Pred (J);
+ Free (X);
+ end;
+ end loop;
+ end Clear;
- Old_First : constant Before_Subtype := Before;
+ --------------
+ -- Contains --
+ --------------
- Old_First_As_Int : constant Int := Int (Old_First);
+ function Contains
+ (Container : Vector;
+ Item : Element_Type) return Boolean is
+ begin
+ return Find_Index (Container, Item) /= No_Index;
+ end Contains;
- New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
- begin
- Index := Index_Type (New_First_As_Int);
- end;
+ ------------
+ -- Delete --
+ ------------
- if Container.Elements = null then
+ procedure Delete
+ (Container : in out Vector;
+ Index : Extended_Index;
+ Count : Count_Type := 1)
+ is
+ begin
+ if Index < Index_Type'First then
+ raise Constraint_Error;
+ end if;
- declare
- subtype Elements_Subtype is
- Elements_Type (Index_Type'First .. New_Last);
- begin
- Container.Elements := new Elements_Subtype;
- Container.Last := Index_Type'Pred (Index_Type'First);
+ if Index > Container.Last then
+ if Index > Container.Last + 1 then
+ raise Constraint_Error;
+ end if;
- for I in Container.Elements'Range loop
- Container.Elements (I) := new Element_Type'(New_Item);
- Container.Last := I;
- end loop;
- end;
+ return;
+ end if;
+ if Count = 0 then
return;
+ end if;
+ if Container.Busy > 0 then
+ raise Program_Error;
end if;
- if New_Last <= Container.Elements'Last then
+ declare
+ I_As_Int : constant Int := Int (Index);
- declare
- E : Elements_Type renames Container.Elements.all;
- begin
- E (Index .. New_Last) := E (Before .. Container.Last);
- Container.Last := New_Last;
+ Old_Last_As_Int : constant Int := Int (Container.Last);
- -- NOTE:
- -- Now we do the allocation. If it fails, we can propagate the
- -- exception and invariants are more or less satisfied. The
- -- issue is that we have some slots still null, and the client
- -- has no way of detecting whether the slot is null (unless we
- -- give him a way).
- --
- -- Another way is to allocate a subarray on the stack, do the
- -- allocation into that array, and if that success then do
- -- the insertion proper. The issue there is that you have to
- -- allocate the subarray on the stack, and that may fail if the
- -- subarray is long.
- --
- -- Or we could try to roll-back the changes: deallocate the
- -- elements we have successfully deallocated, and then copy
- -- the elements ptrs back to their original posns.
- -- END NOTE.
+ Count1 : constant Int'Base := Int (Count);
+ Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
- -- NOTE: I have written the loop manually here. I could
- -- have done it this way too:
- -- E (Before .. Index_Type'Pred (Index)) :=
- -- (others => new Element_Type'New_Item);
- -- END NOTE.
+ N : constant Int'Base := Int'Min (Count1, Count2);
- for I in Before .. Index_Type'Pred (Index) loop
+ J_As_Int : constant Int'Base := I_As_Int + N;
+ J : constant Index_Type'Base := Index_Type'Base (J_As_Int);
- begin
- E (I) := new Element_Type'(New_Item);
- exception
- when others =>
- E (I .. Index_Type'Pred (Index)) := (others => null);
- raise;
- end;
+ E : Elements_Type renames Container.Elements.all;
- end loop;
- end;
+ New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
- return;
+ New_Last : constant Extended_Index :=
+ Extended_Index (New_Last_As_Int);
+
+ begin
+ for K in Index .. Index_Type'Pred (J) loop
+ declare
+ X : Element_Access := E (K);
+ begin
+ E (K) := null;
+ Free (X);
+ end;
+ end loop;
+
+ E (Index .. New_Last) := E (J .. Container.Last);
+ Container.Last := New_Last;
+ end;
+ end Delete;
+ procedure Delete
+ (Container : in out Vector;
+ Position : in out Cursor;
+ Count : Count_Type := 1)
+ is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error;
end if;
- declare
+ if Position.Container /=
+ Vector_Access'(Container'Unchecked_Access)
+ or else Position.Index > Container.Last
+ then
+ raise Program_Error;
+ end if;
- First : constant Int := Int (Index_Type'First);
+ Delete (Container, Position.Index, Count);
- New_Size : constant Int'Base :=
- New_Last_As_Int - First + 1;
+ if Position.Index <= Container.Last then
+ Position := (Container'Unchecked_Access, Position.Index);
+ else
+ Position := No_Element;
+ end if;
+ end Delete;
- Max_Size : constant Int'Base :=
- Int (Index_Type'Last) - First + 1;
+ ------------------
+ -- Delete_First --
+ ------------------
- Size, Dst_Last_As_Int : Int'Base;
+ procedure Delete_First
+ (Container : in out Vector;
+ Count : Count_Type := 1)
+ is
+ begin
+ if Count = 0 then
+ return;
+ end if;
- begin
+ if Count >= Length (Container) then
+ Clear (Container);
+ return;
+ end if;
- if New_Size >= Max_Size / 2 then
+ Delete (Container, Index_Type'First, Count);
+ end Delete_First;
- Dst_Last := Index_Type'Last;
+ -----------------
+ -- Delete_Last --
+ -----------------
- else
+ procedure Delete_Last
+ (Container : in out Vector;
+ Count : Count_Type := 1)
+ is
+ Index : Int'Base;
- Size := Container.Elements'Length;
+ begin
+ if Count = 0 then
+ return;
+ end if;
- if Size = 0 then
- Size := 1;
- end if;
+ if Count >= Length (Container) then
+ Clear (Container);
+ return;
+ end if;
- while Size < New_Size loop
- Size := 2 * Size;
- end loop;
+ Index := Int'Base (Container.Last) - Int'Base (Count) + 1;
- Dst_Last_As_Int := First + Size - 1;
- Dst_Last := Index_Type (Dst_Last_As_Int);
+ Delete (Container, Index_Type'Base (Index), Count);
+ end Delete_Last;
- end if;
+ -------------
+ -- Element --
+ -------------
- end;
+ function Element
+ (Container : Vector;
+ Index : Index_Type) return Element_Type
+ is
+ subtype T is Index_Type'Base range
+ Index_Type'First .. Container.Last;
+ begin
+ return Container.Elements (T'(Index)).all;
+ end Element;
- Dst := new Elements_Type (Index_Type'First .. Dst_Last);
+ function Element (Position : Cursor) return Element_Type is
+ begin
+ return Element (Position.Container.all, Position.Index);
+ end Element;
- declare
- Src : Elements_Type renames Container.Elements.all;
- begin
- Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
- Src (Index_Type'First .. Index_Type'Pred (Before));
+ --------------
+ -- Finalize --
+ --------------
- Dst (Index .. New_Last) := Src (Before .. Container.Last);
- end;
+ procedure Finalize (Container : in out Vector) is
+ begin
+ Clear (Container);
declare
X : Elements_Access := Container.Elements;
begin
- Container.Elements := Dst;
- Container.Last := New_Last;
-
+ Container.Elements := null;
Free (X);
end;
+ end Finalize;
- -- NOTE:
- -- Now do the allocation. If the allocation fails,
- -- then the worst thing is that we have a few null slots.
- -- Our invariants are otherwise satisfied.
- -- END NOTE.
+ ----------
+ -- Find --
+ ----------
- for I in Before .. Index_Type'Pred (Index) loop
- Dst (I) := new Element_Type'(New_Item);
- end loop;
+ function Find
+ (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor is
- end Insert;
+ begin
+ if Position.Container /= null
+ and then (Position.Container /=
+ Vector_Access'(Container'Unchecked_Access)
+ or else Position.Index > Container.Last)
+ then
+ raise Program_Error;
+ end if;
+ for J in Position.Index .. Container.Last loop
+ if Container.Elements (J) /= null
+ and then Container.Elements (J).all = Item
+ then
+ return (Container'Unchecked_Access, J);
+ end if;
+ end loop;
- procedure Insert_Space
- (Container : in out Vector;
- Before : in Extended_Index;
- Count : in Count_Type := 1) is
+ return No_Element;
+ end Find;
- Old_Last_As_Int : constant Int := Int (Container.Last);
+ ----------------
+ -- Find_Index --
+ ----------------
- N : constant Int := Int (Count);
+ function Find_Index
+ (Container : Vector;
+ Item : Element_Type;
+ Index : Index_Type := Index_Type'First) return Extended_Index is
+ begin
+ for Indx in Index .. Container.Last loop
+ if Container.Elements (Indx) /= null
+ and then Container.Elements (Indx).all = Item
+ then
+ return Indx;
+ end if;
+ end loop;
+
+ return No_Index;
+ end Find_Index;
- New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N;
+ -----------
+ -- First --
+ -----------
- New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int);
+ function First (Container : Vector) return Cursor is
+ begin
+ if Is_Empty (Container) then
+ return No_Element;
+ end if;
- Index : Index_Type;
+ return (Container'Unchecked_Access, Index_Type'First);
+ end First;
- Dst_Last : Index_Type;
- Dst : Elements_Access;
+ -------------------
+ -- First_Element --
+ -------------------
+ function First_Element (Container : Vector) return Element_Type is
begin
+ return Element (Container, Index_Type'First);
+ end First_Element;
- if Count = 0 then
- return;
- end if;
+ -----------------
+ -- First_Index --
+ -----------------
- declare
- subtype Before_Subtype is Index_Type'Base range
- Index_Type'First .. Index_Type'Succ (Container.Last);
+ function First_Index (Container : Vector) return Index_Type is
+ pragma Unreferenced (Container);
+ begin
+ return Index_Type'First;
+ end First_Index;
- Old_First : constant Before_Subtype := Before;
+ ---------------------
+ -- Generic_Sorting --
+ ---------------------
- Old_First_As_Int : constant Int := Int (Old_First);
+ package body Generic_Sorting is
- New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
- begin
- Index := Index_Type (New_First_As_Int);
- end;
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- if Container.Elements = null then
+ function Is_Less (L, R : Element_Access) return Boolean;
+ pragma Inline (Is_Less);
- declare
- subtype Elements_Subtype is
- Elements_Type (Index_Type'First .. New_Last);
- begin
- Container.Elements := new Elements_Subtype;
- Container.Last := New_Last;
- end;
+ -------------
+ -- Is_Less --
+ -------------
- return;
+ function Is_Less (L, R : Element_Access) return Boolean is
+ begin
+ if L = null then
+ return R /= null;
+ elsif R = null then
+ return False;
+ else
+ return L.all < R.all;
+ end if;
+ end Is_Less;
- end if;
+ ---------------
+ -- Is_Sorted --
+ ---------------
- if New_Last <= Container.Elements'Last then
+ function Is_Sorted (Container : Vector) return Boolean is
+ begin
+ if Container.Last <= Index_Type'First then
+ return True;
+ end if;
declare
E : Elements_Type renames Container.Elements.all;
begin
- E (Index .. New_Last) := E (Before .. Container.Last);
- E (Before .. Index_Type'Pred (Index)) := (others => null);
-
- Container.Last := New_Last;
+ for I in Index_Type'First .. Container.Last - 1 loop
+ if Is_Less (E (I + 1), E (I)) then
+ return False;
+ end if;
+ end loop;
end;
- return;
+ return True;
+ end Is_Sorted;
- end if;
+ -----------
+ -- Merge --
+ -----------
- declare
+ procedure Merge (Target, Source : in out Vector) is
+ I : Index_Type'Base := Target.Last;
+ J : Index_Type'Base;
- First : constant Int := Int (Index_Type'First);
+ begin
+ if Target.Last < Index_Type'First then
+ Move (Target => Target, Source => Source);
+ return;
+ end if;
- New_Size : constant Int'Base :=
- Int (New_Last_As_Int) - First + 1;
+ if Target'Address = Source'Address then
+ return;
+ end if;
- Max_Size : constant Int'Base :=
- Int (Index_Type'Last) - First + 1;
+ if Source.Last < Index_Type'First then
+ return;
+ end if;
- Size, Dst_Last_As_Int : Int'Base;
+ if Source.Busy > 0 then
+ raise Program_Error;
+ end if;
- begin
+ Target.Set_Length (Length (Target) + Length (Source));
- if New_Size >= Max_Size / 2 then
+ J := Target.Last;
+ while Source.Last >= Index_Type'First loop
+ if I < Index_Type'First then
+ declare
+ Src : Elements_Type renames
+ Source.Elements (Index_Type'First .. Source.Last);
- Dst_Last := Index_Type'Last;
+ begin
+ Target.Elements (Index_Type'First .. J) := Src;
+ Src := (others => null);
+ end;
- else
+ Source.Last := No_Index;
+ return;
+ end if;
- Size := Container.Elements'Length;
+ declare
+ Src : Element_Access renames Source.Elements (Source.Last);
+ Tgt : Element_Access renames Target.Elements (I);
- if Size = 0 then
- Size := 1;
- end if;
+ begin
+ if Is_Less (Src, Tgt) then
+ Target.Elements (J) := Tgt;
+ Tgt := null;
+ I := I - 1;
+
+ else
+ Target.Elements (J) := Src;
+ Src := null;
+ Source.Last := Source.Last - 1;
+ end if;
+ end;
- while Size < New_Size loop
- Size := 2 * Size;
- end loop;
+ J := J - 1;
+ end loop;
+ end Merge;
- Dst_Last_As_Int := First + Size - 1;
- Dst_Last := Index_Type (Dst_Last_As_Int);
-
- end if;
+ ----------
+ -- Sort --
+ ----------
- end;
+ procedure Sort (Container : in out Vector)
+ is
+ procedure Sort is
+ new Generic_Array_Sort
+ (Index_Type => Index_Type,
+ Element_Type => Element_Access,
+ Array_Type => Elements_Type,
+ "<" => Is_Less);
- Dst := new Elements_Type (Index_Type'First .. Dst_Last);
+ -- Start of processing for Sort
- declare
- Src : Elements_Type renames Container.Elements.all;
begin
- Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
- Src (Index_Type'First .. Index_Type'Pred (Before));
-
- Dst (Index .. New_Last) := Src (Before .. Container.Last);
- end;
+ if Container.Last <= Index_Type'First then
+ return;
+ end if;
- declare
- X : Elements_Access := Container.Elements;
- begin
- Container.Elements := Dst;
- Container.Last := New_Last;
+ if Container.Lock > 0 then
+ raise Program_Error;
+ end if;
- Free (X);
- end;
+ Sort (Container.Elements (Index_Type'First .. Container.Last));
+ end Sort;
- end Insert_Space;
+ end Generic_Sorting;
+ -----------------
+ -- Has_Element --
+ -----------------
- procedure Delete_First (Container : in out Vector;
- Count : in Count_Type := 1) is
+ function Has_Element (Position : Cursor) return Boolean is
begin
-
- if Count = 0 then
- return;
+ if Position.Container = null then
+ return False;
end if;
- if Count >= Length (Container) then
- Clear (Container);
- return;
- end if;
+ return Position.Index <= Position.Container.Last;
+ end Has_Element;
- Delete (Container, Index_Type'First, Count);
+ ------------
+ -- Insert --
+ ------------
- end Delete_First;
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ N : constant Int := Int (Count);
+ New_Last_As_Int : Int'Base;
+ New_Last : Index_Type;
- procedure Delete_Last (Container : in out Vector;
- Count : in Count_Type := 1) is
+ Index : Extended_Index; -- TODO: see note in a-convec.adb.
- Index : Int'Base;
+ Dst_Last : Index_Type;
+ Dst : Elements_Access;
begin
+ if Before < Index_Type'First then
+ raise Constraint_Error;
+ end if;
+
+ if Before > Container.Last
+ and then Before > Container.Last + 1
+ then
+ raise Constraint_Error;
+ end if;
if Count = 0 then
return;
end if;
- if Count >= Length (Container) then
- Clear (Container);
- return;
+ declare
+ Old_Last_As_Int : constant Int := Int (Container.Last);
+
+ begin
+ New_Last_As_Int := Old_Last_As_Int + N;
+ New_Last := Index_Type (New_Last_As_Int);
+ end;
+
+ if Container.Busy > 0 then
+ raise Program_Error;
end if;
- Index := Int'Base (Container.Last) - Int'Base (Count) + 1;
+ declare
+ Old_First_As_Int : constant Int := Int (Before);
- Delete (Container, Index_Type'Base (Index), Count);
+ New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
- end Delete_Last;
+ begin
+ Index := Extended_Index (New_First_As_Int); -- TODO
+ end;
+ if Container.Elements = null then
+ declare
+ subtype Elements_Subtype is
+ Elements_Type (Index_Type'First .. New_Last);
+ begin
+ Container.Elements := new Elements_Subtype;
+ Container.Last := Index_Type'Pred (Index_Type'First);
- procedure Delete
- (Container : in out Vector;
- Index : in Extended_Index; -- TODO: verify in Atlanta
- Count : in Count_Type := 1) is
+ for J in Container.Elements'Range loop
+ Container.Elements (J) := new Element_Type'(New_Item);
+ Container.Last := J;
+ end loop;
+ end;
- begin
+ return;
+ end if;
+
+ if New_Last <= Container.Elements'Last then
+ declare
+ E : Elements_Type renames Container.Elements.all;
+ begin
+ E (Index .. New_Last) := E (Before .. Container.Last);
+ Container.Last := New_Last;
+
+ -- NOTE:
+ -- Now we do the allocation. If it fails, we can propagate the
+ -- exception and invariants are more or less satisfied. The
+ -- issue is that we have some slots still null, and the client
+ -- has no way of detecting whether the slot is null (unless we
+ -- give him a way).
+ --
+ -- Another way is to allocate a subarray on the stack, do the
+ -- allocation into that array, and if that success then do
+ -- the insertion proper. The issue there is that you have to
+ -- allocate the subarray on the stack, and that may fail if the
+ -- subarray is long.
+ --
+ -- Or we could try to roll-back the changes: deallocate the
+ -- elements we have successfully deallocated, and then copy
+ -- the elements ptrs back to their original posns.
+ -- END NOTE.
+
+ -- NOTE: I have written the loop manually here. I could
+ -- have done it this way too:
+ -- E (Before .. Index_Type'Pred (Index)) :=
+ -- (others => new Element_Type'New_Item);
+ -- END NOTE.
+
+ for J in Before .. Index_Type'Pred (Index) loop
+ begin
+ E (J) := new Element_Type'(New_Item);
+ exception
+ when others =>
+ E (J .. Index_Type'Pred (Index)) := (others => null);
+ raise;
+ end;
+ end loop;
+ end;
- if Count = 0 then
return;
end if;
declare
+ First : constant Int := Int (Index_Type'First);
- subtype I_Subtype is Index_Type'Base range
- Index_Type'First .. Container.Last;
+ New_Size : constant Int'Base := New_Last_As_Int - First + 1;
+ Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
- I : constant I_Subtype := Index;
- I_As_Int : constant Int := Int (I);
+ Size, Dst_Last_As_Int : Int'Base;
- Old_Last_As_Int : constant Int := Int (Container.Last);
+ begin
+ if New_Size >= Max_Size / 2 then
+ Dst_Last := Index_Type'Last;
- Count1 : constant Int'Base := Int (Count);
- Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
+ else
+ Size := Container.Elements'Length;
- N : constant Int'Base := Int'Min (Count1, Count2);
+ if Size = 0 then
+ Size := 1;
+ end if;
- J_As_Int : constant Int'Base := I_As_Int + N;
- J : constant Index_Type'Base := Index_Type'Base (J_As_Int);
+ while Size < New_Size loop
+ Size := 2 * Size;
+ end loop;
- E : Elements_Type renames Container.Elements.all;
+ Dst_Last_As_Int := First + Size - 1;
+ Dst_Last := Index_Type (Dst_Last_As_Int);
+ end if;
+ end;
- New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
+ Dst := new Elements_Type (Index_Type'First .. Dst_Last);
- New_Last : constant Extended_Index :=
- Extended_Index (New_Last_As_Int);
+ declare
+ Src : Elements_Type renames Container.Elements.all;
begin
+ Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
+ Src (Index_Type'First .. Index_Type'Pred (Before));
- for K in I .. Index_Type'Pred (J) loop
-
- begin
- Free (E (K));
- exception
- when others =>
- E (K) := null;
- raise;
- end;
-
- end loop;
+ Dst (Index .. New_Last) := Src (Before .. Container.Last);
+ end;
- E (I .. New_Last) := E (J .. Container.Last);
+ declare
+ X : Elements_Access := Container.Elements;
+ begin
+ Container.Elements := Dst;
Container.Last := New_Last;
+ Free (X);
end;
- end Delete;
+ -- NOTE:
+ -- Now do the allocation. If the allocation fails,
+ -- then the worst thing is that we have a few null slots.
+ -- Our invariants are otherwise satisfied.
+ -- END NOTE.
+ for J in Before .. Index_Type'Pred (Index) loop
+ Dst (J) := new Element_Type'(New_Item);
+ end loop;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Vector)
+ is
+ N : constant Count_Type := Length (New_Item);
- function Capacity (Container : Vector) return Count_Type is
begin
- if Container.Elements = null then
- return 0;
+ if Before < Index_Type'First then
+ raise Constraint_Error;
end if;
- return Container.Elements'Length;
- end Capacity;
+ if Before > Container.Last
+ and then Before > Container.Last + 1
+ then
+ raise Constraint_Error;
+ end if;
+ if N = 0 then
+ return;
+ end if;
- procedure Reserve_Capacity (Container : in out Vector;
- Capacity : in Count_Type) is
+ Insert_Space (Container, Before, Count => N);
- N : constant Count_Type := Length (Container);
+ if Container'Address = New_Item'Address then
+ declare
+ Dst_Last_As_Int : constant Int'Base :=
+ Int'Base (Before) + Int'Base (N) - 1;
- begin
+ Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
- if Capacity = 0 then
+ Dst_Index : Index_Type'Base := Index_Type'Pred (Before);
- if N = 0 then
+ Dst : Elements_Type renames
+ Container.Elements (Before .. Dst_Last);
+ begin
declare
- X : Elements_Access := Container.Elements;
+ subtype Src_Index_Subtype is Index_Type'Base range
+ Index_Type'First .. Index_Type'Pred (Before);
+
+ Src : Elements_Type renames
+ Container.Elements (Src_Index_Subtype);
+
begin
- Container.Elements := null;
- Free (X);
- end;
+ for Src_Index in Src'Range loop
+ Dst_Index := Index_Type'Succ (Dst_Index);
- elsif N < Container.Elements'Length then
+ if Src (Src_Index) /= null then
+ Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
+ end if;
+ end loop;
+ end;
declare
- subtype Array_Index_Subtype is Index_Type'Base range
- Index_Type'First .. Container.Last;
+ subtype Src_Index_Subtype is Index_Type'Base range
+ Index_Type'Succ (Dst_Last) .. Container.Last;
Src : Elements_Type renames
- Container.Elements (Array_Index_Subtype);
-
- subtype Array_Subtype is
- Elements_Type (Array_Index_Subtype);
+ Container.Elements (Src_Index_Subtype);
- X : Elements_Access := Container.Elements;
begin
- Container.Elements := new Array_Subtype'(Src);
- Free (X);
- end;
-
- end if;
+ for Src_Index in Src'Range loop
+ Dst_Index := Index_Type'Succ (Dst_Index);
- return;
+ if Src (Src_Index) /= null then
+ Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
+ end if;
+ end loop;
+ end;
+ end;
- end if;
+ else
+ declare
+ Dst_Last_As_Int : constant Int'Base :=
+ Int'Base (Before) + Int'Base (N) - 1;
- if Container.Elements = null then
+ Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
- declare
- Last_As_Int : constant Int'Base :=
- Int (Index_Type'First) + Int (Capacity) - 1;
+ Dst_Index : Index_Type'Base := Index_Type'Pred (Before);
- Last : constant Index_Type :=
- Index_Type (Last_As_Int);
+ Src : Elements_Type renames
+ New_Item.Elements (Index_Type'First .. New_Item.Last);
- subtype Array_Subtype is
- Elements_Type (Index_Type'First .. Last);
+ Dst : Elements_Type renames
+ Container.Elements (Before .. Dst_Last);
begin
- Container.Elements := new Array_Subtype;
- end;
+ for Src_Index in Src'Range loop
+ Dst_Index := Index_Type'Succ (Dst_Index);
- return;
+ if Src (Src_Index) /= null then
+ Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
+ end if;
+ end loop;
+ end;
end if;
+ end Insert;
- if Capacity <= N then
-
- if N < Container.Elements'Length then
-
- declare
- subtype Array_Index_Subtype is Index_Type'Base range
- Index_Type'First .. Container.Last;
-
- Src : Elements_Type renames
- Container.Elements (Array_Index_Subtype);
-
- subtype Array_Subtype is
- Elements_Type (Array_Index_Subtype);
-
- X : Elements_Access := Container.Elements;
- begin
- Container.Elements := new Array_Subtype'(Src);
- Free (X);
- end;
-
- end if;
-
- return;
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector)
+ is
+ Index : Index_Type'Base;
+ begin
+ if Before.Container /= null
+ and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
+ then
+ raise Program_Error;
end if;
- if Capacity = Container.Elements'Length then
+ if Is_Empty (New_Item) then
return;
end if;
- declare
- Last_As_Int : constant Int'Base :=
- Int (Index_Type'First) + Int (Capacity) - 1;
-
- Last : constant Index_Type :=
- Index_Type (Last_As_Int);
-
- subtype Array_Subtype is
- Elements_Type (Index_Type'First .. Last);
-
- X : Elements_Access := Container.Elements;
- begin
- Container.Elements := new Array_Subtype;
-
- declare
- Src : Elements_Type renames
- X (Index_Type'First .. Container.Last);
-
- Tgt : Elements_Type renames
- Container.Elements (Index_Type'First .. Container.Last);
- begin
- Tgt := Src;
- end;
-
- Free (X);
- end;
-
- end Reserve_Capacity;
-
-
- function First_Index (Container : Vector) return Index_Type is
- pragma Warnings (Off, Container);
- begin
- return Index_Type'First;
- end First_Index;
-
-
- function First_Element (Container : Vector) return Element_Type is
- begin
- return Element (Container, Index_Type'First);
- end First_Element;
-
-
- function Last_Index (Container : Vector) return Extended_Index is
- begin
- return Container.Last;
- end Last_Index;
-
-
- function Last_Element (Container : Vector) return Element_Type is
- begin
- return Element (Container, Container.Last);
- end Last_Element;
-
-
- function Element (Container : Vector;
- Index : Index_Type)
- return Element_Type is
-
- subtype T is Index_Type'Base range
- Index_Type'First .. Container.Last;
- begin
- return Container.Elements (T'(Index)).all;
- end Element;
-
+ if Before.Container = null
+ or else Before.Index > Container.Last
+ then
+ Index := Index_Type'Succ (Container.Last);
+ else
+ Index := Before.Index;
+ end if;
- procedure Replace_Element (Container : in Vector;
- Index : in Index_Type;
- By : in Element_Type) is
+ Insert (Container, Index, New_Item);
+ end Insert;
- subtype T is Index_Type'Base range
- Index_Type'First .. Container.Last;
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector;
+ Position : out Cursor)
+ is
+ Index : Index_Type'Base;
- X : Element_Access := Container.Elements (T'(Index));
begin
- Container.Elements (T'(Index)) := new Element_Type'(By);
- Free (X);
- end Replace_Element;
-
-
- procedure Generic_Sort (Container : in Vector) is
-
- function Is_Less (L, R : Element_Access) return Boolean;
- pragma Inline (Is_Less);
+ if Before.Container /= null
+ and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
- function Is_Less (L, R : Element_Access) return Boolean is
- begin
- if L = null then
- return R /= null;
- elsif R = null then
- return False;
+ if Is_Empty (New_Item) then
+ if Before.Container = null
+ or else Before.Index > Container.Last
+ then
+ Position := No_Element;
else
- return L.all < R.all;
+ Position := (Container'Unchecked_Access, Before.Index);
end if;
- end Is_Less;
- procedure Sort is
- new Generic_Array_Sort
- (Index_Type,
- Element_Access,
- Elements_Type,
- "<" => Is_Less);
-
- begin
-
- if Container.Elements = null then
return;
end if;
- Sort (Container.Elements (Index_Type'First .. Container.Last));
-
- end Generic_Sort;
-
-
- function Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'First)
- return Extended_Index is
-
- begin
-
- for I in Index .. Container.Last loop
- if Container.Elements (I) /= null
- and then Container.Elements (I).all = Item
- then
- return I;
- end if;
- end loop;
-
- return No_Index;
-
- end Find_Index;
-
-
- function Reverse_Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'Last)
- return Extended_Index is
-
- Last : Index_Type'Base;
-
- begin
-
- if Index > Container.Last then
- Last := Container.Last;
+ if Before.Container = null
+ or else Before.Index > Container.Last
+ then
+ Index := Index_Type'Succ (Container.Last);
else
- Last := Index;
+ Index := Before.Index;
end if;
- for I in reverse Index_Type'First .. Last loop
- if Container.Elements (I) /= null
- and then Container.Elements (I).all = Item
- then
- return I;
- end if;
- end loop;
-
- return No_Index;
-
- end Reverse_Find_Index;
-
-
- function Contains (Container : Vector;
- Item : Element_Type) return Boolean is
- begin
- return Find_Index (Container, Item) /= No_Index;
- end Contains;
-
-
+ Insert (Container, Index, New_Item);
- procedure Assign
- (Target : in out Vector;
- Source : in Vector) is
+ Position := Cursor'(Container'Unchecked_Access, Index);
+ end Insert;
- N : constant Count_Type := Length (Source);
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ Index : Index_Type'Base;
begin
-
- if Target'Address = Source'Address then
- return;
+ if Before.Container /= null
+ and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
+ then
+ raise Program_Error;
end if;
- Clear (Target);
-
- if N = 0 then
+ if Count = 0 then
return;
end if;
- if N > Capacity (Target) then
- Reserve_Capacity (Target, Capacity => N);
+ if Before.Container = null
+ or else Before.Index > Container.Last
+ then
+ Index := Index_Type'Succ (Container.Last);
+ else
+ Index := Before.Index;
end if;
- for I in Index_Type'First .. Source.Last loop
-
- declare
- EA : constant Element_Access := Source.Elements (I);
- begin
- if EA /= null then
- Target.Elements (I) := new Element_Type'(EA.all);
- end if;
- end;
-
- Target.Last := I;
-
- end loop;
-
- end Assign;
-
-
- procedure Move
- (Target : in out Vector;
- Source : in out Vector) is
+ Insert (Container, Index, New_Item, Count);
+ end Insert;
- X : Elements_Access := Target.Elements;
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ Index : Index_Type'Base;
begin
+ if Before.Container /= null
+ and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+
+ if Count = 0 then
+ if Before.Container = null
+ or else Before.Index > Container.Last
+ then
+ Position := No_Element;
+ else
+ Position := (Container'Unchecked_Access, Before.Index);
+ end if;
- if Target'Address = Source'Address then
return;
end if;
- if Target.Last >= Index_Type'First then
- raise Constraint_Error;
+ if Before.Container = null
+ or else Before.Index > Container.Last
+ then
+ Index := Index_Type'Succ (Container.Last);
+ else
+ Index := Before.Index;
end if;
- Target.Elements := null;
- Free (X); -- shouldn't fail
-
- Target.Elements := Source.Elements;
- Target.Last := Source.Last;
-
- Source.Elements := null;
- Source.Last := Index_Type'Pred (Index_Type'First);
-
- end Move;
-
-
- procedure Query_Element
- (Container : in Vector;
- Index : in Index_Type;
- Process : not null access procedure (Element : in Element_Type)) is
-
- subtype T is Index_Type'Base range
- Index_Type'First .. Container.Last;
- begin
- Process (Container.Elements (T'(Index)).all);
- end Query_Element;
-
-
- procedure Update_Element
- (Container : in Vector;
- Index : in Index_Type;
- Process : not null access procedure (Element : in out Element_Type)) is
-
- subtype T is Index_Type'Base range
- Index_Type'First .. Container.Last;
- begin
- Process (Container.Elements (T'(Index)).all);
- end Update_Element;
-
-
- procedure Prepend (Container : in out Vector;
- New_Item : in Element_Type;
- Count : in Count_Type := 1) is
- begin
- Insert (Container,
- Index_Type'First,
- New_Item,
- Count);
- end Prepend;
-
-
- procedure Swap
- (Container : in Vector;
- I, J : in Index_Type) is
-
- subtype T is Index_Type'Base range
- Index_Type'First .. Container.Last;
-
- EI : constant Element_Access := Container.Elements (T'(I));
+ Insert (Container, Index, New_Item, Count);
- begin
+ Position := (Container'Unchecked_Access, Index);
+ end Insert;
- Container.Elements (T'(I)) := Container.Elements (T'(J));
- Container.Elements (T'(J)) := EI;
+ ------------------
+ -- Insert_Space --
+ ------------------
- end Swap;
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Extended_Index;
+ Count : Count_Type := 1)
+ is
+ N : constant Int := Int (Count);
+ New_Last_As_Int : Int'Base;
+ New_Last : Index_Type;
- function "&" (Left, Right : Vector) return Vector is
+ Index : Extended_Index; -- TODO: see a-convec.adb.
- LN : constant Count_Type := Length (Left);
- RN : constant Count_Type := Length (Right);
+ Dst_Last : Index_Type;
+ Dst : Elements_Access;
begin
-
- if LN = 0 then
-
- if RN = 0 then
- return Empty_Vector;
- end if;
-
- declare
- RE : Elements_Type renames
- Right.Elements (Index_Type'First .. Right.Last);
-
- Elements : Elements_Access :=
- new Elements_Type (RE'Range);
- begin
- for I in Elements'Range loop
- begin
- if RE (I) /= null then
- Elements (I) := new Element_Type'(RE (I).all);
- end if;
- exception
- when others =>
- for J in Index_Type'First .. Index_Type'Pred (I) loop
- Free (Elements (J));
- end loop;
-
- Free (Elements);
- raise;
- end;
- end loop;
-
- return (Controlled with Elements, Right.Last);
- end;
-
+ if Before < Index_Type'First then
+ raise Constraint_Error;
end if;
- if RN = 0 then
-
- declare
- LE : Elements_Type renames
- Left.Elements (Index_Type'First .. Left.Last);
-
- Elements : Elements_Access :=
- new Elements_Type (LE'Range);
- begin
- for I in Elements'Range loop
- begin
- if LE (I) /= null then
- Elements (I) := new Element_Type'(LE (I).all);
- end if;
- exception
- when others =>
- for J in Index_Type'First .. Index_Type'Pred (I) loop
- Free (Elements (J));
- end loop;
-
- Free (Elements);
- raise;
- end;
- end loop;
-
- return (Controlled with Elements, Left.Last);
- end;
+ if Before > Container.Last
+ and then Before > Container.Last + 1
+ then
+ raise Constraint_Error;
+ end if;
+ if Count = 0 then
+ return;
end if;
declare
-
- Last_As_Int : constant Int'Base :=
- Int (Index_Type'First) + Int (LN) + Int (RN) - 1;
-
- Last : constant Index_Type := Index_Type (Last_As_Int);
-
- LE : Elements_Type renames
- Left.Elements (Index_Type'First .. Left.Last);
-
- RE : Elements_Type renames
- Right.Elements (Index_Type'First .. Right.Last);
-
- Elements : Elements_Access :=
- new Elements_Type (Index_Type'First .. Last);
-
- I : Index_Type'Base := Index_Type'Pred (Index_Type'First);
+ Old_Last_As_Int : constant Int := Int (Container.Last);
begin
-
- for LI in LE'Range loop
-
- I := Index_Type'Succ (I);
-
- begin
- if LE (LI) /= null then
- Elements (I) := new Element_Type'(LE (LI).all);
- end if;
- exception
- when others =>
- for J in Index_Type'First .. Index_Type'Pred (I) loop
- Free (Elements (J));
- end loop;
-
- Free (Elements);
- raise;
- end;
-
- end loop;
-
- for RI in RE'Range loop
-
- I := Index_Type'Succ (I);
-
- begin
- if RE (RI) /= null then
- Elements (I) := new Element_Type'(RE (RI).all);
- end if;
- exception
- when others =>
- for J in Index_Type'First .. Index_Type'Pred (I) loop
- Free (Elements (J));
- end loop;
-
- Free (Elements);
- raise;
- end;
-
- end loop;
-
- return (Controlled with Elements, Last);
+ New_Last_As_Int := Old_Last_As_Int + N;
+ New_Last := Index_Type (New_Last_As_Int);
end;
- end "&";
-
-
- function "&" (Left : Vector;
- Right : Element_Type) return Vector is
-
- LN : constant Count_Type := Length (Left);
-
- begin
-
- if LN = 0 then
-
- declare
- Elements : Elements_Access :=
- new Elements_Type (Index_Type'First .. Index_Type'First);
- begin
-
- begin
- Elements (Elements'First) := new Element_Type'(Right);
- exception
- when others =>
- Free (Elements);
- raise;
- end;
-
- return (Controlled with Elements, Index_Type'First);
-
- end;
-
+ if Container.Busy > 0 then
+ raise Program_Error;
end if;
declare
+ Old_First_As_Int : constant Int := Int (Before);
- Last_As_Int : constant Int'Base :=
- Int (Index_Type'First) + Int (LN);
-
- Last : constant Index_Type := Index_Type (Last_As_Int);
-
- LE : Elements_Type renames
- Left.Elements (Index_Type'First .. Left.Last);
-
- Elements : Elements_Access :=
- new Elements_Type (Index_Type'First .. Last);
+ New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
begin
+ Index := Extended_Index (New_First_As_Int); -- TODO
+ end;
- for I in LE'Range loop
-
- begin
- if LE (I) /= null then
- Elements (I) := new Element_Type'(LE (I).all);
- end if;
- exception
- when others =>
- for J in Index_Type'First .. Index_Type'Pred (I) loop
- Free (Elements (J));
- end loop;
-
- Free (Elements);
- raise;
- end;
-
- end loop;
-
- begin
- Elements (Elements'Last) := new Element_Type'(Right);
- exception
- when others =>
-
- declare
- subtype J_Subtype is Index_Type'Base range
- Index_Type'First .. Index_Type'Pred (Elements'Last);
- begin
- for J in J_Subtype loop
- Free (Elements (J));
- end loop;
- end;
-
- Free (Elements);
- raise;
- end;
-
- return (Controlled with Elements, Last);
- end;
-
- end "&";
-
-
-
- function "&" (Left : Element_Type;
- Right : Vector) return Vector is
-
- RN : constant Count_Type := Length (Right);
-
- begin
-
- if RN = 0 then
-
+ if Container.Elements = null then
declare
- Elements : Elements_Access :=
- new Elements_Type (Index_Type'First .. Index_Type'First);
+ subtype Elements_Subtype is
+ Elements_Type (Index_Type'First .. New_Last);
begin
+ Container.Elements := new Elements_Subtype;
+ Container.Last := New_Last;
+ end;
- begin
- Elements (Elements'First) := new Element_Type'(Left);
- exception
- when others =>
- Free (Elements);
- raise;
- end;
+ return;
+ end if;
- return (Controlled with Elements, Index_Type'First);
+ if New_Last <= Container.Elements'Last then
+ declare
+ E : Elements_Type renames Container.Elements.all;
+ begin
+ E (Index .. New_Last) := E (Before .. Container.Last);
+ E (Before .. Index_Type'Pred (Index)) := (others => null);
+ Container.Last := New_Last;
end;
+ return;
end if;
declare
+ First : constant Int := Int (Index_Type'First);
- Last_As_Int : constant Int'Base :=
- Int (Index_Type'First) + Int (RN);
+ New_Size : constant Int'Base :=
+ Int (New_Last_As_Int) - First + 1;
- Last : constant Index_Type := Index_Type (Last_As_Int);
+ Max_Size : constant Int'Base :=
+ Int (Index_Type'Last) - First + 1;
- RE : Elements_Type renames
- Right.Elements (Index_Type'First .. Right.Last);
+ Size, Dst_Last_As_Int : Int'Base;
- Elements : Elements_Access :=
- new Elements_Type (Index_Type'First .. Last);
+ begin
+ if New_Size >= Max_Size / 2 then
+ Dst_Last := Index_Type'Last;
- I : Index_Type'Base := Index_Type'First;
+ else
+ Size := Container.Elements'Length;
- begin
+ if Size = 0 then
+ Size := 1;
+ end if;
- begin
- Elements (I) := new Element_Type'(Left);
- exception
- when others =>
- Free (Elements);
- raise;
- end;
+ while Size < New_Size loop
+ Size := 2 * Size;
+ end loop;
- for RI in RE'Range loop
+ Dst_Last_As_Int := First + Size - 1;
+ Dst_Last := Index_Type (Dst_Last_As_Int);
+ end if;
+ end;
- I := Index_Type'Succ (I);
+ Dst := new Elements_Type (Index_Type'First .. Dst_Last);
- begin
- if RE (RI) /= null then
- Elements (I) := new Element_Type'(RE (RI).all);
- end if;
- exception
- when others =>
- for J in Index_Type'First .. Index_Type'Pred (I) loop
- Free (Elements (J));
- end loop;
+ declare
+ Src : Elements_Type renames Container.Elements.all;
- Free (Elements);
- raise;
- end;
+ begin
+ Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
+ Src (Index_Type'First .. Index_Type'Pred (Before));
- end loop;
+ Dst (Index .. New_Last) := Src (Before .. Container.Last);
+ end;
- return (Controlled with Elements, Last);
+ declare
+ X : Elements_Access := Container.Elements;
+ begin
+ Container.Elements := Dst;
+ Container.Last := New_Last;
+
+ Free (X);
end;
+ end Insert_Space;
- end "&";
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ Index : Index_Type'Base;
+
+ begin
+ if Before.Container /= null
+ and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
+ then
+ raise Program_Error;
+ end if;
+ if Count = 0 then
+ if Before.Container = null
+ or else Before.Index > Container.Last
+ then
+ Position := No_Element;
+ else
+ Position := (Container'Unchecked_Access, Before.Index);
+ end if;
- function "&" (Left, Right : Element_Type) return Vector is
+ return;
+ end if;
- subtype IT is Index_Type'Base range
- Index_Type'First .. Index_Type'Succ (Index_Type'First);
+ if Before.Container = null
+ or else Before.Index > Container.Last
+ then
+ Index := Index_Type'Succ (Container.Last);
+ else
+ Index := Before.Index;
+ end if;
- Elements : Elements_Access := new Elements_Type (IT);
+ Insert_Space (Container, Index, Count);
+ Position := Cursor'(Container'Unchecked_Access, Index);
+ end Insert_Space;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Vector) return Boolean is
begin
+ return Container.Last < Index_Type'First;
+ end Is_Empty;
- begin
- Elements (Elements'First) := new Element_Type'(Left);
- exception
- when others =>
- Free (Elements);
- raise;
- end;
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Vector;
+ Process : not null access procedure (Position : in Cursor))
+ is
+ V : Vector renames Container'Unrestricted_Access.all;
+ B : Natural renames V.Busy;
+
+ begin
+ B := B + 1;
begin
- Elements (Elements'Last) := new Element_Type'(Right);
+ for Indx in Index_Type'First .. Container.Last loop
+ Process (Cursor'(Container'Unchecked_Access, Indx));
+ end loop;
exception
when others =>
- Free (Elements (Elements'First));
- Free (Elements);
+ B := B - 1;
raise;
end;
- return (Controlled with Elements, Elements'Last);
-
- end "&";
+ B := B - 1;
+ end Iterate;
+ ----------
+ -- Last --
+ ----------
- function To_Cursor (Container : Vector;
- Index : Extended_Index)
- return Cursor is
+ function Last (Container : Vector) return Cursor is
begin
- if Index not in Index_Type'First .. Container.Last then
+ if Is_Empty (Container) then
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Index);
- end To_Cursor;
+ return (Container'Unchecked_Access, Container.Last);
+ end Last;
+ ------------------
+ -- Last_Element --
+ ------------------
- function To_Index (Position : Cursor) return Extended_Index is
+ function Last_Element (Container : Vector) return Element_Type is
begin
- if Position.Container = null then
- return No_Index;
- end if;
+ return Element (Container, Container.Last);
+ end Last_Element;
- if Position.Index <= Position.Container.Last then
- return Position.Index;
- end if;
+ ----------------
+ -- Last_Index --
+ ----------------
- return No_Index;
- end To_Index;
+ function Last_Index (Container : Vector) return Extended_Index is
+ begin
+ return Container.Last;
+ end Last_Index;
+ ------------
+ -- Length --
+ ------------
- function Element (Position : Cursor) return Element_Type is
+ function Length (Container : Vector) return Count_Type is
+ L : constant Int := Int (Container.Last);
+ F : constant Int := Int (Index_Type'First);
+ N : constant Int'Base := L - F + 1;
begin
- return Element (Position.Container.all, Position.Index);
- end Element;
+ return Count_Type (N);
+ end Length;
+ ----------
+ -- Move --
+ ----------
- function Next (Position : Cursor) return Cursor is
+ procedure Move
+ (Target : in out Vector;
+ Source : in out Vector)
+ is
begin
-
- if Position.Container = null then
- return No_Element;
+ if Target'Address = Source'Address then
+ return;
end if;
- if Position.Index < Position.Container.Last then
- return (Position.Container, Index_Type'Succ (Position.Index));
+ if Source.Busy > 0 then
+ raise Program_Error;
end if;
- return No_Element;
+ Clear (Target);
- end Next;
+ declare
+ X : Elements_Access := Target.Elements;
+ begin
+ Target.Elements := null;
+ Free (X);
+ end;
+ Target.Elements := Source.Elements;
+ Target.Last := Source.Last;
- function Previous (Position : Cursor) return Cursor is
- begin
+ Source.Elements := null;
+ Source.Last := No_Index;
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+ function Next (Position : Cursor) return Cursor is
+ begin
if Position.Container = null then
return No_Element;
end if;
- if Position.Index > Index_Type'First then
- return (Position.Container, Index_Type'Pred (Position.Index));
+ if Position.Index < Position.Container.Last then
+ return (Position.Container, Index_Type'Succ (Position.Index));
end if;
return No_Element;
+ end Next;
- end Previous;
-
+ ----------
+ -- Next --
+ ----------
procedure Next (Position : in out Cursor) is
begin
-
if Position.Container = null then
return;
end if;
else
Position := No_Element;
end if;
-
end Next;
+ -------------
+ -- Prepend --
+ -------------
- procedure Previous (Position : in out Cursor) is
+ procedure Prepend (Container : in out Vector; New_Item : Vector) is
+ begin
+ Insert (Container, Index_Type'First, New_Item);
+ end Prepend;
+
+ procedure Prepend
+ (Container : in out Vector;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
begin
+ Insert (Container,
+ Index_Type'First,
+ New_Item,
+ Count);
+ end Prepend;
+ --------------
+ -- Previous --
+ --------------
+
+ procedure Previous (Position : in out Cursor) is
+ begin
if Position.Container = null then
return;
end if;
else
Position := No_Element;
end if;
-
end Previous;
-
- function Has_Element (Position : Cursor) return Boolean is
+ function Previous (Position : Cursor) return Cursor is
begin
-
if Position.Container = null then
- return False;
+ return No_Element;
end if;
- return Position.Index <= Position.Container.Last;
-
- end Has_Element;
+ if Position.Index > Index_Type'First then
+ return (Position.Container, Index_Type'Pred (Position.Index));
+ end if;
+ return No_Element;
+ end Previous;
- procedure Iterate
- (Container : in Vector;
- Process : not null access procedure (Position : in Cursor)) is
- begin
+ -------------------
+ -- Query_Element --
+ -------------------
- for I in Index_Type'First .. Container.Last loop
- Process (Cursor'(Container'Unchecked_Access, I));
- end loop;
+ procedure Query_Element
+ (Container : Vector;
+ Index : Index_Type;
+ Process : not null access procedure (Element : in Element_Type))
+ is
+ subtype T is Index_Type'Base range
+ Index_Type'First .. Container.Last;
- end Iterate;
+ E : Element_Type renames Container.Elements (T'(Index)).all;
+ V : Vector renames Container'Unrestricted_Access.all;
+ B : Natural renames V.Busy;
+ L : Natural renames V.Lock;
- procedure Reverse_Iterate
- (Container : in Vector;
- Process : not null access procedure (Position : in Cursor)) is
begin
+ B := B + 1;
+ L := L + 1;
- for I in reverse Index_Type'First .. Container.Last loop
- Process (Cursor'(Container'Unchecked_Access, I));
- end loop;
-
- end Reverse_Iterate;
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+ L := L - 1;
+ B := B - 1;
+ end Query_Element;
procedure Query_Element
- (Position : in Cursor;
- Process : not null access procedure (Element : in Element_Type)) is
-
- C : Vector renames Position.Container.all;
- E : Elements_Type renames C.Elements.all;
-
- subtype T is Index_Type'Base range
- Index_Type'First .. C.Last;
+ (Position : Cursor;
+ Process : not null access procedure (Element : in Element_Type))
+ is
begin
- Process (E (T'(Position.Index)).all);
+ Query_Element (Position.Container.all, Position.Index, Process);
end Query_Element;
+ ----------
+ -- Read --
+ ----------
- procedure Update_Element
- (Position : in Cursor;
- Process : not null access procedure (Element : in out Element_Type)) is
+ procedure Read
+ (Stream : access Root_Stream_Type'Class;
+ Container : out Vector)
+ is
+ Length : Count_Type'Base;
+ Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
- C : Vector renames Position.Container.all;
- E : Elements_Type renames C.Elements.all;
+ B : Boolean;
- subtype T is Index_Type'Base range
- Index_Type'First .. C.Last;
begin
- Process (E (T'(Position.Index)).all);
- end Update_Element;
+ Clear (Container);
+ Count_Type'Base'Read (Stream, Length);
- procedure Replace_Element (Position : in Cursor;
- By : in Element_Type) is
+ if Length > Capacity (Container) then
+ Reserve_Capacity (Container, Capacity => Length);
+ end if;
- C : Vector renames Position.Container.all;
- E : Elements_Type renames C.Elements.all;
+ for J in Count_Type range 1 .. Length loop
+ Last := Index_Type'Succ (Last);
- subtype T is Index_Type'Base range
- Index_Type'First .. C.Last;
+ Boolean'Read (Stream, B);
- X : Element_Access := E (T'(Position.Index));
- begin
- E (T'(Position.Index)) := new Element_Type'(By);
- Free (X);
- end Replace_Element;
+ if B then
+ Container.Elements (Last) :=
+ new Element_Type'(Element_Type'Input (Stream));
+ end if;
+
+ Container.Last := Last;
+ end loop;
+ end Read;
+ ---------------------
+ -- Replace_Element --
+ ---------------------
- procedure Insert (Container : in out Vector;
- Before : in Extended_Index;
- New_Item : in Vector) is
+ procedure Replace_Element
+ (Container : Vector;
+ Index : Index_Type;
+ By : Element_Type)
+ is
+ subtype T is Index_Type'Base range
+ Index_Type'First .. Container.Last;
- N : constant Count_Type := Length (New_Item);
+ X : Element_Access := Container.Elements (T'(Index));
begin
-
- if N = 0 then
- return;
+ if Container.Lock > 0 then
+ raise Program_Error;
end if;
- Insert_Space (Container, Before, Count => N);
-
- if Container'Address = New_Item'Address then
-
- declare
- Dst_Last_As_Int : constant Int'Base :=
- Int'Base (Before) + Int'Base (N) - 1;
+ Container.Elements (T'(Index)) := new Element_Type'(By);
+ Free (X);
+ end Replace_Element;
- Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
+ procedure Replace_Element (Position : Cursor; By : Element_Type) is
+ begin
+ Replace_Element (Position.Container.all, Position.Index, By);
+ end Replace_Element;
- Dst_Index : Index_Type'Base := Index_Type'Pred (Before);
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
- Dst : Elements_Type renames
- Container.Elements (Before .. Dst_Last);
- begin
+ procedure Reserve_Capacity
+ (Container : in out Vector;
+ Capacity : Count_Type)
+ is
+ N : constant Count_Type := Length (Container);
+ begin
+ if Capacity = 0 then
+ if N = 0 then
declare
- subtype Src_Index_Subtype is Index_Type'Base range
- Index_Type'First .. Index_Type'Pred (Before);
-
- Src : Elements_Type renames
- Container.Elements (Src_Index_Subtype);
+ X : Elements_Access := Container.Elements;
begin
- for Src_Index in Src'Range loop
- Dst_Index := Index_Type'Succ (Dst_Index);
-
- if Src (Src_Index) /= null then
- Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
- end if;
- end loop;
+ Container.Elements := null;
+ Free (X);
end;
+ elsif N < Container.Elements'Length then
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
declare
- subtype Src_Index_Subtype is Index_Type'Base range
- Index_Type'Succ (Dst_Last) .. Container.Last;
+ subtype Array_Index_Subtype is Index_Type'Base range
+ Index_Type'First .. Container.Last;
Src : Elements_Type renames
- Container.Elements (Src_Index_Subtype);
- begin
- for Src_Index in Src'Range loop
- Dst_Index := Index_Type'Succ (Dst_Index);
+ Container.Elements (Array_Index_Subtype);
- if Src (Src_Index) /= null then
- Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
- end if;
- end loop;
+ subtype Array_Subtype is
+ Elements_Type (Array_Index_Subtype);
+
+ X : Elements_Access := Container.Elements;
+ begin
+ Container.Elements := new Array_Subtype'(Src);
+ Free (X);
end;
- end;
+ end if;
- else
+ return;
+ end if;
+ if Container.Elements = null then
declare
- Dst_Last_As_Int : constant Int'Base :=
- Int'Base (Before) + Int'Base (N) - 1;
-
- Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
+ Last_As_Int : constant Int'Base :=
+ Int (Index_Type'First) + Int (Capacity) - 1;
- Dst_Index : Index_Type'Base := Index_Type'Pred (Before);
+ Last : constant Index_Type :=
+ Index_Type (Last_As_Int);
- Src : Elements_Type renames
- New_Item.Elements (Index_Type'First .. New_Item.Last);
+ subtype Array_Subtype is
+ Elements_Type (Index_Type'First .. Last);
- Dst : Elements_Type renames
- Container.Elements (Before .. Dst_Last);
begin
- for Src_Index in Src'Range loop
- Dst_Index := Index_Type'Succ (Dst_Index);
-
- if Src (Src_Index) /= null then
- Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
- end if;
- end loop;
+ Container.Elements := new Array_Subtype;
end;
- end if;
-
- end Insert;
-
-
- procedure Insert (Container : in out Vector;
- Before : in Cursor;
- New_Item : in Vector) is
-
- Index : Index_Type'Base;
-
- begin
-
- if Before.Container /= null
- and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
- then
- raise Program_Error;
- end if;
-
- if Is_Empty (New_Item) then
return;
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
- Index := Index_Type'Succ (Container.Last);
- else
- Index := Before.Index;
- end if;
-
- Insert (Container, Index, New_Item);
-
- end Insert;
-
-
+ if Capacity <= N then
+ if N < Container.Elements'Length then
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
- procedure Insert (Container : in out Vector;
- Before : in Cursor;
- New_Item : in Vector;
- Position : out Cursor) is
+ declare
+ subtype Array_Index_Subtype is Index_Type'Base range
+ Index_Type'First .. Container.Last;
- Index : Index_Type'Base;
+ Src : Elements_Type renames
+ Container.Elements (Array_Index_Subtype);
- begin
+ subtype Array_Subtype is
+ Elements_Type (Array_Index_Subtype);
- if Before.Container /= null
- and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
- then
- raise Program_Error;
- end if;
+ X : Elements_Access := Container.Elements;
- if Is_Empty (New_Item) then
+ begin
+ Container.Elements := new Array_Subtype'(Src);
+ Free (X);
+ end;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
- Position := No_Element;
- else
- Position := (Container'Unchecked_Access, Before.Index);
end if;
return;
-
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
- Index := Index_Type'Succ (Container.Last);
- else
- Index := Before.Index;
+ if Capacity = Container.Elements'Length then
+ return;
end if;
- Insert (Container, Index, New_Item);
-
- Position := (Container'Unchecked_Access, Index);
-
- end Insert;
-
-
- procedure Insert (Container : in out Vector;
- Before : in Cursor;
- New_Item : in Element_Type;
- Count : in Count_Type := 1) is
-
- Index : Index_Type'Base;
-
- begin
-
- if Before.Container /= null
- and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
- then
+ if Container.Busy > 0 then
raise Program_Error;
end if;
- if Count = 0 then
- return;
- end if;
-
- if Before.Container = null
- or else Before.Index > Container.Last
- then
- Index := Index_Type'Succ (Container.Last);
- else
- Index := Before.Index;
- end if;
+ declare
+ Last_As_Int : constant Int'Base :=
+ Int (Index_Type'First) + Int (Capacity) - 1;
- Insert (Container, Index, New_Item, Count);
+ Last : constant Index_Type := Index_Type (Last_As_Int);
- end Insert;
+ subtype Array_Subtype is
+ Elements_Type (Index_Type'First .. Last);
+ X : Elements_Access := Container.Elements;
- procedure Insert (Container : in out Vector;
- Before : in Cursor;
- New_Item : in Element_Type;
- Position : out Cursor;
- Count : in Count_Type := 1) is
+ begin
+ Container.Elements := new Array_Subtype;
- Index : Index_Type'Base;
+ declare
+ Src : Elements_Type renames
+ X (Index_Type'First .. Container.Last);
- begin
+ Tgt : Elements_Type renames
+ Container.Elements (Index_Type'First .. Container.Last);
- if Before.Container /= null
- and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
- then
- raise Program_Error;
- end if;
+ begin
+ Tgt := Src;
+ end;
- if Count = 0 then
+ Free (X);
+ end;
+ end Reserve_Capacity;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
- Position := No_Element;
- else
- Position := (Container'Unchecked_Access, Before.Index);
- end if;
+ ------------------
+ -- Reverse_Find --
+ ------------------
- return;
+ function Reverse_Find
+ (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor
+ is
+ Last : Index_Type'Base;
+ begin
+ if Position.Container /= null
+ and then Position.Container /=
+ Vector_Access'(Container'Unchecked_Access)
+ then
+ raise Program_Error;
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
+ if Position.Container = null
+ or else Position.Index > Container.Last
then
- Index := Index_Type'Succ (Container.Last);
+ Last := Container.Last;
else
- Index := Before.Index;
+ Last := Position.Index;
end if;
- Insert (Container, Index, New_Item, Count);
-
- Position := (Container'Unchecked_Access, Index);
+ for Indx in reverse Index_Type'First .. Last loop
+ if Container.Elements (Indx) /= null
+ and then Container.Elements (Indx).all = Item
+ then
+ return (Container'Unchecked_Access, Indx);
+ end if;
+ end loop;
- end Insert;
+ return No_Element;
+ end Reverse_Find;
+ ------------------------
+ -- Reverse_Find_Index --
+ ------------------------
+ function Reverse_Find_Index
+ (Container : Vector;
+ Item : Element_Type;
+ Index : Index_Type := Index_Type'Last) return Extended_Index
+ is
+ Last : Index_Type'Base;
- procedure Prepend (Container : in out Vector;
- New_Item : in Vector) is
begin
- Insert (Container, Index_Type'First, New_Item);
- end Prepend;
+ if Index > Container.Last then
+ Last := Container.Last;
+ else
+ Last := Index;
+ end if;
+
+ for Indx in reverse Index_Type'First .. Last loop
+ if Container.Elements (Indx) /= null
+ and then Container.Elements (Indx).all = Item
+ then
+ return Indx;
+ end if;
+ end loop;
+ return No_Index;
+ end Reverse_Find_Index;
- procedure Append (Container : in out Vector;
- New_Item : in Vector) is
- begin
- if Is_Empty (New_Item) then
- return;
- end if;
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
- Insert
- (Container,
- Index_Type'Succ (Container.Last),
- New_Item);
- end Append;
+ procedure Reverse_Iterate
+ (Container : Vector;
+ Process : not null access procedure (Position : in Cursor))
+ is
+ V : Vector renames Container'Unrestricted_Access.all;
+ B : Natural renames V.Busy;
+
+ begin
+ B := B + 1;
+ begin
+ for Indx in reverse Index_Type'First .. Container.Last loop
+ Process (Cursor'(Container'Unchecked_Access, Indx));
+ end loop;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+ B := B - 1;
+ end Reverse_Iterate;
- procedure Insert_Space (Container : in out Vector;
- Before : in Cursor;
- Position : out Cursor;
- Count : in Count_Type := 1) is
+ ----------------
+ -- Set_Length --
+ ----------------
- Index : Index_Type'Base;
+ procedure Set_Length
+ (Container : in out Vector;
+ Length : Count_Type)
+ is
+ N : constant Count_Type := Indefinite_Vectors.Length (Container);
begin
+ if Length = N then
+ return;
+ end if;
- if Before.Container /= null
- and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
- then
+ if Length = 0 then
+ Clear (Container);
+ return;
+ end if;
+
+ if Container.Busy > 0 then
raise Program_Error;
end if;
- if Count = 0 then
+ declare
+ Last_As_Int : constant Int'Base :=
+ Int (Index_Type'First) + Int (Length) - 1;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
- Position := No_Element;
- else
- Position := (Container'Unchecked_Access, Before.Index);
- end if;
+ Last : constant Index_Type :=
+ Index_Type (Last_As_Int);
- return;
+ begin
+ if Length > N then
+ if Length > Capacity (Container) then
+ Reserve_Capacity (Container, Capacity => Length);
+ end if;
- end if;
+ Container.Last := Last;
+ return;
+ end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
- Index := Index_Type'Succ (Container.Last);
- else
- Index := Before.Index;
- end if;
+ for Indx in reverse Index_Type'Succ (Last) .. Container.Last loop
+ declare
+ X : Element_Access := Container.Elements (Indx);
- Insert_Space (Container, Index, Count);
+ begin
+ Container.Elements (Indx) := null;
+ Container.Last := Index_Type'Pred (Container.Last);
+ Free (X);
+ end;
+ end loop;
+ end;
+ end Set_Length;
- Position := (Container'Unchecked_Access, Index);
+ ----------
+ -- Swap --
+ ----------
- end Insert_Space;
+ procedure Swap
+ (Container : Vector;
+ I, J : Index_Type)
+ is
+ subtype T is Index_Type'Base range
+ Index_Type'First .. Container.Last;
+ EI : Element_Type renames Container.Elements (T'(I)).all;
+ EJ : Element_Type renames Container.Elements (T'(J)).all;
- procedure Delete (Container : in out Vector;
- Position : in out Cursor;
- Count : in Count_Type := 1) is
begin
-
- if Position.Container /= null
- and then Position.Container /=
- Vector_Access'(Container'Unchecked_Access)
- then
+ if Container.Lock > 0 then
raise Program_Error;
end if;
- if Position.Container = null
- or else Position.Index > Container.Last
+ declare
+ EI_Copy : constant Element_Type := EI;
+ begin
+ EI := EJ;
+ EJ := EI_Copy;
+ end;
+ end Swap;
+
+ procedure Swap (I, J : Cursor)
+ is
+ begin
+ if I.Container = null
+ or else J.Container = null
then
- Position := No_Element;
- return;
+ raise Constraint_Error;
end if;
- Delete (Container, Position.Index, Count);
-
- if Position.Index <= Container.Last then
- Position := (Container'Unchecked_Access, Position.Index);
- else
- Position := No_Element;
+ if I.Container /= J.Container then
+ raise Program_Error;
end if;
- end Delete;
+ Swap (I.Container.all, I.Index, J.Index);
+ end Swap;
+ ---------------
+ -- To_Cursor --
+ ---------------
- function First (Container : Vector) return Cursor is
+ function To_Cursor
+ (Container : Vector;
+ Index : Extended_Index) return Cursor
+ is
begin
- if Is_Empty (Container) then
+ if Index not in Index_Type'First .. Container.Last then
return No_Element;
end if;
- return (Container'Unchecked_Access, Index_Type'First);
- end First;
+ return Cursor'(Container'Unchecked_Access, Index);
+ end To_Cursor;
+ --------------
+ -- To_Index --
+ --------------
- function Last (Container : Vector) return Cursor is
+ function To_Index (Position : Cursor) return Extended_Index is
begin
- if Is_Empty (Container) then
- return No_Element;
+ if Position.Container = null then
+ return No_Index;
end if;
- return (Container'Unchecked_Access, Container.Last);
- end Last;
+ if Position.Index <= Position.Container.Last then
+ return Position.Index;
+ end if;
+ return No_Index;
+ end To_Index;
- procedure Swap (I, J : in Cursor) is
+ ---------------
+ -- To_Vector --
+ ---------------
- -- NOTE: I've liberalized the behavior here, to
- -- allow I and J to designate different containers.
- -- TODO: I think this is suppose to raise P_E.
+ function To_Vector (Length : Count_Type) return Vector is
+ begin
+ if Length = 0 then
+ return Empty_Vector;
+ end if;
- subtype TI is Index_Type'Base range
- Index_Type'First .. I.Container.Last;
+ declare
+ First : constant Int := Int (Index_Type'First);
+ Last_As_Int : constant Int'Base := First + Int (Length) - 1;
+ Last : constant Index_Type := Index_Type (Last_As_Int);
+ Elements : constant Elements_Access :=
+ new Elements_Type (Index_Type'First .. Last);
+ begin
+ return (Controlled with Elements, Last, 0, 0);
+ end;
+ end To_Vector;
- EI : Element_Access renames
- I.Container.Elements (TI'(I.Index));
+ function To_Vector
+ (New_Item : Element_Type;
+ Length : Count_Type) return Vector
+ is
+ begin
+ if Length = 0 then
+ return Empty_Vector;
+ end if;
- EI_Copy : constant Element_Access := EI;
+ declare
+ First : constant Int := Int (Index_Type'First);
+ Last_As_Int : constant Int'Base := First + Int (Length) - 1;
+ Last : constant Index_Type := Index_Type (Last_As_Int);
+ Elements : Elements_Access :=
+ new Elements_Type (Index_Type'First .. Last);
+ begin
+ for Indx in Elements'Range loop
+ begin
+ Elements (Indx) := new Element_Type'(New_Item);
+ exception
+ when others =>
+ for J in Index_Type'First .. Index_Type'Pred (Indx) loop
+ Free (Elements (J));
+ end loop;
- subtype TJ is Index_Type'Base range
- Index_Type'First .. J.Container.Last;
+ Free (Elements);
+ raise;
+ end;
- EJ : Element_Access renames
- J.Container.Elements (TJ'(J.Index));
+ end loop;
- begin
+ return (Controlled with Elements, Last, 0, 0);
+ end;
+ end To_Vector;
- EI := EJ;
- EJ := EI_Copy;
+ --------------------
+ -- Update_Element --
+ --------------------
- end Swap;
+ procedure Update_Element
+ (Container : Vector;
+ Index : Index_Type;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ subtype T is Index_Type'Base range
+ Index_Type'First .. Container.Last;
+ E : Element_Type renames Container.Elements (T'(Index)).all;
- function Find (Container : Vector;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor is
+ V : Vector renames Container'Unrestricted_Access.all;
+ B : Natural renames V.Busy;
+ L : Natural renames V.Lock;
begin
+ B := B + 1;
+ L := L + 1;
- if Position.Container /= null
- and then Position.Container /=
- Vector_Access'(Container'Unchecked_Access)
- then
- raise Program_Error;
- end if;
-
- for I in Position.Index .. Container.Last loop
- if Container.Elements (I) /= null
- and then Container.Elements (I).all = Item
- then
- return (Container'Unchecked_Access, I);
- end if;
- end loop;
-
- return No_Element;
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
- end Find;
+ L := L - 1;
+ B := B - 1;
+ end Update_Element;
+ procedure Update_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ Update_Element (Position.Container.all, Position.Index, Process);
+ end Update_Element;
- function Reverse_Find (Container : Vector;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor is
+ -----------
+ -- Write --
+ -----------
- Last : Index_Type'Base;
+ procedure Write
+ (Stream : access Root_Stream_Type'Class;
+ Container : Vector)
+ is
+ N : constant Count_Type := Length (Container);
begin
+ Count_Type'Base'Write (Stream, N);
- if Position.Container /= null
- and then Position.Container /=
- Vector_Access'(Container'Unchecked_Access)
- then
- raise Program_Error;
- end if;
-
- if Position.Container = null
- or else Position.Index > Container.Last
- then
- Last := Container.Last;
- else
- Last := Position.Index;
+ if N = 0 then
+ return;
end if;
- for I in reverse Index_Type'First .. Last loop
- if Container.Elements (I) /= null
- and then Container.Elements (I).all = Item
- then
- return (Container'Unchecked_Access, I);
- end if;
- end loop;
+ declare
+ E : Elements_Type renames Container.Elements.all;
- return No_Element;
+ begin
+ for Indx in Index_Type'First .. Container.Last loop
- end Reverse_Find;
+ -- There's another way to do this. Instead a separate
+ -- Boolean for each element, you could write a Boolean
+ -- followed by a count of how many nulls or non-nulls
+ -- follow in the array. Alternately you could use a
+ -- signed integer, and use the sign as the indicator
+ -- of null-ness.
+ if E (Indx) = null then
+ Boolean'Write (Stream, False);
+ else
+ Boolean'Write (Stream, True);
+ Element_Type'Output (Stream, E (Indx).all);
+ end if;
+ end loop;
+ end;
+ end Write;
end Ada.Containers.Indefinite_Vectors;
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.INDEFINITE_VECTORS --
+-- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
procedure Delete
(Container : in out Vector;
- Index : Extended_Index; -- TODO: verify
+ Index : Extended_Index;
Count : Count_Type := 1);
procedure Delete
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
- procedure Generic_Sort (Container : Vector);
+ package Generic_Sorting is
+
+ function Is_Sorted (Container : Vector) return Boolean;
+
+ procedure Sort (Container : in out Vector);
+
+ procedure Merge (Target, Source : in out Vector);
+
+ end Generic_Sorting;
function Find_Index
(Container : Vector;
type Vector is new Controlled with record
Elements : Elements_Access;
Last : Extended_Index := No_Index;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
end record;
procedure Adjust (Container : in out Vector);
for Vector'Read use Read;
- Empty_Vector : constant Vector := Vector'(Controlled with null, No_Index);
+ Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0);
type Vector_Access is access constant Vector;
for Vector_Access'Storage_Size use 0;
No_Element : constant Cursor := Cursor'(null, Index_Type'First);
end Ada.Containers.Indefinite_Vectors;
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.VECTORS --
+-- A D A . C O N T A I N E R S . V E C T O R S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
new Elements_Type'(RE);
begin
- return (Controlled with Elements, Right.Last);
+ return (Controlled with Elements, Right.Last, 0, 0);
end;
end if;
new Elements_Type'(LE);
begin
- return (Controlled with Elements, Left.Last);
+ return (Controlled with Elements, Left.Last, 0, 0);
end;
end if;
declare
- Last_As_Int : constant Int'Base :=
+ Last_As_Int : constant Int'Base := -- TODO: handle overflow
Int (Index_Type'First) + Int (LN) + Int (RN) - 1;
- Last : constant Index_Type := Index_Type (Last_As_Int);
+ begin
+ if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
+ raise Constraint_Error;
+ end if;
- LE : Elements_Type renames
- Left.Elements (Index_Type'First .. Left.Last);
+ declare
+ Last : constant Index_Type := Index_Type (Last_As_Int);
- RE : Elements_Type renames
- Right.Elements (Index_Type'First .. Right.Last);
+ LE : Elements_Type renames
+ Left.Elements (Index_Type'First .. Left.Last);
- Elements : constant Elements_Access :=
+ RE : Elements_Type renames
+ Right.Elements (Index_Type'First .. Right.Last);
+
+ Elements : constant Elements_Access :=
new Elements_Type'(LE & RE);
- begin
- return (Controlled with Elements, Last);
+ begin
+ return (Controlled with Elements, Last, 0, 0);
+ end;
end;
end "&";
new Elements_Subtype'(others => Right);
begin
- return (Controlled with Elements, Index_Type'First);
+ return (Controlled with Elements, Index_Type'First, 0, 0);
end;
end if;
declare
- Last_As_Int : constant Int'Base :=
+ Last_As_Int : constant Int'Base := -- TODO: handle overflow
Int (Index_Type'First) + Int (LN);
- Last : constant Index_Type := Index_Type (Last_As_Int);
+ begin
+ if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
+ raise Constraint_Error;
+ end if;
- LE : Elements_Type renames
- Left.Elements (Index_Type'First .. Left.Last);
+ declare
+ Last : constant Index_Type := Index_Type (Last_As_Int);
- subtype ET is Elements_Type (Index_Type'First .. Last);
+ LE : Elements_Type renames
+ Left.Elements (Index_Type'First .. Left.Last);
- Elements : constant Elements_Access := new ET'(LE & Right);
+ subtype ET is Elements_Type (Index_Type'First .. Last);
- begin
- return (Controlled with Elements, Last);
+ Elements : constant Elements_Access := new ET'(LE & Right);
+
+ begin
+ return (Controlled with Elements, Last, 0, 0);
+ end;
end;
end "&";
new Elements_Subtype'(others => Left);
begin
- return (Controlled with Elements, Index_Type'First);
+ return (Controlled with Elements, Index_Type'First, 0, 0);
end;
end if;
declare
- Last_As_Int : constant Int'Base :=
+ Last_As_Int : constant Int'Base := -- TODO: handle overflow
Int (Index_Type'First) + Int (RN);
- Last : constant Index_Type := Index_Type (Last_As_Int);
+ begin
+ if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
+ raise Constraint_Error;
+ end if;
- RE : Elements_Type renames
- Right.Elements (Index_Type'First .. Right.Last);
+ declare
+ Last : constant Index_Type := Index_Type (Last_As_Int);
- subtype ET is Elements_Type (Index_Type'First .. Last);
+ RE : Elements_Type renames
+ Right.Elements (Index_Type'First .. Right.Last);
- Elements : constant Elements_Access := new ET'(Left & RE);
+ subtype ET is Elements_Type (Index_Type'First .. Last);
- begin
- return (Controlled with Elements, Last);
+ Elements : constant Elements_Access := new ET'(Left & RE);
+
+ begin
+ return (Controlled with Elements, Last, 0, 0);
+ end;
end;
end "&";
function "&" (Left, Right : Element_Type) return Vector is
- subtype IT is Index_Type'Base range
- Index_Type'First .. Index_Type'Succ (Index_Type'First);
+ begin
+ if Index_Type'First >= Index_Type'Last then
+ raise Constraint_Error;
+ end if;
- subtype ET is Elements_Type (IT);
+ declare
+ Last : constant Index_Type := Index_Type'First + 1;
- Elements : constant Elements_Access := new ET'(Left, Right);
+ subtype ET is Elements_Type (Index_Type'First .. Last);
- begin
- return Vector'(Controlled with Elements, Elements'Last);
+ Elements : constant Elements_Access := new ET'(Left, Right);
+
+ begin
+ return (Controlled with Elements, Last, 0, 0);
+ end;
end "&";
---------
procedure Adjust (Container : in out Vector) is
begin
- if Container.Elements = null then
- return;
- end if;
-
- if Container.Elements'Length = 0
- or else Container.Last < Index_Type'First
- then
+ if Container.Last = No_Index then
Container.Elements := null;
return;
end if;
declare
- X : constant Elements_Access := Container.Elements;
- L : constant Index_Type'Base := Container.Last;
- E : Elements_Type renames X (Index_Type'First .. L);
+ E : constant Elements_Access := Container.Elements;
+ L : constant Index_Type := Container.Last;
+
begin
Container.Elements := null;
- Container.Last := Index_Type'Pred (Index_Type'First);
- Container.Elements := new Elements_Type'(E);
+ Container.Last := No_Index;
+ Container.Busy := 0;
+ Container.Lock := 0;
+ Container.Elements := new Elements_Type'(E (Index_Type'First .. L));
Container.Last := L;
end;
end Adjust;
return;
end if;
+ if Container.Last = Index_Type'Last then
+ raise Constraint_Error;
+ end if;
+
Insert
(Container,
- Index_Type'Succ (Container.Last),
+ Container.Last + 1,
New_Item);
end Append;
return;
end if;
+ if Container.Last = Index_Type'Last then
+ raise Constraint_Error;
+ end if;
+
Insert
(Container,
- Index_Type'Succ (Container.Last),
+ Container.Last + 1,
New_Item,
Count);
end Append;
procedure Clear (Container : in out Vector) is
begin
- Container.Last := Index_Type'Pred (Index_Type'First);
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ Container.Last := No_Index;
end Clear;
--------------
Count : Count_Type := 1)
is
begin
- if Count = 0 then
- return;
+ if Index < Index_Type'First then
+ raise Constraint_Error;
end if;
- declare
- subtype I_Subtype is Index_Type'Base range
- Index_Type'First .. Container.Last;
+ if Index > Container.Last then
+ if Index > Container.Last + 1 then
+ raise Constraint_Error;
+ end if;
- I : constant I_Subtype := Index;
- -- TODO: not sure whether to relax this check ???
+ return;
+ end if;
- I_As_Int : constant Int := Int (I);
+ if Count = 0 then
+ return;
+ end if;
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ declare
+ I_As_Int : constant Int := Int (Index);
Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
Count1 : constant Int'Base := Count_Type'Pos (Count);
Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
-
- N : constant Int'Base := Int'Min (Count1, Count2);
+ N : constant Int'Base := Int'Min (Count1, Count2);
J_As_Int : constant Int'Base := I_As_Int + N;
- J : constant Index_Type'Base := Index_Type'Base (J_As_Int);
- E : Elements_Type renames Container.Elements.all;
+ begin
+ if J_As_Int > Old_Last_As_Int then
+ Container.Last := Index - 1;
- New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
+ else
+ declare
+ J : constant Index_Type := Index_Type (J_As_Int);
+ E : Elements_Type renames Container.Elements.all;
- New_Last : constant Extended_Index :=
- Extended_Index (New_Last_As_Int);
+ New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
+ New_Last : constant Index_Type :=
+ Index_Type (New_Last_As_Int);
- begin
- E (I .. New_Last) := E (J .. Container.Last);
- Container.Last := New_Last;
+ begin
+ E (Index .. New_Last) := E (J .. Container.Last);
+ Container.Last := New_Last;
+ end;
+ end if;
end;
end Delete;
Count : Count_Type := 1)
is
begin
-
- if Position.Container /= null
- and then Position.Container /=
- Vector_Access'(Container'Unchecked_Access)
- then
- raise Program_Error;
+ if Position.Container = null then
+ raise Constraint_Error;
end if;
- if Position.Container = null
+ if Position.Container /=
+ Vector_Access'(Container'Unchecked_Access)
or else Position.Index > Container.Last
then
- Position := No_Element;
- return;
+ raise Program_Error;
end if;
Delete (Container, Position.Index, Count);
return;
end if;
- if Count >= Length (Container) then
- Clear (Container);
- return;
+ if Container.Busy > 0 then
+ raise Program_Error;
end if;
- Index := Int'Base (Container.Last) - Int'Base (Count) + 1;
+ Index := Int'Base (Container.Last) - Int'Base (Count);
- Delete (Container, Index_Type'Base (Index), Count);
+ if Index < Index_Type'Pos (Index_Type'First) then
+ Container.Last := No_Index;
+ else
+ Container.Last := Index_Type (Index);
+ end if;
end Delete_Last;
-------------
(Container : Vector;
Index : Index_Type) return Element_Type
is
- subtype T is Index_Type'Base range
- Index_Type'First .. Container.Last;
begin
- return Container.Elements (T'(Index));
+ if Index > Container.Last then
+ raise Constraint_Error;
+ end if;
+
+ return Container.Elements (Index);
end Element;
function Element (Position : Cursor) return Element_Type is
begin
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
+
return Element (Position.Container.all, Position.Index);
end Element;
procedure Finalize (Container : in out Vector) is
X : Elements_Access := Container.Elements;
begin
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
Container.Elements := null;
- Container.Last := Index_Type'Pred (Index_Type'First);
+ Container.Last := No_Index;
Free (X);
end Finalize;
begin
if Position.Container /= null
- and then Position.Container /=
- Vector_Access'(Container'Unchecked_Access)
+ and then (Position.Container /=
+ Vector_Access'(Container'Unchecked_Access)
+ or else Position.Index > Container.Last)
then
raise Program_Error;
end if;
return Index_Type'First;
end First_Index;
- ------------------
- -- Generic_Sort --
- ------------------
+ ---------------------
+ -- Generic_Sorting --
+ ---------------------
- procedure Generic_Sort (Container : Vector)
- is
- procedure Sort is
- new Generic_Array_Sort
- (Index_Type => Index_Type,
- Element_Type => Element_Type,
- Array_Type => Elements_Type,
- "<" => "<");
+ package body Generic_Sorting is
- begin
- if Container.Elements = null then
- return;
- end if;
+ ---------------
+ -- Is_Sorted --
+ ---------------
+
+ function Is_Sorted (Container : Vector) return Boolean is
+ begin
+ if Container.Last <= Index_Type'First then
+ return True;
+ end if;
+
+ declare
+ E : Elements_Type renames Container.Elements.all;
+ begin
+ for I in Index_Type'First .. Container.Last - 1 loop
+ if E (I + 1) < E (I) then
+ return False;
+ end if;
+ end loop;
+ end;
+
+ return True;
+ end Is_Sorted;
+
+ -----------
+ -- Merge --
+ -----------
- Sort (Container.Elements (Index_Type'First .. Container.Last));
- end Generic_Sort;
+ procedure Merge (Target, Source : in out Vector) is
+ I : Index_Type'Base := Target.Last;
+ J : Index_Type'Base;
+
+ begin
+ if Target.Last < Index_Type'First then
+ Move (Target => Target, Source => Source);
+ return;
+ end if;
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Last < Index_Type'First then
+ return;
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ Target.Set_Length (Length (Target) + Length (Source));
+
+ J := Target.Last;
+ while Source.Last >= Index_Type'First loop
+ if I < Index_Type'First then
+ Target.Elements (Index_Type'First .. J) :=
+ Source.Elements (Index_Type'First .. Source.Last);
+
+ Source.Last := No_Index;
+ return;
+ end if;
+
+ if Source.Elements (Source.Last) < Target.Elements (I) then
+ Target.Elements (J) := Target.Elements (I);
+ I := I - 1;
+
+ else
+ Target.Elements (J) := Source.Elements (Source.Last);
+ Source.Last := Source.Last - 1;
+ end if;
+
+ J := J - 1;
+ end loop;
+ end Merge;
+
+ ----------
+ -- Sort --
+ ----------
+
+ procedure Sort (Container : in out Vector)
+ is
+ procedure Sort is
+ new Generic_Array_Sort
+ (Index_Type => Index_Type,
+ Element_Type => Element_Type,
+ Array_Type => Elements_Type,
+ "<" => "<");
+
+ begin
+ if Container.Last <= Index_Type'First then
+ return;
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error;
+ end if;
+
+ Sort (Container.Elements (Index_Type'First .. Container.Last));
+ end Sort;
+
+ end Generic_Sorting;
-----------------
-- Has_Element --
New_Item : Element_Type;
Count : Count_Type := 1)
is
- Old_Last : constant Extended_Index := Container.Last;
-
- Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);
-
N : constant Int := Count_Type'Pos (Count);
- New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N;
+ New_Last_As_Int : Int'Base;
+ New_Last : Index_Type;
- New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int);
+ Dst : Elements_Access;
- Index : Index_Type;
+ begin
+ if Before < Index_Type'First then
+ raise Constraint_Error;
+ end if;
- Dst_Last : Index_Type;
- Dst : Elements_Access;
+ if Before > Container.Last
+ and then Before > Container.Last + 1
+ then
+ raise Constraint_Error;
+ end if;
- begin
if Count = 0 then
return;
end if;
declare
- subtype Before_Subtype is Index_Type'Base range
- Index_Type'First .. Index_Type'Succ (Container.Last);
+ Old_Last : constant Extended_Index := Container.Last;
- Old_First : constant Before_Subtype := Before;
+ Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);
- Old_First_As_Int : constant Int := Index_Type'Pos (Old_First);
+ begin
+ New_Last_As_Int := Old_Last_As_Int + N;
- New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
+ if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then
+ raise Constraint_Error;
+ end if;
- begin
- Index := Index_Type (New_First_As_Int);
+ New_Last := Index_Type (New_Last_As_Int);
end;
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
if Container.Elements = null then
declare
subtype Elements_Subtype is
declare
E : Elements_Type renames Container.Elements.all;
begin
- E (Index .. New_Last) := E (Before .. Container.Last);
- E (Before .. Index_Type'Pred (Index)) := (others => New_Item);
+ if Before <= Container.Last then
+ declare
+ Index_As_Int : constant Int'Base :=
+ Index_Type'Pos (Before) + N;
+
+ Index : constant Index_Type := Index_Type (Index_As_Int);
+
+ begin
+ E (Index .. New_Last) := E (Before .. Container.Last);
+
+ E (Before .. Index_Type'Pred (Index)) :=
+ (others => New_Item);
+ end;
+
+ else
+ E (Before .. New_Last) := (others => New_Item);
+ end if;
end;
Container.Last := New_Last;
end if;
declare
- First : constant Int := Int (Index_Type'First);
-
+ First : constant Int := Int (Index_Type'First);
New_Size : constant Int'Base := New_Last_As_Int - First + 1;
- Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
-
- Size, Dst_Last_As_Int : Int'Base;
+ Size : Int'Base := Int'Max (1, Container.Elements'Length);
begin
- if New_Size >= Max_Size / 2 then
- Dst_Last := Index_Type'Last;
+ while Size < New_Size loop
+ if Size > Int'Last / 2 then
+ Size := Int'Last;
+ exit;
+ end if;
- else
- Size := Container.Elements'Length;
+ Size := 2 * Size;
+ end loop;
- if Size = 0 then
- Size := 1;
- end if;
+ -- TODO: The following calculations aren't quite right, since
+ -- there will be overflow if Index_Type'Range is very large
+ -- (e.g. this package is instantiated with a 64-bit integer).
+ -- END TODO.
- while Size < New_Size loop
- Size := 2 * Size;
- end loop;
+ declare
+ Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
+ begin
+ if Size > Max_Size then
+ Size := Max_Size;
+ end if;
+ end;
- Dst_Last_As_Int := First + Size - 1;
- Dst_Last := Index_Type (Dst_Last_As_Int);
- end if;
+ declare
+ Dst_Last : constant Index_Type := Index_Type (First + Size - 1);
+ begin
+ Dst := new Elements_Type (Index_Type'First .. Dst_Last);
+ end;
end;
- Dst := new Elements_Type (Index_Type'First .. Dst_Last);
-
declare
Src : Elements_Type renames Container.Elements.all;
Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
Src (Index_Type'First .. Index_Type'Pred (Before));
- Dst (Before .. Index_Type'Pred (Index)) :=
- (others => New_Item);
+ if Before <= Container.Last then
+ declare
+ Index_As_Int : constant Int'Base :=
+ Index_Type'Pos (Before) + N;
- Dst (Index .. New_Last) :=
- Src (Before .. Container.Last);
+ Index : constant Index_Type := Index_Type (Index_As_Int);
+ begin
+ Dst (Before .. Index_Type'Pred (Index)) := (others => New_Item);
+ Dst (Index .. New_Last) := Src (Before .. Container.Last);
+ end;
+
+ else
+ Dst (Before .. New_Last) := (others => New_Item);
+ end if;
exception
when others =>
Free (Dst);
N : constant Count_Type := Length (New_Item);
begin
+ if Before < Index_Type'First then
+ raise Constraint_Error;
+ end if;
+
+ if Before > Container.Last
+ and then Before > Container.Last + 1
+ then
+ raise Constraint_Error;
+ end if;
+
if N = 0 then
return;
end if;
Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
begin
- if Container'Address = New_Item'Address then
- declare
- subtype Src_Index_Subtype is Index_Type'Base range
- Index_Type'First .. Index_Type'Pred (Before);
+ if Container'Address /= New_Item'Address then
+ Container.Elements (Before .. Dst_Last) :=
+ New_Item.Elements (Index_Type'First .. New_Item.Last);
- Src : Elements_Type renames
- Container.Elements (Src_Index_Subtype);
+ return;
+ end if;
- Index_As_Int : constant Int'Base :=
- Int (Before) + Src'Length - 1;
+ declare
+ subtype Src_Index_Subtype is Index_Type'Base range
+ Index_Type'First .. Before - 1;
- Index : constant Index_Type'Base :=
- Index_Type'Base (Index_As_Int);
+ Src : Elements_Type renames
+ Container.Elements (Src_Index_Subtype);
- Dst : Elements_Type renames
- Container.Elements (Before .. Index);
+ Index_As_Int : constant Int'Base :=
+ Int (Before) + Src'Length - 1;
- begin
- Dst := Src;
- end;
+ Index : constant Index_Type'Base :=
+ Index_Type'Base (Index_As_Int);
- declare
- subtype Src_Index_Subtype is Index_Type'Base range
- Index_Type'Succ (Dst_Last) .. Container.Last;
+ Dst : Elements_Type renames
+ Container.Elements (Before .. Index);
- Src : Elements_Type renames
- Container.Elements (Src_Index_Subtype);
+ begin
+ Dst := Src;
+ end;
- Index_As_Int : constant Int'Base :=
- Dst_Last_As_Int - Src'Length + 1;
+ if Dst_Last = Container.Last then
+ return;
+ end if;
- Index : constant Index_Type'Base :=
- Index_Type'Base (Index_As_Int);
+ declare
+ subtype Src_Index_Subtype is Index_Type'Base range
+ Dst_Last + 1 .. Container.Last;
- Dst : Elements_Type renames
- Container.Elements (Index .. Dst_Last);
+ Src : Elements_Type renames
+ Container.Elements (Src_Index_Subtype);
- begin
- Dst := Src;
- end;
+ Index_As_Int : constant Int'Base :=
+ Dst_Last_As_Int - Src'Length + 1;
- else
- Container.Elements (Before .. Dst_Last) :=
- New_Item.Elements (Index_Type'First .. New_Item.Last);
- end if;
+ Index : constant Index_Type :=
+ Index_Type (Index_As_Int);
+
+ Dst : Elements_Type renames
+ Container.Elements (Index .. Dst_Last);
+
+ begin
+ Dst := Src;
+ end;
end;
end Insert;
if Before.Container = null
or else Before.Index > Container.Last
then
- Index := Index_Type'Succ (Container.Last);
+ if Container.Last = Index_Type'Last then
+ raise Constraint_Error;
+ end if;
+
+ Index := Container.Last + 1;
+
else
Index := Before.Index;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
- Index := Index_Type'Succ (Container.Last);
+ if Container.Last = Index_Type'Last then
+ raise Constraint_Error;
+ end if;
+
+ Index := Container.Last + 1;
+
else
Index := Before.Index;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
- Index := Index_Type'Succ (Container.Last);
+ if Container.Last = Index_Type'Last then
+ raise Constraint_Error;
+ end if;
+
+ Index := Container.Last + 1;
+
else
Index := Before.Index;
end if;
if Before.Container = null
or else Before.Index > Container.Last
then
- Index := Index_Type'Succ (Container.Last);
+ if Container.Last = Index_Type'Last then
+ raise Constraint_Error;
+ end if;
+
+ Index := Container.Last + 1;
+
else
Index := Before.Index;
end if;
Before : Extended_Index;
Count : Count_Type := 1)
is
- Old_Last : constant Extended_Index := Container.Last;
-
- Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);
-
N : constant Int := Count_Type'Pos (Count);
- New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N;
+ New_Last_As_Int : Int'Base;
+ New_Last : Index_Type;
- New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int);
+ Dst : Elements_Access;
- Index : Index_Type;
+ begin
+ if Before < Index_Type'First then
+ raise Constraint_Error;
+ end if;
- Dst_Last : Index_Type;
- Dst : Elements_Access;
+ if Before > Container.Last
+ and then Before > Container.Last + 1
+ then
+ raise Constraint_Error;
+ end if;
- begin
if Count = 0 then
return;
end if;
declare
- subtype Before_Subtype is Index_Type'Base range
- Index_Type'First .. Index_Type'Succ (Container.Last);
+ Old_Last : constant Extended_Index := Container.Last;
- Old_First : constant Before_Subtype := Before;
+ Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);
- Old_First_As_Int : constant Int := Index_Type'Pos (Old_First);
+ begin
+ New_Last_As_Int := Old_Last_As_Int + N;
- New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
+ if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then
+ raise Constraint_Error;
+ end if;
- begin
- Index := Index_Type (New_First_As_Int);
+ New_Last := Index_Type (New_Last_As_Int);
end;
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
if Container.Elements = null then
Container.Elements :=
new Elements_Type (Index_Type'First .. New_Last);
declare
E : Elements_Type renames Container.Elements.all;
begin
- E (Index .. New_Last) := E (Before .. Container.Last);
+ if Before <= Container.Last then
+ declare
+ Index_As_Int : constant Int'Base :=
+ Index_Type'Pos (Before) + N;
+
+ Index : constant Index_Type := Index_Type (Index_As_Int);
+
+ begin
+ E (Index .. New_Last) := E (Before .. Container.Last);
+ end;
+ end if;
end;
Container.Last := New_Last;
end if;
declare
- First : constant Int := Int (Index_Type'First);
-
+ First : constant Int := Int (Index_Type'First);
New_Size : constant Int'Base := New_Last_As_Int - First + 1;
- Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
-
- Size, Dst_Last_As_Int : Int'Base;
+ Size : Int'Base := Int'Max (1, Container.Elements'Length);
begin
- if New_Size >= Max_Size / 2 then
- Dst_Last := Index_Type'Last;
+ while Size < New_Size loop
+ if Size > Int'Last / 2 then
+ Size := Int'Last;
+ exit;
+ end if;
- else
- Size := Container.Elements'Length;
+ Size := 2 * Size;
+ end loop;
- if Size = 0 then
- Size := 1;
- end if;
+ -- TODO: The following calculations aren't quite right, since
+ -- there will be overflow if Index_Type'Range is very large
+ -- (e.g. this package is instantiated with a 64-bit integer).
+ -- END TODO.
- while Size < New_Size loop
- Size := 2 * Size;
- end loop;
+ declare
+ Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
+ begin
+ if Size > Max_Size then
+ Size := Max_Size;
+ end if;
+ end;
- Dst_Last_As_Int := First + Size - 1;
- Dst_Last := Index_Type (Dst_Last_As_Int);
- end if;
+ declare
+ Dst_Last : constant Index_Type := Index_Type (First + Size - 1);
+ begin
+ Dst := new Elements_Type (Index_Type'First .. Dst_Last);
+ end;
end;
- Dst := new Elements_Type (Index_Type'First .. Dst_Last);
-
declare
Src : Elements_Type renames Container.Elements.all;
Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
Src (Index_Type'First .. Index_Type'Pred (Before));
- Dst (Index .. New_Last) :=
- Src (Before .. Container.Last);
+ if Before <= Container.Last then
+ declare
+ Index_As_Int : constant Int'Base :=
+ Index_Type'Pos (Before) + N;
+ Index : constant Index_Type := Index_Type (Index_As_Int);
+
+ begin
+ Dst (Index .. New_Last) := Src (Before .. Container.Last);
+ end;
+ end if;
exception
when others =>
Free (Dst);
begin
Container.Elements := Dst;
Container.Last := New_Last;
-
Free (X);
end;
end Insert_Space;
if Before.Container = null
or else Before.Index > Container.Last
then
- Index := Index_Type'Succ (Container.Last);
+ if Container.Last = Index_Type'Last then
+ raise Constraint_Error;
+ end if;
+
+ Index := Container.Last + 1;
+
else
Index := Before.Index;
end if;
(Container : Vector;
Process : not null access procedure (Position : Cursor))
is
+ V : Vector renames Container'Unrestricted_Access.all;
+ B : Natural renames V.Busy;
+
begin
- for Indx in Index_Type'First .. Container.Last loop
- Process (Cursor'(Container'Unchecked_Access, Indx));
- end loop;
+
+ B := B + 1;
+
+ begin
+ for Indx in Index_Type'First .. Container.Last loop
+ Process (Cursor'(Container'Unchecked_Access, Indx));
+ end loop;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+
end Iterate;
----------
L : constant Int := Int (Container.Last);
F : constant Int := Int (Index_Type'First);
N : constant Int'Base := L - F + 1;
+
begin
+ if N > Count_Type'Pos (Count_Type'Last) then
+ raise Constraint_Error;
+ end if;
+
return Count_Type (N);
end Length;
(Target : in out Vector;
Source : in out Vector)
is
- X : Elements_Access := Target.Elements;
-
begin
if Target'Address = Source'Address then
return;
end if;
- if Target.Last >= Index_Type'First then
- raise Constraint_Error;
+ if Target.Busy > 0 then
+ raise Program_Error;
end if;
- Target.Elements := null;
- Free (X);
+ if Source.Busy > 0 then
+ raise Program_Error;
+ end if;
- Target.Elements := Source.Elements;
- Target.Last := Source.Last;
+ declare
+ Target_Elements : constant Elements_Access := Target.Elements;
+ begin
+ Target.Elements := Source.Elements;
+ Source.Elements := Target_Elements;
+ end;
- Source.Elements := null;
- Source.Last := Index_Type'Pred (Index_Type'First);
+ Target.Last := Source.Last;
+ Source.Last := No_Index;
end Move;
----------
end if;
if Position.Index < Position.Container.Last then
- return (Position.Container, Index_Type'Succ (Position.Index));
+ return (Position.Container, Position.Index + 1);
end if;
return No_Element;
end if;
if Position.Index < Position.Container.Last then
- Position.Index := Index_Type'Succ (Position.Index);
+ Position.Index := Position.Index + 1;
else
Position := No_Element;
end if;
end if;
if Position.Index > Index_Type'First then
- Position.Index := Index_Type'Pred (Position.Index);
+ Position.Index := Position.Index - 1;
else
Position := No_Element;
end if;
end if;
if Position.Index > Index_Type'First then
- return (Position.Container, Index_Type'Pred (Position.Index));
+ return (Position.Container, Position.Index - 1);
end if;
return No_Element;
Index : Index_Type;
Process : not null access procedure (Element : Element_Type))
is
- subtype T is Index_Type'Base range
- Index_Type'First .. Container.Last;
+ V : Vector renames Container'Unrestricted_Access.all;
+ B : Natural renames V.Busy;
+ L : Natural renames V.Lock;
+
begin
- Process (Container.Elements (T'(Index)));
+ if Index > Container.Last then
+ raise Constraint_Error;
+ end if;
+
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (V.Elements (Index));
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Query_Element;
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
- Container : Vector renames Position.Container.all;
-
- subtype T is Index_Type'Base range
- Index_Type'First .. Container.Last;
-
begin
- Process (Container.Elements (T'(Position.Index)));
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
+
+ Query_Element (Position.Container.all, Position.Index, Process);
end Query_Element;
----------
Container : out Vector)
is
Length : Count_Type'Base;
- Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
+ Last : Index_Type'Base := No_Index;
begin
Clear (Container);
end if;
for J in Count_Type range 1 .. Length loop
- Last := Index_Type'Succ (Last);
+ Last := Last + 1;
Element_Type'Read (Stream, Container.Elements (Last));
Container.Last := Last;
end loop;
Index : Index_Type;
By : Element_Type)
is
- subtype T is Index_Type'Base range
- Index_Type'First .. Container.Last;
begin
- Container.Elements (T'(Index)) := By;
+ if Index > Container.Last then
+ raise Constraint_Error;
+ end if;
+
+ if Container.Lock > 0 then
+ raise Program_Error;
+ end if;
+
+ Container.Elements (Index) := By;
end Replace_Element;
procedure Replace_Element (Position : Cursor; By : Element_Type) is
- subtype T is Index_Type'Base range
- Index_Type'First .. Position.Container.Last;
begin
- Position.Container.Elements (T'(Position.Index)) := By;
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
+
+ Replace_Element (Position.Container.all, Position.Index, By);
end Replace_Element;
----------------------
end;
elsif N < Container.Elements'Length then
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
declare
subtype Array_Index_Subtype is Index_Type'Base range
Index_Type'First .. Container.Last;
Last_As_Int : constant Int'Base :=
Int (Index_Type'First) + Int (Capacity) - 1;
- Last : constant Index_Type := Index_Type (Last_As_Int);
+ begin
+ if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
+ raise Constraint_Error;
+ end if;
- subtype Array_Subtype is
- Elements_Type (Index_Type'First .. Last);
+ declare
+ Last : constant Index_Type := Index_Type (Last_As_Int);
- begin
- Container.Elements := new Array_Subtype;
+ subtype Array_Subtype is
+ Elements_Type (Index_Type'First .. Last);
+ begin
+ Container.Elements := new Array_Subtype;
+ end;
end;
return;
if Capacity <= N then
if N < Container.Elements'Length then
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
declare
subtype Array_Index_Subtype is Index_Type'Base range
Index_Type'First .. Container.Last;
return;
end if;
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
declare
Last_As_Int : constant Int'Base :=
Int (Index_Type'First) + Int (Capacity) - 1;
- Last : constant Index_Type := Index_Type (Last_As_Int);
-
- subtype Array_Subtype is
- Elements_Type (Index_Type'First .. Last);
-
- E : Elements_Access := new Array_Subtype;
-
begin
+ if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
+ raise Constraint_Error;
+ end if;
+
declare
- Src : Elements_Type renames
- Container.Elements (Index_Type'First .. Container.Last);
+ Last : constant Index_Type := Index_Type (Last_As_Int);
+
+ subtype Array_Subtype is
+ Elements_Type (Index_Type'First .. Last);
- Tgt : Elements_Type renames
- E (Index_Type'First .. Container.Last);
+ E : Elements_Access := new Array_Subtype;
begin
- Tgt := Src;
+ declare
+ Src : Elements_Type renames
+ Container.Elements (Index_Type'First .. Container.Last);
- exception
- when others =>
- Free (E);
- raise;
- end;
+ Tgt : Elements_Type renames
+ E (Index_Type'First .. Container.Last);
- declare
- X : Elements_Access := Container.Elements;
- begin
- Container.Elements := E;
- Free (X);
+ begin
+ Tgt := Src;
+
+ exception
+ when others =>
+ Free (E);
+ raise;
+ end;
+
+ declare
+ X : Elements_Access := Container.Elements;
+ begin
+ Container.Elements := E;
+ Free (X);
+ end;
end;
end;
end Reserve_Capacity;
(Container : Vector;
Process : not null access procedure (Position : Cursor))
is
+ V : Vector renames Container'Unrestricted_Access.all;
+ B : Natural renames V.Busy;
+
begin
- for Indx in reverse Index_Type'First .. Container.Last loop
- Process (Cursor'(Container'Unchecked_Access, Indx));
- end loop;
+
+ B := B + 1;
+
+ begin
+ for Indx in reverse Index_Type'First .. Container.Last loop
+ Process (Cursor'(Container'Unchecked_Access, Indx));
+ end loop;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+
end Reverse_Iterate;
----------------
procedure Set_Length (Container : in out Vector; Length : Count_Type) is
begin
- if Length = 0 then
- Clear (Container);
+ if Length = Vectors.Length (Container) then
return;
end if;
+ if Container.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ if Length > Capacity (Container) then
+ Reserve_Capacity (Container, Capacity => Length);
+ end if;
+
declare
Last_As_Int : constant Int'Base :=
Int (Index_Type'First) + Int (Length) - 1;
-
- Last : constant Index_Type := Index_Type (Last_As_Int);
-
begin
- if Length > Capacity (Container) then
- Reserve_Capacity (Container, Capacity => Length);
- end if;
-
- Container.Last := Last;
+ Container.Last := Index_Type'Base (Last_As_Int);
end;
end Set_Length;
-- Swap --
----------
- procedure Swap
- (Container : Vector;
- I, J : Index_Type)
- is
+ procedure Swap (Container : Vector; I, J : Index_Type) is
+ begin
+ if I > Container.Last
+ or else J > Container.Last
+ then
+ raise Constraint_Error;
+ end if;
- subtype T is Index_Type'Base range
- Index_Type'First .. Container.Last;
+ if I = J then
+ return;
+ end if;
- EI : constant Element_Type := Container.Elements (T'(I));
+ if Container.Lock > 0 then
+ raise Program_Error;
+ end if;
- begin
+ declare
+ EI : Element_Type renames Container.Elements (I);
+ EJ : Element_Type renames Container.Elements (J);
- Container.Elements (T'(I)) := Container.Elements (T'(J));
- Container.Elements (T'(J)) := EI;
+ EI_Copy : constant Element_Type := EI;
+ begin
+ EI := EJ;
+ EJ := EI_Copy;
+ end;
end Swap;
procedure Swap (I, J : Cursor) is
+ begin
+ if I.Container = null
+ or else J.Container = null
+ then
+ raise Constraint_Error;
+ end if;
- -- NOTE: The behavior has been liberalized here to
- -- allow I and J to designate different containers.
- -- TODO: Probably this is supposed to raise P_E ???
-
- subtype TI is Index_Type'Base range
- Index_Type'First .. I.Container.Last;
-
- EI : Element_Type renames I.Container.Elements (TI'(I.Index));
-
- EI_Copy : constant Element_Type := EI;
-
- subtype TJ is Index_Type'Base range
- Index_Type'First .. J.Container.Last;
-
- EJ : Element_Type renames J.Container.Elements (TJ'(J.Index));
+ if I.Container /= J.Container then
+ raise Program_Error;
+ end if;
- begin
- EI := EJ;
- EJ := EI_Copy;
+ Swap (I.Container.all, I.Index, J.Index);
end Swap;
---------------
declare
First : constant Int := Int (Index_Type'First);
Last_As_Int : constant Int'Base := First + Int (Length) - 1;
- Last : constant Index_Type := Index_Type (Last_As_Int);
- Elements : constant Elements_Access :=
- new Elements_Type (Index_Type'First .. Last);
+ Last : Index_Type;
+ Elements : Elements_Access;
+
begin
- return (Controlled with Elements, Last);
+ if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
+ raise Constraint_Error;
+ end if;
+
+ Last := Index_Type (Last_As_Int);
+ Elements := new Elements_Type (Index_Type'First .. Last);
+
+ return (Controlled with Elements, Last, 0, 0);
end;
end To_Vector;
declare
First : constant Int := Int (Index_Type'First);
Last_As_Int : constant Int'Base := First + Int (Length) - 1;
- Last : constant Index_Type := Index_Type (Last_As_Int);
- Elements : constant Elements_Access :=
- new Elements_Type'
- (Index_Type'First .. Last => New_Item);
+ Last : Index_Type;
+ Elements : Elements_Access;
+
begin
- return (Controlled with Elements, Last);
+ if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
+ raise Constraint_Error;
+ end if;
+
+ Last := Index_Type (Last_As_Int);
+ Elements := new Elements_Type'(Index_Type'First .. Last => New_Item);
+
+ return (Controlled with Elements, Last, 0, 0);
end;
end To_Vector;
Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type))
is
- subtype T is Index_Type'Base range
- Index_Type'First .. Container.Last;
+ V : Vector renames Container'Unrestricted_Access.all;
+ B : Natural renames V.Busy;
+ L : Natural renames V.Lock;
+
begin
- Process (Container.Elements (T'(Index)));
+ if Index > Container.Last then
+ raise Constraint_Error;
+ end if;
+
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (V.Elements (Index));
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Update_Element;
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
- subtype T is Index_Type'Base range
- Index_Type'First .. Position.Container.Last;
begin
- Process (Position.Container.Elements (T'(Position.Index)));
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
+
+ Update_Element (Position.Container.all, Position.Index, Process);
end Update_Element;
-----------
end Write;
end Ada.Containers.Vectors;
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.VECTORS --
+-- A D A . C O N T A I N E R S . V E C T O R S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
procedure Delete
(Container : in out Vector;
- Index : Extended_Index; -- TODO: verify
+ Index : Extended_Index;
Count : Count_Type := 1);
procedure Delete
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
- procedure Generic_Sort (Container : Vector);
+ package Generic_Sorting is
+
+ function Is_Sorted (Container : Vector) return Boolean;
+
+ procedure Sort (Container : in out Vector);
+
+ procedure Merge (Target, Source : in out Vector);
+
+ end Generic_Sorting;
function Find_Index
(Container : Vector;
type Vector is new Controlled with record
Elements : Elements_Access;
Last : Extended_Index := No_Index;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
end record;
procedure Adjust (Container : in out Vector);
for Vector'Read use Read;
- Empty_Vector : constant Vector := (Controlled with null, No_Index);
+ Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0);
type Vector_Access is access constant Vector;
for Vector_Access'Storage_Size use 0;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.ORDERED_MAPS --
+-- A D A . C O N T A I N E R S . O R D E R E D _ M A P S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Containers.Red_Black_Trees.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
-with System; use type System.Address;
-
package body Ada.Containers.Ordered_Maps is
- use Red_Black_Trees;
-
- type Node_Type is limited record
- Parent : Node_Access;
- Left : Node_Access;
- Right : Node_Access;
- Color : Red_Black_Trees.Color_Type := Red;
- Key : Key_Type;
- Element : Element_Type;
- end record;
-
-----------------------------
-- Node Access Subprograms --
-----------------------------
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
- function Copy_Tree (Source_Root : Node_Access) return Node_Access;
-
- procedure Delete_Tree (X : in out Node_Access);
-
function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
pragma Inline (Is_Equal_Node_Node);
procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
package Tree_Operations is
- new Red_Black_Trees.Generic_Operations
- (Tree_Types => Tree_Types,
- Null_Node => Node_Access'(null));
+ new Red_Black_Trees.Generic_Operations (Tree_Types);
+
+ procedure Delete_Tree is
+ new Tree_Operations.Generic_Delete_Tree (Free);
+
+ function Copy_Tree is
+ new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
use Tree_Operations;
function "=" (Left, Right : Map) return Boolean is
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
return Is_Equal (Left.Tree, Right.Tree);
end "=";
-- Adjust --
------------
- procedure Adjust (Container : in out Map) is
- Tree : Tree_Type renames Container.Tree;
-
- N : constant Count_Type := Tree.Length;
- X : constant Node_Access := Tree.Root;
+ procedure Adjust is
+ new Tree_Operations.Generic_Adjust (Copy_Tree);
+ procedure Adjust (Container : in out Map) is
begin
- if N = 0 then
- pragma Assert (X = null);
- return;
- end if;
-
- Tree := (Length => 0, others => null);
-
- Tree.Root := Copy_Tree (X);
- Tree.First := Min (Tree.Root);
- Tree.Last := Max (Tree.Root);
- Tree.Length := N;
+ Adjust (Container.Tree);
end Adjust;
-------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Ceiling;
-----------
-- Clear --
-----------
+ procedure Clear is
+ new Tree_Operations.Generic_Clear (Delete_Tree);
+
procedure Clear (Container : in out Map) is
- Tree : Tree_Type renames Container.Tree;
- Root : Node_Access := Tree.Root;
begin
- Tree := (Length => 0, others => null);
- Delete_Tree (Root);
+ Clear (Container.Tree);
end Clear;
-----------
return Target;
end Copy_Node;
- ---------------
- -- Copy_Tree --
- ---------------
-
- function Copy_Tree (Source_Root : Node_Access) return Node_Access is
- Target_Root : Node_Access := Copy_Node (Source_Root);
- P, X : Node_Access;
-
- begin
- if Source_Root.Right /= null then
- Target_Root.Right := Copy_Tree (Source_Root.Right);
- Target_Root.Right.Parent := Target_Root;
- end if;
-
- P := Target_Root;
- X := Source_Root.Left;
-
- while X /= null loop
- declare
- Y : Node_Access := Copy_Node (X);
-
- begin
- P.Left := Y;
- Y.Parent := P;
-
- if X.Right /= null then
- Y.Right := Copy_Tree (X.Right);
- Y.Right.Parent := Y;
- end if;
-
- P := Y;
- X := X.Left;
- end;
- end loop;
-
- return Target_Root;
-
- exception
- when others =>
- Delete_Tree (Target_Root);
- raise;
- end Copy_Tree;
-
------------
-- Delete --
------------
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
- if Position = No_Element then
- return;
+ if Position.Node = null then
+ raise Constraint_Error;
end if;
- if Position.Container /= Map_Access'(Container'Unchecked_Access) then
+ if Position.Container /= Map_Access'(Container'Unrestricted_Access) then
raise Program_Error;
end if;
- Delete_Node_Sans_Free (Container.Tree, Position.Node);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
Free (Position.Node);
Position.Container := null;
------------------
procedure Delete_First (Container : in out Map) is
- Position : Cursor := First (Container);
+ X : Node_Access := Container.Tree.First;
begin
- Delete (Container, Position);
+ if X /= null then
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
+ Free (X);
+ end if;
end Delete_First;
-----------------
-----------------
procedure Delete_Last (Container : in out Map) is
- Position : Cursor := Last (Container);
+ X : Node_Access := Container.Tree.Last;
begin
- Delete (Container, Position);
- end Delete_Last;
-
-
- -----------------
- -- Delete_Tree --
- -----------------
-
- procedure Delete_Tree (X : in out Node_Access) is
- Y : Node_Access;
- begin
- while X /= null loop
- Y := X.Right;
- Delete_Tree (Y);
- Y := X.Left;
+ if X /= null then
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
- X := Y;
- end loop;
- end Delete_Tree;
+ end if;
+ end Delete_Last;
-------------
-- Element --
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
end First;
-------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
-----------------
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
+ if Container.Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
+
Position.Node.Key := Key;
Position.Node.Element := New_Item;
end if;
Position.Node,
Inserted);
- Position.Container := Container'Unchecked_Access;
+ Position.Container := Container'Unrestricted_Access;
end Insert;
procedure Insert
Position.Node,
Inserted);
- Position.Container := Container'Unchecked_Access;
+ Position.Container := Container'Unrestricted_Access;
end Insert;
--------------
function Is_Equal_Node_Node
(L, R : Node_Access) return Boolean is
begin
- return L.Element = R.Element;
+ if L.Key < R.Key then
+ return False;
+
+ elsif R.Key < L.Key then
+ return False;
+
+ else
+ return L.Element = R.Element;
+ end if;
end Is_Equal_Node_Node;
-------------------------
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
+
-- Start of processing for Iterate
begin
- Local_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Iterate (Container.Tree);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
---------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end Last;
------------------
-- Move --
----------
+ procedure Move is
+ new Tree_Operations.Generic_Move (Clear);
+
procedure Move (Target : in out Map; Source : in out Map) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Move (Target => Target.Tree, Source => Source.Tree);
end Move;
procedure Query_Element
(Position : Cursor;
- Process : not null access procedure (Element : Element_Type))
+ Process : not null access procedure (Key : Key_Type;
+ Element : Element_Type))
is
+ K : Key_Type renames Position.Node.Key;
+ E : Element_Type renames Position.Node.Element;
+
+ T : Tree_Type renames Position.Container.Tree;
+
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
begin
- Process (Position.Node.Key, Position.Node.Element);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Query_Element;
----------
(Stream : access Root_Stream_Type'Class;
Container : out Map)
is
- N : Count_Type'Base;
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access;
+ pragma Inline (Read_Node);
- function New_Node return Node_Access;
- pragma Inline (New_Node);
+ procedure Read is
+ new Tree_Operations.Generic_Read (Clear, Read_Node);
- procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
+ ---------------
+ -- Read_Node --
+ ---------------
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Node_Access is
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access
+ is
Node : Node_Access := new Node_Type;
-
begin
- begin
- Key_Type'Read (Stream, Node.Key);
- Element_Type'Read (Stream, Node.Element);
- exception
- when others =>
- Free (Node);
- raise;
- end;
-
+ Key_Type'Read (Stream, Node.Key);
+ Element_Type'Read (Stream, Node.Element);
return Node;
- end New_Node;
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end Read_Node;
-- Start of processing for Read
begin
- Clear (Container);
- Count_Type'Base'Read (Stream, N);
- pragma Assert (N >= 0);
-
- Local_Read (Container.Tree, N);
+ Read (Stream, Container.Tree);
end Read;
-------------
raise Constraint_Error;
end if;
+ if Container.Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
+
Node.Key := Key;
Node.Element := New_Item;
end Replace;
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
+ E : Element_Type renames Position.Node.Element;
+
begin
- Position.Node.Element := By;
+ if Position.Container.Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
+
+ E := By;
end Replace_Element;
---------------------
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
+
-- Start of processing for Reverse_Iterate
begin
- Local_Reverse_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (Container.Tree);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
-----------
Node.Parent := Parent;
end Set_Parent;
-
---------------
-- Set_Right --
---------------
procedure Update_Element
(Position : Cursor;
- Process : not null access procedure (Element : in out Element_Type))
+ Process : not null access procedure (Key : Key_Type;
+ Element : in out Element_Type))
is
+ K : Key_Type renames Position.Node.Key;
+ E : Element_Type renames Position.Node.Element;
+
+ T : Tree_Type renames Position.Container.Tree;
+
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
begin
- Process (Position.Node.Key, Position.Node.Element);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Update_Element;
-----------
(Stream : access Root_Stream_Type'Class;
Container : Map)
is
- procedure Process (Node : Node_Access);
- pragma Inline (Process);
-
- procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
-
- -------------
- -- Process --
- -------------
-
- procedure Process (Node : Node_Access) is
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+ pragma Inline (Write_Node);
+
+ procedure Write is
+ new Tree_Operations.Generic_Write (Write_Node);
+
+ ----------------
+ -- Write_Node --
+ ----------------
+
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access)
+ is
begin
Key_Type'Write (Stream, Node.Key);
Element_Type'Write (Stream, Node.Element);
- end Process;
+ end Write_Node;
-- Start of processing for Write
begin
- Count_Type'Base'Write (Stream, Container.Tree.Length);
- Iterate (Container.Tree);
+ Write (Stream, Container.Tree);
end Write;
end Ada.Containers.Ordered_Maps;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.ORDERED_MAPS --
+-- A D A . C O N T A I N E R S . O R D E R E D _ M A P S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
procedure Insert
(Container : in out Map;
Key : Key_Type;
- New_Item : Element_Type);
+ Position : out Cursor;
+ Inserted : out Boolean);
- procedure Include
+ procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
- procedure Replace
+ procedure Include
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
- procedure Insert
+ procedure Replace
(Container : in out Map;
Key : Key_Type;
- Position : out Cursor;
- Inserted : out Boolean);
+ New_Item : Element_Type);
procedure Delete (Container : in out Map; Key : Key_Type);
- procedure Exclude (Container : in out Map; Key : Key_Type);
-
procedure Delete (Container : in out Map; Position : in out Cursor);
procedure Delete_First (Container : in out Map);
procedure Delete_Last (Container : in out Map);
+ procedure Exclude (Container : in out Map; Key : Key_Type);
+
function Contains (Container : Map; Key : Key_Type) return Boolean;
function Find (Container : Map; Key : Key_Type) return Cursor;
function Next (Position : Cursor) return Cursor;
- function Previous (Position : Cursor) return Cursor;
-
procedure Next (Position : in out Cursor);
+ function Previous (Position : Cursor) return Cursor;
+
procedure Previous (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
type Node_Type;
type Node_Access is access Node_Type;
- package Tree_Types is
- new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
+ Key : Key_Type;
+ Element : Element_Type;
+ end record;
- use Tree_Types;
- use Ada.Finalization;
+ package Tree_Types is new Red_Black_Trees.Generic_Tree_Types
+ (Node_Type,
+ Node_Access);
- type Map is new Controlled with record
- Tree : Tree_Type := (Length => 0, others => null);
+ type Map is new Ada.Finalization.Controlled with record
+ Tree : Tree_Types.Tree_Type;
end record;
procedure Adjust (Container : in out Map);
procedure Finalize (Container : in out Map) renames Clear;
- type Map_Access is access constant Map;
+ use Red_Black_Trees;
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Map_Access is access Map;
for Map_Access'Storage_Size use 0;
type Cursor is record
for Map'Write use Write;
-
procedure Read
(Stream : access Root_Stream_Type'Class;
Container : out Map);
for Map'Read use Read;
Empty_Map : constant Map :=
- (Controlled with Tree => (Length => 0, others => null));
+ (Controlled with Tree => (First => null,
+ Last => null,
+ Root => null,
+ Length => 0,
+ Busy => 0,
+ Lock => 0));
end Ada.Containers.Ordered_Maps;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.ORDERED_MULTISETS --
+-- A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
-with System; use type System.Address;
-
package body Ada.Containers.Ordered_Multisets is
- use Red_Black_Trees;
-
- type Node_Type is limited record
- Parent : Node_Access;
- Left : Node_Access;
- Right : Node_Access;
- Color : Red_Black_Trees.Color_Type := Red;
- Element : Element_Type;
- end record;
-
-----------------------------
-- Node Access Subprograms --
-----------------------------
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
- function Copy_Tree (Source_Root : Node_Access) return Node_Access;
-
- procedure Delete_Tree (X : in out Node_Access);
-
procedure Insert_With_Hint
(Dst_Tree : in out Tree_Type;
Dst_Hint : Node_Access;
function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
pragma Inline (Is_Less_Node_Node);
+ procedure Replace_Element
+ (Tree : in out Tree_Type;
+ Node : Node_Access;
+ Item : Element_Type);
+
--------------------------
-- Local Instantiations --
--------------------------
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
package Tree_Operations is
- new Red_Black_Trees.Generic_Operations
- (Tree_Types => Tree_Types,
- Null_Node => Node_Access'(null));
+ new Red_Black_Trees.Generic_Operations (Tree_Types);
- use Tree_Operations;
+ procedure Delete_Tree is
+ new Tree_Operations.Generic_Delete_Tree (Free);
- procedure Free is
- new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+ function Copy_Tree is
+ new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
+
+ use Tree_Operations;
function Is_Equal is
new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
function "=" (Left, Right : Set) return Boolean is
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
return Is_Equal (Left.Tree, Right.Tree);
end "=";
-- Adjust --
------------
- procedure Adjust (Container : in out Set) is
- Tree : Tree_Type renames Container.Tree;
-
- N : constant Count_Type := Tree.Length;
- X : constant Node_Access := Tree.Root;
+ procedure Adjust is
+ new Tree_Operations.Generic_Adjust (Copy_Tree);
+ procedure Adjust (Container : in out Set) is
begin
- if N = 0 then
- pragma Assert (X = null);
- return;
- end if;
-
- Tree := (Length => 0, others => null);
-
- Tree.Root := Copy_Tree (X);
- Tree.First := Min (Tree.Root);
- Tree.Last := Max (Tree.Root);
- Tree.Length := N;
+ Adjust (Container.Tree);
end Adjust;
-------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Ceiling;
-----------
-- Clear --
-----------
+ procedure Clear is
+ new Tree_Operations.Generic_Clear (Delete_Tree);
+
procedure Clear (Container : in out Set) is
- Tree : Tree_Type renames Container.Tree;
- Root : Node_Access := Tree.Root;
begin
- Tree := (Length => 0, others => null);
- Delete_Tree (Root);
+ Clear (Container.Tree);
end Clear;
-----------
return Target;
end Copy_Node;
- ---------------
- -- Copy_Tree --
- ---------------
-
- function Copy_Tree (Source_Root : Node_Access) return Node_Access is
- Target_Root : Node_Access := Copy_Node (Source_Root);
-
- P, X : Node_Access;
-
- begin
- if Source_Root.Right /= null then
- Target_Root.Right := Copy_Tree (Source_Root.Right);
- Target_Root.Right.Parent := Target_Root;
- end if;
-
- P := Target_Root;
- X := Source_Root.Left;
- while X /= null loop
- declare
- Y : Node_Access := Copy_Node (X);
-
- begin
- P.Left := Y;
- Y.Parent := P;
-
- if X.Right /= null then
- Y.Right := Copy_Tree (X.Right);
- Y.Right.Parent := Y;
- end if;
-
- P := Y;
- X := X.Left;
- end;
- end loop;
-
- return Target_Root;
-
- exception
- when others =>
- Delete_Tree (Target_Root);
- raise;
- end Copy_Tree;
-
------------
-- Delete --
------------
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
- if Position = No_Element then
- return;
+ if Position.Node = null then
+ raise Constraint_Error;
end if;
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
Free (X);
end Delete_Last;
- -----------------
- -- Delete_Tree --
- -----------------
-
- procedure Delete_Tree (X : in out Node_Access) is
- Y : Node_Access;
- begin
- while X /= null loop
- Y := X.Right;
- Delete_Tree (Y);
- Y := X.Left;
- Free (X);
- X := Y;
- end loop;
- end Delete_Tree;
-
----------------
-- Difference --
----------------
procedure Difference (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
-
Set_Ops.Difference (Target.Tree, Source.Tree);
end Difference;
function Difference (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Difference (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Difference (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Difference;
-------------
return Position.Node.Element;
end Element;
+ ---------------------
+ -- Equivalent_Sets --
+ ---------------------
+
+ function Equivalent_Sets (Left, Right : Set) return Boolean is
+
+ function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Equivalent_Node_Node);
+
+ function Is_Equivalent is
+ new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
+
+ -----------------------------
+ -- Is_Equivalent_Node_Node --
+ -----------------------------
+
+ function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ if L.Element < R.Element then
+ return False;
+ elsif R.Element < L.Element then
+ return False;
+ else
+ return True;
+ end if;
+ end Is_Equivalent_Node_Node;
+
+ -- Start of processing for Equivalent_Sets
+
+ begin
+ return Is_Equivalent (Left.Tree, Right.Tree);
+ end Equivalent_Sets;
+
-------------
-- Exclude --
-------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
end First;
-------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Ceiling;
- ----------------------------
- -- Checked_Update_Element --
- ----------------------------
-
- procedure Checked_Update_Element
- (Container : in out Set;
- Position : Cursor;
- Process : not null access procedure (Element : in out Element_Type))
- is
- begin
- if Position.Container = null then
- raise Constraint_Error;
- end if;
-
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
- raise Program_Error;
- end if;
-
- declare
- Old_Key : Key_Type renames Key (Position.Node.Element);
-
- begin
- Process (Position.Node.Element);
-
- if Old_Key < Position.Node.Element
- or else Old_Key > Position.Node.Element
- then
- null;
- else
- return;
- end if;
- end;
-
- Delete_Node_Sans_Free (Container.Tree, Position.Node);
-
- Do_Insert : declare
- Result : Node_Access;
-
- function New_Node return Node_Access;
- pragma Inline (New_Node);
-
- procedure Insert_Post is
- new Key_Keys.Generic_Insert_Post (New_Node);
-
- procedure Insert is
- new Key_Keys.Generic_Unconditional_Insert (Insert_Post);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Node_Access is
- begin
- return Position.Node;
- end New_Node;
-
- -- Start of processing for Do_Insert
-
- begin
- Insert
- (Tree => Container.Tree,
- Key => Key (Position.Node.Element),
- Node => Result);
-
- pragma Assert (Result = Position.Node);
- end Do_Insert;
- end Checked_Update_Element;
-
--------------
-- Contains --
--------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
-------------------------
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Iterate
begin
- Local_Iterate (Container.Tree, Key);
+ B := B + 1;
+
+ begin
+ Local_Iterate (T, Key);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
---------
return Key (Position.Node.Element);
end Key;
- -------------
- -- Replace --
- -------------
-
- -- In post-madision api:???
-
--- procedure Replace
--- (Container : in out Set;
--- Key : Key_Type;
--- New_Item : Element_Type)
--- is
--- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
-
--- begin
--- if Node = null then
--- raise Constraint_Error;
--- end if;
-
--- Replace_Node (Container, Node, New_Item);
--- end Replace;
-
---------------------
-- Reverse_Iterate --
---------------------
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Reverse_Iterate
begin
- Local_Reverse_Iterate (Container.Tree, Key);
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (T, Key);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
+ -----------------------------------
+ -- Update_Element_Preserving_Key --
+ -----------------------------------
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ Tree : Tree_Type renames Container.Tree;
+
+ begin
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error;
+ end if;
+
+ declare
+ E : Element_Type renames Position.Node.Element;
+ K : Key_Type renames Key (E);
+
+ B : Natural renames Tree.Busy;
+ L : Natural renames Tree.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+
+ if K < E
+ or else K > E
+ then
+ null;
+ else
+ return;
+ end if;
+ end;
+
+ declare
+ X : Node_Access := Position.Node;
+ begin
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end;
+
+ raise Program_Error;
+ end Update_Element_Preserving_Key;
+
end Generic_Keys;
-----------------
New_Item,
Position.Node);
- Position.Container := Container'Unchecked_Access;
+ Position.Container := Container'Unrestricted_Access;
end Insert;
----------------------
procedure Intersection (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Set_Ops.Intersection (Target.Tree, Source.Tree);
end Intersection;
function Intersection (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Intersection (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Left;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Intersection (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Intersection;
--------------
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
begin
- if Subset'Address = Of_Set'Address then
- return True;
- end if;
-
return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
end Is_Subset;
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Iterate
begin
- Local_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Iterate (T);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
procedure Iterate
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Iterate
begin
- Local_Iterate (Container.Tree, Item);
+ B := B + 1;
+
+ begin
+ Local_Iterate (T, Item);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end Last;
------------------
-- Move --
----------
+ procedure Move is
+ new Tree_Operations.Generic_Move (Clear);
+
procedure Move (Target : in out Set; Source : in out Set) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Move (Target => Target.Tree, Source => Source.Tree);
end Move;
declare
Node : constant Node_Access :=
- Tree_Operations.Next (Position.Node);
+ Tree_Operations.Next (Position.Node);
begin
if Node = null then
return No_Element;
function Overlap (Left, Right : Set) return Boolean is
begin
- if Left'Address = Right'Address then
- return Left.Tree.Length /= 0;
- end if;
-
return Set_Ops.Overlap (Left.Tree, Right.Tree);
end Overlap;
declare
Node : constant Node_Access :=
- Tree_Operations.Previous (Position.Node);
+ Tree_Operations.Previous (Position.Node);
begin
if Node = null then
return No_Element;
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
+ E : Element_Type renames Position.Node.Element;
+
+ S : Set renames Position.Container.all;
+ T : Tree_Type renames S.Tree'Unrestricted_Access.all;
+
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
begin
- Process (Position.Node.Element);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Query_Element;
----------
(Stream : access Root_Stream_Type'Class;
Container : out Set)
is
- N : Count_Type'Base;
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access;
+ pragma Inline (Read_Node);
- function New_Node return Node_Access;
- pragma Inline (New_Node);
-
- procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
+ procedure Read is
+ new Tree_Operations.Generic_Read (Clear, Read_Node);
- --------------
- -- New_Node --
- --------------
+ ---------------
+ -- Read_Node --
+ ---------------
- function New_Node return Node_Access is
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access
+ is
Node : Node_Access := new Node_Type;
-
begin
- begin
- Element_Type'Read (Stream, Node.Element);
-
- exception
- when others =>
- Free (Node);
- raise;
- end;
-
+ Element_Type'Read (Stream, Node.Element);
return Node;
- end New_Node;
+ exception
+ when others =>
+ Free (Node); -- Note that Free deallocates elem too
+ raise;
+ end Read_Node;
-- Start of processing for Read
begin
- Clear (Container);
+ Read (Stream, Container.Tree);
+ end Read;
- Count_Type'Base'Read (Stream, N);
- pragma Assert (N >= 0);
+ ---------------------
+ -- Replace_Element --
+ ---------------------
- Local_Read (Container.Tree, N);
- end Read;
+ procedure Replace_Element
+ (Tree : in out Tree_Type;
+ Node : Node_Access;
+ Item : Element_Type)
+ is
+ begin
+ if Item < Node.Element
+ or else Node.Element < Item
+ then
+ null;
+ else
+ if Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
- -------------
- -- Replace --
- -------------
+ Node.Element := Item;
+ return;
+ end if;
- -- NOTE: from post-madison api ???
+ Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
--- procedure Replace
--- (Container : in out Set;
--- Position : Cursor;
--- By : Element_Type)
--- is
--- begin
--- if Position.Container = null then
--- raise Constraint_Error;
--- end if;
+ Insert_New_Item : declare
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
--- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
--- raise Program_Error;
--- end if;
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
--- Replace_Node (Container, Position.Node, By);
--- end Replace;
+ procedure Unconditional_Insert is
+ new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
- ------------------
- -- Replace_Node --
- ------------------
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ Node.Element := Item;
+ return Node;
+ end New_Node;
+
+ Result : Node_Access;
+
+ -- Start of processing for Insert_New_Item
+
+ begin
+ Unconditional_Insert
+ (Tree => Tree,
+ Key => Item,
+ Node => Result);
+
+ pragma Assert (Result = Node);
+ end Insert_New_Item;
+ end Replace_Element;
+
+ procedure Replace_Element
+ (Container : Set;
+ Position : Cursor;
+ By : Element_Type)
+ is
+ Tree : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+
+ begin
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
- -- NOTE: from post-madison api ???
-
--- procedure Replace_Node
--- (Container : in out Set;
--- Position : Node_Access;
--- By : Element_Type)
--- is
--- Tree : Tree_Type renames Container.Tree;
--- Node : Node_Access := Position;
-
--- begin
--- if By < Node.Element
--- or else Node.Element < By
--- then
--- null;
-
--- else
--- begin
--- Node.Element := By;
-
--- exception
--- when others =>
--- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
--- Free (Node);
--- raise;
--- end;
-
--- return;
--- end if;
-
--- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
-
--- begin
--- Node.Element := By;
-
--- exception
--- when others =>
--- Free (Node);
--- raise;
--- end;
---
--- Do_Insert : declare
--- Result : Node_Access;
--- Success : Boolean;
-
--- function New_Node return Node_Access;
--- pragma Inline (New_Node);
-
--- procedure Insert_Post is
--- new Element_Keys.Generic_Insert_Post (New_Node);
---
--- procedure Insert is
--- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
-
--- --------------
--- -- New_Node --
--- --------------
-
--- function New_Node return Node_Access is
--- begin
--- return Node;
--- end New_Node;
-
--- -- Start of processing for Do_Insert
-
--- begin
--- Insert
--- (Tree => Tree,
--- Key => Node.Element,
--- Node => Result,
--- Success => Success);
---
--- if not Success then
--- Free (Node);
--- raise Program_Error;
--- end if;
---
--- pragma Assert (Result = Node);
--- end Do_Insert;
--- end Replace_Node;
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error;
+ end if;
+
+ Replace_Element (Tree, Position.Node, By);
+ end Replace_Element;
---------------------
-- Reverse_Iterate --
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Reverse_Iterate
begin
- Local_Reverse_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (T);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
procedure Reverse_Iterate
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Reverse_Iterate
begin
- Local_Reverse_Iterate (Container.Tree, Item);
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (T, Item);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
-----------
procedure Symmetric_Difference (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
-
Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
end Symmetric_Difference;
function Symmetric_Difference (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Symmetric_Difference;
-----------
procedure Union (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Set_Ops.Union (Target.Tree, Source.Tree);
end Union;
function Union (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Union (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Left;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Union (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Union;
-----------
(Stream : access Root_Stream_Type'Class;
Container : Set)
is
- procedure Process (Node : Node_Access);
- pragma Inline (Process);
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+ pragma Inline (Write_Node);
- procedure Iterate is
- new Tree_Operations.Generic_Iteration (Process);
+ procedure Write is
+ new Tree_Operations.Generic_Write (Write_Node);
- -------------
- -- Process --
- -------------
+ ----------------
+ -- Write_Node --
+ ----------------
- procedure Process (Node : Node_Access) is
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access)
+ is
begin
Element_Type'Write (Stream, Node.Element);
- end Process;
+ end Write_Node;
-- Start of processing for Write
begin
- Count_Type'Base'Write (Stream, Container.Tree.Length);
- Iterate (Container.Tree);
+ Write (Stream, Container.Tree);
end Write;
end Ada.Containers.Ordered_Multisets;
-
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.ORDERED_MULTISETS --
+-- A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
function "=" (Left, Right : Set) return Boolean;
+ function Equivalent_Sets (Left, Right : Set) return Boolean;
+
function Length (Container : Set) return Count_Type;
function Is_Empty (Container : Set) return Boolean;
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
+ procedure Replace_Element
+ (Container : Set;
+ Position : Cursor;
+ By : Element_Type);
+
procedure Move
(Target : in out Set;
Source : in out Set);
(Container : in out Set;
Item : Element_Type);
- procedure Exclude
- (Container : in out Set;
- Item : Element_Type);
-
procedure Delete
(Container : in out Set;
Position : in out Cursor);
procedure Delete_Last (Container : in out Set);
- -- NOTE: The following operation is named Replace in the Madison API.
- -- However, it should be named Replace_Element. ???
- --
- -- procedure Replace
- -- (Container : in out Set;
- -- Position : Cursor;
- -- By : Element_Type);
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type);
procedure Union (Target : in out Set; Source : Set);
function Next (Position : Cursor) return Cursor;
- function Previous (Position : Cursor) return Cursor;
-
procedure Next (Position : in out Cursor);
+ function Previous (Position : Cursor) return Cursor;
+
procedure Previous (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
function Element (Container : Set; Key : Key_Type) return Element_Type;
- -- NOTE: in post-madison api ???
- -- procedure Replace
- -- (Container : in out Set;
- -- Key : Key_Type;
- -- New_Item : Element_Type);
-
procedure Delete (Container : in out Set; Key : Key_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
function ">" (Left : Key_Type; Right : Cursor) return Boolean;
- -- Should name of following be "Update_Element" ???
-
- procedure Checked_Update_Element
+ procedure Update_Element_Preserving_Key
(Container : in out Set;
Position : Cursor;
Process : not null access
type Node_Type;
type Node_Access is access Node_Type;
- package Tree_Types is
- new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
+ Element : Element_Type;
+ end record;
- use Tree_Types;
- use Ada.Finalization;
+ package Tree_Types is new Red_Black_Trees.Generic_Tree_Types
+ (Node_Type,
+ Node_Access);
- type Set is new Controlled with record
- Tree : Tree_Type := (Length => 0, others => null);
+ type Set is new Ada.Finalization.Controlled with record
+ Tree : Tree_Types.Tree_Type;
end record;
procedure Adjust (Container : in out Set);
procedure Finalize (Container : in out Set) renames Clear;
- type Set_Access is access constant Set;
+ use Red_Black_Trees;
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
type Cursor is record
for Set'Read use Read;
Empty_Set : constant Set :=
- (Controlled with Tree => (Length => 0, others => null));
+ (Controlled with Tree => (First => null,
+ Last => null,
+ Root => null,
+ Length => 0,
+ Busy => 0,
+ Lock => 0));
end Ada.Containers.Ordered_Multisets;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.ORDERED_SETS --
+-- A D A . C O N T A I N E R S . O R D E R E D _ S E T S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
-with System; use type System.Address;
-
package body Ada.Containers.Ordered_Sets is
- use Red_Black_Trees;
-
- type Node_Type is limited record
- Parent : Node_Access;
- Left : Node_Access;
- Right : Node_Access;
- Color : Red_Black_Trees.Color_Type := Red;
- Element : Element_Type;
- end record;
-
------------------------------
-- Access to Fields of Node --
------------------------------
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
- function Copy_Tree (Source_Root : Node_Access) return Node_Access;
-
- procedure Delete_Tree (X : in out Node_Access);
-
procedure Insert_With_Hint
(Dst_Tree : in out Tree_Type;
Dst_Hint : Node_Access;
function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
pragma Inline (Is_Less_Node_Node);
+ procedure Replace_Element
+ (Tree : in out Tree_Type;
+ Node : Node_Access;
+ Item : Element_Type);
+
--------------------------
-- Local Instantiations --
--------------------------
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
package Tree_Operations is
- new Red_Black_Trees.Generic_Operations
- (Tree_Types => Tree_Types,
- Null_Node => Node_Access'(null));
+ new Red_Black_Trees.Generic_Operations (Tree_Types);
- use Tree_Operations;
+ procedure Delete_Tree is
+ new Tree_Operations.Generic_Delete_Tree (Free);
- procedure Free is
- new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+ function Copy_Tree is
+ new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
+
+ use Tree_Operations;
function Is_Equal is
new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
function "=" (Left, Right : Set) return Boolean is
begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
return Is_Equal (Left.Tree, Right.Tree);
end "=";
-- Adjust --
------------
- procedure Adjust (Container : in out Set) is
- Tree : Tree_Type renames Container.Tree;
-
- N : constant Count_Type := Tree.Length;
- X : constant Node_Access := Tree.Root;
+ procedure Adjust is
+ new Tree_Operations.Generic_Adjust (Copy_Tree);
+ procedure Adjust (Container : in out Set) is
begin
- if N = 0 then
- pragma Assert (X = null);
- return;
- end if;
-
- Tree := (Length => 0, others => null);
-
- Tree.Root := Copy_Tree (X);
- Tree.First := Min (Tree.Root);
- Tree.Last := Max (Tree.Root);
- Tree.Length := N;
+ Adjust (Container.Tree);
end Adjust;
-------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Ceiling;
-----------
-- Clear --
-----------
+ procedure Clear is
+ new Tree_Operations.Generic_Clear (Delete_Tree);
+
procedure Clear (Container : in out Set) is
- Tree : Tree_Type renames Container.Tree;
- Root : Node_Access := Tree.Root;
begin
- Tree := (Length => 0, others => null);
- Delete_Tree (Root);
+ Clear (Container.Tree);
end Clear;
-----------
return Target;
end Copy_Node;
- ---------------
- -- Copy_Tree --
- ---------------
-
- function Copy_Tree (Source_Root : Node_Access) return Node_Access is
- Target_Root : Node_Access := Copy_Node (Source_Root);
-
- P, X : Node_Access;
-
- begin
- if Source_Root.Right /= null then
- Target_Root.Right := Copy_Tree (Source_Root.Right);
- Target_Root.Right.Parent := Target_Root;
- end if;
-
- P := Target_Root;
- X := Source_Root.Left;
- while X /= null loop
- declare
- Y : Node_Access := Copy_Node (X);
-
- begin
- P.Left := Y;
- Y.Parent := P;
-
- if X.Right /= null then
- Y.Right := Copy_Tree (X.Right);
- Y.Right.Parent := Y;
- end if;
-
- P := Y;
- X := X.Left;
- end;
- end loop;
-
- return Target_Root;
-
- exception
- when others =>
-
- Delete_Tree (Target_Root);
- raise;
- end Copy_Tree;
-
------------
-- Delete --
------------
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
- if Position = No_Element then
- return;
+ if Position.Node = null then
+ raise Constraint_Error;
end if;
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
+ if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
- Delete_Node_Sans_Free (Container.Tree, Position.Node);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
Free (Position.Node);
Position.Container := null;
end Delete;
raise Constraint_Error;
end if;
- Delete_Node_Sans_Free (Container.Tree, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end Delete;
------------------
procedure Delete_First (Container : in out Set) is
- C : Cursor := First (Container);
+ Tree : Tree_Type renames Container.Tree;
+ X : Node_Access := Tree.First;
+
begin
- Delete (Container, C);
+ if X /= null then
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end if;
end Delete_First;
-----------------
-----------------
procedure Delete_Last (Container : in out Set) is
- C : Cursor := Last (Container);
- begin
- Delete (Container, C);
- end Delete_Last;
-
- -----------------
- -- Delete_Tree --
- -----------------
+ Tree : Tree_Type renames Container.Tree;
+ X : Node_Access := Tree.Last;
- procedure Delete_Tree (X : in out Node_Access) is
- Y : Node_Access;
begin
- while X /= null loop
- Y := X.Right;
- Delete_Tree (Y);
- Y := X.Left;
+ if X /= null then
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
Free (X);
- X := Y;
- end loop;
- end Delete_Tree;
+ end if;
+ end Delete_Last;
----------------
-- Difference --
procedure Difference (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
-
Set_Ops.Difference (Target.Tree, Source.Tree);
end Difference;
function Difference (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Difference (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Difference (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Difference;
-------------
return Position.Node.Element;
end Element;
+ ---------------------
+ -- Equivalent_Sets --
+ ---------------------
+
+ function Equivalent_Sets (Left, Right : Set) return Boolean is
+ function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
+ pragma Inline (Is_Equivalent_Node_Node);
+
+ function Is_Equivalent is
+ new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
+
+ -----------------------------
+ -- Is_Equivalent_Node_Node --
+ -----------------------------
+
+ function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
+ begin
+ if L.Element < R.Element then
+ return False;
+ elsif R.Element < L.Element then
+ return False;
+ else
+ return True;
+ end if;
+ end Is_Equivalent_Node_Node;
+
+ -- Start of processing for Equivalent_Sets
+
+ begin
+ return Is_Equivalent (Left.Tree, Right.Tree);
+ end Equivalent_Sets;
+
-------------
-- Exclude --
-------------
begin
if X /= null then
- Delete_Node_Sans_Free (Container.Tree, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end if;
end Exclude;
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.First);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
end First;
-------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
------------------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Ceiling;
- ----------------------------
- -- Checked_Update_Element --
- ----------------------------
-
- procedure Checked_Update_Element
- (Container : in out Set;
- Position : Cursor;
- Process : not null access procedure (Element : in out Element_Type))
- is
- begin
- if Position.Container = null then
- raise Constraint_Error;
- end if;
-
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
- raise Program_Error;
- end if;
-
- declare
- Old_Key : Key_Type renames Key (Position.Node.Element);
-
- begin
- Process (Position.Node.Element);
-
- if Old_Key < Position.Node.Element
- or else Old_Key > Position.Node.Element
- then
- null;
- else
- return;
- end if;
- end;
-
- Delete_Node_Sans_Free (Container.Tree, Position.Node);
-
- declare
- Result : Node_Access;
- Success : Boolean;
-
- function New_Node return Node_Access;
- pragma Inline (New_Node);
-
- procedure Local_Insert_Post is
- new Key_Keys.Generic_Insert_Post (New_Node);
-
- procedure Local_Conditional_Insert is
- new Key_Keys.Generic_Conditional_Insert (Local_Insert_Post);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Node_Access is
- begin
- return Position.Node;
- end New_Node;
-
-
- begin
- Local_Conditional_Insert
- (Tree => Container.Tree,
- Key => Key (Position.Node.Element),
- Node => Result,
- Success => Success);
-
- if not Success then
- declare
- X : Node_Access := Position.Node;
- begin
- Free (X);
- end;
-
- raise Program_Error;
- end if;
-
- pragma Assert (Result = Position.Node);
- end;
- end Checked_Update_Element;
-
--------------
-- Contains --
--------------
Key : Key_Type) return Element_Type
is
Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
+
begin
return Node.Element;
end Element;
procedure Exclude (Container : in out Set; Key : Key_Type) is
X : Node_Access := Key_Keys.Find (Container.Tree, Key);
+
begin
if X /= null then
Delete_Node_Sans_Free (Container.Tree, X);
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Find;
-----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
-------------------------
-- Replace --
-------------
--- TODO???
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
--- procedure Replace
--- (Container : in out Set;
--- Key : Key_Type;
--- New_Item : Element_Type)
--- is
--- Node : Node_Access := Key_Keys.Find (Container.Tree, Key);
+ begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
--- begin
--- if Node = null then
--- raise Constraint_Error;
--- end if;
+ Replace_Element (Container.Tree, Node, New_Item);
+ end Replace;
--- Replace_Element (Container, Node, New_Item);
--- end Replace;
+ -----------------------------------
+ -- Update_Element_Preserving_Key --
+ -----------------------------------
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ Tree : Tree_Type renames Container.Tree;
+
+ begin
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error;
+ end if;
+
+ declare
+ E : Element_Type renames Position.Node.Element;
+ K : Key_Type renames Key (E);
+
+ B : Natural renames Tree.Busy;
+ L : Natural renames Tree.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+
+ if K < E
+ or else K > E
+ then
+ null;
+ else
+ return;
+ end if;
+ end;
+
+ declare
+ X : Node_Access := Position.Node;
+ begin
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Free (X);
+ end;
+
+ raise Program_Error;
+ end Update_Element_Preserving_Key;
end Generic_Keys;
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
+ if Container.Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
+
Position.Node.Element := New_Item;
end if;
end Include;
Position.Node,
Inserted);
- Position.Container := Container'Unchecked_Access;
+ Position.Container := Container'Unrestricted_Access;
end Insert;
procedure Insert
(Container : in out Set;
New_Item : Element_Type)
is
-
Position : Cursor;
Inserted : Boolean;
procedure Intersection (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Set_Ops.Intersection (Target.Tree, Source.Tree);
end Intersection;
function Intersection (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Intersection (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Left;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Intersection (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Intersection;
--------------
function Is_Empty (Container : Set) return Boolean is
begin
- return Length (Container) = 0;
+ return Container.Tree.Length = 0;
end Is_Empty;
------------------------
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
begin
- if Subset'Address = Of_Set'Address then
- return True;
- end if;
-
return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
end Is_Subset;
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of prccessing for Iterate
begin
- Local_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Iterate (T);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
+ return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end Last;
------------------
-- Move --
----------
+ procedure Move is
+ new Tree_Operations.Generic_Move (Clear);
+
procedure Move (Target : in out Set; Source : in out Set) is
begin
- if Target'Address = Source'Address then
- return;
- end if;
-
Move (Target => Target.Tree, Source => Source.Tree);
end Move;
declare
Node : constant Node_Access :=
- Tree_Operations.Next (Position.Node);
+ Tree_Operations.Next (Position.Node);
+
begin
if Node = null then
return No_Element;
function Overlap (Left, Right : Set) return Boolean is
begin
- if Left'Address = Right'Address then
- return Left.Tree.Length /= 0;
- end if;
-
return Set_Ops.Overlap (Left.Tree, Right.Tree);
end Overlap;
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
+ E : Element_Type renames Position.Node.Element;
+
+ S : Set renames Position.Container.all;
+ T : Tree_Type renames S.Tree'Unrestricted_Access.all;
+
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
begin
- Process (Position.Node.Element);
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
end Query_Element;
----------
(Stream : access Root_Stream_Type'Class;
Container : out Set)
is
- N : Count_Type'Base;
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access;
+ pragma Inline (Read_Node);
- function New_Node return Node_Access;
- pragma Inline (New_Node);
-
- procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
+ procedure Read is
+ new Tree_Operations.Generic_Read (Clear, Read_Node);
- --------------
- -- New_Node --
- --------------
+ ---------------
+ -- Read_Node --
+ ---------------
- function New_Node return Node_Access is
+ function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access
+ is
Node : Node_Access := new Node_Type;
begin
- begin
- Element_Type'Read (Stream, Node.Element);
-
- exception
- when others =>
- Free (Node);
- raise;
- end;
-
+ Element_Type'Read (Stream, Node.Element);
return Node;
- end New_Node;
+
+ exception
+ when others =>
+ Free (Node);
+ raise;
+ end Read_Node;
-- Start of processing for Read
begin
- Clear (Container);
-
- Count_Type'Base'Read (Stream, N);
- pragma Assert (N >= 0);
-
- Local_Read (Container.Tree, N);
+ Read (Stream, Container.Tree);
end Read;
-------------
raise Constraint_Error;
end if;
+ if Container.Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
+
Node.Element := New_Item;
end Replace;
-- Replace_Element --
---------------------
--- TODO: ???
--- procedure Replace_Element
--- (Container : in out Set;
--- Position : Node_Access;
--- By : Element_Type)
--- is
--- Node : Node_Access := Position;
-
--- begin
--- if By < Node.Element
--- or else Node.Element < By
--- then
--- null;
-
--- else
--- begin
--- Node.Element := By;
-
--- exception
--- when others =>
--- Delete_Node_Sans_Free (Container.Tree, Node);
--- Free (Node);
--- raise;
--- end;
-
--- return;
--- end if;
-
--- Delete_Node_Sans_Free (Container.Tree, Node);
-
--- begin
--- Node.Element := By;
--- exception
--- when others =>
--- Free (Node);
--- raise;
--- end;
-
--- declare
--- function New_Node return Node_Access;
--- pragma Inline (New_Node);
-
--- function New_Node return Node_Access is
--- begin
--- return Node;
--- end New_Node;
-
--- procedure Insert_Post is
--- new Element_Keys.Generic_Insert_Post (New_Node);
-
--- procedure Insert is
--- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
-
--- Result : Node_Access;
--- Success : Boolean;
-
--- begin
--- Insert
--- (Tree => Container.Tree,
--- Key => Node.Element,
--- Node => Result,
--- Success => Success);
-
--- if not Success then
--- Free (Node);
--- raise Program_Error;
--- end if;
-
--- pragma Assert (Result = Node);
--- end;
--- end Replace_Element;
-
-
--- procedure Replace_Element
--- (Container : in out Set;
--- Position : Cursor;
--- By : Element_Type)
--- is
--- begin
--- if Position.Container = null then
--- raise Constraint_Error;
--- end if;
-
--- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
--- raise Program_Error;
--- end if;
-
--- Replace_Element (Container, Position.Node, By);
--- end Replace_Element;
+ procedure Replace_Element
+ (Tree : in out Tree_Type;
+ Node : Node_Access;
+ Item : Element_Type)
+ is
+ begin
+ if Item < Node.Element
+ or else Node.Element < Item
+ then
+ null;
+ else
+ if Tree.Lock > 0 then
+ raise Program_Error;
+ end if;
+
+ Node.Element := Item;
+ return;
+ end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
+
+ Insert_New_Item : declare
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ Node.Element := Item;
+ return Node;
+ end New_Node;
+
+ Result : Node_Access;
+ Inserted : Boolean;
+
+ -- Start of processing for Insert_New_Item
+
+ begin
+ Insert
+ (Tree => Tree,
+ Key => Item,
+ Node => Result,
+ Success => Inserted); -- TODO: change param name
+
+ if Inserted then
+ pragma Assert (Result = Node);
+ return;
+ end if;
+ exception
+ when others =>
+ null; -- Assignment must have failed
+ end Insert_New_Item;
+
+ Reinsert_Old_Element : declare
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ return Node;
+ end New_Node;
+
+ Result : Node_Access;
+ Inserted : Boolean;
+
+ -- Start of processing for Reinsert_Old_Element
+
+ begin
+ Insert
+ (Tree => Tree,
+ Key => Node.Element,
+ Node => Result,
+ Success => Inserted); -- TODO: change param name
+ exception
+ when others =>
+ null; -- Assignment must have failed
+ end Reinsert_Old_Element;
+
+ raise Program_Error;
+ end Replace_Element;
+
+ procedure Replace_Element
+ (Container : Set;
+ Position : Cursor;
+ By : Element_Type)
+ is
+ Tree : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+
+ begin
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error;
+ end if;
+
+ Replace_Element (Tree, Position.Node, By);
+ end Replace_Element;
---------------------
-- Reverse_Iterate --
procedure Process_Node (Node : Node_Access) is
begin
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ B : Natural renames T.Busy;
+
-- Start of processing for Reverse_Iterate
begin
- Local_Reverse_Iterate (Container.Tree);
+ B := B + 1;
+
+ begin
+ Local_Reverse_Iterate (T);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Reverse_Iterate;
-----------
procedure Symmetric_Difference (Target : in out Set; Source : Set) is
begin
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
-
Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
end Symmetric_Difference;
function Symmetric_Difference (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- declare
- Tree : constant Tree_Type :=
- Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Symmetric_Difference;
-----------
procedure Union (Target : in out Set; Source : Set) is
begin
-
- if Target'Address = Source'Address then
- return;
- end if;
-
Set_Ops.Union (Target.Tree, Source.Tree);
end Union;
function Union (Left, Right : Set) return Set is
+ Tree : constant Tree_Type :=
+ Set_Ops.Union (Left.Tree, Right.Tree);
begin
- if Left'Address = Right'Address then
- return Left;
- end if;
-
- declare
- Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
- begin
- return (Controlled with Tree);
- end;
+ return Set'(Controlled with Tree);
end Union;
-----------
(Stream : access Root_Stream_Type'Class;
Container : Set)
is
- procedure Process (Node : Node_Access);
- pragma Inline (Process);
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+ pragma Inline (Write_Node);
- procedure Iterate is
- new Tree_Operations.Generic_Iteration (Process);
+ procedure Write is
+ new Tree_Operations.Generic_Write (Write_Node);
- -------------
- -- Process --
- -------------
+ ----------------
+ -- Write_Node --
+ ----------------
- procedure Process (Node : Node_Access) is
+ procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access)
+ is
begin
Element_Type'Write (Stream, Node.Element);
- end Process;
+ end Write_Node;
-- Start of processing for Write
begin
- Count_Type'Base'Write (Stream, Container.Tree.Length);
- Iterate (Container.Tree);
+ Write (Stream, Container.Tree);
end Write;
-
-
-
end Ada.Containers.Ordered_Sets;
-
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.ORDERED_SETS --
+-- A D A . C O N T A I N E R S . O R D E R E D _ S E T S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
function "=" (Left, Right : Set) return Boolean;
+ function Equivalent_Sets (Left, Right : Set) return Boolean;
+
function Length (Container : Set) return Count_Type;
function Is_Empty (Container : Set) return Boolean;
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
--- TODO: resolve in Atlanta. ???
--- procedure Replace_Element
--- (Container : in out Set;
--- Position : Cursor;
--- By : Element_Type);
+ procedure Replace_Element
+ (Container : Set; -- TODO: need ARG ruling
+ Position : Cursor;
+ By : Element_Type);
procedure Move
(Target : in out Set;
New_Item : Element_Type);
procedure Replace
- (Container : in out Set;
+ (Container : in out Set; -- TODO: need ARG ruling
New_Item : Element_Type);
procedure Delete
(Container : in out Set;
Item : Element_Type);
- procedure Exclude
- (Container : in out Set;
- Item : Element_Type);
-
procedure Delete
(Container : in out Set;
Position : in out Cursor);
procedure Delete_Last (Container : in out Set);
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type);
+
procedure Union (Target : in out Set; Source : Set);
function Union (Left, Right : Set) return Set;
function Next (Position : Cursor) return Cursor;
- function Previous (Position : Cursor) return Cursor;
-
procedure Next (Position : in out Cursor);
+ function Previous (Position : Cursor) return Cursor;
+
procedure Previous (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
function Element (Container : Set; Key : Key_Type) return Element_Type;
--- TODO: resolve in Atlanta ???
--- procedure Replace
--- (Container : in out Set;
--- Key : Key_Type;
--- New_Item : Element_Type);
+ procedure Replace
+ (Container : in out Set; -- TODO: need ARG ruling
+ Key : Key_Type;
+ New_Item : Element_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
function ">" (Left : Key_Type; Right : Cursor) return Boolean;
--- TODO: resolve name in Atlanta. Should name be just "Update_Element" ???
- procedure Checked_Update_Element
+ procedure Update_Element_Preserving_Key
(Container : in out Set;
Position : Cursor;
Process : not null access
type Node_Type;
type Node_Access is access Node_Type;
- package Tree_Types is
- new Red_Black_Trees.Generic_Tree_Types (Node_Access);
+ type Node_Type is limited record
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
+ Element : Element_Type;
+ end record;
- use Tree_Types;
- use Ada.Finalization;
+ package Tree_Types is new Red_Black_Trees.Generic_Tree_Types
+ (Node_Type,
+ Node_Access);
- type Set is new Controlled with record
- Tree : Tree_Type := (Length => 0, others => null);
+ type Set is new Ada.Finalization.Controlled with record
+ Tree : Tree_Types.Tree_Type;
end record;
procedure Adjust (Container : in out Set);
procedure Finalize (Container : in out Set) renames Clear;
- type Set_Access is access constant Set;
+ use Red_Black_Trees;
+ use Tree_Types;
+ use Ada.Finalization;
+
+ type Set_Access is access all Set;
+ for Set_Access'Storage_Size use 0;
type Cursor is record
Container : Set_Access;
for Set'Read use Read;
Empty_Set : constant Set :=
- (Controlled with Tree => (Length => 0, others => null));
+ (Controlled with Tree => (First => null,
+ Last => null,
+ Root => null,
+ Length => 0,
+ Busy => 0,
+ Lock => 0));
end Ada.Containers.Ordered_Sets;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.RED_BLACK_TREES --
+-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S --
-- --
-- S p e c --
-- --
--- This specification is adapted from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT 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. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; 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. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
package Ada.Containers.Red_Black_Trees is
type Color_Type is (Red, Black);
generic
- type Node_Access is private;
+ type Node_Type (<>) is limited private;
+ type Node_Access is access Node_Type;
package Generic_Tree_Types is
- type Tree_Type is record
+ type Tree_Type is tagged record
First : Node_Access;
Last : Node_Access;
Root : Node_Access;
- Length : Count_Type;
+ Length : Count_Type := 0;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
end record;
end Generic_Tree_Types;
+
end Ada.Containers.Red_Black_Trees;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS --
+-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . --
+-- G E N E R I C _ K E Y S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
X : Node_Access := Tree.Root;
begin
- while X /= Ops.Null_Node loop
+ while X /= null loop
if Is_Greater_Key_Node (Key, X) then
X := Ops.Right (X);
else
X : Node_Access := Tree.Root;
begin
- while X /= Ops.Null_Node loop
+ while X /= null loop
if Is_Greater_Key_Node (Key, X) then
X := Ops.Right (X);
else
end if;
end loop;
- if Y = Ops.Null_Node then
- return Ops.Null_Node;
+ if Y = null then
+ return null;
end if;
if Is_Less_Key_Node (Key, Y) then
- return Ops.Null_Node;
+ return null;
end if;
return Y;
X : Node_Access := Tree.Root;
begin
- while X /= Ops.Null_Node loop
+ while X /= null loop
if Is_Less_Key_Node (Key, X) then
X := Ops.Left (X);
else
Node : out Node_Access;
Success : out Boolean)
is
- Y : Node_Access := Ops.Null_Node;
+ Y : Node_Access := null;
X : Node_Access := Tree.Root;
begin
Success := True;
- while X /= Ops.Null_Node loop
+ while X /= null loop
Y := X;
Success := Is_Less_Key_Node (Key, X);
Success : out Boolean)
is
begin
- if Position = Ops.Null_Node then -- largest
+ if Position = null then -- largest
if Tree.Length > 0
and then Is_Greater_Key_Node (Key, Tree.Last)
then
- Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
+ Insert_Post (Tree, null, Tree.Last, Key, Node);
Success := True;
else
Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
begin
if Is_Greater_Key_Node (Key, Before) then
- if Ops.Right (Before) = Ops.Null_Node then
- Insert_Post (Tree, Ops.Null_Node, Before, Key, Node);
+ if Ops.Right (Before) = null then
+ Insert_Post (Tree, null, Before, Key, Node);
else
Insert_Post (Tree, Position, Position, Key, Node);
end if;
if Is_Greater_Key_Node (Key, Position) then
if Position = Tree.Last then
- Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
+ Insert_Post (Tree, null, Tree.Last, Key, Node);
Success := True;
return;
end if;
begin
if Is_Less_Key_Node (Key, After) then
- if Ops.Right (Position) = Ops.Null_Node then
- Insert_Post (Tree, Ops.Null_Node, Position, Key, Node);
+ if Ops.Right (Position) = null then
+ Insert_Post (Tree, null, Position, Key, Node);
else
Insert_Post (Tree, After, After, Key, Node);
end if;
New_Length : constant Count_Type := Length_Subtype'(Tree.Length) + 1;
begin
- if Y = Ops.Null_Node
- or else X /= Ops.Null_Node
+ if Tree.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ if Y = null
+ or else X /= null
or else Is_Less_Key_Node (Key, Y)
then
- pragma Assert (Y = Ops.Null_Node
- or else Ops.Left (Y) = Ops.Null_Node);
+ pragma Assert (Y = null
+ or else Ops.Left (Y) = null);
-- Delay allocation as long as we can, in order to defend
-- against exceptions propagated by relational operators.
Z := New_Node;
- pragma Assert (Z /= Ops.Null_Node);
+ pragma Assert (Z /= null);
pragma Assert (Ops.Color (Z) = Red);
- if Y = Ops.Null_Node then
+ if Y = null then
pragma Assert (Tree.Length = 0);
- pragma Assert (Tree.Root = Ops.Null_Node);
- pragma Assert (Tree.First = Ops.Null_Node);
- pragma Assert (Tree.Last = Ops.Null_Node);
+ pragma Assert (Tree.Root = null);
+ pragma Assert (Tree.First = null);
+ pragma Assert (Tree.Last = null);
Tree.Root := Z;
Tree.First := Z;
end if;
else
- pragma Assert (Ops.Right (Y) = Ops.Null_Node);
+ pragma Assert (Ops.Right (Y) = null);
-- Delay allocation as long as we can, in order to defend
-- against exceptions propagated by relational operators.
Z := New_Node;
- pragma Assert (Z /= Ops.Null_Node);
+ pragma Assert (Z /= null);
pragma Assert (Ops.Color (Z) = Red);
Ops.Set_Right (Y, Z);
procedure Iterate (Node : Node_Access) is
N : Node_Access := Node;
begin
- while N /= Ops.Null_Node loop
+ while N /= null loop
if Is_Less_Key_Node (Key, N) then
N := Ops.Left (N);
elsif Is_Greater_Key_Node (Key, N) then
procedure Iterate (Node : Node_Access) is
N : Node_Access := Node;
begin
- while N /= Ops.Null_Node loop
+ while N /= null loop
if Is_Less_Key_Node (Key, N) then
N := Ops.Left (N);
elsif Is_Greater_Key_Node (Key, N) then
Key : Key_Type;
Node : out Node_Access)
is
- Y : Node_Access := Ops.Null_Node;
+ Y : Node_Access := null;
X : Node_Access := Tree.Root;
begin
- while X /= Ops.Null_Node loop
+ while X /= null loop
Y := X;
if Is_Less_Key_Node (Key, X) then
-- inserted last in the sequence of equivalent items.) ???
begin
- if Hint = Ops.Null_Node then -- largest
+ if Hint = null then -- largest
if Tree.Length > 0
and then Is_Greater_Key_Node (Key, Tree.Last)
then
- Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
+ Insert_Post (Tree, null, Tree.Last, Key, Node);
else
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
end if;
Before : constant Node_Access := Ops.Previous (Hint);
begin
if Is_Greater_Key_Node (Key, Before) then
- if Ops.Right (Before) = Ops.Null_Node then
- Insert_Post (Tree, Ops.Null_Node, Before, Key, Node);
+ if Ops.Right (Before) = null then
+ Insert_Post (Tree, null, Before, Key, Node);
else
Insert_Post (Tree, Hint, Hint, Key, Node);
end if;
if Is_Greater_Key_Node (Key, Hint) then
if Hint = Tree.Last then
- Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
+ Insert_Post (Tree, null, Tree.Last, Key, Node);
return;
end if;
After : constant Node_Access := Ops.Next (Hint);
begin
if Is_Less_Key_Node (Key, After) then
- if Ops.Right (Hint) = Ops.Null_Node then
- Insert_Post (Tree, Ops.Null_Node, Hint, Key, Node);
+ if Ops.Right (Hint) = null then
+ Insert_Post (Tree, null, Hint, Key, Node);
else
Insert_Post (Tree, After, After, Key, Node);
end if;
X : Node_Access := Tree.Root;
begin
- while X /= Ops.Null_Node loop
+ while X /= null loop
if Is_Less_Key_Node (Key, X) then
Y := X;
X := Ops.Left (X);
end Upper_Bound;
end Ada.Containers.Red_Black_Trees.Generic_Keys;
-
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS --
+-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . --
+-- G E N E R I C _ K E Y S --
-- --
-- S p e c --
-- --
Key : Key_Type);
end Ada.Containers.Red_Black_Trees.Generic_Keys;
-
-
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS --
+-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . --
+-- G E N E R I C _ O P E R A T I O N S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+with System; use type System.Address;
+
package body Ada.Containers.Red_Black_Trees.Generic_Operations is
-----------------------
function Check (Node : Node_Access) return Natural is
begin
- if Node = Null_Node then
+ if Node = null then
return 0;
end if;
declare
L : constant Node_Access := Left (Node);
begin
- pragma Assert (L = Null_Node or else Color (L) = Black);
+ pragma Assert (L = null or else Color (L) = Black);
null;
end;
declare
R : constant Node_Access := Right (Node);
begin
- pragma Assert (R = Null_Node or else Color (R) = Black);
+ pragma Assert (R = null or else Color (R) = Black);
null;
end;
-- Start of processing for Check_Invariant
begin
- if Root = Null_Node then
- pragma Assert (Tree.First = Null_Node);
- pragma Assert (Tree.Last = Null_Node);
+ if Root = null then
+ pragma Assert (Tree.First = null);
+ pragma Assert (Tree.Last = null);
pragma Assert (Tree.Length = 0);
null;
else
pragma Assert (Color (Root) = Black);
pragma Assert (Tree.Length > 0);
- pragma Assert (Tree.Root /= Null_Node);
- pragma Assert (Tree.First /= Null_Node);
- pragma Assert (Tree.Last /= Null_Node);
- pragma Assert (Parent (Tree.Root) = Null_Node);
+ pragma Assert (Tree.Root /= null);
+ pragma Assert (Tree.First /= null);
+ pragma Assert (Tree.Last /= null);
+ pragma Assert (Parent (Tree.Root) = null);
pragma Assert ((Tree.Length > 1)
or else (Tree.First = Tree.Last
and Tree.First = Tree.Root));
- pragma Assert (Left (Tree.First) = Null_Node);
- pragma Assert (Right (Tree.Last) = Null_Node);
+ pragma Assert (Left (Tree.First) = null);
+ pragma Assert (Right (Tree.Last) = null);
declare
L : constant Node_Access := Left (Root);
W := Right (Parent (X));
end if;
- if (Left (W) = Null_Node or else Color (Left (W)) = Black)
+ if (Left (W) = null or else Color (Left (W)) = Black)
and then
- (Right (W) = Null_Node or else Color (Right (W)) = Black)
+ (Right (W) = null or else Color (Right (W)) = Black)
then
Set_Color (W, Red);
X := Parent (X);
else
- if Right (W) = Null_Node
+ if Right (W) = null
or else Color (Right (W)) = Black
then
- if Left (W) /= Null_Node then
+ if Left (W) /= null then
Set_Color (Left (W), Black);
end if;
W := Left (Parent (X));
end if;
- if (Left (W) = Null_Node or else Color (Left (W)) = Black)
+ if (Left (W) = null or else Color (Left (W)) = Black)
and then
- (Right (W) = Null_Node or else Color (Right (W)) = Black)
+ (Right (W) = null or else Color (Right (W)) = Black)
then
Set_Color (W, Red);
X := Parent (X);
else
- if Left (W) = Null_Node or else Color (Left (W)) = Black then
- if Right (W) /= Null_Node then
+ if Left (W) = null or else Color (Left (W)) = Black then
+ if Right (W) /= null then
Set_Color (Right (W), Black);
end if;
X, Y : Node_Access;
Z : constant Node_Access := Node;
- pragma Assert (Z /= Null_Node);
+ pragma Assert (Z /= null);
begin
+ if Tree.Busy > 0 then
+ raise Program_Error;
+ end if;
+
pragma Assert (Tree.Length > 0);
- pragma Assert (Tree.Root /= Null_Node);
- pragma Assert (Tree.First /= Null_Node);
- pragma Assert (Tree.Last /= Null_Node);
- pragma Assert (Parent (Tree.Root) = Null_Node);
+ pragma Assert (Tree.Root /= null);
+ pragma Assert (Tree.First /= null);
+ pragma Assert (Tree.Last /= null);
+ pragma Assert (Parent (Tree.Root) = null);
pragma Assert ((Tree.Length > 1)
or else (Tree.First = Tree.Last
and then Tree.First = Tree.Root));
- pragma Assert ((Left (Node) = Null_Node)
+ pragma Assert ((Left (Node) = null)
or else (Parent (Left (Node)) = Node));
- pragma Assert ((Right (Node) = Null_Node)
+ pragma Assert ((Right (Node) = null)
or else (Parent (Right (Node)) = Node));
- pragma Assert (((Parent (Node) = Null_Node) and then (Tree.Root = Node))
- or else ((Parent (Node) /= Null_Node) and then
+ pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node))
+ or else ((Parent (Node) /= null) and then
((Left (Parent (Node)) = Node)
or else (Right (Parent (Node)) = Node))));
- if Left (Z) = Null_Node then
- if Right (Z) = Null_Node then
+ if Left (Z) = null then
+ if Right (Z) = null then
if Z = Tree.First then
Tree.First := Parent (Z);
end if;
Delete_Fixup (Tree, Z);
end if;
- pragma Assert (Left (Z) = Null_Node);
- pragma Assert (Right (Z) = Null_Node);
+ pragma Assert (Left (Z) = null);
+ pragma Assert (Right (Z) = null);
if Z = Tree.Root then
pragma Assert (Tree.Length = 1);
- pragma Assert (Parent (Z) = Null_Node);
- Tree.Root := Null_Node;
+ pragma Assert (Parent (Z) = null);
+ Tree.Root := null;
elsif Z = Left (Parent (Z)) then
- Set_Left (Parent (Z), Null_Node);
+ Set_Left (Parent (Z), null);
else
pragma Assert (Z = Right (Parent (Z)));
- Set_Right (Parent (Z), Null_Node);
+ Set_Right (Parent (Z), null);
end if;
else
end if;
end if;
- elsif Right (Z) = Null_Node then
+ elsif Right (Z) = null then
pragma Assert (Z /= Tree.First);
X := Left (Z);
pragma Assert (Z /= Tree.Last);
Y := Next (Z);
- pragma Assert (Left (Y) = Null_Node);
+ pragma Assert (Left (Y) = null);
X := Right (Y);
- if X = Null_Node then
+ if X = null then
if Y = Left (Parent (Y)) then
pragma Assert (Parent (Y) /= Z);
Delete_Swap (Tree, Z, Y);
Set_Parent (Left (Y), Y);
Set_Right (Y, Z);
Set_Parent (Z, Y);
- Set_Left (Z, Null_Node);
- Set_Right (Z, Null_Node);
+ Set_Left (Z, null);
+ Set_Right (Z, null);
declare
Y_Color : constant Color_Type := Color (Y);
Delete_Fixup (Tree, Z);
end if;
- pragma Assert (Left (Z) = Null_Node);
- pragma Assert (Right (Z) = Null_Node);
+ pragma Assert (Left (Z) = null);
+ pragma Assert (Right (Z) = null);
if Z = Right (Parent (Z)) then
- Set_Right (Parent (Z), Null_Node);
+ Set_Right (Parent (Z), null);
else
pragma Assert (Z = Left (Parent (Z)));
- Set_Left (Parent (Z), Null_Node);
+ Set_Left (Parent (Z), null);
end if;
else
Set_Left (Parent (Y), Y);
end if;
- if Right (Y) /= Null_Node then
+ if Right (Y) /= null then
Set_Parent (Right (Y), Y);
end if;
- if Left (Y) /= Null_Node then
+ if Left (Y) /= null then
Set_Parent (Left (Y), Y);
end if;
Set_Parent (Z, Y_Parent);
Set_Color (Z, Y_Color);
- Set_Left (Z, Null_Node);
- Set_Right (Z, Null_Node);
+ Set_Left (Z, null);
+ Set_Right (Z, null);
end Delete_Swap;
+ --------------------
+ -- Generic_Adjust --
+ --------------------
+
+ procedure Generic_Adjust (Tree : in out Tree_Type) is
+ N : constant Count_Type := Tree.Length;
+ Root : constant Node_Access := Tree.Root;
+
+ begin
+ if N = 0 then
+ pragma Assert (Root = null);
+ pragma Assert (Tree.Busy = 0);
+ pragma Assert (Tree.Lock = 0);
+ return;
+ end if;
+
+ Tree.Root := null;
+ Tree.First := null;
+ Tree.Last := null;
+ Tree.Length := 0;
+
+ Tree.Root := Copy_Tree (Root);
+ Tree.First := Min (Tree.Root);
+ Tree.Last := Max (Tree.Root);
+ Tree.Length := N;
+ end Generic_Adjust;
+
+ -------------------
+ -- Generic_Clear --
+ -------------------
+
+ procedure Generic_Clear (Tree : in out Tree_Type) is
+ Root : Node_Access := Tree.Root;
+ begin
+ if Tree.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ Tree := (First => null,
+ Last => null,
+ Root => null,
+ Length => 0,
+ Busy => 0,
+ Lock => 0);
+
+ Delete_Tree (Root);
+ end Generic_Clear;
+
+ -----------------------
+ -- Generic_Copy_Tree --
+ -----------------------
+
+ function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is
+ Target_Root : Node_Access := Copy_Node (Source_Root);
+ P, X : Node_Access;
+
+ begin
+
+ if Right (Source_Root) /= null then
+ Set_Right
+ (Node => Target_Root,
+ Right => Generic_Copy_Tree (Right (Source_Root)));
+
+ Set_Parent
+ (Node => Right (Target_Root),
+ Parent => Target_Root);
+ end if;
+
+ P := Target_Root;
+
+ X := Left (Source_Root);
+ while X /= null loop
+ declare
+ Y : constant Node_Access := Copy_Node (X);
+ begin
+ Set_Left (Node => P, Left => Y);
+ Set_Parent (Node => Y, Parent => P);
+
+ if Right (X) /= null then
+ Set_Right
+ (Node => Y,
+ Right => Generic_Copy_Tree (Right (X)));
+
+ Set_Parent
+ (Node => Right (Y),
+ Parent => Y);
+ end if;
+
+ P := Y;
+ X := Left (X);
+ end;
+ end loop;
+
+ return Target_Root;
+ exception
+ when others =>
+ Delete_Tree (Target_Root);
+ raise;
+
+ end Generic_Copy_Tree;
+
+ -------------------------
+ -- Generic_Delete_Tree --
+ -------------------------
+
+ procedure Generic_Delete_Tree (X : in out Node_Access) is
+ Y : Node_Access;
+ begin
+ while X /= null loop
+ Y := Right (X);
+ Generic_Delete_Tree (Y);
+ Y := Left (X);
+ Free (X);
+ X := Y;
+ end loop;
+ end Generic_Delete_Tree;
+
-------------------
-- Generic_Equal --
-------------------
R_Node : Node_Access;
begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
if Left.Length /= Right.Length then
return False;
end if;
L_Node := Left.First;
R_Node := Right.First;
- while L_Node /= Null_Node loop
+ while L_Node /= null loop
if not Is_Equal (L_Node, R_Node) then
return False;
end if;
procedure Iterate (P : Node_Access) is
X : Node_Access := P;
begin
- while X /= Null_Node loop
+ while X /= null loop
Iterate (Left (X));
Process (X);
X := Right (X);
end Generic_Iteration;
------------------
- -- Generic_Read --
+ -- Generic_Move --
------------------
- procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type) is
+ procedure Generic_Move (Target, Source : in out Tree_Type) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
- pragma Assert (Tree.Length = 0);
- -- Clear and back node reinit was done by caller
+ if Source.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ Clear (Target);
+
+ Target := Source;
+
+ Source := (First => null,
+ Last => null,
+ Root => null,
+ Length => 0,
+ Busy => 0,
+ Lock => 0);
+ end Generic_Move;
+
+ ------------------
+ -- Generic_Read --
+ ------------------
+
+ procedure Generic_Read
+ (Stream : access Root_Stream_Type'Class;
+ Tree : in out Tree_Type)
+ is
+ N : Count_Type'Base;
Node, Last_Node : Node_Access;
begin
+ Clear (Tree);
+
+ Count_Type'Base'Read (Stream, N);
+ pragma Assert (N >= 0);
+
if N = 0 then
return;
end if;
- Node := New_Node;
- pragma Assert (Node /= Null_Node);
+ Node := Read_Node (Stream);
+ pragma Assert (Node /= null);
pragma Assert (Color (Node) = Red);
Set_Color (Node, Black);
Last_Node := Node;
pragma Assert (Last_Node = Tree.Last);
- Node := New_Node;
- pragma Assert (Node /= Null_Node);
+ Node := Read_Node (Stream);
+ pragma Assert (Node /= null);
pragma Assert (Color (Node) = Red);
Set_Right (Node => Last_Node, Right => Node);
procedure Iterate (P : Node_Access) is
X : Node_Access := P;
begin
- while X /= Null_Node loop
+ while X /= null loop
Iterate (Right (X));
Process (X);
X := Left (X);
Iterate (Tree.Root);
end Generic_Reverse_Iteration;
+ -------------------
+ -- Generic_Write --
+ -------------------
+
+ procedure Generic_Write
+ (Stream : access Root_Stream_Type'Class;
+ Tree : in Tree_Type)
+ is
+ procedure Process (Node : Node_Access);
+ pragma Inline (Process);
+
+ procedure Iterate is
+ new Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Node : Node_Access) is
+ begin
+ Write_Node (Stream, Node);
+ end Process;
+
+ -- Start of processing for Generic_Write
+
+ begin
+ Count_Type'Base'Write (Stream, Tree.Length);
+ Iterate (Tree);
+ end Generic_Write;
+
-----------------
-- Left_Rotate --
-----------------
-- CLR p266 ???
Y : constant Node_Access := Right (X);
- pragma Assert (Y /= Null_Node);
+ pragma Assert (Y /= null);
begin
Set_Right (X, Left (Y));
- if Left (Y) /= Null_Node then
+ if Left (Y) /= null then
Set_Parent (Left (Y), X);
end if;
loop
Y := Right (X);
- if Y = Null_Node then
+ if Y = null then
return X;
end if;
loop
Y := Left (X);
- if Y = Null_Node then
+ if Y = null then
return X;
end if;
end loop;
end Min;
- ----------
- -- Move --
- ----------
-
- procedure Move (Target, Source : in out Tree_Type) is
- begin
- if Target.Length > 0 then
- raise Constraint_Error;
- end if;
-
- Target := Source;
- Source := (First => Null_Node,
- Last => Null_Node,
- Root => Null_Node,
- Length => 0);
- end Move;
-
----------
-- Next --
----------
begin
-- CLR p249 ???
- if Node = Null_Node then
- return Null_Node;
+ if Node = null then
+ return null;
end if;
- if Right (Node) /= Null_Node then
+ if Right (Node) /= null then
return Min (Right (Node));
end if;
Y : Node_Access := Parent (Node);
begin
- while Y /= Null_Node
+ while Y /= null
and then X = Right (Y)
loop
X := Y;
function Previous (Node : Node_Access) return Node_Access is
begin
- if Node = Null_Node then
- return Null_Node;
+ if Node = null then
+ return null;
end if;
- if Left (Node) /= Null_Node then
+ if Left (Node) /= null then
return Max (Left (Node));
end if;
Y : Node_Access := Parent (Node);
begin
- while Y /= Null_Node
+ while Y /= null
and then X = Left (Y)
loop
X := Y;
-- CLR p.268 ???
X : Node_Access := Node;
- pragma Assert (X /= Null_Node);
+ pragma Assert (X /= null);
pragma Assert (Color (X) = Red);
Y : Node_Access;
if Parent (X) = Left (Parent (Parent (X))) then
Y := Right (Parent (Parent (X)));
- if Y /= Null_Node and then Color (Y) = Red then
+ if Y /= null and then Color (Y) = Red then
Set_Color (Parent (X), Black);
Set_Color (Y, Black);
Set_Color (Parent (Parent (X)), Red);
Y := Left (Parent (Parent (X)));
- if Y /= Null_Node and then Color (Y) = Red then
+ if Y /= null and then Color (Y) = Red then
Set_Color (Parent (X), Black);
Set_Color (Y, Black);
Set_Color (Parent (Parent (X)), Red);
procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is
X : constant Node_Access := Left (Y);
- pragma Assert (X /= Null_Node);
+ pragma Assert (X /= null);
begin
Set_Left (Y, Right (X));
- if Right (X) /= Null_Node then
+ if Right (X) /= null then
Set_Parent (Right (X), Y);
end if;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS --
+-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . --
+-- G E N E R I C _ O P E R A T I O N S --
-- --
-- S p e c --
-- --
--- This specification is adapted from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT 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. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; 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. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+with Ada.Streams; use Ada.Streams;
+
generic
with package Tree_Types is new Generic_Tree_Types (<>);
use Tree_Types;
- Null_Node : Node_Access;
-
with function Parent (Node : Node_Access) return Node_Access is <>;
with procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is <>;
with function Left (Node : Node_Access) return Node_Access is <>;
function Previous (Node : Node_Access) return Node_Access;
- procedure Move (Target, Source : in out Tree_Type);
-
generic
with function Is_Equal (L, R : Node_Access) return Boolean;
function Generic_Equal (Left, Right : Tree_Type) return Boolean;
(Tree : in out Tree_Type;
Node : Node_Access);
+ generic
+ with procedure Free (X : in out Node_Access);
+ procedure Generic_Delete_Tree (X : in out Node_Access);
+
+ generic
+ with function Copy_Node (Source : Node_Access) return Node_Access;
+ with procedure Delete_Tree (X : in out Node_Access);
+ function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access;
+
+ generic
+ with function Copy_Tree (Root : Node_Access) return Node_Access;
+ procedure Generic_Adjust (Tree : in out Tree_Type);
+
+ generic
+ with procedure Delete_Tree (X : in out Node_Access);
+ procedure Generic_Clear (Tree : in out Tree_Type);
+
+ generic
+ with procedure Clear (Tree : in out Tree_Type);
+ procedure Generic_Move (Target, Source : in out Tree_Type);
+
generic
with procedure Process (Node : Node_Access) is <>;
procedure Generic_Iteration (Tree : Tree_Type);
procedure Generic_Reverse_Iteration (Tree : Tree_Type);
generic
- with function New_Node return Node_Access is <>;
- procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type);
+ with procedure Write_Node
+ (Stream : access Root_Stream_Type'Class;
+ Node : Node_Access);
+ procedure Generic_Write
+ (Stream : access Root_Stream_Type'Class;
+ Tree : Tree_Type);
+
+ generic
+ with procedure Clear (Tree : in out Tree_Type);
+ with function Read_Node
+ (Stream : access Root_Stream_Type'Class) return Node_Access;
+ procedure Generic_Read
+ (Stream : access Root_Stream_Type'Class;
+ Tree : in out Tree_Type);
procedure Rebalance_For_Insert
(Tree : in out Tree_Type;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS --
+-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . --
+-- G E N E R I C _ S E T _ O P E R A T I O N S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+with System; use type System.Address;
+
package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Clear (Tree : in out Tree_Type);
+
+ function Copy (Source : Tree_Type) return Tree_Type;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Tree : in out Tree_Type) is
+ pragma Assert (Tree.Busy = 0);
+ pragma Assert (Tree.Lock = 0);
+
+ Root : Node_Access := Tree.Root;
+
+ begin
+ Tree.Root := null;
+ Tree.First := null;
+ Tree.Last := null;
+ Tree.Length := 0;
+
+ Delete_Tree (Root);
+ end Clear;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy (Source : Tree_Type) return Tree_Type is
+ Target : Tree_Type;
+
+ begin
+ if Source.Length = 0 then
+ return Target;
+ end if;
+
+ Target.Root := Copy_Tree (Source.Root);
+ Target.First := Tree_Operations.Min (Target.Root);
+ Target.Last := Tree_Operations.Max (Target.Root);
+ Target.Length := Source.Length;
+
+ return Target;
+ end Copy;
+
----------------
-- Difference --
----------------
Src : Node_Access := Source.First;
begin
+ if Target'Address = Source'Address then
+ if Target.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ Clear (Target);
+ return;
+ end if;
+
+ if Source.Length = 0 then
+ return;
+ end if;
- -- NOTE: must be done by client:
- -- if Target'Address = Source'Address then
- -- Clear (Target);
- -- return;
- -- end if;
+ if Target.Busy > 0 then
+ raise Program_Error;
+ end if;
loop
- if Tgt = Tree_Operations.Null_Node then
+ if Tgt = null then
return;
end if;
- if Src = Tree_Operations.Null_Node then
+ if Src = null then
return;
end if;
end Difference;
function Difference (Left, Right : Tree_Type) return Tree_Type is
- Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node);
+ Tree : Tree_Type;
L_Node : Node_Access := Left.First;
R_Node : Node_Access := Right.First;
Dst_Node : Node_Access;
begin
- -- NOTE: must by done by client:
- -- if Left'Address = Right'Address then
- -- return Empty_Set;
- -- end if;
+ if Left'Address = Right'Address then
+ return Tree; -- Empty set
+ end if;
+
+ if Left.Length = 0 then
+ return Tree; -- Empty set
+ end if;
+
+ if Right.Length = 0 then
+ return Copy (Left);
+ end if;
loop
- if L_Node = Tree_Operations.Null_Node then
+ if L_Node = null then
return Tree;
end if;
- if R_Node = Tree_Operations.Null_Node then
- while L_Node /= Tree_Operations.Null_Node loop
+ if R_Node = null then
+ while L_Node /= null loop
Insert_With_Hint
(Dst_Tree => Tree,
- Dst_Hint => Tree_Operations.Null_Node,
+ Dst_Hint => null,
Src_Node => L_Node,
Dst_Node => Dst_Node);
if Is_Less (L_Node, R_Node) then
Insert_With_Hint
(Dst_Tree => Tree,
- Dst_Hint => Tree_Operations.Null_Node,
+ Dst_Hint => null,
Src_Node => L_Node,
Dst_Node => Dst_Node);
Src : Node_Access := Source.First;
begin
- -- NOTE: must be done by caller: ???
- -- if Target'Address = Source'Address then
- -- return;
- -- end if;
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ if Source.Length = 0 then
+ Clear (Target);
+ return;
+ end if;
- while Tgt /= Tree_Operations.Null_Node
- and then Src /= Tree_Operations.Null_Node
+ while Tgt /= null
+ and then Src /= null
loop
if Is_Less (Tgt, Src) then
declare
Src := Tree_Operations.Next (Src);
end if;
end loop;
+
+ while Tgt /= null loop
+ declare
+ X : Node_Access := Tgt;
+ begin
+ Tgt := Tree_Operations.Next (Tgt);
+ Tree_Operations.Delete_Node_Sans_Free (Target, X);
+ Free (X);
+ end;
+ end loop;
end Intersection;
function Intersection (Left, Right : Tree_Type) return Tree_Type is
- Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node);
+ Tree : Tree_Type;
L_Node : Node_Access := Left.First;
R_Node : Node_Access := Right.First;
Dst_Node : Node_Access;
begin
- -- NOTE: must be done by caller: ???
- -- if Left'Address = Right'Address then
- -- return Left;
- -- end if;
+ if Left'Address = Right'Address then
+ return Copy (Left);
+ end if;
loop
- if L_Node = Tree_Operations.Null_Node then
+ if L_Node = null then
return Tree;
end if;
- if R_Node = Tree_Operations.Null_Node then
+ if R_Node = null then
return Tree;
end if;
else
Insert_With_Hint
(Dst_Tree => Tree,
- Dst_Hint => Tree_Operations.Null_Node,
+ Dst_Hint => null,
Src_Node => L_Node,
Dst_Node => Dst_Node);
Of_Set : Tree_Type) return Boolean
is
begin
- -- NOTE: must by done by caller:
- -- if Subset'Address = Of_Set'Address then
- -- return True;
- -- end if;
+ if Subset'Address = Of_Set'Address then
+ return True;
+ end if;
if Subset.Length > Of_Set.Length then
return False;
declare
Subset_Node : Node_Access := Subset.First;
- Set_Node : Node_Access := Of_Set.First;
+ Set_Node : Node_Access := Of_Set.First;
begin
loop
- if Set_Node = Tree_Operations.Null_Node then
- return Subset_Node = Tree_Operations.Null_Node;
+ if Set_Node = null then
+ return Subset_Node = null;
end if;
- if Subset_Node = Tree_Operations.Null_Node then
+ if Subset_Node = null then
return True;
end if;
R_Node : Node_Access := Right.First;
begin
- -- NOTE: must be done by caller: ???
- -- if Left'Address = Right'Address then
- -- return Left.Tree.Length /= 0;
- -- end if;
+ if Left'Address = Right'Address then
+ return Left.Length /= 0;
+ end if;
loop
- if L_Node = Tree_Operations.Null_Node
- or else R_Node = Tree_Operations.Null_Node
+ if L_Node = null
+ or else R_Node = null
then
return False;
end if;
New_Tgt_Node : Node_Access;
begin
- -- NOTE: must by done by client: ???
- -- if Target'Address = Source'Address then
- -- Clear (Target);
- -- return;
- -- end if;
+ if Target.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
loop
- if Tgt = Tree_Operations.Null_Node then
- while Src /= Tree_Operations.Null_Node loop
+ if Tgt = null then
+ while Src /= null loop
Insert_With_Hint
(Dst_Tree => Target,
- Dst_Hint => Tree_Operations.Null_Node,
+ Dst_Hint => null,
Src_Node => Src,
Dst_Node => New_Tgt_Node);
return;
end if;
- if Src = Tree_Operations.Null_Node then
+ if Src = null then
return;
end if;
end Symmetric_Difference;
function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is
- Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node);
+ Tree : Tree_Type;
L_Node : Node_Access := Left.First;
R_Node : Node_Access := Right.First;
Dst_Node : Node_Access;
begin
- -- NOTE: must by done by caller ???
- -- if Left'Address = Right'Address then
- -- return Empty_Set;
- -- end if;
+ if Left'Address = Right'Address then
+ return Tree; -- Empty set
+ end if;
+
+ if Right.Length = 0 then
+ return Copy (Left);
+ end if;
+
+ if Left.Length = 0 then
+ return Copy (Right);
+ end if;
loop
- if L_Node = Tree_Operations.Null_Node then
- while R_Node /= Tree_Operations.Null_Node loop
+ if L_Node = null then
+ while R_Node /= null loop
Insert_With_Hint
(Dst_Tree => Tree,
- Dst_Hint => Tree_Operations.Null_Node,
+ Dst_Hint => null,
Src_Node => R_Node,
Dst_Node => Dst_Node);
R_Node := Tree_Operations.Next (R_Node);
return Tree;
end if;
- if R_Node = Tree_Operations.Null_Node then
- while L_Node /= Tree_Operations.Null_Node loop
+ if R_Node = null then
+ while L_Node /= null loop
Insert_With_Hint
(Dst_Tree => Tree,
- Dst_Hint => Tree_Operations.Null_Node,
+ Dst_Hint => null,
Src_Node => L_Node,
Dst_Node => Dst_Node);
if Is_Less (L_Node, R_Node) then
Insert_With_Hint
(Dst_Tree => Tree,
- Dst_Hint => Tree_Operations.Null_Node,
+ Dst_Hint => null,
Src_Node => L_Node,
Dst_Node => Dst_Node);
elsif Is_Less (R_Node, L_Node) then
Insert_With_Hint
(Dst_Tree => Tree,
- Dst_Hint => Tree_Operations.Null_Node,
+ Dst_Hint => null,
Src_Node => R_Node,
Dst_Node => Dst_Node);
-- Start of processing for Union
begin
- -- NOTE: must be done by caller: ???
- -- if Target'Address = Source'Address then
- -- return;
- -- end if;
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Busy > 0 then
+ raise Program_Error;
+ end if;
Iterate (Source);
end Union;
function Union (Left, Right : Tree_Type) return Tree_Type is
- Tree : Tree_Type;
-
begin
- -- NOTE: must be done by caller:
- -- if Left'Address = Right'Address then
- -- return Left;
- -- end if;
+ if Left'Address = Right'Address then
+ return Copy (Left);
+ end if;
- declare
- Root : constant Node_Access := Copy_Tree (Left.Root);
- begin
- Tree := (Root => Root,
- First => Tree_Operations.Min (Root),
- Last => Tree_Operations.Max (Root),
- Length => Left.Length);
- end;
+ if Left.Length = 0 then
+ return Copy (Right);
+ end if;
+
+ if Right.Length = 0 then
+ return Copy (Left);
+ end if;
declare
+ Tree : Tree_Type := Copy (Left);
+
Hint : Node_Access;
procedure Process (Node : Node_Access);
begin
Iterate (Right);
+ return Tree;
exception
when others =>
raise;
end;
- return Tree;
end Union;
end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.STRINGS.HASH_CASE_INSENSITIVE --
+-- A D A . S T R I N G S . H A S H _ C A S E _ I N S E N S I T I V E --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
begin
Tmp := 0;
for J in Key'Range loop
- Tmp := Rotate_Left (Tmp, 1) + Character'Pos (To_Lower (Key (J)));
+ Tmp := Rotate_Left (Tmp, 3) + Character'Pos (To_Lower (Key (J)));
end loop;
return Tmp;
end Ada.Strings.Hash_Case_Insensitive;
-
-
-
-
-
-
-
-
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.STRINGS.HASH_CASE_INSENSITIVE --
+-- A D A . S T R I N G S . H A S H _ C A S E _ I N S E N S I T I V E --
-- --
-- S p e c --
-- --
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.STRINGS.HASH --
+-- A D A . S T R I N G S . H A S H --
-- --
--- B o d y --
+-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
begin
Tmp := 0;
for J in Key'Range loop
- Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J));
+ Tmp := Rotate_Left (Tmp, 3) + Character'Pos (Key (J));
end loop;
return Tmp;
end Ada.Strings.Hash;
-
-
-
-
-
-
-
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.STRINGS.UNBOUNDED.HASH --
+-- A D A . S T R I N G S . U N B O U N D E D . H A S H --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
begin
Tmp := 0;
for J in 1 .. Key.Last loop
- Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key.Reference (J));
+ Tmp := Rotate_Left (Tmp, 3) + Character'Pos (Key.Reference (J));
end loop;
return Tmp;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.STRINGS.WIDE_HASH --
+-- A D A . S T R I N G S . W I D E _ H A S H --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
begin
Tmp := 0;
for J in Key'Range loop
- Tmp := Rotate_Left (Tmp, 1) + Wide_Character'Pos (Key (J));
+ Tmp := Rotate_Left (Tmp, 3) + Wide_Character'Pos (Key (J));
end loop;
return Tmp;
end Ada.Strings.Wide_Hash;
-
-
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- ADA.STRINGS.WIDE_HASH --
+-- A D A . S T R I N G S . W I D E _ H A S H --
-- --
-- S p e c --
-- --
(Key : Wide_String) return Containers.Hash_Type;
pragma Pure (Ada.Strings.Wide_Hash);
-
-
-
begin
Tmp := 0;
for J in Key'Range loop
- Tmp := Rotate_Left (Tmp, 1) + Wide_Wide_Character'Pos (Key (J));
+ Tmp := Rotate_Left (Tmp, 3) + Wide_Wide_Character'Pos (Key (J));
end loop;
return Tmp;
end Ada.Strings.Wide_Wide_Hash;
-
-
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.STRINGS.WIDE_UNBOUNDED.HASH --
--- --
--- B o d y --
--- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT 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. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; 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. --
--- --
--- This unit was originally developed by Matthew J Heaney. --
-------------------------------------------------------------------------------
-
--- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
-
-function Ada.Strings.Wide_Unbounded.Hash
- (Key : Unbounded_Wide_String) return Containers.Hash_Type
-is
- use Ada.Containers;
-
- function Rotate_Left
- (Value : Hash_Type;
- Amount : Natural) return Hash_Type;
- pragma Import (Intrinsic, Rotate_Left);
-
- Tmp : Hash_Type;
-
-begin
- Tmp := 0;
- for J in 1 .. Key.Last loop
- Tmp := Rotate_Left (Tmp, 1) + Wide_Character'Pos (Key.Reference (J));
- end loop;
-
- return Tmp;
-end Ada.Strings.Wide_Unbounded.Hash;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.STRINGS.WIDE_UNBOUNDED.HASH --
--- --
--- S p e c --
--- --
--- This specification is adapted from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Containers;
-
-function Ada.Strings.Wide_Unbounded.Hash
- (Key : Unbounded_Wide_String) return Containers.Hash_Type;
-
-pragma Preelaborate (Ada.Strings.Wide_Unbounded.Hash);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT 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. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; 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. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Wide_Unbounded.Wide_Hash
+ (Key : Unbounded_Wide_String) return Containers.Hash_Type
+is
+ use Ada.Containers;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Hash_Type;
+
+begin
+ Tmp := 0;
+ for J in 1 .. Key.Last loop
+ Tmp := Rotate_Left (Tmp, 3) + Wide_Character'Pos (Key.Reference (J));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Wide_Unbounded.Wide_Hash;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+function Ada.Strings.Wide_Unbounded.Wide_Hash
+ (Key : Unbounded_Wide_String) return Containers.Hash_Type;
+
+pragma Preelaborate (Ada.Strings.Wide_Unbounded.Wide_Hash);
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . S T R I N G S . W I D E _ U N B O U N D E D . H A S H --
--- --
--- B o d y --
--- --
--- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT 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. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; 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. --
--- --
--- This unit was originally developed by Matthew J Heaney. --
-------------------------------------------------------------------------------
-
--- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
-
-function Ada.Strings.Wide_Wide_Unbounded.Hash
- (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type
-is
- use Ada.Containers;
-
- function Rotate_Left
- (Value : Hash_Type;
- Amount : Natural) return Hash_Type;
- pragma Import (Intrinsic, Rotate_Left);
-
- Tmp : Hash_Type;
-
-begin
- Tmp := 0;
- for J in 1 .. Key.Last loop
- Tmp := Rotate_Left (Tmp, 1) +
- Wide_Wide_Character'Pos (Key.Reference (J));
- end loop;
-
- return Tmp;
-end Ada.Strings.Wide_Wide_Unbounded.Hash;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . S T R I N G S . W I D E _ U N B O U N D E D . H A S H --
--- --
--- S p e c --
--- --
--- This specification is adapted from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Containers;
-
-function Ada.Strings.Wide_Wide_Unbounded.Hash
- (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type;
-
-pragma Preelaborate (Ada.Strings.Wide_Wide_Unbounded.Hash);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT 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. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; 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. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash
+ (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type
+is
+ use Ada.Containers;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Hash_Type;
+
+begin
+ Tmp := 0;
+ for J in 1 .. Key.Last loop
+ Tmp := Rotate_Left (Tmp, 3) +
+ Wide_Wide_Character'Pos (Key.Reference (J));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+function Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash
+ (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type;
+
+pragma Preelaborate (Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash);
projects / gcc.git / commitdiff