aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.3/gcc/ada/g-dirope.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.3/gcc/ada/g-dirope.adb')
-rw-r--r--gcc-4.4.3/gcc/ada/g-dirope.adb804
1 files changed, 804 insertions, 0 deletions
diff --git a/gcc-4.4.3/gcc/ada/g-dirope.adb b/gcc-4.4.3/gcc/ada/g-dirope.adb
new file mode 100644
index 000000000..f27336697
--- /dev/null
+++ b/gcc-4.4.3/gcc/ada/g-dirope.adb
@@ -0,0 +1,804 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . D I R E C T O R Y _ O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-2008, AdaCore --
+-- --
+-- 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 Ada.Characters.Handling;
+with Ada.Strings.Fixed;
+
+with Ada.Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
+
+with System; use System;
+with System.CRTL; use System.CRTL;
+
+with GNAT.OS_Lib;
+
+package body GNAT.Directory_Operations is
+
+ use Ada;
+
+ Filename_Max : constant Integer := 1024;
+ -- 1024 is the value of FILENAME_MAX in stdio.h
+
+ procedure Free is new
+ Ada.Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
+
+ On_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\';
+ -- An indication that we are on Windows. Used in Get_Current_Dir, to
+ -- deal with drive letters in the beginning of absolute paths.
+
+ ---------------
+ -- Base_Name --
+ ---------------
+
+ function Base_Name
+ (Path : Path_Name;
+ Suffix : String := "") return String
+ is
+ function Get_File_Names_Case_Sensitive return Integer;
+ pragma Import
+ (C, Get_File_Names_Case_Sensitive,
+ "__gnat_get_file_names_case_sensitive");
+
+ Case_Sensitive_File_Name : constant Boolean :=
+ Get_File_Names_Case_Sensitive = 1;
+
+ function Basename
+ (Path : Path_Name;
+ Suffix : String := "") return String;
+ -- This function does the job. The only difference between Basename
+ -- and Base_Name (the parent function) is that the former is case
+ -- sensitive, while the latter is not. Path and Suffix are adjusted
+ -- appropriately before calling Basename under platforms where the
+ -- file system is not case sensitive.
+
+ --------------
+ -- Basename --
+ --------------
+
+ function Basename
+ (Path : Path_Name;
+ Suffix : String := "") return String
+ is
+ Cut_Start : Natural :=
+ Strings.Fixed.Index
+ (Path, Dir_Seps, Going => Strings.Backward);
+ Cut_End : Natural;
+
+ begin
+ -- Cut_Start point to the first basename character
+
+ if Cut_Start = 0 then
+ Cut_Start := Path'First;
+
+ else
+ Cut_Start := Cut_Start + 1;
+ end if;
+
+ -- Cut_End point to the last basename character
+
+ Cut_End := Path'Last;
+
+ -- If basename ends with Suffix, adjust Cut_End
+
+ if Suffix /= ""
+ and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
+ then
+ Cut_End := Path'Last - Suffix'Length;
+ end if;
+
+ Check_For_Standard_Dirs : declare
+ Offset : constant Integer := Path'First - Base_Name.Path'First;
+ BN : constant String :=
+ Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
+ -- Here we use Base_Name.Path to keep the original casing
+
+ Has_Drive_Letter : constant Boolean :=
+ OS_Lib.Path_Separator /= ':';
+ -- If Path separator is not ':' then we are on a DOS based OS
+ -- where this character is used as a drive letter separator.
+
+ begin
+ if BN = "." or else BN = ".." then
+ return "";
+
+ elsif Has_Drive_Letter
+ and then BN'Length > 2
+ and then Characters.Handling.Is_Letter (BN (BN'First))
+ and then BN (BN'First + 1) = ':'
+ then
+ -- We have a DOS drive letter prefix, remove it
+
+ return BN (BN'First + 2 .. BN'Last);
+
+ else
+ return BN;
+ end if;
+ end Check_For_Standard_Dirs;
+ end Basename;
+
+ -- Start processing for Base_Name
+
+ begin
+ if Path'Length <= Suffix'Length then
+ return Path;
+ end if;
+
+ if Case_Sensitive_File_Name then
+ return Basename (Path, Suffix);
+ else
+ return Basename
+ (Characters.Handling.To_Lower (Path),
+ Characters.Handling.To_Lower (Suffix));
+ end if;
+ end Base_Name;
+
+ ----------------
+ -- Change_Dir --
+ ----------------
+
+ procedure Change_Dir (Dir_Name : Dir_Name_Str) is
+ C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
+
+ function chdir (Dir_Name : String) return Integer;
+ pragma Import (C, chdir, "chdir");
+
+ begin
+ if chdir (C_Dir_Name) /= 0 then
+ raise Directory_Error;
+ end if;
+ end Change_Dir;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (Dir : in out Dir_Type) is
+ Discard : Integer;
+ pragma Warnings (Off, Discard);
+
+ function closedir (directory : DIRs) return Integer;
+ pragma Import (C, closedir, "__gnat_closedir");
+
+ begin
+ if not Is_Open (Dir) then
+ raise Directory_Error;
+ end if;
+
+ Discard := closedir (DIRs (Dir.all));
+ Free (Dir);
+ end Close;
+
+ --------------
+ -- Dir_Name --
+ --------------
+
+ function Dir_Name (Path : Path_Name) return Dir_Name_Str is
+ Last_DS : constant Natural :=
+ Strings.Fixed.Index
+ (Path, Dir_Seps, Going => Strings.Backward);
+
+ begin
+ if Last_DS = 0 then
+
+ -- There is no directory separator, returns current working directory
+
+ return "." & Dir_Separator;
+
+ else
+ return Path (Path'First .. Last_DS);
+ end if;
+ end Dir_Name;
+
+ -----------------
+ -- Expand_Path --
+ -----------------
+
+ function Expand_Path
+ (Path : Path_Name;
+ Mode : Environment_Style := System_Default) return Path_Name
+ is
+ Environment_Variable_Char : Character;
+ pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");
+
+ Result : OS_Lib.String_Access := new String (1 .. 200);
+ Result_Last : Natural := 0;
+
+ procedure Append (C : Character);
+ procedure Append (S : String);
+ -- Append to Result
+
+ procedure Double_Result_Size;
+ -- Reallocate Result, doubling its size
+
+ function Is_Var_Prefix (C : Character) return Boolean;
+ pragma Inline (Is_Var_Prefix);
+
+ procedure Read (K : in out Positive);
+ -- Update Result while reading current Path starting at position K. If
+ -- a variable is found, call Var below.
+
+ procedure Var (K : in out Positive);
+ -- Translate variable name starting at position K with the associated
+ -- environment value.
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append (C : Character) is
+ begin
+ if Result_Last = Result'Last then
+ Double_Result_Size;
+ end if;
+
+ Result_Last := Result_Last + 1;
+ Result (Result_Last) := C;
+ end Append;
+
+ procedure Append (S : String) is
+ begin
+ while Result_Last + S'Length - 1 > Result'Last loop
+ Double_Result_Size;
+ end loop;
+
+ Result (Result_Last + 1 .. Result_Last + S'Length) := S;
+ Result_Last := Result_Last + S'Length;
+ end Append;
+
+ ------------------------
+ -- Double_Result_Size --
+ ------------------------
+
+ procedure Double_Result_Size is
+ New_Result : constant OS_Lib.String_Access :=
+ new String (1 .. 2 * Result'Last);
+ begin
+ New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
+ OS_Lib.Free (Result);
+ Result := New_Result;
+ end Double_Result_Size;
+
+ -------------------
+ -- Is_Var_Prefix --
+ -------------------
+
+ function Is_Var_Prefix (C : Character) return Boolean is
+ begin
+ return (C = Environment_Variable_Char and then Mode = System_Default)
+ or else
+ (C = '$' and then (Mode = UNIX or else Mode = Both))
+ or else
+ (C = '%' and then (Mode = DOS or else Mode = Both));
+ end Is_Var_Prefix;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read (K : in out Positive) is
+ P : Character;
+
+ begin
+ For_All_Characters : loop
+ if Is_Var_Prefix (Path (K)) then
+ P := Path (K);
+
+ -- Could be a variable
+
+ if K < Path'Last then
+ if Path (K + 1) = P then
+
+ -- Not a variable after all, this is a double $ or %,
+ -- just insert one in the result string.
+
+ Append (P);
+ K := K + 1;
+
+ else
+ -- Let's parse the variable
+
+ Var (K);
+ end if;
+
+ else
+ -- We have an ending $ or % sign
+
+ Append (P);
+ end if;
+
+ else
+ -- This is a standard character, just add it to the result
+
+ Append (Path (K));
+ end if;
+
+ -- Skip to next character
+
+ K := K + 1;
+
+ exit For_All_Characters when K > Path'Last;
+ end loop For_All_Characters;
+ end Read;
+
+ ---------
+ -- Var --
+ ---------
+
+ procedure Var (K : in out Positive) is
+ P : constant Character := Path (K);
+ T : Character;
+ E : Positive;
+
+ begin
+ K := K + 1;
+
+ if P = '%' or else Path (K) = '{' then
+
+ -- Set terminator character
+
+ if P = '%' then
+ T := '%';
+ else
+ T := '}';
+ K := K + 1;
+ end if;
+
+ -- Look for terminator character, k point to the first character
+ -- for the variable name.
+
+ E := K;
+
+ loop
+ E := E + 1;
+ exit when Path (E) = T or else E = Path'Last;
+ end loop;
+
+ if Path (E) = T then
+
+ -- OK found, translate with environment value
+
+ declare
+ Env : OS_Lib.String_Access :=
+ OS_Lib.Getenv (Path (K .. E - 1));
+
+ begin
+ Append (Env.all);
+ OS_Lib.Free (Env);
+ end;
+
+ else
+ -- No terminator character, not a variable after all or a
+ -- syntax error, ignore it, insert string as-is.
+
+ Append (P); -- Add prefix character
+
+ if T = '}' then -- If we were looking for curly bracket
+ Append ('{'); -- terminator, add the curly bracket
+ end if;
+
+ Append (Path (K .. E));
+ end if;
+
+ else
+ -- The variable name is everything from current position to first
+ -- non letter/digit character.
+
+ E := K;
+
+ -- Check that first character is a letter
+
+ if Characters.Handling.Is_Letter (Path (E)) then
+ E := E + 1;
+
+ Var_Name : loop
+ exit Var_Name when E > Path'Last;
+
+ if Characters.Handling.Is_Letter (Path (E))
+ or else Characters.Handling.Is_Digit (Path (E))
+ then
+ E := E + 1;
+ else
+ exit Var_Name;
+ end if;
+ end loop Var_Name;
+
+ E := E - 1;
+
+ declare
+ Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
+
+ begin
+ Append (Env.all);
+ OS_Lib.Free (Env);
+ end;
+
+ else
+ -- This is not a variable after all
+
+ Append ('$');
+ Append (Path (E));
+ end if;
+
+ end if;
+
+ K := E;
+ end Var;
+
+ -- Start of processing for Expand_Path
+
+ begin
+ declare
+ K : Positive := Path'First;
+
+ begin
+ Read (K);
+
+ declare
+ Returned_Value : constant String := Result (1 .. Result_Last);
+
+ begin
+ OS_Lib.Free (Result);
+ return Returned_Value;
+ end;
+ end;
+ end Expand_Path;
+
+ --------------------
+ -- File_Extension --
+ --------------------
+
+ function File_Extension (Path : Path_Name) return String is
+ First : Natural :=
+ Strings.Fixed.Index
+ (Path, Dir_Seps, Going => Strings.Backward);
+
+ Dot : Natural;
+
+ begin
+ if First = 0 then
+ First := Path'First;
+ end if;
+
+ Dot := Strings.Fixed.Index (Path (First .. Path'Last),
+ ".",
+ Going => Strings.Backward);
+
+ if Dot = 0 or else Dot = Path'Last then
+ return "";
+ else
+ return Path (Dot .. Path'Last);
+ end if;
+ end File_Extension;
+
+ ---------------
+ -- File_Name --
+ ---------------
+
+ function File_Name (Path : Path_Name) return String is
+ begin
+ return Base_Name (Path);
+ end File_Name;
+
+ ---------------------
+ -- Format_Pathname --
+ ---------------------
+
+ function Format_Pathname
+ (Path : Path_Name;
+ Style : Path_Style := System_Default) return String
+ is
+ N_Path : String := Path;
+ K : Positive := N_Path'First;
+ Prev_Dirsep : Boolean := False;
+
+ begin
+ if Dir_Separator = '\'
+ and then Path'Length > 1
+ and then Path (K .. K + 1) = "\\"
+ then
+ if Style = UNIX then
+ N_Path (K .. K + 1) := "//";
+ end if;
+
+ K := K + 2;
+ end if;
+
+ for J in K .. Path'Last loop
+ if Strings.Maps.Is_In (Path (J), Dir_Seps) then
+ if not Prev_Dirsep then
+ case Style is
+ when UNIX => N_Path (K) := '/';
+ when DOS => N_Path (K) := '\';
+ when System_Default => N_Path (K) := Dir_Separator;
+ end case;
+
+ K := K + 1;
+ end if;
+
+ Prev_Dirsep := True;
+
+ else
+ N_Path (K) := Path (J);
+ K := K + 1;
+ Prev_Dirsep := False;
+ end if;
+ end loop;
+
+ return N_Path (N_Path'First .. K - 1);
+ end Format_Pathname;
+
+ ---------------------
+ -- Get_Current_Dir --
+ ---------------------
+
+ Max_Path : Integer;
+ pragma Import (C, Max_Path, "__gnat_max_path_len");
+
+ function Get_Current_Dir return Dir_Name_Str is
+ Current_Dir : String (1 .. Max_Path + 1);
+ Last : Natural;
+ begin
+ Get_Current_Dir (Current_Dir, Last);
+ return Current_Dir (1 .. Last);
+ end Get_Current_Dir;
+
+ procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is
+ Path_Len : Natural := Max_Path;
+ Buffer : String (Dir'First .. Dir'First + Max_Path + 1);
+
+ procedure Local_Get_Current_Dir
+ (Dir : System.Address;
+ Length : System.Address);
+ pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
+
+ begin
+ Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
+
+ if Dir'Length > Path_Len then
+ Last := Dir'First + Path_Len - 1;
+ else
+ Last := Dir'Last;
+ end if;
+
+ Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
+
+ -- By default, the drive letter on Windows is in upper case
+
+ if On_Windows and then Last > Dir'First and then
+ Dir (Dir'First + 1) = ':'
+ then
+ Dir (Dir'First) :=
+ Ada.Characters.Handling.To_Upper (Dir (Dir'First));
+ end if;
+ end Get_Current_Dir;
+
+ -------------
+ -- Is_Open --
+ -------------
+
+ function Is_Open (Dir : Dir_Type) return Boolean is
+ begin
+ return Dir /= Null_Dir
+ and then System.Address (Dir.all) /= System.Null_Address;
+ end Is_Open;
+
+ --------------
+ -- Make_Dir --
+ --------------
+
+ procedure Make_Dir (Dir_Name : Dir_Name_Str) is
+ C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
+
+ function mkdir (Dir_Name : String) return Integer;
+ pragma Import (C, mkdir, "__gnat_mkdir");
+
+ begin
+ if mkdir (C_Dir_Name) /= 0 then
+ raise Directory_Error;
+ end if;
+ end Make_Dir;
+
+ ----------
+ -- Open --
+ ----------
+
+ procedure Open
+ (Dir : out Dir_Type;
+ Dir_Name : Dir_Name_Str)
+ is
+ function opendir (file_name : String) return DIRs;
+ pragma Import (C, opendir, "__gnat_opendir");
+
+ C_File_Name : constant String := Dir_Name & ASCII.NUL;
+
+ begin
+ Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name)));
+
+ if not Is_Open (Dir) then
+ Free (Dir);
+ Dir := Null_Dir;
+ raise Directory_Error;
+ end if;
+ end Open;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Dir : Dir_Type;
+ Str : out String;
+ Last : out Natural)
+ is
+ Filename_Addr : Address;
+ Filename_Len : aliased Integer;
+
+ Buffer : array (0 .. Filename_Max + 12) of Character;
+ -- 12 is the size of the dirent structure (see dirent.h), without the
+ -- field for the filename.
+
+ function readdir_gnat
+ (Directory : System.Address;
+ Buffer : System.Address;
+ Last : not null access Integer) return System.Address;
+ pragma Import (C, readdir_gnat, "__gnat_readdir");
+
+ begin
+ if not Is_Open (Dir) then
+ raise Directory_Error;
+ end if;
+
+ Filename_Addr :=
+ readdir_gnat
+ (System.Address (Dir.all), Buffer'Address, Filename_Len'Access);
+
+ if Filename_Addr = System.Null_Address then
+ Last := 0;
+ return;
+ end if;
+
+ if Str'Length > Filename_Len then
+ Last := Str'First + Filename_Len - 1;
+ else
+ Last := Str'Last;
+ end if;
+
+ declare
+ subtype Path_String is String (1 .. Filename_Len);
+ type Path_String_Access is access Path_String;
+
+ function Address_To_Access is new
+ Ada.Unchecked_Conversion
+ (Source => Address,
+ Target => Path_String_Access);
+
+ Path_Access : constant Path_String_Access :=
+ Address_To_Access (Filename_Addr);
+
+ begin
+ for J in Str'First .. Last loop
+ Str (J) := Path_Access (J - Str'First + 1);
+ end loop;
+ end;
+ end Read;
+
+ -------------------------
+ -- Read_Is_Thread_Sage --
+ -------------------------
+
+ function Read_Is_Thread_Safe return Boolean is
+ function readdir_is_thread_safe return Integer;
+ pragma Import
+ (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
+ begin
+ return (readdir_is_thread_safe /= 0);
+ end Read_Is_Thread_Safe;
+
+ ----------------
+ -- Remove_Dir --
+ ----------------
+
+ procedure Remove_Dir
+ (Dir_Name : Dir_Name_Str;
+ Recursive : Boolean := False)
+ is
+ C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
+ Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
+ Last : Integer;
+ Str : String (1 .. Filename_Max);
+ Success : Boolean;
+ Working_Dir : Dir_Type;
+
+ begin
+ -- Remove the directory only if it is empty
+
+ if not Recursive then
+ rmdir (C_Dir_Name);
+
+ if GNAT.OS_Lib.Is_Directory (Dir_Name) then
+ raise Directory_Error;
+ end if;
+
+ -- Remove directory and all files and directories that it may contain
+
+ else
+ -- Substantial comments needed. See RH for revision 1.50 ???
+
+ begin
+ Change_Dir (Dir_Name);
+ Open (Working_Dir, ".");
+
+ loop
+ Read (Working_Dir, Str, Last);
+ exit when Last = 0;
+
+ if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then
+ if Str (1 .. Last) /= "."
+ and then
+ Str (1 .. Last) /= ".."
+ then
+ Remove_Dir (Str (1 .. Last), True);
+ Remove_Dir (Str (1 .. Last));
+ end if;
+
+ else
+ GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
+
+ if not Success then
+ Change_Dir (Current_Dir);
+ raise Directory_Error;
+ end if;
+ end if;
+ end loop;
+
+ Change_Dir (Current_Dir);
+ Close (Working_Dir);
+ Remove_Dir (Dir_Name);
+
+ exception
+ when others =>
+
+ -- An exception occurred. We must make sure the current working
+ -- directory is unchanged.
+
+ Change_Dir (Current_Dir);
+
+ -- What if the Change_Dir raises an exception itself, shouldn't
+ -- that be protected? ???
+
+ raise;
+ end;
+ end if;
+ end Remove_Dir;
+
+end GNAT.Directory_Operations;