Skip to content

R
riscv-gcc-1
Commit ffabcde5 by Matthew Heaney Committed by Arnaud Charlet
Options

a-rbtgso.adb, [...]: All explicit raise statements now include an exception message. 

2006-02-13  Matthew Heaney  <heaney@adacore.com>

	* a-rbtgso.adb, a-crbtgo.adb, a-crbtgk.adb, a-coorse.adb, 
	a-cohama.adb, a-ciorse.adb, a-cihama.adb, a-cihase.adb, 
	a-cohase.adb: All explicit raise statements now include an exception
	message.

	* a-ciormu.ads, a-ciormu.adb, a-coormu.ads, a-coormu.adb
	(Update_Element_Preserving_Key): renamed op to just Update_Element.
	Explicit raise statements now include an exception message

	* a-cihase.ads, a-cohase.ads: Removed comment.

	* a-stboha.ads, a-stboha.adb, a-stfiha.ads, a-envvar.adb,
	a-envvar.ads, a-swbwha.ads, a-swbwha.adb, a-swfwha.ads, a-szbzha.ads,
	a-szbzha.adb, a-szfzha.ads: New files.

From-SVN: r111035
parent 738819cd
Showing with 940 additions and 216 deletions
gcc/ada/a-cihase.ads
......@@ -180,7 +180,7 @@ package Ada.Containers.Indefinite_Hashed_Sets is
function Element (Container : Set; Key : Key_Type) return Element_Type;
procedure Replace -- TODO: ask Randy why this is still here
procedure Replace
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
......
gcc/ada/a-ciormu.ads
......@@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
......@@ -216,7 +216,7 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
function Contains (Container : Set; Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
procedure Update_Element
(Container : in out Set;
Position : Cursor;
Process : not null access
......
gcc/ada/a-cohama.adb
......@@ -180,7 +180,7 @@ package body Ada.Containers.Hashed_Maps is
Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
if X = null then
raise Constraint_Error;
raise Constraint_Error with "attempt to delete key not in map";
end if;
Free (X);
......@@ -188,20 +188,23 @@ package body Ada.Containers.Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
pragma Assert (Vet (Position), "bad cursor in Delete");
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor of Delete equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor of Delete designates wrong map";
end if;
if Container.HT.Busy > 0 then
raise Program_Error;
raise Program_Error with
"Delete attempted to tamper with elements (map is busy)";
end if;
pragma Assert (Vet (Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
Free (Position.Node);
......@@ -217,7 +220,8 @@ package body Ada.Containers.Hashed_Maps is
begin
if Node = null then
raise Constraint_Error;
raise Constraint_Error with
"no element available because key not in map";
end if;
return Node.Element;
......@@ -225,12 +229,13 @@ package body Ada.Containers.Hashed_Maps is
function Element (Position : Cursor) return Element_Type is
begin
pragma Assert (Vet (Position), "bad cursor in function Element");
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor of function Element equals No_Element";
end if;
pragma Assert (Vet (Position), "bad cursor in function Element");
return Position.Node.Element;
end Element;
......@@ -252,37 +257,43 @@ package body Ada.Containers.Hashed_Maps is
function Equivalent_Keys (Left, Right : Cursor)
return Boolean is
begin
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Left.Node = null then
raise Constraint_Error with
"Left cursor of Equivalent_Keys equals No_Element";
end if;
if Left.Node = null
or else Right.Node = null
then
raise Constraint_Error;
if Right.Node = null then
raise Constraint_Error with
"Right cursor of Equivalent_Keys equals No_Element";
end if;
pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad");
pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
end Equivalent_Keys;
function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
begin
pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
if Left.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Left cursor of Equivalent_Keys equals No_Element";
end if;
pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad");
return Equivalent_Keys (Left.Node.Key, Right);
end Equivalent_Keys;
function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
begin
pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
if Right.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Right cursor of Equivalent_Keys equals No_Element";
end if;
pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
return Equivalent_Keys (Left, Right.Node.Key);
end Equivalent_Keys;
......@@ -409,7 +420,8 @@ package body Ada.Containers.Hashed_Maps is
if not Inserted then
if Container.HT.Lock > 0 then
raise Program_Error;
raise Program_Error with
"Include attempted to tamper with cursors (map is locked)";
end if;
Position.Node.Key := Key;
......@@ -518,7 +530,8 @@ package body Ada.Containers.Hashed_Maps is
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
raise Constraint_Error;
raise Constraint_Error with
"attempt to insert key already in map";
end if;
end Insert;
......@@ -565,12 +578,13 @@ package body Ada.Containers.Hashed_Maps is
function Key (Position : Cursor) return Key_Type is
begin
pragma Assert (Vet (Position), "bad cursor in function Key");
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor of function Key equals No_Element";
end if;
pragma Assert (Vet (Position), "bad cursor in function Key");
return Position.Node.Key;
end Key;
......@@ -606,12 +620,12 @@ package body Ada.Containers.Hashed_Maps is
function Next (Position : Cursor) return Cursor is
begin
pragma Assert (Vet (Position), "bad cursor in function Next");
if Position.Node = null then
return No_Element;
end if;
pragma Assert (Vet (Position), "bad cursor in function Next");
declare
HT : Hash_Table_Type renames Position.Container.HT;
Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
......@@ -640,12 +654,13 @@ package body Ada.Containers.Hashed_Maps is
procedure (Key : Key_Type; Element : Element_Type))
is
begin
pragma Assert (Vet (Position), "bad cursor in Query_Element");
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor of Query_Element equals No_Element";
end if;
pragma Assert (Vet (Position), "bad cursor in Query_Element");
declare
M : Map renames Position.Container.all;
HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
......@@ -692,7 +707,7 @@ package body Ada.Containers.Hashed_Maps is
Item : out Cursor)
is
begin
raise Program_Error;
raise Program_Error with "attempt to stream map cursor";
end Read;
---------------
......@@ -728,11 +743,13 @@ package body Ada.Containers.Hashed_Maps is
begin
if Node = null then
raise Constraint_Error;
raise Constraint_Error with
"attempt to replace key not in map";
end if;
if Container.HT.Lock > 0 then
raise Program_Error;
raise Program_Error with
"Replace attempted to tamper with cursors (map is locked)";
end if;
Node.Key := Key;
......@@ -749,20 +766,23 @@ package body Ada.Containers.Hashed_Maps is
New_Item : Element_Type)
is
begin
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor of Replace_Element equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor of Replace_Element designates wrong map";
end if;
if Position.Container.HT.Lock > 0 then
raise Program_Error;
raise Program_Error with
"Replace_Element attempted to tamper with cursors (map is locked)";
end if;
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
Position.Node.Element := New_Item;
end Replace_Element;
......@@ -798,16 +818,18 @@ package body Ada.Containers.Hashed_Maps is
Element : in out Element_Type))
is
begin
pragma Assert (Vet (Position), "bad cursor in Update_Element");
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor of Update_Element equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor of Update_Element designates wrong map";
end if;
pragma Assert (Vet (Position), "bad cursor in Update_Element");
declare
HT : Hash_Table_Type renames Container.HT;
B : Natural renames HT.Busy;
......@@ -906,7 +928,7 @@ package body Ada.Containers.Hashed_Maps is
Item : Cursor)
is
begin
raise Program_Error;
raise Program_Error with "attempt to stream map cursor";
end Write;
----------------
......
gcc/ada/a-cohase.ads
......@@ -179,7 +179,7 @@ package Ada.Containers.Hashed_Sets is
function Element (Container : Set; Key : Key_Type) return Element_Type;
procedure Replace -- TODO: ask Randy why this wasn't removed
procedure Replace
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
......
gcc/ada/a-coormu.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
......@@ -223,7 +223,7 @@ package Ada.Containers.Ordered_Multisets is
function Contains (Container : Set; Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
procedure Update_Element
(Container : in out Set;
Position : Cursor;
Process : not null access
......
gcc/ada/a-coorse.adb
......@@ -159,10 +159,12 @@ package body Ada.Containers.Ordered_Sets is
function "<" (Left, Right : Cursor) return Boolean is
begin
if Left.Node = null
or else Right.Node = null
then
raise Constraint_Error;
if Left.Node = null then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
if Right.Node = null then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
......@@ -177,7 +179,7 @@ package body Ada.Containers.Ordered_Sets is
function "<" (Left : Cursor; Right : Element_Type) return Boolean is
begin
if Left.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Left cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
......@@ -189,7 +191,7 @@ package body Ada.Containers.Ordered_Sets is
function "<" (Left : Element_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
......@@ -213,10 +215,12 @@ package body Ada.Containers.Ordered_Sets is
function ">" (Left, Right : Cursor) return Boolean is
begin
if Left.Node = null
or else Right.Node = null
then
raise Constraint_Error;
if Left.Node = null then
raise Constraint_Error with "Left cursor equals No_Element";
end if;
if Right.Node = null then
raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
......@@ -233,7 +237,7 @@ package body Ada.Containers.Ordered_Sets is
function ">" (Left : Element_Type; Right : Cursor) return Boolean is
begin
if Right.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Right cursor equals No_Element";
end if;
pragma Assert (Vet (Right.Container.Tree, Right.Node),
......@@ -245,7 +249,7 @@ package body Ada.Containers.Ordered_Sets is
function ">" (Left : Cursor; Right : Element_Type) return Boolean is
begin
if Left.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Left cursor equals No_Element";
end if;
pragma Assert (Vet (Left.Container.Tree, Left.Node),
......@@ -337,11 +341,11 @@ package body Ada.Containers.Ordered_Sets is
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with "Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
......@@ -357,7 +361,7 @@ package body Ada.Containers.Ordered_Sets is
begin
if X = null then
raise Constraint_Error;
raise Constraint_Error with "attempt to delete element not in set";
end if;
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
......@@ -417,7 +421,7 @@ package body Ada.Containers.Ordered_Sets is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Position cursor equals No_Element";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
......@@ -523,7 +527,7 @@ package body Ada.Containers.Ordered_Sets is
function First_Element (Container : Set) return Element_Type is
begin
if Container.Tree.First = null then
raise Constraint_Error;
raise Constraint_Error with "set is empty";
end if;
return Container.Tree.First.Element;
......@@ -628,7 +632,7 @@ package body Ada.Containers.Ordered_Sets is
begin
if X = null then
raise Constraint_Error;
raise Constraint_Error with "attempt to delete key not in set";
end if;
Delete_Node_Sans_Free (Container.Tree, X);
......@@ -645,7 +649,7 @@ package body Ada.Containers.Ordered_Sets is
begin
if Node = null then
raise Constraint_Error;
raise Constraint_Error with "key not in set";
end if;
return Node.Element;
......@@ -741,7 +745,8 @@ package body Ada.Containers.Ordered_Sets is
function Key (Position : Cursor) return Key_Type is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
......@@ -763,7 +768,8 @@ package body Ada.Containers.Ordered_Sets is
begin
if Node = null then
raise Constraint_Error;
raise Constraint_Error with
"attempt to replace key not in set";
end if;
Replace_Element (Container.Tree, Node, New_Item);
......@@ -782,11 +788,13 @@ package body Ada.Containers.Ordered_Sets is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
......@@ -827,7 +835,7 @@ package body Ada.Containers.Ordered_Sets is
Free (X);
end;
raise Program_Error;
raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
end Generic_Keys;
......@@ -854,7 +862,8 @@ package body Ada.Containers.Ordered_Sets is
if not Inserted then
if Container.Tree.Lock > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
Position.Node.Element := New_Item;
......@@ -892,7 +901,8 @@ package body Ada.Containers.Ordered_Sets is
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
raise Constraint_Error;
raise Constraint_Error with
"attempt to insert element already in set";
end if;
end Insert;
......@@ -1130,7 +1140,7 @@ package body Ada.Containers.Ordered_Sets is
function Last_Element (Container : Set) return Element_Type is
begin
if Container.Tree.Last = null then
raise Constraint_Error;
raise Constraint_Error with "set is empty";
end if;
return Container.Tree.Last.Element;
......@@ -1256,7 +1266,7 @@ package body Ada.Containers.Ordered_Sets is
is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with "Position cursor equals No_Element";
end if;
pragma Assert (Vet (Position.Container.Tree, Position.Node),
......@@ -1331,7 +1341,7 @@ package body Ada.Containers.Ordered_Sets is
Item : out Cursor)
is
begin
raise Program_Error;
raise Program_Error with "attempt to stream set cursor";
end Read;
-------------
......@@ -1344,11 +1354,13 @@ package body Ada.Containers.Ordered_Sets is
begin
if Node = null then
raise Constraint_Error;
raise Constraint_Error with
"attempt to replace element not in set";
end if;
if Container.Tree.Lock > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
Node.Element := New_Item;
......@@ -1370,7 +1382,8 @@ package body Ada.Containers.Ordered_Sets is
null;
else
if Tree.Lock > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
Node.Element := Item;
......@@ -1465,7 +1478,7 @@ package body Ada.Containers.Ordered_Sets is
null; -- Assignment must have failed
end Reinsert_Old_Element;
raise Program_Error;
raise Program_Error with "attempt to replace existing element";
end Replace_Element;
procedure Replace_Element
......@@ -1475,11 +1488,13 @@ package body Ada.Containers.Ordered_Sets is
is
begin
if Position.Node = null then
raise Constraint_Error;
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error;
raise Program_Error with
"Position cursor designates wrong set";
end if;
pragma Assert (Vet (Container.Tree, Position.Node),
......@@ -1660,7 +1675,7 @@ package body Ada.Containers.Ordered_Sets is
Item : Cursor)
is
begin
raise Program_Error;
raise Program_Error with "attempt to stream set cursor";
end Write;
end Ada.Containers.Ordered_Sets;
gcc/ada/a-crbtgk.adb
......@@ -254,13 +254,14 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Key : Key_Type;
Z : out Node_Access)
is
subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1;
New_Length : constant Count_Type := Length_Subtype'(Tree.Length) + 1;
begin
if Tree.Length = Count_Type'Last then
raise Constraint_Error with "too many elements";
end if;
if Tree.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
if Y = null
......@@ -316,7 +317,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is
Ops.Set_Parent (Z, Y);
Ops.Rebalance_For_Insert (Tree, Z);
Tree.Length := New_Length;
Tree.Length := Tree.Length + 1;
end Generic_Insert_Post;
-----------------------
......
gcc/ada/a-crbtgo.adb
......@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
......@@ -246,7 +246,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
begin
if Tree.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
-- pragma Assert (Tree.Length > 0);
......@@ -523,7 +524,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
Root : Node_Access := Tree.Root;
begin
if Tree.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
Tree := (First => null,
......@@ -672,7 +674,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
end if;
if Source.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
Clear (Target);
......@@ -771,7 +774,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Generic_Write
(Stream : access Root_Stream_Type'Class;
Tree : in Tree_Type)
Tree : Tree_Type)
is
procedure Process (Node : Node_Access);
pragma Inline (Process);
......
gcc/ada/a-envvar.adb 0 → 100755
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-envvar.ads 0 → 100755
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-rbtgso.adb
......@@ -96,7 +96,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
begin
if Target'Address = Source'Address then
if Target.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
Clear (Target);
......@@ -108,7 +109,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
end if;
if Target.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
loop
......@@ -222,7 +224,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
end if;
if Target.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
if Source.Length = 0 then
......@@ -400,7 +403,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
begin
if Target.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
if Target'Address = Source'Address then
......@@ -566,7 +570,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
end if;
if Target.Busy > 0 then
raise Program_Error;
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
Iterate (Source);
......
gcc/ada/a-stboha.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-stboha.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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);
gcc/ada/a-stfiha.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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);
gcc/ada/a-swbwha.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-swbwha.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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);
gcc/ada/a-swfwha.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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);
gcc/ada/a-szbzha.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-szbzha.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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);
gcc/ada/a-szfzha.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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);
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment