diff options
| -rw-r--r-- | gcc/ada/a-cihama.adb | 147 | ||||
| -rw-r--r-- | gcc/ada/a-cihase.adb | 187 | ||||
| -rw-r--r-- | gcc/ada/a-cihase.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/a-ciormu.adb | 200 | ||||
| -rw-r--r-- | gcc/ada/a-ciormu.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/a-ciorse.adb | 135 | ||||
| -rw-r--r-- | gcc/ada/a-cohama.adb | 112 | ||||
| -rw-r--r-- | gcc/ada/a-cohase.adb | 151 | ||||
| -rw-r--r-- | gcc/ada/a-cohase.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/a-coormu.adb | 149 | ||||
| -rw-r--r-- | gcc/ada/a-coormu.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/a-coorse.adb | 87 | ||||
| -rw-r--r-- | gcc/ada/a-crbtgk.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/a-crbtgo.adb | 13 | ||||
| -rwxr-xr-x | gcc/ada/a-envvar.adb | 228 | ||||
| -rwxr-xr-x | gcc/ada/a-envvar.ads | 61 | ||||
| -rw-r--r-- | gcc/ada/a-rbtgso.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/a-stboha.adb | 57 | ||||
| -rw-r--r-- | gcc/ada/a-stboha.ads | 25 | ||||
| -rw-r--r-- | gcc/ada/a-stfiha.ads | 21 | ||||
| -rw-r--r-- | gcc/ada/a-swbwha.adb | 59 | ||||
| -rw-r--r-- | gcc/ada/a-swbwha.ads | 25 | ||||
| -rw-r--r-- | gcc/ada/a-swfwha.ads | 22 | ||||
| -rw-r--r-- | gcc/ada/a-szbzha.adb | 60 | ||||
| -rw-r--r-- | gcc/ada/a-szbzha.ads | 27 | ||||
| -rw-r--r-- | gcc/ada/a-szfzha.ads | 23 |
26 files changed, 1342 insertions, 487 deletions
diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 3a78e8e..04c9c6b 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 9503e88..0bb8cb7 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 bde7917..7163634 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 458e42e..980e868 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 1240aca..358c891 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 bb441a3..0e11e65 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 a29784b..59ae2a5 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 afb2190..a54683e 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 19aad29..dccb56c 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 eb1e365..2ad3613 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 ab3d4d4..7e53d1c 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 9060552..5529873 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 6d748a3..7fe8e3b 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 4720f8c..b0b7ca0 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 0000000..586451b --- /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 0000000..2b0229c --- /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 6742e28..fcb9adf 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 0000000..ba5ce06 --- /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 0000000..999850e --- /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 0000000..2338003 --- /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 0000000..42b844b --- /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 0000000..5947952 --- /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 0000000..ebabe86 --- /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 0000000..458f477 --- /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 0000000..b368d793 --- /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 0000000..1753fc7 --- /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); |