OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

a-cihase.adb, [...]: Synchronized with latest draft (Draft 13, August 2005) of Ada Amendment 1. 

2005-09-01  Matthew Heaney  <heaney@adacore.com>

	* a-cihase.adb, a-coorse.ads, a-coorse.adb, a-cohama.adb,
	a-ciorse.ads, a-ciorse.adb, a-cihama.adb, a-cdlili.adb,
	a-cidlli.adb, a-chtgop.adb, a-cihase.adb, a-cihase.ads,
	a-cohase.adb, a-cohase.adb, a-cohase.ads: Synchronized with latest
	draft (Draft 13, August 2005) of Ada Amendment 1.

From-SVN: r103892
This commit is contained in:
Matthew Heaney 2005-09-05 10:05:32 +02:00 committed by Arnaud Charlet
parent c1cd0d9675
commit ba355842e8
13 changed files with 1786 additions and 1758 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

File diff suppressed because it is too large Load Diff

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

@ -42,14 +42,6 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
procedure Free is
new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);
-----------------------
-- Local Subprograms --
-----------------------
procedure Rehash
(HT : in out Hash_Table_Type;
Size : Hash_Type);
------------
-- Adjust --
------------
@ -405,27 +397,33 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
begin
Clear (HT);
declare
B : Buckets_Access := HT.Buckets;
begin
HT.Buckets := null;
HT.Length := 0;
Free (B); -- can this fail???
end;
Hash_Type'Read (Stream, Last);
-- TODO: don't immediately deallocate the buckets array we
-- already have. Instead, allocate a new buckets array only
-- if it needs to expanded because of the value of Last.
if Last /= 0 then
HT.Buckets := new Buckets_Type (0 .. Last);
end if;
Count_Type'Base'Read (Stream, N);
pragma Assert (N >= 0);
while N > 0 loop
if N = 0 then
return;
end if;
if HT.Buckets = null
or else HT.Buckets'Last /= Last
then
Free (HT.Buckets);
HT.Buckets := new Buckets_Type (0 .. Last);
end if;
-- TODO: should we rewrite this algorithm so that it doesn't
-- depend on preserving the exactly length of the hash table
-- array? We would prefer to not have to (re)allocate a
-- buckets array (the array that HT already has might be large
-- enough), and to not have to stream the count of the number
-- of nodes in each bucket. The algorithm below is vestigial,
-- as it was written prior to the meeting in Palma, when the
-- semantics of equality were changed (and which obviated the
-- need to preserve the hash table length).
loop
Hash_Type'Read (Stream, I);
pragma Assert (I in HT.Buckets'Range);
pragma Assert (HT.Buckets (I) = null);
@ -454,6 +452,8 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
end loop;
N := N - M;
exit when N = 0;
end loop;
end Generic_Read;
@ -481,6 +481,8 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
return;
end if;
-- TODO: see note in Generic_Read???
for Indx in HT.Buckets'Range loop
X := HT.Buckets (Indx);
@ -577,104 +579,6 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
return null;
end Next;
------------
-- Rehash --
------------
procedure Rehash
(HT : in out Hash_Table_Type;
Size : Hash_Type)
is
subtype Buckets_Range is Hash_Type range 0 .. Size - 1;
Dst_Buckets : Buckets_Access := new Buckets_Type (Buckets_Range);
Src_Buckets : Buckets_Access := HT.Buckets;
L : Count_Type renames HT.Length;
LL : constant Count_Type := L;
begin
if Src_Buckets = null then
pragma Assert (L = 0);
HT.Buckets := Dst_Buckets;
return;
end if;
if L = 0 then
HT.Buckets := Dst_Buckets;
Free (Src_Buckets);
return;
end if;
-- We might want to change this to iter from 1 .. L instead ???
for Src_Index in Src_Buckets'Range loop
declare
Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
begin
while Src_Bucket /= null loop
declare
Src_Node : constant Node_Access := Src_Bucket;
Dst_Index : constant Hash_Type :=
Index (Dst_Buckets.all, Src_Node);
Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
begin
Src_Bucket := Next (Src_Node);
Set_Next (Src_Node, Dst_Bucket);
Dst_Bucket := Src_Node;
end;
pragma Assert (L > 0);
L := L - 1;
end loop;
exception
when others =>
-- NOTE: see todo below.
-- Not clear that we can deallocate the nodes,
-- because they may be designated by outstanding
-- iterators. Which means they're now lost... ???
-- for J in NB'Range loop
-- declare
-- Dst : Node_Access renames NB (J);
-- X : Node_Access;
-- begin
-- while Dst /= null loop
-- X := Dst;
-- Dst := Succ (Dst);
-- Free (X);
-- end loop;
-- end;
-- end loop;
-- TODO: 17 Apr 2005
-- What I should do instead is go ahead and deallocate the
-- nodes, since when assertions are enabled, we vet the
-- cursors, and we modify the state of a node enough when
-- it is deallocated in order to detect mischief.
-- END TODO.
Free (Dst_Buckets);
raise; -- TODO: raise Program_Error instead
end;
-- exit when L = 0;
-- need to bother???
end loop;
pragma Assert (L = 0);
HT.Buckets := Dst_Buckets;
HT.Length := LL;
Free (Src_Buckets);
end Rehash;
----------------------
-- Reserve_Capacity --
----------------------
@ -686,74 +590,142 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
NN : Hash_Type;
begin
if N = 0 then
if HT.Length = 0 then
Free (HT.Buckets);
elsif HT.Length < HT.Buckets'Length then
NN := Prime_Numbers.To_Prime (HT.Length);
-- ASSERT: NN >= HT.Length
if NN < HT.Buckets'Length then
if HT.Busy > 0 then
raise Program_Error;
end if;
Rehash (HT, Size => NN);
end if;
if HT.Buckets = null then
if N > 0 then
NN := Prime_Numbers.To_Prime (N);
HT.Buckets := new Buckets_Type (0 .. NN - 1);
end if;
return;
end if;
if HT.Buckets = null then
if HT.Length = 0 then
if N = 0 then
Free (HT.Buckets);
return;
end if;
if N = HT.Buckets'Length then
return;
end if;
NN := Prime_Numbers.To_Prime (N);
-- ASSERT: NN >= N
if NN = HT.Buckets'Length then
return;
end if;
declare
X : Buckets_Access := HT.Buckets;
begin
HT.Buckets := new Buckets_Type (0 .. NN - 1);
Free (X);
end;
Rehash (HT, Size => NN);
return;
end if;
if N <= HT.Length then
if N = HT.Buckets'Length then
return;
end if;
if N < HT.Buckets'Length then
if HT.Length >= HT.Buckets'Length then
return;
end if;
NN := Prime_Numbers.To_Prime (HT.Length);
-- ASSERT: NN >= HT.Length
if NN < HT.Buckets'Length then
if HT.Busy > 0 then
raise Program_Error;
end if;
Rehash (HT, Size => NN);
if NN >= HT.Buckets'Length then
return;
end if;
return;
end if;
else
NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
-- ASSERT: N > HT.Length
if N = HT.Buckets'Length then
return;
end if;
NN := Prime_Numbers.To_Prime (N);
-- ASSERT: NN >= N
-- ASSERT: NN > HT.Length
if NN /= HT.Buckets'Length then
if HT.Busy > 0 then
raise Program_Error;
if NN = HT.Buckets'Length then -- can't expand any more
return;
end if;
Rehash (HT, Size => NN);
end if;
if HT.Busy > 0 then
raise Program_Error;
end if;
Rehash : declare
Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1);
Src_Buckets : Buckets_Access := HT.Buckets;
L : Count_Type renames HT.Length;
LL : constant Count_Type := L;
Src_Index : Hash_Type := Src_Buckets'First;
begin
while L > 0 loop
declare
Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
begin
while Src_Bucket /= null loop
declare
Src_Node : constant Node_Access := Src_Bucket;
Dst_Index : constant Hash_Type :=
Index (Dst_Buckets.all, Src_Node);
Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
begin
Src_Bucket := Next (Src_Node);
Set_Next (Src_Node, Dst_Bucket);
Dst_Bucket := Src_Node;
end;
pragma Assert (L > 0);
L := L - 1;
end loop;
exception
when others =>
-- If there's an error computing a hash value during a
-- rehash, then AI-302 says the nodes "become lost." The
-- issue is whether to actually deallocate these lost nodes,
-- since they might be designated by extant cursors. Here
-- we decide to deallocate the nodes, since it's better to
-- solve real problems (storage consumption) rather than
-- imaginary ones (the user might, or might not, dereference
-- a cursor designating a node that has been deallocated),
-- and because we have a way to vet a dangling cursor
-- reference anyway, and hence can actually detect the
-- problem.
for Dst_Index in Dst_Buckets'Range loop
declare
B : Node_Access renames Dst_Buckets (Dst_Index);
X : Node_Access;
begin
while B /= null loop
X := B;
B := Next (X);
Free (X);
end loop;
end;
end loop;
Free (Dst_Buckets);
raise Program_Error;
end;
Src_Index := Src_Index + 1;
end loop;
HT.Buckets := Dst_Buckets;
HT.Length := LL;
Free (Src_Buckets);
end Rehash;
end Reserve_Capacity;
end Ada.Containers.Hash_Tables.Generic_Operations;

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

File diff suppressed because it is too large Load Diff

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

@ -194,19 +194,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = null then
raise Constraint_Error;
return;
end if;
if Position.Container /= Map_Access'(Container'Unchecked_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Position.Node.Next /= Position.Node);
pragma Assert (Position.Node.Key /= null);
pragma Assert (Position.Node.Element /= null);
if Container.HT.Busy > 0 then
raise Program_Error;
end if;
@ -222,14 +219,24 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
-------------
function Element (Container : Map; Key : Key_Type) return Element_Type is
C : constant Cursor := Find (Container, Key);
Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
begin
return C.Node.Element.all;
if Node = null then
raise Constraint_Error;
end if;
return Node.Element.all;
end Element;
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Vet (Position));
pragma Assert (Vet (Position), "bad cursor in function Element");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Element.all;
end Element;
@ -251,8 +258,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Equivalent_Keys (Left, Right : Cursor) return Boolean is
begin
pragma Assert (Vet (Left));
pragma Assert (Vet (Right));
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Left.Node = null
or else Right.Node = null
then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
end Equivalent_Keys;
@ -261,7 +275,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Right : Key_Type) return Boolean
is
begin
pragma Assert (Vet (Left));
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
if Left.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left.Node.Key.all, Right);
end Equivalent_Keys;
@ -270,7 +289,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Right : Cursor) return Boolean
is
begin
pragma Assert (Vet (Right));
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Right.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left, Right.Node.Key.all);
end Equivalent_Keys;
@ -338,6 +362,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function First (Container : Map) return Cursor is
Node : constant Node_Access := HT_Ops.First (Container.HT);
begin
if Node = null then
return No_Element;
@ -396,13 +421,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Has_Element (Position : Cursor) return Boolean is
begin
if Position.Node = null then
pragma Assert (Position.Container = null);
return False;
end if;
pragma Assert (Vet (Position));
return True;
pragma Assert (Vet (Position), "bad cursor in Has_Element");
return Position.Node /= null;
end Has_Element;
---------------
@ -468,7 +488,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
is
function New_Node (Next : Node_Access) return Node_Access;
procedure Insert is
procedure Local_Insert is
new Key_Ops.Generic_Conditional_Insert (New_Node);
--------------
@ -478,6 +498,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function New_Node (Next : Node_Access) return Node_Access is
K : Key_Access := new Key_Type'(Key);
E : Element_Access;
begin
E := new Element_Type'(New_Item);
return new Node_Type'(K, E, Next);
@ -493,12 +514,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
-- Start of processing for Insert
begin
if HT.Length >= HT_Ops.Capacity (HT) then
-- TODO: see note in a-cohama.adb.
HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
if HT_Ops.Capacity (HT) = 0 then
HT_Ops.Reserve_Capacity (HT, 1);
end if;
Local_Insert (HT, Key, Position.Node, Inserted);
if Inserted
and then HT.Length > HT_Ops.Capacity (HT)
then
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
Insert (HT, Key, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
@ -562,7 +589,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Key (Position : Cursor) return Key_Type is
begin
pragma Assert (Vet (Position));
pragma Assert (Vet (Position), "bad cursor in function Key");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Key.all;
end Key;
@ -603,13 +635,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
declare
pragma Assert (Vet (Position));
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
@ -631,32 +663,40 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Process : not null access procedure (Key : Key_Type;
Element : Element_Type))
is
pragma Assert (Vet (Position));
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
B := B + 1;
L := L + 1;
L := L - 1;
B := B - 1;
declare
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
@ -748,15 +788,24 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
pragma Assert (Vet (Position));
X : Element_Access := Position.Node.Element;
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container.HT.Lock > 0 then
raise Program_Error;
end if;
Position.Node.Element := new Element_Type'(By);
Free_Element (X);
declare
X : Element_Access := Position.Node.Element;
begin
Position.Node.Element := new Element_Type'(By);
Free_Element (X);
end;
end Replace_Element;
----------------------
@ -789,32 +838,40 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
is
pragma Assert (Vet (Position));
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
B := B + 1;
L := L + 1;
L := L - 1;
B := B - 1;
declare
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Update_Element;
---------
@ -824,6 +881,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Vet (Position : Cursor) return Boolean is
begin
if Position.Node = null then
return Position.Container = null;
end if;
if Position.Container = null then
return False;
end if;
@ -842,12 +903,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
declare
HT : Hash_Table_Type renames Position.Container.HT;
X : Node_Access;
begin
if HT.Length = 0 then
return False;
end if;
if HT.Buckets = null then
if HT.Buckets = null
or else HT.Buckets'Length = 0
then
return False;
end if;
@ -862,7 +926,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
return False;
end if;
if X = X.Next then -- weird
if X = X.Next then -- to prevent endless loop
return False;
end if;

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

@ -84,13 +84,15 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
pragma Inline (Read_Node);
procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
Element : Element_Type);
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type);
procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next);
function Vet (Position : Cursor) return Boolean;
procedure Write_Node
(Stream : access Root_Stream_Type'Class;
Node : Node_Access);
@ -217,11 +219,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Position : in out Cursor)
is
begin
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unchecked_Access) then
if Position.Node.Element = null then
raise Program_Error;
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
@ -232,7 +240,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
Free (Position.Node);
Position.Container := null;
end Delete;
@ -351,6 +358,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Vet (Position), "bad cursor in function Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Element = null then -- handle dangling reference
raise Program_Error;
end if;
return Position.Node.Element.all;
end Element;
@ -370,6 +387,21 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Equivalent_Elements (Left, Right : Cursor)
return Boolean is
begin
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Left.Node = null
or else Right.Node = null
then
raise Constraint_Error;
end if;
if Left.Node.Element = null -- handle dangling cursor reference
or else Right.Node.Element = null
then
raise Program_Error;
end if;
return Equivalent_Elements
(Left.Node.Element.all,
Right.Node.Element.all);
@ -378,12 +410,32 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Equivalent_Elements (Left : Cursor; Right : Element_Type)
return Boolean is
begin
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
if Left.Node = null then
raise Constraint_Error;
end if;
if Left.Node.Element = null then -- handling dangling reference
raise Program_Error;
end if;
return Equivalent_Elements (Left.Node.Element.all, Right);
end Equivalent_Elements;
function Equivalent_Elements (Left : Element_Type; Right : Cursor)
return Boolean is
begin
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Right.Node = null then
raise Constraint_Error;
end if;
if Right.Node.Element = null then -- handle dangling cursor reference
raise Program_Error;
end if;
return Equivalent_Elements (Left, Right.Node.Element.all);
end Equivalent_Elements;
@ -520,6 +572,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
return;
end if;
X.Next := X; -- detect mischief (in Vet)
begin
Free_Element (X.Element);
exception
@ -538,12 +592,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Has_Element (Position : Cursor) return Boolean is
begin
if Position.Node = null then
pragma Assert (Position.Container = null);
return False;
end if;
return True;
pragma Assert (Vet (Position), "bad cursor in Has_Element");
return Position.Node /= null;
end Has_Element;
---------------
@ -597,7 +647,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function New_Node (Next : Node_Access) return Node_Access;
pragma Inline (New_Node);
procedure Insert is
procedure Local_Insert is
new Element_Keys.Generic_Conditional_Insert (New_Node);
--------------
@ -620,12 +670,18 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
-- Start of processing for Insert
begin
if HT.Length >= HT_Ops.Capacity (HT) then
-- TODO: optimize this (see a-cohase.adb)
HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
if HT_Ops.Capacity (HT) = 0 then
HT_Ops.Reserve_Capacity (HT, 1);
end if;
Local_Insert (HT, New_Item, Position.Node, Inserted);
if Inserted
and then HT.Length > HT_Ops.Capacity (HT)
then
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
Insert (HT, New_Item, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
@ -763,7 +819,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Is_Empty (Container : Set) return Boolean is
begin
return Container.Length = 0;
return Container.HT.Length = 0;
end Is_Empty;
-----------
@ -833,22 +889,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end Process_Node;
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
-- Start of processing for Iterate
begin
B := B + 1;
-- TODO: resolve whether HT_Ops.Generic_Iteration should
-- manipulate busy bit.
begin
Iterate (HT);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
Iterate (HT);
end Iterate;
------------
@ -880,11 +928,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
if Position.Node.Element = null then
raise Program_Error;
end if;
declare
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
@ -939,29 +992,40 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
E : Element_Type renames Position.Node.Element.all;
HT : Hash_Table_Type renames
Position.Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Element = null then
raise Program_Error;
end if;
declare
HT : Hash_Table_Type renames
Position.Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
Process (E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
B := B + 1;
L := L + 1;
L := L - 1;
B := B - 1;
begin
Process (Position.Node.Element.all);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
@ -1027,13 +1091,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
---------------------
procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
Element : Element_Type)
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type)
is
begin
if Equivalent_Elements (Node.Element.all, Element) then
pragma Assert (Hash (Node.Element.all) = Hash (Element));
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;
@ -1042,7 +1106,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
declare
X : Element_Access := Node.Element;
begin
Node.Element := new Element_Type'(Element); -- OK if fails
Node.Element := new Element_Type'(New_Item); -- OK if fails
Free_Element (X);
end;
@ -1068,7 +1132,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function New_Node (Next : Node_Access) return Node_Access is
begin
Node.Element := new Element_Type'(Element); -- OK if fails
Node.Element := new Element_Type'(New_Item); -- OK if fails
Node.Next := Next;
return Node;
end New_Node;
@ -1084,7 +1148,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Attempt_Insert : begin
Insert
(HT => HT,
Key => Element,
Key => New_Item,
Node => Result,
Inserted => Inserted);
exception
@ -1093,7 +1157,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end Attempt_Insert;
if Inserted then
pragma Assert (Result = Node);
Free_Element (X); -- Just propagate if fails
return;
end if;
@ -1137,22 +1200,26 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end Replace_Element;
procedure Replace_Element
(Container : Set;
(Container : in out Set;
Position : Cursor;
By : Element_Type)
New_Item : Element_Type)
is
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unrestricted_Access) then
if Position.Node.Element = null then
raise Program_Error;
end if;
Replace_Element (HT, Position.Node, By);
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
Replace_Element (Container.HT, Position.Node, New_Item);
end Replace_Element;
----------------------
@ -1613,6 +1680,65 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
return (Controlled with HT => (Buckets, Length, 0, 0));
end Union;
---------
-- Vet --
---------
function Vet (Position : Cursor) return Boolean is
begin
if Position.Node = null then
return Position.Container = null;
end if;
if Position.Container = null then
return False;
end if;
if Position.Node.Next = Position.Node then
return False;
end if;
if Position.Node.Element = null then
return False;
end if;
declare
HT : Hash_Table_Type renames Position.Container.HT;
X : Node_Access;
begin
if HT.Length = 0 then
return False;
end if;
if HT.Buckets = null
or else HT.Buckets'Length = 0
then
return False;
end if;
X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
for J in 1 .. HT.Length loop
if X = Position.Node then
return True;
end if;
if X = null then
return False;
end if;
if X = X.Next then -- to prevent unnecessary looping
return False;
end if;
X := X.Next;
end loop;
return False;
end;
end Vet;
-----------
-- Write --
-----------
@ -1714,29 +1840,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
(Key : Key_Type;
Node : Node_Access) return Boolean is
begin
return Equivalent_Keys (Key, Node.Element.all);
return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
end Equivalent_Key_Node;
---------------------
-- Equivalent_Keys --
---------------------
function Equivalent_Keys
(Left : Cursor;
Right : Key_Type) return Boolean
is
begin
return Equivalent_Keys (Right, Left.Node.Element.all);
end Equivalent_Keys;
function Equivalent_Keys
(Left : Key_Type;
Right : Cursor) return Boolean
is
begin
return Equivalent_Keys (Left, Right.Node.Element.all);
end Equivalent_Keys;
-------------
-- Exclude --
-------------
@ -1775,6 +1881,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Key (Position : Cursor) return Key_Type is
begin
pragma Assert (Vet (Position), "bad cursor in function Key");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Node.Element = null then
raise Program_Error;
end if;
return Key (Position.Node.Element.all);
end Key;
@ -1804,20 +1920,40 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Process : not null access
procedure (Element : in out Element_Type))
is
HT : Hash_Table_Type renames Container.HT;
HT : Hash_Table_Type renames Container.HT;
Indx : Hash_Type;
begin
pragma Assert
(Vet (Position),
"bad cursor in Update_Element_Preserving_Key");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unchecked_Access) then
if Position.Node.Element = null
or else Position.Node.Next = Position.Node
then
raise Program_Error;
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
if HT.Buckets = null
or else HT.Buckets'Length = 0
or else HT.Length = 0
then
raise Program_Error;
end if;
Indx := HT_Ops.Index (HT, Position.Node);
declare
E : Element_Type renames Position.Node.Element.all;
K : Key_Type renames Key (E);
K : constant Key_Type := Key (E);
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
@ -1838,16 +1974,38 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
L := L - 1;
B := B - 1;
if Equivalent_Keys (K, E) then
if Equivalent_Keys (K, Key (E)) then
pragma Assert (Hash (K) = Hash (E));
return;
end if;
end;
if HT.Buckets (Indx) = Position.Node then
HT.Buckets (Indx) := Position.Node.Next;
else
declare
Prev : Node_Access := HT.Buckets (Indx);
begin
while Prev.Next /= Position.Node loop
Prev := Prev.Next;
if Prev = null then
raise Program_Error;
end if;
end loop;
Prev.Next := Position.Node.Next;
end;
end if;
HT.Length := HT.Length - 1;
declare
X : Node_Access := Position.Node;
begin
HT_Ops.Delete_Node_Sans_Free (HT, X);
Free (X);
end;

102
gcc/ada/a-cihase.ads
View File

@ -49,8 +49,7 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Indefinite_Hashed_Sets is
pragma Preelaborate (Indefinite_Hashed_Sets);
pragma Preelaborate;
type Set is tagged private;
@ -64,6 +63,12 @@ package Ada.Containers.Indefinite_Hashed_Sets is
function Equivalent_Sets (Left, Right : Set) return Boolean;
function Capacity (Container : Set) return Count_Type;
procedure Reserve_Capacity
(Container : in out Set;
Capacity : Count_Type);
function Length (Container : Set) return Count_Type;
function Is_Empty (Container : Set) return Boolean;
@ -72,15 +77,15 @@ package Ada.Containers.Indefinite_Hashed_Sets is
function Element (Position : Cursor) return Element_Type;
procedure Replace_Element
(Container : in out Set;
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
procedure Replace_Element
(Container : Set;
Position : Cursor;
By : Element_Type);
procedure Move
(Target : in out Set;
Source : in out Set);
@ -97,38 +102,12 @@ package Ada.Containers.Indefinite_Hashed_Sets is
procedure Replace (Container : in out Set; New_Item : Element_Type);
procedure Exclude (Container : in out Set; Item : Element_Type);
procedure Delete (Container : in out Set; Item : Element_Type);
procedure Delete (Container : in out Set; Position : in out Cursor);
procedure Exclude (Container : in out Set; Item : Element_Type);
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Find (Container : Set; Item : Element_Type) return Cursor;
function First (Container : Set) return Cursor;
function Next (Position : Cursor) return Cursor;
procedure Next (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
function Equivalent_Elements (Left, Right : Cursor) return Boolean;
function Equivalent_Elements
(Left : Cursor;
Right : Element_Type) return Boolean;
function Equivalent_Elements
(Left : Element_Type;
Right : Cursor) return Boolean;
procedure Iterate
(Container : Set;
Process : not null access procedure (Position : Cursor));
procedure Union (Target : in out Set; Source : Set);
function Union (Left, Right : Set) return Set;
@ -158,41 +137,59 @@ package Ada.Containers.Indefinite_Hashed_Sets is
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
function Capacity (Container : Set) return Count_Type;
function First (Container : Set) return Cursor;
procedure Reserve_Capacity
(Container : in out Set;
Capacity : Count_Type);
function Next (Position : Cursor) return Cursor;
procedure Next (Position : in out Cursor);
function Find (Container : Set; Item : Element_Type) return Cursor;
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Has_Element (Position : Cursor) return Boolean;
function Equivalent_Elements (Left, Right : Cursor) return Boolean;
function Equivalent_Elements
(Left : Cursor;
Right : Element_Type) return Boolean;
function Equivalent_Elements
(Left : Element_Type;
Right : Cursor) return Boolean;
procedure Iterate
(Container : Set;
Process : not null access procedure (Position : Cursor));
generic
type Key_Type (<>) is limited private;
type Key_Type (<>) is private;
with function Key (Element : Element_Type) return Key_Type;
with function Hash (Key : Key_Type) return Hash_Type;
with function Equivalent_Keys
(Key : Key_Type;
Element : Element_Type) return Boolean;
with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
package Generic_Keys is
function Contains (Container : Set; Key : Key_Type) return Boolean;
function Find (Container : Set; Key : Key_Type) return Cursor;
function Key (Position : Cursor) return Key_Type;
function Element (Container : Set; Key : Key_Type) return Element_Type;
procedure Replace
procedure Replace -- TODO: ask Randy why this is still here
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
function Find (Container : Set; Key : Key_Type) return Cursor;
function Contains (Container : Set; Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
(Container : in out Set;
@ -200,13 +197,6 @@ package Ada.Containers.Indefinite_Hashed_Sets is
Process : not null access
procedure (Element : in out Element_Type));
function Equivalent_Keys
(Left : Cursor;
Right : Key_Type) return Boolean;
function Equivalent_Keys
(Left : Key_Type;
Right : Cursor) return Boolean;
end Generic_Keys;
private

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

@ -369,6 +369,21 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
return Position.Node.Element.all;
end Element;
-------------------------
-- Equivalent_Elements --
-------------------------
function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
begin
if Left < Right
or else Right < Left
then
return False;
else
return True;
end if;
end Equivalent_Elements;
---------------------
-- Equivalent_Sets --
---------------------
@ -528,34 +543,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
---------
-- "<" --
---------
function "<" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Left < Right.Node.Element.all;
end "<";
function "<" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Right > Left.Node.Element.all;
end "<";
---------
-- ">" --
---------
function ">" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Left > Right.Node.Element.all;
end ">";
function ">" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Right < Left.Node.Element.all;
end ">";
-------------
-- Ceiling --
-------------
@ -609,6 +596,21 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
return Node.Element.all;
end Element;
---------------------
-- Equivalent_Keys --
---------------------
function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
begin
if Left < Right
or else Right < Left
then
return False;
else
return True;
end if;
end Equivalent_Keys;
-------------
-- Exclude --
-------------
@ -663,7 +665,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
(Left : Key_Type;
Right : Node_Access) return Boolean is
begin
return Left > Right.Element.all;
return Key (Right.Element.all) < Left;
end Is_Greater_Key_Node;
----------------------
@ -674,7 +676,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
(Left : Key_Type;
Right : Node_Access) return Boolean is
begin
return Left < Right.Element.all;
return Left < Key (Right.Element.all);
end Is_Less_Key_Node;
---------
@ -728,7 +730,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
declare
E : Element_Type renames Position.Node.Element.all;
K : Key_Type renames Key (E);
K : constant Key_Type := Key (E);
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
@ -749,11 +751,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
L := L - 1;
B := B - 1;
if K < E
or else K > E
then
null;
else
if Equivalent_Keys (K, Key (E)) then
return;
end if;
end;
@ -1365,12 +1363,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
end Replace_Element;
procedure Replace_Element
(Container : Set;
(Container : in out Set;
Position : Cursor;
By : Element_Type)
New_Item : Element_Type)
is
Tree : Tree_Type renames Position.Container.Tree'Unrestricted_Access.all;
begin
if Position.Node = null then
raise Constraint_Error;
@ -1380,7 +1376,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
raise Program_Error;
end if;
Replace_Element (Tree, Position.Node, By);
Replace_Element (Container.Tree, Position.Node, New_Item);
end Replace_Element;
---------------------

89
gcc/ada/a-ciorse.ads
View File

@ -45,7 +45,9 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Indefinite_Ordered_Sets is
pragma Preelaborate (Indefinite_Ordered_Sets);
pragma Preelaborate;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
type Set is tagged private;
@ -67,15 +69,15 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
function Element (Position : Cursor) return Element_Type;
procedure Replace_Element
(Container : in out Set;
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
procedure Replace_Element
(Container : Set; -- TODO: need ruling from ARG
Position : Cursor;
By : Element_Type);
procedure Move (Target : in out Set; Source : in out Set);
procedure Insert
@ -96,6 +98,10 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
(Container : in out Set;
New_Item : Element_Type);
procedure Exclude
(Container : in out Set;
Item : Element_Type);
procedure Delete
(Container : in out Set;
Item : Element_Type);
@ -108,10 +114,6 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
procedure Delete_Last (Container : in out Set);
procedure Exclude
(Container : in out Set;
Item : Element_Type);
procedure Union (Target : in out Set; Source : Set);
function Union (Left, Right : Set) return Set;
@ -124,8 +126,7 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
function "and" (Left, Right : Set) return Set renames Intersection;
procedure Difference (Target : in out Set;
Source : Set);
procedure Difference (Target : in out Set; Source : Set);
function Difference (Left, Right : Set) return Set;
@ -141,14 +142,6 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Find (Container : Set; Item : Element_Type) return Cursor;
function Floor (Container : Set; Item : Element_Type) return Cursor;
function Ceiling (Container : Set; Item : Element_Type) return Cursor;
function First (Container : Set) return Cursor;
function First_Element (Container : Set) return Element_Type;
@ -165,6 +158,14 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
procedure Previous (Position : in out Cursor);
function Find (Container : Set; Item : Element_Type) return Cursor;
function Floor (Container : Set; Item : Element_Type) return Cursor;
function Ceiling (Container : Set; Item : Element_Type) return Cursor;
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Has_Element (Position : Cursor) return Boolean;
function "<" (Left, Right : Cursor) return Boolean;
@ -188,21 +189,28 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
Process : not null access procedure (Position : Cursor));
generic
type Key_Type (<>) is limited private;
type Key_Type (<>) is private;
with function Key (Element : Element_Type) return Key_Type;
with function "<" (Left : Key_Type; Right : Element_Type)
return Boolean is <>;
with function ">" (Left : Key_Type; Right : Element_Type)
return Boolean is <>;
with function "<" (Left, Right : Key_Type) return Boolean is <>;
package Generic_Keys is
function Contains
(Container : Set;
Key : Key_Type) return Boolean;
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
function Key (Position : Cursor) return Key_Type;
function Element (Container : Set; Key : Key_Type) return Element_Type;
procedure Replace
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
function Find
(Container : Set;
@ -216,28 +224,9 @@ pragma Preelaborate (Indefinite_Ordered_Sets);
(Container : Set;
Key : Key_Type) return Cursor;
function Key (Position : Cursor) return Key_Type;
function Element
function Contains
(Container : Set;
Key : Key_Type) return Element_Type;
procedure Replace
(Container : in out Set; -- TODO: need ruling from ARG
Key : Key_Type;
New_Item : Element_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
function "<" (Left : Cursor; Right : Key_Type) return Boolean;
function ">" (Left : Cursor; Right : Key_Type) return Boolean;
function "<" (Left : Key_Type; Right : Cursor) return Boolean;
function ">" (Left : Key_Type; Right : Cursor) return Boolean;
Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
(Container : in out Set;

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

@ -188,16 +188,16 @@ package body Ada.Containers.Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Map_Access'(Container'Unchecked_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
pragma Assert (Position.Node.Next /= Position.Node);
if Container.HT.Busy > 0 then
raise Program_Error;
end if;
@ -213,14 +213,24 @@ package body Ada.Containers.Hashed_Maps is
-------------
function Element (Container : Map; Key : Key_Type) return Element_Type is
C : constant Cursor := Find (Container, Key);
Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
begin
return C.Node.Element;
if Node = null then
raise Constraint_Error;
end if;
return Node.Element;
end Element;
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Vet (Position));
pragma Assert (Vet (Position), "bad cursor in function Element");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Element;
end Element;
@ -242,20 +252,37 @@ package body Ada.Containers.Hashed_Maps is
function Equivalent_Keys (Left, Right : Cursor)
return Boolean is
begin
pragma Assert (Vet (Left));
pragma Assert (Vet (Right));
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Left.Node = null
or else Right.Node = null
then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
end Equivalent_Keys;
function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
begin
pragma Assert (Vet (Left));
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
if Left.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left.Node.Key, Right);
end Equivalent_Keys;
function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
begin
pragma Assert (Vet (Right));
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Right.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Keys (Left, Right.Node.Key);
end Equivalent_Keys;
@ -352,13 +379,8 @@ package body Ada.Containers.Hashed_Maps is
function Has_Element (Position : Cursor) return Boolean is
begin
if Position.Node = null then
pragma Assert (Position.Container = null);
return False;
end if;
pragma Assert (Vet (Position));
return True;
pragma Assert (Vet (Position), "bad cursor in Has_Element");
return Position.Node /= null;
end Has_Element;
---------------
@ -435,25 +457,18 @@ package body Ada.Containers.Hashed_Maps is
-- Start of processing for Insert
begin
if HT.Length >= HT_Ops.Capacity (HT) then
-- TODO: 17 Apr 2005
-- We should defer the expansion until we're sure that the
-- element was successfully inserted. We can do that by
-- first performing the insertion attempt, and allowing the
-- invariant len <= cap to be violated temporarily. After
-- the insertion we can restore the invariant. The
-- worst that can happen is that the insertion succeeds
-- (new element is added to the map), but the
-- invariant is broken (len > cap). But it's only
-- broken by a little (since len = cap + 1), so the
-- effect is benign.
-- END TODO.
HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
if HT_Ops.Capacity (HT) = 0 then
HT_Ops.Reserve_Capacity (HT, 1);
end if;
Local_Insert (HT, Key, Position.Node, Inserted);
if Inserted
and then HT.Length > HT_Ops.Capacity (HT)
then
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
Position.Container := Container'Unchecked_Access;
end Insert;
@ -485,12 +500,18 @@ package body Ada.Containers.Hashed_Maps is
-- Start of processing for Insert
begin
if HT.Length >= HT_Ops.Capacity (HT) then
-- TODO: see note above.
HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
if HT_Ops.Capacity (HT) = 0 then
HT_Ops.Reserve_Capacity (HT, 1);
end if;
Local_Insert (HT, Key, Position.Node, Inserted);
if Inserted
and then HT.Length > HT_Ops.Capacity (HT)
then
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
Position.Container := Container'Unchecked_Access;
end Insert;
@ -553,7 +574,12 @@ package body Ada.Containers.Hashed_Maps is
function Key (Position : Cursor) return Key_Type is
begin
pragma Assert (Vet (Position));
pragma Assert (Vet (Position), "bad cursor in function Key");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Key;
end Key;
@ -589,16 +615,15 @@ package body Ada.Containers.Hashed_Maps is
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
declare
pragma Assert (Vet (Position));
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
begin
if Node = null then
return No_Element;
@ -621,34 +646,41 @@ package body Ada.Containers.Hashed_Maps is
(Position : Cursor;
Process : not null access
procedure (Key : Key_Type; Element : Element_Type))
is
pragma Assert (Vet (Position));
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
B := B + 1;
L := L + 1;
L := L - 1;
B := B - 1;
declare
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
@ -712,15 +744,18 @@ package body Ada.Containers.Hashed_Maps is
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
pragma Assert (Vet (Position));
E : Element_Type renames Position.Node.Element;
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container.HT.Lock > 0 then
raise Program_Error;
end if;
E := By;
Position.Node.Element := By;
end Replace_Element;
----------------------
@ -753,32 +788,40 @@ package body Ada.Containers.Hashed_Maps is
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
is
pragma Assert (Vet (Position));
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
B := B + 1;
L := L + 1;
L := L - 1;
B := B - 1;
declare
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Update_Element;
---------
@ -788,6 +831,10 @@ package body Ada.Containers.Hashed_Maps is
function Vet (Position : Cursor) return Boolean is
begin
if Position.Node = null then
return Position.Container = null;
end if;
if Position.Container = null then
return False;
end if;
@ -795,27 +842,21 @@ package body Ada.Containers.Hashed_Maps is
return False;
end if;
if Position.Container = null then
return False;
end if;
declare
HT : Hash_Table_Type renames Position.Container.HT;
X : Node_Access;
begin
if HT.Length = 0 then
return False;
end if;
if HT.Buckets = null then
if HT.Buckets = null
or else HT.Buckets'Length = 0
then
return False;
end if;
-- NOTE: see notes in Insert.
-- if HT.Length > HT.Buckets'Length then
-- return False;
-- end if;
X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key));
for J in 1 .. HT.Length loop
@ -827,7 +868,7 @@ package body Ada.Containers.Hashed_Maps is
return False;
end if;
if X = X.Next then -- weird
if X = X.Next then -- to prevent endless loop
return False;
end if;

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

@ -67,6 +67,8 @@ package body Ada.Containers.Hashed_Sets is
(R_HT : Hash_Table_Type;
L_Node : Node_Access) return Boolean;
procedure Free (X : in out Node_Access);
function Hash_Node (Node : Node_Access) return Hash_Type;
pragma Inline (Hash_Node);
@ -83,13 +85,15 @@ package body Ada.Containers.Hashed_Sets is
pragma Inline (Read_Node);
procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
Element : Element_Type);
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type);
procedure Set_Next (Node : Node_Access; Next : Node_Access);
pragma Inline (Set_Next);
function Vet (Position : Cursor) return Boolean;
procedure Write_Node
(Stream : access Root_Stream_Type'Class;
Node : Node_Access);
@ -99,9 +103,6 @@ package body Ada.Containers.Hashed_Sets is
-- Local Instantiations --
--------------------------
procedure Free is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
package HT_Ops is
new Hash_Tables.Generic_Operations
(HT_Types => HT_Types,
@ -211,11 +212,13 @@ package body Ada.Containers.Hashed_Sets is
Position : in out Cursor)
is
begin
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unchecked_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
@ -226,7 +229,6 @@ package body Ada.Containers.Hashed_Sets is
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
Free (Position.Node);
Position.Container := null;
end Delete;
@ -345,6 +347,12 @@ package body Ada.Containers.Hashed_Sets is
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Vet (Position), "bad cursor in function Element");
if Position.Node = null then
raise Constraint_Error;
end if;
return Position.Node.Element;
end Element;
@ -364,18 +372,39 @@ package body Ada.Containers.Hashed_Sets is
function Equivalent_Elements (Left, Right : Cursor)
return Boolean is
begin
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Left.Node = null
or else Right.Node = null
then
raise Constraint_Error;
end if;
return Equivalent_Elements (Left.Node.Element, Right.Node.Element);
end Equivalent_Elements;
function Equivalent_Elements (Left : Cursor; Right : Element_Type)
return Boolean is
begin
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
if Left.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Elements (Left.Node.Element, Right);
end Equivalent_Elements;
function Equivalent_Elements (Left : Element_Type; Right : Cursor)
return Boolean is
begin
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Right.Node = null then
raise Constraint_Error;
end if;
return Equivalent_Elements (Left, Right.Node.Element);
end Equivalent_Elements;
@ -499,18 +528,29 @@ package body Ada.Containers.Hashed_Sets is
return Cursor'(Container'Unrestricted_Access, Node);
end First;
----------
-- Free --
----------
procedure Free (X : in out Node_Access) is
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
if X /= null then
X.Next := X; -- detect mischief (in Vet)
Deallocate (X);
end if;
end Free;
-----------------
-- Has_Element --
-----------------
function Has_Element (Position : Cursor) return Boolean is
begin
if Position.Node = null then
pragma Assert (Position.Container = null);
return False;
end if;
return True;
pragma Assert (Vet (Position), "bad cursor in Has_Element");
return Position.Node /= null;
end Has_Element;
---------------
@ -576,18 +616,18 @@ package body Ada.Containers.Hashed_Sets is
-- Start of processing for Insert
begin
if HT.Length >= HT_Ops.Capacity (HT) then
-- TODO:
-- Perform the insertion first, and then reserve
-- capacity, but only if the insertion succeeds and
-- the (new) length is greater then current capacity.
-- END TODO.
HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
if HT_Ops.Capacity (HT) = 0 then
HT_Ops.Reserve_Capacity (HT, 1);
end if;
Local_Insert (HT, New_Item, Position.Node, Inserted);
if Inserted
and then HT.Length > HT_Ops.Capacity (HT)
then
HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
Position.Container := Container'Unchecked_Access;
end Insert;
@ -725,7 +765,7 @@ package body Ada.Containers.Hashed_Sets is
function Is_Empty (Container : Set) return Boolean is
begin
return Container.Length = 0;
return Container.HT.Length = 0;
end Is_Empty;
-----------
@ -790,23 +830,13 @@ package body Ada.Containers.Hashed_Sets is
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
B : Natural renames HT.Busy;
-- Start of processing for Iterate
begin
B := B + 1;
-- TODO: resolve whether HT_Ops.Generic_Iteration should
-- manipulate busy bit.
begin
Iterate (HT);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
Iterate (Container.HT);
end Iterate;
------------
@ -838,8 +868,9 @@ package body Ada.Containers.Hashed_Sets is
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
pragma Assert (Position.Container = null);
return No_Element;
end if;
@ -896,28 +927,35 @@ package body Ada.Containers.Hashed_Sets is
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
E : Element_Type renames Position.Node.Element;
HT : Hash_Table_Type renames Position.Container.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
B := B + 1;
L := L + 1;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
declare
HT : Hash_Table_Type renames Position.Container.HT;
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
begin
Process (E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
B := B + 1;
L := L + 1;
L := L - 1;
B := B - 1;
begin
Process (Position.Node.Element);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
@ -955,7 +993,7 @@ package body Ada.Containers.Hashed_Sets is
-------------
procedure Replace
(Container : in out Set; -- TODO: need ruling from ARG
(Container : in out Set;
New_Item : Element_Type)
is
Node : constant Node_Access :=
@ -978,19 +1016,19 @@ package body Ada.Containers.Hashed_Sets is
---------------------
procedure Replace_Element
(HT : in out Hash_Table_Type;
Node : Node_Access;
Element : Element_Type)
(HT : in out Hash_Table_Type;
Node : Node_Access;
New_Item : Element_Type)
is
begin
if Equivalent_Elements (Node.Element, Element) then
pragma Assert (Hash (Node.Element) = Hash (Element));
if Equivalent_Elements (Node.Element, New_Item) then
pragma Assert (Hash (Node.Element) = Hash (New_Item));
if HT.Lock > 0 then
raise Program_Error;
end if;
Node.Element := Element; -- Note that this assignment can fail
Node.Element := New_Item; -- Note that this assignment can fail
return;
end if;
@ -1013,7 +1051,7 @@ package body Ada.Containers.Hashed_Sets is
function New_Node (Next : Node_Access) return Node_Access is
begin
Node.Element := Element; -- Note that this assignment can fail
Node.Element := New_Item; -- Note that this assignment can fail
Node.Next := Next;
return Node;
end New_Node;
@ -1026,12 +1064,11 @@ package body Ada.Containers.Hashed_Sets is
begin
Local_Insert
(HT => HT,
Key => Element,
Key => New_Item,
Node => Result,
Inserted => Inserted);
if Inserted then
pragma Assert (Result = Node);
return;
end if;
exception
@ -1076,22 +1113,22 @@ package body Ada.Containers.Hashed_Sets is
end Replace_Element;
procedure Replace_Element
(Container : Set;
(Container : in out Set;
Position : Cursor;
By : Element_Type)
New_Item : Element_Type)
is
HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unrestricted_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
Replace_Element (HT, Position.Node, By);
Replace_Element (Container.HT, Position.Node, New_Item);
end Replace_Element;
----------------------
@ -1491,6 +1528,61 @@ package body Ada.Containers.Hashed_Sets is
return (Controlled with HT => (Buckets, Length, 0, 0));
end Union;
---------
-- Vet --
---------
function Vet (Position : Cursor) return Boolean is
begin
if Position.Node = null then
return Position.Container = null;
end if;
if Position.Container = null then
return False;
end if;
if Position.Node.Next = Position.Node then
return False;
end if;
declare
HT : Hash_Table_Type renames Position.Container.HT;
X : Node_Access;
begin
if HT.Length = 0 then
return False;
end if;
if HT.Buckets = null
or else HT.Buckets'Length = 0
then
return False;
end if;
X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element));
for J in 1 .. HT.Length loop
if X = Position.Node then
return True;
end if;
if X = null then
return False;
end if;
if X = X.Next then -- to prevent unnecessary looping
return False;
end if;
X := X.Next;
end loop;
return False;
end;
end Vet;
-----------
-- Write --
-----------
@ -1594,27 +1686,9 @@ package body Ada.Containers.Hashed_Sets is
Node : Node_Access) return Boolean
is
begin
return Equivalent_Keys (Key, Node.Element);
return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
end Equivalent_Key_Node;
---------------------
-- Equivalent_Keys --
---------------------
function Equivalent_Keys
(Left : Cursor;
Right : Key_Type) return Boolean is
begin
return Equivalent_Keys (Right, Left.Node.Element);
end Equivalent_Keys;
function Equivalent_Keys
(Left : Key_Type;
Right : Cursor) return Boolean is
begin
return Equivalent_Keys (Left, Right.Node.Element);
end Equivalent_Keys;
-------------
-- Exclude --
-------------
@ -1654,6 +1728,12 @@ package body Ada.Containers.Hashed_Sets is
function Key (Position : Cursor) return Key_Type is
begin
pragma Assert (Vet (Position), "bad cursor in function Key");
if Position.Node = null then
raise Constraint_Error;
end if;
return Key (Position.Node.Element);
end Key;
@ -1687,20 +1767,35 @@ package body Ada.Containers.Hashed_Sets is
Process : not null access
procedure (Element : in out Element_Type))
is
HT : Hash_Table_Type renames Container.HT;
HT : Hash_Table_Type renames Container.HT;
Indx : Hash_Type;
begin
pragma Assert
(Vet (Position),
"bad cursor in Update_Element_Preserving_Key");
if Position.Node = null then
raise Constraint_Error;
end if;
if Position.Container /= Set_Access'(Container'Unchecked_Access) then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
if HT.Buckets = null
or else HT.Buckets'Length = 0
or else HT.Length = 0
or else Position.Node.Next = Position.Node
then
raise Program_Error;
end if;
Indx := HT_Ops.Index (HT, Position.Node);
declare
E : Element_Type renames Position.Node.Element;
K : Key_Type renames Key (E);
K : constant Key_Type := Key (E);
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
@ -1721,16 +1816,38 @@ package body Ada.Containers.Hashed_Sets is
L := L - 1;
B := B - 1;
if Equivalent_Keys (K, E) then
if Equivalent_Keys (K, Key (E)) then
pragma Assert (Hash (K) = Hash (E));
return;
end if;
end;
if HT.Buckets (Indx) = Position.Node then
HT.Buckets (Indx) := Position.Node.Next;
else
declare
Prev : Node_Access := HT.Buckets (Indx);
begin
while Prev.Next /= Position.Node loop
Prev := Prev.Next;
if Prev = null then
raise Program_Error;
end if;
end loop;
Prev.Next := Position.Node.Next;
end;
end if;
HT.Length := HT.Length - 1;
declare
X : Node_Access := Position.Node;
begin
HT_Ops.Delete_Node_Sans_Free (HT, X);
Free (X);
end;

107
gcc/ada/a-cohase.ads
View File

@ -48,7 +48,7 @@ generic
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Hashed_Sets is
pragma Preelaborate (Hashed_Sets);
pragma Preelaborate;
type Set is tagged private;
@ -62,6 +62,12 @@ pragma Preelaborate (Hashed_Sets);
function Equivalent_Sets (Left, Right : Set) return Boolean;
function Capacity (Container : Set) return Count_Type;
procedure Reserve_Capacity
(Container : in out Set;
Capacity : Count_Type);
function Length (Container : Set) return Count_Type;
function Is_Empty (Container : Set) return Boolean;
@ -70,15 +76,15 @@ pragma Preelaborate (Hashed_Sets);
function Element (Position : Cursor) return Element_Type;
procedure Replace_Element
(Container : in out Set;
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
procedure Replace_Element
(Container : Set;
Position : Cursor;
By : Element_Type);
procedure Move (Target : in out Set; Source : in out Set);
procedure Insert
@ -93,40 +99,12 @@ pragma Preelaborate (Hashed_Sets);
procedure Replace (Container : in out Set; New_Item : Element_Type);
procedure Exclude (Container : in out Set; Item : Element_Type);
procedure Delete (Container : in out Set; Item : Element_Type);
procedure Delete (Container : in out Set; Position : in out Cursor);
procedure Exclude (Container : in out Set; Item : Element_Type);
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Find
(Container : Set;
Item : Element_Type) return Cursor;
function First (Container : Set) return Cursor;
function Next (Position : Cursor) return Cursor;
procedure Next (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
function Equivalent_Elements (Left, Right : Cursor) return Boolean;
function Equivalent_Elements
(Left : Cursor;
Right : Element_Type) return Boolean;
function Equivalent_Elements
(Left : Element_Type;
Right : Cursor) return Boolean;
procedure Iterate
(Container : Set;
Process : not null access procedure (Position : Cursor));
procedure Union (Target : in out Set; Source : Set);
function Union (Left, Right : Set) return Set;
@ -156,41 +134,61 @@ pragma Preelaborate (Hashed_Sets);
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
function Capacity (Container : Set) return Count_Type;
function First (Container : Set) return Cursor;
procedure Reserve_Capacity
(Container : in out Set;
Capacity : Count_Type);
function Next (Position : Cursor) return Cursor;
procedure Next (Position : in out Cursor);
function Find
(Container : Set;
Item : Element_Type) return Cursor;
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Has_Element (Position : Cursor) return Boolean;
function Equivalent_Elements (Left, Right : Cursor) return Boolean;
function Equivalent_Elements
(Left : Cursor;
Right : Element_Type) return Boolean;
function Equivalent_Elements
(Left : Element_Type;
Right : Cursor) return Boolean;
procedure Iterate
(Container : Set;
Process : not null access procedure (Position : Cursor));
generic
type Key_Type (<>) is limited private;
type Key_Type (<>) is private;
with function Key (Element : Element_Type) return Key_Type;
with function Hash (Key : Key_Type) return Hash_Type;
with function Equivalent_Keys
(Key : Key_Type;
Element : Element_Type) return Boolean;
with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
package Generic_Keys is
function Contains (Container : Set; Key : Key_Type) return Boolean;
function Find (Container : Set; Key : Key_Type) return Cursor;
function Key (Position : Cursor) return Key_Type;
function Element (Container : Set; Key : Key_Type) return Element_Type;
procedure Replace
procedure Replace -- TODO: ask Randy why this wasn't removed
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
function Find (Container : Set; Key : Key_Type) return Cursor;
function Contains (Container : Set; Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
(Container : in out Set;
@ -198,18 +196,9 @@ pragma Preelaborate (Hashed_Sets);
Process : not null access
procedure (Element : in out Element_Type));
function Equivalent_Keys
(Left : Cursor;
Right : Key_Type) return Boolean;
function Equivalent_Keys
(Left : Key_Type;
Right : Cursor) return Boolean;
end Generic_Keys;
private
type Node_Type;
type Node_Access is access Node_Type;

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

@ -359,6 +359,21 @@ package body Ada.Containers.Ordered_Sets is
return Position.Node.Element;
end Element;
-------------------------
-- Equivalent_Elements --
-------------------------
function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
begin
if Left < Right
or else Right < Left
then
return False;
else
return True;
end if;
end Equivalent_Elements;
---------------------
-- Equivalent_Sets --
---------------------
@ -490,34 +505,6 @@ package body Ada.Containers.Ordered_Sets is
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
---------
-- "<" --
---------
function "<" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Left < Right.Node.Element;
end "<";
function "<" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Right > Left.Node.Element;
end "<";
---------
-- ">" --
---------
function ">" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Left > Right.Node.Element;
end ">";
function ">" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Right < Left.Node.Element;
end ">";
-------------
-- Ceiling --
-------------
@ -573,6 +560,21 @@ package body Ada.Containers.Ordered_Sets is
return Node.Element;
end Element;
---------------------
-- Equivalent_Keys --
---------------------
function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
begin
if Left < Right
or else Right < Left
then
return False;
else
return True;
end if;
end Equivalent_Keys;
-------------
-- Exclude --
-------------
@ -626,7 +628,7 @@ package body Ada.Containers.Ordered_Sets is
Right : Node_Access) return Boolean
is
begin
return Left > Right.Element;
return Key (Right.Element) < Left;
end Is_Greater_Key_Node;
----------------------
@ -638,7 +640,7 @@ package body Ada.Containers.Ordered_Sets is
Right : Node_Access) return Boolean
is
begin
return Left < Right.Element;
return Left < Key (Right.Element);
end Is_Less_Key_Node;
---------
@ -691,7 +693,7 @@ package body Ada.Containers.Ordered_Sets is
declare
E : Element_Type renames Position.Node.Element;
K : Key_Type renames Key (E);
K : constant Key_Type := Key (E);
B : Natural renames Tree.Busy;
L : Natural renames Tree.Lock;
@ -712,11 +714,7 @@ package body Ada.Containers.Ordered_Sets is
L := L - 1;
B := B - 1;
if K < E
or else K > E
then
null;
else
if Equivalent_Keys (K, Key (E)) then
return;
end if;
end;
@ -1319,12 +1317,10 @@ package body Ada.Containers.Ordered_Sets is
end Replace_Element;
procedure Replace_Element
(Container : Set;
(Container : in out Set;
Position : Cursor;
By : Element_Type)
New_Item : Element_Type)
is
Tree : Tree_Type renames Container.Tree'Unrestricted_Access.all;
begin
if Position.Node = null then
raise Constraint_Error;
@ -1334,7 +1330,7 @@ package body Ada.Containers.Ordered_Sets is
raise Program_Error;
end if;
Replace_Element (Tree, Position.Node, By);
Replace_Element (Container.Tree, Position.Node, New_Item);
end Replace_Element;
---------------------

94
gcc/ada/a-coorse.ads
View File

@ -38,14 +38,15 @@ with Ada.Finalization;
with Ada.Streams;
generic
type Element_Type is private;
with function "<" (Left, Right : Element_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Ordered_Sets is
pragma Preelaborate (Ordered_Sets);
pragma Preelaborate;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
type Set is tagged private;
@ -67,18 +68,16 @@ pragma Preelaborate (Ordered_Sets);
function Element (Position : Cursor) return Element_Type;
procedure Replace_Element
(Container : in out Set;
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
procedure Replace_Element
(Container : Set; -- TODO: need ARG ruling
Position : Cursor;
By : Element_Type);
procedure Move
(Target : in out Set;
Source : in out Set);
procedure Move (Target : in out Set; Source : in out Set);
procedure Insert
(Container : in out Set;
@ -95,9 +94,13 @@ pragma Preelaborate (Ordered_Sets);
New_Item : Element_Type);
procedure Replace
(Container : in out Set; -- TODO: need ARG ruling
(Container : in out Set;
New_Item : Element_Type);
procedure Exclude
(Container : in out Set;
Item : Element_Type);
procedure Delete
(Container : in out Set;
Item : Element_Type);
@ -110,10 +113,6 @@ pragma Preelaborate (Ordered_Sets);
procedure Delete_Last (Container : in out Set);
procedure Exclude
(Container : in out Set;
Item : Element_Type);
procedure Union (Target : in out Set; Source : Set);
function Union (Left, Right : Set) return Set;
@ -126,8 +125,7 @@ pragma Preelaborate (Ordered_Sets);
function "and" (Left, Right : Set) return Set renames Intersection;
procedure Difference (Target : in out Set;
Source : Set);
procedure Difference (Target : in out Set; Source : Set);
function Difference (Left, Right : Set) return Set;
@ -143,14 +141,6 @@ pragma Preelaborate (Ordered_Sets);
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Find (Container : Set; Item : Element_Type) return Cursor;
function Floor (Container : Set; Item : Element_Type) return Cursor;
function Ceiling (Container : Set; Item : Element_Type) return Cursor;
function First (Container : Set) return Cursor;
function First_Element (Container : Set) return Element_Type;
@ -167,6 +157,14 @@ pragma Preelaborate (Ordered_Sets);
procedure Previous (Position : in out Cursor);
function Find (Container : Set; Item : Element_Type) return Cursor;
function Floor (Container : Set; Item : Element_Type) return Cursor;
function Ceiling (Container : Set; Item : Element_Type) return Cursor;
function Contains (Container : Set; Item : Element_Type) return Boolean;
function Has_Element (Position : Cursor) return Boolean;
function "<" (Left, Right : Cursor) return Boolean;
@ -190,21 +188,28 @@ pragma Preelaborate (Ordered_Sets);
Process : not null access procedure (Position : Cursor));
generic
type Key_Type (<>) is limited private;
type Key_Type (<>) is private;
with function Key (Element : Element_Type) return Key_Type;
with function "<"
(Left : Key_Type;
Right : Element_Type) return Boolean is <>;
with function ">"
(Left : Key_Type;
Right : Element_Type) return Boolean is <>;
with function "<" (Left, Right : Key_Type) return Boolean is <>;
package Generic_Keys is
function Contains (Container : Set; Key : Key_Type) return Boolean;
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
function Key (Position : Cursor) return Key_Type;
function Element (Container : Set; Key : Key_Type) return Element_Type;
procedure Replace
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
function Find (Container : Set; Key : Key_Type) return Cursor;
@ -212,26 +217,7 @@ pragma Preelaborate (Ordered_Sets);
function Ceiling (Container : Set; Key : Key_Type) return Cursor;
function Key (Position : Cursor) return Key_Type;
function Element (Container : Set; Key : Key_Type) return Element_Type;
procedure Replace
(Container : in out Set; -- TODO: need ARG ruling
Key : Key_Type;
New_Item : Element_Type);
procedure Delete (Container : in out Set; Key : Key_Type);
procedure Exclude (Container : in out Set; Key : Key_Type);
function "<" (Left : Cursor; Right : Key_Type) return Boolean;
function ">" (Left : Cursor; Right : Key_Type) return Boolean;
function "<" (Left : Key_Type; Right : Cursor) return Boolean;
function ">" (Left : Key_Type; Right : Cursor) return Boolean;
function Contains (Container : Set; Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
(Container : in out Set;