Skip to content

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

a-crbtgo.ads: Commented each subprogram 

2006-10-31  Matt Heaney  <heaney@adacore.com>

	* a-crbtgo.ads: Commented each subprogram

	* a-crbtgo.adb: Added reference to book from which algorithms were
	adapted.

        * a-crbtgk.ads, a-crbtgk.adb (Generic_Insert_Post): pass flag to
	indicate which child.
	(Generic_Conditional_Insert): changed parameter name from "Success" to
	"Inserted".
	(Generic_Unconditional_Insert_With_Hint): improved algorithm

	* a-coorse.adb (Replace_Element): changed parameter name in call to
	conditional insert operation.

	* a-convec.adb, a-coinve.adb (Insert): removed obsolete comment

	* a-cohama.adb (Iterate): manipulate busy-bit here, instead of in
	Generic_Iteration

	* a-ciorse.adb (Replace_Element): changed parameter name in call to
	conditional insert operation.

	* a-cihama.adb (Iterate): manipulate busy-bit here, instead of in
	Generic_Iteration.

	* a-cidlli.ads, a-cidlli.adb (Splice): Position param is now mode in
	instead of mode inout.

	* a-chtgop.adb (Adjust): modified comments to reflect current AI-302
	draft
	(Generic_Read): preserve existing buckets array if possible
	(Generic_Write): don't send buckets array length anymore

	* a-cdlili.ads, a-cdlili.adb (Splice): Position param is now mode in
	instead of mode inout.

	* a-cihase.adb (Difference): iterate over smaller of Tgt and Src sets
	(Iterate): manipulate busy-bit here, instead of in Generic_Iteration

	* a-cohase.adb (Difference): iterate over smaller of Tgt and Src sets
	(Iterate): manipulate busy-bit here, instead of in Generic_Iteration
	(Replace_Element): local operation is now an instantiation

	* a-chtgke.ads, a-chtgke.adb (Generic_Conditional_Insert): manually
	check current length.
	(Generic_Replace_Element): new operation

From-SVN: r118324
parent 31a33125
Showing with 1098 additions and 1163 deletions
gcc/ada/a-cdlili.adb
...@@ -8,10 +8,6 @@ ...@@ -8,10 +8,6 @@
-- -- -- --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- -- -- ware Foundation; either version 2, or (at your option) any later ver- --
...@@ -156,7 +152,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -156,7 +152,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null); pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
while Container.Length > 1 loop while Container.Length > 1 loop
...@@ -206,11 +203,13 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -206,11 +203,13 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with
"Position cursor has no element";
end if; end if;
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Delete"); pragma Assert (Vet (Position), "bad cursor in Delete");
...@@ -227,7 +226,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -227,7 +226,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if; end if;
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
for Index in 1 .. Count loop for Index in 1 .. Count loop
...@@ -276,7 +276,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -276,7 +276,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if; end if;
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
for I in 1 .. Count loop for I in 1 .. Count loop
...@@ -313,7 +314,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -313,7 +314,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if; end if;
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
for I in 1 .. Count loop for I in 1 .. Count loop
...@@ -336,7 +338,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -336,7 +338,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Element (Position : Cursor) return Element_Type is function Element (Position : Cursor) return Element_Type is
begin begin
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with
"Position cursor has no element";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Element"); pragma Assert (Vet (Position), "bad cursor in Element");
...@@ -361,7 +364,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -361,7 +364,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
else else
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Find"); pragma Assert (Vet (Position), "bad cursor in Find");
...@@ -398,7 +402,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -398,7 +402,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
function First_Element (Container : List) return Element_Type is function First_Element (Container : List) return Element_Type is
begin begin
if Container.First = null then if Container.First = null then
raise Constraint_Error; raise Constraint_Error with "list is empty";
end if; end if;
return Container.First.Element; return Container.First.Element;
...@@ -451,20 +455,25 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -451,20 +455,25 @@ package body Ada.Containers.Doubly_Linked_Lists is
(Target : in out List; (Target : in out List;
Source : in out List) Source : in out List)
is is
LI : Cursor := First (Target); LI, RI : Cursor;
RI : Cursor := First (Source);
begin begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
return; return;
end if; end if;
if Target.Busy > 0 if Target.Busy > 0 then
or else Source.Busy > 0 raise Program_Error with
then "attempt to tamper with elements of Target (list is busy)";
raise Program_Error; end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if; end if;
LI := First (Target);
RI := First (Source);
while RI.Node /= null loop while RI.Node /= null loop
pragma Assert (RI.Node.Next = null pragma Assert (RI.Node.Next = null
or else not (RI.Node.Next.Element < or else not (RI.Node.Next.Element <
...@@ -578,7 +587,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -578,7 +587,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null); pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
Sort (Front => null, Back => null); Sort (Front => null, Back => null);
...@@ -615,7 +625,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -615,7 +625,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Before.Container /= null then if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access 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; end if;
pragma Assert (Vet (Before), "bad cursor in Insert"); pragma Assert (Vet (Before), "bad cursor in Insert");
...@@ -627,11 +638,12 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -627,11 +638,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if; end if;
if Container.Length > Count_Type'Last - Count then if Container.Length > Count_Type'Last - Count then
raise Constraint_Error; raise Constraint_Error with "new length exceeds maximum";
end if; end if;
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
New_Node := new Node_Type'(New_Item, null, null); New_Node := new Node_Type'(New_Item, null, null);
...@@ -667,7 +679,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -667,7 +679,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Before.Container /= null then if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access then if Before.Container /= Container'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Before cursor designates wrong list";
end if; end if;
pragma Assert (Vet (Before), "bad cursor in Insert"); pragma Assert (Vet (Before), "bad cursor in Insert");
...@@ -679,11 +692,12 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -679,11 +692,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if; end if;
if Container.Length > Count_Type'Last - Count then if Container.Length > Count_Type'Last - Count then
raise Constraint_Error; raise Constraint_Error with "new length exceeds maximum";
end if; end if;
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
New_Node := new Node_Type; New_Node := new Node_Type;
...@@ -804,7 +818,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -804,7 +818,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Last_Element (Container : List) return Element_Type is function Last_Element (Container : List) return Element_Type is
begin begin
if Container.Last = null then if Container.Last = null then
raise Constraint_Error; raise Constraint_Error with "list is empty";
end if; end if;
return Container.Last.Element; return Container.Last.Element;
...@@ -833,7 +847,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -833,7 +847,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if; end if;
if Source.Busy > 0 then if Source.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if; end if;
Clear (Target); Clear (Target);
...@@ -854,27 +869,17 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -854,27 +869,17 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Next (Position : in out Cursor) is procedure Next (Position : in out Cursor) is
begin begin
pragma Assert (Vet (Position), "bad cursor in procedure Next"); Position := Next (Position);
if Position.Node = null then
return;
end if;
Position.Node := Position.Node.Next;
if Position.Node = null then
Position.Container := null;
end if;
end Next; end Next;
function Next (Position : Cursor) return Cursor is function Next (Position : Cursor) return Cursor is
begin begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then if Position.Node = null then
return No_Element; return No_Element;
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Next");
declare declare
Next_Node : constant Node_Access := Position.Node.Next; Next_Node : constant Node_Access := Position.Node.Next;
begin begin
...@@ -905,27 +910,17 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -905,27 +910,17 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Previous (Position : in out Cursor) is procedure Previous (Position : in out Cursor) is
begin begin
pragma Assert (Vet (Position), "bad cursor in procedure Previous"); Position := Previous (Position);
if Position.Node = null then
return;
end if;
Position.Node := Position.Node.Prev;
if Position.Node = null then
Position.Container := null;
end if;
end Previous; end Previous;
function Previous (Position : Cursor) return Cursor is function Previous (Position : Cursor) return Cursor is
begin begin
pragma Assert (Vet (Position), "bad cursor in function Previous");
if Position.Node = null then if Position.Node = null then
return No_Element; return No_Element;
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Previous");
declare declare
Prev_Node : constant Node_Access := Position.Node.Prev; Prev_Node : constant Node_Access := Position.Node.Prev;
begin begin
...@@ -947,7 +942,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -947,7 +942,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
is is
begin begin
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with
"Position cursor has no element";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Query_Element"); pragma Assert (Vet (Position), "bad cursor in Query_Element");
...@@ -980,7 +976,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -980,7 +976,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
---------- ----------
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out List) Item : out List)
is is
N : Count_Type'Base; N : Count_Type'Base;
...@@ -1028,11 +1024,11 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1028,11 +1024,11 @@ package body Ada.Containers.Doubly_Linked_Lists is
end Read; end Read;
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out Cursor) Item : out Cursor)
is is
begin begin
raise Program_Error; raise Program_Error with "attempt to stream list cursor";
end Read; end Read;
--------------------- ---------------------
...@@ -1046,15 +1042,17 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1046,15 +1042,17 @@ package body Ada.Containers.Doubly_Linked_Lists is
is is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error; raise Constraint_Error with "Position cursor has no element";
end if; end if;
if Position.Container /= Container'Unchecked_Access then if Position.Container /= Container'Unchecked_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
if Container.Lock > 0 then if Container.Lock > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with cursors (list is locked)";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element"); pragma Assert (Vet (Position), "bad cursor in Replace_Element");
...@@ -1121,7 +1119,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1121,7 +1119,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null); pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
Container.First := J; Container.First := J;
...@@ -1165,7 +1164,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1165,7 +1164,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
else else
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
...@@ -1225,7 +1225,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1225,7 +1225,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
begin begin
if Before.Container /= null then if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then if Before.Container /= Target'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Before cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Before), "bad cursor in Splice"); pragma Assert (Vet (Before), "bad cursor in Splice");
...@@ -1241,13 +1242,17 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1241,13 +1242,17 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Source.Last.Next = null); pragma Assert (Source.Last.Next = null);
if Target.Length > Count_Type'Last - Source.Length then if Target.Length > Count_Type'Last - Source.Length then
raise Constraint_Error; raise Constraint_Error with "new length exceeds maximum";
end if; end if;
if Target.Busy > 0 if Target.Busy > 0 then
or else Source.Busy > 0 raise Program_Error with
then "attempt to tamper with elements of Target (list is busy)";
raise Program_Error; end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if; end if;
if Target.Length = 0 then if Target.Length = 0 then
...@@ -1294,23 +1299,25 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1294,23 +1299,25 @@ package body Ada.Containers.Doubly_Linked_Lists is
procedure Splice procedure Splice
(Container : in out List; (Container : in out List;
Before : Cursor; Before : Cursor;
Position : in out Cursor) Position : Cursor)
is is
begin begin
if Before.Container /= null then if Before.Container /= null then
if Before.Container /= Container'Unchecked_Access then if Before.Container /= Container'Unchecked_Access then
raise Program_Error; raise Program_Error with
"Before cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice"); pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if; end if;
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with "Position cursor has no element";
end if; end if;
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice"); pragma Assert (Vet (Position), "bad Position cursor in Splice");
...@@ -1324,7 +1331,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1324,7 +1331,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
pragma Assert (Container.Length >= 2); pragma Assert (Container.Length >= 2);
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
if Before.Node = null then if Before.Node = null then
...@@ -1404,30 +1412,36 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1404,30 +1412,36 @@ package body Ada.Containers.Doubly_Linked_Lists is
if Before.Container /= null then if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then if Before.Container /= Target'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Before cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice"); pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if; end if;
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with "Position cursor has no element";
end if; end if;
if Position.Container /= Source'Unrestricted_Access then if Position.Container /= Source'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice"); pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Target.Length = Count_Type'Last then if Target.Length = Count_Type'Last then
raise Constraint_Error; raise Constraint_Error with "Target is full";
end if; end if;
if Target.Busy > 0 if Target.Busy > 0 then
or else Source.Busy > 0 raise Program_Error with
then "attempt to tamper with elements of Target (list is busy)";
raise Program_Error; end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if; end if;
if Position.Node = Source.First then if Position.Node = Source.First then
...@@ -1504,16 +1518,20 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1504,16 +1518,20 @@ package body Ada.Containers.Doubly_Linked_Lists is
I, J : Cursor) I, J : Cursor)
is is
begin begin
if I.Node = null if I.Node = null then
or else J.Node = null raise Constraint_Error with "I cursor has no element";
then
raise Constraint_Error;
end if; end if;
if I.Container /= Container'Unchecked_Access if J.Node = null then
or else J.Container /= Container'Unchecked_Access raise Constraint_Error with "J cursor has no element";
then end if;
raise Program_Error;
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; end if;
if I.Node = J.Node then if I.Node = J.Node then
...@@ -1521,7 +1539,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1521,7 +1539,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if; end if;
if Container.Lock > 0 then if Container.Lock > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with cursors (list is locked)";
end if; end if;
pragma Assert (Vet (I), "bad I cursor in Swap"); pragma Assert (Vet (I), "bad I cursor in Swap");
...@@ -1548,16 +1567,20 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1548,16 +1567,20 @@ package body Ada.Containers.Doubly_Linked_Lists is
I, J : Cursor) I, J : Cursor)
is is
begin begin
if I.Node = null if I.Node = null then
or else J.Node = null raise Constraint_Error with "I cursor has no element";
then
raise Constraint_Error;
end if; end if;
if I.Container /= Container'Unrestricted_Access if J.Node = null then
or else I.Container /= J.Container raise Constraint_Error with "J cursor has no element";
then end if;
raise Program_Error;
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; end if;
if I.Node = J.Node then if I.Node = J.Node then
...@@ -1565,7 +1588,8 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1565,7 +1588,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if; end if;
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
pragma Assert (Vet (I), "bad I cursor in Swap_Links"); pragma Assert (Vet (I), "bad I cursor in Swap_Links");
...@@ -1573,26 +1597,24 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1573,26 +1597,24 @@ package body Ada.Containers.Doubly_Linked_Lists is
declare declare
I_Next : constant Cursor := Next (I); I_Next : constant Cursor := Next (I);
J_Copy : Cursor := J;
begin begin
if I_Next = J then if I_Next = J then
Splice (Container, Before => I, Position => J_Copy); Splice (Container, Before => I, Position => J);
else else
declare declare
J_Next : constant Cursor := Next (J); J_Next : constant Cursor := Next (J);
I_Copy : Cursor := I;
begin begin
if J_Next = I then if J_Next = I then
Splice (Container, Before => J, Position => I_Copy); Splice (Container, Before => J, Position => I);
else else
pragma Assert (Container.Length >= 3); pragma Assert (Container.Length >= 3);
Splice (Container, Before => I_Next, Position => J_Copy); Splice (Container, Before => I_Next, Position => J);
Splice (Container, Before => J_Next, Position => I_Copy); Splice (Container, Before => J_Next, Position => I);
end if; end if;
end; end;
end if; end if;
...@@ -1610,11 +1632,12 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1610,11 +1632,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
is is
begin begin
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with "Position cursor has no element";
end if; end if;
if Position.Container /= Container'Unchecked_Access then if Position.Container /= Container'Unchecked_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element"); pragma Assert (Vet (Position), "bad cursor in Update_Element");
...@@ -1785,7 +1808,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1785,7 +1808,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
----------- -----------
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : List) Item : List)
is is
Node : Node_Access := Item.First; Node : Node_Access := Item.First;
...@@ -1800,11 +1823,11 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1800,11 +1823,11 @@ package body Ada.Containers.Doubly_Linked_Lists is
end Write; end Write;
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : Cursor) Item : Cursor)
is is
begin begin
raise Program_Error; raise Program_Error with "attempt to stream list cursor";
end Write; end Write;
end Ada.Containers.Doubly_Linked_Lists; end Ada.Containers.Doubly_Linked_Lists;
gcc/ada/a-cdlili.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -46,8 +46,10 @@ package Ada.Containers.Doubly_Linked_Lists is ...@@ -46,8 +46,10 @@ package Ada.Containers.Doubly_Linked_Lists is
pragma Preelaborate; pragma Preelaborate;
type List is tagged private; type List is tagged private;
pragma Preelaborable_Initialization (List);
type Cursor is private; type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
Empty_List : constant List; Empty_List : constant List;
...@@ -147,7 +149,7 @@ package Ada.Containers.Doubly_Linked_Lists is ...@@ -147,7 +149,7 @@ package Ada.Containers.Doubly_Linked_Lists is
procedure Splice procedure Splice
(Container : in out List; (Container : in out List;
Before : Cursor; Before : Cursor;
Position : in out Cursor); Position : Cursor);
function First (Container : List) return Cursor; function First (Container : List) return Cursor;
...@@ -230,13 +232,13 @@ private ...@@ -230,13 +232,13 @@ private
use Ada.Streams; use Ada.Streams;
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out List); Item : out List);
for List'Read use Read; for List'Read use Read;
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : List); Item : List);
for List'Write use Write; for List'Write use Write;
...@@ -253,13 +255,13 @@ private ...@@ -253,13 +255,13 @@ private
end record; end record;
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out Cursor); Item : out Cursor);
for Cursor'Read use Read; for Cursor'Read use Read;
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : Cursor); Item : Cursor);
for Cursor'Write use Write; for Cursor'Write use Write;
......
gcc/ada/a-chtgke.adb
...@@ -7,11 +7,7 @@ ...@@ -7,11 +7,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -131,23 +127,21 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is ...@@ -131,23 +127,21 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
Indx : constant Hash_Type := Index (HT, Key); Indx : constant Hash_Type := Index (HT, Key);
B : Node_Access renames HT.Buckets (Indx); B : Node_Access renames HT.Buckets (Indx);
subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1;
begin begin
if B = null then if B = null then
if HT.Busy > 0 then if HT.Busy > 0 then
raise Program_Error; raise Program_Error;
end if; end if;
declare if HT.Length = Count_Type'Last then
Length : constant Length_Subtype := HT.Length; raise Constraint_Error;
begin end if;
Node := New_Node (Next => null);
Inserted := True;
B := Node; Node := New_Node (Next => null);
HT.Length := Length + 1; Inserted := True;
end;
B := Node;
HT.Length := HT.Length + 1;
return; return;
end if; end if;
...@@ -168,15 +162,15 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is ...@@ -168,15 +162,15 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
raise Program_Error; raise Program_Error;
end if; end if;
declare if HT.Length = Count_Type'Last then
Length : constant Length_Subtype := HT.Length; raise Constraint_Error;
begin end if;
Node := New_Node (Next => B);
Inserted := True;
B := Node; Node := New_Node (Next => B);
HT.Length := Length + 1; Inserted := True;
end;
B := Node;
HT.Length := HT.Length + 1;
end Generic_Conditional_Insert; end Generic_Conditional_Insert;
----------- -----------
...@@ -190,4 +184,91 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is ...@@ -190,4 +184,91 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
return Hash (Key) mod HT.Buckets'Length; return Hash (Key) mod HT.Buckets'Length;
end Index; end Index;
---------------------
-- Replace_Element --
---------------------
procedure Generic_Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
Key : Key_Type)
is
begin
pragma Assert (HT.Length > 0);
if Equivalent_Keys (Key, Node) then
pragma Assert (Hash (Key) = Hash (Node));
if HT.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is locked)";
end if;
Assign (Node, Key);
return;
end if;
declare
J : Hash_Type;
K : constant Hash_Type := Index (HT, Key);
B : Node_Access renames HT.Buckets (K);
N : Node_Access := B;
M : Node_Access;
begin
while N /= null loop
if Equivalent_Keys (Key, N) then
raise Program_Error with
"attempt to replace existing element";
end if;
N := Next (N);
end loop;
J := Hash (Node);
if J = K then
if HT.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is locked)";
end if;
Assign (Node, Key);
return;
end if;
if HT.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (container is busy)";
end if;
Assign (Node, Key);
N := HT.Buckets (J);
pragma Assert (N /= null);
if N = Node then
HT.Buckets (J) := Next (Node);
else
pragma Assert (HT.Length > 1);
loop
M := Next (N);
pragma Assert (M /= null);
if M = Node then
Set_Next (Node => N, Next => Next (Node));
exit;
end if;
N := M;
end loop;
end if;
Set_Next (Node => Node, Next => B);
B := Node;
end;
end Generic_Replace_Element;
end Ada.Containers.Hash_Tables.Generic_Keys; end Ada.Containers.Hash_Tables.Generic_Keys;
gcc/ada/a-chtgke.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -67,15 +67,22 @@ package Ada.Containers.Hash_Tables.Generic_Keys is ...@@ -67,15 +67,22 @@ package Ada.Containers.Hash_Tables.Generic_Keys is
Key : Key_Type; Key : Key_Type;
X : out Node_Access); X : out Node_Access);
function Find (HT : Hash_Table_Type; Key : Key_Type) return Node_Access; function Find (HT : Hash_Table_Type; Key : Key_Type) return Node_Access;
generic generic
with function New_Node with function New_Node (Next : Node_Access) return Node_Access;
(Next : Node_Access) return Node_Access;
procedure Generic_Conditional_Insert procedure Generic_Conditional_Insert
(HT : in out Hash_Table_Type; (HT : in out Hash_Table_Type;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access; Node : out Node_Access;
Inserted : out Boolean); Inserted : out Boolean);
generic
with function Hash (Node : Node_Access) return Hash_Type;
with procedure Assign (Node : Node_Access; Key : Key_Type);
procedure Generic_Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
Key : Key_Type);
end Ada.Containers.Hash_Tables.Generic_Keys; end Ada.Containers.Hash_Tables.Generic_Keys;
gcc/ada/a-chtgop.adb
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -30,8 +30,6 @@ ...@@ -30,8 +30,6 @@
-- This unit was originally developed by Matthew J Heaney. -- -- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This body needs commenting ???
with Ada.Containers.Prime_Numbers; with Ada.Containers.Prime_Numbers;
with Ada.Unchecked_Deallocation; with Ada.Unchecked_Deallocation;
...@@ -60,40 +58,15 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ...@@ -60,40 +58,15 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
return; return;
end if; end if;
-- Technically it isn't necessary to allocate the exact same length
-- buckets array, because our only requirement is that following
-- assignment the source and target containers compare equal (that is,
-- operator "=" returns True). We can satisfy this requirement with any
-- hash table length, but we decide here to match the length of the
-- source table. This has the benefit that when iterating, elements of
-- the target are delivered in the exact same order as for the source.
HT.Buckets := new Buckets_Type (Src_Buckets'Range); HT.Buckets := new Buckets_Type (Src_Buckets'Range);
-- TODO: allocate minimum size req'd. (See note below.)
-- NOTE: see note below about these comments.
-- Probably we have to duplicate the Size (Src), too, in order
-- to guarantee that
-- Dst := Src;
-- Dst = Src is true
-- The only quirk is that we depend on the hash value of a dst key
-- to be the same as the src key from which it was copied.
-- If we relax the requirement that the hash value must be the
-- same, then of course we can't guarantee that following
-- assignment that Dst = Src is true ???
--
-- NOTE: 17 Apr 2005
-- What I said above is no longer true. The semantics of (map) equality
-- changed, such that we use key in the left map to look up the
-- equivalent key in the right map, and then compare the elements (using
-- normal equality) of the equivalent keys. So it doesn't matter that
-- the maps have different capacities (i.e. the hash tables have
-- different lengths), since we just look up the key, irrespective of
-- its map's hash table length. All the RM says we're required to do
-- it arrange for the target map to "=" the source map following an
-- assignment (that is, following an Adjust), so it doesn't matter
-- what the capacity of the target map is. What I'll probably do is
-- allocate a new hash table that has the minimum size necessary,
-- instead of allocating a new hash table whose size exactly matches
-- that of the source. (See the assignment that immediately precedes
-- these comments.) What we really need is a special Assign operation
-- (not unlike what we have already for Vector) that allows the user to
-- choose the capacity of the target.
-- END NOTE.
for Src_Index in Src_Buckets'Range loop for Src_Index in Src_Buckets'Range loop
Src_Node := Src_Buckets (Src_Index); Src_Node := Src_Buckets (Src_Index);
...@@ -102,7 +75,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ...@@ -102,7 +75,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
declare declare
Dst_Node : constant Node_Access := Copy_Node (Src_Node); Dst_Node : constant Node_Access := Copy_Node (Src_Node);
-- See note above -- See note above
pragma Assert (Index (HT, Dst_Node) = Src_Index); pragma Assert (Index (HT, Dst_Node) = Src_Index);
...@@ -353,32 +326,20 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ...@@ -353,32 +326,20 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
----------------------- -----------------------
procedure Generic_Iteration (HT : Hash_Table_Type) is procedure Generic_Iteration (HT : Hash_Table_Type) is
Busy : Natural renames HT'Unrestricted_Access.all.Busy; Node : Node_Access;
begin begin
if HT.Length = 0 then if HT.Length = 0 then
return; return;
end if; end if;
Busy := Busy + 1; for Indx in HT.Buckets'Range loop
Node := HT.Buckets (Indx);
declare while Node /= null loop
Node : Node_Access; Process (Node);
begin Node := Next (Node);
for Indx in HT.Buckets'Range loop
Node := HT.Buckets (Indx);
while Node /= null loop
Process (Node);
Node := Next (Node);
end loop;
end loop; end loop;
exception end loop;
when others =>
Busy := Busy - 1;
raise;
end;
Busy := Busy - 1;
end Generic_Iteration; end Generic_Iteration;
------------------ ------------------
...@@ -389,71 +350,41 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ...@@ -389,71 +350,41 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
(Stream : access Root_Stream_Type'Class; (Stream : access Root_Stream_Type'Class;
HT : out Hash_Table_Type) HT : out Hash_Table_Type)
is is
X, Y : Node_Access; N : Count_Type'Base;
NN : Hash_Type;
Last, I : Hash_Type;
N, M : Count_Type'Base;
begin begin
Clear (HT); Clear (HT);
Hash_Type'Read (Stream, Last);
Count_Type'Base'Read (Stream, N); Count_Type'Base'Read (Stream, N);
pragma Assert (N >= 0);
if N < 0 then
raise Program_Error;
end if;
if N = 0 then if N = 0 then
return; return;
end if; end if;
if HT.Buckets = null if HT.Buckets = null
or else HT.Buckets'Last /= Last or else HT.Buckets'Length < N
then then
Free (HT.Buckets); Free (HT.Buckets);
HT.Buckets := new Buckets_Type (0 .. Last); NN := Prime_Numbers.To_Prime (N);
HT.Buckets := new Buckets_Type (0 .. NN - 1);
end if; end if;
-- TODO: should we rewrite this algorithm so that it doesn't for J in 1 .. N loop
-- depend on preserving the exactly length of the hash table declare
-- array? We would prefer to not have to (re)allocate a Node : constant Node_Access := New_Node (Stream);
-- buckets array (the array that HT already has might be large Indx : constant Hash_Type := Index (HT, Node);
-- enough), and to not have to stream the count of the number B : Node_Access renames HT.Buckets (Indx);
-- of nodes in each bucket. The algorithm below is vestigial, begin
-- as it was written prior to the meeting in Palma, when the Set_Next (Node => Node, Next => B);
-- semantics of equality were changed (and which obviated the B := Node;
-- need to preserve the hash table length). end;
loop
Hash_Type'Read (Stream, I);
pragma Assert (I in HT.Buckets'Range);
pragma Assert (HT.Buckets (I) = null);
Count_Type'Base'Read (Stream, M);
pragma Assert (M >= 1);
pragma Assert (M <= N);
HT.Buckets (I) := New_Node (Stream);
pragma Assert (HT.Buckets (I) /= null);
pragma Assert (Next (HT.Buckets (I)) = null);
Y := HT.Buckets (I);
HT.Length := HT.Length + 1; HT.Length := HT.Length + 1;
for J in Count_Type range 2 .. M loop
X := New_Node (Stream);
pragma Assert (X /= null);
pragma Assert (Next (X) = null);
Set_Next (Node => Y, Next => X);
Y := X;
HT.Length := HT.Length + 1;
end loop;
N := N - M;
exit when N = 0;
end loop; end loop;
end Generic_Read; end Generic_Read;
...@@ -465,47 +396,23 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ...@@ -465,47 +396,23 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
(Stream : access Root_Stream_Type'Class; (Stream : access Root_Stream_Type'Class;
HT : Hash_Table_Type) HT : Hash_Table_Type)
is is
M : Count_Type'Base; procedure Write (Node : Node_Access);
X : Node_Access; pragma Inline (Write);
begin
if HT.Buckets = null then
Hash_Type'Write (Stream, 0);
else
Hash_Type'Write (Stream, HT.Buckets'Last);
end if;
Count_Type'Base'Write (Stream, HT.Length); procedure Write is new Generic_Iteration (Write);
if HT.Length = 0 then -----------
return; -- Write --
end if; -----------
-- TODO: see note in Generic_Read??? procedure Write (Node : Node_Access) is
begin
for Indx in HT.Buckets'Range loop Write (Stream, Node);
X := HT.Buckets (Indx); end Write;
if X /= null then
M := 1;
loop
X := Next (X);
exit when X = null;
M := M + 1;
end loop;
Hash_Type'Write (Stream, Indx);
Count_Type'Base'Write (Stream, M);
X := HT.Buckets (Indx);
for J in Count_Type range 1 .. M loop
Write (Stream, X);
X := Next (X);
end loop;
pragma Assert (X = null); begin
end if; Count_Type'Base'Write (Stream, HT.Length);
end loop; Write (HT);
end Generic_Write; end Generic_Write;
----------- -----------
......
gcc/ada/a-cidlli.adb
...@@ -9,10 +9,6 @@ ...@@ -9,10 +9,6 @@
-- -- -- --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- -- -- ware Foundation; either version 2, or (at your option) any later ver- --
...@@ -180,7 +176,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -180,7 +176,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null); pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
while Container.Length > 1 loop while Container.Length > 1 loop
...@@ -230,15 +227,18 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -230,15 +227,18 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with
"Position cursor has no element";
end if; end if;
if Position.Node.Element = null then if Position.Node.Element = null then
raise Program_Error; raise Program_Error with
"Position cursor has no element";
end if; end if;
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Delete"); pragma Assert (Vet (Position), "bad cursor in Delete");
...@@ -255,7 +255,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -255,7 +255,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if; end if;
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
for Index in 1 .. Count loop for Index in 1 .. Count loop
...@@ -304,7 +305,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -304,7 +305,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if; end if;
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
for I in 1 .. Count loop for I in 1 .. Count loop
...@@ -341,7 +343,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -341,7 +343,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if; end if;
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
for I in 1 .. Count loop for I in 1 .. Count loop
...@@ -364,11 +367,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -364,11 +367,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Element (Position : Cursor) return Element_Type is function Element (Position : Cursor) return Element_Type is
begin begin
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with
"Position cursor has no element";
end if; end if;
if Position.Node.Element = null then if Position.Node.Element = null then
raise Program_Error; raise Program_Error with
"Position cursor has no element";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Element"); pragma Assert (Vet (Position), "bad cursor in Element");
...@@ -397,7 +402,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -397,7 +402,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if; end if;
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Find"); pragma Assert (Vet (Position), "bad cursor in Find");
...@@ -434,7 +440,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -434,7 +440,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function First_Element (Container : List) return Element_Type is function First_Element (Container : List) return Element_Type is
begin begin
if Container.First = null then if Container.First = null then
raise Constraint_Error; raise Constraint_Error with "list is empty";
end if; end if;
return Container.First.Element.all; return Container.First.Element.all;
...@@ -497,18 +503,21 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -497,18 +503,21 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
(Target : in out List; (Target : in out List;
Source : in out List) Source : in out List)
is is
LI : Cursor; LI, RI : Cursor;
RI : Cursor;
begin begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
return; return;
end if; end if;
if Target.Busy > 0 if Target.Busy > 0 then
or else Source.Busy > 0 raise Program_Error with
then "attempt to tamper with elements of Target (list is busy)";
raise Program_Error; end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if; end if;
LI := First (Target); LI := First (Target);
...@@ -624,7 +633,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -624,7 +633,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null); pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
Sort (Front => null, Back => null); Sort (Front => null, Back => null);
...@@ -661,13 +671,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -661,13 +671,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Before.Container /= null then if Before.Container /= null then
if Before.Container /= Container'Unrestricted_Access 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; end if;
if Before.Node = null if Before.Node = null
or else Before.Node.Element = null or else Before.Node.Element = null
then then
raise Program_Error; raise Program_Error with
"Before cursor has no element";
end if; end if;
pragma Assert (Vet (Before), "bad cursor in Insert"); pragma Assert (Vet (Before), "bad cursor in Insert");
...@@ -679,11 +691,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -679,11 +691,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if; end if;
if Container.Length > Count_Type'Last - Count then if Container.Length > Count_Type'Last - Count then
raise Constraint_Error; raise Constraint_Error with "new length exceeds maximum";
end if; end if;
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
declare declare
...@@ -833,7 +846,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -833,7 +846,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Last_Element (Container : List) return Element_Type is function Last_Element (Container : List) return Element_Type is
begin begin
if Container.Last = null then if Container.Last = null then
raise Constraint_Error; raise Constraint_Error with "list is empty";
end if; end if;
return Container.Last.Element.all; return Container.Last.Element.all;
...@@ -859,7 +872,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -859,7 +872,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if; end if;
if Source.Busy > 0 then if Source.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if; end if;
Clear (Target); Clear (Target);
...@@ -880,27 +894,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -880,27 +894,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Next (Position : in out Cursor) is procedure Next (Position : in out Cursor) is
begin begin
pragma Assert (Vet (Position), "bad cursor in procedure Next"); Position := Next (Position);
if Position.Node = null then
return;
end if;
Position.Node := Position.Node.Next;
if Position.Node = null then
Position.Container := null;
end if;
end Next; end Next;
function Next (Position : Cursor) return Cursor is function Next (Position : Cursor) return Cursor is
begin begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then if Position.Node = null then
return No_Element; return No_Element;
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Next");
declare declare
Next_Node : constant Node_Access := Position.Node.Next; Next_Node : constant Node_Access := Position.Node.Next;
begin begin
...@@ -931,27 +935,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -931,27 +935,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Previous (Position : in out Cursor) is procedure Previous (Position : in out Cursor) is
begin begin
pragma Assert (Vet (Position), "bad cursor in procedure Previous"); Position := Previous (Position);
if Position.Node = null then
return;
end if;
Position.Node := Position.Node.Prev;
if Position.Node = null then
Position.Container := null;
end if;
end Previous; end Previous;
function Previous (Position : Cursor) return Cursor is function Previous (Position : Cursor) return Cursor is
begin begin
pragma Assert (Vet (Position), "bad cursor in function Previous");
if Position.Node = null then if Position.Node = null then
return No_Element; return No_Element;
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Previous");
declare declare
Prev_Node : constant Node_Access := Position.Node.Prev; Prev_Node : constant Node_Access := Position.Node.Prev;
begin begin
...@@ -973,11 +967,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -973,11 +967,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
is is
begin begin
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with
"Position cursor has no element";
end if; end if;
if Position.Node.Element = null then if Position.Node.Element = null then
raise Program_Error; raise Program_Error with
"Position cursor has no element";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Query_Element"); pragma Assert (Vet (Position), "bad cursor in Query_Element");
...@@ -1010,7 +1006,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1010,7 +1006,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
---------- ----------
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out List) Item : out List)
is is
N : Count_Type'Base; N : Count_Type'Base;
...@@ -1059,11 +1055,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1059,11 +1055,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end Read; end Read;
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out Cursor) Item : out Cursor)
is is
begin begin
raise Program_Error; raise Program_Error with "attempt to stream list cursor";
end Read; end Read;
--------------------- ---------------------
...@@ -1077,19 +1073,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1077,19 +1073,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
is is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error; raise Constraint_Error with "Position cursor has no element";
end if; end if;
if Position.Container /= Container'Unchecked_Access then if Position.Container /= Container'Unchecked_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
if Position.Container.Lock > 0 then if Container.Lock > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with cursors (list is locked)";
end if; end if;
if Position.Node.Element = null then if Position.Node.Element = null then
raise Program_Error; raise Program_Error with
"Position cursor has no element";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element"); pragma Assert (Vet (Position), "bad cursor in Replace_Element");
...@@ -1162,7 +1161,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1162,7 +1161,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Container.Last.Next = null); pragma Assert (Container.Last.Next = null);
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
Container.First := J; Container.First := J;
...@@ -1206,11 +1206,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1206,11 +1206,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
else else
if Node.Element = null then if Node.Element = null then
raise Program_Error; raise Program_Error with "Position cursor has no element";
end if; end if;
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
...@@ -1269,13 +1270,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1269,13 +1270,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin begin
if Before.Container /= null then if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then if Before.Container /= Target'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Before cursor designates wrong container";
end if; end if;
if Before.Node = null if Before.Node = null
or else Before.Node.Element = null or else Before.Node.Element = null
then then
raise Program_Error; raise Program_Error with
"Before cursor has no element";
end if; end if;
pragma Assert (Vet (Before), "bad cursor in Splice"); pragma Assert (Vet (Before), "bad cursor in Splice");
...@@ -1291,13 +1294,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1291,13 +1294,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Source.Last.Next = null); pragma Assert (Source.Last.Next = null);
if Target.Length > Count_Type'Last - Source.Length then if Target.Length > Count_Type'Last - Source.Length then
raise Constraint_Error; raise Constraint_Error with "new length exceeds maximum";
end if; end if;
if Target.Busy > 0 if Target.Busy > 0 then
or else Source.Busy > 0 raise Program_Error with
then "attempt to tamper with elements of Target (list is busy)";
raise Program_Error; end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if; end if;
if Target.Length = 0 then if Target.Length = 0 then
...@@ -1343,33 +1350,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1343,33 +1350,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Splice procedure Splice
(Container : in out List; (Container : in out List;
Before : Cursor; Before : Cursor;
Position : in out Cursor) Position : Cursor)
is is
begin begin
if Before.Container /= null then if Before.Container /= null then
if Before.Container /= Container'Unchecked_Access then if Before.Container /= Container'Unchecked_Access then
raise Program_Error; raise Program_Error with
"Before cursor designates wrong container";
end if; end if;
if Before.Node = null if Before.Node = null
or else Before.Node.Element = null or else Before.Node.Element = null
then then
raise Program_Error; raise Program_Error with
"Before cursor has no element";
end if; end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice"); pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if; end if;
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with "Position cursor has no element";
end if; end if;
if Position.Node.Element = null then if Position.Node.Element = null then
raise Program_Error; raise Program_Error with "Position cursor has no element";
end if; end if;
if Position.Container /= Container'Unrestricted_Access then if Position.Container /= Container'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice"); pragma Assert (Vet (Position), "bad Position cursor in Splice");
...@@ -1383,7 +1393,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1383,7 +1393,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Assert (Container.Length >= 2); pragma Assert (Container.Length >= 2);
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
if Before.Node = null then if Before.Node = null then
...@@ -1463,40 +1474,48 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1463,40 +1474,48 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
if Before.Container /= null then if Before.Container /= null then
if Before.Container /= Target'Unrestricted_Access then if Before.Container /= Target'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Before cursor designates wrong container";
end if; end if;
if Before.Node = null if Before.Node = null
or else Before.Node.Element = null or else Before.Node.Element = null
then then
raise Program_Error; raise Program_Error with
"Before cursor has no element";
end if; end if;
pragma Assert (Vet (Before), "bad Before cursor in Splice"); pragma Assert (Vet (Before), "bad Before cursor in Splice");
end if; end if;
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with "Position cursor has no element";
end if; end if;
if Position.Node.Element = null then if Position.Node.Element = null then
raise Program_Error; raise Program_Error with
"Position cursor has no element";
end if; end if;
if Position.Container /= Source'Unrestricted_Access then if Position.Container /= Source'Unrestricted_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad Position cursor in Splice"); pragma Assert (Vet (Position), "bad Position cursor in Splice");
if Target.Length = Count_Type'Last then if Target.Length = Count_Type'Last then
raise Constraint_Error; raise Constraint_Error with "Target is full";
end if; end if;
if Target.Busy > 0 if Target.Busy > 0 then
or else Source.Busy > 0 raise Program_Error with
then "attempt to tamper with elements of Target (list is busy)";
raise Program_Error; end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements of Source (list is busy)";
end if; end if;
if Position.Node = Source.First then if Position.Node = Source.First then
...@@ -1573,16 +1592,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1573,16 +1592,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
I, J : Cursor) I, J : Cursor)
is is
begin begin
if I.Node = null if I.Node = null then
or else J.Node = null raise Constraint_Error with "I cursor has no element";
then
raise Constraint_Error;
end if; end if;
if I.Container /= Container'Unchecked_Access if J.Node = null then
or else J.Container /= Container'Unchecked_Access raise Constraint_Error with "J cursor has no element";
then end if;
raise Program_Error;
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; end if;
if I.Node = J.Node then if I.Node = J.Node then
...@@ -1590,7 +1613,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1590,7 +1613,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if; end if;
if Container.Lock > 0 then if Container.Lock > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with cursors (list is locked)";
end if; end if;
pragma Assert (Vet (I), "bad I cursor in Swap"); pragma Assert (Vet (I), "bad I cursor in Swap");
...@@ -1614,16 +1638,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1614,16 +1638,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
I, J : Cursor) I, J : Cursor)
is is
begin begin
if I.Node = null if I.Node = null then
or else J.Node = null raise Constraint_Error with "I cursor has no element";
then
raise Constraint_Error;
end if; end if;
if I.Container /= Container'Unrestricted_Access if J.Node = null then
or else I.Container /= J.Container raise Constraint_Error with "J cursor has no element";
then end if;
raise Program_Error;
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; end if;
if I.Node = J.Node then if I.Node = J.Node then
...@@ -1631,7 +1659,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1631,7 +1659,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
end if; end if;
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error; raise Program_Error with
"attempt to tamper with elements (list is busy)";
end if; end if;
pragma Assert (Vet (I), "bad I cursor in Swap_Links"); pragma Assert (Vet (I), "bad I cursor in Swap_Links");
...@@ -1639,26 +1668,24 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1639,26 +1668,24 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
declare declare
I_Next : constant Cursor := Next (I); I_Next : constant Cursor := Next (I);
J_Copy : Cursor := J;
begin begin
if I_Next = J then if I_Next = J then
Splice (Container, Before => I, Position => J_Copy); Splice (Container, Before => I, Position => J);
else else
declare declare
J_Next : constant Cursor := Next (J); J_Next : constant Cursor := Next (J);
I_Copy : Cursor := I;
begin begin
if J_Next = I then if J_Next = I then
Splice (Container, Before => J, Position => I_Copy); Splice (Container, Before => J, Position => I);
else else
pragma Assert (Container.Length >= 3); pragma Assert (Container.Length >= 3);
Splice (Container, Before => I_Next, Position => J_Copy); Splice (Container, Before => I_Next, Position => J);
Splice (Container, Before => J_Next, Position => I_Copy); Splice (Container, Before => J_Next, Position => I);
end if; end if;
end; end;
end if; end if;
...@@ -1679,15 +1706,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1679,15 +1706,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
is is
begin begin
if Position.Node = null then if Position.Node = null then
raise Constraint_Error; raise Constraint_Error with "Position cursor has no element";
end if; end if;
if Position.Node.Element = null then if Position.Node.Element = null then
raise Program_Error; raise Program_Error with
"Position cursor has no element";
end if; end if;
if Position.Container /= Container'Unchecked_Access then if Position.Container /= Container'Unchecked_Access then
raise Program_Error; raise Program_Error with
"Position cursor designates wrong container";
end if; end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element"); pragma Assert (Vet (Position), "bad cursor in Update_Element");
...@@ -1862,7 +1891,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1862,7 +1891,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
----------- -----------
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : List) Item : List)
is is
Node : Node_Access := Item.First; Node : Node_Access := Item.First;
...@@ -1871,17 +1900,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -1871,17 +1900,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
Count_Type'Base'Write (Stream, Item.Length); Count_Type'Base'Write (Stream, Item.Length);
while Node /= null loop while Node /= null loop
Element_Type'Output (Stream, Node.Element.all); -- X.all Element_Type'Output (Stream, Node.Element.all);
Node := Node.Next; Node := Node.Next;
end loop; end loop;
end Write; end Write;
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : Cursor) Item : Cursor)
is is
begin begin
raise Program_Error; raise Program_Error with "attempt to stream list cursor";
end Write; end Write;
end Ada.Containers.Indefinite_Doubly_Linked_Lists; end Ada.Containers.Indefinite_Doubly_Linked_Lists;
gcc/ada/a-cidlli.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -47,8 +47,10 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -47,8 +47,10 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Preelaborate; pragma Preelaborate;
type List is tagged private; type List is tagged private;
pragma Preelaborable_Initialization (List);
type Cursor is private; type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
Empty_List : constant List; Empty_List : constant List;
...@@ -138,7 +140,7 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is ...@@ -138,7 +140,7 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Splice procedure Splice
(Container : in out List; (Container : in out List;
Before : Cursor; Before : Cursor;
Position : in out Cursor); Position : Cursor);
function First (Container : List) return Cursor; function First (Container : List) return Cursor;
...@@ -223,13 +225,13 @@ private ...@@ -223,13 +225,13 @@ private
use Ada.Streams; use Ada.Streams;
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out List); Item : out List);
for List'Read use Read; for List'Read use Read;
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : List); Item : List);
for List'Write use Write; for List'Write use Write;
...@@ -246,13 +248,13 @@ private ...@@ -246,13 +248,13 @@ private
end record; end record;
procedure Read procedure Read
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out Cursor); Item : out Cursor);
for Cursor'Read use Read; for Cursor'Read use Read;
procedure Write procedure Write
(Stream : access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : Cursor); Item : Cursor);
for Cursor'Write use Write; for Cursor'Write use Write;
......
gcc/ada/a-cihama.adb
...@@ -7,11 +7,7 @@ ...@@ -7,11 +7,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -603,7 +599,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ...@@ -603,7 +599,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
procedure Process_Node (Node : Node_Access); procedure Process_Node (Node : Node_Access);
pragma Inline (Process_Node); pragma Inline (Process_Node);
procedure Iterate is procedure Local_Iterate is
new HT_Ops.Generic_Iteration (Process_Node); new HT_Ops.Generic_Iteration (Process_Node);
------------------ ------------------
...@@ -615,10 +611,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ...@@ -615,10 +611,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Process (Cursor'(Container'Unchecked_Access, Node)); Process (Cursor'(Container'Unchecked_Access, Node));
end Process_Node; end Process_Node;
B : Natural renames Container'Unrestricted_Access.HT.Busy;
-- Start of processing Iterate -- Start of processing Iterate
begin begin
Iterate (Container.HT); B := B + 1;
begin
Local_Iterate (Container.HT);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Iterate; end Iterate;
--------- ---------
......
gcc/ada/a-cihase.adb
...@@ -9,10 +9,6 @@ ...@@ -9,10 +9,6 @@
-- -- -- --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- -- -- ware Foundation; either version 2, or (at your option) any later ver- --
...@@ -52,6 +48,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -52,6 +48,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
procedure Assign (Node : Node_Access; Item : Element_Type);
pragma Inline (Assign);
function Copy_Node (Source : Node_Access) return Node_Access; function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node); pragma Inline (Copy_Node);
...@@ -89,11 +88,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -89,11 +88,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
return Node_Access; return Node_Access;
pragma Inline (Read_Node); pragma Inline (Read_Node);
procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type);
procedure Set_Next (Node : Node_Access; Next : Node_Access); procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next); pragma Inline (Set_Next);
...@@ -138,6 +132,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -138,6 +132,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
procedure Read_Nodes is procedure Read_Nodes is
new HT_Ops.Generic_Read (Read_Node); new HT_Ops.Generic_Read (Read_Node);
procedure Replace_Element is
new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
procedure Write_Nodes is procedure Write_Nodes is
new HT_Ops.Generic_Write (Write_Node); new HT_Ops.Generic_Write (Write_Node);
...@@ -159,6 +156,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -159,6 +156,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
HT_Ops.Adjust (Container.HT); HT_Ops.Adjust (Container.HT);
end Adjust; end Adjust;
------------
-- Assign --
------------
procedure Assign (Node : Node_Access; Item : Element_Type) is
X : Element_Access := Node.Element;
begin
Node.Element := new Element_Type'(Item);
Free_Element (X);
end Assign;
-------------- --------------
-- Capacity -- -- Capacity --
-------------- --------------
...@@ -266,7 +274,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -266,7 +274,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
return; return;
end if; end if;
if Source.Length = 0 then if Source.HT.Length = 0 then
return; return;
end if; end if;
...@@ -275,24 +283,41 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -275,24 +283,41 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
"attempt to tamper with elements (set is busy)"; "attempt to tamper with elements (set is busy)";
end if; end if;
-- TODO: This can be written in terms of a loop instead as if Source.HT.Length < Target.HT.Length then
-- active-iterator style, sort of like a passive iterator. declare
Src_Node : Node_Access;
Tgt_Node := HT_Ops.First (Target.HT); begin
while Tgt_Node /= null loop Src_Node := HT_Ops.First (Source.HT);
if Is_In (Source.HT, Tgt_Node) then while Src_Node /= null loop
declare Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
X : Node_Access := Tgt_Node;
begin
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
Free (X);
end;
else if Tgt_Node /= null then
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
end if; Free (Tgt_Node);
end loop; end if;
Src_Node := HT_Ops.Next (Source.HT, Src_Node);
end loop;
end;
else
Tgt_Node := HT_Ops.First (Target.HT);
while Tgt_Node /= null loop
if Is_In (Source.HT, Tgt_Node) then
declare
X : Node_Access := Tgt_Node;
begin
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
Free (X);
end;
else
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
end if;
end loop;
end if;
end Difference; end Difference;
function Difference (Left, Right : Set) return Set is function Difference (Left, Right : Set) return Set is
...@@ -757,15 +782,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -757,15 +782,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
"attempt to tamper with elements (set is busy)"; "attempt to tamper with elements (set is busy)";
end if; end if;
-- TODO: optimize this to use an explicit
-- loop instead of an active iterator
-- (similar to how a passive iterator is
-- implemented).
--
-- Another possibility is to test which
-- set is smaller, and iterate over the
-- smaller set.
Tgt_Node := HT_Ops.First (Target.HT); Tgt_Node := HT_Ops.First (Target.HT);
while Tgt_Node /= null loop while Tgt_Node /= null loop
if Is_In (Source.HT, Tgt_Node) then if Is_In (Source.HT, Tgt_Node) then
...@@ -890,9 +906,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -890,9 +906,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
return False; return False;
end if; end if;
-- TODO: rewrite this to loop in the
-- style of a passive iterator.
Subset_Node := HT_Ops.First (Subset.HT); Subset_Node := HT_Ops.First (Subset.HT);
while Subset_Node /= null loop while Subset_Node /= null loop
if not Is_In (Of_Set.HT, Subset_Node) then if not Is_In (Of_Set.HT, Subset_Node) then
...@@ -928,15 +941,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -928,15 +941,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Process (Cursor'(Container'Unrestricted_Access, Node)); Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node; end Process_Node;
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; B : Natural renames Container'Unrestricted_Access.HT.Busy;
-- Start of processing for Iterate -- Start of processing for Iterate
begin begin
-- TODO: resolve whether HT_Ops.Generic_Iteration should B := B + 1;
-- manipulate busy bit.
begin
Iterate (Container.HT);
exception
when others =>
B := B - 1;
raise;
end;
Iterate (HT); B := B - 1;
end Iterate; end Iterate;
------------ ------------
...@@ -1142,117 +1162,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ...@@ -1142,117 +1162,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
--------------------- ---------------------
procedure Replace_Element procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type)
is
begin
if Equivalent_Elements (Node.Element.all, New_Item) then
pragma Assert (Hash (Node.Element.all) = Hash (New_Item));
if HT.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
declare
X : Element_Access := Node.Element;
begin
Node.Element := new Element_Type'(New_Item); -- OK if fails
Free_Element (X);
end;
return;
end if;
if HT.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
HT_Ops.Delete_Node_Sans_Free (HT, Node);
Insert_New_Element : declare
function New_Node (Next : Node_Access) return Node_Access;
pragma Inline (New_Node);
procedure Insert is
new Element_Keys.Generic_Conditional_Insert (New_Node);
------------------------
-- Insert_New_Element --
------------------------
function New_Node (Next : Node_Access) return Node_Access is
begin
Node.Element := new Element_Type'(New_Item); -- OK if fails
Node.Next := Next;
return Node;
end New_Node;
Result : Node_Access;
Inserted : Boolean;
X : Element_Access := Node.Element;
-- Start of processing for Insert_New_Element
begin
Attempt_Insert : begin
Insert
(HT => HT,
Key => New_Item,
Node => Result,
Inserted => Inserted);
exception
when others =>
Inserted := False; -- Assignment failed
end Attempt_Insert;
if Inserted then
Free_Element (X); -- Just propagate if fails
return;
end if;
end Insert_New_Element;
Reinsert_Old_Element :
declare
function New_Node (Next : Node_Access) return Node_Access;
pragma Inline (New_Node);
procedure Insert is
new Element_Keys.Generic_Conditional_Insert (New_Node);
--------------
-- New_Node --
--------------
function New_Node (Next : Node_Access) return Node_Access is
begin
Node.Next := Next;
return Node;
end New_Node;
Result : Node_Access;
Inserted : Boolean;
-- Start of processing for Reinsert_Old_Element
begin
Insert
(HT => HT,
Key => Node.Element.all,
Node => Result,
Inserted => Inserted);
exception
when others =>
null;
end Reinsert_Old_Element;
raise Program_Error with "attempt to replace existing element";
end Replace_Element;
procedure Replace_Element
(Container : in out Set; (Container : in out Set;
Position : Cursor; Position : Cursor;
New_Item : Element_Type) New_Item : Element_Type)
......
gcc/ada/a-ciorse.adb
...@@ -7,11 +7,7 @@ ...@@ -7,11 +7,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1463,121 +1459,100 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ...@@ -1463,121 +1459,100 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Node : Node_Access; Node : Node_Access;
Item : Element_Type) Item : Element_Type)
is is
pragma Assert (Node /= null);
pragma Assert (Node.Element /= null);
function New_Node return Node_Access;
pragma Inline (New_Node);
procedure Local_Insert_Post is
new Element_Keys.Generic_Insert_Post (New_Node);
procedure Local_Insert_Sans_Hint is
new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
procedure Local_Insert_With_Hint is
new Element_Keys.Generic_Conditional_Insert_With_Hint
(Local_Insert_Post,
Local_Insert_Sans_Hint);
--------------
-- New_Node --
--------------
function New_Node return Node_Access is
begin
Node.Element := new Element_Type'(Item); -- OK if fails
Node.Color := Red;
Node.Parent := null;
Node.Right := null;
Node.Left := null;
return Node;
end New_Node;
Hint : Node_Access;
Result : Node_Access;
Inserted : Boolean;
X : Element_Access := Node.Element;
-- Start of processing for Insert
begin begin
if Item < Node.Element.all if Item < Node.Element.all
or else Node.Element.all < Item or else Node.Element.all < Item
then then
null; null;
else else
if Tree.Lock > 0 then if Tree.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors (set is locked)"; "attempt to tamper with cursors (set is locked)";
end if; end if;
declare Node.Element := new Element_Type'(Item);
X : Element_Access := Node.Element; Free_Element (X);
begin
Node.Element := new Element_Type'(Item);
Free_Element (X);
end;
return; return;
end if; end if;
Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit Hint := Element_Keys.Ceiling (Tree, Item);
Insert_New_Item : declare
function New_Node return Node_Access;
pragma Inline (New_Node);
procedure Insert_Post is
new Element_Keys.Generic_Insert_Post (New_Node);
procedure Insert is
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
--------------
-- New_Node --
--------------
function New_Node return Node_Access is
begin
Node.Element := new Element_Type'(Item); -- OK if fails
Node.Color := Red;
Node.Parent := null;
Node.Right := null;
Node.Left := null;
return Node;
end New_Node;
Result : Node_Access; if Hint = null then
Inserted : Boolean; null;
X : Element_Access := Node.Element;
-- Start of processing for Insert_New_Item elsif Item < Hint.Element.all then
if Hint = Node then
if Tree.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
begin Node.Element := new Element_Type'(Item);
Attempt_Insert : begin Free_Element (X);
Insert
(Tree => Tree,
Key => Item,
Node => Result,
Success => Inserted); -- TODO: change name of formal param
exception
when others =>
Inserted := False;
end Attempt_Insert;
if Inserted then
pragma Assert (Result = Node);
Free_Element (X); -- OK if fails
return; return;
end if; end if;
end Insert_New_Item;
Reinsert_Old_Element : declare
function New_Node return Node_Access;
pragma Inline (New_Node);
procedure Insert_Post is
new Element_Keys.Generic_Insert_Post (New_Node);
procedure Insert is
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
--------------
-- New_Node --
--------------
function New_Node return Node_Access is
begin
Node.Color := Red;
Node.Parent := null;
Node.Right := null;
Node.Left := null;
return Node; else
end New_Node; pragma Assert (not (Hint.Element.all < Item));
raise Program_Error with "attempt to replace existing element";
end if;
Result : Node_Access; Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
Inserted : Boolean;
-- Start of processing for Reinsert_Old_Element Local_Insert_With_Hint
(Tree => Tree,
Position => Hint,
Key => Item,
Node => Result,
Inserted => Inserted);
begin pragma Assert (Inserted);
Insert pragma Assert (Result = Node);
(Tree => Tree,
Key => Node.Element.all,
Node => Result,
Success => Inserted); -- TODO: change name of formal param
exception
when others =>
null;
end Reinsert_Old_Element;
raise Program_Error with "attempt to replace existing element"; Free_Element (X);
end Replace_Element; end Replace_Element;
procedure Replace_Element procedure Replace_Element
......
gcc/ada/a-cohama.adb
...@@ -6,11 +6,7 @@ ...@@ -6,11 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -566,10 +562,22 @@ package body Ada.Containers.Hashed_Maps is ...@@ -566,10 +562,22 @@ package body Ada.Containers.Hashed_Maps is
Process (Cursor'(Container'Unchecked_Access, Node)); Process (Cursor'(Container'Unchecked_Access, Node));
end Process_Node; end Process_Node;
B : Natural renames Container'Unrestricted_Access.HT.Busy;
-- Start of processing for Iterate -- Start of processing for Iterate
begin begin
Local_Iterate (Container.HT); B := B + 1;
begin
Local_Iterate (Container.HT);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Iterate; end Iterate;
--------- ---------
......
gcc/ada/a-cohase.adb
...@@ -6,11 +6,7 @@ ...@@ -6,11 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -51,6 +47,9 @@ package body Ada.Containers.Hashed_Sets is ...@@ -51,6 +47,9 @@ package body Ada.Containers.Hashed_Sets is
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
procedure Assign (Node : Node_Access; Item : Element_Type);
pragma Inline (Assign);
function Copy_Node (Source : Node_Access) return Node_Access; function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node); pragma Inline (Copy_Node);
...@@ -90,11 +89,6 @@ package body Ada.Containers.Hashed_Sets is ...@@ -90,11 +89,6 @@ package body Ada.Containers.Hashed_Sets is
return Node_Access; return Node_Access;
pragma Inline (Read_Node); pragma Inline (Read_Node);
procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type);
procedure Set_Next (Node : Node_Access; Next : Node_Access); procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next); pragma Inline (Set_Next);
...@@ -136,6 +130,9 @@ package body Ada.Containers.Hashed_Sets is ...@@ -136,6 +130,9 @@ package body Ada.Containers.Hashed_Sets is
procedure Read_Nodes is procedure Read_Nodes is
new HT_Ops.Generic_Read (Read_Node); new HT_Ops.Generic_Read (Read_Node);
procedure Replace_Element is
new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
procedure Write_Nodes is procedure Write_Nodes is
new HT_Ops.Generic_Write (Write_Node); new HT_Ops.Generic_Write (Write_Node);
...@@ -157,6 +154,15 @@ package body Ada.Containers.Hashed_Sets is ...@@ -157,6 +154,15 @@ package body Ada.Containers.Hashed_Sets is
HT_Ops.Adjust (Container.HT); HT_Ops.Adjust (Container.HT);
end Adjust; end Adjust;
------------
-- Assign --
------------
procedure Assign (Node : Node_Access; Item : Element_Type) is
begin
Node.Element := Item;
end Assign;
-------------- --------------
-- Capacity -- -- Capacity --
-------------- --------------
...@@ -264,24 +270,41 @@ package body Ada.Containers.Hashed_Sets is ...@@ -264,24 +270,41 @@ package body Ada.Containers.Hashed_Sets is
"attempt to tamper with elements (set is busy)"; "attempt to tamper with elements (set is busy)";
end if; end if;
-- TODO: This can be written in terms of a loop instead as if Source.HT.Length < Target.HT.Length then
-- active-iterator style, sort of like a passive iterator. declare
Src_Node : Node_Access;
Tgt_Node := HT_Ops.First (Target.HT); begin
while Tgt_Node /= null loop Src_Node := HT_Ops.First (Source.HT);
if Is_In (Source.HT, Tgt_Node) then while Src_Node /= null loop
declare Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element);
X : Node_Access := Tgt_Node;
begin
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
Free (X);
end;
else if Tgt_Node /= null then
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
end if; Free (Tgt_Node);
end loop; end if;
Src_Node := HT_Ops.Next (Source.HT, Src_Node);
end loop;
end;
else
Tgt_Node := HT_Ops.First (Target.HT);
while Tgt_Node /= null loop
if Is_In (Source.HT, Tgt_Node) then
declare
X : Node_Access := Tgt_Node;
begin
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
Free (X);
end;
else
Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
end if;
end loop;
end if;
end Difference; end Difference;
function Difference (Left, Right : Set) return Set is function Difference (Left, Right : Set) return Set is
...@@ -685,7 +708,7 @@ package body Ada.Containers.Hashed_Sets is ...@@ -685,7 +708,7 @@ package body Ada.Containers.Hashed_Sets is
return; return;
end if; end if;
if Source.Length = 0 then if Source.HT.Length = 0 then
Clear (Target); Clear (Target);
return; return;
end if; end if;
...@@ -695,15 +718,6 @@ package body Ada.Containers.Hashed_Sets is ...@@ -695,15 +718,6 @@ package body Ada.Containers.Hashed_Sets is
"attempt to tamper with elements (set is busy)"; "attempt to tamper with elements (set is busy)";
end if; end if;
-- TODO: optimize this to use an explicit
-- loop instead of an active iterator
-- (similar to how a passive iterator is
-- implemented).
--
-- Another possibility is to test which
-- set is smaller, and iterate over the
-- smaller set.
Tgt_Node := HT_Ops.First (Target.HT); Tgt_Node := HT_Ops.First (Target.HT);
while Tgt_Node /= null loop while Tgt_Node /= null loop
if Is_In (Source.HT, Tgt_Node) then if Is_In (Source.HT, Tgt_Node) then
...@@ -818,9 +832,6 @@ package body Ada.Containers.Hashed_Sets is ...@@ -818,9 +832,6 @@ package body Ada.Containers.Hashed_Sets is
return False; return False;
end if; end if;
-- TODO: rewrite this to loop in the
-- style of a passive iterator.
Subset_Node := HT_Ops.First (Subset.HT); Subset_Node := HT_Ops.First (Subset.HT);
while Subset_Node /= null loop while Subset_Node /= null loop
if not Is_In (Of_Set.HT, Subset_Node) then if not Is_In (Of_Set.HT, Subset_Node) then
...@@ -855,13 +866,22 @@ package body Ada.Containers.Hashed_Sets is ...@@ -855,13 +866,22 @@ package body Ada.Containers.Hashed_Sets is
Process (Cursor'(Container'Unrestricted_Access, Node)); Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node; end Process_Node;
B : Natural renames Container'Unrestricted_Access.HT.Busy;
-- Start of processing for Iterate -- Start of processing for Iterate
begin begin
-- TODO: resolve whether HT_Ops.Generic_Iteration should B := B + 1;
-- manipulate busy bit.
begin
Iterate (Container.HT);
exception
when others =>
B := B - 1;
raise;
end;
Iterate (Container.HT); B := B - 1;
end Iterate; end Iterate;
------------ ------------
...@@ -1047,109 +1067,6 @@ package body Ada.Containers.Hashed_Sets is ...@@ -1047,109 +1067,6 @@ package body Ada.Containers.Hashed_Sets is
Node.Element := New_Item; Node.Element := New_Item;
end Replace; end Replace;
---------------------
-- Replace_Element --
---------------------
procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type)
is
begin
if Equivalent_Elements (Node.Element, New_Item) then
pragma Assert (Hash (Node.Element) = Hash (New_Item));
if HT.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
Node.Element := New_Item; -- Note that this assignment can fail
return;
end if;
if HT.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
HT_Ops.Delete_Node_Sans_Free (HT, Node);
Insert_New_Element : declare
function New_Node (Next : Node_Access) return Node_Access;
pragma Inline (New_Node);
procedure Local_Insert is
new Element_Keys.Generic_Conditional_Insert (New_Node);
--------------
-- New_Node --
--------------
function New_Node (Next : Node_Access) return Node_Access is
begin
Node.Element := New_Item; -- Note that this assignment can fail
Node.Next := Next;
return Node;
end New_Node;
Result : Node_Access;
Inserted : Boolean;
-- Start of processing for Insert_New_Element
begin
Local_Insert
(HT => HT,
Key => New_Item,
Node => Result,
Inserted => Inserted);
if Inserted then
return;
end if;
exception
when others =>
null; -- Assignment must have failed
end Insert_New_Element;
Reinsert_Old_Element : declare
function New_Node (Next : Node_Access) return Node_Access;
pragma Inline (New_Node);
procedure Local_Insert is
new Element_Keys.Generic_Conditional_Insert (New_Node);
--------------
-- New_Node --
--------------
function New_Node (Next : Node_Access) return Node_Access is
begin
Node.Next := Next;
return Node;
end New_Node;
Result : Node_Access;
Inserted : Boolean;
-- Start of processing for Reinsert_Old_Element
begin
Local_Insert
(HT => HT,
Key => Node.Element,
Node => Result,
Inserted => Inserted);
exception
when others =>
null;
end Reinsert_Old_Element;
raise Program_Error with "attempt to replace existing element";
end Replace_Element;
procedure Replace_Element procedure Replace_Element
(Container : in out Set; (Container : in out Set;
Position : Cursor; Position : Cursor;
......
gcc/ada/a-coinve.adb
...@@ -8,10 +8,6 @@ ...@@ -8,10 +8,6 @@
-- -- -- --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- -- -- ware Foundation; either version 2, or (at your option) any later ver- --
...@@ -1052,7 +1048,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1052,7 +1048,7 @@ package body Ada.Containers.Indefinite_Vectors is
Old_Last_As_Int : constant Int := Int (Container.Last); Old_Last_As_Int : constant Int := Int (Container.Last);
begin begin
if Old_Last_As_Int > Int'Last - N then -- see a-convec.adb ??? if Old_Last_As_Int > Int'Last - N then
raise Constraint_Error with "new length is out of range"; raise Constraint_Error with "new length is out of range";
end if; end if;
...@@ -1514,7 +1510,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1514,7 +1510,7 @@ package body Ada.Containers.Indefinite_Vectors is
Old_Last_As_Int : constant Int := Int (Container.Last); Old_Last_As_Int : constant Int := Int (Container.Last);
begin begin
if Old_Last_As_Int > Int'Last - N then -- see a-convec.adb ??? if Old_Last_As_Int > Int'Last - N then
raise Constraint_Error with "new length is out of range"; raise Constraint_Error with "new length is out of range";
end if; end if;
...@@ -2586,12 +2582,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2586,12 +2582,6 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
for Indx in Index_Type'First .. Container.Last loop for Indx in Index_Type'First .. Container.Last loop
-- There's another way to do this. Instead a separate
-- Boolean for each element, you could write a Boolean
-- followed by a count of how many nulls or non-nulls
-- follow in the array. ???
if E (Indx) = null then if E (Indx) = null then
Boolean'Write (Stream, False); Boolean'Write (Stream, False);
else else
......
gcc/ada/a-convec.adb
...@@ -8,10 +8,6 @@ ...@@ -8,10 +8,6 @@
-- -- -- --
-- Copyright (C) 2004-2006 Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006 Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- -- -- ware Foundation; either version 2, or (at your option) any later ver- --
...@@ -799,34 +795,6 @@ package body Ada.Containers.Vectors is ...@@ -799,34 +795,6 @@ package body Ada.Containers.Vectors is
begin begin
if Old_Last_As_Int > Int'Last - N then if Old_Last_As_Int > Int'Last - N then
-- ???
-- The purpose of this test is to ensure that the calculation of
-- New_Last_As_Int (see below) doesn't overflow.
-- This isn't quite right, since the only requirements are:
-- V.Last <= Index_Type'Last
-- V.Length <= Count_Type'Last
-- To be strictly correct there's no (explicit) requirement that
-- Old_Last + N <= Int'Last
-- However, there might indeed be an implied requirement, since
-- machine constraints dictate that
-- Index_Type'Last <= Int'Last
-- and so this check is perhaps proper after all.
-- This shouldn't be an issue in practice, since it can only
-- happen when N is very large, or V.Last is near Int'Last.
-- N isn't likely to be large, since there's probably not enough
-- storage.
-- V.Last would only be large if IT'First is very large (and
-- V.Length has some "normal" size). But typically IT'First is
-- either 0 or 1.
raise Constraint_Error with "new length is out of range"; raise Constraint_Error with "new length is out of range";
end if; end if;
...@@ -1282,7 +1250,7 @@ package body Ada.Containers.Vectors is ...@@ -1282,7 +1250,7 @@ package body Ada.Containers.Vectors is
Old_Last_As_Int : constant Int := Int (Container.Last); Old_Last_As_Int : constant Int := Int (Container.Last);
begin begin
if Old_Last_As_Int > Int'Last - N then -- see Insert ??? if Old_Last_As_Int > Int'Last - N then
raise Constraint_Error with "new length is out of range"; raise Constraint_Error with "new length is out of range";
end if; end if;
......
gcc/ada/a-coorse.adb
...@@ -6,11 +6,7 @@ ...@@ -6,11 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1375,11 +1371,49 @@ package body Ada.Containers.Ordered_Sets is ...@@ -1375,11 +1371,49 @@ package body Ada.Containers.Ordered_Sets is
Node : Node_Access; Node : Node_Access;
Item : Element_Type) Item : Element_Type)
is is
pragma Assert (Node /= null);
function New_Node return Node_Access;
pragma Inline (New_Node);
procedure Local_Insert_Post is
new Element_Keys.Generic_Insert_Post (New_Node);
procedure Local_Insert_Sans_Hint is
new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
procedure Local_Insert_With_Hint is
new Element_Keys.Generic_Conditional_Insert_With_Hint
(Local_Insert_Post,
Local_Insert_Sans_Hint);
--------------
-- New_Node --
--------------
function New_Node return Node_Access is
begin
Node.Element := Item;
Node.Color := Red;
Node.Parent := null;
Node.Right := null;
Node.Left := null;
return Node;
end New_Node;
Hint : Node_Access;
Result : Node_Access;
Inserted : Boolean;
-- Start of processing for Insert
begin begin
if Item < Node.Element if Item < Node.Element
or else Node.Element < Item or else Node.Element < Item
then then
null; null;
else else
if Tree.Lock > 0 then if Tree.Lock > 0 then
raise Program_Error with raise Program_Error with
...@@ -1390,95 +1424,38 @@ package body Ada.Containers.Ordered_Sets is ...@@ -1390,95 +1424,38 @@ package body Ada.Containers.Ordered_Sets is
return; return;
end if; end if;
Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit Hint := Element_Keys.Ceiling (Tree, Item);
Insert_New_Item : declare
function New_Node return Node_Access;
pragma Inline (New_Node);
procedure Insert_Post is
new Element_Keys.Generic_Insert_Post (New_Node);
procedure Insert is if Hint = null then
new Element_Keys.Generic_Conditional_Insert (Insert_Post); null;
-------------- elsif Item < Hint.Element then
-- New_Node -- if Hint = Node then
-------------- if Tree.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
function New_Node return Node_Access is
begin
Node.Element := Item; Node.Element := Item;
Node.Color := Red;
Node.Parent := null;
Node.Right := null;
Node.Left := null;
return Node;
end New_Node;
Result : Node_Access;
Inserted : Boolean;
-- Start of processing for Insert_New_Item
begin
Insert
(Tree => Tree,
Key => Item,
Node => Result,
Success => Inserted); -- TODO: change param name
if Inserted then
pragma Assert (Result = Node);
return; return;
end if; end if;
exception
when others =>
null; -- Assignment must have failed
end Insert_New_Item;
Reinsert_Old_Element : declare
function New_Node return Node_Access;
pragma Inline (New_Node);
procedure Insert_Post is
new Element_Keys.Generic_Insert_Post (New_Node);
procedure Insert is
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
-------------- else
-- New_Node -- pragma Assert (not (Hint.Element < Item));
-------------- raise Program_Error with "attempt to replace existing element";
end if;
function New_Node return Node_Access is
begin
Node.Color := Red;
Node.Parent := null;
Node.Right := null;
Node.Left := null;
return Node;
end New_Node;
Result : Node_Access;
Inserted : Boolean;
-- Start of processing for Reinsert_Old_Element
begin Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
Insert
(Tree => Tree,
Key => Node.Element,
Node => Result,
Success => Inserted); -- TODO: change param name
exception
when others =>
null; -- Assignment must have failed
end Reinsert_Old_Element;
raise Program_Error with "attempt to replace existing element"; Local_Insert_With_Hint
(Tree => Tree,
Position => Hint,
Key => Item,
Node => Result,
Inserted => Inserted);
pragma Assert (Inserted);
pragma Assert (Result = Node);
end Replace_Element; end Replace_Element;
procedure Replace_Element procedure Replace_Element
......
gcc/ada/a-crbtgk.adb
...@@ -7,11 +7,7 @@ ...@@ -7,11 +7,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -44,11 +40,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -44,11 +40,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-- AKA Lower_Bound -- 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; Y : Node_Access;
X : Node_Access := Tree.Root; X : Node_Access;
begin begin
X := Tree.Root;
while X /= null loop while X /= null loop
if Is_Greater_Key_Node (Key, X) then if Is_Greater_Key_Node (Key, X) then
X := Ops.Right (X); X := Ops.Right (X);
...@@ -67,9 +64,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -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 function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is
Y : Node_Access; Y : Node_Access;
X : Node_Access := Tree.Root; X : Node_Access;
begin begin
X := Tree.Root;
while X /= null loop while X /= null loop
if Is_Greater_Key_Node (Key, X) then if Is_Greater_Key_Node (Key, X) then
X := Ops.Right (X); X := Ops.Right (X);
...@@ -96,9 +94,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -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 function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is
Y : Node_Access; Y : Node_Access;
X : Node_Access := Tree.Root; X : Node_Access;
begin begin
X := Tree.Root;
while X /= null loop while X /= null loop
if Is_Less_Key_Node (Key, X) then if Is_Less_Key_Node (Key, X) then
X := Ops.Left (X); X := Ops.Left (X);
...@@ -116,45 +115,55 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -116,45 +115,55 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
-------------------------------- --------------------------------
procedure Generic_Conditional_Insert procedure Generic_Conditional_Insert
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access; Node : out Node_Access;
Success : out Boolean) Inserted : out Boolean)
is is
Y : Node_Access := null; Y : Node_Access := null;
X : Node_Access := Tree.Root; X : Node_Access := Tree.Root;
begin begin
Success := True; Inserted := True;
while X /= null loop while X /= null loop
Y := X; 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); X := Ops.Left (X);
else else
X := Ops.Right (X); X := Ops.Right (X);
end if; end if;
end loop; 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 Inserted then
if Node = Tree.First then if Y = Tree.First then
Insert_Post (Tree, X, Y, Key, Node); Insert_Post (Tree, Y, True, Node);
return; return;
end if; end if;
Node := Ops.Previous (Node); Node := Ops.Previous (Y);
else
Node := Y;
end if; 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 if Is_Greater_Key_Node (Key, Node) then
Insert_Post (Tree, X, Y, Key, Node); Insert_Post (Tree, Y, Inserted, Node);
Success := True; Inserted := True;
return; return;
end if; end if;
Success := False; Inserted := False;
end Generic_Conditional_Insert; end Generic_Conditional_Insert;
------------------------------------------ ------------------------------------------
...@@ -162,21 +171,33 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -162,21 +171,33 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
------------------------------------------ ------------------------------------------
procedure Generic_Conditional_Insert_With_Hint procedure Generic_Conditional_Insert_With_Hint
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Position : Node_Access; Position : Node_Access;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access; Node : out Node_Access;
Success : out Boolean) Inserted : out Boolean)
is is
begin 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 Position = null then -- largest
if Tree.Length > 0 if Tree.Last = null
and then Is_Greater_Key_Node (Key, Tree.Last) or else Is_Greater_Key_Node (Key, Tree.Last)
then then
Insert_Post (Tree, null, Tree.Last, Key, Node); Insert_Post (Tree, Tree.Last, False, Node);
Success := True; Inserted := True;
else else
Conditional_Insert_Sans_Hint (Tree, Key, Node, Success); Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
end if; end if;
return; return;
...@@ -184,64 +205,88 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -184,64 +205,88 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
pragma Assert (Tree.Length > 0); pragma Assert (Tree.Length > 0);
if Is_Less_Key_Node (Key, Position) then -- A hint can either name the node that immediately follows Key,
if Position = Tree.First then -- or immediately precedes Key. We first test whether Key is is
Insert_Post (Tree, Position, Position, Key, Node); -- less than the hint, and if so we compare Key to the node that
Success := True; -- precedes the hint. If Key is both less than the hint and
return; -- greater than the hint's preceding neighbor, then we're done;
end if; -- 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 declare
Before : constant Node_Access := Ops.Previous (Position); Before : constant Node_Access := Ops.Previous (Position);
begin 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 if Ops.Right (Before) = null then
Insert_Post (Tree, null, Before, Key, Node); Insert_Post (Tree, Before, False, Node);
else else
Insert_Post (Tree, Position, Position, Key, Node); Insert_Post (Tree, Position, True, Node);
end if; end if;
Success := True; Inserted := True;
else else
Conditional_Insert_Sans_Hint (Tree, Key, Node, Success); Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
end if; end if;
end; end;
return; return;
end if; end if;
if Is_Greater_Key_Node (Key, Position) then -- We know that Key isn't less than the hint so we try again,
if Position = Tree.Last then -- this time to see if it's greater than the hint. If so we
Insert_Post (Tree, null, Tree.Last, Key, Node); -- compare Key to the node that follows the hint. If Key is both
Success := True; -- greater than the hint and less than the hint's next neighbor,
return; -- then we're done; otherwise we must search.
end if;
if Is_Greater_Key_Node (Key, Position) then
declare declare
After : constant Node_Access := Ops.Next (Position); After : constant Node_Access := Ops.Next (Position);
begin 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 if Ops.Right (Position) = null then
Insert_Post (Tree, null, Position, Key, Node); Insert_Post (Tree, Position, False, Node);
else else
Insert_Post (Tree, After, After, Key, Node); Insert_Post (Tree, After, True, Node);
end if; end if;
Success := True; Inserted := True;
else else
Conditional_Insert_Sans_Hint (Tree, Key, Node, Success); Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
end if; end if;
end; end;
return; return;
end if; 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; Node := Position;
Success := False; Inserted := False;
end Generic_Conditional_Insert_With_Hint; end Generic_Conditional_Insert_With_Hint;
------------------------- -------------------------
...@@ -249,10 +294,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -249,10 +294,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
------------------------- -------------------------
procedure Generic_Insert_Post procedure Generic_Insert_Post
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
X, Y : Node_Access; Y : Node_Access;
Key : Key_Type; Before : Boolean;
Z : out Node_Access) Z : out Node_Access)
is is
begin begin
if Tree.Length = Count_Type'Last then if Tree.Length = Count_Type'Last then
...@@ -264,50 +309,32 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -264,50 +309,32 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
"attempt to tamper with cursors (container is busy)"; "attempt to tamper with cursors (container is busy)";
end if; end if;
if Y = null Z := New_Node;
or else X /= null pragma Assert (Z /= null);
or else Is_Less_Key_Node (Key, Y) pragma Assert (Ops.Color (Z) = Red);
then
pragma Assert (Y = null
or else Ops.Left (Y) = null);
-- Delay allocation as long as we can, in order to defend if Y = null then
-- against exceptions propagated by relational operators. 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); elsif Before then
pragma Assert (Ops.Color (Z) = Red); pragma Assert (Ops.Left (Y) = null);
if Y = null then Ops.Set_Left (Y, Z);
pragma Assert (Tree.Length = 0);
pragma Assert (Tree.Root = null);
pragma Assert (Tree.First = null);
pragma Assert (Tree.Last = null);
Tree.Root := Z; if Y = Tree.First then
Tree.First := Z; Tree.First := Z;
Tree.Last := Z;
else
Ops.Set_Left (Y, Z);
if Y = Tree.First then
Tree.First := Z;
end if;
end if; end if;
else else
pragma Assert (Ops.Right (Y) = null); 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); Ops.Set_Right (Y, Z);
if Y = Tree.Last then if Y = Tree.Last then
...@@ -335,8 +362,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -335,8 +362,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
------------- -------------
procedure Iterate (Node : Node_Access) is procedure Iterate (Node : Node_Access) is
N : Node_Access := Node; N : Node_Access;
begin begin
N := Node;
while N /= null loop while N /= null loop
if Is_Less_Key_Node (Key, N) then if Is_Less_Key_Node (Key, N) then
N := Ops.Left (N); N := Ops.Left (N);
...@@ -371,8 +399,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -371,8 +399,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
------------- -------------
procedure Iterate (Node : Node_Access) is procedure Iterate (Node : Node_Access) is
N : Node_Access := Node; N : Node_Access;
begin begin
N := Node;
while N /= null loop while N /= null loop
if Is_Less_Key_Node (Key, N) then if Is_Less_Key_Node (Key, N) then
N := Ops.Left (N); N := Ops.Left (N);
...@@ -401,21 +430,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -401,21 +430,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Key : Key_Type; Key : Key_Type;
Node : out Node_Access) Node : out Node_Access)
is is
Y : Node_Access := null; Y : Node_Access;
X : Node_Access := Tree.Root; X : Node_Access;
Before : Boolean;
begin begin
Y := null;
Before := False;
X := Tree.Root;
while X /= null loop while X /= null loop
Y := X; Y := X;
Before := Is_Less_Key_Node (Key, X);
if Is_Less_Key_Node (Key, X) then if Before then
X := Ops.Left (X); X := Ops.Left (X);
else else
X := Ops.Right (X); X := Ops.Right (X);
end if; end if;
end loop; end loop;
Insert_Post (Tree, X, Y, Key, Node); Insert_Post (Tree, Y, Before, Node);
end Generic_Unconditional_Insert; end Generic_Unconditional_Insert;
-------------------------------------------- --------------------------------------------
...@@ -428,22 +464,34 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -428,22 +464,34 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Key : Key_Type; Key : Key_Type;
Node : out Node_Access) Node : out Node_Access)
is 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 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 Hint = null then -- largest
if Tree.Length > 0 if Tree.Last = null then
and then Is_Greater_Key_Node (Key, Tree.Last) Insert_Post (Tree, null, False, Node);
then elsif Is_Less_Key_Node (Key, Tree.Last) then
Insert_Post (Tree, null, Tree.Last, Key, Node);
else
Unconditional_Insert_Sans_Hint (Tree, Key, Node); Unconditional_Insert_Sans_Hint (Tree, Key, Node);
else
Insert_Post (Tree, Tree.Last, False, Node);
end if; end if;
return; return;
...@@ -451,53 +499,53 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -451,53 +499,53 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
pragma Assert (Tree.Length > 0); pragma Assert (Tree.Length > 0);
if Is_Less_Key_Node (Key, Hint) then -- We decide here whether to insert the new node prior to the
if Hint = Tree.First then -- hint. Key could be equivalent to the hint, so in theory we
Insert_Post (Tree, Hint, Hint, Key, Node); -- could write the following test as "not greater than" (same as
return; -- "less than or equal to"). If Key were equivalent to the hint,
end if; -- 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 declare
Before : constant Node_Access := Ops.Previous (Hint); Before : constant Node_Access := Ops.Previous (Hint);
begin begin
if Is_Greater_Key_Node (Key, Before) then if Before = null then
if Ops.Right (Before) = null then Insert_Post (Tree, Hint, True, Node);
Insert_Post (Tree, null, Before, Key, Node); elsif Is_Less_Key_Node (Key, Before) then
else
Insert_Post (Tree, Hint, Hint, Key, Node);
end if;
else
Unconditional_Insert_Sans_Hint (Tree, Key, Node); Unconditional_Insert_Sans_Hint (Tree, Key, Node);
end if; elsif Ops.Right (Before) = null then
end; Insert_Post (Tree, Before, False, Node);
return;
end if;
if Is_Greater_Key_Node (Key, Hint) then
if Hint = Tree.Last then
Insert_Post (Tree, null, Tree.Last, Key, Node);
return;
end if;
declare
After : constant Node_Access := Ops.Next (Hint);
begin
if Is_Less_Key_Node (Key, After) then
if Ops.Right (Hint) = null then
Insert_Post (Tree, null, Hint, Key, Node);
else
Insert_Post (Tree, After, After, Key, Node);
end if;
else else
Unconditional_Insert_Sans_Hint (Tree, Key, Node); Insert_Post (Tree, Hint, True, Node);
end if; end if;
end; end;
return; return;
end if; end if;
Unconditional_Insert_Sans_Hint (Tree, Key, Node); -- We know that Key isn't less than the hint, so it must be equal
-- or greater. So we just test whether Key is less than or equal
-- to (same as "not greater than") the hint's next neighbor, and
-- if so insert it after the hint.
declare
After : constant Node_Access := Ops.Next (Hint);
begin
if After = null then
Insert_Post (Tree, Hint, False, Node);
elsif Is_Greater_Key_Node (Key, After) then
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
elsif Ops.Right (Hint) = null then
Insert_Post (Tree, Hint, False, Node);
else
Insert_Post (Tree, After, True, Node);
end if;
end;
end Generic_Unconditional_Insert_With_Hint; end Generic_Unconditional_Insert_With_Hint;
----------------- -----------------
...@@ -509,9 +557,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -509,9 +557,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Key : Key_Type) return Node_Access Key : Key_Type) return Node_Access
is is
Y : Node_Access; Y : Node_Access;
X : Node_Access := Tree.Root; X : Node_Access;
begin begin
X := Tree.Root;
while X /= null loop while X /= null loop
if Is_Less_Key_Node (Key, X) then if Is_Less_Key_Node (Key, X) then
Y := X; Y := X;
......
gcc/ada/a-crbtgk.ads
...@@ -7,13 +7,32 @@ ...@@ -7,13 +7,32 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- This specification is adapted from the Ada Reference Manual for use with -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Tree_Type is used to implement ordered containers. This package declares
-- the tree operations that depend on keys.
with Ada.Containers.Red_Black_Trees.Generic_Operations; with Ada.Containers.Red_Black_Trees.Generic_Operations;
generic generic
...@@ -37,42 +56,58 @@ package Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -37,42 +56,58 @@ package Ada.Containers.Red_Black_Trees.Generic_Keys is
generic generic
with function New_Node return Node_Access; with function New_Node return Node_Access;
procedure Generic_Insert_Post procedure Generic_Insert_Post
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
X, Y : Node_Access; Y : Node_Access;
Key : Key_Type; Before : Boolean;
Z : out Node_Access); Z : out Node_Access);
-- Completes an insertion after the insertion position has been
-- determined. On output Z contains a pointer to the newly inserted
-- node, allocated using New_Node. If Tree is busy then
-- Program_Error is raised. If Y is null, then Tree must be empty.
-- Otherwise Y denotes the insertion position, and Before specifies
-- whether the new node is Y's left (True) or right (False) child.
generic generic
with procedure Insert_Post with procedure Insert_Post
(Tree : in out Tree_Type; (T : in out Tree_Type;
X, Y : Node_Access; Y : Node_Access;
Key : Key_Type; B : Boolean;
Z : out Node_Access); Z : out Node_Access);
procedure Generic_Conditional_Insert procedure Generic_Conditional_Insert
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access; Node : out Node_Access;
Success : out Boolean); Inserted : out Boolean);
-- Inserts a new node in Tree, but only if the tree does not already
-- contain Key. Generic_Conditional_Insert first searches for a key
-- equivalent to Key in Tree. If an equivalent key is found, then on
-- output Node designates the node with that key and Inserted is
-- False; there is no allocation and Tree is not modified. Otherwise
-- Node designates a new node allocated using Insert_Post, and
-- Inserted is True.
generic generic
with procedure Insert_Post with procedure Insert_Post
(Tree : in out Tree_Type; (T : in out Tree_Type;
X, Y : Node_Access; Y : Node_Access;
Key : Key_Type; B : Boolean;
Z : out Node_Access); Z : out Node_Access);
procedure Generic_Unconditional_Insert procedure Generic_Unconditional_Insert
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access); Node : out Node_Access);
-- Inserts a new node in Tree. On output Node designates the new
-- node, which is allocated using Insert_Post. The node is inserted
-- immediately after already-existing equivalent keys.
generic generic
with procedure Insert_Post with procedure Insert_Post
(Tree : in out Tree_Type; (T : in out Tree_Type;
X, Y : Node_Access; Y : Node_Access;
Key : Key_Type; B : Boolean;
Z : out Node_Access); Z : out Node_Access);
with procedure Unconditional_Insert_Sans_Hint with procedure Unconditional_Insert_Sans_Hint
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
...@@ -84,53 +119,77 @@ package Ada.Containers.Red_Black_Trees.Generic_Keys is ...@@ -84,53 +119,77 @@ package Ada.Containers.Red_Black_Trees.Generic_Keys is
Hint : Node_Access; Hint : Node_Access;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access); Node : out Node_Access);
-- Inserts a new node in Tree near position Hint, to avoid having to
-- search from the root for the insertion position. If Hint is null
-- then Generic_Unconditional_Insert_With_Hint attempts to insert
-- the new node after Tree.Last. If Hint is non-null then if Key is
-- less than Hint, it attempts to insert the new node immediately
-- prior to Hint. Otherwise it attempts to insert the node
-- immediately following Hint. We say "attempts" above to emphasize
-- that insertions always preserve invariants with respect to key
-- order, even when there's a hint. So if Key can't be inserted
-- immediately near Hint, then the new node is inserted in the
-- normal way, by searching for the correct position starting from
-- the root.
generic generic
with procedure Insert_Post with procedure Insert_Post
(Tree : in out Tree_Type; (T : in out Tree_Type;
X, Y : Node_Access; Y : Node_Access;
Key : Key_Type; B : Boolean;
Z : out Node_Access); Z : out Node_Access);
with procedure Conditional_Insert_Sans_Hint with procedure Conditional_Insert_Sans_Hint
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Key : Key_Type; Key : Key_Type;
Node : out Node_Access; Node : out Node_Access;
Success : out Boolean); Inserted : out Boolean);
procedure Generic_Conditional_Insert_With_Hint procedure Generic_Conditional_Insert_With_Hint
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Position : Node_Access; Position : Node_Access; -- the hint
Key : Key_Type; Key : Key_Type;
Node : out Node_Access; Node : out Node_Access;
Success : out Boolean); Inserted : out Boolean);
-- Inserts a new node in Tree if the tree does not already contain
-- Key, using Position as a hint about where to insert the new node.
-- See Generic_Unconditional_Insert_With_Hint for more details about
-- hint semantics.
function Find function Find
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_Type) return Node_Access; Key : Key_Type) return Node_Access;
-- Searches Tree for the smallest node equivalent to Key
function Ceiling function Ceiling
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_Type) return Node_Access; Key : Key_Type) return Node_Access;
-- Searches Tree for the smallest node equal to or greater than Key
function Floor function Floor
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_Type) return Node_Access; Key : Key_Type) return Node_Access;
-- Searches Tree for the largest node less than or equal to Key
function Upper_Bound function Upper_Bound
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_Type) return Node_Access; Key : Key_Type) return Node_Access;
-- Searches Tree for the smallest node greater than Key
generic generic
with procedure Process (Node : Node_Access); with procedure Process (Node : Node_Access);
procedure Generic_Iteration procedure Generic_Iteration
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_Type); Key : Key_Type);
-- Calls Process for each node in Tree equivalent to Key, in order
-- from earliest in range to latest.
generic generic
with procedure Process (Node : Node_Access); with procedure Process (Node : Node_Access);
procedure Generic_Reverse_Iteration procedure Generic_Reverse_Iteration
(Tree : Tree_Type; (Tree : Tree_Type;
Key : Key_Type); Key : Key_Type);
-- Calls Process for each node in Tree equivalent to Key, but in
-- order from largest in range to earliest.
end Ada.Containers.Red_Black_Trees.Generic_Keys; end Ada.Containers.Red_Black_Trees.Generic_Keys;
gcc/ada/a-crbtgo.adb
...@@ -9,10 +9,6 @@ ...@@ -9,10 +9,6 @@
-- -- -- --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- -- -- ware Foundation; either version 2, or (at your option) any later ver- --
...@@ -34,6 +30,13 @@ ...@@ -34,6 +30,13 @@
-- This unit was originally developed by Matthew J Heaney. -- -- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- The references below to "CLR" refer to the following book, from which
-- several of the algorithms here were adapted:
-- Introduction to Algorithms
-- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest
-- Publisher: The MIT Press (June 18, 1990)
-- ISBN: 0262031418
with System; use type System.Address; with System; use type System.Address;
package body Ada.Containers.Red_Black_Trees.Generic_Operations is package body Ada.Containers.Red_Black_Trees.Generic_Operations is
...@@ -141,7 +144,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -141,7 +144,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is
-- CLR p274 ??? -- CLR p274
X : Node_Access := Node; X : Node_Access := Node;
W : Node_Access; W : Node_Access;
...@@ -237,7 +240,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -237,7 +240,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Node : Node_Access) Node : Node_Access)
is is
-- CLR p273 ??? -- CLR p273
X, Y : Node_Access; X, Y : Node_Access;
...@@ -804,7 +807,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -804,7 +807,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
-- CLR p266 ??? -- CLR p266
Y : constant Node_Access := Right (X); Y : constant Node_Access := Right (X);
pragma Assert (Y /= null); pragma Assert (Y /= null);
...@@ -837,7 +840,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -837,7 +840,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
function Max (Node : Node_Access) return Node_Access is function Max (Node : Node_Access) return Node_Access is
-- CLR p248 ??? -- CLR p248
X : Node_Access := Node; X : Node_Access := Node;
Y : Node_Access; Y : Node_Access;
...@@ -860,7 +863,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -860,7 +863,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
function Min (Node : Node_Access) return Node_Access is function Min (Node : Node_Access) return Node_Access is
-- CLR p248 ??? -- CLR p248
X : Node_Access := Node; X : Node_Access := Node;
Y : Node_Access; Y : Node_Access;
...@@ -883,7 +886,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -883,7 +886,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
function Next (Node : Node_Access) return Node_Access is function Next (Node : Node_Access) return Node_Access is
begin begin
-- CLR p249 ??? -- CLR p249
if Node = null then if Node = null then
return null; return null;
...@@ -905,14 +908,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -905,14 +908,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
Y := Parent (Y); Y := Parent (Y);
end loop; end loop;
-- Why is this code commented out ???
-- if Right (X) /= Y then
-- return Y;
-- else
-- return X;
-- end if;
return Y; return Y;
end; end;
end Next; end Next;
...@@ -943,14 +938,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -943,14 +938,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
Y := Parent (Y); Y := Parent (Y);
end loop; end loop;
-- Why is this code commented out ???
-- if Left (X) /= Y then
-- return Y;
-- else
-- return X;
-- end if;
return Y; return Y;
end; end;
end Previous; end Previous;
...@@ -963,7 +950,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -963,7 +950,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Node : Node_Access) Node : Node_Access)
is is
-- CLR p.268 ??? -- CLR p.268
X : Node_Access := Node; X : Node_Access := Node;
pragma Assert (X /= null); pragma Assert (X /= null);
......
gcc/ada/a-crbtgo.ads
...@@ -7,11 +7,7 @@ ...@@ -7,11 +7,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -34,6 +30,9 @@ ...@@ -34,6 +30,9 @@
-- This unit was originally developed by Matthew J Heaney. -- -- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Tree_Type is used to implement the ordered containers. This package
-- declares the tree operations that do not depend on keys.
with Ada.Streams; use Ada.Streams; with Ada.Streams; use Ada.Streams;
generic generic
...@@ -53,8 +52,10 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -53,8 +52,10 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is
pragma Pure; pragma Pure;
function Min (Node : Node_Access) return Node_Access; function Min (Node : Node_Access) return Node_Access;
-- Returns the smallest-valued node of the subtree rooted at Node
function Max (Node : Node_Access) return Node_Access; function Max (Node : Node_Access) return Node_Access;
-- Returns the largest-valued node of the subtree rooted at Node
-- NOTE: The Check_Invariant operation was used during early -- NOTE: The Check_Invariant operation was used during early
-- development of the red-black tree. Now that the tree type -- development of the red-black tree. Now that the tree type
...@@ -64,47 +65,75 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -64,47 +65,75 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is
-- procedure Check_Invariant (Tree : Tree_Type); -- procedure Check_Invariant (Tree : Tree_Type);
function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean; function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean;
-- Inspects Node to determine (to the extent possible) whether
-- the node is valid; used to detect if the node is dangling.
function Next (Node : Node_Access) return Node_Access; function Next (Node : Node_Access) return Node_Access;
-- Returns the smallest node greater than Node
function Previous (Node : Node_Access) return Node_Access; function Previous (Node : Node_Access) return Node_Access;
-- Returns the largest node less than Node
generic generic
with function Is_Equal (L, R : Node_Access) return Boolean; with function Is_Equal (L, R : Node_Access) return Boolean;
function Generic_Equal (Left, Right : Tree_Type) return Boolean; function Generic_Equal (Left, Right : Tree_Type) return Boolean;
-- Uses Is_Equal to perform a node-by-node comparison of the
-- Left and Right trees; processing stops as soon as the first
-- non-equal node is found.
procedure Delete_Node_Sans_Free procedure Delete_Node_Sans_Free
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Node : Node_Access); Node : Node_Access);
-- Removes Node from Tree without deallocating the node. If Tree
-- is busy then Program_Error is raised.
generic generic
with procedure Free (X : in out Node_Access); with procedure Free (X : in out Node_Access);
procedure Generic_Delete_Tree (X : in out Node_Access); procedure Generic_Delete_Tree (X : in out Node_Access);
-- Deallocates the tree rooted at X, calling Free on each node
generic generic
with function Copy_Node (Source : Node_Access) return Node_Access; with function Copy_Node (Source : Node_Access) return Node_Access;
with procedure Delete_Tree (X : in out Node_Access); with procedure Delete_Tree (X : in out Node_Access);
function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access; function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access;
-- Copies the tree rooted at Source_Root, using Copy_Node to copy each
-- node of the source tree. If Copy_Node propagates an exception
-- (e.g. Storage_Error), then Delete_Tree is first used to deallocate
-- the target tree, and then the exception is propagated.
generic generic
with function Copy_Tree (Root : Node_Access) return Node_Access; with function Copy_Tree (Root : Node_Access) return Node_Access;
procedure Generic_Adjust (Tree : in out Tree_Type); procedure Generic_Adjust (Tree : in out Tree_Type);
-- Used to implement controlled Adjust. On input to Generic_Adjust, Tree
-- holds a bitwise (shallow) copy of the source tree (as would be the case
-- when controlled Adjust is called). On output, Tree holds its own (deep)
-- copy of the source tree, which is constructed by calling Copy_Tree.
generic generic
with procedure Delete_Tree (X : in out Node_Access); with procedure Delete_Tree (X : in out Node_Access);
procedure Generic_Clear (Tree : in out Tree_Type); procedure Generic_Clear (Tree : in out Tree_Type);
-- Clears Tree by deallocating all of its nodes. If Tree is busy then
-- Program_Error is raised.
generic generic
with procedure Clear (Tree : in out Tree_Type); with procedure Clear (Tree : in out Tree_Type);
procedure Generic_Move (Target, Source : in out Tree_Type); procedure Generic_Move (Target, Source : in out Tree_Type);
-- Moves the tree belonging to Source onto Target. If Source is busy then
-- Program_Error is raised. Otherwise Target is first cleared (by calling
-- Clear, to deallocate its existing tree), then given the Source tree, and
-- then finally Source is cleared (by setting its pointers to null).
generic generic
with procedure Process (Node : Node_Access) is <>; with procedure Process (Node : Node_Access) is <>;
procedure Generic_Iteration (Tree : Tree_Type); procedure Generic_Iteration (Tree : Tree_Type);
-- Calls Process for each node in Tree, in order from smallest-valued
-- node to largest-valued node.
generic generic
with procedure Process (Node : Node_Access) is <>; with procedure Process (Node : Node_Access) is <>;
procedure Generic_Reverse_Iteration (Tree : Tree_Type); procedure Generic_Reverse_Iteration (Tree : Tree_Type);
-- Calls Process for each node in Tree, in order from largest-valued
-- node to smallest-valued node.
generic generic
with procedure Write_Node with procedure Write_Node
...@@ -113,6 +142,9 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -113,6 +142,9 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Generic_Write procedure Generic_Write
(Stream : access Root_Stream_Type'Class; (Stream : access Root_Stream_Type'Class;
Tree : Tree_Type); Tree : Tree_Type);
-- Used to implement stream attribute T'Write. Generic_Write
-- first writes the number of nodes into Stream, then calls
-- Write_Node for each node in Tree.
generic generic
with procedure Clear (Tree : in out Tree_Type); with procedure Clear (Tree : in out Tree_Type);
...@@ -121,9 +153,14 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -121,9 +153,14 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Generic_Read procedure Generic_Read
(Stream : access Root_Stream_Type'Class; (Stream : access Root_Stream_Type'Class;
Tree : in out Tree_Type); Tree : in out Tree_Type);
-- Used to implement stream attribute T'Read. Generic_Read
-- first clears Tree. It then reads the number of nodes out of
-- Stream, and calls Read_Node for each node in Stream.
procedure Rebalance_For_Insert procedure Rebalance_For_Insert
(Tree : in out Tree_Type; (Tree : in out Tree_Type;
Node : Node_Access); Node : Node_Access);
-- This rebalances Tree to complete the insertion of Node (which
-- must already be linked in at its proper insertion position).
end Ada.Containers.Red_Black_Trees.Generic_Operations; end Ada.Containers.Red_Black_Trees.Generic_Operations;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment