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 @@
-- --
-- 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_Lists is
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_Lists is
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;
......
gcc/ada/a-chtgke.adb
......@@ -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.Generic_Keys is
Indx : constant Hash_Type := Index (HT, Key);
B : Node_Access renames HT.Buckets (Indx);
subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1;
begin
if B = null 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;
if HT.Length = Count_Type'Last then
raise Constraint_Error;
end if;
B := Node;
HT.Length := Length + 1;
end;
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.Generic_Keys is
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.Generic_Keys is
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;
gcc/ada/a-chtgke.ads
......@@ -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.Generic_Keys is
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;
gcc/ada/a-chtgop.adb
......@@ -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.Generic_Operations is
return;
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);
-- 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
Src_Node := Src_Buckets (Src_Index);
......@@ -102,7 +75,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
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.Generic_Operations is
-----------------------
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.Generic_Operations is
(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.Generic_Operations is
(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;
procedure Write (Node : Node_Access);
pragma Inline (Write);
Count_Type'Base'Write (Stream, HT.Length);
procedure Write is new Generic_Iteration (Write);
if HT.Length = 0 then
return;
end if;
-----------
-- 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;
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;
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;
-----------
......
gcc/ada/a-cidlli.ads
......@@ -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_Linked_Lists is
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_Linked_Lists is
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;
......
gcc/ada/a-cihama.adb
......@@ -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_Hashed_Maps is
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_Hashed_Maps is
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;
---------
......
gcc/ada/a-cihase.adb
......@@ -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_Hashed_Sets is
-- 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_Hashed_Sets is
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_Hashed_Sets is
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_Hashed_Sets is
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_Hashed_Sets is
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_Hashed_Sets is
"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);
else
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
end if;
end loop;
if Tgt_Node /= null then
HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
Free (Tgt_Node);
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;
function Difference (Left, Right : Set) return Set is
......@@ -757,15 +782,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
"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_Hashed_Sets is
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_Hashed_Sets is
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;
begin
Iterate (Container.HT);
exception
when others =>
B := B - 1;
raise;
end;
Iterate (HT);
B := B - 1;
end Iterate;
------------
......@@ -1142,117 +1162,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
---------------------
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)
......
gcc/ada/a-ciorse.adb
......@@ -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_Ordered_Sets is
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
......
gcc/ada/a-cohama.adb
......@@ -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 is
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;
---------
......
gcc/ada/a-cohase.adb
......@@ -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 is
-- 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 is
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 is
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 is
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 is
"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);
else
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
end if;
end loop;
if Tgt_Node /= null then
HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
Free (Tgt_Node);
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;
function Difference (Left, Right : Set) return Set is
......@@ -685,7 +708,7 @@ package body Ada.Containers.Hashed_Sets is
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 is
"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 is
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 is
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;
begin
Iterate (Container.HT);
exception
when others =>
B := B - 1;
raise;
end;
Iterate (Container.HT);
B := B - 1;
end Iterate;
------------
......@@ -1047,109 +1067,6 @@ package body Ada.Containers.Hashed_Sets is
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;
......
gcc/ada/a-coinve.adb
......@@ -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_Vectors is
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_Vectors is
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_Vectors is
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
......
gcc/ada/a-convec.adb
......@@ -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;
......
gcc/ada/a-coorse.adb
......@@ -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 is
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 is
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;
-- Start of processing for Reinsert_Old_Element
else
pragma Assert (not (Hint.Element < Item));
raise Program_Error with "attempt to replace existing element";
end if;
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;
Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
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;
procedure Replace_Element
......
gcc/ada/a-crbtgk.ads
......@@ -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.Generic_Keys is
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.Generic_Keys is
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;
gcc/ada/a-crbtgo.adb
......@@ -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_Trees.Generic_Operations is
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_Trees.Generic_Operations is
(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_Trees.Generic_Operations is
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_Trees.Generic_Operations is
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_Trees.Generic_Operations is
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_Trees.Generic_Operations is
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_Trees.Generic_Operations is
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_Trees.Generic_Operations is
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_Trees.Generic_Operations is
(Tree : in out Tree_Type;
Node : Node_Access)
is
-- CLR p.268 ???
-- CLR p.268
X : Node_Access := Node;
pragma Assert (X /= null);
......
gcc/ada/a-crbtgo.ads
......@@ -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.Generic_Operations is
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.Generic_Operations is
-- 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.Generic_Operations is
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.Generic_Operations is
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;
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