mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-19 03:40:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

a-crbtgo.ads: Commented each subprogram

Browse Source 
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
This commit is contained in:
Matt Heaney 2006-10-31 19:13:22 +01:00 committed by Arnaud Charlet
parent 31a3312587
commit 3837bc7f86
19 changed files with 1098 additions and 1163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

245
gcc/ada/a-cdlili.adb
View File

@ -8,10 +8,6 @@
-- --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
@ -156,7 +152,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
while Container.Length > 1 loop
@ -206,11 +203,13 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Delete");
@ -227,7 +226,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if;
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
for Index in 1 .. Count loop
@ -276,7 +276,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if;
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
for I in 1 .. Count loop
@ -313,7 +314,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if;
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
for I in 1 .. Count loop
@ -336,7 +338,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Element");
@ -361,7 +364,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
else
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Find");
@ -398,7 +402,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
function First_Element (Container : List) return Element_Type is
begin
if Container.First = null then
raise Constraint_Error;
raise Constraint_Error with "list is empty";
end if;
return Container.First.Element;
@ -451,20 +455,25 @@ package body Ada.Containers.Doubly_Linked_Lists is
(Target : in out List;
Source : in out List)
is
LI : Cursor := First (Target);
RI : Cursor := First (Source);
LI, RI : Cursor;
begin
if Target'Address = Source'Address then
return;
end if;
if Target.Busy > 0
or else Source.Busy > 0
then
raise Program_Error;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Target (list is busy)";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if;
LI := First (Target);
RI := First (Source);
while RI.Node /= null loop
pragma Assert (RI.Node.Next = null
or else not (RI.Node.Next.Element <
@ -578,7 +587,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
Sort (Front => null, Back => null);
@ -615,7 +625,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin
if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
pragma Assert (Vet (Before), "bad cursor in Insert");
@ -627,11 +638,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if;
if Container.Length > Count_Type'Last - Count then
raise Constraint_Error;
raise Constraint_Error with "new length exceeds maximum";
end if;
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
New_Node := new Node_Type'(New_Item, null, null);
@ -667,7 +679,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin
if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Before cursor designates wrong list";
end if;
pragma Assert (Vet (Before), "bad cursor in Insert");
@ -679,11 +692,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if;
if Container.Length > Count_Type'Last - Count then
raise Constraint_Error;
raise Constraint_Error with "new length exceeds maximum";
end if;
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
New_Node := new Node_Type;
@ -804,7 +818,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Last_Element (Container : List) return Element_Type is
begin
if Container.Last = null then
raise Constraint_Error;
raise Constraint_Error with "list is empty";
end if;
return Container.Last.Element;
@ -833,7 +847,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if;
if Source.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if;
Clear (Target);
@ -854,27 +869,17 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Next (Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in procedure Next");
if Position.Node = null then
return;
end if;
Position.Node := Position.Node.Next;
if Position.Node = null then
Position.Container := null;
end if;
Position := Next (Position);
end Next;
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
return No_Element;
end if;
pragma Assert (Vet (Position), "bad cursor in Next");
declare
Next_Node : constant Node_Access := Position.Node.Next;
begin
@ -905,27 +910,17 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Previous (Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in procedure Previous");
if Position.Node = null then
return;
end if;
Position.Node := Position.Node.Prev;
if Position.Node = null then
Position.Container := null;
end if;
Position := Previous (Position);
end Previous;
function Previous (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Previous");
if Position.Node = null then
return No_Element;
end if;
pragma Assert (Vet (Position), "bad cursor in Previous");
declare
Prev_Node : constant Node_Access := Position.Node.Prev;
begin
@ -947,7 +942,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
@ -980,7 +976,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
----------
procedure Read
(Stream : access Root_Stream_Type'Class;
(Stream : not null access Root_Stream_Type'Class;
Item : out List)
is
N : Count_Type'Base;
@ -1028,11 +1024,11 @@ package body Ada.Containers.Doubly_Linked_Lists is
end Read;
procedure Read
(Stream : access Root_Stream_Type'Class;
(Stream : not null access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error;
raise Program_Error with "attempt to stream list cursor";
end Read;
---------------------
@ -1046,15 +1042,17 @@ package body Ada.Containers.Doubly_Linked_Lists is
is
begin
if Position.Container = null then
raise Constraint_Error;
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
if Container.Lock > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (list is locked)";
end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
@ -1121,7 +1119,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
Container.First := J;
@ -1165,7 +1164,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
else
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
@ -1225,7 +1225,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Before cursor designates wrong container";
end if;
pragma Assert (Vet (Before), "bad cursor in Splice");
@ -1241,13 +1242,17 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Source.Last.Next = null);
if Target.Length > Count_Type'Last - Source.Length then
raise Constraint_Error;
raise Constraint_Error with "new length exceeds maximum";
end if;
if Target.Busy > 0
or else Source.Busy > 0
then
raise Program_Error;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Target (list is busy)";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if;
if Target.Length = 0 then
@ -1294,23 +1299,25 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Splice
(Container : in out List;
Before : Cursor;
Position : in out Cursor)
Position : Cursor)
is
begin
if Before.Container /= null then
if Before.Container /= Container'Unchecked_Access then
raise Program_Error;
raise Program_Error with
"Before cursor designates wrong container";
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
@ -1324,7 +1331,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Container.Length >= 2);
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
if Before.Node = null then
@ -1404,30 +1412,36 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Before cursor designates wrong container";
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Source'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Target.Length = Count_Type'Last then
raise Constraint_Error;
raise Constraint_Error with "Target is full";
end if;
if Target.Busy > 0
or else Source.Busy > 0
then
raise Program_Error;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Target (list is busy)";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if;
if Position.Node = Source.First then
@ -1504,16 +1518,20 @@ package body Ada.Containers.Doubly_Linked_Lists is
I, J : Cursor)
is
begin
if I.Node = null
or else J.Node = null
then
raise Constraint_Error;
if I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
if I.Container /= Container'Unchecked_Access
or else J.Container /= Container'Unchecked_Access
then
raise Program_Error;
if J.Node = null then
raise Constraint_Error with "J cursor has no element";
end if;
if I.Container /= Container'Unchecked_Access then
raise Program_Error with "I cursor designates wrong container";
end if;
if J.Container /= Container'Unchecked_Access then
raise Program_Error with "J cursor designates wrong container";
end if;
if I.Node = J.Node then
@ -1521,7 +1539,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if;
if Container.Lock > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (list is locked)";
end if;
pragma Assert (Vet (I), "bad I cursor in Swap");
@ -1548,16 +1567,20 @@ package body Ada.Containers.Doubly_Linked_Lists is
I, J : Cursor)
is
begin
if I.Node = null
or else J.Node = null
then
raise Constraint_Error;
if I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
if I.Container /= Container'Unrestricted_Access
or else I.Container /= J.Container
then
raise Program_Error;
if J.Node = null then
raise Constraint_Error with "J cursor has no element";
end if;
if I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor designates wrong container";
end if;
if J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor designates wrong container";
end if;
if I.Node = J.Node then
@ -1565,7 +1588,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if;
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
@ -1573,26 +1597,24 @@ package body Ada.Containers.Doubly_Linked_Lists is
declare
I_Next : constant Cursor := Next (I);
J_Copy : Cursor := J;
begin
if I_Next = J then
Splice (Container, Before => I, Position => J_Copy);
Splice (Container, Before => I, Position => J);
else
declare
J_Next : constant Cursor := Next (J);
I_Copy : Cursor := I;
begin
if J_Next = I then
Splice (Container, Before => J, Position => I_Copy);
Splice (Container, Before => J, Position => I);
else
pragma Assert (Container.Length >= 3);
Splice (Container, Before => I_Next, Position => J_Copy);
Splice (Container, Before => J_Next, Position => I_Copy);
Splice (Container, Before => I_Next, Position => J);
Splice (Container, Before => J_Next, Position => I);
end if;
end;
end if;
@ -1610,11 +1632,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
@ -1785,7 +1808,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
-----------
procedure Write
(Stream : access Root_Stream_Type'Class;
(Stream : not null access Root_Stream_Type'Class;
Item : List)
is
Node : Node_Access := Item.First;
@ -1800,11 +1823,11 @@ package body Ada.Containers.Doubly_Linked_Lists is
end Write;
procedure Write
(Stream : access Root_Stream_Type'Class;
(Stream : not null access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error;
raise Program_Error with "attempt to stream list cursor";
end Write;
end Ada.Containers.Doubly_Linked_Lists;

14
gcc/ada/a-cdlili.ads
View File

@ -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;

127
gcc/ada/a-chtgke.adb
View File

@ -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;

15
gcc/ada/a-chtgke.ads
View File

@ -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;

191
gcc/ada/a-chtgop.adb
View File

@ -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;
procedure Write (Node : Node_Access);
pragma Inline (Write);
procedure Write is new Generic_Iteration (Write);
-----------
-- Write --
-----------
procedure Write (Node : Node_Access) is
begin
Write (Stream, Node);
end 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);
if HT.Length = 0 then
return;
end if;
-- 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;
pragma Assert (X = null);
end if;
end loop;
Write (HT);
end Generic_Write;
-----------

273
gcc/ada/a-cidlli.adb
View File

@ -9,10 +9,6 @@
-- --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
@ -180,7 +176,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
while Container.Length > 1 loop
@ -230,15 +227,18 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor has no element";
end if;
if Position.Node.Element = null then
raise Program_Error;
raise Program_Error with
"Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Delete");
@ -255,7 +255,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if;
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
for Index in 1 .. Count loop
@ -304,7 +305,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if;
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
for I in 1 .. Count loop
@ -341,7 +343,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if;
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
for I in 1 .. Count loop
@ -364,11 +367,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor has no element";
end if;
if Position.Node.Element = null then
raise Program_Error;
raise Program_Error with
"Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Element");
@ -397,7 +402,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Find");
@ -434,7 +440,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function First_Element (Container : List) return Element_Type is
begin
if Container.First = null then
raise Constraint_Error;
raise Constraint_Error with "list is empty";
end if;
return Container.First.Element.all;
@ -497,18 +503,21 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
(Target : in out List;
Source : in out List)
is
LI : Cursor;
RI : Cursor;
LI, RI : Cursor;
begin
if Target'Address = Source'Address then
return;
end if;
if Target.Busy > 0
or else Source.Busy > 0
then
raise Program_Error;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Target (list is busy)";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if;
LI := First (Target);
@ -624,7 +633,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
Sort (Front => null, Back => null);
@ -661,13 +671,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin
if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
if Before.Node = null
or else Before.Node.Element = null
then
raise Program_Error;
raise Program_Error with
"Before cursor has no element";
end if;
pragma Assert (Vet (Before), "bad cursor in Insert");
@ -679,11 +691,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if;
if Container.Length > Count_Type'Last - Count then
raise Constraint_Error;
raise Constraint_Error with "new length exceeds maximum";
end if;
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
declare
@ -833,7 +846,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Last_Element (Container : List) return Element_Type is
begin
if Container.Last = null then
raise Constraint_Error;
raise Constraint_Error with "list is empty";
end if;
return Container.Last.Element.all;
@ -859,7 +872,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if;
if Source.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if;
Clear (Target);
@ -880,27 +894,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Next (Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in procedure Next");
if Position.Node = null then
return;
end if;
Position.Node := Position.Node.Next;
if Position.Node = null then
Position.Container := null;
end if;
Position := Next (Position);
end Next;
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
return No_Element;
end if;
pragma Assert (Vet (Position), "bad cursor in Next");
declare
Next_Node : constant Node_Access := Position.Node.Next;
begin
@ -931,27 +935,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Previous (Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in procedure Previous");
if Position.Node = null then
return;
end if;
Position.Node := Position.Node.Prev;
if Position.Node = null then
Position.Container := null;
end if;
Position := Previous (Position);
end Previous;
function Previous (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Previous");
if Position.Node = null then
return No_Element;
end if;
pragma Assert (Vet (Position), "bad cursor in Previous");
declare
Prev_Node : constant Node_Access := Position.Node.Prev;
begin
@ -973,11 +967,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor has no element";
end if;
if Position.Node.Element = null then
raise Program_Error;
raise Program_Error with
"Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
@ -1010,7 +1006,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
----------
procedure Read
(Stream : access Root_Stream_Type'Class;
(Stream : not null access Root_Stream_Type'Class;
Item : out List)
is
N : Count_Type'Base;
@ -1059,11 +1055,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end Read;
procedure Read
(Stream : access Root_Stream_Type'Class;
(Stream : not null access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error;
raise Program_Error with "attempt to stream list cursor";
end Read;
---------------------
@ -1077,19 +1073,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
is
begin
if Position.Container = null then
raise Constraint_Error;
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
if Position.Container.Lock > 0 then
raise Program_Error;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (list is locked)";
end if;
if Position.Node.Element = null then
raise Program_Error;
raise Program_Error with
"Position cursor has no element";
end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
@ -1162,7 +1161,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
Container.First := J;
@ -1206,11 +1206,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
else
if Node.Element = null then
raise Program_Error;
raise Program_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
@ -1269,13 +1270,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Before cursor designates wrong container";
end if;
if Before.Node = null
or else Before.Node.Element = null
then
raise Program_Error;
raise Program_Error with
"Before cursor has no element";
end if;
pragma Assert (Vet (Before), "bad cursor in Splice");
@ -1291,13 +1294,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Source.Last.Next = null);
if Target.Length > Count_Type'Last - Source.Length then
raise Constraint_Error;
raise Constraint_Error with "new length exceeds maximum";
end if;
if Target.Busy > 0
or else Source.Busy > 0
then
raise Program_Error;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Target (list is busy)";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if;
if Target.Length = 0 then
@ -1343,33 +1350,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Splice
(Container : in out List;
Before : Cursor;
Position : in out Cursor)
Position : Cursor)
is
begin
if Before.Container /= null then
if Before.Container /= Container'Unchecked_Access then
raise Program_Error;
raise Program_Error with
"Before cursor designates wrong container";
end if;
if Before.Node = null
or else Before.Node.Element = null
then
raise Program_Error;
raise Program_Error with
"Before cursor has no element";
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Node.Element = null then
raise Program_Error;
raise Program_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
@ -1383,7 +1393,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Container.Length >= 2);
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
if Before.Node = null then
@ -1463,40 +1474,48 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Before cursor designates wrong container";
end if;
if Before.Node = null
or else Before.Node.Element = null
then
raise Program_Error;
raise Program_Error with
"Before cursor has no element";
end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if;
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Node.Element = null then
raise Program_Error;
raise Program_Error with
"Position cursor has no element";
end if;
if Position.Container /= Source'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Target.Length = Count_Type'Last then
raise Constraint_Error;
raise Constraint_Error with "Target is full";
end if;
if Target.Busy > 0
or else Source.Busy > 0
then
raise Program_Error;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Target (list is busy)";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if;
if Position.Node = Source.First then
@ -1573,16 +1592,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
if I.Node = null
or else J.Node = null
then
raise Constraint_Error;
if I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
if I.Container /= Container'Unchecked_Access
or else J.Container /= Container'Unchecked_Access
then
raise Program_Error;
if J.Node = null then
raise Constraint_Error with "J cursor has no element";
end if;
if I.Container /= Container'Unchecked_Access then
raise Program_Error with "I cursor designates wrong container";
end if;
if J.Container /= Container'Unchecked_Access then
raise Program_Error with "J cursor designates wrong container";
end if;
if I.Node = J.Node then
@ -1590,7 +1613,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if;
if Container.Lock > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (list is locked)";
end if;
pragma Assert (Vet (I), "bad I cursor in Swap");
@ -1614,16 +1638,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
if I.Node = null
or else J.Node = null
then
raise Constraint_Error;
if I.Node = null then
raise Constraint_Error with "I cursor has no element";
end if;
if I.Container /= Container'Unrestricted_Access
or else I.Container /= J.Container
then
raise Program_Error;
if J.Node = null then
raise Constraint_Error with "J cursor has no element";
end if;
if I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor designates wrong container";
end if;
if J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor designates wrong container";
end if;
if I.Node = J.Node then
@ -1631,7 +1659,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if;
if Container.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if;
pragma Assert (Vet (I), "bad I cursor in Swap_Links");
@ -1639,26 +1668,24 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
declare
I_Next : constant Cursor := Next (I);
J_Copy : Cursor := J;
begin
if I_Next = J then
Splice (Container, Before => I, Position => J_Copy);
Splice (Container, Before => I, Position => J);
else
declare
J_Next : constant Cursor := Next (J);
I_Copy : Cursor := I;
begin
if J_Next = I then
Splice (Container, Before => J, Position => I_Copy);
Splice (Container, Before => J, Position => I);
else
pragma Assert (Container.Length >= 3);
Splice (Container, Before => I_Next, Position => J_Copy);
Splice (Container, Before => J_Next, Position => I_Copy);
Splice (Container, Before => I_Next, Position => J);
Splice (Container, Before => J_Next, Position => I);
end if;
end;
end if;
@ -1679,15 +1706,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Node.Element = null then
raise Program_Error;
raise Program_Error with
"Position cursor has no element";
end if;
if Position.Container /= Container'Unchecked_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong container";
end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
@ -1862,7 +1891,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
-----------
procedure Write
(Stream : access Root_Stream_Type'Class;
(Stream : not null access Root_Stream_Type'Class;
Item : List)
is
Node : Node_Access := Item.First;
@ -1871,17 +1900,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Count_Type'Base'Write (Stream, Item.Length);
while Node /= null loop
Element_Type'Output (Stream, Node.Element.all); -- X.all
Element_Type'Output (Stream, Node.Element.all);
Node := Node.Next;
end loop;
end Write;
procedure Write
(Stream : access Root_Stream_Type'Class;
(Stream : not null access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error;
raise Program_Error with "attempt to stream list cursor";
end Write;
end Ada.Containers.Indefinite_Doubly_Linked_Lists;

14
gcc/ada/a-cidlli.ads
View File

@ -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;

22
gcc/ada/a-cihama.adb
View File

@ -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;
---------

215
gcc/ada/a-cihase.adb
View File

@ -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
begin
Src_Node := HT_Ops.First (Source.HT);
while Src_Node /= null loop
Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
if Tgt_Node /= null then
HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
Free (Tgt_Node);
end if;
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);
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 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;
Iterate (HT);
begin
Iterate (Container.HT);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Iterate;
------------
@ -1141,117 +1161,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
-- 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;
Position : Cursor;

163
gcc/ada/a-ciorse.adb
View File

@ -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
Hint := Element_Keys.Ceiling (Tree, Item);
Insert_New_Item : declare
function New_Node return Node_Access;
pragma Inline (New_Node);
if Hint = null then
null;
procedure Insert_Post is
new Element_Keys.Generic_Insert_Post (New_Node);
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;
procedure Insert is
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
Node.Element := new Element_Type'(Item);
Free_Element (X);
--------------
-- 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;
Inserted : Boolean;
X : Element_Access := Node.Element;
-- Start of processing for Insert_New_Item
begin
Attempt_Insert : begin
Insert
(Tree => Tree,
Key => Item,
Node => Result,
Success => Inserted); -- TODO: change name of formal param
exception
when others =>
Inserted := False;
end Attempt_Insert;
if Inserted then
pragma Assert (Result = Node);
Free_Element (X); -- OK if fails
return;
end if;
end Insert_New_Item;
Reinsert_Old_Element : declare
function New_Node return Node_Access;
pragma Inline (New_Node);
else
pragma Assert (not (Hint.Element.all < Item));
raise Program_Error with "attempt to replace existing element";
end if;
procedure Insert_Post is
new Element_Keys.Generic_Insert_Post (New_Node);
Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
procedure Insert is
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
Local_Insert_With_Hint
(Tree => Tree,
Position => Hint,
Key => Item,
Node => Result,
Inserted => Inserted);
--------------
-- New_Node --
--------------
pragma Assert (Inserted);
pragma Assert (Result = 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
begin
Insert
(Tree => Tree,
Key => Node.Element.all,
Node => Result,
Success => Inserted); -- TODO: change name of formal param
exception
when others =>
null;
end Reinsert_Old_Element;
raise Program_Error with "attempt to replace existing element";
Free_Element (X);
end Replace_Element;
procedure Replace_Element

20
gcc/ada/a-cohama.adb
View File

@ -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;
---------

207
gcc/ada/a-cohase.adb
View File

@ -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
begin
Src_Node := HT_Ops.First (Source.HT);
while Src_Node /= null loop
Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element);
if Tgt_Node /= null then
HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
Free (Tgt_Node);
end if;
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);
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 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;
Iterate (Container.HT);
begin
Iterate (Container.HT);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Iterate;
------------
@ -1047,109 +1067,6 @@ package body Ada.Containers.Hashed_Sets 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;

14
gcc/ada/a-coinve.adb
View File

@ -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

34
gcc/ada/a-convec.adb
View File

@ -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;

145
gcc/ada/a-coorse.adb
View File

@ -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
Hint := Element_Keys.Ceiling (Tree, Item);
Insert_New_Item : declare
function New_Node return Node_Access;
pragma Inline (New_Node);
if Hint = null then
null;
procedure Insert_Post is
new Element_Keys.Generic_Insert_Post (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;
procedure Insert is
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
--------------
-- 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;
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);
else
pragma Assert (not (Hint.Element < Item));
raise Program_Error with "attempt to replace existing element";
end if;
procedure Insert_Post is
new Element_Keys.Generic_Insert_Post (New_Node);
Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
procedure Insert is
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
Local_Insert_With_Hint
(Tree => Tree,
Position => Hint,
Key => Item,
Node => Result,
Inserted => Inserted);
--------------
-- 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
begin
Insert
(Tree => Tree,
Key => Node.Element,
Node => Result,
Success => Inserted); -- TODO: change param name
exception
when others =>
null; -- Assignment must have failed
end Reinsert_Old_Element;
raise Program_Error with "attempt to replace existing element";
pragma Assert (Inserted);
pragma Assert (Result = Node);
end Replace_Element;
procedure Replace_Element

347
gcc/ada/a-crbtgk.adb
View File

@ -7,11 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -44,11 +40,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-- AKA Lower_Bound
function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is
function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is
Y : Node_Access;
X : Node_Access := Tree.Root;
X : Node_Access;
begin
X := Tree.Root;
while X /= null loop
if Is_Greater_Key_Node (Key, X) then
X := Ops.Right (X);
@ -67,9 +64,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is
Y : Node_Access;
X : Node_Access := Tree.Root;
X : Node_Access;
begin
X := Tree.Root;
while X /= null loop
if Is_Greater_Key_Node (Key, X) then
X := Ops.Right (X);
@ -96,9 +94,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is
Y : Node_Access;
X : Node_Access := Tree.Root;
X : Node_Access;
begin
X := Tree.Root;
while X /= null loop
if Is_Less_Key_Node (Key, X) then
X := Ops.Left (X);
@ -116,45 +115,55 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
--------------------------------
procedure Generic_Conditional_Insert
(Tree : in out Tree_Type;
Key : Key_Type;
Node : out Node_Access;
Success : out Boolean)
(Tree : in out Tree_Type;
Key : Key_Type;
Node : out Node_Access;
Inserted : out Boolean)
is
Y : Node_Access := null;
X : Node_Access := Tree.Root;
begin
Success := True;
Inserted := True;
while X /= null loop
Y := X;
Success := Is_Less_Key_Node (Key, X);
Inserted := Is_Less_Key_Node (Key, X);
if Success then
if Inserted then
X := Ops.Left (X);
else
X := Ops.Right (X);
end if;
end loop;
Node := Y;
-- If Inserted is True, then this means either that Tree is
-- empty, or there was a least one node (strictly) greater than
-- Key. Otherwise, it means that Key is equal to or greater than
-- every node.
if Success then
if Node = Tree.First then
Insert_Post (Tree, X, Y, Key, Node);
if Inserted then
if Y = Tree.First then
Insert_Post (Tree, Y, True, Node);
return;
end if;
Node := Ops.Previous (Node);
Node := Ops.Previous (Y);
else
Node := Y;
end if;
-- Here Node has a value that is less than or equal to Key. We
-- now have to resolve whether Key is equal to or greater than
-- Node, which determines whether the insertion succeeds.
if Is_Greater_Key_Node (Key, Node) then
Insert_Post (Tree, X, Y, Key, Node);
Success := True;
Insert_Post (Tree, Y, Inserted, Node);
Inserted := True;
return;
end if;
Success := False;
Inserted := False;
end Generic_Conditional_Insert;
------------------------------------------
@ -162,21 +171,33 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
------------------------------------------
procedure Generic_Conditional_Insert_With_Hint
(Tree : in out Tree_Type;
Position : Node_Access;
Key : Key_Type;
Node : out Node_Access;
Success : out Boolean)
(Tree : in out Tree_Type;
Position : Node_Access;
Key : Key_Type;
Node : out Node_Access;
Inserted : out Boolean)
is
begin
-- The purpose of a hint is to avoid a search from the root of
-- tree. If we have it hint it means we only need to traverse the
-- subtree rooted at the hint to find the nearest neighbor. Note
-- that finding the neighbor means merely walking the tree; this
-- is not a search and the only comparisons that occur are with
-- the hint and its neighbor.
-- If Position is null, this is intepreted to mean that Key is
-- large relative to the nodes in the tree. If the tree is empty,
-- or Key is greater than the last node in the tree, then we're
-- done; otherwise the hint was "wrong" and we must search.
if Position = null then -- largest
if Tree.Length > 0
and then Is_Greater_Key_Node (Key, Tree.Last)
if Tree.Last = null
or else Is_Greater_Key_Node (Key, Tree.Last)
then
Insert_Post (Tree, null, Tree.Last, Key, Node);
Success := True;
Insert_Post (Tree, Tree.Last, False, Node);
Inserted := True;
else
Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
end if;
return;
@ -184,64 +205,88 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
pragma Assert (Tree.Length > 0);
if Is_Less_Key_Node (Key, Position) then
if Position = Tree.First then
Insert_Post (Tree, Position, Position, Key, Node);
Success := True;
return;
end if;
-- A hint can either name the node that immediately follows Key,
-- or immediately precedes Key. We first test whether Key is is
-- less than the hint, and if so we compare Key to the node that
-- precedes the hint. If Key is both less than the hint and
-- greater than the hint's preceding neighbor, then we're done;
-- otherwise we must search.
-- Note also that a hint can either be an anterior node or a leaf
-- node. A new node is always inserted at the bottom of the tree
-- (at least prior to rebalancing), becoming the new left or
-- right child of leaf node (which prior to the insertion must
-- necessarily be null, since this is a leaf). If the hint names
-- an anterior node then its neighbor must be a leaf, and so
-- (here) we insert after the neighbor. If the hint names a leaf
-- then its neighbor must be anterior and so we insert before the
-- hint.
if Is_Less_Key_Node (Key, Position) then
declare
Before : constant Node_Access := Ops.Previous (Position);
begin
if Is_Greater_Key_Node (Key, Before) then
if Before = null then
Insert_Post (Tree, Tree.First, True, Node);
Inserted := True;
elsif Is_Greater_Key_Node (Key, Before) then
if Ops.Right (Before) = null then
Insert_Post (Tree, null, Before, Key, Node);
Insert_Post (Tree, Before, False, Node);
else
Insert_Post (Tree, Position, Position, Key, Node);
Insert_Post (Tree, Position, True, Node);
end if;
Success := True;
Inserted := True;
else
Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
end if;
end;
return;
end if;
if Is_Greater_Key_Node (Key, Position) then
if Position = Tree.Last then
Insert_Post (Tree, null, Tree.Last, Key, Node);
Success := True;
return;
end if;
-- We know that Key isn't less than the hint so we try again,
-- this time to see if it's greater than the hint. If so we
-- compare Key to the node that follows the hint. If Key is both
-- greater than the hint and less than the hint's next neighbor,
-- then we're done; otherwise we must search.
if Is_Greater_Key_Node (Key, Position) then
declare
After : constant Node_Access := Ops.Next (Position);
begin
if Is_Less_Key_Node (Key, After) then
if After = null then
Insert_Post (Tree, Tree.Last, False, Node);
Inserted := True;
elsif Is_Less_Key_Node (Key, After) then
if Ops.Right (Position) = null then
Insert_Post (Tree, null, Position, Key, Node);
Insert_Post (Tree, Position, False, Node);
else
Insert_Post (Tree, After, After, Key, Node);
Insert_Post (Tree, After, True, Node);
end if;
Success := True;
Inserted := True;
else
Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
end if;
end;
return;
end if;
-- We know that Key is neither less than the hint nor greater
-- than the hint, and that's the definition of equivalence.
-- There's nothing else we need to do, since a search would just
-- reach the same conclusion.
Node := Position;
Success := False;
Inserted := False;
end Generic_Conditional_Insert_With_Hint;
-------------------------
@ -249,10 +294,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-------------------------
procedure Generic_Insert_Post
(Tree : in out Tree_Type;
X, Y : Node_Access;
Key : Key_Type;
Z : out Node_Access)
(Tree : in out Tree_Type;
Y : Node_Access;
Before : Boolean;
Z : out Node_Access)
is
begin
if Tree.Length = Count_Type'Last then
@ -264,50 +309,32 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
"attempt to tamper with cursors (container is busy)";
end if;
if Y = null
or else X /= null
or else Is_Less_Key_Node (Key, Y)
then
pragma Assert (Y = null
or else Ops.Left (Y) = null);
Z := New_Node;
pragma Assert (Z /= null);
pragma Assert (Ops.Color (Z) = Red);
-- Delay allocation as long as we can, in order to defend
-- against exceptions propagated by relational operators.
if Y = null then
pragma Assert (Tree.Length = 0);
pragma Assert (Tree.Root = null);
pragma Assert (Tree.First = null);
pragma Assert (Tree.Last = null);
Z := New_Node;
Tree.Root := Z;
Tree.First := Z;
Tree.Last := Z;
pragma Assert (Z /= null);
pragma Assert (Ops.Color (Z) = Red);
elsif Before then
pragma Assert (Ops.Left (Y) = null);
if Y = null then
pragma Assert (Tree.Length = 0);
pragma Assert (Tree.Root = null);
pragma Assert (Tree.First = null);
pragma Assert (Tree.Last = null);
Ops.Set_Left (Y, Z);
Tree.Root := Z;
if Y = Tree.First then
Tree.First := Z;
Tree.Last := Z;
else
Ops.Set_Left (Y, Z);
if Y = Tree.First then
Tree.First := Z;
end if;
end if;
else
pragma Assert (Ops.Right (Y) = null);
-- Delay allocation as long as we can, in order to defend
-- against exceptions propagated by relational operators.
Z := New_Node;
pragma Assert (Z /= null);
pragma Assert (Ops.Color (Z) = Red);
Ops.Set_Right (Y, Z);
if Y = Tree.Last then
@ -335,8 +362,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-------------
procedure Iterate (Node : Node_Access) is
N : Node_Access := Node;
N : Node_Access;
begin
N := Node;
while N /= null loop
if Is_Less_Key_Node (Key, N) then
N := Ops.Left (N);
@ -371,8 +399,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-------------
procedure Iterate (Node : Node_Access) is
N : Node_Access := Node;
N : Node_Access;
begin
N := Node;
while N /= null loop
if Is_Less_Key_Node (Key, N) then
N := Ops.Left (N);
@ -401,21 +430,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Key : Key_Type;
Node : out Node_Access)
is
Y : Node_Access := null;
X : Node_Access := Tree.Root;
Y : Node_Access;
X : Node_Access;
Before : Boolean;
begin
Y := null;
Before := False;
X := Tree.Root;
while X /= null loop
Y := X;
Before := Is_Less_Key_Node (Key, X);
if Is_Less_Key_Node (Key, X) then
if Before then
X := Ops.Left (X);
else
X := Ops.Right (X);
end if;
end loop;
Insert_Post (Tree, X, Y, Key, Node);
Insert_Post (Tree, Y, Before, Node);
end Generic_Unconditional_Insert;
--------------------------------------------
@ -428,22 +464,34 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Key : Key_Type;
Node : out Node_Access)
is
-- TODO: verify this algorithm. It was (quickly) adapted it from the
-- same algorithm for conditional_with_hint. It may be that the test
-- Key > Hint should be something like a Key >= Hint, to handle the
-- case when Hint is The Last Item of A (Contiguous) sequence of
-- Equivalent Items. (The Key < Hint Test is probably OK. It is not
-- clear that you can use Key <= Hint, since new items are always
-- inserted last in the sequence of equivalent items.) ???
begin
-- There are fewer constraints for an unconditional insertion
-- than for a conditional insertion, since we allow duplicate
-- keys. So instead of having to check (say) whether Key is
-- (strictly) greater than the hint's previous neighbor, here we
-- allow Key to be equal to or greater than the previous node.
-- There is the issue of what to do if Key is equivalent to the
-- hint. Does the new node get inserted before or after the hint?
-- We decide that it gets inserted after the hint, reasoning that
-- this is consistent with behavior for non-hint insertion, which
-- inserts a new node after existing nodes with equivalent keys.
-- First we check whether the hint is null, which is interpreted
-- to mean that Key is large relative to existing nodes.
-- Following our rule above, if Key is equal to or greater than
-- the last node, then we insert the new node immediately after
-- last. (We don't have an operation for testing whether a key is
-- "equal to or greater than" a node, so we must say instead "not
-- less than", which is equivalent.)
if Hint = null then -- largest
if Tree.Length > 0
and then Is_Greater_Key_Node (Key, Tree.Last)
then
Insert_Post (Tree, null, Tree.Last, Key, Node);
else
if Tree.Last = null then
Insert_Post (Tree, null, False, Node);
elsif Is_Less_Key_Node (Key, Tree.Last) then
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
else
Insert_Post (Tree, Tree.Last, False, Node);
end if;
return;
@ -451,53 +499,53 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
pragma Assert (Tree.Length > 0);
if Is_Less_Key_Node (Key, Hint) then
if Hint = Tree.First then
Insert_Post (Tree, Hint, Hint, Key, Node);
return;
end if;
-- We decide here whether to insert the new node prior to the
-- hint. Key could be equivalent to the hint, so in theory we
-- could write the following test as "not greater than" (same as
-- "less than or equal to"). If Key were equivalent to the hint,
-- that would mean that the new node gets inserted before an
-- equivalent node. That wouldn't break any container invariants,
-- but our rule above says that new nodes always get inserted
-- after equivalent nodes. So here we test whether Key is both
-- less than the hint and and equal to or greater than the hint's
-- previous neighbor, and if so insert it before the hint.
if Is_Less_Key_Node (Key, Hint) then
declare
Before : constant Node_Access := Ops.Previous (Hint);
begin
if Is_Greater_Key_Node (Key, Before) then
if Ops.Right (Before) = null then
Insert_Post (Tree, null, Before, Key, Node);
else
Insert_Post (Tree, Hint, Hint, Key, Node);
end if;
else
if Before = null then
Insert_Post (Tree, Hint, True, Node);
elsif Is_Less_Key_Node (Key, Before) then
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
elsif Ops.Right (Before) = null then
Insert_Post (Tree, Before, False, Node);
else
Insert_Post (Tree, Hint, True, Node);
end if;
end;
return;
end if;
if Is_Greater_Key_Node (Key, Hint) then
if Hint = Tree.Last then
Insert_Post (Tree, null, Tree.Last, Key, Node);
return;
-- We know that Key isn't less than the hint, so it must be equal
-- or greater. So we just test whether Key is less than or equal
-- to (same as "not greater than") the hint's next neighbor, and
-- if so insert it after the hint.
declare
After : constant Node_Access := Ops.Next (Hint);
begin
if After = null then
Insert_Post (Tree, Hint, False, Node);
elsif Is_Greater_Key_Node (Key, After) then
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
elsif Ops.Right (Hint) = null then
Insert_Post (Tree, Hint, False, Node);
else
Insert_Post (Tree, After, True, Node);
end if;
declare
After : constant Node_Access := Ops.Next (Hint);
begin
if Is_Less_Key_Node (Key, After) then
if Ops.Right (Hint) = null then
Insert_Post (Tree, null, Hint, Key, Node);
else
Insert_Post (Tree, After, After, Key, Node);
end if;
else
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
end if;
end;
return;
end if;
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
end;
end Generic_Unconditional_Insert_With_Hint;
-----------------
@ -509,9 +557,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Key : Key_Type) return Node_Access
is
Y : Node_Access;
X : Node_Access := Tree.Root;
X : Node_Access;
begin
X := Tree.Root;
while X /= null loop
if Is_Less_Key_Node (Key, X) then
Y := X;

127
gcc/ada/a-crbtgk.ads
View File

@ -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;

41
gcc/ada/a-crbtgo.adb
View File

@ -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);

47
gcc/ada/a-crbtgo.ads
View File

@ -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;