[Ada] AI-302
Arnaud Charlet
charlet@adacore.com
Tue Oct 31 20:20:00 GMT 2006
Tested on i686-linux, committed on trunk.
Update Ada containers to latest AI-302 draft, which can be found at:
http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-20302.TXT?rev=1.27
Also, the previous implementation of Generic_Insert_Post was really a hold-over
from a very early design, when the container created a dummy node that served
as the previous node of first and next node of last. A dummy node is no longer
allocated and so when you fall off the end the value is null.
The generic operations that imported an instantiation of Generic_Insert_Post
as a generic formal have also been fixed to match its new signature.
Passing a flag to indicate explicitly which child the new node should be also
has the benefit that it simplifies the implementation of Generic_Insert_Post.
Previously it had to make some tests to determine which child, but that only
duplicated tests already performed by the caller, who can now tell
Generic_Insert_Post directly which child.
In one of the earlier AI-302 drafts, the "Success" parameter of the
conditional insertion operation Insert was renamed to "Inserted", the name
preferred by members of the development community using early versions of the
container library. The Generic_Keys package is used to implement container
Insert, and so the parameter name was changed to match.
The new algorithm is not as conservative as the old one, and now takes
advantage of the fact that the tree can have multiple keys that are equivalent.
There are now fewer tests and (more importantly) fewer searches from the root,
and hence the algorithm should be more efficient.
2006-10-31 Matt Heaney <heaney@adacore.com>
* a-crbtgo.ads: Commented each subprogram
* a-crbtgo.adb: Added reference to book from which algorithms were
adapted.
* a-crbtgk.ads, a-crbtgk.adb (Generic_Insert_Post): pass flag to
indicate which child.
(Generic_Conditional_Insert): changed parameter name from "Success" to
"Inserted".
(Generic_Unconditional_Insert_With_Hint): improved algorithm
* a-coorse.adb (Replace_Element): changed parameter name in call to
conditional insert operation.
* a-convec.adb, a-coinve.adb (Insert): removed obsolete comment
* a-cohama.adb (Iterate): manipulate busy-bit here, instead of in
Generic_Iteration
* a-ciorse.adb (Replace_Element): changed parameter name in call to
conditional insert operation.
* a-cihama.adb (Iterate): manipulate busy-bit here, instead of in
Generic_Iteration.
* a-cidlli.ads, a-cidlli.adb (Splice): Position param is now mode in
instead of mode inout.
* a-chtgop.adb (Adjust): modified comments to reflect current AI-302
draft
(Generic_Read): preserve existing buckets array if possible
(Generic_Write): don't send buckets array length anymore
* a-cdlili.ads, a-cdlili.adb (Splice): Position param is now mode in
instead of mode inout.
* a-cihase.adb (Difference): iterate over smaller of Tgt and Src sets
(Iterate): manipulate busy-bit here, instead of in Generic_Iteration
* a-cohase.adb (Difference): iterate over smaller of Tgt and Src sets
(Iterate): manipulate busy-bit here, instead of in Generic_Iteration
(Replace_Element): local operation is now an instantiation
* a-chtgke.ads, a-chtgke.adb (Generic_Conditional_Insert): manually
check current length.
(Generic_Replace_Element): new operation
-------------- next part --------------
Index: a-crbtgo.ads
===================================================================
--- a-crbtgo.ads (revision 118179)
+++ a-crbtgo.ads (working copy)
@@ -7,11 +7,7 @@
-- --
-- S p e c --
-- --
--- 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. --
+-- Copyright (C) 2004-2006, 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- --
@@ -34,6 +30,9 @@
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+-- Tree_Type is used to implement the ordered containers. This package
+-- declares the tree operations that do not depend on keys.
+
with Ada.Streams; use Ada.Streams;
generic
@@ -53,8 +52,10 @@ package Ada.Containers.Red_Black_Trees.G
pragma Pure;
function Min (Node : Node_Access) return Node_Access;
+ -- Returns the smallest-valued node of the subtree rooted at Node
function Max (Node : Node_Access) return Node_Access;
+ -- Returns the largest-valued node of the subtree rooted at Node
-- NOTE: The Check_Invariant operation was used during early
-- development of the red-black tree. Now that the tree type
@@ -64,47 +65,75 @@ package Ada.Containers.Red_Black_Trees.G
-- procedure Check_Invariant (Tree : Tree_Type);
function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean;
+ -- Inspects Node to determine (to the extent possible) whether
+ -- the node is valid; used to detect if the node is dangling.
function Next (Node : Node_Access) return Node_Access;
+ -- Returns the smallest node greater than Node
function Previous (Node : Node_Access) return Node_Access;
+ -- Returns the largest node less than Node
generic
with function Is_Equal (L, R : Node_Access) return Boolean;
function Generic_Equal (Left, Right : Tree_Type) return Boolean;
+ -- Uses Is_Equal to perform a node-by-node comparison of the
+ -- Left and Right trees; processing stops as soon as the first
+ -- non-equal node is found.
procedure Delete_Node_Sans_Free
(Tree : in out Tree_Type;
Node : Node_Access);
+ -- Removes Node from Tree without deallocating the node. If Tree
+ -- is busy then Program_Error is raised.
generic
with procedure Free (X : in out Node_Access);
procedure Generic_Delete_Tree (X : in out Node_Access);
+ -- Deallocates the tree rooted at X, calling Free on each node
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;
+ -- Copies the tree rooted at Source_Root, using Copy_Node to copy each
+ -- node of the source tree. If Copy_Node propagates an exception
+ -- (e.g. Storage_Error), then Delete_Tree is first used to deallocate
+ -- the target tree, and then the exception is propagated.
generic
with function Copy_Tree (Root : Node_Access) return Node_Access;
procedure Generic_Adjust (Tree : in out Tree_Type);
+ -- Used to implement controlled Adjust. On input to Generic_Adjust, Tree
+ -- holds a bitwise (shallow) copy of the source tree (as would be the case
+ -- when controlled Adjust is called). On output, Tree holds its own (deep)
+ -- copy of the source tree, which is constructed by calling Copy_Tree.
generic
with procedure Delete_Tree (X : in out Node_Access);
procedure Generic_Clear (Tree : in out Tree_Type);
+ -- Clears Tree by deallocating all of its nodes. If Tree is busy then
+ -- Program_Error is raised.
generic
with procedure Clear (Tree : in out Tree_Type);
procedure Generic_Move (Target, Source : in out Tree_Type);
+ -- Moves the tree belonging to Source onto Target. If Source is busy then
+ -- Program_Error is raised. Otherwise Target is first cleared (by calling
+ -- Clear, to deallocate its existing tree), then given the Source tree, and
+ -- then finally Source is cleared (by setting its pointers to null).
generic
with procedure Process (Node : Node_Access) is <>;
procedure Generic_Iteration (Tree : Tree_Type);
+ -- Calls Process for each node in Tree, in order from smallest-valued
+ -- node to largest-valued node.
generic
with procedure Process (Node : Node_Access) is <>;
procedure Generic_Reverse_Iteration (Tree : Tree_Type);
+ -- Calls Process for each node in Tree, in order from largest-valued
+ -- node to smallest-valued node.
generic
with procedure Write_Node
@@ -113,6 +142,9 @@ package Ada.Containers.Red_Black_Trees.G
procedure Generic_Write
(Stream : access Root_Stream_Type'Class;
Tree : Tree_Type);
+ -- Used to implement stream attribute T'Write. Generic_Write
+ -- first writes the number of nodes into Stream, then calls
+ -- Write_Node for each node in Tree.
generic
with procedure Clear (Tree : in out Tree_Type);
@@ -121,9 +153,14 @@ package Ada.Containers.Red_Black_Trees.G
procedure Generic_Read
(Stream : access Root_Stream_Type'Class;
Tree : in out Tree_Type);
+ -- Used to implement stream attribute T'Read. Generic_Read
+ -- first clears Tree. It then reads the number of nodes out of
+ -- Stream, and calls Read_Node for each node in Stream.
procedure Rebalance_For_Insert
(Tree : in out Tree_Type;
Node : Node_Access);
+ -- This rebalances Tree to complete the insertion of Node (which
+ -- must already be linked in at its proper insertion position).
end Ada.Containers.Red_Black_Trees.Generic_Operations;
Index: a-crbtgo.adb
===================================================================
--- a-crbtgo.adb (revision 118179)
+++ a-crbtgo.adb (working copy)
@@ -9,10 +9,6 @@
-- --
-- Copyright (C) 2004-2006, 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- --
@@ -34,6 +30,13 @@
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+-- The references below to "CLR" refer to the following book, from which
+-- several of the algorithms here were adapted:
+-- Introduction to Algorithms
+-- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest
+-- Publisher: The MIT Press (June 18, 1990)
+-- ISBN: 0262031418
+
with System; use type System.Address;
package body Ada.Containers.Red_Black_Trees.Generic_Operations is
@@ -141,7 +144,7 @@ package body Ada.Containers.Red_Black_Tr
procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is
- -- CLR p274 ???
+ -- CLR p274
X : Node_Access := Node;
W : Node_Access;
@@ -237,7 +240,7 @@ package body Ada.Containers.Red_Black_Tr
(Tree : in out Tree_Type;
Node : Node_Access)
is
- -- CLR p273 ???
+ -- CLR p273
X, Y : Node_Access;
@@ -804,7 +807,7 @@ package body Ada.Containers.Red_Black_Tr
procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
- -- CLR p266 ???
+ -- CLR p266
Y : constant Node_Access := Right (X);
pragma Assert (Y /= null);
@@ -837,7 +840,7 @@ package body Ada.Containers.Red_Black_Tr
function Max (Node : Node_Access) return Node_Access is
- -- CLR p248 ???
+ -- CLR p248
X : Node_Access := Node;
Y : Node_Access;
@@ -860,7 +863,7 @@ package body Ada.Containers.Red_Black_Tr
function Min (Node : Node_Access) return Node_Access is
- -- CLR p248 ???
+ -- CLR p248
X : Node_Access := Node;
Y : Node_Access;
@@ -883,7 +886,7 @@ package body Ada.Containers.Red_Black_Tr
function Next (Node : Node_Access) return Node_Access is
begin
- -- CLR p249 ???
+ -- CLR p249
if Node = null then
return null;
@@ -905,14 +908,6 @@ package body Ada.Containers.Red_Black_Tr
Y := Parent (Y);
end loop;
- -- Why is this code commented out ???
-
--- if Right (X) /= Y then
--- return Y;
--- else
--- return X;
--- end if;
-
return Y;
end;
end Next;
@@ -943,14 +938,6 @@ package body Ada.Containers.Red_Black_Tr
Y := Parent (Y);
end loop;
- -- Why is this code commented out ???
-
--- if Left (X) /= Y then
--- return Y;
--- else
--- return X;
--- end if;
-
return Y;
end;
end Previous;
@@ -963,7 +950,7 @@ package body Ada.Containers.Red_Black_Tr
(Tree : in out Tree_Type;
Node : Node_Access)
is
- -- CLR p.268 ???
+ -- CLR p.268
X : Node_Access := Node;
pragma Assert (X /= null);
Index: a-crbtgk.ads
===================================================================
--- a-crbtgk.ads (revision 118179)
+++ a-crbtgk.ads (working copy)
@@ -7,13 +7,32 @@
-- --
-- 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-2006, 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- --
+-- 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, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, 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. --
------------------------------------------------------------------------------
+-- Tree_Type is used to implement ordered containers. This package declares
+-- the tree operations that depend on keys.
+
with Ada.Containers.Red_Black_Trees.Generic_Operations;
generic
@@ -37,42 +56,58 @@ package Ada.Containers.Red_Black_Trees.G
generic
with function New_Node return Node_Access;
procedure Generic_Insert_Post
- (Tree : in out Tree_Type;
- X, Y : Node_Access;
- Key : Key_Type;
- Z : out Node_Access);
+ (Tree : in out Tree_Type;
+ Y : Node_Access;
+ Before : Boolean;
+ Z : out Node_Access);
+ -- Completes an insertion after the insertion position has been
+ -- determined. On output Z contains a pointer to the newly inserted
+ -- node, allocated using New_Node. If Tree is busy then
+ -- Program_Error is raised. If Y is null, then Tree must be empty.
+ -- Otherwise Y denotes the insertion position, and Before specifies
+ -- whether the new node is Y's left (True) or right (False) child.
generic
with procedure Insert_Post
- (Tree : in out Tree_Type;
- X, Y : Node_Access;
- Key : Key_Type;
- Z : out Node_Access);
+ (T : in out Tree_Type;
+ Y : Node_Access;
+ B : Boolean;
+ Z : out Node_Access);
procedure Generic_Conditional_Insert
- (Tree : in out Tree_Type;
- Key : Key_Type;
- Node : out Node_Access;
- Success : out Boolean);
+ (Tree : in out Tree_Type;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Inserted : out Boolean);
+ -- Inserts a new node in Tree, but only if the tree does not already
+ -- contain Key. Generic_Conditional_Insert first searches for a key
+ -- equivalent to Key in Tree. If an equivalent key is found, then on
+ -- output Node designates the node with that key and Inserted is
+ -- False; there is no allocation and Tree is not modified. Otherwise
+ -- Node designates a new node allocated using Insert_Post, and
+ -- Inserted is True.
generic
with procedure Insert_Post
- (Tree : in out Tree_Type;
- X, Y : Node_Access;
- Key : Key_Type;
- Z : out Node_Access);
+ (T : in out Tree_Type;
+ Y : Node_Access;
+ B : Boolean;
+ Z : out Node_Access);
procedure Generic_Unconditional_Insert
(Tree : in out Tree_Type;
Key : Key_Type;
Node : out Node_Access);
+ -- Inserts a new node in Tree. On output Node designates the new
+ -- node, which is allocated using Insert_Post. The node is inserted
+ -- immediately after already-existing equivalent keys.
generic
with procedure Insert_Post
- (Tree : in out Tree_Type;
- X, Y : Node_Access;
- Key : Key_Type;
- Z : out Node_Access);
+ (T : in out Tree_Type;
+ Y : Node_Access;
+ B : Boolean;
+ Z : out Node_Access);
with procedure Unconditional_Insert_Sans_Hint
(Tree : in out Tree_Type;
@@ -84,53 +119,77 @@ package Ada.Containers.Red_Black_Trees.G
Hint : Node_Access;
Key : Key_Type;
Node : out Node_Access);
+ -- Inserts a new node in Tree near position Hint, to avoid having to
+ -- search from the root for the insertion position. If Hint is null
+ -- then Generic_Unconditional_Insert_With_Hint attempts to insert
+ -- the new node after Tree.Last. If Hint is non-null then if Key is
+ -- less than Hint, it attempts to insert the new node immediately
+ -- prior to Hint. Otherwise it attempts to insert the node
+ -- immediately following Hint. We say "attempts" above to emphasize
+ -- that insertions always preserve invariants with respect to key
+ -- order, even when there's a hint. So if Key can't be inserted
+ -- immediately near Hint, then the new node is inserted in the
+ -- normal way, by searching for the correct position starting from
+ -- the root.
generic
with procedure Insert_Post
- (Tree : in out Tree_Type;
- X, Y : Node_Access;
- Key : Key_Type;
- Z : out Node_Access);
+ (T : in out Tree_Type;
+ Y : Node_Access;
+ B : Boolean;
+ Z : out Node_Access);
with procedure Conditional_Insert_Sans_Hint
- (Tree : in out Tree_Type;
- Key : Key_Type;
- Node : out Node_Access;
- Success : out Boolean);
+ (Tree : in out Tree_Type;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Inserted : out Boolean);
procedure Generic_Conditional_Insert_With_Hint
(Tree : in out Tree_Type;
- Position : Node_Access;
+ Position : Node_Access; -- the hint
Key : Key_Type;
Node : out Node_Access;
- Success : out Boolean);
+ Inserted : out Boolean);
+ -- Inserts a new node in Tree if the tree does not already contain
+ -- Key, using Position as a hint about where to insert the new node.
+ -- See Generic_Unconditional_Insert_With_Hint for more details about
+ -- hint semantics.
function Find
(Tree : Tree_Type;
Key : Key_Type) return Node_Access;
+ -- Searches Tree for the smallest node equivalent to Key
function Ceiling
(Tree : Tree_Type;
Key : Key_Type) return Node_Access;
+ -- Searches Tree for the smallest node equal to or greater than Key
function Floor
(Tree : Tree_Type;
Key : Key_Type) return Node_Access;
+ -- Searches Tree for the largest node less than or equal to Key
function Upper_Bound
(Tree : Tree_Type;
Key : Key_Type) return Node_Access;
+ -- Searches Tree for the smallest node greater than Key
generic
with procedure Process (Node : Node_Access);
procedure Generic_Iteration
(Tree : Tree_Type;
Key : Key_Type);
+ -- Calls Process for each node in Tree equivalent to Key, in order
+ -- from earliest in range to latest.
generic
with procedure Process (Node : Node_Access);
procedure Generic_Reverse_Iteration
(Tree : Tree_Type;
Key : Key_Type);
+ -- Calls Process for each node in Tree equivalent to Key, but in
+ -- order from largest in range to earliest.
end Ada.Containers.Red_Black_Trees.Generic_Keys;
Index: a-crbtgk.adb
===================================================================
--- a-crbtgk.adb (revision 118179)
+++ a-crbtgk.adb (working copy)
@@ -7,11 +7,7 @@
-- --
-- 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. --
+-- Copyright (C) 2004-2006, 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- --
@@ -44,11 +40,12 @@ package body Ada.Containers.Red_Black_Tr
-- AKA Lower_Bound
- function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is
+ function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is
Y : Node_Access;
- X : Node_Access := Tree.Root;
+ X : Node_Access;
begin
+ X := Tree.Root;
while X /= null loop
if Is_Greater_Key_Node (Key, X) then
X := Ops.Right (X);
@@ -67,9 +64,10 @@ package body Ada.Containers.Red_Black_Tr
function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is
Y : Node_Access;
- X : Node_Access := Tree.Root;
+ X : Node_Access;
begin
+ X := Tree.Root;
while X /= null loop
if Is_Greater_Key_Node (Key, X) then
X := Ops.Right (X);
@@ -96,9 +94,10 @@ package body Ada.Containers.Red_Black_Tr
function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is
Y : Node_Access;
- X : Node_Access := Tree.Root;
+ X : Node_Access;
begin
+ X := Tree.Root;
while X /= null loop
if Is_Less_Key_Node (Key, X) then
X := Ops.Left (X);
@@ -116,45 +115,55 @@ package body Ada.Containers.Red_Black_Tr
--------------------------------
procedure Generic_Conditional_Insert
- (Tree : in out Tree_Type;
- Key : Key_Type;
- Node : out Node_Access;
- Success : out Boolean)
+ (Tree : in out Tree_Type;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Inserted : out Boolean)
is
Y : Node_Access := null;
X : Node_Access := Tree.Root;
begin
- Success := True;
+ Inserted := True;
while X /= null loop
Y := X;
- Success := Is_Less_Key_Node (Key, X);
+ Inserted := Is_Less_Key_Node (Key, X);
- if Success then
+ if Inserted then
X := Ops.Left (X);
else
X := Ops.Right (X);
end if;
end loop;
- Node := Y;
-
- if Success then
- if Node = Tree.First then
- Insert_Post (Tree, X, Y, Key, Node);
+ -- If Inserted is True, then this means either that Tree is
+ -- empty, or there was a least one node (strictly) greater than
+ -- Key. Otherwise, it means that Key is equal to or greater than
+ -- every node.
+
+ if Inserted then
+ if Y = Tree.First then
+ Insert_Post (Tree, Y, True, Node);
return;
end if;
- Node := Ops.Previous (Node);
+ Node := Ops.Previous (Y);
+
+ else
+ Node := Y;
end if;
+ -- Here Node has a value that is less than or equal to Key. We
+ -- now have to resolve whether Key is equal to or greater than
+ -- Node, which determines whether the insertion succeeds.
+
if Is_Greater_Key_Node (Key, Node) then
- Insert_Post (Tree, X, Y, Key, Node);
- Success := True;
+ Insert_Post (Tree, Y, Inserted, Node);
+ Inserted := True;
return;
end if;
- Success := False;
+ Inserted := False;
end Generic_Conditional_Insert;
------------------------------------------
@@ -162,21 +171,33 @@ package body Ada.Containers.Red_Black_Tr
------------------------------------------
procedure Generic_Conditional_Insert_With_Hint
- (Tree : in out Tree_Type;
- Position : Node_Access;
- Key : Key_Type;
- Node : out Node_Access;
- Success : out Boolean)
+ (Tree : in out Tree_Type;
+ Position : Node_Access;
+ Key : Key_Type;
+ Node : out Node_Access;
+ Inserted : out Boolean)
is
begin
+ -- The purpose of a hint is to avoid a search from the root of
+ -- tree. If we have it hint it means we only need to traverse the
+ -- subtree rooted at the hint to find the nearest neighbor. Note
+ -- that finding the neighbor means merely walking the tree; this
+ -- is not a search and the only comparisons that occur are with
+ -- the hint and its neighbor.
+
+ -- If Position is null, this is intepreted to mean that Key is
+ -- large relative to the nodes in the tree. If the tree is empty,
+ -- or Key is greater than the last node in the tree, then we're
+ -- done; otherwise the hint was "wrong" and we must search.
+
if Position = null then -- largest
- if Tree.Length > 0
- and then Is_Greater_Key_Node (Key, Tree.Last)
+ if Tree.Last = null
+ or else Is_Greater_Key_Node (Key, Tree.Last)
then
- Insert_Post (Tree, null, Tree.Last, Key, Node);
- Success := True;
+ Insert_Post (Tree, Tree.Last, False, Node);
+ Inserted := True;
else
- Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
+ Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
end if;
return;
@@ -184,64 +205,88 @@ package body Ada.Containers.Red_Black_Tr
pragma Assert (Tree.Length > 0);
- if Is_Less_Key_Node (Key, Position) then
- if Position = Tree.First then
- Insert_Post (Tree, Position, Position, Key, Node);
- Success := True;
- return;
- end if;
+ -- A hint can either name the node that immediately follows Key,
+ -- or immediately precedes Key. We first test whether Key is is
+ -- less than the hint, and if so we compare Key to the node that
+ -- precedes the hint. If Key is both less than the hint and
+ -- greater than the hint's preceding neighbor, then we're done;
+ -- otherwise we must search.
+
+ -- Note also that a hint can either be an anterior node or a leaf
+ -- node. A new node is always inserted at the bottom of the tree
+ -- (at least prior to rebalancing), becoming the new left or
+ -- right child of leaf node (which prior to the insertion must
+ -- necessarily be null, since this is a leaf). If the hint names
+ -- an anterior node then its neighbor must be a leaf, and so
+ -- (here) we insert after the neighbor. If the hint names a leaf
+ -- then its neighbor must be anterior and so we insert before the
+ -- hint.
+ if Is_Less_Key_Node (Key, Position) then
declare
Before : constant Node_Access := Ops.Previous (Position);
begin
- if Is_Greater_Key_Node (Key, Before) then
+ if Before = null then
+ Insert_Post (Tree, Tree.First, True, Node);
+ Inserted := True;
+
+ elsif Is_Greater_Key_Node (Key, Before) then
if Ops.Right (Before) = null then
- Insert_Post (Tree, null, Before, Key, Node);
+ Insert_Post (Tree, Before, False, Node);
else
- Insert_Post (Tree, Position, Position, Key, Node);
+ Insert_Post (Tree, Position, True, Node);
end if;
- Success := True;
+ Inserted := True;
else
- Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
+ Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
end if;
end;
return;
end if;
- if Is_Greater_Key_Node (Key, Position) then
- if Position = Tree.Last then
- Insert_Post (Tree, null, Tree.Last, Key, Node);
- Success := True;
- return;
- end if;
+ -- We know that Key isn't less than the hint so we try again,
+ -- this time to see if it's greater than the hint. If so we
+ -- compare Key to the node that follows the hint. If Key is both
+ -- greater than the hint and less than the hint's next neighbor,
+ -- then we're done; otherwise we must search.
+ if Is_Greater_Key_Node (Key, Position) then
declare
After : constant Node_Access := Ops.Next (Position);
begin
- if Is_Less_Key_Node (Key, After) then
+ if After = null then
+ Insert_Post (Tree, Tree.Last, False, Node);
+ Inserted := True;
+
+ elsif Is_Less_Key_Node (Key, After) then
if Ops.Right (Position) = null then
- Insert_Post (Tree, null, Position, Key, Node);
+ Insert_Post (Tree, Position, False, Node);
else
- Insert_Post (Tree, After, After, Key, Node);
+ Insert_Post (Tree, After, True, Node);
end if;
- Success := True;
+ Inserted := True;
else
- Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
+ Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
end if;
end;
return;
end if;
+ -- We know that Key is neither less than the hint nor greater
+ -- than the hint, and that's the definition of equivalence.
+ -- There's nothing else we need to do, since a search would just
+ -- reach the same conclusion.
+
Node := Position;
- Success := False;
+ Inserted := False;
end Generic_Conditional_Insert_With_Hint;
-------------------------
@@ -249,10 +294,10 @@ package body Ada.Containers.Red_Black_Tr
-------------------------
procedure Generic_Insert_Post
- (Tree : in out Tree_Type;
- X, Y : Node_Access;
- Key : Key_Type;
- Z : out Node_Access)
+ (Tree : in out Tree_Type;
+ Y : Node_Access;
+ Before : Boolean;
+ Z : out Node_Access)
is
begin
if Tree.Length = Count_Type'Last then
@@ -264,50 +309,32 @@ package body Ada.Containers.Red_Black_Tr
"attempt to tamper with cursors (container is busy)";
end if;
- if Y = null
- or else X /= null
- or else Is_Less_Key_Node (Key, Y)
- then
- 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 /= null);
- pragma Assert (Ops.Color (Z) = Red);
-
- if Y = null then
- pragma Assert (Tree.Length = 0);
- pragma Assert (Tree.Root = null);
- pragma Assert (Tree.First = null);
- pragma Assert (Tree.Last = null);
+ Z := New_Node;
+ pragma Assert (Z /= null);
+ pragma Assert (Ops.Color (Z) = Red);
- Tree.Root := Z;
- Tree.First := Z;
- Tree.Last := Z;
+ if Y = null then
+ pragma Assert (Tree.Length = 0);
+ pragma Assert (Tree.Root = null);
+ pragma Assert (Tree.First = null);
+ pragma Assert (Tree.Last = null);
- else
- Ops.Set_Left (Y, Z);
+ Tree.Root := Z;
+ Tree.First := Z;
+ Tree.Last := Z;
- if Y = Tree.First then
- Tree.First := Z;
- end if;
+ elsif Before then
+ pragma Assert (Ops.Left (Y) = null);
+
+ Ops.Set_Left (Y, Z);
+
+ if Y = Tree.First then
+ Tree.First := Z;
end if;
else
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 /= null);
- pragma Assert (Ops.Color (Z) = Red);
-
Ops.Set_Right (Y, Z);
if Y = Tree.Last then
@@ -335,8 +362,9 @@ package body Ada.Containers.Red_Black_Tr
-------------
procedure Iterate (Node : Node_Access) is
- N : Node_Access := Node;
+ N : Node_Access;
begin
+ N := Node;
while N /= null loop
if Is_Less_Key_Node (Key, N) then
N := Ops.Left (N);
@@ -371,8 +399,9 @@ package body Ada.Containers.Red_Black_Tr
-------------
procedure Iterate (Node : Node_Access) is
- N : Node_Access := Node;
+ N : Node_Access;
begin
+ N := Node;
while N /= null loop
if Is_Less_Key_Node (Key, N) then
N := Ops.Left (N);
@@ -401,21 +430,28 @@ package body Ada.Containers.Red_Black_Tr
Key : Key_Type;
Node : out Node_Access)
is
- Y : Node_Access := null;
- X : Node_Access := Tree.Root;
+ Y : Node_Access;
+ X : Node_Access;
+
+ Before : Boolean;
begin
+ Y := null;
+ Before := False;
+
+ X := Tree.Root;
while X /= null loop
Y := X;
+ Before := Is_Less_Key_Node (Key, X);
- if Is_Less_Key_Node (Key, X) then
+ if Before then
X := Ops.Left (X);
else
X := Ops.Right (X);
end if;
end loop;
- Insert_Post (Tree, X, Y, Key, Node);
+ Insert_Post (Tree, Y, Before, Node);
end Generic_Unconditional_Insert;
--------------------------------------------
@@ -428,22 +464,34 @@ package body Ada.Containers.Red_Black_Tr
Key : Key_Type;
Node : out Node_Access)
is
- -- TODO: verify this algorithm. It was (quickly) adapted it from the
- -- same algorithm for conditional_with_hint. It may be that the test
- -- Key > Hint should be something like a Key >= Hint, to handle the
- -- case when Hint is The Last Item of A (Contiguous) sequence of
- -- Equivalent Items. (The Key < Hint Test is probably OK. It is not
- -- clear that you can use Key <= Hint, since new items are always
- -- inserted last in the sequence of equivalent items.) ???
-
begin
+ -- There are fewer constraints for an unconditional insertion
+ -- than for a conditional insertion, since we allow duplicate
+ -- keys. So instead of having to check (say) whether Key is
+ -- (strictly) greater than the hint's previous neighbor, here we
+ -- allow Key to be equal to or greater than the previous node.
+
+ -- There is the issue of what to do if Key is equivalent to the
+ -- hint. Does the new node get inserted before or after the hint?
+ -- We decide that it gets inserted after the hint, reasoning that
+ -- this is consistent with behavior for non-hint insertion, which
+ -- inserts a new node after existing nodes with equivalent keys.
+
+ -- First we check whether the hint is null, which is interpreted
+ -- to mean that Key is large relative to existing nodes.
+ -- Following our rule above, if Key is equal to or greater than
+ -- the last node, then we insert the new node immediately after
+ -- last. (We don't have an operation for testing whether a key is
+ -- "equal to or greater than" a node, so we must say instead "not
+ -- less than", which is equivalent.)
+
if Hint = null then -- largest
- if Tree.Length > 0
- and then Is_Greater_Key_Node (Key, Tree.Last)
- then
- Insert_Post (Tree, null, Tree.Last, Key, Node);
- else
+ if Tree.Last = null then
+ Insert_Post (Tree, null, False, Node);
+ elsif Is_Less_Key_Node (Key, Tree.Last) then
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
+ else
+ Insert_Post (Tree, Tree.Last, False, Node);
end if;
return;
@@ -451,53 +499,53 @@ package body Ada.Containers.Red_Black_Tr
pragma Assert (Tree.Length > 0);
- if Is_Less_Key_Node (Key, Hint) then
- if Hint = Tree.First then
- Insert_Post (Tree, Hint, Hint, Key, Node);
- return;
- end if;
+ -- We decide here whether to insert the new node prior to the
+ -- hint. Key could be equivalent to the hint, so in theory we
+ -- could write the following test as "not greater than" (same as
+ -- "less than or equal to"). If Key were equivalent to the hint,
+ -- that would mean that the new node gets inserted before an
+ -- equivalent node. That wouldn't break any container invariants,
+ -- but our rule above says that new nodes always get inserted
+ -- after equivalent nodes. So here we test whether Key is both
+ -- less than the hint and and equal to or greater than the hint's
+ -- previous neighbor, and if so insert it before the hint.
+ if Is_Less_Key_Node (Key, Hint) then
declare
Before : constant Node_Access := Ops.Previous (Hint);
begin
- if Is_Greater_Key_Node (Key, Before) then
- if Ops.Right (Before) = null then
- Insert_Post (Tree, null, Before, Key, Node);
- else
- Insert_Post (Tree, Hint, Hint, Key, Node);
- end if;
- else
+ if Before = null then
+ Insert_Post (Tree, Hint, True, Node);
+ elsif Is_Less_Key_Node (Key, Before) then
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
- end if;
- end;
-
- return;
- end if;
-
- if Is_Greater_Key_Node (Key, Hint) then
- if Hint = Tree.Last then
- Insert_Post (Tree, null, Tree.Last, Key, Node);
- return;
- end if;
-
- declare
- After : constant Node_Access := Ops.Next (Hint);
- begin
- if Is_Less_Key_Node (Key, After) then
- if Ops.Right (Hint) = null then
- Insert_Post (Tree, null, Hint, Key, Node);
- else
- Insert_Post (Tree, After, After, Key, Node);
- end if;
+ elsif Ops.Right (Before) = null then
+ Insert_Post (Tree, Before, False, Node);
else
- Unconditional_Insert_Sans_Hint (Tree, Key, Node);
+ Insert_Post (Tree, Hint, True, Node);
end if;
end;
return;
end if;
- Unconditional_Insert_Sans_Hint (Tree, Key, Node);
+ -- We know that Key isn't less than the hint, so it must be equal
+ -- or greater. So we just test whether Key is less than or equal
+ -- to (same as "not greater than") the hint's next neighbor, and
+ -- if so insert it after the hint.
+
+ declare
+ After : constant Node_Access := Ops.Next (Hint);
+ begin
+ if After = null then
+ Insert_Post (Tree, Hint, False, Node);
+ elsif Is_Greater_Key_Node (Key, After) then
+ Unconditional_Insert_Sans_Hint (Tree, Key, Node);
+ elsif Ops.Right (Hint) = null then
+ Insert_Post (Tree, Hint, False, Node);
+ else
+ Insert_Post (Tree, After, True, Node);
+ end if;
+ end;
end Generic_Unconditional_Insert_With_Hint;
-----------------
@@ -509,9 +557,10 @@ package body Ada.Containers.Red_Black_Tr
Key : Key_Type) return Node_Access
is
Y : Node_Access;
- X : Node_Access := Tree.Root;
+ X : Node_Access;
begin
+ X := Tree.Root;
while X /= null loop
if Is_Less_Key_Node (Key, X) then
Y := X;
Index: a-coorse.adb
===================================================================
--- a-coorse.adb (revision 118179)
+++ a-coorse.adb (working copy)
@@ -6,11 +6,7 @@
-- --
-- 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. --
+-- Copyright (C) 2004-2006, 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- --
@@ -1375,11 +1371,49 @@ package body Ada.Containers.Ordered_Sets
Node : Node_Access;
Item : Element_Type)
is
+ pragma Assert (Node /= null);
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Local_Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Local_Insert_Sans_Hint is
+ new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
+
+ procedure Local_Insert_With_Hint is
+ new Element_Keys.Generic_Conditional_Insert_With_Hint
+ (Local_Insert_Post,
+ Local_Insert_Sans_Hint);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ Node.Element := Item;
+ Node.Color := Red;
+ Node.Parent := null;
+ Node.Right := null;
+ Node.Left := null;
+
+ return Node;
+ end New_Node;
+
+ Hint : Node_Access;
+ Result : Node_Access;
+ Inserted : Boolean;
+
+ -- Start of processing for Insert
+
begin
if Item < Node.Element
or else Node.Element < Item
then
null;
+
else
if Tree.Lock > 0 then
raise Program_Error with
@@ -1390,95 +1424,38 @@ package body Ada.Containers.Ordered_Sets
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);
+ Hint := Element_Keys.Ceiling (Tree, Item);
- procedure Insert is
- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
+ if Hint = null then
+ null;
- --------------
- -- New_Node --
- --------------
+ elsif Item < Hint.Element then
+ if Hint = Node then
+ if Tree.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
+ end if;
- function New_Node return Node_Access is
- begin
Node.Element := Item;
- Node.Color := Red;
- Node.Parent := null;
- Node.Right := null;
- Node.Left := null;
-
- 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
- Node.Color := Red;
- Node.Parent := null;
- Node.Right := null;
- Node.Left := null;
-
- return Node;
- end New_Node;
-
- Result : Node_Access;
- Inserted : Boolean;
+ else
+ pragma Assert (not (Hint.Element < Item));
+ raise Program_Error with "attempt to replace existing element";
+ end if;
- -- Start of processing for Reinsert_Old_Element
+ Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
- 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;
+ Local_Insert_With_Hint
+ (Tree => Tree,
+ Position => Hint,
+ Key => Item,
+ Node => Result,
+ Inserted => Inserted);
- raise Program_Error with "attempt to replace existing element";
+ pragma Assert (Inserted);
+ pragma Assert (Result = Node);
end Replace_Element;
procedure Replace_Element
Index: a-convec.adb
===================================================================
--- a-convec.adb (revision 118179)
+++ a-convec.adb (working copy)
@@ -8,10 +8,6 @@
-- --
-- Copyright (C) 2004-2006 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- --
@@ -799,34 +795,6 @@ package body Ada.Containers.Vectors is
begin
if Old_Last_As_Int > Int'Last - N then
-
- -- ???
-
- -- The purpose of this test is to ensure that the calculation of
- -- New_Last_As_Int (see below) doesn't overflow.
-
- -- This isn't quite right, since the only requirements are:
- -- V.Last <= Index_Type'Last
- -- V.Length <= Count_Type'Last
-
- -- To be strictly correct there's no (explicit) requirement that
- -- Old_Last + N <= Int'Last
-
- -- However, there might indeed be an implied requirement, since
- -- machine constraints dictate that
- -- Index_Type'Last <= Int'Last
- -- and so this check is perhaps proper after all.
-
- -- This shouldn't be an issue in practice, since it can only
- -- happen when N is very large, or V.Last is near Int'Last.
-
- -- N isn't likely to be large, since there's probably not enough
- -- storage.
-
- -- V.Last would only be large if IT'First is very large (and
- -- V.Length has some "normal" size). But typically IT'First is
- -- either 0 or 1.
-
raise Constraint_Error with "new length is out of range";
end if;
@@ -1282,7 +1250,7 @@ package body Ada.Containers.Vectors is
Old_Last_As_Int : constant Int := Int (Container.Last);
begin
- if Old_Last_As_Int > Int'Last - N then -- see Insert ???
+ if Old_Last_As_Int > Int'Last - N then
raise Constraint_Error with "new length is out of range";
end if;
Index: a-coinve.adb
===================================================================
--- a-coinve.adb (revision 118179)
+++ a-coinve.adb (working copy)
@@ -8,10 +8,6 @@
-- --
-- Copyright (C) 2004-2006, 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- --
@@ -1052,7 +1048,7 @@ package body Ada.Containers.Indefinite_V
Old_Last_As_Int : constant Int := Int (Container.Last);
begin
- if Old_Last_As_Int > Int'Last - N then -- see a-convec.adb ???
+ if Old_Last_As_Int > Int'Last - N then
raise Constraint_Error with "new length is out of range";
end if;
@@ -1514,7 +1510,7 @@ package body Ada.Containers.Indefinite_V
Old_Last_As_Int : constant Int := Int (Container.Last);
begin
- if Old_Last_As_Int > Int'Last - N then -- see a-convec.adb ???
+ if Old_Last_As_Int > Int'Last - N then
raise Constraint_Error with "new length is out of range";
end if;
@@ -2586,12 +2582,6 @@ package body Ada.Containers.Indefinite_V
begin
for Indx 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. ???
-
if E (Indx) = null then
Boolean'Write (Stream, False);
else
Index: a-cohama.adb
===================================================================
--- a-cohama.adb (revision 118179)
+++ a-cohama.adb (working copy)
@@ -6,11 +6,7 @@
-- --
-- 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. --
+-- Copyright (C) 2004-2006, 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- --
@@ -566,10 +562,22 @@ package body Ada.Containers.Hashed_Maps
Process (Cursor'(Container'Unchecked_Access, Node));
end Process_Node;
+ B : Natural renames Container'Unrestricted_Access.HT.Busy;
+
-- Start of processing for Iterate
begin
- Local_Iterate (Container.HT);
+ B := B + 1;
+
+ begin
+ Local_Iterate (Container.HT);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
---------
Index: a-ciorse.adb
===================================================================
--- a-ciorse.adb (revision 118179)
+++ a-ciorse.adb (working copy)
@@ -7,11 +7,7 @@
-- --
-- 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. --
+-- Copyright (C) 2004-2006, 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- --
@@ -1463,121 +1459,100 @@ package body Ada.Containers.Indefinite_O
Node : Node_Access;
Item : Element_Type)
is
+ pragma Assert (Node /= null);
+ pragma Assert (Node.Element /= null);
+
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Local_Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Local_Insert_Sans_Hint is
+ new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
+
+ procedure Local_Insert_With_Hint is
+ new Element_Keys.Generic_Conditional_Insert_With_Hint
+ (Local_Insert_Post,
+ Local_Insert_Sans_Hint);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ Node.Element := new Element_Type'(Item); -- OK if fails
+ Node.Color := Red;
+ Node.Parent := null;
+ Node.Right := null;
+ Node.Left := null;
+
+ return Node;
+ end New_Node;
+
+ Hint : Node_Access;
+ Result : Node_Access;
+ Inserted : Boolean;
+
+ X : Element_Access := Node.Element;
+
+ -- Start of processing for Insert
+
begin
if Item < Node.Element.all
or else Node.Element.all < Item
then
null;
+
else
if Tree.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
- declare
- X : Element_Access := Node.Element;
- begin
- Node.Element := new Element_Type'(Item);
- Free_Element (X);
- end;
+ Node.Element := new Element_Type'(Item);
+ Free_Element (X);
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
- Node.Color := Red;
- Node.Parent := null;
- Node.Right := null;
- Node.Left := null;
-
- return Node;
- end New_Node;
+ Hint := Element_Keys.Ceiling (Tree, Item);
- Result : Node_Access;
- Inserted : Boolean;
-
- X : Element_Access := Node.Element;
+ if Hint = null then
+ null;
- -- Start of processing for Insert_New_Item
+ elsif Item < Hint.Element.all then
+ if Hint = Node then
+ if Tree.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
+ end if;
- 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;
+ Node.Element := new Element_Type'(Item);
+ Free_Element (X);
- 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
- Node.Color := Red;
- Node.Parent := null;
- Node.Right := null;
- Node.Left := null;
- return Node;
- end New_Node;
+ else
+ pragma Assert (not (Hint.Element.all < Item));
+ raise Program_Error with "attempt to replace existing element";
+ end if;
- Result : Node_Access;
- Inserted : Boolean;
+ Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
- -- Start of processing for Reinsert_Old_Element
+ Local_Insert_With_Hint
+ (Tree => Tree,
+ Position => Hint,
+ Key => Item,
+ Node => Result,
+ Inserted => Inserted);
- 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;
+ pragma Assert (Inserted);
+ pragma Assert (Result = Node);
- raise Program_Error with "attempt to replace existing element";
+ Free_Element (X);
end Replace_Element;
procedure Replace_Element
Index: a-cihama.adb
===================================================================
--- a-cihama.adb (revision 118179)
+++ a-cihama.adb (working copy)
@@ -7,11 +7,7 @@
-- --
-- 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. --
+-- Copyright (C) 2004-2006, 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- --
@@ -603,7 +599,7 @@ package body Ada.Containers.Indefinite_H
procedure Process_Node (Node : Node_Access);
pragma Inline (Process_Node);
- procedure Iterate is
+ procedure Local_Iterate is
new HT_Ops.Generic_Iteration (Process_Node);
------------------
@@ -615,10 +611,22 @@ package body Ada.Containers.Indefinite_H
Process (Cursor'(Container'Unchecked_Access, Node));
end Process_Node;
+ B : Natural renames Container'Unrestricted_Access.HT.Busy;
+
-- Start of processing Iterate
begin
- Iterate (Container.HT);
+ B := B + 1;
+
+ begin
+ Local_Iterate (Container.HT);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
---------
Index: a-cidlli.ads
===================================================================
--- a-cidlli.ads (revision 118179)
+++ a-cidlli.ads (working copy)
@@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2006, 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 --
@@ -47,8 +47,10 @@ package Ada.Containers.Indefinite_Doubly
pragma Preelaborate;
type List is tagged private;
+ pragma Preelaborable_Initialization (List);
type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
Empty_List : constant List;
@@ -138,7 +140,7 @@ package Ada.Containers.Indefinite_Doubly
procedure Splice
(Container : in out List;
Before : Cursor;
- Position : in out Cursor);
+ Position : Cursor);
function First (Container : List) return Cursor;
@@ -223,13 +225,13 @@ private
use Ada.Streams;
procedure Read
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : out List);
for List'Read use Read;
procedure Write
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : List);
for List'Write use Write;
@@ -246,13 +248,13 @@ private
end record;
procedure Read
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
procedure Write
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Write use Write;
Index: a-cidlli.adb
===================================================================
--- a-cidlli.adb (revision 118179)
+++ a-cidlli.adb (working copy)
@@ -9,10 +9,6 @@
-- --
-- Copyright (C) 2004-2006, 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- --
@@ -180,7 +176,8 @@ package body Ada.Containers.Indefinite_D
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
while Container.Length > 1 loop
@@ -230,15 +227,18 @@ package body Ada.Containers.Indefinite_D
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor has no element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Delete");
@@ -255,7 +255,8 @@ package body Ada.Containers.Indefinite_D
end if;
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
for Index in 1 .. Count loop
@@ -304,7 +305,8 @@ package body Ada.Containers.Indefinite_D
end if;
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
for I in 1 .. Count loop
@@ -341,7 +343,8 @@ package body Ada.Containers.Indefinite_D
end if;
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
for I in 1 .. Count loop
@@ -364,11 +367,13 @@ package body Ada.Containers.Indefinite_D
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor has no element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Element");
@@ -397,7 +402,8 @@ package body Ada.Containers.Indefinite_D
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Find");
@@ -434,7 +440,7 @@ package body Ada.Containers.Indefinite_D
function First_Element (Container : List) return Element_Type is
begin
if Container.First = null then
- raise Constraint_Error;
+ raise Constraint_Error with "list is empty";
end if;
return Container.First.Element.all;
@@ -497,18 +503,21 @@ package body Ada.Containers.Indefinite_D
(Target : in out List;
Source : in out List)
is
- LI : Cursor;
- RI : Cursor;
+ LI, RI : Cursor;
begin
if Target'Address = Source'Address then
return;
end if;
- if Target.Busy > 0
- or else Source.Busy > 0
- then
- raise Program_Error;
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Target (list is busy)";
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Source (list is busy)";
end if;
LI := First (Target);
@@ -624,7 +633,8 @@ package body Ada.Containers.Indefinite_D
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
Sort (Front => null, Back => null);
@@ -661,13 +671,15 @@ package body Ada.Containers.Indefinite_D
begin
if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
if Before.Node = null
or else Before.Node.Element = null
then
- raise Program_Error;
+ raise Program_Error with
+ "Before cursor has no element";
end if;
pragma Assert (Vet (Before), "bad cursor in Insert");
@@ -679,11 +691,12 @@ package body Ada.Containers.Indefinite_D
end if;
if Container.Length > Count_Type'Last - Count then
- raise Constraint_Error;
+ raise Constraint_Error with "new length exceeds maximum";
end if;
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
declare
@@ -833,7 +846,7 @@ package body Ada.Containers.Indefinite_D
function Last_Element (Container : List) return Element_Type is
begin
if Container.Last = null then
- raise Constraint_Error;
+ raise Constraint_Error with "list is empty";
end if;
return Container.Last.Element.all;
@@ -859,7 +872,8 @@ package body Ada.Containers.Indefinite_D
end if;
if Source.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements of Source (list is busy)";
end if;
Clear (Target);
@@ -880,27 +894,17 @@ package body Ada.Containers.Indefinite_D
procedure Next (Position : in out Cursor) is
begin
- pragma Assert (Vet (Position), "bad cursor in procedure Next");
-
- if Position.Node = null then
- return;
- end if;
-
- Position.Node := Position.Node.Next;
-
- if Position.Node = null then
- Position.Container := null;
- end if;
+ Position := Next (Position);
end Next;
function Next (Position : Cursor) return Cursor is
begin
- pragma Assert (Vet (Position), "bad cursor in function Next");
-
if Position.Node = null then
return No_Element;
end if;
+ pragma Assert (Vet (Position), "bad cursor in Next");
+
declare
Next_Node : constant Node_Access := Position.Node.Next;
begin
@@ -931,27 +935,17 @@ package body Ada.Containers.Indefinite_D
procedure Previous (Position : in out Cursor) is
begin
- pragma Assert (Vet (Position), "bad cursor in procedure Previous");
-
- if Position.Node = null then
- return;
- end if;
-
- Position.Node := Position.Node.Prev;
-
- if Position.Node = null then
- Position.Container := null;
- end if;
+ Position := Previous (Position);
end Previous;
function Previous (Position : Cursor) return Cursor is
begin
- pragma Assert (Vet (Position), "bad cursor in function Previous");
-
if Position.Node = null then
return No_Element;
end if;
+ pragma Assert (Vet (Position), "bad cursor in Previous");
+
declare
Prev_Node : constant Node_Access := Position.Node.Prev;
begin
@@ -973,11 +967,13 @@ package body Ada.Containers.Indefinite_D
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor has no element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
@@ -1010,7 +1006,7 @@ package body Ada.Containers.Indefinite_D
----------
procedure Read
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : out List)
is
N : Count_Type'Base;
@@ -1059,11 +1055,11 @@ package body Ada.Containers.Indefinite_D
end Read;
procedure Read
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream list cursor";
end Read;
---------------------
@@ -1077,19 +1073,22 @@ package body Ada.Containers.Indefinite_D
is
begin
if Position.Container = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
- if Position.Container.Lock > 0 then
- raise Program_Error;
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (list is locked)";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
@@ -1162,7 +1161,8 @@ package body Ada.Containers.Indefinite_D
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
Container.First := J;
@@ -1206,11 +1206,12 @@ package body Ada.Containers.Indefinite_D
else
if Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
@@ -1269,13 +1270,15 @@ package body Ada.Containers.Indefinite_D
begin
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Before cursor designates wrong container";
end if;
if Before.Node = null
or else Before.Node.Element = null
then
- raise Program_Error;
+ raise Program_Error with
+ "Before cursor has no element";
end if;
pragma Assert (Vet (Before), "bad cursor in Splice");
@@ -1291,13 +1294,17 @@ package body Ada.Containers.Indefinite_D
pragma Assert (Source.Last.Next = null);
if Target.Length > Count_Type'Last - Source.Length then
- raise Constraint_Error;
+ raise Constraint_Error with "new length exceeds maximum";
end if;
- if Target.Busy > 0
- or else Source.Busy > 0
- then
- raise Program_Error;
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Target (list is busy)";
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Source (list is busy)";
end if;
if Target.Length = 0 then
@@ -1343,33 +1350,36 @@ package body Ada.Containers.Indefinite_D
procedure Splice
(Container : in out List;
Before : Cursor;
- Position : in out Cursor)
+ Position : Cursor)
is
begin
if Before.Container /= null then
if Before.Container /= Container'Unchecked_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Before cursor designates wrong container";
end if;
if Before.Node = null
or else Before.Node.Element = null
then
- raise Program_Error;
+ raise Program_Error with
+ "Before cursor has no element";
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
@@ -1383,7 +1393,8 @@ package body Ada.Containers.Indefinite_D
pragma Assert (Container.Length >= 2);
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
if Before.Node = null then
@@ -1463,40 +1474,48 @@ package body Ada.Containers.Indefinite_D
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Before cursor designates wrong container";
end if;
if Before.Node = null
or else Before.Node.Element = null
then
- raise Program_Error;
+ raise Program_Error with
+ "Before cursor has no element";
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor has no element";
end if;
if Position.Container /= Source'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Target.Length = Count_Type'Last then
- raise Constraint_Error;
+ raise Constraint_Error with "Target is full";
end if;
- if Target.Busy > 0
- or else Source.Busy > 0
- then
- raise Program_Error;
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Target (list is busy)";
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Source (list is busy)";
end if;
if Position.Node = Source.First then
@@ -1573,16 +1592,20 @@ package body Ada.Containers.Indefinite_D
I, J : Cursor)
is
begin
- if I.Node = null
- or else J.Node = null
- then
- raise Constraint_Error;
+ if I.Node = null then
+ raise Constraint_Error with "I cursor has no element";
end if;
- if I.Container /= Container'Unchecked_Access
- or else J.Container /= Container'Unchecked_Access
- then
- raise Program_Error;
+ if J.Node = null then
+ raise Constraint_Error with "J cursor has no element";
+ end if;
+
+ if I.Container /= Container'Unchecked_Access then
+ raise Program_Error with "I cursor designates wrong container";
+ end if;
+
+ if J.Container /= Container'Unchecked_Access then
+ raise Program_Error with "J cursor designates wrong container";
end if;
if I.Node = J.Node then
@@ -1590,7 +1613,8 @@ package body Ada.Containers.Indefinite_D
end if;
if Container.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (list is locked)";
end if;
pragma Assert (Vet (I), "bad I cursor in Swap");
@@ -1614,16 +1638,20 @@ package body Ada.Containers.Indefinite_D
I, J : Cursor)
is
begin
- if I.Node = null
- or else J.Node = null
- then
- raise Constraint_Error;
+ if I.Node = null then
+ raise Constraint_Error with "I cursor has no element";
end if;
- if I.Container /= Container'Unrestricted_Access
- or else I.Container /= J.Container
- then
- raise Program_Error;
+ if J.Node = null then
+ raise Constraint_Error with "J cursor has no element";
+ end if;
+
+ if I.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "I cursor designates wrong container";
+ end if;
+
+ if J.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "J cursor designates wrong container";
end if;
if I.Node = J.Node then
@@ -1631,7 +1659,8 @@ package body Ada.Containers.Indefinite_D
end if;
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
@@ -1639,26 +1668,24 @@ package body Ada.Containers.Indefinite_D
declare
I_Next : constant Cursor := Next (I);
- J_Copy : Cursor := J;
begin
if I_Next = J then
- Splice (Container, Before => I, Position => J_Copy);
+ Splice (Container, Before => I, Position => J);
else
declare
J_Next : constant Cursor := Next (J);
- I_Copy : Cursor := I;
begin
if J_Next = I then
- Splice (Container, Before => J, Position => I_Copy);
+ Splice (Container, Before => J, Position => I);
else
pragma Assert (Container.Length >= 3);
- Splice (Container, Before => I_Next, Position => J_Copy);
- Splice (Container, Before => J_Next, Position => I_Copy);
+ Splice (Container, Before => I_Next, Position => J);
+ Splice (Container, Before => J_Next, Position => I);
end if;
end;
end if;
@@ -1679,15 +1706,17 @@ package body Ada.Containers.Indefinite_D
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
@@ -1862,7 +1891,7 @@ package body Ada.Containers.Indefinite_D
-----------
procedure Write
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : List)
is
Node : Node_Access := Item.First;
@@ -1871,17 +1900,17 @@ package body Ada.Containers.Indefinite_D
Count_Type'Base'Write (Stream, Item.Length);
while Node /= null loop
- Element_Type'Output (Stream, Node.Element.all); -- X.all
+ Element_Type'Output (Stream, Node.Element.all);
Node := Node.Next;
end loop;
end Write;
procedure Write
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream list cursor";
end Write;
end Ada.Containers.Indefinite_Doubly_Linked_Lists;
Index: a-chtgop.adb
===================================================================
--- a-chtgop.adb (revision 118179)
+++ a-chtgop.adb (working copy)
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2006, 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- --
@@ -30,8 +30,6 @@
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
--- This body needs commenting ???
-
with Ada.Containers.Prime_Numbers;
with Ada.Unchecked_Deallocation;
@@ -60,40 +58,15 @@ package body Ada.Containers.Hash_Tables.
return;
end if;
- HT.Buckets := new Buckets_Type (Src_Buckets'Range);
- -- TODO: allocate minimum size req'd. (See note below.)
+ -- Technically it isn't necessary to allocate the exact same length
+ -- buckets array, because our only requirement is that following
+ -- assignment the source and target containers compare equal (that is,
+ -- operator "=" returns True). We can satisfy this requirement with any
+ -- hash table length, but we decide here to match the length of the
+ -- source table. This has the benefit that when iterating, elements of
+ -- the target are delivered in the exact same order as for the source.
- -- NOTE: see note below about these comments.
- -- Probably we have to duplicate the Size (Src), too, in order
- -- to guarantee that
-
- -- Dst := Src;
- -- Dst = Src is true
-
- -- The only quirk is that we depend on the hash value of a dst key
- -- to be the same as the src key from which it was copied.
- -- 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.
+ HT.Buckets := new Buckets_Type (Src_Buckets'Range);
for Src_Index in Src_Buckets'Range loop
Src_Node := Src_Buckets (Src_Index);
@@ -102,7 +75,7 @@ package body Ada.Containers.Hash_Tables.
declare
Dst_Node : constant Node_Access := Copy_Node (Src_Node);
- -- See note above
+ -- See note above
pragma Assert (Index (HT, Dst_Node) = Src_Index);
@@ -353,32 +326,20 @@ package body Ada.Containers.Hash_Tables.
-----------------------
procedure Generic_Iteration (HT : Hash_Table_Type) is
- Busy : Natural renames HT'Unrestricted_Access.all.Busy;
+ Node : Node_Access;
begin
if HT.Length = 0 then
return;
end if;
- 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;
+ for Indx in HT.Buckets'Range loop
+ Node := HT.Buckets (Indx);
+ while Node /= null loop
+ Process (Node);
+ Node := Next (Node);
end loop;
- exception
- when others =>
- Busy := Busy - 1;
- raise;
- end;
-
- Busy := Busy - 1;
+ end loop;
end Generic_Iteration;
------------------
@@ -389,71 +350,41 @@ package body Ada.Containers.Hash_Tables.
(Stream : access Root_Stream_Type'Class;
HT : out Hash_Table_Type)
is
- X, Y : Node_Access;
-
- Last, I : Hash_Type;
- N, M : Count_Type'Base;
+ N : Count_Type'Base;
+ NN : Hash_Type;
begin
Clear (HT);
- Hash_Type'Read (Stream, Last);
-
Count_Type'Base'Read (Stream, N);
- pragma Assert (N >= 0);
+
+ if N < 0 then
+ raise Program_Error;
+ end if;
if N = 0 then
return;
end if;
if HT.Buckets = null
- or else HT.Buckets'Last /= Last
+ or else HT.Buckets'Length < N
then
Free (HT.Buckets);
- HT.Buckets := new Buckets_Type (0 .. Last);
+ NN := Prime_Numbers.To_Prime (N);
+ HT.Buckets := new Buckets_Type (0 .. NN - 1);
end if;
- -- TODO: should we rewrite this algorithm so that it doesn't
- -- depend on preserving the exactly length of the hash table
- -- array? We would prefer to not have to (re)allocate a
- -- buckets array (the array that HT already has might be large
- -- enough), and to not have to stream the count of the number
- -- of nodes in each bucket. The algorithm below is vestigial,
- -- as it was written prior to the meeting in Palma, when the
- -- semantics of equality were changed (and which obviated the
- -- need to preserve the hash table length).
-
- loop
- Hash_Type'Read (Stream, I);
- pragma Assert (I in HT.Buckets'Range);
- 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);
- pragma Assert (Next (HT.Buckets (I)) = null);
-
- Y := HT.Buckets (I);
+ for J in 1 .. N loop
+ declare
+ Node : constant Node_Access := New_Node (Stream);
+ Indx : constant Hash_Type := Index (HT, Node);
+ B : Node_Access renames HT.Buckets (Indx);
+ begin
+ Set_Next (Node => Node, Next => B);
+ B := Node;
+ end;
HT.Length := HT.Length + 1;
-
- for J in Count_Type range 2 .. M loop
- X := New_Node (Stream);
- pragma Assert (X /= null);
- pragma Assert (Next (X) = null);
-
- Set_Next (Node => Y, Next => X);
- Y := X;
-
- HT.Length := HT.Length + 1;
- end loop;
-
- N := N - M;
-
- exit when N = 0;
end loop;
end Generic_Read;
@@ -465,47 +396,23 @@ package body Ada.Containers.Hash_Tables.
(Stream : access Root_Stream_Type'Class;
HT : Hash_Table_Type)
is
- M : Count_Type'Base;
- X : Node_Access;
-
- begin
- if HT.Buckets = null then
- Hash_Type'Write (Stream, 0);
- else
- Hash_Type'Write (Stream, HT.Buckets'Last);
- end if;
-
- Count_Type'Base'Write (Stream, HT.Length);
-
- if HT.Length = 0 then
- return;
- end if;
+ procedure Write (Node : Node_Access);
+ pragma Inline (Write);
- -- TODO: see note in Generic_Read???
-
- for Indx in HT.Buckets'Range loop
- X := HT.Buckets (Indx);
-
- if X /= null then
- M := 1;
- loop
- X := Next (X);
- exit when X = null;
- M := M + 1;
- end loop;
+ procedure Write is new Generic_Iteration (Write);
- Hash_Type'Write (Stream, Indx);
- Count_Type'Base'Write (Stream, M);
+ -----------
+ -- Write --
+ -----------
- X := HT.Buckets (Indx);
- for J in Count_Type range 1 .. M loop
- Write (Stream, X);
- X := Next (X);
- end loop;
+ procedure Write (Node : Node_Access) is
+ begin
+ Write (Stream, Node);
+ end Write;
- pragma Assert (X = null);
- end if;
- end loop;
+ begin
+ Count_Type'Base'Write (Stream, HT.Length);
+ Write (HT);
end Generic_Write;
-----------
Index: a-cdlili.ads
===================================================================
--- a-cdlili.ads (revision 118179)
+++ a-cdlili.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2006, 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 --
@@ -46,8 +46,10 @@ package Ada.Containers.Doubly_Linked_Lis
pragma Preelaborate;
type List is tagged private;
+ pragma Preelaborable_Initialization (List);
type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
Empty_List : constant List;
@@ -147,7 +149,7 @@ package Ada.Containers.Doubly_Linked_Lis
procedure Splice
(Container : in out List;
Before : Cursor;
- Position : in out Cursor);
+ Position : Cursor);
function First (Container : List) return Cursor;
@@ -230,13 +232,13 @@ private
use Ada.Streams;
procedure Read
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : out List);
for List'Read use Read;
procedure Write
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : List);
for List'Write use Write;
@@ -253,13 +255,13 @@ private
end record;
procedure Read
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
procedure Write
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Write use Write;
Index: a-cdlili.adb
===================================================================
--- a-cdlili.adb (revision 118179)
+++ a-cdlili.adb (working copy)
@@ -8,10 +8,6 @@
-- --
-- Copyright (C) 2004-2006, 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- --
@@ -156,7 +152,8 @@ package body Ada.Containers.Doubly_Linke
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
while Container.Length > 1 loop
@@ -206,11 +203,13 @@ package body Ada.Containers.Doubly_Linke
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Delete");
@@ -227,7 +226,8 @@ package body Ada.Containers.Doubly_Linke
end if;
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
for Index in 1 .. Count loop
@@ -276,7 +276,8 @@ package body Ada.Containers.Doubly_Linke
end if;
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
for I in 1 .. Count loop
@@ -313,7 +314,8 @@ package body Ada.Containers.Doubly_Linke
end if;
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
for I in 1 .. Count loop
@@ -336,7 +338,8 @@ package body Ada.Containers.Doubly_Linke
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Element");
@@ -361,7 +364,8 @@ package body Ada.Containers.Doubly_Linke
else
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Find");
@@ -398,7 +402,7 @@ package body Ada.Containers.Doubly_Linke
function First_Element (Container : List) return Element_Type is
begin
if Container.First = null then
- raise Constraint_Error;
+ raise Constraint_Error with "list is empty";
end if;
return Container.First.Element;
@@ -451,20 +455,25 @@ package body Ada.Containers.Doubly_Linke
(Target : in out List;
Source : in out List)
is
- LI : Cursor := First (Target);
- RI : Cursor := First (Source);
+ LI, RI : Cursor;
begin
if Target'Address = Source'Address then
return;
end if;
- if Target.Busy > 0
- or else Source.Busy > 0
- then
- raise Program_Error;
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Target (list is busy)";
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Source (list is busy)";
end if;
+ LI := First (Target);
+ RI := First (Source);
while RI.Node /= null loop
pragma Assert (RI.Node.Next = null
or else not (RI.Node.Next.Element <
@@ -578,7 +587,8 @@ package body Ada.Containers.Doubly_Linke
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
Sort (Front => null, Back => null);
@@ -615,7 +625,8 @@ package body Ada.Containers.Doubly_Linke
begin
if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
pragma Assert (Vet (Before), "bad cursor in Insert");
@@ -627,11 +638,12 @@ package body Ada.Containers.Doubly_Linke
end if;
if Container.Length > Count_Type'Last - Count then
- raise Constraint_Error;
+ raise Constraint_Error with "new length exceeds maximum";
end if;
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
New_Node := new Node_Type'(New_Item, null, null);
@@ -667,7 +679,8 @@ package body Ada.Containers.Doubly_Linke
begin
if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Before cursor designates wrong list";
end if;
pragma Assert (Vet (Before), "bad cursor in Insert");
@@ -679,11 +692,12 @@ package body Ada.Containers.Doubly_Linke
end if;
if Container.Length > Count_Type'Last - Count then
- raise Constraint_Error;
+ raise Constraint_Error with "new length exceeds maximum";
end if;
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
New_Node := new Node_Type;
@@ -804,7 +818,7 @@ package body Ada.Containers.Doubly_Linke
function Last_Element (Container : List) return Element_Type is
begin
if Container.Last = null then
- raise Constraint_Error;
+ raise Constraint_Error with "list is empty";
end if;
return Container.Last.Element;
@@ -833,7 +847,8 @@ package body Ada.Containers.Doubly_Linke
end if;
if Source.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements of Source (list is busy)";
end if;
Clear (Target);
@@ -854,27 +869,17 @@ package body Ada.Containers.Doubly_Linke
procedure Next (Position : in out Cursor) is
begin
- pragma Assert (Vet (Position), "bad cursor in procedure Next");
-
- if Position.Node = null then
- return;
- end if;
-
- Position.Node := Position.Node.Next;
-
- if Position.Node = null then
- Position.Container := null;
- end if;
+ Position := Next (Position);
end Next;
function Next (Position : Cursor) return Cursor is
begin
- pragma Assert (Vet (Position), "bad cursor in function Next");
-
if Position.Node = null then
return No_Element;
end if;
+ pragma Assert (Vet (Position), "bad cursor in Next");
+
declare
Next_Node : constant Node_Access := Position.Node.Next;
begin
@@ -905,27 +910,17 @@ package body Ada.Containers.Doubly_Linke
procedure Previous (Position : in out Cursor) is
begin
- pragma Assert (Vet (Position), "bad cursor in procedure Previous");
-
- if Position.Node = null then
- return;
- end if;
-
- Position.Node := Position.Node.Prev;
-
- if Position.Node = null then
- Position.Container := null;
- end if;
+ Position := Previous (Position);
end Previous;
function Previous (Position : Cursor) return Cursor is
begin
- pragma Assert (Vet (Position), "bad cursor in function Previous");
-
if Position.Node = null then
return No_Element;
end if;
+ pragma Assert (Vet (Position), "bad cursor in Previous");
+
declare
Prev_Node : constant Node_Access := Position.Node.Prev;
begin
@@ -947,7 +942,8 @@ package body Ada.Containers.Doubly_Linke
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
@@ -980,7 +976,7 @@ package body Ada.Containers.Doubly_Linke
----------
procedure Read
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : out List)
is
N : Count_Type'Base;
@@ -1028,11 +1024,11 @@ package body Ada.Containers.Doubly_Linke
end Read;
procedure Read
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream list cursor";
end Read;
---------------------
@@ -1046,15 +1042,17 @@ package body Ada.Containers.Doubly_Linke
is
begin
if Position.Container = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
if Container.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (list is locked)";
end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
@@ -1121,7 +1119,8 @@ package body Ada.Containers.Doubly_Linke
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
Container.First := J;
@@ -1165,7 +1164,8 @@ package body Ada.Containers.Doubly_Linke
else
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
@@ -1225,7 +1225,8 @@ package body Ada.Containers.Doubly_Linke
begin
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Before cursor designates wrong container";
end if;
pragma Assert (Vet (Before), "bad cursor in Splice");
@@ -1241,13 +1242,17 @@ package body Ada.Containers.Doubly_Linke
pragma Assert (Source.Last.Next = null);
if Target.Length > Count_Type'Last - Source.Length then
- raise Constraint_Error;
+ raise Constraint_Error with "new length exceeds maximum";
end if;
- if Target.Busy > 0
- or else Source.Busy > 0
- then
- raise Program_Error;
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Target (list is busy)";
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Source (list is busy)";
end if;
if Target.Length = 0 then
@@ -1294,23 +1299,25 @@ package body Ada.Containers.Doubly_Linke
procedure Splice
(Container : in out List;
Before : Cursor;
- Position : in out Cursor)
+ Position : Cursor)
is
begin
if Before.Container /= null then
if Before.Container /= Container'Unchecked_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Before cursor designates wrong container";
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
@@ -1324,7 +1331,8 @@ package body Ada.Containers.Doubly_Linke
pragma Assert (Container.Length >= 2);
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
if Before.Node = null then
@@ -1404,30 +1412,36 @@ package body Ada.Containers.Doubly_Linke
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Before cursor designates wrong container";
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Source'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Target.Length = Count_Type'Last then
- raise Constraint_Error;
+ raise Constraint_Error with "Target is full";
end if;
- if Target.Busy > 0
- or else Source.Busy > 0
- then
- raise Program_Error;
+ if Target.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Target (list is busy)";
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements of Source (list is busy)";
end if;
if Position.Node = Source.First then
@@ -1504,16 +1518,20 @@ package body Ada.Containers.Doubly_Linke
I, J : Cursor)
is
begin
- if I.Node = null
- or else J.Node = null
- then
- raise Constraint_Error;
+ if I.Node = null then
+ raise Constraint_Error with "I cursor has no element";
end if;
- if I.Container /= Container'Unchecked_Access
- or else J.Container /= Container'Unchecked_Access
- then
- raise Program_Error;
+ if J.Node = null then
+ raise Constraint_Error with "J cursor has no element";
+ end if;
+
+ if I.Container /= Container'Unchecked_Access then
+ raise Program_Error with "I cursor designates wrong container";
+ end if;
+
+ if J.Container /= Container'Unchecked_Access then
+ raise Program_Error with "J cursor designates wrong container";
end if;
if I.Node = J.Node then
@@ -1521,7 +1539,8 @@ package body Ada.Containers.Doubly_Linke
end if;
if Container.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (list is locked)";
end if;
pragma Assert (Vet (I), "bad I cursor in Swap");
@@ -1548,16 +1567,20 @@ package body Ada.Containers.Doubly_Linke
I, J : Cursor)
is
begin
- if I.Node = null
- or else J.Node = null
- then
- raise Constraint_Error;
+ if I.Node = null then
+ raise Constraint_Error with "I cursor has no element";
end if;
- if I.Container /= Container'Unrestricted_Access
- or else I.Container /= J.Container
- then
- raise Program_Error;
+ if J.Node = null then
+ raise Constraint_Error with "J cursor has no element";
+ end if;
+
+ if I.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "I cursor designates wrong container";
+ end if;
+
+ if J.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "J cursor designates wrong container";
end if;
if I.Node = J.Node then
@@ -1565,7 +1588,8 @@ package body Ada.Containers.Doubly_Linke
end if;
if Container.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
end if;
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
@@ -1573,26 +1597,24 @@ package body Ada.Containers.Doubly_Linke
declare
I_Next : constant Cursor := Next (I);
- J_Copy : Cursor := J;
begin
if I_Next = J then
- Splice (Container, Before => I, Position => J_Copy);
+ Splice (Container, Before => I, Position => J);
else
declare
J_Next : constant Cursor := Next (J);
- I_Copy : Cursor := I;
begin
if J_Next = I then
- Splice (Container, Before => J, Position => I_Copy);
+ Splice (Container, Before => J, Position => I);
else
pragma Assert (Container.Length >= 3);
- Splice (Container, Before => I_Next, Position => J_Copy);
- Splice (Container, Before => J_Next, Position => I_Copy);
+ Splice (Container, Before => I_Next, Position => J);
+ Splice (Container, Before => J_Next, Position => I);
end if;
end;
end if;
@@ -1610,11 +1632,12 @@ package body Ada.Containers.Doubly_Linke
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
@@ -1785,7 +1808,7 @@ package body Ada.Containers.Doubly_Linke
-----------
procedure Write
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : List)
is
Node : Node_Access := Item.First;
@@ -1800,11 +1823,11 @@ package body Ada.Containers.Doubly_Linke
end Write;
procedure Write
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream list cursor";
end Write;
end Ada.Containers.Doubly_Linked_Lists;
Index: a-cihase.adb
===================================================================
--- a-cihase.adb (revision 118179)
+++ a-cihase.adb (working copy)
@@ -9,10 +9,6 @@
-- --
-- Copyright (C) 2004-2006, 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- --
@@ -52,6 +48,9 @@ package body Ada.Containers.Indefinite_H
-- Local Subprograms --
-----------------------
+ procedure Assign (Node : Node_Access; Item : Element_Type);
+ pragma Inline (Assign);
+
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
@@ -89,11 +88,6 @@ package body Ada.Containers.Indefinite_H
return Node_Access;
pragma Inline (Read_Node);
- procedure Replace_Element
- (HT : in out Hash_Table_Type;
- Node : Node_Access;
- New_Item : Element_Type);
-
procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next);
@@ -138,6 +132,9 @@ package body Ada.Containers.Indefinite_H
procedure Read_Nodes is
new HT_Ops.Generic_Read (Read_Node);
+ procedure Replace_Element is
+ new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
+
procedure Write_Nodes is
new HT_Ops.Generic_Write (Write_Node);
@@ -159,6 +156,17 @@ package body Ada.Containers.Indefinite_H
HT_Ops.Adjust (Container.HT);
end Adjust;
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Node : Node_Access; Item : Element_Type) is
+ X : Element_Access := Node.Element;
+ begin
+ Node.Element := new Element_Type'(Item);
+ Free_Element (X);
+ end Assign;
+
--------------
-- Capacity --
--------------
@@ -266,7 +274,7 @@ package body Ada.Containers.Indefinite_H
return;
end if;
- if Source.Length = 0 then
+ if Source.HT.Length = 0 then
return;
end if;
@@ -275,24 +283,41 @@ package body Ada.Containers.Indefinite_H
"attempt to tamper with elements (set is busy)";
end if;
- -- TODO: This can be written in terms of a loop instead as
- -- active-iterator style, sort of like a passive iterator.
+ if Source.HT.Length < Target.HT.Length then
+ declare
+ Src_Node : Node_Access;
- 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;
+ begin
+ Src_Node := HT_Ops.First (Source.HT);
+ while Src_Node /= null loop
+ Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
+
+ if Tgt_Node /= null then
+ HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
+ Free (Tgt_Node);
+ end if;
- else
- Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
- end if;
- end loop;
+ Src_Node := HT_Ops.Next (Source.HT, Src_Node);
+ end loop;
+ end;
+
+ else
+ 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;
+
+ else
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+ end if;
+ end loop;
+ end if;
end Difference;
function Difference (Left, Right : Set) return Set is
@@ -757,15 +782,6 @@ package body Ada.Containers.Indefinite_H
"attempt to tamper with elements (set is busy)";
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
@@ -890,9 +906,6 @@ package body Ada.Containers.Indefinite_H
return False;
end if;
- -- TODO: rewrite this to loop in the
- -- style of a passive iterator.
-
Subset_Node := HT_Ops.First (Subset.HT);
while Subset_Node /= null loop
if not Is_In (Of_Set.HT, Subset_Node) then
@@ -928,15 +941,22 @@ package body Ada.Containers.Indefinite_H
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
+ B : Natural renames Container'Unrestricted_Access.HT.Busy;
-- Start of processing for Iterate
begin
- -- TODO: resolve whether HT_Ops.Generic_Iteration should
- -- manipulate busy bit.
+ B := B + 1;
- Iterate (HT);
+ begin
+ Iterate (Container.HT);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
------------
@@ -1142,117 +1162,6 @@ package body Ada.Containers.Indefinite_H
---------------------
procedure Replace_Element
- (HT : in out Hash_Table_Type;
- Node : Node_Access;
- New_Item : Element_Type)
- is
- begin
- if Equivalent_Elements (Node.Element.all, New_Item) then
- pragma Assert (Hash (Node.Element.all) = Hash (New_Item));
-
- if HT.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is locked)";
- end if;
-
- declare
- X : Element_Access := Node.Element;
- begin
- Node.Element := new Element_Type'(New_Item); -- OK if fails
- Free_Element (X);
- end;
-
- return;
- end if;
-
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is busy)";
- end if;
-
- HT_Ops.Delete_Node_Sans_Free (HT, Node);
-
- Insert_New_Element : declare
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
-
- procedure Insert is
- new Element_Keys.Generic_Conditional_Insert (New_Node);
-
- ------------------------
- -- Insert_New_Element --
- ------------------------
-
- function New_Node (Next : Node_Access) return Node_Access is
- begin
- Node.Element := new Element_Type'(New_Item); -- OK if fails
- Node.Next := Next;
- return Node;
- end New_Node;
-
- Result : Node_Access;
- Inserted : Boolean;
-
- X : Element_Access := Node.Element;
-
- -- Start of processing for Insert_New_Element
-
- begin
- Attempt_Insert : begin
- Insert
- (HT => HT,
- Key => New_Item,
- Node => Result,
- Inserted => Inserted);
- exception
- when others =>
- Inserted := False; -- Assignment failed
- end Attempt_Insert;
-
- if Inserted then
- Free_Element (X); -- Just propagate if fails
- return;
- end if;
- end Insert_New_Element;
-
- Reinsert_Old_Element :
- declare
- 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 New_Node (Next : Node_Access) return Node_Access is
- begin
- Node.Next := Next;
- return Node;
- end New_Node;
-
- Result : Node_Access;
- Inserted : Boolean;
-
- -- Start of processing for Reinsert_Old_Element
-
- begin
- Insert
- (HT => HT,
- Key => Node.Element.all,
- Node => Result,
- Inserted => Inserted);
- exception
- when others =>
- null;
- end Reinsert_Old_Element;
-
- raise Program_Error with "attempt to replace existing element";
- end Replace_Element;
-
- procedure Replace_Element
(Container : in out Set;
Position : Cursor;
New_Item : Element_Type)
Index: a-cohase.adb
===================================================================
--- a-cohase.adb (revision 118179)
+++ a-cohase.adb (working copy)
@@ -6,11 +6,7 @@
-- --
-- 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. --
+-- Copyright (C) 2004-2006, 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- --
@@ -51,6 +47,9 @@ package body Ada.Containers.Hashed_Sets
-- Local Subprograms --
-----------------------
+ procedure Assign (Node : Node_Access; Item : Element_Type);
+ pragma Inline (Assign);
+
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
@@ -90,11 +89,6 @@ package body Ada.Containers.Hashed_Sets
return Node_Access;
pragma Inline (Read_Node);
- procedure Replace_Element
- (HT : in out Hash_Table_Type;
- Node : Node_Access;
- New_Item : Element_Type);
-
procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next);
@@ -136,6 +130,9 @@ package body Ada.Containers.Hashed_Sets
procedure Read_Nodes is
new HT_Ops.Generic_Read (Read_Node);
+ procedure Replace_Element is
+ new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
+
procedure Write_Nodes is
new HT_Ops.Generic_Write (Write_Node);
@@ -157,6 +154,15 @@ package body Ada.Containers.Hashed_Sets
HT_Ops.Adjust (Container.HT);
end Adjust;
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Node : Node_Access; Item : Element_Type) is
+ begin
+ Node.Element := Item;
+ end Assign;
+
--------------
-- Capacity --
--------------
@@ -264,24 +270,41 @@ package body Ada.Containers.Hashed_Sets
"attempt to tamper with elements (set is busy)";
end if;
- -- TODO: This can be written in terms of a loop instead as
- -- active-iterator style, sort of like a passive iterator.
+ if Source.HT.Length < Target.HT.Length then
+ declare
+ Src_Node : Node_Access;
- 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;
+ begin
+ Src_Node := HT_Ops.First (Source.HT);
+ while Src_Node /= null loop
+ Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element);
+
+ if Tgt_Node /= null then
+ HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
+ Free (Tgt_Node);
+ end if;
- else
- Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
- end if;
- end loop;
+ Src_Node := HT_Ops.Next (Source.HT, Src_Node);
+ end loop;
+ end;
+
+ else
+ 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;
+
+ else
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+ end if;
+ end loop;
+ end if;
end Difference;
function Difference (Left, Right : Set) return Set is
@@ -685,7 +708,7 @@ package body Ada.Containers.Hashed_Sets
return;
end if;
- if Source.Length = 0 then
+ if Source.HT.Length = 0 then
Clear (Target);
return;
end if;
@@ -695,15 +718,6 @@ package body Ada.Containers.Hashed_Sets
"attempt to tamper with elements (set is busy)";
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
@@ -818,9 +832,6 @@ package body Ada.Containers.Hashed_Sets
return False;
end if;
- -- TODO: rewrite this to loop in the
- -- style of a passive iterator.
-
Subset_Node := HT_Ops.First (Subset.HT);
while Subset_Node /= null loop
if not Is_In (Of_Set.HT, Subset_Node) then
@@ -855,13 +866,22 @@ package body Ada.Containers.Hashed_Sets
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
+ B : Natural renames Container'Unrestricted_Access.HT.Busy;
+
-- Start of processing for Iterate
begin
- -- TODO: resolve whether HT_Ops.Generic_Iteration should
- -- manipulate busy bit.
+ B := B + 1;
- Iterate (Container.HT);
+ begin
+ Iterate (Container.HT);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
end Iterate;
------------
@@ -1047,109 +1067,6 @@ package body Ada.Containers.Hashed_Sets
Node.Element := New_Item;
end Replace;
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (HT : in out Hash_Table_Type;
- Node : Node_Access;
- New_Item : Element_Type)
- is
- begin
- if Equivalent_Elements (Node.Element, New_Item) then
- pragma Assert (Hash (Node.Element) = Hash (New_Item));
-
- if HT.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (set is locked)";
- end if;
-
- Node.Element := New_Item; -- Note that this assignment can fail
- return;
- end if;
-
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with elements (set is busy)";
- end if;
-
- HT_Ops.Delete_Node_Sans_Free (HT, Node);
-
- Insert_New_Element : declare
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
-
- procedure Local_Insert is
- new Element_Keys.Generic_Conditional_Insert (New_Node);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node (Next : Node_Access) return Node_Access is
- begin
- Node.Element := New_Item; -- Note that this assignment can fail
- Node.Next := Next;
- return Node;
- end New_Node;
-
- Result : Node_Access;
- Inserted : Boolean;
-
- -- Start of processing for Insert_New_Element
-
- begin
- Local_Insert
- (HT => HT,
- Key => New_Item,
- Node => Result,
- Inserted => Inserted);
-
- if Inserted then
- return;
- end if;
- exception
- when others =>
- null; -- Assignment must have failed
- end Insert_New_Element;
-
- Reinsert_Old_Element : declare
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
-
- procedure Local_Insert is
- new Element_Keys.Generic_Conditional_Insert (New_Node);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node (Next : Node_Access) return Node_Access is
- begin
- Node.Next := Next;
- return Node;
- end New_Node;
-
- Result : Node_Access;
- Inserted : Boolean;
-
- -- Start of processing for Reinsert_Old_Element
-
- begin
- Local_Insert
- (HT => HT,
- Key => Node.Element,
- Node => Result,
- Inserted => Inserted);
- exception
- when others =>
- null;
- end Reinsert_Old_Element;
-
- raise Program_Error with "attempt to replace existing element";
- end Replace_Element;
-
procedure Replace_Element
(Container : in out Set;
Position : Cursor;
Index: a-chtgke.ads
===================================================================
--- a-chtgke.ads (revision 118179)
+++ a-chtgke.ads (working copy)
@@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2006, 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 --
@@ -67,15 +67,22 @@ package Ada.Containers.Hash_Tables.Gener
Key : Key_Type;
X : out Node_Access);
- function Find (HT : Hash_Table_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;
+ with function New_Node (Next : Node_Access) return Node_Access;
procedure Generic_Conditional_Insert
(HT : in out Hash_Table_Type;
Key : Key_Type;
Node : out Node_Access;
Inserted : out Boolean);
+ generic
+ with function Hash (Node : Node_Access) return Hash_Type;
+ with procedure Assign (Node : Node_Access; Key : Key_Type);
+ procedure Generic_Replace_Element
+ (HT : in out Hash_Table_Type;
+ Node : Node_Access;
+ Key : Key_Type);
+
end Ada.Containers.Hash_Tables.Generic_Keys;
Index: a-chtgke.adb
===================================================================
--- a-chtgke.adb (revision 118179)
+++ a-chtgke.adb (working copy)
@@ -7,11 +7,7 @@
-- --
-- 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. --
+-- Copyright (C) 2004-2006, 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- --
@@ -131,23 +127,21 @@ package body Ada.Containers.Hash_Tables.
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 then
if HT.Busy > 0 then
raise Program_Error;
end if;
- declare
- Length : constant Length_Subtype := HT.Length;
- begin
- Node := New_Node (Next => null);
- Inserted := True;
-
- B := Node;
- HT.Length := Length + 1;
- end;
+ if HT.Length = Count_Type'Last then
+ raise Constraint_Error;
+ end if;
+
+ Node := New_Node (Next => null);
+ Inserted := True;
+
+ B := Node;
+ HT.Length := HT.Length + 1;
return;
end if;
@@ -168,15 +162,15 @@ package body Ada.Containers.Hash_Tables.
raise Program_Error;
end if;
- declare
- Length : constant Length_Subtype := HT.Length;
- begin
- Node := New_Node (Next => B);
- Inserted := True;
+ if HT.Length = Count_Type'Last then
+ raise Constraint_Error;
+ end if;
- B := Node;
- HT.Length := Length + 1;
- end;
+ Node := New_Node (Next => B);
+ Inserted := True;
+
+ B := Node;
+ HT.Length := HT.Length + 1;
end Generic_Conditional_Insert;
-----------
@@ -190,4 +184,91 @@ package body Ada.Containers.Hash_Tables.
return Hash (Key) mod HT.Buckets'Length;
end Index;
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Generic_Replace_Element
+ (HT : in out Hash_Table_Type;
+ Node : Node_Access;
+ Key : Key_Type)
+ is
+ begin
+ pragma Assert (HT.Length > 0);
+
+ if Equivalent_Keys (Key, Node) then
+ pragma Assert (Hash (Key) = Hash (Node));
+
+ if HT.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is locked)";
+ end if;
+
+ Assign (Node, Key);
+ return;
+ end if;
+
+ declare
+ J : Hash_Type;
+ K : constant Hash_Type := Index (HT, Key);
+ B : Node_Access renames HT.Buckets (K);
+ N : Node_Access := B;
+ M : Node_Access;
+
+ begin
+ while N /= null loop
+ if Equivalent_Keys (Key, N) then
+ raise Program_Error with
+ "attempt to replace existing element";
+ end if;
+
+ N := Next (N);
+ end loop;
+
+ J := Hash (Node);
+
+ if J = K then
+ if HT.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is locked)";
+ end if;
+
+ Assign (Node, Key);
+ return;
+ end if;
+
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (container is busy)";
+ end if;
+
+ Assign (Node, Key);
+
+ N := HT.Buckets (J);
+ pragma Assert (N /= null);
+
+ if N = Node then
+ HT.Buckets (J) := Next (Node);
+
+ else
+ pragma Assert (HT.Length > 1);
+
+ loop
+ M := Next (N);
+ pragma Assert (M /= null);
+
+ if M = Node then
+ Set_Next (Node => N, Next => Next (Node));
+ exit;
+ end if;
+
+ N := M;
+ end loop;
+ end if;
+
+ Set_Next (Node => Node, Next => B);
+ B := Node;
+ end;
+ end Generic_Replace_Element;
+
end Ada.Containers.Hash_Tables.Generic_Keys;
More information about the Gcc-patches
mailing list