Skip to content

R
riscv-gcc-1
Commit 3837bc7f by Matt Heaney Committed by Arnaud Charlet
Options

a-crbtgo.ads: Commented each subprogram 

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

From-SVN: r118324
parent 31a33125
Showing with 615 additions and 781 deletions
gcc/ada/a-cdlili.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -46,8 +46,10 @@ package Ada.Containers.Doubly_Linked_Lists is ...@@ -46,8 +46,10 @@ package Ada.Containers.Doubly_Linked_Lists is
pragma Preelaborate; pragma Preelaborate;
type List is tagged private; type List is tagged private;
pragma Preelaborable_Initialization (List);
type Cursor is private; type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
Empty_List : constant List; Empty_List : constant List;
...@@ -147,7 +149,7 @@ package Ada.Containers.Doubly_Linked_Lists is ...@@ -147,7 +149,7 @@ package Ada.Containers.Doubly_Linked_Lists is
procedure Splice procedure Splice
(Container : in out List; (Container : in out List;
Before : Cursor; Before : Cursor;
Position : in out Cursor); Position : Cursor);
function First (Container : List) return Cursor; function First (Container : List) return Cursor;
...@@ -230,13 +232,13 @@ private ...@@ -230,13 +232,13 @@ private
use Ada.Streams; use Ada.Streams;
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out List); Item : out List);
for List'Read use Read; for List'Read use Read;
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : List); Item : List);
for List'Write use Write; for List'Write use Write;
...@@ -253,13 +255,13 @@ private ...@@ -253,13 +255,13 @@ private
end record; end record;
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out Cursor); Item : out Cursor);
for Cursor'Read use Read; for Cursor'Read use Read;
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : Cursor); Item : Cursor);
for Cursor'Write use Write; for Cursor'Write use Write;
......
gcc/ada/a-chtgke.adb
...@@ -7,11 +7,7 @@ ...@@ -7,11 +7,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- 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 --
-- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -131,23 +127,21 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is ...@@ -131,23 +127,21 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
Indx : constant Hash_Type := Index (HT, Key); Indx : constant Hash_Type := Index (HT, Key);
B : Node_Access renames HT.Buckets (Indx); B : Node_Access renames HT.Buckets (Indx);
subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1;
begin begin
if B = null then if B = null then
if HT.Busy > 0 then if HT.Busy > 0 then
raise Program_Error; raise Program_Error;
end if; end if;
declare if HT.Length = Count_Type'Last then
Length : constant Length_Subtype := HT.Length; raise Constraint_Error;
begin end if;
Node := New_Node (Next => null);
Inserted := True;
B := Node; Node := New_Node (Next => null);
HT.Length := Length + 1; Inserted := True;
end;
B := Node;
HT.Length := HT.Length + 1;
return; return;
end if; end if;
...@@ -168,15 +162,15 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is ...@@ -168,15 +162,15 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
raise Program_Error; raise Program_Error;
end if; end if;
declare if HT.Length = Count_Type'Last then
Length : constant Length_Subtype := HT.Length; raise Constraint_Error;
begin end if;
Node := New_Node (Next => B);
Inserted := True;
B := Node; Node := New_Node (Next => B);
HT.Length := Length + 1; Inserted := True;
end;
B := Node;
HT.Length := HT.Length + 1;
end Generic_Conditional_Insert; end Generic_Conditional_Insert;
----------- -----------
...@@ -190,4 +184,91 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is ...@@ -190,4 +184,91 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
return Hash (Key) mod HT.Buckets'Length; return Hash (Key) mod HT.Buckets'Length;
end Index; 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; end Ada.Containers.Hash_Tables.Generic_Keys;
gcc/ada/a-chtgke.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -67,15 +67,22 @@ package Ada.Containers.Hash_Tables.Generic_Keys is ...@@ -67,15 +67,22 @@ package Ada.Containers.Hash_Tables.Generic_Keys is
Key : Key_Type; Key : Key_Type;
X : out Node_Access); 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 generic
with function New_Node with function New_Node (Next : Node_Access) return Node_Access;
(Next : Node_Access) return Node_Access;
procedure Generic_Conditional_Insert procedure Generic_Conditional_Insert
(HT : in out Hash_Table_Type; (HT : in out Hash_Table_Type;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access; Node : out Node_Access;
Inserted : out Boolean); 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; end Ada.Containers.Hash_Tables.Generic_Keys;
gcc/ada/a-chtgop.adb
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -30,8 +30,6 @@ ...@@ -30,8 +30,6 @@
-- This unit was originally developed by Matthew J Heaney. -- -- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This body needs commenting ???
with Ada.Containers.Prime_Numbers; with Ada.Containers.Prime_Numbers;
with Ada.Unchecked_Deallocation; with Ada.Unchecked_Deallocation;
...@@ -60,40 +58,15 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ...@@ -60,40 +58,15 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
return; return;
end if; end if;
-- 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.
HT.Buckets := new Buckets_Type (Src_Buckets'Range); HT.Buckets := new Buckets_Type (Src_Buckets'Range);
-- TODO: allocate minimum size req'd. (See note below.)
-- NOTE: see note below about these comments.
-- Probably we have to duplicate the Size (Src), too, in order
-- to guarantee that
-- 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.
for Src_Index in Src_Buckets'Range loop for Src_Index in Src_Buckets'Range loop
Src_Node := Src_Buckets (Src_Index); Src_Node := Src_Buckets (Src_Index);
...@@ -102,7 +75,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ...@@ -102,7 +75,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
declare declare
Dst_Node : constant Node_Access := Copy_Node (Src_Node); Dst_Node : constant Node_Access := Copy_Node (Src_Node);
-- See note above -- See note above
pragma Assert (Index (HT, Dst_Node) = Src_Index); pragma Assert (Index (HT, Dst_Node) = Src_Index);
...@@ -353,32 +326,20 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ...@@ -353,32 +326,20 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
----------------------- -----------------------
procedure Generic_Iteration (HT : Hash_Table_Type) is procedure Generic_Iteration (HT : Hash_Table_Type) is
Busy : Natural renames HT'Unrestricted_Access.all.Busy; Node : Node_Access;
begin begin
if HT.Length = 0 then if HT.Length = 0 then
return; return;
end if; end if;
Busy := Busy + 1; for Indx in HT.Buckets'Range loop
Node := HT.Buckets (Indx);
declare while Node /= null loop
Node : Node_Access; Process (Node);
begin Node := Next (Node);
for Indx in HT.Buckets'Range loop
Node := HT.Buckets (Indx);
while Node /= null loop
Process (Node);
Node := Next (Node);
end loop;
end loop; end loop;
exception end loop;
when others =>
Busy := Busy - 1;
raise;
end;
Busy := Busy - 1;
end Generic_Iteration; end Generic_Iteration;
------------------ ------------------
...@@ -389,71 +350,41 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ...@@ -389,71 +350,41 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
(Stream : access Root_Stream_Type'Class; (Stream : access Root_Stream_Type'Class;
HT : out Hash_Table_Type) HT : out Hash_Table_Type)
is is
X, Y : Node_Access; N : Count_Type'Base;
NN : Hash_Type;
Last, I : Hash_Type;
N, M : Count_Type'Base;
begin begin
Clear (HT); Clear (HT);
Hash_Type'Read (Stream, Last);
Count_Type'Base'Read (Stream, N); Count_Type'Base'Read (Stream, N);
pragma Assert (N >= 0);
if N < 0 then
raise Program_Error;
end if;
if N = 0 then if N = 0 then
return; return;
end if; end if;
if HT.Buckets = null if HT.Buckets = null
or else HT.Buckets'Last /= Last or else HT.Buckets'Length < N
then then
Free (HT.Buckets); 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; end if;
-- TODO: should we rewrite this algorithm so that it doesn't for J in 1 .. N loop
-- depend on preserving the exactly length of the hash table declare
-- array? We would prefer to not have to (re)allocate a Node : constant Node_Access := New_Node (Stream);
-- buckets array (the array that HT already has might be large Indx : constant Hash_Type := Index (HT, Node);
-- enough), and to not have to stream the count of the number B : Node_Access renames HT.Buckets (Indx);
-- of nodes in each bucket. The algorithm below is vestigial, begin
-- as it was written prior to the meeting in Palma, when the Set_Next (Node => Node, Next => B);
-- semantics of equality were changed (and which obviated the B := Node;
-- need to preserve the hash table length). end;
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);
HT.Length := HT.Length + 1; 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 loop;
end Generic_Read; end Generic_Read;
...@@ -465,47 +396,23 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ...@@ -465,47 +396,23 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
(Stream : access Root_Stream_Type'Class; (Stream : access Root_Stream_Type'Class;
HT : Hash_Table_Type) HT : Hash_Table_Type)
is is
M : Count_Type'Base; procedure Write (Node : Node_Access);
X : Node_Access; pragma Inline (Write);
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); procedure Write is new Generic_Iteration (Write);
if HT.Length = 0 then -----------
return; -- Write --
end if; -----------
-- TODO: see note in Generic_Read??? procedure Write (Node : Node_Access) is
begin
for Indx in HT.Buckets'Range loop Write (Stream, Node);
X := HT.Buckets (Indx); end Write;
if X /= null then
M := 1;
loop
X := Next (X);
exit when X = null;
M := M + 1;
end loop;
Hash_Type'Write (Stream, Indx);
Count_Type'Base'Write (Stream, M);
X := HT.Buckets (Indx);
for J in Count_Type range 1 .. M loop
Write (Stream, X);
X := Next (X);
end loop;
pragma Assert (X = null); begin
end if; Count_Type'Base'Write (Stream, HT.Length);
end loop; Write (HT);
end Generic_Write; end Generic_Write;
----------- -----------
......
gcc/ada/a-cidlli.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -47,8 +47,10 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -47,8 +47,10 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Preelaborate; pragma Preelaborate;
type List is tagged private; type List is tagged private;
pragma Preelaborable_Initialization (List);
type Cursor is private; type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
Empty_List : constant List; Empty_List : constant List;
...@@ -138,7 +140,7 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -138,7 +140,7 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Splice procedure Splice
(Container : in out List; (Container : in out List;
Before : Cursor; Before : Cursor;
Position : in out Cursor); Position : Cursor);
function First (Container : List) return Cursor; function First (Container : List) return Cursor;
...@@ -223,13 +225,13 @@ private ...@@ -223,13 +225,13 @@ private
use Ada.Streams; use Ada.Streams;
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out List); Item : out List);
for List'Read use Read; for List'Read use Read;
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : List); Item : List);
for List'Write use Write; for List'Write use Write;
...@@ -246,13 +248,13 @@ private ...@@ -246,13 +248,13 @@ private
end record; end record;
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out Cursor); Item : out Cursor);
for Cursor'Read use Read; for Cursor'Read use Read;
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : Cursor); Item : Cursor);
for Cursor'Write use Write; for Cursor'Write use Write;
......
gcc/ada/a-cihama.adb
...@@ -7,11 +7,7 @@ ...@@ -7,11 +7,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- 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 --
-- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -603,7 +599,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ...@@ -603,7 +599,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
procedure Process_Node (Node : Node_Access); procedure Process_Node (Node : Node_Access);
pragma Inline (Process_Node); pragma Inline (Process_Node);
procedure Iterate is procedure Local_Iterate is
new HT_Ops.Generic_Iteration (Process_Node); new HT_Ops.Generic_Iteration (Process_Node);
------------------ ------------------
...@@ -615,10 +611,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ...@@ -615,10 +611,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Process (Cursor'(Container'Unchecked_Access, Node)); Process (Cursor'(Container'Unchecked_Access, Node));
end Process_Node; end Process_Node;
B : Natural renames Container'Unrestricted_Access.HT.Busy;
-- Start of processing Iterate -- Start of processing Iterate
begin 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; end Iterate;
--------- ---------
......
gcc/ada/a-cihase.adb
...@@ -9,10 +9,6 @@ ...@@ -9,10 +9,6 @@
-- -- -- --
-- Copyright (C) 2004-2006, 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 --
-- 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 -- -- 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- -- -- 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- -- -- ware Foundation; either version 2, or (at your option) any later ver- --
...@@ -52,6 +48,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -52,6 +48,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
procedure Assign (Node : Node_Access; Item : Element_Type);
pragma Inline (Assign);
function Copy_Node (Source : Node_Access) return Node_Access; function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node); pragma Inline (Copy_Node);
...@@ -89,11 +88,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -89,11 +88,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
return Node_Access; return Node_Access;
pragma Inline (Read_Node); 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); procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next); pragma Inline (Set_Next);
...@@ -138,6 +132,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -138,6 +132,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
procedure Read_Nodes is procedure Read_Nodes is
new HT_Ops.Generic_Read (Read_Node); new HT_Ops.Generic_Read (Read_Node);
procedure Replace_Element is
new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
procedure Write_Nodes is procedure Write_Nodes is
new HT_Ops.Generic_Write (Write_Node); new HT_Ops.Generic_Write (Write_Node);
...@@ -159,6 +156,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -159,6 +156,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
HT_Ops.Adjust (Container.HT); HT_Ops.Adjust (Container.HT);
end Adjust; 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 -- -- Capacity --
-------------- --------------
...@@ -266,7 +274,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -266,7 +274,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
return; return;
end if; end if;
if Source.Length = 0 then if Source.HT.Length = 0 then
return; return;
end if; end if;
...@@ -275,24 +283,41 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -275,24 +283,41 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
"attempt to tamper with elements (set is busy)"; "attempt to tamper with elements (set is busy)";
end if; end if;
-- TODO: This can be written in terms of a loop instead as if Source.HT.Length < Target.HT.Length then
-- active-iterator style, sort of like a passive iterator. declare
Src_Node : Node_Access;
Tgt_Node := HT_Ops.First (Target.HT); begin
while Tgt_Node /= null loop Src_Node := HT_Ops.First (Source.HT);
if Is_In (Source.HT, Tgt_Node) then while Src_Node /= null loop
declare Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
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 if Tgt_Node /= null then
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
end if; Free (Tgt_Node);
end loop; end if;
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; end Difference;
function Difference (Left, Right : Set) return Set is function Difference (Left, Right : Set) return Set is
...@@ -757,15 +782,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -757,15 +782,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
"attempt to tamper with elements (set is busy)"; "attempt to tamper with elements (set is busy)";
end if; 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); Tgt_Node := HT_Ops.First (Target.HT);
while Tgt_Node /= null loop while Tgt_Node /= null loop
if Is_In (Source.HT, Tgt_Node) then if Is_In (Source.HT, Tgt_Node) then
...@@ -890,9 +906,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -890,9 +906,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
return False; return False;
end if; end if;
-- TODO: rewrite this to loop in the
-- style of a passive iterator.
Subset_Node := HT_Ops.First (Subset.HT); Subset_Node := HT_Ops.First (Subset.HT);
while Subset_Node /= null loop while Subset_Node /= null loop
if not Is_In (Of_Set.HT, Subset_Node) then if not Is_In (Of_Set.HT, Subset_Node) then
...@@ -928,15 +941,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -928,15 +941,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Process (Cursor'(Container'Unrestricted_Access, Node)); Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_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 -- Start of processing for Iterate
begin begin
-- TODO: resolve whether HT_Ops.Generic_Iteration should B := B + 1;
-- manipulate busy bit.
begin
Iterate (Container.HT);
exception
when others =>
B := B - 1;
raise;
end;
Iterate (HT); B := B - 1;
end Iterate; end Iterate;
------------ ------------
...@@ -1142,117 +1162,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -1142,117 +1162,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
--------------------- ---------------------
procedure 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.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; (Container : in out Set;
Position : Cursor; Position : Cursor;
New_Item : Element_Type) New_Item : Element_Type)
......
gcc/ada/a-ciorse.adb
...@@ -7,11 +7,7 @@ ...@@ -7,11 +7,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- 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 --
-- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1463,121 +1459,100 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ...@@ -1463,121 +1459,100 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Node : Node_Access; Node : Node_Access;
Item : Element_Type) Item : Element_Type)
is 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 begin
if Item < Node.Element.all if Item < Node.Element.all
or else Node.Element.all < Item or else Node.Element.all < Item
then then
null; null;
else else
if Tree.Lock > 0 then if Tree.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors (set is locked)"; "attempt to tamper with cursors (set is locked)";
end if; end if;
declare Node.Element := new Element_Type'(Item);
X : Element_Access := Node.Element; Free_Element (X);
begin
Node.Element := new Element_Type'(Item);
Free_Element (X);
end;
return; return;
end if; end if;
Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit Hint := Element_Keys.Ceiling (Tree, Item);
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;
Result : Node_Access; if Hint = null then
Inserted : Boolean; null;
X : Element_Access := Node.Element;
-- 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 Node.Element := new Element_Type'(Item);
Attempt_Insert : begin Free_Element (X);
Insert
(Tree => Tree,
Key => Item,
Node => Result,
Success => Inserted); -- TODO: change name of formal param
exception
when others =>
Inserted := False;
end Attempt_Insert;
if Inserted then
pragma Assert (Result = Node);
Free_Element (X); -- OK if fails
return; return;
end if; 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; else
end New_Node; pragma Assert (not (Hint.Element.all < Item));
raise Program_Error with "attempt to replace existing element";
end if;
Result : Node_Access; Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
Inserted : Boolean;
-- Start of processing for Reinsert_Old_Element Local_Insert_With_Hint
(Tree => Tree,
Position => Hint,
Key => Item,
Node => Result,
Inserted => Inserted);
begin pragma Assert (Inserted);
Insert pragma Assert (Result = Node);
(Tree => Tree,
Key => Node.Element.all,
Node => Result,
Success => Inserted); -- TODO: change name of formal param
exception
when others =>
null;
end Reinsert_Old_Element;
raise Program_Error with "attempt to replace existing element"; Free_Element (X);
end Replace_Element; end Replace_Element;
procedure Replace_Element procedure Replace_Element
......
gcc/ada/a-cohama.adb
...@@ -6,11 +6,7 @@ ...@@ -6,11 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- 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 --
-- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -566,10 +562,22 @@ package body Ada.Containers.Hashed_Maps is ...@@ -566,10 +562,22 @@ package body Ada.Containers.Hashed_Maps is
Process (Cursor'(Container'Unchecked_Access, Node)); Process (Cursor'(Container'Unchecked_Access, Node));
end Process_Node; end Process_Node;
B : Natural renames Container'Unrestricted_Access.HT.Busy;
-- Start of processing for Iterate -- Start of processing for Iterate
begin 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; end Iterate;
--------- ---------
......
gcc/ada/a-cohase.adb
...@@ -6,11 +6,7 @@ ...@@ -6,11 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- 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 --
-- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -51,6 +47,9 @@ package body Ada.Containers.Hashed_Sets is ...@@ -51,6 +47,9 @@ package body Ada.Containers.Hashed_Sets is
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
procedure Assign (Node : Node_Access; Item : Element_Type);
pragma Inline (Assign);
function Copy_Node (Source : Node_Access) return Node_Access; function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node); pragma Inline (Copy_Node);
...@@ -90,11 +89,6 @@ package body Ada.Containers.Hashed_Sets is ...@@ -90,11 +89,6 @@ package body Ada.Containers.Hashed_Sets is
return Node_Access; return Node_Access;
pragma Inline (Read_Node); 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); procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next); pragma Inline (Set_Next);
...@@ -136,6 +130,9 @@ package body Ada.Containers.Hashed_Sets is ...@@ -136,6 +130,9 @@ package body Ada.Containers.Hashed_Sets is
procedure Read_Nodes is procedure Read_Nodes is
new HT_Ops.Generic_Read (Read_Node); new HT_Ops.Generic_Read (Read_Node);
procedure Replace_Element is
new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
procedure Write_Nodes is procedure Write_Nodes is
new HT_Ops.Generic_Write (Write_Node); new HT_Ops.Generic_Write (Write_Node);
...@@ -157,6 +154,15 @@ package body Ada.Containers.Hashed_Sets is ...@@ -157,6 +154,15 @@ package body Ada.Containers.Hashed_Sets is
HT_Ops.Adjust (Container.HT); HT_Ops.Adjust (Container.HT);
end Adjust; end Adjust;
------------
-- Assign --
------------
procedure Assign (Node : Node_Access; Item : Element_Type) is
begin
Node.Element := Item;
end Assign;
-------------- --------------
-- Capacity -- -- Capacity --
-------------- --------------
...@@ -264,24 +270,41 @@ package body Ada.Containers.Hashed_Sets is ...@@ -264,24 +270,41 @@ package body Ada.Containers.Hashed_Sets is
"attempt to tamper with elements (set is busy)"; "attempt to tamper with elements (set is busy)";
end if; end if;
-- TODO: This can be written in terms of a loop instead as if Source.HT.Length < Target.HT.Length then
-- active-iterator style, sort of like a passive iterator. declare
Src_Node : Node_Access;
Tgt_Node := HT_Ops.First (Target.HT); begin
while Tgt_Node /= null loop Src_Node := HT_Ops.First (Source.HT);
if Is_In (Source.HT, Tgt_Node) then while Src_Node /= null loop
declare Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element);
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 if Tgt_Node /= null then
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
end if; Free (Tgt_Node);
end loop; end if;
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; end Difference;
function Difference (Left, Right : Set) return Set is function Difference (Left, Right : Set) return Set is
...@@ -685,7 +708,7 @@ package body Ada.Containers.Hashed_Sets is ...@@ -685,7 +708,7 @@ package body Ada.Containers.Hashed_Sets is
return; return;
end if; end if;
if Source.Length = 0 then if Source.HT.Length = 0 then
Clear (Target); Clear (Target);
return; return;
end if; end if;
...@@ -695,15 +718,6 @@ package body Ada.Containers.Hashed_Sets is ...@@ -695,15 +718,6 @@ package body Ada.Containers.Hashed_Sets is
"attempt to tamper with elements (set is busy)"; "attempt to tamper with elements (set is busy)";
end if; 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); Tgt_Node := HT_Ops.First (Target.HT);
while Tgt_Node /= null loop while Tgt_Node /= null loop
if Is_In (Source.HT, Tgt_Node) then if Is_In (Source.HT, Tgt_Node) then
...@@ -818,9 +832,6 @@ package body Ada.Containers.Hashed_Sets is ...@@ -818,9 +832,6 @@ package body Ada.Containers.Hashed_Sets is
return False; return False;
end if; end if;
-- TODO: rewrite this to loop in the
-- style of a passive iterator.
Subset_Node := HT_Ops.First (Subset.HT); Subset_Node := HT_Ops.First (Subset.HT);
while Subset_Node /= null loop while Subset_Node /= null loop
if not Is_In (Of_Set.HT, Subset_Node) then if not Is_In (Of_Set.HT, Subset_Node) then
...@@ -855,13 +866,22 @@ package body Ada.Containers.Hashed_Sets is ...@@ -855,13 +866,22 @@ package body Ada.Containers.Hashed_Sets is
Process (Cursor'(Container'Unrestricted_Access, Node)); Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node; end Process_Node;
B : Natural renames Container'Unrestricted_Access.HT.Busy;
-- Start of processing for Iterate -- Start of processing for Iterate
begin begin
-- TODO: resolve whether HT_Ops.Generic_Iteration should B := B + 1;
-- manipulate busy bit.
begin
Iterate (Container.HT);
exception
when others =>
B := B - 1;
raise;
end;
Iterate (Container.HT); B := B - 1;
end Iterate; end Iterate;
------------ ------------
...@@ -1047,109 +1067,6 @@ package body Ada.Containers.Hashed_Sets is ...@@ -1047,109 +1067,6 @@ package body Ada.Containers.Hashed_Sets is
Node.Element := New_Item; Node.Element := New_Item;
end Replace; 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 procedure Replace_Element
(Container : in out Set; (Container : in out Set;
Position : Cursor; Position : Cursor;
......
gcc/ada/a-coinve.adb
...@@ -8,10 +8,6 @@ ...@@ -8,10 +8,6 @@
-- -- -- --
-- Copyright (C) 2004-2006, 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 --
-- 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 -- -- 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- -- -- 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- -- -- ware Foundation; either version 2, or (at your option) any later ver- --
...@@ -1052,7 +1048,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1052,7 +1048,7 @@ package body Ada.Containers.Indefinite_Vectors is
Old_Last_As_Int : constant Int := Int (Container.Last); Old_Last_As_Int : constant Int := Int (Container.Last);
begin 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"; raise Constraint_Error with "new length is out of range";
end if; end if;
...@@ -1514,7 +1510,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1514,7 +1510,7 @@ package body Ada.Containers.Indefinite_Vectors is
Old_Last_As_Int : constant Int := Int (Container.Last); Old_Last_As_Int : constant Int := Int (Container.Last);
begin 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"; raise Constraint_Error with "new length is out of range";
end if; end if;
...@@ -2586,12 +2582,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2586,12 +2582,6 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
for Indx in Index_Type'First .. Container.Last loop 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 if E (Indx) = null then
Boolean'Write (Stream, False); Boolean'Write (Stream, False);
else else
......
gcc/ada/a-convec.adb
...@@ -8,10 +8,6 @@ ...@@ -8,10 +8,6 @@
-- -- -- --
-- Copyright (C) 2004-2006 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 --
-- 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 -- -- 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- -- -- 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- -- -- ware Foundation; either version 2, or (at your option) any later ver- --
...@@ -799,34 +795,6 @@ package body Ada.Containers.Vectors is ...@@ -799,34 +795,6 @@ package body Ada.Containers.Vectors is
begin begin
if Old_Last_As_Int > Int'Last - N then 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"; raise Constraint_Error with "new length is out of range";
end if; end if;
...@@ -1282,7 +1250,7 @@ package body Ada.Containers.Vectors is ...@@ -1282,7 +1250,7 @@ package body Ada.Containers.Vectors is
Old_Last_As_Int : constant Int := Int (Container.Last); Old_Last_As_Int : constant Int := Int (Container.Last);
begin 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"; raise Constraint_Error with "new length is out of range";
end if; end if;
......
gcc/ada/a-coorse.adb
...@@ -6,11 +6,7 @@ ...@@ -6,11 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- 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 --
-- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1375,11 +1371,49 @@ package body Ada.Containers.Ordered_Sets is ...@@ -1375,11 +1371,49 @@ package body Ada.Containers.Ordered_Sets is
Node : Node_Access; Node : Node_Access;
Item : Element_Type) Item : Element_Type)
is 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 begin
if Item < Node.Element if Item < Node.Element
or else Node.Element < Item or else Node.Element < Item
then then
null; null;
else else
if Tree.Lock > 0 then if Tree.Lock > 0 then
raise Program_Error with raise Program_Error with
...@@ -1390,95 +1424,38 @@ package body Ada.Containers.Ordered_Sets is ...@@ -1390,95 +1424,38 @@ package body Ada.Containers.Ordered_Sets is
return; return;
end if; end if;
Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit Hint := Element_Keys.Ceiling (Tree, Item);
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 if Hint = null then
new Element_Keys.Generic_Conditional_Insert (Insert_Post); null;
-------------- elsif Item < Hint.Element then
-- New_Node -- 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.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; return;
end if; 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);
-------------- else
-- New_Node -- pragma Assert (not (Hint.Element < Item));
-------------- raise Program_Error with "attempt to replace existing element";
end if;
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;
-- Start of processing for Reinsert_Old_Element
begin Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
Insert
(Tree => Tree,
Key => Node.Element,
Node => Result,
Success => Inserted); -- TODO: change param name
exception
when others =>
null; -- Assignment must have failed
end Reinsert_Old_Element;
raise Program_Error with "attempt to replace existing element"; Local_Insert_With_Hint
(Tree => Tree,
Position => Hint,
Key => Item,
Node => Result,
Inserted => Inserted);
pragma Assert (Inserted);
pragma Assert (Result = Node);
end Replace_Element; end Replace_Element;
procedure Replace_Element procedure Replace_Element
......
gcc/ada/a-crbtgk.ads
...@@ -7,13 +7,32 @@ ...@@ -7,13 +7,32 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- This specification is adapted from the Ada Reference Manual for use with -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- 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. --
-- -- -- --
-- 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; with Ada.Containers.Red_Black_Trees.Generic_Operations;
generic generic
...@@ -37,42 +56,58 @@ package Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -37,42 +56,58 @@ package Ada.Containers.Red_Black_Trees.Generic_Keys is
generic generic
with function New_Node return Node_Access; with function New_Node return Node_Access;
procedure Generic_Insert_Post procedure Generic_Insert_Post
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
X, Y : Node_Access; Y : Node_Access;
Key : Key_Type; Before : Boolean;
Z : out Node_Access); 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 generic
with procedure Insert_Post with procedure Insert_Post
(Tree : in out Tree_Type; (T : in out Tree_Type;
X, Y : Node_Access; Y : Node_Access;
Key : Key_Type; B : Boolean;
Z : out Node_Access); Z : out Node_Access);
procedure Generic_Conditional_Insert procedure Generic_Conditional_Insert
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access; Node : out Node_Access;
Success : out Boolean); 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 generic
with procedure Insert_Post with procedure Insert_Post
(Tree : in out Tree_Type; (T : in out Tree_Type;
X, Y : Node_Access; Y : Node_Access;
Key : Key_Type; B : Boolean;
Z : out Node_Access); Z : out Node_Access);
procedure Generic_Unconditional_Insert procedure Generic_Unconditional_Insert
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access); 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 generic
with procedure Insert_Post with procedure Insert_Post
(Tree : in out Tree_Type; (T : in out Tree_Type;
X, Y : Node_Access; Y : Node_Access;
Key : Key_Type; B : Boolean;
Z : out Node_Access); Z : out Node_Access);
with procedure Unconditional_Insert_Sans_Hint with procedure Unconditional_Insert_Sans_Hint
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
...@@ -84,53 +119,77 @@ package Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -84,53 +119,77 @@ package Ada.Containers.Red_Black_Trees.Generic_Keys is
Hint : Node_Access; Hint : Node_Access;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access); 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 generic
with procedure Insert_Post with procedure Insert_Post
(Tree : in out Tree_Type; (T : in out Tree_Type;
X, Y : Node_Access; Y : Node_Access;
Key : Key_Type; B : Boolean;
Z : out Node_Access); Z : out Node_Access);
with procedure Conditional_Insert_Sans_Hint with procedure Conditional_Insert_Sans_Hint
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access; Node : out Node_Access;
Success : out Boolean); Inserted : out Boolean);
procedure Generic_Conditional_Insert_With_Hint procedure Generic_Conditional_Insert_With_Hint
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Position : Node_Access; Position : Node_Access; -- the hint
Key : Key_Type; Key : Key_Type;
Node : out Node_Access; 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 function Find
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_Type) return Node_Access; Key : Key_Type) return Node_Access;
-- Searches Tree for the smallest node equivalent to Key
function Ceiling function Ceiling
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_Type) return Node_Access; Key : Key_Type) return Node_Access;
-- Searches Tree for the smallest node equal to or greater than Key
function Floor function Floor
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_Type) return Node_Access; Key : Key_Type) return Node_Access;
-- Searches Tree for the largest node less than or equal to Key
function Upper_Bound function Upper_Bound
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_Type) return Node_Access; Key : Key_Type) return Node_Access;
-- Searches Tree for the smallest node greater than Key
generic generic
with procedure Process (Node : Node_Access); with procedure Process (Node : Node_Access);
procedure Generic_Iteration procedure Generic_Iteration
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_Type); Key : Key_Type);
-- Calls Process for each node in Tree equivalent to Key, in order
-- from earliest in range to latest.
generic generic
with procedure Process (Node : Node_Access); with procedure Process (Node : Node_Access);
procedure Generic_Reverse_Iteration procedure Generic_Reverse_Iteration
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_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; end Ada.Containers.Red_Black_Trees.Generic_Keys;
gcc/ada/a-crbtgo.adb
...@@ -9,10 +9,6 @@ ...@@ -9,10 +9,6 @@
-- -- -- --
-- Copyright (C) 2004-2006, 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 --
-- 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 -- -- 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- -- -- 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- -- -- ware Foundation; either version 2, or (at your option) any later ver- --
...@@ -34,6 +30,13 @@ ...@@ -34,6 +30,13 @@
-- This unit was originally developed by Matthew J Heaney. -- -- 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; with System; use type System.Address;
package body Ada.Containers.Red_Black_Trees.Generic_Operations is package body Ada.Containers.Red_Black_Trees.Generic_Operations is
...@@ -141,7 +144,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -141,7 +144,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is
-- CLR p274 ??? -- CLR p274
X : Node_Access := Node; X : Node_Access := Node;
W : Node_Access; W : Node_Access;
...@@ -237,7 +240,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -237,7 +240,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Node : Node_Access) Node : Node_Access)
is is
-- CLR p273 ??? -- CLR p273
X, Y : Node_Access; X, Y : Node_Access;
...@@ -804,7 +807,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -804,7 +807,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
-- CLR p266 ??? -- CLR p266
Y : constant Node_Access := Right (X); Y : constant Node_Access := Right (X);
pragma Assert (Y /= null); pragma Assert (Y /= null);
...@@ -837,7 +840,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -837,7 +840,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
function Max (Node : Node_Access) return Node_Access is function Max (Node : Node_Access) return Node_Access is
-- CLR p248 ??? -- CLR p248
X : Node_Access := Node; X : Node_Access := Node;
Y : Node_Access; Y : Node_Access;
...@@ -860,7 +863,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -860,7 +863,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
function Min (Node : Node_Access) return Node_Access is function Min (Node : Node_Access) return Node_Access is
-- CLR p248 ??? -- CLR p248
X : Node_Access := Node; X : Node_Access := Node;
Y : Node_Access; Y : Node_Access;
...@@ -883,7 +886,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -883,7 +886,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
function Next (Node : Node_Access) return Node_Access is function Next (Node : Node_Access) return Node_Access is
begin begin
-- CLR p249 ??? -- CLR p249
if Node = null then if Node = null then
return null; return null;
...@@ -905,14 +908,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -905,14 +908,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
Y := Parent (Y); Y := Parent (Y);
end loop; end loop;
-- Why is this code commented out ???
-- if Right (X) /= Y then
-- return Y;
-- else
-- return X;
-- end if;
return Y; return Y;
end; end;
end Next; end Next;
...@@ -943,14 +938,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -943,14 +938,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
Y := Parent (Y); Y := Parent (Y);
end loop; end loop;
-- Why is this code commented out ???
-- if Left (X) /= Y then
-- return Y;
-- else
-- return X;
-- end if;
return Y; return Y;
end; end;
end Previous; end Previous;
...@@ -963,7 +950,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -963,7 +950,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Node : Node_Access) Node : Node_Access)
is is
-- CLR p.268 ??? -- CLR p.268
X : Node_Access := Node; X : Node_Access := Node;
pragma Assert (X /= null); pragma Assert (X /= null);
......
gcc/ada/a-crbtgo.ads
...@@ -7,11 +7,7 @@ ...@@ -7,11 +7,7 @@
-- -- -- --
-- S p e c -- -- 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 --
-- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -34,6 +30,9 @@ ...@@ -34,6 +30,9 @@
-- This unit was originally developed by Matthew J Heaney. -- -- 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; with Ada.Streams; use Ada.Streams;
generic generic
...@@ -53,8 +52,10 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -53,8 +52,10 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is
pragma Pure; pragma Pure;
function Min (Node : Node_Access) return Node_Access; 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; 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 -- NOTE: The Check_Invariant operation was used during early
-- development of the red-black tree. Now that the tree type -- development of the red-black tree. Now that the tree type
...@@ -64,47 +65,75 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -64,47 +65,75 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is
-- procedure Check_Invariant (Tree : Tree_Type); -- procedure Check_Invariant (Tree : Tree_Type);
function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean; 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; function Next (Node : Node_Access) return Node_Access;
-- Returns the smallest node greater than Node
function Previous (Node : Node_Access) return Node_Access; function Previous (Node : Node_Access) return Node_Access;
-- Returns the largest node less than Node
generic generic
with function Is_Equal (L, R : Node_Access) return Boolean; with function Is_Equal (L, R : Node_Access) return Boolean;
function Generic_Equal (Left, Right : Tree_Type) 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 procedure Delete_Node_Sans_Free
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Node : Node_Access); Node : Node_Access);
-- Removes Node from Tree without deallocating the node. If Tree
-- is busy then Program_Error is raised.
generic generic
with procedure Free (X : in out Node_Access); with procedure Free (X : in out Node_Access);
procedure Generic_Delete_Tree (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 generic
with function Copy_Node (Source : Node_Access) return Node_Access; with function Copy_Node (Source : Node_Access) return Node_Access;
with procedure Delete_Tree (X : in out Node_Access); with procedure Delete_Tree (X : in out Node_Access);
function Generic_Copy_Tree (Source_Root : Node_Access) return 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 generic
with function Copy_Tree (Root : Node_Access) return Node_Access; with function Copy_Tree (Root : Node_Access) return Node_Access;
procedure Generic_Adjust (Tree : in out Tree_Type); 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 generic
with procedure Delete_Tree (X : in out Node_Access); with procedure Delete_Tree (X : in out Node_Access);
procedure Generic_Clear (Tree : in out Tree_Type); 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 generic
with procedure Clear (Tree : in out Tree_Type); with procedure Clear (Tree : in out Tree_Type);
procedure Generic_Move (Target, Source : 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 generic
with procedure Process (Node : Node_Access) is <>; with procedure Process (Node : Node_Access) is <>;
procedure Generic_Iteration (Tree : Tree_Type); procedure Generic_Iteration (Tree : Tree_Type);
-- Calls Process for each node in Tree, in order from smallest-valued
-- node to largest-valued node.
generic generic
with procedure Process (Node : Node_Access) is <>; with procedure Process (Node : Node_Access) is <>;
procedure Generic_Reverse_Iteration (Tree : Tree_Type); 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 generic
with procedure Write_Node with procedure Write_Node
...@@ -113,6 +142,9 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -113,6 +142,9 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Generic_Write procedure Generic_Write
(Stream : access Root_Stream_Type'Class; (Stream : access Root_Stream_Type'Class;
Tree : Tree_Type); 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 generic
with procedure Clear (Tree : in out Tree_Type); with procedure Clear (Tree : in out Tree_Type);
...@@ -121,9 +153,14 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -121,9 +153,14 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Generic_Read procedure Generic_Read
(Stream : access Root_Stream_Type'Class; (Stream : access Root_Stream_Type'Class;
Tree : in out Tree_Type); 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 procedure Rebalance_For_Insert
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Node : Node_Access); 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; end Ada.Containers.Red_Black_Trees.Generic_Operations;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment