summaryrefslogtreecommitdiffstats
path: root/gcc/ada
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2006-02-15 09:32:52 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2006-02-15 09:32:52 +0000
commita6588f4f32ec59846a4d5ae481510e01bd4604ff (patch)
tree39a55d293e0dcbbc8992be624d0eb85bc7be0307 /gcc/ada
parente11441b606ae5dbf70d412effa06b036e897e5d3 (diff)
downloadppe42-gcc-a6588f4f32ec59846a4d5ae481510e01bd4604ff.tar.gz
ppe42-gcc-a6588f4f32ec59846a4d5ae481510e01bd4604ff.zip
2006-02-13 Matthew Heaney <heaney@adacore.com>
* a-rbtgso.adb, a-crbtgo.adb, a-crbtgk.adb, a-coorse.adb, a-cohama.adb, a-ciorse.adb, a-cihama.adb, a-cihase.adb, a-cohase.adb: All explicit raise statements now include an exception message. * a-ciormu.ads, a-ciormu.adb, a-coormu.ads, a-coormu.adb (Update_Element_Preserving_Key): renamed op to just Update_Element. Explicit raise statements now include an exception message * a-cihase.ads, a-cohase.ads: Removed comment. * a-stboha.ads, a-stboha.adb, a-stfiha.ads, a-envvar.adb, a-envvar.ads, a-swbwha.ads, a-swbwha.adb, a-swfwha.ads, a-szbzha.ads, a-szbzha.adb, a-szfzha.ads: New files. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@111035 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/a-cihama.adb147
-rw-r--r--gcc/ada/a-cihase.adb187
-rw-r--r--gcc/ada/a-cihase.ads2
-rw-r--r--gcc/ada/a-ciormu.adb200
-rw-r--r--gcc/ada/a-ciormu.ads4
-rw-r--r--gcc/ada/a-ciorse.adb135
-rw-r--r--gcc/ada/a-cohama.adb112
-rw-r--r--gcc/ada/a-cohase.adb151
-rw-r--r--gcc/ada/a-cohase.ads2
-rw-r--r--gcc/ada/a-coormu.adb149
-rw-r--r--gcc/ada/a-coormu.ads4
-rw-r--r--gcc/ada/a-coorse.adb87
-rw-r--r--gcc/ada/a-crbtgk.adb13
-rw-r--r--gcc/ada/a-crbtgo.adb13
-rwxr-xr-xgcc/ada/a-envvar.adb228
-rwxr-xr-xgcc/ada/a-envvar.ads61
-rw-r--r--gcc/ada/a-rbtgso.adb15
-rw-r--r--gcc/ada/a-stboha.adb57
-rw-r--r--gcc/ada/a-stboha.ads25
-rw-r--r--gcc/ada/a-stfiha.ads21
-rw-r--r--gcc/ada/a-swbwha.adb59
-rw-r--r--gcc/ada/a-swbwha.ads25
-rw-r--r--gcc/ada/a-swfwha.ads22
-rw-r--r--gcc/ada/a-szbzha.adb60
-rw-r--r--gcc/ada/a-szbzha.ads27
-rw-r--r--gcc/ada/a-szfzha.ads23
26 files changed, 1342 insertions, 487 deletions
diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb
index 3a78e8eab0d..04c9c6b0e76 100644
--- a/gcc/ada/a-cihama.adb
+++ b/gcc/ada/a-cihama.adb
@@ -186,7 +186,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
if X = null then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete key not in map";
end if;
Free (X);
@@ -194,20 +194,23 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
- pragma Assert (Vet (Position), "bad cursor in Delete");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of Delete equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor of Delete designates wrong map";
end if;
if Container.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "Delete attempted to tamper with elements (map is busy)";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Delete");
+
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
Free (Position.Node);
@@ -223,7 +226,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "no element available because key not in map";
end if;
return Node.Element.all;
@@ -231,16 +235,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Element (Position : Cursor) return Element_Type is
begin
- pragma Assert (Vet (Position), "bad cursor in function Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of function Element equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor of function Element is bad";
end if;
+ pragma Assert (Vet (Position), "bad cursor in function Element");
+
return Position.Node.Element.all;
end Element;
@@ -262,21 +268,29 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Equivalent_Keys (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 then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Keys equals No_Element";
+ end if;
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Right.Node = null then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Keys equals No_Element";
end if;
- if Left.Node.Key = null
- or else Right.Node.Key = null
- then
- raise Program_Error;
+ if Left.Node.Key = null then
+ raise Program_Error with
+ "Left cursor of Equivalent_Keys is bad";
+ end if;
+
+ if Right.Node.Key = null then
+ raise Program_Error with
+ "Right cursor of Equivalent_Keys is bad";
end if;
+ pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
+ pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
+
return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
end Equivalent_Keys;
@@ -285,16 +299,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Right : Key_Type) return Boolean
is
begin
- pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
-
if Left.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Keys equals No_Element";
end if;
if Left.Node.Key = null then
- raise Program_Error;
+ raise Program_Error with
+ "Left cursor of Equivalent_Keys is bad";
end if;
+ pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
+
return Equivalent_Keys (Left.Node.Key.all, Right);
end Equivalent_Keys;
@@ -303,16 +319,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Right : Cursor) return Boolean
is
begin
- pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
-
if Right.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Keys equals No_Element";
end if;
if Right.Node.Key = null then
- raise Program_Error;
+ raise Program_Error with
+ "Right cursor of Equivalent_Keys is bad";
end if;
+ pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
+
return Equivalent_Keys (Left, Right.Node.Key.all);
end Equivalent_Keys;
@@ -472,7 +490,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
if not Inserted then
if Container.HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "Include attempted to tamper with cursors (map is locked)";
end if;
K := Position.Node.Key;
@@ -559,7 +578,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to insert key already in map";
end if;
end Insert;
@@ -607,16 +627,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Key (Position : Cursor) return Key_Type is
begin
- pragma Assert (Vet (Position), "bad cursor in function Key");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of function Key equals No_Element";
end if;
if Position.Node.Key = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor of function Key is bad";
end if;
+ pragma Assert (Vet (Position), "bad cursor in function Key");
+
return Position.Node.Key.all;
end Key;
@@ -657,8 +679,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Next (Position : Cursor) return Cursor is
begin
- pragma Assert (Vet (Position), "bad cursor in function Next");
-
if Position.Node = null then
return No_Element;
end if;
@@ -666,9 +686,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
if Position.Node.Key = null
or else Position.Node.Element = null
then
- raise Program_Error;
+ raise Program_Error with "Position cursor of Next is bad";
end if;
+ pragma Assert (Vet (Position), "Position cursor of Next is bad");
+
declare
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
@@ -692,18 +714,20 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Element : Element_Type))
is
begin
- pragma Assert (Vet (Position), "bad cursor in Query_Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of Query_Element equals No_Element";
end if;
if Position.Node.Key = null
or else Position.Node.Element = null
then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor of Query_Element is bad";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
+
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
@@ -752,7 +776,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream map cursor";
end Read;
---------------
@@ -801,11 +825,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to replace key not in map";
end if;
if Container.HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "Replace attempted to tamper with cursors (map is locked)";
end if;
K := Node.Key;
@@ -835,26 +861,30 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
New_Item : Element_Type)
is
begin
- pragma Assert (Vet (Position), "bad cursor in Replace_Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of Replace_Element equals No_Element";
end if;
if Position.Node.Key = null
or else Position.Node.Element = null
then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor of Replace_Element is bad";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor of Replace_Element designates wrong map";
end if;
if Position.Container.HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "Replace_Element attempted to tamper with cursors (map is locked)";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
+
declare
X : Element_Access := Position.Node.Element;
@@ -896,22 +926,25 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Element : in out Element_Type))
is
begin
- pragma Assert (Vet (Position), "bad cursor in Update_Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of Update_Element equals No_Element";
end if;
if Position.Node.Key = null
or else Position.Node.Element = null
then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor of Update_Element is bad";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor of Update_Element designates wrong map";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Update_Element");
+
declare
HT : Hash_Table_Type renames Container.HT;
@@ -1021,7 +1054,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream map cursor";
end Write;
----------------
diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb
index 9503e8859a2..0bb8cb73f75 100644
--- a/gcc/ada/a-cihase.adb
+++ b/gcc/ada/a-cihase.adb
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -42,10 +42,10 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
with Ada.Containers.Hash_Tables.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
-with System; use type System.Address;
-
with Ada.Containers.Prime_Numbers;
+with System; use type System.Address;
+
package body Ada.Containers.Indefinite_Hashed_Sets is
-----------------------
@@ -214,7 +214,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
if X = null then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete element not in set";
end if;
Free (X);
@@ -225,24 +225,25 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Position : in out Cursor)
is
begin
- pragma Assert (Vet (Position), "bad cursor in Delete");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with "Position cursor designates wrong set";
end if;
if Container.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
+ pragma Assert (Vet (Position), "Position cursor is bad");
+
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
Free (Position.Node);
@@ -270,7 +271,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end if;
if Target.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
-- TODO: This can be written in terms of a loop instead as
@@ -367,16 +369,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Element (Position : Cursor) return Element_Type is
begin
- pragma Assert (Vet (Position), "bad cursor in function Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor of equals No_Element";
end if;
if Position.Node.Element = null then -- handle dangling reference
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad";
end if;
+ pragma Assert (Vet (Position), "bad cursor in function Element");
+
return Position.Node.Element.all;
end Element;
@@ -396,21 +398,29 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Equivalent_Elements (Left, Right : Cursor)
return Boolean is
begin
- pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
- pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
+ if Left.Node = null then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Elements equals No_Element";
+ end if;
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Right.Node = null then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Elements equals No_Element";
end if;
- if Left.Node.Element = null -- handle dangling cursor reference
- or else Right.Node.Element = null
- then
- raise Program_Error;
+ if Left.Node.Element = null then
+ raise Program_Error with
+ "Left cursor of Equivalent_Elements is bad";
end if;
+ if Right.Node.Element = null then
+ raise Program_Error with
+ "Right cursor of Equivalent_Elements is bad";
+ end if;
+
+ pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
+ pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
+
return Equivalent_Elements
(Left.Node.Element.all,
Right.Node.Element.all);
@@ -419,32 +429,36 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Equivalent_Elements (Left : Cursor; Right : Element_Type)
return Boolean is
begin
- pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
-
if Left.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Elements equals No_Element";
end if;
- if Left.Node.Element = null then -- handling dangling reference
- raise Program_Error;
+ if Left.Node.Element = null then
+ raise Program_Error with
+ "Left cursor of Equivalent_Elements is bad";
end if;
+ pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
+
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;
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Elements equals No_Element";
end if;
- if Right.Node.Element = null then -- handle dangling cursor reference
- raise Program_Error;
+ if Right.Node.Element = null then
+ raise Program_Error with
+ "Right cursor of Equivalent_Elements is bad";
end if;
+ pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
+
return Equivalent_Elements (Left, Right.Node.Element.all);
end Equivalent_Elements;
@@ -632,7 +646,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
if not Inserted then
if Container.HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
X := Position.Node.Element;
@@ -669,7 +684,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to insert element already in set";
end if;
end Insert;
@@ -737,7 +753,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end if;
if Target.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
-- TODO: optimize this to use an explicit
@@ -951,16 +968,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Next (Position : Cursor) return Cursor is
begin
- pragma Assert (Vet (Position), "bad cursor in function Next");
-
if Position.Node = null then
return No_Element;
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "bad cursor in Next";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Next");
+
declare
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
@@ -1016,16 +1033,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Process : not null access procedure (Element : Element_Type))
is
begin
- pragma Assert (Vet (Position), "bad cursor in Query_Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of Query_Element equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "bad cursor in Query_Element";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
+
declare
HT : Hash_Table_Type renames
Position.Container'Unrestricted_Access.all.HT;
@@ -1068,7 +1086,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
---------------
@@ -1103,11 +1121,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to replace element not in set";
end if;
if Container.HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
X := Node.Element;
@@ -1131,7 +1151,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
pragma Assert (Hash (Node.Element.all) = Hash (New_Item));
if HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
declare
@@ -1145,7 +1166,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end if;
if HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
HT_Ops.Delete_Node_Sans_Free (HT, Node);
@@ -1227,7 +1249,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
null;
end Reinsert_Old_Element;
- raise Program_Error;
+ raise Program_Error with "attempt to replace existing element";
end Replace_Element;
procedure Replace_Element
@@ -1236,20 +1258,21 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
New_Item : Element_Type)
is
begin
- pragma Assert (Vet (Position), "bad cursor in Replace_Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "bad cursor in Replace_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong set";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
+
Replace_Element (Container.HT, Position.Node, New_Item);
end Replace_Element;
@@ -1289,7 +1312,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end if;
if Target.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
declare
@@ -1605,7 +1629,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
end if;
if Target.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
declare
@@ -1808,7 +1833,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
----------------
@@ -1873,7 +1898,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
if X = null then
- raise Constraint_Error;
+ raise Constraint_Error with "key not in map";
end if;
Free (X);
@@ -1888,7 +1913,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Key : Key_Type) return Element_Type
is
Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
+
begin
+ if Node = null then
+ raise Constraint_Error with "key not in map";
+ end if;
+
return Node.Element.all;
end Element;
@@ -1941,16 +1971,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
function Key (Position : Cursor) return Key_Type is
begin
- pragma Assert (Vet (Position), "bad cursor in function Key");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad";
end if;
+ pragma Assert (Vet (Position), "bad cursor in function Key");
+
return Key (Position.Node.Element.all);
end Key;
@@ -1968,7 +1999,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to replace key not in set";
end if;
Replace_Element (Container.HT, Node, New_Item);
@@ -1976,7 +2008,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
procedure Update_Element_Preserving_Key
(Container : in out Set;
- Position : in Cursor;
+ Position : Cursor;
Process : not null access
procedure (Element : in out Element_Type))
is
@@ -1984,31 +2016,33 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Indx : Hash_Type;
begin
- pragma Assert
- (Vet (Position),
- "bad cursor in Update_Element_Preserving_Key");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
if Position.Node.Element = null
or else Position.Node.Next = Position.Node
then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong set";
end if;
if HT.Buckets = null
or else HT.Buckets'Length = 0
or else HT.Length = 0
then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad (set is empty)";
end if;
+ pragma Assert
+ (Vet (Position),
+ "bad cursor in Update_Element_Preserving_Key");
+
Indx := HT_Ops.Index (HT, Position.Node);
declare
@@ -2052,7 +2086,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Prev := Prev.Next;
if Prev = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor is bad (node not found)";
end if;
end loop;
@@ -2069,7 +2104,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Free (X);
end;
- raise Program_Error;
+ raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
end Generic_Keys;
diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads
index bde7917ff37..71636340414 100644
--- a/gcc/ada/a-cihase.ads
+++ b/gcc/ada/a-cihase.ads
@@ -180,7 +180,7 @@ package Ada.Containers.Indefinite_Hashed_Sets is
function Element (Container : Set; Key : Key_Type) return Element_Type;
- procedure Replace -- TODO: ask Randy why this is still here
+ procedure Replace
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb
index 458e42e4225..980e868f0ef 100644
--- a/gcc/ada/a-ciormu.adb
+++ b/gcc/ada/a-ciormu.adb
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -162,16 +162,20 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function "<" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Left.Node = null then
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Left.Node.Element = null
- or else Right.Node.Element = null
- then
- raise Program_Error;
+ if Right.Node = null then
+ raise Constraint_Error with "Right cursor equals No_Element";
+ end if;
+
+ if Left.Node.Element = null then
+ raise Program_Error with "Left cursor is bad";
+ end if;
+
+ if Right.Node.Element = null then
+ raise Program_Error with "Right cursor is bad";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -186,11 +190,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function "<" (Left : Cursor; Right : Element_Type) return Boolean is
begin
if Left.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
if Left.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Left cursor is bad";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -202,11 +206,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function "<" (Left : Element_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
if Right.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Right cursor is bad";
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
@@ -230,16 +234,20 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function ">" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Left.Node = null then
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Left.Node.Element = null
- or else Right.Node.Element = null
- then
- raise Program_Error;
+ if Right.Node = null then
+ raise Constraint_Error with "Right cursor equals No_Element";
+ end if;
+
+ if Left.Node.Element = null then
+ raise Program_Error with "Left cursor is bad";
+ end if;
+
+ if Right.Node.Element = null then
+ raise Program_Error with "Right cursor is bad";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -256,11 +264,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function ">" (Left : Cursor; Right : Element_Type) return Boolean is
begin
if Left.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
if Left.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Left cursor is bad";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -272,11 +280,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function ">" (Left : Element_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
if Right.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Right cursor is bad";
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
@@ -375,7 +383,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
begin
if Node = Done then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete element not in set";
end if;
loop
@@ -391,11 +399,15 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
+ end if;
+
+ if Position.Node.Element = null then
+ raise Program_Error with "Position cursor is bad";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with "Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
@@ -464,11 +476,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -580,13 +592,10 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function First_Element (Container : Set) return Element_Type is
begin
if Container.Tree.First = null then
- raise Constraint_Error;
- end if;
-
- if Container.Tree.First.Element = null then
- raise Program_Error;
+ raise Constraint_Error with "set is empty";
end if;
+ pragma Assert (Container.Tree.First.Element /= null);
return Container.Tree.First.Element.all;
end First_Element;
@@ -703,7 +712,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
begin
if Node = Done then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete key not in set";
end if;
loop
@@ -726,7 +735,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "key not in set";
end if;
return Node.Element.all;
@@ -870,11 +879,13 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function Key (Position : Cursor) return Key_Type is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor is bad";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -930,35 +941,36 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
B := B - 1;
end Reverse_Iterate;
- -----------------------------------
- -- Update_Element_Preserving_Key --
- -----------------------------------
+ --------------------
+ -- Update_Element --
+ --------------------
- procedure Update_Element_Preserving_Key
+ procedure Update_Element
(Container : in out Set;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
Tree : Tree_Type renames Container.Tree;
+ Node : constant Node_Access := Position.Node;
begin
- if Position.Node = null then
- raise Constraint_Error;
+ if Node = null then
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
- if Position.Node.Element = null then
- raise Program_Error;
+ if Node.Element = null then
+ raise Program_Error with "Position cursor is bad";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with "Position cursor designates wrong set";
end if;
- pragma Assert (Vet (Container.Tree, Position.Node),
- "bad cursor in Update_Element_Preserving_Key");
+ pragma Assert (Vet (Tree, Node),
+ "bad cursor in Update_Element");
declare
- E : Element_Type renames Position.Node.Element.all;
+ E : Element_Type renames Node.Element.all;
K : constant Key_Type := Key (E);
B : Natural renames Tree.Busy;
@@ -985,15 +997,47 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
end if;
end;
- declare
- X : Node_Access := Position.Node;
+ -- Delete_Node checks busy-bit
+
+ Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
+
+ Insert_New_Item : declare
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Unconditional_Insert is
+ new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ Node.Color := Red_Black_Trees.Red;
+ Node.Parent := null;
+ Node.Left := null;
+ Node.Right := null;
+
+ return Node;
+ end New_Node;
+
+ Result : Node_Access;
+
+ -- Start of processing for Insert_New_Item
+
begin
- Tree_Operations.Delete_Node_Sans_Free (Tree, X);
- Free (X);
- end;
+ Unconditional_Insert
+ (Tree => Tree,
+ Key => Node.Element.all,
+ Node => Result);
- raise Program_Error;
- end Update_Element_Preserving_Key;
+ pragma Assert (Result = Node);
+ end Insert_New_Item;
+ end Update_Element;
end Generic_Keys;
@@ -1022,11 +1066,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
Position : out Cursor)
is
begin
- Insert_Sans_Hint
- (Container.Tree,
- New_Item,
- Position.Node);
-
+ Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
Position.Container := Container'Unrestricted_Access;
end Insert;
@@ -1045,7 +1085,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
procedure Insert_Post is
new Element_Keys.Generic_Insert_Post (New_Node);
- procedure Unconditional_Insert_Sans_Hint is
+ procedure Unconditional_Insert is
new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
--------------
@@ -1053,28 +1093,24 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
--------------
function New_Node return Node_Access is
- X : Element_Access := new Element_Type'(New_Item);
+ Element : Element_Access := new Element_Type'(New_Item);
begin
return new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Red_Black_Trees.Red,
- Element => X);
-
+ Element => Element);
exception
when others =>
- Free_Element (X);
+ Free_Element (Element);
raise;
end New_Node;
-- Start of processing for Insert_Sans_Hint
begin
- Unconditional_Insert_Sans_Hint
- (Tree,
- New_Item,
- Node);
+ Unconditional_Insert (Tree, New_Item, Node);
end Insert_Sans_Hint;
----------------------
@@ -1310,9 +1346,10 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
function Last_Element (Container : Set) return Element_Type is
begin
if Container.Tree.Last = null then
- raise Constraint_Error;
+ raise Constraint_Error with "set is empty";
end if;
+ pragma Assert (Container.Tree.Last.Element /= null);
return Container.Tree.Last.Element.all;
end Last_Element;
@@ -1436,11 +1473,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -1513,7 +1550,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
---------------------
@@ -1532,7 +1569,8 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
null;
else
if Tree.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
declare
@@ -1596,15 +1634,15 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with "Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
@@ -1823,7 +1861,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
end Ada.Containers.Indefinite_Ordered_Multisets;
diff --git a/gcc/ada/a-ciormu.ads b/gcc/ada/a-ciormu.ads
index 1240aca4d66..358c891649d 100644
--- a/gcc/ada/a-ciormu.ads
+++ b/gcc/ada/a-ciormu.ads
@@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -216,7 +216,7 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
function Contains (Container : Set; Key : Key_Type) return Boolean;
- procedure Update_Element_Preserving_Key
+ procedure Update_Element
(Container : in out Set;
Position : Cursor;
Process : not null access
diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb
index bb441a3201c..0e11e6506ed 100644
--- a/gcc/ada/a-ciorse.adb
+++ b/gcc/ada/a-ciorse.adb
@@ -150,16 +150,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function "<" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Left.Node = null then
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Left.Node.Element = null
- or else Right.Node.Element = null
- then
- raise Program_Error;
+ if Right.Node = null then
+ raise Constraint_Error with "Right cursor equals No_Element";
+ end if;
+
+ if Left.Node.Element = null then
+ raise Program_Error with "Left cursor is bad";
+ end if;
+
+ if Right.Node.Element = null then
+ raise Program_Error with "Right cursor is bad";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -174,11 +178,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function "<" (Left : Cursor; Right : Element_Type) return Boolean is
begin
if Left.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
if Left.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Left cursor is bad";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -190,11 +194,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function "<" (Left : Element_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
if Right.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Right cursor is bad";
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
@@ -236,16 +240,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function ">" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Left.Node = null then
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
- if Left.Node.Element = null
- or else Right.Node.Element = null
- then
- raise Program_Error;
+ if Right.Node = null then
+ raise Constraint_Error with "Right cursor equals No_Element";
+ end if;
+
+ if Left.Node.Element = null then
+ raise Program_Error with "Left cursor is bad";
+ end if;
+
+ if Right.Node.Element = null then
+ raise Program_Error with "Right cursor is bad";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -262,11 +270,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function ">" (Left : Cursor; Right : Element_Type) return Boolean is
begin
if Left.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
if Left.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Left cursor is bad";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -278,11 +286,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function ">" (Left : Element_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
if Right.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Right cursor is bad";
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
@@ -372,14 +380,18 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
-- Delete --
------------
- procedure Delete (Container : in out Set; Position : in out Cursor) is
+ procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
+ end if;
+
+ if Position.Node.Element = null then
+ raise Program_Error with "Position cursor is bad";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with "Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
@@ -396,7 +408,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
begin
if X = null then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete element not in set";
end if;
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
@@ -456,11 +468,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -568,7 +580,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function First_Element (Container : Set) return Element_Type is
begin
if Container.Tree.First = null then
- raise Constraint_Error;
+ raise Constraint_Error with "set is empty";
end if;
return Container.Tree.First.Element.all;
@@ -684,7 +696,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
begin
if X = null then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete key not in set";
end if;
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
@@ -701,7 +713,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "key not in set";
end if;
return Node.Element.all;
@@ -797,11 +809,13 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function Key (Position : Cursor) return Key_Type is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor is bad";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -823,7 +837,8 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to replace key not in set";
end if;
Replace_Element (Container.Tree, Node, New_Item);
@@ -843,15 +858,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with "Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
@@ -892,7 +907,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Free (X);
end;
- raise Program_Error;
+ raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
end Generic_Keys;
@@ -921,7 +936,8 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
if not Inserted then
if Container.Tree.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
X := Position.Node.Element;
@@ -957,7 +973,8 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to insert element already in set";
end if;
end Insert;
@@ -1196,7 +1213,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function Last_Element (Container : Set) return Element_Type is
begin
if Container.Tree.Last = null then
- raise Constraint_Error;
+ raise Constraint_Error with "set is empty";
end if;
return Container.Tree.Last.Element.all;
@@ -1247,6 +1264,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
return No_Element;
end if;
+ if Position.Node.Element = null then
+ raise Program_Error with "Position cursor is bad";
+ end if;
+
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Next");
@@ -1296,6 +1317,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
return No_Element;
end if;
+ if Position.Node.Element = null then
+ raise Program_Error with "Position cursor is bad";
+ end if;
+
pragma Assert (Vet (Position.Container.Tree, Position.Node),
"bad cursor in Previous");
@@ -1322,11 +1347,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -1401,7 +1426,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
-------------
@@ -1416,11 +1441,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to replace element not in set";
end if;
if Container.Tree.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
X := Node.Element;
@@ -1444,7 +1470,8 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
null;
else
if Tree.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
declare
@@ -1550,7 +1577,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
null;
end Reinsert_Old_Element;
- raise Program_Error;
+ raise Program_Error with "attempt to replace existing element";
end Replace_Element;
procedure Replace_Element
@@ -1560,15 +1587,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Node.Element = null then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with "Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
@@ -1749,7 +1776,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
end Ada.Containers.Indefinite_Ordered_Sets;
diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb
index a29784bdb45..59ae2a5cd58 100644
--- a/gcc/ada/a-cohama.adb
+++ b/gcc/ada/a-cohama.adb
@@ -180,7 +180,7 @@ package body Ada.Containers.Hashed_Maps is
Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
if X = null then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete key not in map";
end if;
Free (X);
@@ -188,20 +188,23 @@ package body Ada.Containers.Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
- pragma Assert (Vet (Position), "bad cursor in Delete");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of Delete equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor of Delete designates wrong map";
end if;
if Container.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "Delete attempted to tamper with elements (map is busy)";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Delete");
+
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
Free (Position.Node);
@@ -217,7 +220,8 @@ package body Ada.Containers.Hashed_Maps is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "no element available because key not in map";
end if;
return Node.Element;
@@ -225,12 +229,13 @@ package body Ada.Containers.Hashed_Maps is
function Element (Position : Cursor) return Element_Type is
begin
- pragma Assert (Vet (Position), "bad cursor in function Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of function Element equals No_Element";
end if;
+ pragma Assert (Vet (Position), "bad cursor in function Element");
+
return Position.Node.Element;
end Element;
@@ -252,37 +257,43 @@ package body Ada.Containers.Hashed_Maps is
function Equivalent_Keys (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 then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Keys equals No_Element";
+ end if;
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Right.Node = null then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Keys equals No_Element";
end if;
+ pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad");
+ pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
+
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), "bad Left cursor in Equivalent_Keys");
-
if Left.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Keys equals No_Element";
end if;
+ pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad");
+
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), "bad Right cursor in Equivalent_Keys");
-
if Right.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Keys equals No_Element";
end if;
+ pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
+
return Equivalent_Keys (Left, Right.Node.Key);
end Equivalent_Keys;
@@ -409,7 +420,8 @@ package body Ada.Containers.Hashed_Maps is
if not Inserted then
if Container.HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "Include attempted to tamper with cursors (map is locked)";
end if;
Position.Node.Key := Key;
@@ -518,7 +530,8 @@ package body Ada.Containers.Hashed_Maps is
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to insert key already in map";
end if;
end Insert;
@@ -565,12 +578,13 @@ package body Ada.Containers.Hashed_Maps is
function Key (Position : Cursor) return Key_Type is
begin
- pragma Assert (Vet (Position), "bad cursor in function Key");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of function Key equals No_Element";
end if;
+ pragma Assert (Vet (Position), "bad cursor in function Key");
+
return Position.Node.Key;
end Key;
@@ -606,12 +620,12 @@ package body Ada.Containers.Hashed_Maps is
function Next (Position : Cursor) return Cursor is
begin
- pragma Assert (Vet (Position), "bad cursor in function Next");
-
if Position.Node = null then
return No_Element;
end if;
+ pragma Assert (Vet (Position), "bad cursor in function Next");
+
declare
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
@@ -640,12 +654,13 @@ package body Ada.Containers.Hashed_Maps is
procedure (Key : Key_Type; Element : Element_Type))
is
begin
- pragma Assert (Vet (Position), "bad cursor in Query_Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of Query_Element equals No_Element";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
+
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
@@ -692,7 +707,7 @@ package body Ada.Containers.Hashed_Maps is
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream map cursor";
end Read;
---------------
@@ -728,11 +743,13 @@ package body Ada.Containers.Hashed_Maps is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to replace key not in map";
end if;
if Container.HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "Replace attempted to tamper with cursors (map is locked)";
end if;
Node.Key := Key;
@@ -749,20 +766,23 @@ package body Ada.Containers.Hashed_Maps is
New_Item : Element_Type)
is
begin
- pragma Assert (Vet (Position), "bad cursor in Replace_Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of Replace_Element equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor of Replace_Element designates wrong map";
end if;
if Position.Container.HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "Replace_Element attempted to tamper with cursors (map is locked)";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
+
Position.Node.Element := New_Item;
end Replace_Element;
@@ -798,16 +818,18 @@ package body Ada.Containers.Hashed_Maps is
Element : in out Element_Type))
is
begin
- pragma Assert (Vet (Position), "bad cursor in Update_Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of Update_Element equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor of Update_Element designates wrong map";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Update_Element");
+
declare
HT : Hash_Table_Type renames Container.HT;
B : Natural renames HT.Busy;
@@ -906,7 +928,7 @@ package body Ada.Containers.Hashed_Maps is
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream map cursor";
end Write;
----------------
diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb
index afb219055d5..a54683e36ff 100644
--- a/gcc/ada/a-cohase.adb
+++ b/gcc/ada/a-cohase.adb
@@ -207,7 +207,7 @@ package body Ada.Containers.Hashed_Sets is
Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
if X = null then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete element not in set";
end if;
Free (X);
@@ -218,20 +218,21 @@ package body Ada.Containers.Hashed_Sets is
Position : in out Cursor)
is
begin
- pragma Assert (Vet (Position), "bad cursor in Delete");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with "Position cursor designates wrong set";
end if;
if Container.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Delete");
+
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
Free (Position.Node);
@@ -254,12 +255,13 @@ package body Ada.Containers.Hashed_Sets is
return;
end if;
- if Source.Length = 0 then
+ if Source.HT.Length = 0 then
return;
end if;
if Target.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
-- TODO: This can be written in terms of a loop instead as
@@ -291,11 +293,11 @@ package body Ada.Containers.Hashed_Sets is
return Empty_Set;
end if;
- if Left.Length = 0 then
+ if Left.HT.Length = 0 then
return Empty_Set;
end if;
- if Right.Length = 0 then
+ if Right.HT.Length = 0 then
return Left;
end if;
@@ -353,12 +355,12 @@ package body Ada.Containers.Hashed_Sets is
function Element (Position : Cursor) return Element_Type is
begin
- pragma Assert (Vet (Position), "bad cursor in function Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
+ pragma Assert (Vet (Position), "bad cursor in function Element");
+
return Position.Node.Element;
end Element;
@@ -378,39 +380,47 @@ package body Ada.Containers.Hashed_Sets is
function Equivalent_Elements (Left, Right : Cursor)
return Boolean is
begin
- pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
- pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
+ if Left.Node = null then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Elements equals No_Element";
+ end if;
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Right.Node = null then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Elements equals No_Element";
end if;
+ pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
+ pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
+
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;
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Elements equals No_Element";
end if;
+ pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad");
+
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;
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Elements equals No_Element";
end if;
+ pragma Assert
+ (Vet (Right),
+ "Right cursor of Equivalent_Elements is bad");
+
return Equivalent_Elements (Left, Right.Node.Element);
end Equivalent_Elements;
@@ -584,7 +594,8 @@ package body Ada.Containers.Hashed_Sets is
if not Inserted then
if Container.HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
Position.Node.Element := New_Item;
@@ -617,7 +628,8 @@ package body Ada.Containers.Hashed_Sets is
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to insert element already in set";
end if;
end Insert;
@@ -679,7 +691,8 @@ package body Ada.Containers.Hashed_Sets is
end if;
if Target.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
-- TODO: optimize this to use an explicit
@@ -880,12 +893,12 @@ package body Ada.Containers.Hashed_Sets is
function Next (Position : Cursor) return Cursor is
begin
- pragma Assert (Vet (Position), "bad cursor in function Next");
-
if Position.Node = null then
return No_Element;
end if;
+ pragma Assert (Vet (Position), "bad cursor in Next");
+
declare
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
@@ -940,12 +953,13 @@ package body Ada.Containers.Hashed_Sets is
Process : not null access procedure (Element : Element_Type))
is
begin
- pragma Assert (Vet (Position), "bad cursor in Query_Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor of Query_Element equals No_Element";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
+
declare
HT : Hash_Table_Type renames Position.Container.HT;
@@ -987,7 +1001,7 @@ package body Ada.Containers.Hashed_Sets is
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
---------------
@@ -1021,11 +1035,13 @@ package body Ada.Containers.Hashed_Sets is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to replace element not in set";
end if;
if Container.HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
Node.Element := New_Item;
@@ -1045,7 +1061,8 @@ package body Ada.Containers.Hashed_Sets is
pragma Assert (Hash (Node.Element) = Hash (New_Item));
if HT.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
Node.Element := New_Item; -- Note that this assignment can fail
@@ -1053,7 +1070,8 @@ package body Ada.Containers.Hashed_Sets is
end if;
if HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
HT_Ops.Delete_Node_Sans_Free (HT, Node);
@@ -1129,7 +1147,7 @@ package body Ada.Containers.Hashed_Sets is
null;
end Reinsert_Old_Element;
- raise Program_Error;
+ raise Program_Error with "attempt to replace existing element";
end Replace_Element;
procedure Replace_Element
@@ -1138,16 +1156,18 @@ package body Ada.Containers.Hashed_Sets is
New_Item : Element_Type)
is
begin
- pragma Assert (Vet (Position), "bad cursor in Replace_Element");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong set";
end if;
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
+
Replace_Element (Container.HT, Position.Node, New_Item);
end Replace_Element;
@@ -1187,7 +1207,8 @@ package body Ada.Containers.Hashed_Sets is
end if;
if Target.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
declare
@@ -1452,7 +1473,8 @@ package body Ada.Containers.Hashed_Sets is
end if;
if Target.HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
end if;
declare
@@ -1634,7 +1656,7 @@ package body Ada.Containers.Hashed_Sets is
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
----------------
@@ -1699,7 +1721,7 @@ package body Ada.Containers.Hashed_Sets is
Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
if X = null then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete key not in set";
end if;
Free (X);
@@ -1716,6 +1738,10 @@ package body Ada.Containers.Hashed_Sets is
Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
begin
+ if Node = null then
+ raise Constraint_Error with "key not in map";
+ end if;
+
return Node.Element;
end Element;
@@ -1770,12 +1796,13 @@ package body Ada.Containers.Hashed_Sets is
function Key (Position : Cursor) return Key_Type is
begin
- pragma Assert (Vet (Position), "bad cursor in function Key");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
+ pragma Assert (Vet (Position), "bad cursor in function Key");
+
return Key (Position.Node.Element);
end Key;
@@ -1793,7 +1820,8 @@ package body Ada.Containers.Hashed_Sets is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to replace key not in set";
end if;
Replace_Element (Container.HT, Node, New_Item);
@@ -1813,16 +1841,14 @@ package body Ada.Containers.Hashed_Sets is
Indx : Hash_Type;
begin
- pragma Assert
- (Vet (Position),
- "bad cursor in Update_Element_Preserving_Key");
-
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong set";
end if;
if HT.Buckets = null
@@ -1830,9 +1856,13 @@ package body Ada.Containers.Hashed_Sets is
or else HT.Length = 0
or else Position.Node.Next = Position.Node
then
- raise Program_Error;
+ raise Program_Error with "Position cursor is bad (set is empty)";
end if;
+ pragma Assert
+ (Vet (Position),
+ "bad cursor in Update_Element_Preserving_Key");
+
Indx := HT_Ops.Index (HT, Position.Node);
declare
@@ -1876,7 +1906,8 @@ package body Ada.Containers.Hashed_Sets is
Prev := Prev.Next;
if Prev = null then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor is bad (node not found)";
end if;
end loop;
@@ -1893,7 +1924,7 @@ package body Ada.Containers.Hashed_Sets is
Free (X);
end;
- raise Program_Error;
+ raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
end Generic_Keys;
diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads
index 19aad2911fa..dccb56cb0cc 100644
--- a/gcc/ada/a-cohase.ads
+++ b/gcc/ada/a-cohase.ads
@@ -179,7 +179,7 @@ package Ada.Containers.Hashed_Sets is
function Element (Container : Set; Key : Key_Type) return Element_Type;
- procedure Replace -- TODO: ask Randy why this wasn't removed
+ procedure Replace
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb
index eb1e3656229..2ad3613016f 100644
--- a/gcc/ada/a-coormu.adb
+++ b/gcc/ada/a-coormu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -158,10 +158,12 @@ package body Ada.Containers.Ordered_Multisets is
function "<" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Left.Node = null then
+ raise Constraint_Error with "Left cursor equals No_Element";
+ end if;
+
+ if Right.Node = null then
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -177,7 +179,7 @@ package body Ada.Containers.Ordered_Multisets is
return Boolean is
begin
if Left.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -190,7 +192,7 @@ package body Ada.Containers.Ordered_Multisets is
return Boolean is
begin
if Right.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
@@ -214,10 +216,12 @@ package body Ada.Containers.Ordered_Multisets is
function ">" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Left.Node = null then
+ raise Constraint_Error with "Left cursor equals No_Element";
+ end if;
+
+ if Right.Node = null then
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -235,7 +239,7 @@ package body Ada.Containers.Ordered_Multisets is
return Boolean is
begin
if Left.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -248,7 +252,7 @@ package body Ada.Containers.Ordered_Multisets is
return Boolean is
begin
if Right.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
@@ -342,7 +346,8 @@ package body Ada.Containers.Ordered_Multisets is
begin
if Node = Done then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to delete element not in set";
end if;
loop
@@ -358,11 +363,11 @@ package body Ada.Containers.Ordered_Multisets is
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with "Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
@@ -431,7 +436,7 @@ package body Ada.Containers.Ordered_Multisets is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -542,7 +547,7 @@ package body Ada.Containers.Ordered_Multisets is
function First_Element (Container : Set) return Element_Type is
begin
if Container.Tree.First = null then
- raise Constraint_Error;
+ raise Constraint_Error with "set is empty";
end if;
return Container.Tree.First.Element;
@@ -650,7 +655,7 @@ package body Ada.Containers.Ordered_Multisets is
begin
if Node = Done then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete key not in set";
end if;
loop
@@ -672,7 +677,7 @@ package body Ada.Containers.Ordered_Multisets is
Key_Keys.Find (Container.Tree, Key);
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "key not in set";
end if;
return Node.Element;
@@ -816,7 +821,8 @@ package body Ada.Containers.Ordered_Multisets is
function Key (Position : Cursor) return Key_Type is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -868,31 +874,34 @@ package body Ada.Containers.Ordered_Multisets is
B := B - 1;
end Reverse_Iterate;
- -----------------------------------
- -- Update_Element_Preserving_Key --
- -----------------------------------
+ --------------------
+ -- Update_Element --
+ --------------------
- procedure Update_Element_Preserving_Key
+ procedure Update_Element
(Container : in out Set;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
Tree : Tree_Type renames Container.Tree;
+ Node : constant Node_Access := Position.Node;
begin
- if Position.Node = null then
- raise Constraint_Error;
+ if Node = null then
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong set";
end if;
- pragma Assert (Vet (Container.Tree, Position.Node),
- "bad cursor in Update_Element_Preserving_Key");
+ pragma Assert (Vet (Tree, Node),
+ "bad cursor in Update_Element");
declare
- E : Element_Type renames Position.Node.Element;
+ E : Element_Type renames Node.Element;
K : constant Key_Type := Key (E);
B : Natural renames Tree.Busy;
@@ -919,15 +928,47 @@ package body Ada.Containers.Ordered_Multisets is
end if;
end;
- declare
- X : Node_Access := Position.Node;
+ -- Delete_Node checks busy-bit
+
+ Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
+
+ Insert_New_Item : declare
+ function New_Node return Node_Access;
+ pragma Inline (New_Node);
+
+ procedure Insert_Post is
+ new Element_Keys.Generic_Insert_Post (New_Node);
+
+ procedure Unconditional_Insert is
+ new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
+
+ --------------
+ -- New_Node --
+ --------------
+
+ function New_Node return Node_Access is
+ begin
+ Node.Color := Red_Black_Trees.Red;
+ Node.Parent := null;
+ Node.Left := null;
+ Node.Right := null;
+
+ return Node;
+ end New_Node;
+
+ Result : Node_Access;
+
+ -- Start of processing for Insert_New_Item
+
begin
- Tree_Operations.Delete_Node_Sans_Free (Tree, X);
- Free (X);
- end;
+ Unconditional_Insert
+ (Tree => Tree,
+ Key => Node.Element,
+ Node => Result);
- raise Program_Error;
- end Update_Element_Preserving_Key;
+ pragma Assert (Result = Node);
+ end Insert_New_Item;
+ end Update_Element;
end Generic_Keys;
@@ -944,7 +985,7 @@ package body Ada.Containers.Ordered_Multisets is
-- Insert --
------------
- procedure Insert (Container : in out Set; New_Item : Element_Type) is
+ procedure Insert (Container : in out Set; New_Item : Element_Type) is
Position : Cursor;
begin
Insert (Container, New_Item, Position);
@@ -956,11 +997,7 @@ package body Ada.Containers.Ordered_Multisets is
Position : out Cursor)
is
begin
- Insert_Sans_Hint
- (Container.Tree,
- New_Item,
- Position.Node);
-
+ Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
Position.Container := Container'Unrestricted_Access;
end Insert;
@@ -979,7 +1016,7 @@ package body Ada.Containers.Ordered_Multisets is
procedure Insert_Post is
new Element_Keys.Generic_Insert_Post (New_Node);
- procedure Unconditional_Insert_Sans_Hint is
+ procedure Unconditional_Insert is
new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
--------------
@@ -1000,10 +1037,7 @@ package body Ada.Containers.Ordered_Multisets is
-- Start of processing for Insert_Sans_Hint
begin
- Unconditional_Insert_Sans_Hint
- (Tree,
- New_Item,
- Node);
+ Unconditional_Insert (Tree, New_Item, Node);
end Insert_Sans_Hint;
----------------------
@@ -1234,7 +1268,7 @@ package body Ada.Containers.Ordered_Multisets is
function Last_Element (Container : Set) return Element_Type is
begin
if Container.Tree.Last = null then
- raise Constraint_Error;
+ raise Constraint_Error with "set is empty";
end if;
return Container.Tree.Last.Element;
@@ -1360,7 +1394,7 @@ package body Ada.Containers.Ordered_Multisets is
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -1433,7 +1467,7 @@ package body Ada.Containers.Ordered_Multisets is
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
---------------------
@@ -1452,7 +1486,8 @@ package body Ada.Containers.Ordered_Multisets is
null;
else
if Tree.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
Node.Element := Item;
@@ -1507,11 +1542,13 @@ package body Ada.Containers.Ordered_Multisets is
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
@@ -1730,7 +1767,7 @@ package body Ada.Containers.Ordered_Multisets is
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
end Ada.Containers.Ordered_Multisets;
diff --git a/gcc/ada/a-coormu.ads b/gcc/ada/a-coormu.ads
index ab3d4d4d01e..7e53d1ca7a7 100644
--- a/gcc/ada/a-coormu.ads
+++ b/gcc/ada/a-coormu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -223,7 +223,7 @@ package Ada.Containers.Ordered_Multisets is
function Contains (Container : Set; Key : Key_Type) return Boolean;
- procedure Update_Element_Preserving_Key
+ procedure Update_Element
(Container : in out Set;
Position : Cursor;
Process : not null access
diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb
index 9060552302b..552987329d7 100644
--- a/gcc/ada/a-coorse.adb
+++ b/gcc/ada/a-coorse.adb
@@ -159,10 +159,12 @@ package body Ada.Containers.Ordered_Sets is
function "<" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Left.Node = null then
+ raise Constraint_Error with "Left cursor equals No_Element";
+ end if;
+
+ if Right.Node = null then
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -177,7 +179,7 @@ package body Ada.Containers.Ordered_Sets is
function "<" (Left : Cursor; Right : Element_Type) return Boolean is
begin
if Left.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -189,7 +191,7 @@ package body Ada.Containers.Ordered_Sets is
function "<" (Left : Element_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
@@ -213,10 +215,12 @@ package body Ada.Containers.Ordered_Sets is
function ">" (Left, Right : Cursor) return Boolean is
begin
- if Left.Node = null
- or else Right.Node = null
- then
- raise Constraint_Error;
+ if Left.Node = null then
+ raise Constraint_Error with "Left cursor equals No_Element";
+ end if;
+
+ if Right.Node = null then
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -233,7 +237,7 @@ package body Ada.Containers.Ordered_Sets is
function ">" (Left : Element_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
@@ -245,7 +249,7 @@ package body Ada.Containers.Ordered_Sets is
function ">" (Left : Cursor; Right : Element_Type) return Boolean is
begin
if Left.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Left cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
@@ -337,11 +341,11 @@ package body Ada.Containers.Ordered_Sets is
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with "Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
@@ -357,7 +361,7 @@ package body Ada.Containers.Ordered_Sets is
begin
if X = null then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete element not in set";
end if;
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
@@ -417,7 +421,7 @@ package body Ada.Containers.Ordered_Sets is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -523,7 +527,7 @@ package body Ada.Containers.Ordered_Sets is
function First_Element (Container : Set) return Element_Type is
begin
if Container.Tree.First = null then
- raise Constraint_Error;
+ raise Constraint_Error with "set is empty";
end if;
return Container.Tree.First.Element;
@@ -628,7 +632,7 @@ package body Ada.Containers.Ordered_Sets is
begin
if X = null then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete key not in set";
end if;
Delete_Node_Sans_Free (Container.Tree, X);
@@ -645,7 +649,7 @@ package body Ada.Containers.Ordered_Sets is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "key not in set";
end if;
return Node.Element;
@@ -741,7 +745,8 @@ package body Ada.Containers.Ordered_Sets is
function Key (Position : Cursor) return Key_Type is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -763,7 +768,8 @@ package body Ada.Containers.Ordered_Sets is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to replace key not in set";
end if;
Replace_Element (Container.Tree, Node, New_Item);
@@ -782,11 +788,13 @@ package body Ada.Containers.Ordered_Sets is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
@@ -827,7 +835,7 @@ package body Ada.Containers.Ordered_Sets is
Free (X);
end;
- raise Program_Error;
+ raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
end Generic_Keys;
@@ -854,7 +862,8 @@ package body Ada.Containers.Ordered_Sets is
if not Inserted then
if Container.Tree.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
Position.Node.Element := New_Item;
@@ -892,7 +901,8 @@ package body Ada.Containers.Ordered_Sets is
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to insert element already in set";
end if;
end Insert;
@@ -1130,7 +1140,7 @@ package body Ada.Containers.Ordered_Sets is
function Last_Element (Container : Set) return Element_Type is
begin
if Container.Tree.Last = null then
- raise Constraint_Error;
+ raise Constraint_Error with "set is empty";
end if;
return Container.Tree.Last.Element;
@@ -1256,7 +1266,7 @@ package body Ada.Containers.Ordered_Sets is
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "Position cursor equals No_Element";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
@@ -1331,7 +1341,7 @@ package body Ada.Containers.Ordered_Sets is
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
-------------
@@ -1344,11 +1354,13 @@ package body Ada.Containers.Ordered_Sets is
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to replace element not in set";
end if;
if Container.Tree.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
Node.Element := New_Item;
@@ -1370,7 +1382,8 @@ package body Ada.Containers.Ordered_Sets is
null;
else
if Tree.Lock > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
Node.Element := Item;
@@ -1465,7 +1478,7 @@ package body Ada.Containers.Ordered_Sets is
null; -- Assignment must have failed
end Reinsert_Old_Element;
- raise Program_Error;
+ raise Program_Error with "attempt to replace existing element";
end Replace_Element;
procedure Replace_Element
@@ -1475,11 +1488,13 @@ package body Ada.Containers.Ordered_Sets is
is
begin
if Position.Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
- raise Program_Error;
+ raise Program_Error with
+ "Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
@@ -1660,7 +1675,7 @@ package body Ada.Containers.Ordered_Sets is
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
end Ada.Containers.Ordered_Sets;
diff --git a/gcc/ada/a-crbtgk.adb b/gcc/ada/a-crbtgk.adb
index 6d748a30ec3..7fe8e3b5f67 100644
--- a/gcc/ada/a-crbtgk.adb
+++ b/gcc/ada/a-crbtgk.adb
@@ -254,13 +254,14 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Key : Key_Type;
Z : out Node_Access)
is
- subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1;
-
- New_Length : constant Count_Type := Length_Subtype'(Tree.Length) + 1;
-
begin
+ if Tree.Length = Count_Type'Last then
+ raise Constraint_Error with "too many elements";
+ end if;
+
if Tree.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
if Y = null
@@ -316,7 +317,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Ops.Set_Parent (Z, Y);
Ops.Rebalance_For_Insert (Tree, Z);
- Tree.Length := New_Length;
+ Tree.Length := Tree.Length + 1;
end Generic_Insert_Post;
-----------------------
diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb
index 4720f8cbb48..b0b7ca09bc6 100644
--- a/gcc/ada/a-crbtgo.adb
+++ b/gcc/ada/a-crbtgo.adb
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -246,7 +246,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
begin
if Tree.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
-- pragma Assert (Tree.Length > 0);
@@ -523,7 +524,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
Root : Node_Access := Tree.Root;
begin
if Tree.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
Tree := (First => null,
@@ -672,7 +674,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
end if;
if Source.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
Clear (Target);
@@ -771,7 +774,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Generic_Write
(Stream : access Root_Stream_Type'Class;
- Tree : in Tree_Type)
+ Tree : Tree_Type)
is
procedure Process (Node : Node_Access);
pragma Inline (Process);
diff --git a/gcc/ada/a-envvar.adb b/gcc/ada/a-envvar.adb
new file mode 100755
index 00000000000..586451b974e
--- /dev/null
+++ b/gcc/ada/a-envvar.adb
@@ -0,0 +1,228 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E N V I R O N M E N T _ V A R I A B L E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2005, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System;
+with Interfaces.C.Strings;
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Environment_Variables is
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Name : String) is
+ procedure Clear_Env_Var (Name : System.Address);
+ pragma Import (C, Clear_Env_Var, "__gnat_unsetenv");
+
+ F_Name : String (1 .. Name'Length + 1);
+
+ begin
+ F_Name (1 .. Name'Length) := Name;
+ F_Name (F_Name'Last) := ASCII.NUL;
+
+ Clear_Env_Var (F_Name'Address);
+ end Clear;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear is
+ procedure Clear_Env;
+ pragma Import (C, Clear_Env, "__gnat_clearenv");
+ begin
+ Clear_Env;
+ end Clear;
+
+ ------------
+ -- Exists --
+ ------------
+
+ function Exists (Name : String) return Boolean is
+ use System;
+
+ procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
+ pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
+
+ Env_Value_Ptr : aliased Address;
+ Env_Value_Length : aliased Integer;
+ F_Name : aliased String (1 .. Name'Length + 1);
+
+ begin
+ F_Name (1 .. Name'Length) := Name;
+ F_Name (F_Name'Last) := ASCII.NUL;
+
+ Get_Env_Value_Ptr
+ (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
+
+ if Env_Value_Ptr = System.Null_Address then
+ return False;
+ end if;
+
+ return True;
+ end Exists;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Process : not null access procedure (Name, Value : String))
+ is
+ use Interfaces.C.Strings;
+ type C_String_Array is array (Natural) of aliased chars_ptr;
+ type C_String_Array_Access is access C_String_Array;
+
+ function Get_Env return C_String_Array_Access;
+ pragma Import (C, Get_Env, "__gnat_environ");
+
+ type String_Access is access all String;
+ procedure Free is new Ada.Unchecked_Deallocation (String, String_Access);
+
+ Env_Length : Natural := 0;
+ Env : constant C_String_Array_Access := Get_Env;
+
+ begin
+ -- If the environment is null return directly
+
+ if Env = null then
+ return;
+ end if;
+
+ -- First get the number of environment variables
+
+ loop
+ exit when Env (Env_Length) = Null_Ptr;
+ Env_Length := Env_Length + 1;
+ end loop;
+
+ declare
+ Env_Copy : array (1 .. Env_Length) of String_Access;
+
+ begin
+ -- Copy the environment
+
+ for Iterator in 1 .. Env_Length loop
+ Env_Copy (Iterator) := new String'(Value (Env (Iterator - 1)));
+ end loop;
+
+ -- Iterate on the environment copy
+
+ for Iterator in 1 .. Env_Length loop
+ declare
+ Current_Var : constant String := Env_Copy (Iterator).all;
+ Value_Index : Natural := Env_Copy (Iterator)'First;
+
+ begin
+ loop
+ exit when Current_Var (Value_Index) = '=';
+ Value_Index := Value_Index + 1;
+ end loop;
+
+ Process
+ (Current_Var (Current_Var'First .. Value_Index - 1),
+ Current_Var (Value_Index + 1 .. Current_Var'Last));
+ end;
+ end loop;
+
+ -- Free the copy of the environment
+
+ for Iterator in 1 .. Env_Length loop
+ Free (Env_Copy (Iterator));
+ end loop;
+ end;
+ end Iterate;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Name : String; Value : String) is
+ F_Name : String (1 .. Name'Length + 1);
+ F_Value : String (1 .. Value'Length + 1);
+
+ procedure Set_Env_Value (Name, Value : System.Address);
+ pragma Import (C, Set_Env_Value, "__gnat_setenv");
+
+ begin
+ F_Name (1 .. Name'Length) := Name;
+ F_Name (F_Name'Last) := ASCII.NUL;
+
+ F_Value (1 .. Value'Length) := Value;
+ F_Value (F_Value'Last) := ASCII.NUL;
+
+ Set_Env_Value (F_Name'Address, F_Value'Address);
+ end Set;
+
+ -----------
+ -- Value --
+ -----------
+
+ function Value (Name : String) return String is
+ use System;
+
+ procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
+ pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
+
+ procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
+ pragma Import (C, Strncpy, "strncpy");
+
+ Env_Value_Ptr : aliased Address;
+ Env_Value_Length : aliased Integer;
+ F_Name : aliased String (1 .. Name'Length + 1);
+
+ begin
+ F_Name (1 .. Name'Length) := Name;
+ F_Name (F_Name'Last) := ASCII.NUL;
+
+ Get_Env_Value_Ptr
+ (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
+
+ if Env_Value_Ptr = System.Null_Address then
+ raise Constraint_Error;
+ end if;
+
+ if Env_Value_Length > 0 then
+ declare
+ Result : aliased String (1 .. Env_Value_Length);
+ begin
+ Strncpy (Result'Address, Env_Value_Ptr, Env_Value_Length);
+ return Result;
+ end;
+ else
+ return "";
+ end if;
+ end Value;
+
+end Ada.Environment_Variables;
diff --git a/gcc/ada/a-envvar.ads b/gcc/ada/a-envvar.ads
new file mode 100755
index 00000000000..2b0229c5069
--- /dev/null
+++ b/gcc/ada/a-envvar.ads
@@ -0,0 +1,61 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E N V I R O N M E N T _ V A R I A B L E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2005-2006, Free Software Foundation, Inc. --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+--- --
+------------------------------------------------------------------------------
+
+package Ada.Environment_Variables is
+ pragma Preelaborate (Environment_Variables);
+
+ function Value (Name : String) return String;
+ -- If the external execution environment supports environment variables,
+ -- then Value returns the value of the environment variable with the given
+ -- name. If no environment variable with the given name exists, then
+ -- Constraint_Error is propagated. If the execution environment does not
+ -- support environment variables, then Program_Error is propagated.
+
+ function Exists (Name : String) return Boolean;
+ -- If the external execution environment supports environment variables and
+ -- an environment variable with the given name currently exists, then
+ -- Exists returns True; otherwise it returns False.
+
+ procedure Set (Name : String; Value : String);
+ -- If the external execution environment supports environment variables,
+ -- then Set first clears any existing environment variable with the given
+ -- name, and then defines a single new environment variable with the given
+ -- name and value. Otherwise Program_Error is propagated.
+ -- If implementation-defined circumstances prohibit the definition of an
+ -- environment variable with the given name and value, then
+ -- Constraint_Error is propagated.
+ -- It is implementation defined whether there exist values for which the
+ -- call Set(Name, Value) has the same effect as Clear (Name).
+
+ procedure Clear (Name : String);
+ -- If the external execution environment supports environment variables,
+ -- then Clear deletes all existing environment variables with the given
+ -- name. Otherwise Program_Error is propagated.
+
+ procedure Clear;
+ -- If the external execution environment supports environment variables,
+ -- then Clear deletes all existing environment variables. Otherwise
+ -- Program_Error is propagated.
+
+ procedure Iterate
+ (Process : not null access procedure (Name, Value : String));
+ -- If the external execution environment supports environment variables,
+ -- then Iterate calls the subprogram designated by Process for each
+ -- existing environment variable, passing the name and value of that
+ -- environment variable. Otherwise Program_Error is propagated.
+
+end Ada.Environment_Variables;
diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb
index 6742e285291..fcb9adf2fc6 100644
--- a/gcc/ada/a-rbtgso.adb
+++ b/gcc/ada/a-rbtgso.adb
@@ -96,7 +96,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
begin
if Target'Address = Source'Address then
if Target.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
Clear (Target);
@@ -108,7 +109,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
end if;
if Target.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
loop
@@ -222,7 +224,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
end if;
if Target.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
if Source.Length = 0 then
@@ -400,7 +403,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
begin
if Target.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
if Target'Address = Source'Address then
@@ -566,7 +570,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
end if;
if Target.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
Iterate (Source);
diff --git a/gcc/ada/a-stboha.adb b/gcc/ada/a-stboha.adb
new file mode 100644
index 00000000000..ba5ce06b0d2
--- /dev/null
+++ b/gcc/ada/a-stboha.adb
@@ -0,0 +1,57 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . B O U N D E D . H A S H --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2006 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Bounded.Hash (Key : Bounded.Bounded_String)
+ return Containers.Hash_Type
+is
+ use Ada.Containers;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Hash_Type;
+
+begin
+ Tmp := 0;
+ for J in 1 .. Bounded.Length (Key) loop
+ Tmp := Rotate_Left (Tmp, 3) + Character'Pos (Bounded.Element (Key, J));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Bounded.Hash;
diff --git a/gcc/ada/a-stboha.ads b/gcc/ada/a-stboha.ads
new file mode 100644
index 00000000000..999850e9ef1
--- /dev/null
+++ b/gcc/ada/a-stboha.ads
@@ -0,0 +1,25 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . B O U N D E D . H A S H --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+generic
+ with package Bounded is
+ new Ada.Strings.Bounded.Generic_Bounded_Length (<>);
+
+function Ada.Strings.Bounded.Hash (Key : Bounded.Bounded_String)
+ return Containers.Hash_Type;
+
+pragma Preelaborate (Ada.Strings.Bounded.Hash);
diff --git a/gcc/ada/a-stfiha.ads b/gcc/ada/a-stfiha.ads
new file mode 100644
index 00000000000..23380034625
--- /dev/null
+++ b/gcc/ada/a-stfiha.ads
@@ -0,0 +1,21 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . F I X E D . H A S H --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers, Ada.Strings.Hash;
+
+function Ada.Strings.Fixed.Hash (Key : String) return Containers.Hash_Type
+ renames Ada.Strings.Hash;
+
+pragma Pure (Ada.Strings.Fixed.Hash);
diff --git a/gcc/ada/a-swbwha.adb b/gcc/ada/a-swbwha.adb
new file mode 100644
index 00000000000..42b844ba8f2
--- /dev/null
+++ b/gcc/ada/a-swbwha.adb
@@ -0,0 +1,59 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ B O U N D E D . W I D E _ H A S H --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2006 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Wide_Bounded.Wide_Hash
+ (Key : Bounded.Bounded_Wide_String)
+ return Containers.Hash_Type
+is
+ use Ada.Containers;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Hash_Type;
+
+begin
+ Tmp := 0;
+ for J in 1 .. Bounded.Length (Key) loop
+ Tmp := Rotate_Left (Tmp, 3) +
+ Wide_Character'Pos (Bounded.Element (Key, J));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Wide_Bounded.Wide_Hash;
diff --git a/gcc/ada/a-swbwha.ads b/gcc/ada/a-swbwha.ads
new file mode 100644
index 00000000000..59479527c30
--- /dev/null
+++ b/gcc/ada/a-swbwha.ads
@@ -0,0 +1,25 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ B O U N D E D . W I D E _ H A S H --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+generic
+ with package Bounded is
+ new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (<>);
+
+function Ada.Strings.Wide_Bounded.Wide_Hash (Key : Bounded.Bounded_Wide_String)
+ return Containers.Hash_Type;
+
+pragma Preelaborate (Ada.Strings.Wide_Bounded.Wide_Hash);
diff --git a/gcc/ada/a-swfwha.ads b/gcc/ada/a-swfwha.ads
new file mode 100644
index 00000000000..ebabe865b70
--- /dev/null
+++ b/gcc/ada/a-swfwha.ads
@@ -0,0 +1,22 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ F I X E D . W I D E _ H A S H --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers, Ada.Strings.Wide_Hash;
+
+function Ada.Strings.Wide_Fixed.Wide_Hash
+ (Key : Wide_String) return Containers.Hash_Type
+ renames Ada.Strings.Wide_Hash;
+
+pragma Pure (Ada.Strings.Wide_Fixed.Wide_Hash);
diff --git a/gcc/ada/a-szbzha.adb b/gcc/ada/a-szbzha.adb
new file mode 100644
index 00000000000..458f47757d4
--- /dev/null
+++ b/gcc/ada/a-szbzha.adb
@@ -0,0 +1,60 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D . --
+-- W I D E _ W I D E _ H A S H --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2006 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb)
+
+function Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash
+ (Key : Bounded.Bounded_Wide_Wide_String)
+ return Containers.Hash_Type
+is
+ use Ada.Containers;
+
+ function Rotate_Left
+ (Value : Hash_Type;
+ Amount : Natural) return Hash_Type;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Hash_Type;
+
+begin
+ Tmp := 0;
+ for J in 1 .. Bounded.Length (Key) loop
+ Tmp := Rotate_Left (Tmp, 3) +
+ Wide_Wide_Character'Pos (Bounded.Element (Key, J));
+ end loop;
+
+ return Tmp;
+end Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash;
diff --git a/gcc/ada/a-szbzha.ads b/gcc/ada/a-szbzha.ads
new file mode 100644
index 00000000000..b368d793414
--- /dev/null
+++ b/gcc/ada/a-szbzha.ads
@@ -0,0 +1,27 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D . --
+-- W I D E _ W I D E _ H A S H --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers;
+
+generic
+ with package Bounded is
+ new Ada.Strings.Wide_Wide_Bounded.Generic_Bounded_Length (<>);
+
+function Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash
+ (Key : Bounded.Bounded_Wide_Wide_String)
+ return Containers.Hash_Type;
+
+pragma Preelaborate (Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash);
diff --git a/gcc/ada/a-szfzha.ads b/gcc/ada/a-szfzha.ads
new file mode 100644
index 00000000000..1753fc7462c
--- /dev/null
+++ b/gcc/ada/a-szfzha.ads
@@ -0,0 +1,23 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ F I X E D . --
+-- W I D E _ W I D E _ H A S H --
+-- --
+-- S p e c --
+-- --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Containers, Ada.Strings.Wide_Wide_Hash;
+
+function Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash
+ (Key : Wide_Wide_String) return Containers.Hash_Type
+ renames Ada.Strings.Wide_Wide_Hash;
+
+pragma Pure (Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash);
OpenPOWER on IntegriCloud