diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/g-dirope.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/g-dirope.adb | 804 |
1 files changed, 0 insertions, 804 deletions
diff --git a/gcc-4.4.3/gcc/ada/g-dirope.adb b/gcc-4.4.3/gcc/ada/g-dirope.adb deleted file mode 100644 index f27336697..000000000 --- a/gcc-4.4.3/gcc/ada/g-dirope.adb +++ /dev/null @@ -1,804 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |