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);
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);
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;
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;
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;
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;
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;
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;
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;
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;
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.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);
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;
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream map cursor";
end Read;
---------------
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;
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;
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;
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream map cursor";
end Write;
----------------
-- --
-- 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 --
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
-----------------------
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);
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);
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
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;
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);
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;
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;
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;
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
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);
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;
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
---------------
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;
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
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);
null;
end Reinsert_Old_Element;
- raise Program_Error;
+ raise Program_Error with "attempt to replace existing element";
end Replace_Element;
procedure Replace_Element
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;
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
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
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
----------------
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);
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;
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;
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);
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
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
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;
Free (X);
end;
- raise Program_Error;
+ raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
end Generic_Keys;
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);
-- --
-- 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 --
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),
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),
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),
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),
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),
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),
begin
if Node = Done then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete element not in set";
end if;
loop
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),
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),
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;
begin
if Node = Done then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete key not in set";
end if;
loop
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "key not in set";
end if;
return Node.Element.all;
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),
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;
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;
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;
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);
--------------
--------------
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;
----------------------
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;
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),
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
---------------------
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
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),
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
end Ada.Containers.Indefinite_Ordered_Multisets;
-- --
-- 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 --
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
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),
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),
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),
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),
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),
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),
-- 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),
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);
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),
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;
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);
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "key not in set";
end if;
return Node.Element.all;
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),
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);
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),
Free (X);
end;
- raise Program_Error;
+ raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
end Generic_Keys;
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;
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;
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;
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");
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");
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),
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
-------------
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;
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
null;
end Reinsert_Old_Element;
- raise Program_Error;
+ raise Program_Error with "attempt to replace existing element";
end Replace_Element;
procedure Replace_Element
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),
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
end Ada.Containers.Indefinite_Ordered_Sets;
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);
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);
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;
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;
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;
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;
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;
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;
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);
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;
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream map cursor";
end Read;
---------------
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;
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;
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;
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream map cursor";
end Write;
----------------
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);
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);
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
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;
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;
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;
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;
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;
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
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);
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;
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
---------------
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;
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
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);
null;
end Reinsert_Old_Element;
- raise Program_Error;
+ raise Program_Error with "attempt to replace existing element";
end Replace_Element;
procedure Replace_Element
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;
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
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
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
----------------
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);
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;
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;
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);
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
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
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;
Free (X);
end;
- raise Program_Error;
+ raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
end Generic_Keys;
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);
-- --
-- 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 --
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),
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),
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),
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),
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),
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),
begin
if Node = Done then
- raise Constraint_Error;
+ raise Constraint_Error with
+ "attempt to delete element not in set";
end if;
loop
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),
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),
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;
begin
if Node = Done then
- raise Constraint_Error;
+ raise Constraint_Error with "attempt to delete key not in set";
end if;
loop
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;
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),
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;
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;
-- 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);
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;
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);
--------------
-- 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;
----------------------
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;
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),
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
---------------------
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;
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),
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
end Ada.Containers.Ordered_Multisets;
-- --
-- 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 --
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
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),
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),
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),
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),
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),
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),
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),
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);
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),
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;
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);
begin
if Node = null then
- raise Constraint_Error;
+ raise Constraint_Error with "key not in set";
end if;
return Node.Element;
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),
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);
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),
Free (X);
end;
- raise Program_Error;
+ raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
end Generic_Keys;
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;
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;
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;
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),
Item : out Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Read;
-------------
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;
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;
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
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),
Item : Cursor)
is
begin
- raise Program_Error;
+ raise Program_Error with "attempt to stream set cursor";
end Write;
end Ada.Containers.Ordered_Sets;
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
Ops.Set_Parent (Z, Y);
Ops.Rebalance_For_Insert (Tree, Z);
- Tree.Length := New_Length;
+ Tree.Length := Tree.Length + 1;
end Generic_Insert_Post;
-----------------------
-- --
-- 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 --
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);
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,
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);
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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
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);
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
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
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
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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
projects / platform / upstream / gcc.git / commitdiff