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

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

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

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

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



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@111035 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 228 insertions, 0 deletions

diff --git a/gcc/ada/a-envvar.adb b/gcc/ada/a-envvar.adb
new file mode 100755
index 00000000000..586451b974e
--- /dev/null
+++ b/gcc/ada/a-envvar.adb
@@ -0,0 +1,228 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--              A D A . E N V I R O N M E N T _ V A R I A B L E S           --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--            Copyright (C) 2005, Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
+-- Boston, MA 02110-1301, USA.                                              --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with System;
+with Interfaces.C.Strings;
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Environment_Variables is
+
+   -----------
+   -- Clear --
+   -----------
+
+   procedure Clear (Name : String) is
+      procedure Clear_Env_Var (Name : System.Address);
+      pragma Import (C, Clear_Env_Var, "__gnat_unsetenv");
+
+      F_Name  : String (1 .. Name'Length + 1);
+
+   begin
+      F_Name (1 .. Name'Length) := Name;
+      F_Name (F_Name'Last)      := ASCII.NUL;
+
+      Clear_Env_Var (F_Name'Address);
+   end Clear;
+
+   -----------
+   -- Clear --
+   -----------
+
+   procedure Clear is
+      procedure Clear_Env;
+      pragma Import (C, Clear_Env, "__gnat_clearenv");
+   begin
+      Clear_Env;
+   end Clear;
+
+   ------------
+   -- Exists --
+   ------------
+
+   function Exists (Name : String) return Boolean is
+      use System;
+
+      procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
+      pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
+
+      Env_Value_Ptr    : aliased Address;
+      Env_Value_Length : aliased Integer;
+      F_Name           : aliased String (1 .. Name'Length + 1);
+
+   begin
+      F_Name (1 .. Name'Length) := Name;
+      F_Name (F_Name'Last)      := ASCII.NUL;
+
+      Get_Env_Value_Ptr
+        (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
+
+      if Env_Value_Ptr = System.Null_Address then
+         return False;
+      end if;
+
+      return True;
+   end Exists;
+
+   -------------
+   -- Iterate --
+   -------------
+
+   procedure Iterate
+     (Process : not null access procedure (Name, Value : String))
+   is
+      use Interfaces.C.Strings;
+      type C_String_Array is array (Natural) of aliased chars_ptr;
+      type C_String_Array_Access is access C_String_Array;
+
+      function Get_Env return C_String_Array_Access;
+      pragma Import (C, Get_Env, "__gnat_environ");
+
+      type String_Access is access all String;
+      procedure Free is new Ada.Unchecked_Deallocation (String, String_Access);
+
+      Env_Length : Natural := 0;
+      Env        : constant C_String_Array_Access := Get_Env;
+
+   begin
+      --  If the environment is null return directly
+
+      if Env = null then
+         return;
+      end if;
+
+      --  First get the number of environment variables
+
+      loop
+         exit when Env (Env_Length) = Null_Ptr;
+         Env_Length := Env_Length + 1;
+      end loop;
+
+      declare
+         Env_Copy : array (1 .. Env_Length) of String_Access;
+
+      begin
+         --  Copy the environment
+
+         for Iterator in 1 ..  Env_Length loop
+            Env_Copy (Iterator) := new String'(Value (Env (Iterator - 1)));
+         end loop;
+
+         --  Iterate on the environment copy
+
+         for Iterator in 1 .. Env_Length loop
+            declare
+               Current_Var : constant String := Env_Copy (Iterator).all;
+               Value_Index : Natural := Env_Copy (Iterator)'First;
+
+            begin
+               loop
+                  exit when Current_Var (Value_Index) = '=';
+                  Value_Index := Value_Index + 1;
+               end loop;
+
+               Process
+                 (Current_Var (Current_Var'First .. Value_Index - 1),
+                  Current_Var (Value_Index + 1 .. Current_Var'Last));
+            end;
+         end loop;
+
+         --  Free the copy of the environment
+
+         for Iterator in 1 .. Env_Length loop
+            Free (Env_Copy (Iterator));
+         end loop;
+      end;
+   end Iterate;
+
+   ---------
+   -- Set --
+   ---------
+
+   procedure Set (Name : String; Value : String) is
+      F_Name  : String (1 .. Name'Length + 1);
+      F_Value : String (1 .. Value'Length + 1);
+
+      procedure Set_Env_Value (Name, Value : System.Address);
+      pragma Import (C, Set_Env_Value, "__gnat_setenv");
+
+   begin
+      F_Name (1 .. Name'Length) := Name;
+      F_Name (F_Name'Last)      := ASCII.NUL;
+
+      F_Value (1 .. Value'Length) := Value;
+      F_Value (F_Value'Last)      := ASCII.NUL;
+
+      Set_Env_Value (F_Name'Address, F_Value'Address);
+   end Set;
+
+   -----------
+   -- Value --
+   -----------
+
+   function Value (Name : String) return String is
+      use System;
+
+      procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
+      pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
+
+      procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
+      pragma Import (C, Strncpy, "strncpy");
+
+      Env_Value_Ptr    : aliased Address;
+      Env_Value_Length : aliased Integer;
+      F_Name           : aliased String (1 .. Name'Length + 1);
+
+   begin
+      F_Name (1 .. Name'Length) := Name;
+      F_Name (F_Name'Last)      := ASCII.NUL;
+
+      Get_Env_Value_Ptr
+        (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
+
+      if Env_Value_Ptr = System.Null_Address then
+         raise Constraint_Error;
+      end if;
+
+      if Env_Value_Length > 0 then
+         declare
+            Result : aliased String (1 .. Env_Value_Length);
+         begin
+            Strncpy (Result'Address, Env_Value_Ptr, Env_Value_Length);
+            return Result;
+         end;
+      else
+         return "";
+      end if;
+   end Value;
+
+end Ada.Environment_Variables;