[Ada] Update on AI-302
Arnaud Charlet
charlet@adacore.com
Mon Sep 5 08:49:00 GMT 2005
Tested on i686-linux, committed on HEAD
The latest draft (Draft 13) of the language amendment can be found on this page:
http://www.ada-auth.org/amendment.html
The amendment draft itself is here (there's also a PDF):
http://www.ada-auth.org/ai-files/grab_bag/Amendment-D13.html
The container library is specified by AI-302. The changes made to this
container spec were specified by v1.22 ("post-York") of the AI-302 draft:
http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-20302.TXT?rev=1.22
The differences between v1.21 and v1.22 are here:
http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-20302.TXT.diff?r1=1.21&r2=1.22
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.
-------------- next part --------------
Index: a-cihase.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-cihase.adb,v
retrieving revision 1.3
diff -u -p -r1.3 a-cihase.adb
--- a-cihase.adb 1 Jul 2005 01:22:36 -0000 1.3
+++ a-cihase.adb 5 Sep 2005 07:32:09 -0000
@@ -84,13 +84,15 @@ package body Ada.Containers.Indefinite_H
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_H
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_H
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_H
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_H
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_H
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_H
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_H
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_H
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_H
-- 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_H
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_H
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;
-
- begin
- Iterate (HT);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
+ -- TODO: resolve whether HT_Ops.Generic_Iteration should
+ -- manipulate busy bit.
- B := B - 1;
+ Iterate (HT);
end Iterate;
------------
@@ -880,11 +928,16 @@ package body Ada.Containers.Indefinite_H
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_H
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
- E : Element_Type renames Position.Node.Element.all;
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
- HT : Hash_Table_Type renames
- Position.Container'Unrestricted_Access.all.HT;
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ if Position.Node.Element = null then
+ raise Program_Error;
+ end if;
- begin
- B := B + 1;
- L := L + 1;
+ 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_H
---------------------
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_H
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_H
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_H
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_H
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_H
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_H
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_H
(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_H
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_H
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_H
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;
Index: a-coorse.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-coorse.ads,v
retrieving revision 1.3
diff -u -p -r1.3 a-coorse.ads
--- a-coorse.ads 1 Jul 2005 01:22:38 -0000 1.3
+++ a-coorse.ads 5 Sep 2005 07:32:09 -0000
@@ -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,48 +188,36 @@ 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 Find (Container : Set; Key : Key_Type) return Cursor;
-
- function Floor (Container : Set; Key : Key_Type) return Cursor;
-
- function Ceiling (Container : Set; Key : Key_Type) return Cursor;
+ 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; -- TODO: need ARG ruling
+ (Container : in out Set;
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;
+ procedure Delete (Container : in out Set; Key : Key_Type);
+
+ function Find (Container : Set; Key : Key_Type) return Cursor;
- function ">" (Left : Cursor; Right : Key_Type) return Boolean;
+ function Floor (Container : Set; Key : Key_Type) return Cursor;
- function "<" (Left : Key_Type; Right : Cursor) return Boolean;
+ function Ceiling (Container : Set; Key : Key_Type) return Cursor;
- 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;
Index: a-coorse.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-coorse.adb,v
retrieving revision 1.3
diff -u -p -r1.3 a-coorse.adb
--- a-coorse.adb 1 Jul 2005 01:22:38 -0000 1.3
+++ a-coorse.adb 5 Sep 2005 07:32:09 -0000
@@ -359,6 +359,21 @@ package body Ada.Containers.Ordered_Sets
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_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
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
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
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
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
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
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
raise Program_Error;
end if;
- Replace_Element (Tree, Position.Node, By);
+ Replace_Element (Container.Tree, Position.Node, New_Item);
end Replace_Element;
---------------------
Index: a-cohama.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-cohama.adb,v
retrieving revision 1.3
diff -u -p -r1.3 a-cohama.adb
--- a-cohama.adb 1 Jul 2005 01:22:37 -0000 1.3
+++ a-cohama.adb 5 Sep 2005 07:32:09 -0000
@@ -188,16 +188,16 @@ package body Ada.Containers.Hashed_Maps
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
-------------
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
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
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
-- Start of processing for Insert
begin
- if HT.Length >= HT_Ops.Capacity (HT) then
+ if HT_Ops.Capacity (HT) = 0 then
+ HT_Ops.Reserve_Capacity (HT, 1);
+ end if;
- -- 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.
+ Local_Insert (HT, Key, Position.Node, Inserted);
- HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
+ if Inserted
+ and then HT.Length > HT_Ops.Capacity (HT)
+ then
+ HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
- Local_Insert (HT, Key, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
@@ -485,12 +500,18 @@ package body Ada.Containers.Hashed_Maps
-- 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
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
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
(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;
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
- M : Map renames Position.Container.all;
- HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ declare
+ M : Map renames Position.Container.all;
+ HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
- begin
- B := B + 1;
- L := L + 1;
+ 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;
+
+ 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;
+ L := L - 1;
+ B := B - 1;
+ end;
end Query_Element;
----------
@@ -712,15 +744,18 @@ package body Ada.Containers.Hashed_Maps
---------------------
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
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;
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Update_Element");
- M : Map renames Position.Container.all;
- HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ declare
+ M : Map renames Position.Container.all;
+ HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
- begin
- B := B + 1;
- L := L + 1;
+ 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;
+
+ 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;
+ L := L - 1;
+ B := B - 1;
+ end;
end Update_Element;
---------
@@ -788,34 +831,32 @@ package body Ada.Containers.Hashed_Maps
function Vet (Position : Cursor) return Boolean is
begin
if Position.Node = null then
- return False;
+ return Position.Container = null;
end if;
- if Position.Node.Next = Position.Node then
+ if Position.Container = null then
return False;
end if;
- if Position.Container = null then
+ 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 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
return False;
end if;
- if X = X.Next then -- weird
+ if X = X.Next then -- to prevent endless loop
return False;
end if;
Index: a-ciorse.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-ciorse.ads,v
retrieving revision 1.3
diff -u -p -r1.3 a-ciorse.ads
--- a-ciorse.ads 1 Jul 2005 01:22:37 -0000 1.3
+++ a-ciorse.ads 5 Sep 2005 07:32:09 -0000
@@ -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_
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_
(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_
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_
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_
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_
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_
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_
(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;
Index: a-ciorse.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-ciorse.adb,v
retrieving revision 1.3
diff -u -p -r1.3 a-ciorse.adb
--- a-ciorse.adb 1 Jul 2005 01:22:37 -0000 1.3
+++ a-ciorse.adb 5 Sep 2005 07:32:09 -0000
@@ -369,6 +369,21 @@ package body Ada.Containers.Indefinite_O
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_O
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_O
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_O
(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_O
(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_O
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_O
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_O
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_O
raise Program_Error;
end if;
- Replace_Element (Tree, Position.Node, By);
+ Replace_Element (Container.Tree, Position.Node, New_Item);
end Replace_Element;
---------------------
Index: a-cihama.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-cihama.adb,v
retrieving revision 1.3
diff -u -p -r1.3 a-cihama.adb
--- a-cihama.adb 1 Jul 2005 01:22:36 -0000 1.3
+++ a-cihama.adb 5 Sep 2005 07:32:10 -0000
@@ -194,19 +194,16 @@ package body Ada.Containers.Indefinite_H
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_H
-------------
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_H
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_H
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_H
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_H
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_H
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_H
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_H
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_H
-- 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_H
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_H
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_H
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;
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
- M : Map renames Position.Container.all;
- HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ declare
+ M : Map renames Position.Container.all;
+ HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
- begin
- B := B + 1;
- L := L + 1;
+ 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_H
---------------------
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_H
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
is
- pragma Assert (Vet (Position));
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Update_Element");
- K : Key_Type renames Position.Node.Key.all;
- E : Element_Type renames Position.Node.Element.all;
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
- M : Map renames Position.Container.all;
- HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+ 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
- B := B + 1;
- L := L + 1;
+ 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_H
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_H
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_H
return False;
end if;
- if X = X.Next then -- weird
+ if X = X.Next then -- to prevent endless loop
return False;
end if;
Index: a-cdlili.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-cdlili.adb,v
retrieving revision 1.3
diff -u -p -r1.3 a-cdlili.adb
--- a-cdlili.adb 1 Jul 2005 01:22:35 -0000 1.3
+++ a-cdlili.adb 5 Sep 2005 07:32:10 -0000
@@ -38,18 +38,19 @@ with Ada.Unchecked_Deallocation;
package body Ada.Containers.Doubly_Linked_Lists is
- procedure Free is
- new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
-
-----------------------
-- Local Subprograms --
-----------------------
+ procedure Free (X : in out Node_Access);
+
procedure Insert_Internal
(Container : in out List;
Before : Node_Access;
New_Node : Node_Access);
+ function Vet (Position : Cursor) return Boolean;
+
---------
-- "=" --
---------
@@ -110,7 +111,6 @@ package body Ada.Containers.Doubly_Linke
Container.Length := 1;
Src := Src.Next;
-
while Src /= null loop
Container.Last.Next := new Node_Type'(Element => Src.Element,
Prev => Container.Last,
@@ -162,9 +162,8 @@ package body Ada.Containers.Doubly_Linke
pragma Assert (X.Next.Prev = Container.First);
Container.First := X.Next;
- X.Next := null; -- prevent mischief
-
Container.First.Prev := null;
+
Container.Length := Container.Length - 1;
Free (X);
@@ -181,7 +180,7 @@ package body Ada.Containers.Doubly_Linke
end Clear;
--------------
- -- Continue --
+ -- Contains --
--------------
function Contains
@@ -203,28 +202,16 @@ package body Ada.Containers.Doubly_Linke
X : Node_Access;
begin
+ pragma Assert (Vet (Position), "bad cursor in Delete");
+
if Position.Node = null then
- pragma Assert (Position.Container = null);
raise Constraint_Error;
end if;
- if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
- pragma Assert (Container.Length > 0);
- pragma Assert (Container.First.Prev = null);
- pragma Assert (Container.Last.Next = null);
-
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Container.Last);
-
if Position.Node = Container.First then
Delete_First (Container, Count);
Position := First (Container);
@@ -249,7 +236,6 @@ package body Ada.Containers.Doubly_Linke
Container.Last := X.Prev;
Container.Last.Next := null;
- X.Prev := null; -- prevent mischief
Free (X);
return;
end if;
@@ -259,8 +245,6 @@ package body Ada.Containers.Doubly_Linke
X.Next.Prev := X.Prev;
X.Prev.Next := X.Next;
- X.Next := null;
- X.Prev := null;
Free (X);
end loop;
end Delete;
@@ -298,7 +282,6 @@ package body Ada.Containers.Doubly_Linke
Container.Length := Container.Length - 1;
- X.Next := null; -- prevent mischief
Free (X);
end loop;
end Delete_First;
@@ -336,7 +319,6 @@ package body Ada.Containers.Doubly_Linke
Container.Length := Container.Length - 1;
- X.Prev := null; -- prevent mischief
Free (X);
end loop;
end Delete_Last;
@@ -347,20 +329,11 @@ package body Ada.Containers.Doubly_Linke
function Element (Position : Cursor) return Element_Type is
begin
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
+ pragma Assert (Vet (Position), "bad cursor in Element");
+
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
return Position.Node.Element;
end Element;
@@ -379,23 +352,13 @@ package body Ada.Containers.Doubly_Linke
begin
if Node = null then
Node := Container.First;
+
else
- if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ pragma Assert (Vet (Position), "bad cursor in Find");
+
+ if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
-
- pragma Assert (Container.Length > 0);
- pragma Assert (Container.First.Prev = null);
- pragma Assert (Container.Last.Next = null);
-
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Container.Last);
end if;
while Node /= null loop
@@ -428,9 +391,27 @@ package body Ada.Containers.Doubly_Linke
function First_Element (Container : List) return Element_Type is
begin
+ if Container.First = null then
+ raise Constraint_Error;
+ end if;
+
return Container.First.Element;
end First_Element;
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Node_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ begin
+ X.Prev := X;
+ X.Next := X;
+ Deallocate (X);
+ end Free;
+
---------------------
-- Generic_Sorting --
---------------------
@@ -605,26 +586,8 @@ package body Ada.Containers.Doubly_Linke
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 (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
- return True;
+ pragma Assert (Vet (Position), "bad cursor in Has_Element");
+ return Position.Node /= null;
end Has_Element;
------------
@@ -641,23 +604,12 @@ package body Ada.Containers.Doubly_Linke
New_Node : Node_Access;
begin
- if Before.Node /= null then
- if Before.Container /= List_Access'(Container'Unchecked_Access) then
- raise Program_Error;
- end if;
+ pragma Assert (Vet (Before), "bad cursor in Insert");
- pragma Assert (Container.Length > 0);
- pragma Assert (Container.First.Prev = null);
- pragma Assert (Container.Last.Next = null);
-
- pragma Assert (Before.Node.Prev = null
- or else Before.Node.Prev.Next = Before.Node);
- pragma Assert (Before.Node.Next = null
- or else Before.Node.Next.Prev = Before.Node);
- pragma Assert (Before.Node.Prev /= null
- or else Before.Node = Container.First);
- pragma Assert (Before.Node.Next /= null
- or else Before.Node = Container.Last);
+ if Before.Container /= null
+ and then Before.Container /= Container'Unrestricted_Access
+ then
+ raise Program_Error;
end if;
if Count = 0 then
@@ -704,23 +656,12 @@ package body Ada.Containers.Doubly_Linke
New_Node : Node_Access;
begin
- if Before.Node /= null then
- if Before.Container /= List_Access'(Container'Unchecked_Access) then
- raise Program_Error;
- end if;
-
- pragma Assert (Container.Length > 0);
- pragma Assert (Container.First.Prev = null);
- pragma Assert (Container.Last.Next = null);
+ pragma Assert (Vet (Before), "bad cursor in Insert");
- pragma Assert (Before.Node.Prev = null
- or else Before.Node.Prev.Next = Before.Node);
- pragma Assert (Before.Node.Next = null
- or else Before.Node.Next.Prev = Before.Node);
- pragma Assert (Before.Node.Prev /= null
- or else Before.Node = Container.First);
- pragma Assert (Before.Node.Next /= null
- or else Before.Node = Container.Last);
+ if Before.Container /= null
+ and then Before.Container /= Container'Unrestricted_Access
+ then
+ raise Program_Error;
end if;
if Count = 0 then
@@ -853,6 +794,10 @@ package body Ada.Containers.Doubly_Linke
function Last_Element (Container : List) return Element_Type is
begin
+ if Container.Last = null then
+ raise Constraint_Error;
+ end if;
+
return Container.Last.Element;
end Last_Element;
@@ -900,25 +845,12 @@ package body Ada.Containers.Doubly_Linke
procedure Next (Position : in out Cursor) is
begin
+ pragma Assert (Vet (Position), "bad cursor in procedure Next");
+
if Position.Node = null then
- pragma Assert (Position.Container = null);
return;
end if;
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
Position.Node := Position.Node.Next;
if Position.Node = null then
@@ -928,25 +860,12 @@ package body Ada.Containers.Doubly_Linke
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;
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
declare
Next_Node : constant Node_Access := Position.Node.Next;
begin
@@ -977,25 +896,12 @@ package body Ada.Containers.Doubly_Linke
procedure Previous (Position : in out Cursor) is
begin
+ pragma Assert (Vet (Position), "bad cursor in procedure Previous");
+
if Position.Node = null then
- pragma Assert (Position.Container = null);
return;
end if;
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
Position.Node := Position.Node.Prev;
if Position.Node = null then
@@ -1005,25 +911,12 @@ package body Ada.Containers.Doubly_Linke
function Previous (Position : Cursor) return Cursor is
begin
+ pragma Assert (Vet (Position), "bad cursor in function Previous");
+
if Position.Node = null then
- pragma Assert (Position.Container = null);
return No_Element;
end if;
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
declare
Prev_Node : constant Node_Access := Position.Node.Prev;
begin
@@ -1043,42 +936,34 @@ package body Ada.Containers.Doubly_Linke
(Position : Cursor;
Process : not null access procedure (Element : in Element_Type))
is
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
- E : Element_Type renames Position.Node.Element;
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
- C : List renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
- begin
- B := B + 1;
- L := L + 1;
+ declare
+ C : List renames Position.Container.all'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.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;
----------
@@ -1141,29 +1026,18 @@ package body Ada.Containers.Doubly_Linke
(Position : Cursor;
By : Element_Type)
is
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
- E : Element_Type renames Position.Node.Element;
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
- begin
if Position.Container.Lock > 0 then
raise Program_Error;
end if;
- E := By;
+ Position.Node.Element := By;
end Replace_Element;
------------------
@@ -1180,23 +1054,13 @@ package body Ada.Containers.Doubly_Linke
begin
if Node = null then
Node := Container.Last;
+
else
- if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
+
+ if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
-
- pragma Assert (Container.Length > 0);
- pragma Assert (Container.First.Prev = null);
- pragma Assert (Container.Last.Next = null);
-
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Container.Last);
end if;
while Node /= null loop
@@ -1336,23 +1200,12 @@ package body Ada.Containers.Doubly_Linke
Source : in out List)
is
begin
- if Before.Node /= null then
- if Before.Container /= List_Access'(Target'Unchecked_Access) then
- raise Program_Error;
- end if;
-
- pragma Assert (Target.Length >= 1);
- pragma Assert (Target.First.Prev = null);
- pragma Assert (Target.Last.Next = null);
+ pragma Assert (Vet (Before), "bad cursor in Splice");
- pragma Assert (Before.Node.Prev = null
- or else Before.Node.Prev.Next = Before.Node);
- pragma Assert (Before.Node.Next = null
- or else Before.Node.Next.Prev = Before.Node);
- pragma Assert (Before.Node.Prev /= null
- or else Before.Node = Target.First);
- pragma Assert (Before.Node.Next /= null
- or else Before.Node = Target.Last);
+ if Before.Container /= null
+ and then Before.Container /= Target'Unrestricted_Access
+ then
+ raise Program_Error;
end if;
if Target'Address = Source'Address
@@ -1421,46 +1274,23 @@ package body Ada.Containers.Doubly_Linke
Position : Cursor)
is
begin
- if Before.Node /= null then
- if Before.Container /= List_Access'(Target'Unchecked_Access) then
- raise Program_Error;
- end if;
-
- pragma Assert (Target.Length >= 1);
- pragma Assert (Target.First.Prev = null);
- pragma Assert (Target.Last.Next = null);
+ pragma Assert (Vet (Before), "bad Before cursor in Splice");
+ pragma Assert (Vet (Position), "bad Position cursor in Splice");
- pragma Assert (Before.Node.Prev = null
- or else Before.Node.Prev.Next = Before.Node);
- pragma Assert (Before.Node.Next = null
- or else Before.Node.Next.Prev = Before.Node);
- pragma Assert (Before.Node.Prev /= null
- or else Before.Node = Target.First);
- pragma Assert (Before.Node.Next /= null
- or else Before.Node = Target.Last);
+ if Before.Container /= null
+ and then Before.Container /= Target'Unchecked_Access
+ then
+ raise Program_Error;
end if;
if Position.Node = null then
raise Constraint_Error;
end if;
- if Position.Container /= List_Access'(Target'Unchecked_Access) then
+ if Position.Container /= Target'Unrestricted_Access then
raise Program_Error;
end if;
- pragma Assert (Target.Length >= 1);
- pragma Assert (Target.First.Prev = null);
- pragma Assert (Target.Last.Next = null);
-
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Target.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Target.Last);
-
if Position.Node = Before.Node
or else Position.Node.Next = Before.Node
then
@@ -1548,46 +1378,23 @@ package body Ada.Containers.Doubly_Linke
return;
end if;
- if Before.Node /= null then
- if Before.Container /= List_Access'(Target'Unchecked_Access) then
- raise Program_Error;
- end if;
-
- pragma Assert (Target.Length >= 1);
- pragma Assert (Target.First.Prev = null);
- pragma Assert (Target.Last.Next = null);
+ pragma Assert (Vet (Before), "bad Before cursor in Splice");
+ pragma Assert (Vet (Position), "bad Position cursor in Splice");
- pragma Assert (Before.Node.Prev = null
- or else Before.Node.Prev.Next = Before.Node);
- pragma Assert (Before.Node.Next = null
- or else Before.Node.Next.Prev = Before.Node);
- pragma Assert (Before.Node.Prev /= null
- or else Before.Node = Target.First);
- pragma Assert (Before.Node.Next /= null
- or else Before.Node = Target.Last);
+ if Before.Container /= null
+ and then Before.Container /= Target'Unrestricted_Access
+ then
+ raise Program_Error;
end if;
if Position.Node = null then
raise Constraint_Error;
end if;
- if Position.Container /= List_Access'(Source'Unchecked_Access) then
+ if Position.Container /= Source'Unrestricted_Access then
raise Program_Error;
end if;
- pragma Assert (Source.Length >= 1);
- pragma Assert (Source.First.Prev = null);
- pragma Assert (Source.Last.Next = null);
-
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Source.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Source.Last);
-
if Target.Length = Count_Type'Last then
raise Constraint_Error;
end if;
@@ -1600,12 +1407,14 @@ package body Ada.Containers.Doubly_Linke
if Position.Node = Source.First then
Source.First := Position.Node.Next;
- Source.First.Prev := null;
if Position.Node = Source.Last then
pragma Assert (Source.First = null);
pragma Assert (Source.Length = 1);
Source.Last := null;
+
+ else
+ Source.First.Prev := null;
end if;
elsif Position.Node = Source.Last then
@@ -1667,8 +1476,11 @@ package body Ada.Containers.Doubly_Linke
procedure Swap (I, J : Cursor) is
begin
- if I.Container = null
- or else J.Container = null
+ pragma Assert (Vet (I), "bad I cursor in Swap");
+ pragma Assert (Vet (J), "bad J cursor in Swap");
+
+ if I.Node = null
+ or else J.Node = null
then
raise Constraint_Error;
end if;
@@ -1677,51 +1489,22 @@ package body Ada.Containers.Doubly_Linke
raise Program_Error;
end if;
- declare
- C : List renames I.Container.all;
- begin
- pragma Assert (C.Length >= 1);
- pragma Assert (C.First.Prev = null);
- pragma Assert (C.Last.Next = null);
-
- pragma Assert (I.Node /= null);
- pragma Assert (I.Node.Prev = null
- or else I.Node.Prev.Next = I.Node);
- pragma Assert (I.Node.Next = null
- or else I.Node.Next.Prev = I.Node);
- pragma Assert (I.Node.Prev /= null
- or else I.Node = C.First);
- pragma Assert (I.Node.Next /= null
- or else I.Node = C.Last);
-
- if I.Node = J.Node then
- return;
- end if;
-
- pragma Assert (C.Length >= 2);
- pragma Assert (J.Node /= null);
- pragma Assert (J.Node.Prev = null
- or else J.Node.Prev.Next = J.Node);
- pragma Assert (J.Node.Next = null
- or else J.Node.Next.Prev = J.Node);
- pragma Assert (J.Node.Prev /= null
- or else J.Node = C.First);
- pragma Assert (J.Node.Next /= null
- or else J.Node = C.Last);
+ if I.Node = J.Node then
+ return;
+ end if;
- if C.Lock > 0 then
- raise Program_Error;
- end if;
+ if I.Container.Lock > 0 then
+ raise Program_Error;
+ end if;
- declare
- EI : Element_Type renames I.Node.Element;
- EJ : Element_Type renames J.Node.Element;
+ declare
+ EI : Element_Type renames I.Node.Element;
+ EJ : Element_Type renames J.Node.Element;
- EI_Copy : constant Element_Type := EI;
- begin
- EI := EJ;
- EJ := EI_Copy;
- end;
+ EI_Copy : constant Element_Type := EI;
+ begin
+ EI := EJ;
+ EJ := EI_Copy;
end;
end Swap;
@@ -1733,50 +1516,25 @@ package body Ada.Containers.Doubly_Linke
(Container : in out List;
I, J : Cursor) is
begin
- if I.Container = null
- or else J.Container = null
+ pragma Assert (Vet (I), "bad I cursor in Swap_Links");
+ pragma Assert (Vet (J), "bad J cursor in Swap_Links");
+
+ if I.Node = null
+ or else J.Node = null
then
raise Constraint_Error;
end if;
- if I.Container /= List_Access'(Container'Unchecked_Access) then
- raise Program_Error;
- end if;
-
- if J.Container /= I.Container then
+ if I.Container /= Container'Unrestricted_Access
+ or else I.Container /= J.Container
+ then
raise Program_Error;
end if;
- pragma Assert (Container.Length >= 1);
- pragma Assert (Container.First.Prev = null);
- pragma Assert (Container.Last.Next = null);
-
- pragma Assert (I.Node /= null);
- pragma Assert (I.Node.Prev = null
- or else I.Node.Prev.Next = I.Node);
- pragma Assert (I.Node.Next = null
- or else I.Node.Next.Prev = I.Node);
- pragma Assert (I.Node.Prev /= null
- or else I.Node = Container.First);
- pragma Assert (I.Node.Next /= null
- or else I.Node = Container.Last);
-
if I.Node = J.Node then
return;
end if;
- pragma Assert (Container.Length >= 2);
-
- pragma Assert (J.Node /= null);
- pragma Assert (J.Node.Prev = null
- or else J.Node.Prev.Next = J.Node);
- pragma Assert (J.Node.Next = null
- or else J.Node.Next.Prev = J.Node);
- pragma Assert (J.Node.Prev /= null
- or else J.Node = Container.First);
- pragma Assert (J.Node.Next /= null
- or else J.Node = Container.Last);
-
if Container.Busy > 0 then
raise Program_Error;
end if;
@@ -1813,45 +1571,176 @@ package body Ada.Containers.Doubly_Linke
procedure Update_Element
(Position : Cursor;
- Process : not null access procedure (Element : in out Element_Type)) is
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Update_Element");
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length >= 1);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
- E : Element_Type renames Position.Node.Element;
+ declare
+ C : List renames Position.Container.all'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
- C : List renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
+ begin
+ B := B + 1;
+ L := L + 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 Update_Element;
+
+ ---------
+ -- Vet --
+ ---------
+
+ function Vet (Position : Cursor) return Boolean is
begin
- B := B + 1;
- L := L + 1;
+ 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.Prev = Position.Node then
+ return False;
+ end if;
+
+ declare
+ L : List renames Position.Container.all;
begin
- Process (E);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
+ if L.Length = 0 then
+ return False;
+ end if;
- L := L - 1;
- B := B - 1;
- end Update_Element;
+ if L.First = null then
+ return False;
+ end if;
+
+ if L.Last = null then
+ return False;
+ end if;
+
+ if L.First.Prev /= null then
+ return False;
+ end if;
+
+ if L.Last.Next /= null then
+ return False;
+ end if;
+
+ if Position.Node.Prev = null
+ and then Position.Node /= L.First
+ then
+ return False;
+ end if;
+
+ if Position.Node.Next = null
+ and then Position.Node /= L.Last
+ then
+ return False;
+ end if;
+
+ if L.Length = 1 then
+ return L.First = L.Last;
+ end if;
+
+ if L.First = L.Last then
+ return False;
+ end if;
+
+ if L.First.Next = null then
+ return False;
+ end if;
+
+ if L.Last.Prev = null then
+ return False;
+ end if;
+
+ if L.First.Next.Prev /= L.First then
+ return False;
+ end if;
+
+ if L.Last.Prev.Next /= L.Last then
+ return False;
+ end if;
+
+ if L.Length = 2 then
+ if L.First.Next /= L.Last then
+ return False;
+ end if;
+
+ if L.Last.Prev /= L.First then
+ return False;
+ end if;
+
+ return True;
+ end if;
+
+ if L.First.Next = L.Last then
+ return False;
+ end if;
+
+ if L.Last.Prev = L.First then
+ return False;
+ end if;
+
+ if Position.Node = L.First then
+ return True;
+ end if;
+
+ if Position.Node = L.Last then
+ return True;
+ end if;
+
+ if Position.Node.Next = null then
+ return False;
+ end if;
+
+ if Position.Node.Prev = null then
+ return False;
+ end if;
+
+ if Position.Node.Next.Prev /= Position.Node then
+ return False;
+ end if;
+
+ if Position.Node.Prev.Next /= Position.Node then
+ return False;
+ end if;
+
+ if L.Length = 3 then
+ if L.First.Next /= Position.Node then
+ return False;
+ end if;
+
+ if L.Last.Prev /= Position.Node then
+ return False;
+ end if;
+ end if;
+
+ return True;
+ end;
+ end Vet;
-----------
-- Write --
Index: a-cidlli.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-cidlli.adb,v
retrieving revision 1.3
diff -u -p -r1.3 a-cidlli.adb
--- a-cidlli.adb 1 Jul 2005 01:22:36 -0000 1.3
+++ a-cidlli.adb 5 Sep 2005 07:32:10 -0000
@@ -40,20 +40,21 @@ with Ada.Unchecked_Deallocation;
package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Free is
- new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
-
- procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
-----------------------
-- Local Subprograms --
-----------------------
+ procedure Free (X : in out Node_Access);
+
procedure Insert_Internal
(Container : in out List;
Before : Node_Access;
New_Node : Node_Access);
+ function Vet (Position : Cursor) return Boolean;
+
---------
-- "=" --
---------
@@ -188,18 +189,8 @@ package body Ada.Containers.Indefinite_D
Container.First := X.Next;
Container.First.Prev := null;
- Container.Length := Container.Length - 1;
-
- X.Next := null; -- prevent mischief
- begin
- Free (X.Element);
- exception
- when others =>
- X.Element := null;
- Free (X);
- raise;
- end;
+ Container.Length := Container.Length - 1;
Free (X);
end loop;
@@ -211,15 +202,6 @@ package body Ada.Containers.Indefinite_D
Container.Last := null;
Container.Length := 0;
- begin
- Free (X.Element);
- exception
- when others =>
- X.Element := null;
- Free (X);
- raise;
- end;
-
Free (X);
end Clear;
@@ -246,28 +228,16 @@ package body Ada.Containers.Indefinite_D
X : Node_Access;
begin
+ pragma Assert (Vet (Position), "bad cursor in Delete");
+
if Position.Node = null then
raise Constraint_Error;
end if;
- if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
- pragma Assert (Container.Length > 0);
- pragma Assert (Container.First.Prev = null);
- pragma Assert (Container.Last.Next = null);
-
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Container.Last);
-
if Position.Node = Container.First then
Delete_First (Container, Count);
Position := First (Container);
@@ -292,17 +262,6 @@ package body Ada.Containers.Indefinite_D
Container.Last := X.Prev;
Container.Last.Next := null;
- X.Prev := null; -- prevent mischief
-
- begin
- Free (X.Element);
- exception
- when others =>
- X.Element := null;
- Free (X);
- raise;
- end;
-
Free (X);
return;
end if;
@@ -312,18 +271,6 @@ package body Ada.Containers.Indefinite_D
X.Next.Prev := X.Prev;
X.Prev.Next := X.Next;
- X.Prev := null;
- X.Next := null;
-
- begin
- Free (X.Element);
- exception
- when others =>
- X.Element := null;
- Free (X);
- raise;
- end;
-
Free (X);
end loop;
end Delete;
@@ -361,17 +308,6 @@ package body Ada.Containers.Indefinite_D
Container.Length := Container.Length - 1;
- X.Next := null; -- prevent mischief
-
- begin
- Free (X.Element);
- exception
- when others =>
- X.Element := null;
- Free (X);
- raise;
- end;
-
Free (X);
end loop;
end Delete_First;
@@ -409,17 +345,6 @@ package body Ada.Containers.Indefinite_D
Container.Length := Container.Length - 1;
- X.Prev := null; -- prevent mischief
-
- begin
- Free (X.Element);
- exception
- when others =>
- X.Element := null;
- Free (X);
- raise;
- end;
-
Free (X);
end loop;
end Delete_Last;
@@ -430,21 +355,11 @@ package body Ada.Containers.Indefinite_D
function Element (Position : Cursor) return Element_Type is
begin
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node /= null);
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
+ pragma Assert (Vet (Position), "bad cursor in Element");
+
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
return Position.Node.Element.all;
end Element;
@@ -465,23 +380,11 @@ package body Ada.Containers.Indefinite_D
Node := Container.First;
else
- if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ pragma Assert (Vet (Position), "bad cursor in Find");
+
+ if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
-
- pragma Assert (Container.Length > 0);
- pragma Assert (Container.First.Prev = null);
- pragma Assert (Container.Last.Next = null);
-
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Container.Last);
end if;
while Node /= null loop
@@ -514,9 +417,37 @@ package body Ada.Containers.Indefinite_D
function First_Element (Container : List) return Element_Type is
begin
+ if Container.First = null then
+ raise Constraint_Error;
+ end if;
+
return Container.First.Element.all;
end First_Element;
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Node_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ begin
+ X.Next := X;
+ X.Prev := X;
+
+ begin
+ Free (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ Deallocate (X);
+ raise;
+ end;
+
+ Deallocate (X);
+ end Free;
+
---------------------
-- Generic_Sorting --
---------------------
@@ -686,27 +617,8 @@ package body Ada.Containers.Indefinite_D
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 (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
- return True;
+ pragma Assert (Vet (Position), "bad cursor in Has_Element");
+ return Position.Node /= null;
end Has_Element;
------------
@@ -723,24 +635,12 @@ package body Ada.Containers.Indefinite_D
New_Node : Node_Access;
begin
- if Before.Node /= null then
- if Before.Container /= List_Access'(Container'Unchecked_Access) then
- raise Program_Error;
- end if;
+ pragma Assert (Vet (Before), "bad cursor in Insert");
- pragma Assert (Container.Length > 0);
- pragma Assert (Container.First.Prev = null);
- pragma Assert (Container.Last.Next = null);
-
- pragma Assert (Before.Node.Element /= null);
- pragma Assert (Before.Node.Prev = null
- or else Before.Node.Prev.Next = Before.Node);
- pragma Assert (Before.Node.Next = null
- or else Before.Node.Next.Prev = Before.Node);
- pragma Assert (Before.Node.Prev /= null
- or else Before.Node = Container.First);
- pragma Assert (Before.Node.Next /= null
- or else Before.Node = Container.Last);
+ if Before.Container /= null
+ and then Before.Container /= Container'Unrestricted_Access
+ then
+ raise Program_Error;
end if;
if Count = 0 then
@@ -884,32 +784,6 @@ package body Ada.Containers.Indefinite_D
end Iterate;
----------
- -- Move --
- ----------
-
- procedure Move (Target : in out List; Source : in out List) is
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Source.Busy > 0 then
- raise Program_Error;
- end if;
-
- Clear (Target);
-
- Target.First := Source.First;
- Source.First := null;
-
- Target.Last := Source.Last;
- Source.Last := null;
-
- Target.Length := Source.Length;
- Source.Length := 0;
- end Move;
-
- ----------
-- Last --
----------
@@ -928,6 +802,10 @@ package body Ada.Containers.Indefinite_D
function Last_Element (Container : List) return Element_Type is
begin
+ if Container.Last = null then
+ raise Constraint_Error;
+ end if;
+
return Container.Last.Element.all;
end Last_Element;
@@ -941,31 +819,43 @@ package body Ada.Containers.Indefinite_D
end Length;
----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out List; Source : in out List) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Busy > 0 then
+ raise Program_Error;
+ end if;
+
+ Clear (Target);
+
+ Target.First := Source.First;
+ Source.First := null;
+
+ Target.Last := Source.Last;
+ Source.Last := null;
+
+ Target.Length := Source.Length;
+ Source.Length := 0;
+ end Move;
+
+ ----------
-- Next --
----------
procedure Next (Position : in out Cursor) is
begin
+ pragma Assert (Vet (Position), "bad cursor in procedure Next");
+
if Position.Node = null then
- pragma Assert (Position.Container = null);
return;
end if;
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
Position.Node := Position.Node.Next;
if Position.Node = null then
@@ -975,26 +865,12 @@ package body Ada.Containers.Indefinite_D
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;
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
declare
Next_Node : constant Node_Access := Position.Node.Next;
begin
@@ -1025,26 +901,12 @@ package body Ada.Containers.Indefinite_D
procedure Previous (Position : in out Cursor) is
begin
+ pragma Assert (Vet (Position), "bad cursor in procedure Previous");
+
if Position.Node = null then
- pragma Assert (Position.Container = null);
return;
end if;
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
Position.Node := Position.Node.Prev;
if Position.Node = null then
@@ -1054,26 +916,12 @@ package body Ada.Containers.Indefinite_D
function Previous (Position : Cursor) return Cursor is
begin
+ pragma Assert (Vet (Position), "bad cursor in function Previous");
+
if Position.Node = null then
- pragma Assert (Position.Container = null);
return No_Element;
end if;
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
declare
Prev_Node : constant Node_Access := Position.Node.Prev;
begin
@@ -1093,43 +941,34 @@ package body Ada.Containers.Indefinite_D
(Position : Cursor;
Process : not null access procedure (Element : in Element_Type))
is
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node /= null);
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
-
- E : Element_Type renames Position.Node.Element.all;
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
- C : List renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
- begin
- B := B + 1;
- L := L + 1;
+ declare
+ C : List renames Position.Container.all'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.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;
----------
@@ -1193,31 +1032,23 @@ package body Ada.Containers.Indefinite_D
(Position : Cursor;
By : Element_Type)
is
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node /= null);
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
- X : Element_Access := Position.Node.Element;
+ if Position.Container = null then
+ raise Constraint_Error;
+ end if;
- begin
if Position.Container.Lock > 0 then
raise Program_Error;
end if;
- Position.Node.Element := new Element_Type'(By);
- Free (X);
+ declare
+ X : Element_Access := Position.Node.Element;
+ begin
+ Position.Node.Element := new Element_Type'(By);
+ Free (X);
+ end;
end Replace_Element;
------------------
@@ -1236,23 +1067,11 @@ package body Ada.Containers.Indefinite_D
Node := Container.Last;
else
- if Position.Container /= List_Access'(Container'Unchecked_Access) then
+ pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
+
+ if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
end if;
-
- pragma Assert (Container.Length > 0);
- pragma Assert (Container.First.Prev = null);
- pragma Assert (Container.Last.Next = null);
-
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Container.Last);
end if;
while Node /= null loop
@@ -1392,24 +1211,12 @@ package body Ada.Containers.Indefinite_D
Source : in out List)
is
begin
- if Before.Node /= null then
- if Before.Container /= List_Access'(Target'Unchecked_Access) then
- raise Program_Error;
- end if;
+ pragma Assert (Vet (Before), "bad cursor in Splice");
- pragma Assert (Target.Length >= 1);
- pragma Assert (Target.First.Prev = null);
- pragma Assert (Target.Last.Next = null);
-
- pragma Assert (Before.Node.Element /= null);
- pragma Assert (Before.Node.Prev = null
- or else Before.Node.Prev.Next = Before.Node);
- pragma Assert (Before.Node.Next = null
- or else Before.Node.Next.Prev = Before.Node);
- pragma Assert (Before.Node.Prev /= null
- or else Before.Node = Target.First);
- pragma Assert (Before.Node.Next /= null
- or else Before.Node = Target.Last);
+ if Before.Container /= null
+ and then Before.Container /= Target'Unrestricted_Access
+ then
+ raise Program_Error;
end if;
if Target'Address = Source'Address
@@ -1477,48 +1284,23 @@ package body Ada.Containers.Indefinite_D
Position : Cursor)
is
begin
- if Before.Node /= null then
- if Before.Container /= List_Access'(Target'Unchecked_Access) then
- raise Program_Error;
- end if;
-
- pragma Assert (Target.Length >= 1);
- pragma Assert (Target.First.Prev = null);
- pragma Assert (Target.Last.Next = null);
+ pragma Assert (Vet (Before), "bad Before cursor in Splice");
+ pragma Assert (Vet (Position), "bad Position cursor in Splice");
- pragma Assert (Before.Node.Element /= null);
- pragma Assert (Before.Node.Prev = null
- or else Before.Node.Prev.Next = Before.Node);
- pragma Assert (Before.Node.Next = null
- or else Before.Node.Next.Prev = Before.Node);
- pragma Assert (Before.Node.Prev /= null
- or else Before.Node = Target.First);
- pragma Assert (Before.Node.Next /= null
- or else Before.Node = Target.Last);
+ if Before.Container /= null
+ and then Before.Container /= Target'Unchecked_Access
+ then
+ raise Program_Error;
end if;
if Position.Node = null then
raise Constraint_Error;
end if;
- if Position.Container /= List_Access'(Target'Unchecked_Access) then
+ if Position.Container /= Target'Unrestricted_Access then
raise Program_Error;
end if;
- pragma Assert (Target.Length >= 1);
- pragma Assert (Target.First.Prev = null);
- pragma Assert (Target.Last.Next = null);
-
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Target.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Target.Last);
-
if Position.Node = Before.Node
or else Position.Node.Next = Before.Node
then
@@ -1606,48 +1388,23 @@ package body Ada.Containers.Indefinite_D
return;
end if;
- if Before.Node /= null then
- if Before.Container /= List_Access'(Target'Unchecked_Access) then
- raise Program_Error;
- end if;
+ pragma Assert (Vet (Before), "bad Before cursor in Splice");
+ pragma Assert (Vet (Position), "bad Position cursor in Splice");
- pragma Assert (Target.Length >= 1);
- pragma Assert (Target.First.Prev = null);
- pragma Assert (Target.Last.Next = null);
-
- pragma Assert (Before.Node.Element /= null);
- pragma Assert (Before.Node.Prev = null
- or else Before.Node.Prev.Next = Before.Node);
- pragma Assert (Before.Node.Next = null
- or else Before.Node.Next.Prev = Before.Node);
- pragma Assert (Before.Node.Prev /= null
- or else Before.Node = Target.First);
- pragma Assert (Before.Node.Next /= null
- or else Before.Node = Target.Last);
+ if Before.Container /= null
+ and then Before.Container /= Target'Unrestricted_Access
+ then
+ raise Program_Error;
end if;
if Position.Node = null then
raise Constraint_Error;
end if;
- if Position.Container /= List_Access'(Source'Unchecked_Access) then
+ if Position.Container /= Source'Unrestricted_Access then
raise Program_Error;
end if;
- pragma Assert (Source.Length >= 1);
- pragma Assert (Source.First.Prev = null);
- pragma Assert (Source.Last.Next = null);
-
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Source.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Source.Last);
-
if Target.Length = Count_Type'Last then
raise Constraint_Error;
end if;
@@ -1660,12 +1417,14 @@ package body Ada.Containers.Indefinite_D
if Position.Node = Source.First then
Source.First := Position.Node.Next;
- Source.First.Prev := null;
if Position.Node = Source.Last then
pragma Assert (Source.First = null);
pragma Assert (Source.Length = 1);
Source.Last := null;
+
+ else
+ Source.First.Prev := null;
end if;
elsif Position.Node = Source.Last then
@@ -1727,8 +1486,11 @@ package body Ada.Containers.Indefinite_D
procedure Swap (I, J : Cursor) is
begin
- if I.Container = null
- or else J.Container = null
+ pragma Assert (Vet (I), "bad I cursor in Swap");
+ pragma Assert (Vet (J), "bad J cursor in Swap");
+
+ if I.Node = null
+ or else J.Node = null
then
raise Constraint_Error;
end if;
@@ -1737,50 +1499,19 @@ package body Ada.Containers.Indefinite_D
raise Program_Error;
end if;
- declare
- C : List renames I.Container.all;
- begin
- pragma Assert (C.Length > 0);
- pragma Assert (C.First.Prev = null);
- pragma Assert (C.Last.Next = null);
-
- pragma Assert (I.Node /= null);
- pragma Assert (I.Node.Element /= null);
- pragma Assert (I.Node.Prev = null
- or else I.Node.Prev.Next = I.Node);
- pragma Assert (I.Node.Next = null
- or else I.Node.Next.Prev = I.Node);
- pragma Assert (I.Node.Prev /= null
- or else I.Node = C.First);
- pragma Assert (I.Node.Next /= null
- or else I.Node = C.Last);
-
- if I.Node = J.Node then
- return;
- end if;
-
- pragma Assert (C.Length > 1);
- pragma Assert (J.Node /= null);
- pragma Assert (J.Node.Element /= null);
- pragma Assert (J.Node.Prev = null
- or else J.Node.Prev.Next = J.Node);
- pragma Assert (J.Node.Next = null
- or else J.Node.Next.Prev = J.Node);
- pragma Assert (J.Node.Prev /= null
- or else J.Node = C.First);
- pragma Assert (J.Node.Next /= null
- or else J.Node = C.Last);
+ if I.Node = J.Node then
+ return;
+ end if;
- if C.Lock > 0 then
- raise Program_Error;
- end if;
+ if I.Container.Lock > 0 then
+ raise Program_Error;
+ end if;
- declare
- EI_Copy : constant Element_Access := I.Node.Element;
- begin
- I.Node.Element := J.Node.Element;
- J.Node.Element := EI_Copy;
- end;
+ declare
+ EI_Copy : constant Element_Access := I.Node.Element;
+ begin
+ I.Node.Element := J.Node.Element;
+ J.Node.Element := EI_Copy;
end;
end Swap;
@@ -1793,51 +1524,25 @@ package body Ada.Containers.Indefinite_D
I, J : Cursor)
is
begin
- if I.Container = null
- or else J.Container = null
+ pragma Assert (Vet (I), "bad I cursor in Swap_Links");
+ pragma Assert (Vet (J), "bad J cursor in Swap_Links");
+
+ if I.Node = null
+ or else J.Node = null
then
raise Constraint_Error;
end if;
- if I.Container /= List_Access'(Container'Unchecked_Access) then
- raise Program_Error;
- end if;
-
- if J.Container /= I.Container then
+ if I.Container /= Container'Unrestricted_Access
+ or else I.Container /= J.Container
+ then
raise Program_Error;
end if;
- pragma Assert (Container.Length >= 1);
- pragma Assert (Container.First.Prev = null);
- pragma Assert (Container.Last.Next = null);
-
- pragma Assert (I.Node /= null);
- pragma Assert (I.Node.Element /= null);
- pragma Assert (I.Node.Prev = null
- or else I.Node.Prev.Next = I.Node);
- pragma Assert (I.Node.Next = null
- or else I.Node.Next.Prev = I.Node);
- pragma Assert (I.Node.Prev /= null
- or else I.Node = Container.First);
- pragma Assert (I.Node.Next /= null
- or else I.Node = Container.Last);
-
if I.Node = J.Node then
return;
end if;
- pragma Assert (Container.Length >= 2);
- pragma Assert (J.Node /= null);
- pragma Assert (J.Node.Element /= null);
- pragma Assert (J.Node.Prev = null
- or else J.Node.Prev.Next = J.Node);
- pragma Assert (J.Node.Next = null
- or else J.Node.Next.Prev = J.Node);
- pragma Assert (J.Node.Prev /= null
- or else J.Node = Container.First);
- pragma Assert (J.Node.Next /= null
- or else J.Node = Container.Last);
-
if Container.Busy > 0 then
raise Program_Error;
end if;
@@ -1878,44 +1583,178 @@ package body Ada.Containers.Indefinite_D
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
- pragma Assert (Position.Container /= null);
- pragma Assert (Position.Container.Length > 0);
- pragma Assert (Position.Container.First.Prev = null);
- pragma Assert (Position.Container.Last.Next = null);
-
- pragma Assert (Position.Node /= null);
- pragma Assert (Position.Node.Element /= null);
- pragma Assert (Position.Node.Prev = null
- or else Position.Node.Prev.Next = Position.Node);
- pragma Assert (Position.Node.Next = null
- or else Position.Node.Next.Prev = Position.Node);
- pragma Assert (Position.Node.Prev /= null
- or else Position.Node = Position.Container.First);
- pragma Assert (Position.Node.Next /= null
- or else Position.Node = Position.Container.Last);
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Update_Element");
- E : Element_Type renames Position.Node.Element.all;
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
- C : List renames Position.Container.all'Unrestricted_Access.all;
- B : Natural renames C.Busy;
- L : Natural renames C.Lock;
+ declare
+ C : List renames Position.Container.all'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+ begin
+ B := B + 1;
+ L := L + 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 Update_Element;
+
+ ---------
+ -- Vet --
+ ---------
+
+ function Vet (Position : Cursor) return Boolean is
begin
- B := B + 1;
- L := L + 1;
+ 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.Prev = Position.Node then
+ return False;
+ end if;
+
+ if Position.Node.Element = null then
+ return False;
+ end if;
+
+ declare
+ L : List renames Position.Container.all;
begin
- Process (E);
- exception
- when others =>
- L := L - 1;
- B := B - 1;
- raise;
- end;
+ if L.Length = 0 then
+ return False;
+ end if;
- L := L - 1;
- B := B - 1;
- end Update_Element;
+ if L.First = null then
+ return False;
+ end if;
+
+ if L.Last = null then
+ return False;
+ end if;
+
+ if L.First.Prev /= null then
+ return False;
+ end if;
+
+ if L.Last.Next /= null then
+ return False;
+ end if;
+
+ if Position.Node.Prev = null
+ and then Position.Node /= L.First
+ then
+ return False;
+ end if;
+
+ if Position.Node.Next = null
+ and then Position.Node /= L.Last
+ then
+ return False;
+ end if;
+
+ if L.Length = 1 then
+ return L.First = L.Last;
+ end if;
+
+ if L.First = L.Last then
+ return False;
+ end if;
+
+ if L.First.Next = null then
+ return False;
+ end if;
+
+ if L.Last.Prev = null then
+ return False;
+ end if;
+
+ if L.First.Next.Prev /= L.First then
+ return False;
+ end if;
+
+ if L.Last.Prev.Next /= L.Last then
+ return False;
+ end if;
+
+ if L.Length = 2 then
+ if L.First.Next /= L.Last then
+ return False;
+ end if;
+
+ if L.Last.Prev /= L.First then
+ return False;
+ end if;
+
+ return True;
+ end if;
+
+ if L.First.Next = L.Last then
+ return False;
+ end if;
+
+ if L.Last.Prev = L.First then
+ return False;
+ end if;
+
+ if Position.Node = L.First then
+ return True;
+ end if;
+
+ if Position.Node = L.Last then
+ return True;
+ end if;
+
+ if Position.Node.Next = null then
+ return False;
+ end if;
+
+ if Position.Node.Prev = null then
+ return False;
+ end if;
+
+ if Position.Node.Next.Prev /= Position.Node then
+ return False;
+ end if;
+
+ if Position.Node.Prev.Next /= Position.Node then
+ return False;
+ end if;
+
+ if L.Length = 3 then
+ if L.First.Next /= Position.Node then
+ return False;
+ end if;
+
+ if L.Last.Prev /= Position.Node then
+ return False;
+ end if;
+ end if;
+
+ return True;
+ end;
+ end Vet;
-----------
-- Write --
@@ -1926,8 +1765,10 @@ package body Ada.Containers.Indefinite_D
Item : List)
is
Node : Node_Access := Item.First;
+
begin
Count_Type'Base'Write (Stream, Item.Length);
+
while Node /= null loop
Element_Type'Output (Stream, Node.Element.all); -- X.all
Node := Node.Next;
Index: a-chtgop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-chtgop.adb,v
retrieving revision 1.3
diff -u -p -r1.3 a-chtgop.adb
--- a-chtgop.adb 1 Jul 2005 01:22:36 -0000 1.3
+++ a-chtgop.adb 5 Sep 2005 07:32:10 -0000
@@ -42,14 +42,6 @@ package body Ada.Containers.Hash_Tables.
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.
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.
+ Count_Type'Base'Read (Stream, N);
+ pragma Assert (N >= 0);
+
+ if N = 0 then
+ return;
+ end if;
- if Last /= 0 then
+ if HT.Buckets = null
+ or else HT.Buckets'Last /= Last
+ then
+ Free (HT.Buckets);
HT.Buckets := new Buckets_Type (0 .. Last);
end if;
- Count_Type'Base'Read (Stream, N);
- pragma Assert (N >= 0);
- while N > 0 loop
+ -- 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.
end loop;
N := N - M;
+
+ exit when N = 0;
end loop;
end Generic_Read;
@@ -481,6 +481,8 @@ package body Ada.Containers.Hash_Tables.
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.
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.
NN : Hash_Type;
begin
- if N = 0 then
- if HT.Length = 0 then
- Free (HT.Buckets);
+ 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;
- elsif HT.Length < HT.Buckets'Length then
- NN := Prime_Numbers.To_Prime (HT.Length);
+ return;
+ end if;
- -- ASSERT: NN >= HT.Length
+ if HT.Length = 0 then
+ if N = 0 then
+ Free (HT.Buckets);
+ return;
+ end if;
- if NN < HT.Buckets'Length then
- if HT.Busy > 0 then
- raise Program_Error;
- end if;
+ if N = HT.Buckets'Length then
+ return;
+ end if;
- Rehash (HT, Size => NN);
- end if;
+ NN := Prime_Numbers.To_Prime (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;
+
return;
end if;
- if HT.Buckets = null then
- NN := Prime_Numbers.To_Prime (N);
-
- -- ASSERT: NN >= N
-
- Rehash (HT, Size => NN);
+ if N = HT.Buckets'Length then
return;
end if;
- if N <= HT.Length then
+ 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
+ return;
+ end if;
- if NN < HT.Buckets'Length then
- if HT.Busy > 0 then
- raise Program_Error;
- end if;
+ else
+ NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
- Rehash (HT, Size => NN);
+ if NN = HT.Buckets'Length then -- can't expand any more
+ return;
end if;
+ end if;
- return;
+ if HT.Busy > 0 then
+ raise Program_Error;
end if;
- -- ASSERT: N > HT.Length
+ Rehash : declare
+ Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1);
+ Src_Buckets : Buckets_Access := HT.Buckets;
- if N = HT.Buckets'Length then
- return;
- end if;
+ L : Count_Type renames HT.Length;
+ LL : constant Count_Type := L;
- NN := Prime_Numbers.To_Prime (N);
+ Src_Index : Hash_Type := Src_Buckets'First;
- -- ASSERT: NN >= N
- -- ASSERT: NN > HT.Length
+ begin
+ while L > 0 loop
+ declare
+ Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
- if NN /= HT.Buckets'Length then
- if HT.Busy > 0 then
- raise Program_Error;
- end if;
+ 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;
- Rehash (HT, Size => NN);
- end if;
+ 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;
Index: a-cihase.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-cihase.ads,v
retrieving revision 1.3
diff -u -p -r1.3 a-cihase.ads
--- a-cihase.ads 1 Jul 2005 01:22:36 -0000 1.3
+++ a-cihase.ads 5 Sep 2005 07:32:10 -0000
@@ -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
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
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,37 +102,11 @@ package Ada.Containers.Indefinite_Hashed
procedure Replace (Container : in out Set; New_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 Delete (Container : in out Set; Item : Element_Type);
- procedure Iterate
- (Container : Set;
- Process : not null access procedure (Position : Cursor));
+ procedure Delete (Container : in out Set; Position : in out Cursor);
procedure Union (Target : in out Set; Source : Set);
@@ -158,41 +137,59 @@ package Ada.Containers.Indefinite_Hashed
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
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
Index: a-cohase.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-cohase.adb,v
retrieving revision 1.3
diff -u -p -r1.3 a-cohase.adb
--- a-cohase.adb 1 Jul 2005 01:22:37 -0000 1.3
+++ a-cohase.adb 5 Sep 2005 07:32:10 -0000
@@ -67,6 +67,8 @@ package body Ada.Containers.Hashed_Sets
(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
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
-- 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
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
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
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
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
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
-- Start of processing for Insert
begin
- if HT.Length >= HT_Ops.Capacity (HT) then
+ if HT_Ops.Capacity (HT) = 0 then
+ HT_Ops.Reserve_Capacity (HT, 1);
+ end if;
- -- 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.
+ Local_Insert (HT, New_Item, Position.Node, Inserted);
- HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
+ if Inserted
+ and then HT.Length > HT_Ops.Capacity (HT)
+ then
+ HT_Ops.Reserve_Capacity (HT, HT.Length);
end if;
- Local_Insert (HT, New_Item, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
@@ -725,7 +765,7 @@ package body Ada.Containers.Hashed_Sets
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
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;
-
- begin
- Iterate (HT);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
+ -- TODO: resolve whether HT_Ops.Generic_Iteration should
+ -- manipulate busy bit.
- B := B - 1;
+ Iterate (Container.HT);
end Iterate;
------------
@@ -838,8 +868,9 @@ package body Ada.Containers.Hashed_Sets
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
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
- E : Element_Type renames Position.Node.Element;
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
- HT : Hash_Table_Type renames Position.Container.HT;
+ if Position.Node = null then
+ raise Constraint_Error;
+ end if;
- B : Natural renames HT.Busy;
- L : Natural renames HT.Lock;
+ declare
+ HT : Hash_Table_Type renames Position.Container.HT;
- begin
- B := B + 1;
- L := L + 1;
+ 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
-------------
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
---------------------
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
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
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
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
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
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
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
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
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;
Index: a-cohase.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-cohase.ads,v
retrieving revision 1.3
diff -u -p -r1.3 a-cohase.ads
--- a-cohase.ads 1 Jul 2005 01:22:37 -0000 1.3
+++ a-cohase.ads 5 Sep 2005 07:32:10 -0000
@@ -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,39 +99,11 @@ pragma Preelaborate (Hashed_Sets);
procedure Replace (Container : in out Set; New_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 Delete (Container : in out Set; Item : Element_Type);
- procedure Iterate
- (Container : Set;
- Process : not null access procedure (Position : Cursor));
+ procedure Delete (Container : in out Set; Position : in out Cursor);
procedure Union (Target : in out Set; Source : 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;
More information about the Gcc-patches
mailing list