From: Justin Squirek Date: Mon, 12 Aug 2019 09:00:27 +0000 (+0000) Subject: [Ada] Implement Ada.Directories.Hierarchical_File_Names X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=5076fb182e2f99b46dca619f7be8e6e158bc902f;p=gcc.git [Ada] Implement Ada.Directories.Hierarchical_File_Names This patch corrects certain behaviors within Ada.Directories to better conform to conformance tests and implements the package Ada.Directories.Hierarchical_File_Names outlined in AI05-0049-1. Only partial test sources are included. ------------ -- Source -- ------------ -- main.ads with Ada.Directories.Hierarchical_File_Names; use Ada.Directories.Hierarchical_File_Names; with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; procedure Main is FULL_PATH_A : constant String := "/export/work/user/bug"; FULL_PATH_B : constant String := "/export/work/user"; RELATIVE_PATH_A : constant String := "export/work/user/bug/"; RELATIVE_PATH_B : constant String := "export/work/user/bug"; SIMPLE_PATH_A : constant String := "bug/"; SIMPLE_PATH_B : constant String := "bug"; ROOT_PATH : constant String := "/"; CURRENT_DIR : constant String := "."; PARENT_DIR : constant String := ".."; RELATIVE_WITH_CURRENT : constant String := RELATIVE_PATH_A & "."; RELATIVE_WITH_PARENT : constant String := RELATIVE_PATH_A & ".."; begin Put_Line ("Simple_Name"); Put_Line (Is_Simple_Name (FULL_PATH_A)'Image); Put_Line (Is_Simple_Name (FULL_PATH_B)'Image); Put_Line (Is_Simple_Name (RELATIVE_PATH_A)'Image); Put_Line (Is_Simple_Name (RELATIVE_PATH_B)'Image); Put_Line (Is_Simple_Name (SIMPLE_PATH_A)'Image); Put_Line (Is_Simple_Name (SIMPLE_PATH_B)'Image); Put_Line (Is_Simple_Name (ROOT_PATH)'Image); Put_Line (Is_Simple_Name (CURRENT_DIR)'Image); Put_Line (Is_Simple_Name (PARENT_DIR)'Image); Put_Line (Is_Simple_Name (RELATIVE_WITH_CURRENT)'Image); Put_Line (Is_Simple_Name (RELATIVE_WITH_PARENT)'Image); Put_Line (Simple_Name (FULL_PATH_A)); Put_Line (Simple_Name (FULL_PATH_B)); Put_Line (Simple_Name (RELATIVE_PATH_A)); Put_Line (Simple_Name (RELATIVE_PATH_B)); Put_Line (Simple_Name (SIMPLE_PATH_A)); Put_Line (Simple_Name (SIMPLE_PATH_B)); Put_Line (Simple_Name (ROOT_PATH)); Put_Line (Simple_Name (CURRENT_DIR)); Put_Line (Simple_Name (PARENT_DIR)); Put_Line (Simple_Name (RELATIVE_WITH_CURRENT)); Put_Line (Simple_Name (RELATIVE_WITH_PARENT)); Put_Line ("Root_Directory_Name"); Put_Line (Is_Root_Directory_Name (FULL_PATH_A)'Image); Put_Line (Is_Root_Directory_Name (FULL_PATH_B)'Image); Put_Line (Is_Root_Directory_Name (RELATIVE_PATH_A)'Image); Put_Line (Is_Root_Directory_Name (RELATIVE_PATH_B)'Image); Put_Line (Is_Root_Directory_Name (SIMPLE_PATH_A)'Image); Put_Line (Is_Root_Directory_Name (SIMPLE_PATH_B)'Image); Put_Line (Is_Root_Directory_Name (ROOT_PATH)'Image); Put_Line (Is_Root_Directory_Name (CURRENT_DIR)'Image); Put_Line (Is_Root_Directory_Name (PARENT_DIR)'Image); Put_Line (Is_Root_Directory_Name (RELATIVE_WITH_CURRENT)'Image); Put_Line (Is_Root_Directory_Name (RELATIVE_WITH_PARENT)'Image); Put_Line ("Is_Parent_Directory_Name"); Put_Line (Is_Parent_Directory_Name (FULL_PATH_A)'Image); Put_Line (Is_Parent_Directory_Name (FULL_PATH_B)'Image); Put_Line (Is_Parent_Directory_Name (RELATIVE_PATH_A)'Image); Put_Line (Is_Parent_Directory_Name (RELATIVE_PATH_B)'Image); Put_Line (Is_Parent_Directory_Name (SIMPLE_PATH_A)'Image); Put_Line (Is_Parent_Directory_Name (SIMPLE_PATH_B)'Image); Put_Line (Is_Parent_Directory_Name (ROOT_PATH)'Image); Put_Line (Is_Parent_Directory_Name (CURRENT_DIR)'Image); Put_Line (Is_Parent_Directory_Name (PARENT_DIR)'Image); Put_Line (Is_Parent_Directory_Name (RELATIVE_WITH_CURRENT)'Image); Put_Line (Is_Parent_Directory_Name (RELATIVE_WITH_PARENT)'Image); Put_Line ("Is_Current_Directory_Name"); Put_Line (Is_Current_Directory_Name (FULL_PATH_A)'Image); Put_Line (Is_Current_Directory_Name (FULL_PATH_B)'Image); Put_Line (Is_Current_Directory_Name (RELATIVE_PATH_A)'Image); Put_Line (Is_Current_Directory_Name (RELATIVE_PATH_B)'Image); Put_Line (Is_Current_Directory_Name (SIMPLE_PATH_A)'Image); Put_Line (Is_Current_Directory_Name (SIMPLE_PATH_B)'Image); Put_Line (Is_Current_Directory_Name (ROOT_PATH)'Image); Put_Line (Is_Current_Directory_Name (CURRENT_DIR)'Image); Put_Line (Is_Current_Directory_Name (PARENT_DIR)'Image); Put_Line (Is_Current_Directory_Name (RELATIVE_WITH_CURRENT)'Image); Put_Line (Is_Current_Directory_Name (RELATIVE_WITH_PARENT)'Image); Put_Line ("Is_Full_Name"); Put_Line (Is_Full_Name (FULL_PATH_A)'Image); Put_Line (Is_Full_Name (FULL_PATH_B)'Image); Put_Line (Is_Full_Name (RELATIVE_PATH_A)'Image); Put_Line (Is_Full_Name (RELATIVE_PATH_B)'Image); Put_Line (Is_Full_Name (SIMPLE_PATH_A)'Image); Put_Line (Is_Full_Name (SIMPLE_PATH_B)'Image); Put_Line (Is_Full_Name (ROOT_PATH)'Image); Put_Line (Is_Full_Name (CURRENT_DIR)'Image); Put_Line (Is_Full_Name (PARENT_DIR)'Image); Put_Line (Is_Full_Name (RELATIVE_WITH_CURRENT)'Image); Put_Line (Is_Full_Name (RELATIVE_WITH_PARENT)'Image); Put_Line ("Relative_Name"); Put_Line (Is_Relative_Name (FULL_PATH_A)'Image); Put_Line (Is_Relative_Name (FULL_PATH_B)'Image); Put_Line (Is_Relative_Name (RELATIVE_PATH_A)'Image); Put_Line (Is_Relative_Name (RELATIVE_PATH_B)'Image); Put_Line (Is_Relative_Name (SIMPLE_PATH_A)'Image); Put_Line (Is_Relative_Name (SIMPLE_PATH_B)'Image); Put_Line (Is_Relative_Name (ROOT_PATH)'Image); Put_Line (Is_Relative_Name (CURRENT_DIR)'Image); Put_Line (Is_Relative_Name (PARENT_DIR)'Image); Put_Line (Is_Relative_Name (RELATIVE_WITH_CURRENT)'Image); Put_Line (Is_Relative_Name (RELATIVE_WITH_PARENT)'Image); Put_Line (Relative_Name (FULL_PATH_A)); Put_Line (Relative_Name (FULL_PATH_B)); Put_Line (Relative_Name (RELATIVE_PATH_A)); Put_Line (Relative_Name (RELATIVE_PATH_B)); begin Put_Line (Relative_Name (SIMPLE_PATH_A)); exception when E: others => Put_Line (Exception_Information (E)); end; begin Put_Line (Relative_Name (SIMPLE_PATH_B)); exception when E: others => Put_Line (Exception_Information (E)); end; begin Put_Line (Relative_Name (ROOT_PATH)); exception when E: others => Put_Line (Exception_Information (E)); end; begin Put_Line (Relative_Name (CURRENT_DIR)); exception when E: others => Put_Line (Exception_Information (E)); end; begin Put_Line (Relative_Name (PARENT_DIR)); exception when E: others => Put_Line (Exception_Information (E)); end; Put_Line (Relative_Name (RELATIVE_WITH_CURRENT)); Put_Line (Relative_Name (RELATIVE_WITH_PARENT)); Put_Line ("Containing_Directory"); Put_Line (Containing_Directory (FULL_PATH_A)); Put_Line (Containing_Directory (FULL_PATH_B)); Put_Line (Containing_Directory (RELATIVE_PATH_A)); Put_Line (Containing_Directory (RELATIVE_PATH_B)); Put_Line (Containing_Directory (SIMPLE_PATH_A)); Put_Line (Containing_Directory (SIMPLE_PATH_B)); begin Put_Line (Containing_Directory (ROOT_PATH)); exception when E: others => Put_Line (Exception_Information (E)); end; begin Put_Line (Containing_Directory (CURRENT_DIR)); exception when E: others => Put_Line (Exception_Information (E)); end; begin Put_Line (Containing_Directory (PARENT_DIR)); exception when E: others => Put_Line (Exception_Information (E)); end; Put_Line (Containing_Directory (RELATIVE_WITH_CURRENT)); Put_Line (Containing_Directory (RELATIVE_WITH_PARENT)); Put_Line ("Initial_Directory"); Put_Line (Initial_Directory (FULL_PATH_A)); Put_Line (Initial_Directory (FULL_PATH_B)); Put_Line (Initial_Directory (RELATIVE_PATH_A)); Put_Line (Initial_Directory (RELATIVE_PATH_B)); Put_Line (Initial_Directory (SIMPLE_PATH_A)); Put_Line (Initial_Directory (SIMPLE_PATH_B)); Put_Line (Initial_Directory (ROOT_PATH)); Put_Line (Initial_Directory (CURRENT_DIR)); Put_Line (Initial_Directory (PARENT_DIR)); Put_Line (Initial_Directory (RELATIVE_WITH_CURRENT)); Put_Line (Initial_Directory (RELATIVE_WITH_PARENT)); end; ----------------- -- Compilation -- ----------------- $ gnatmake -q main.adb Simple_Name FALSE FALSE FALSE FALSE TRUE TRUE FALSE TRUE TRUE FALSE FALSE bug user bug bug bug bug / . .. . .. Root_Directory_Name FALSE FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE Is_Parent_Directory_Name FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE Is_Current_Directory_Name FALSE FALSE FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE Is_Full_Name TRUE TRUE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE Relative_Name FALSE FALSE TRUE TRUE TRUE TRUE FALSE TRUE TRUE TRUE TRUE export/work/user/bug export/work/user work/user/bug/ work/user/bug raised ADA.IO_EXCEPTIONS.NAME_ERROR : relative path name "bug/" is composed of a single part raised ADA.IO_EXCEPTIONS.NAME_ERROR : relative path name "bug" is composed of a single part raised ADA.IO_EXCEPTIONS.NAME_ERROR : relative path name "/" is composed of a single part raised ADA.IO_EXCEPTIONS.NAME_ERROR : relative path name "." is composed of a single part raised ADA.IO_EXCEPTIONS.NAME_ERROR : relative path name ".." is composed of a single part work/user/bug/. work/user/bug/.. Containing_Directory /export/work/user /export/work export/work/user/bug export/work/user bug . raised ADA.IO_EXCEPTIONS.USE_ERROR : directory "/" has no containing directory raised ADA.IO_EXCEPTIONS.USE_ERROR : directory "." has no containing directory raised ADA.IO_EXCEPTIONS.USE_ERROR : directory ".." has no containing directory export/work/user/bug export/work/user/bug Initial_Directory / / export export bug bug / . .. export export 2019-08-12 Justin Squirek gcc/ada/ * libgnat/a-dhfina.adb, libgnat/a-dhfina.ads (Is_Simple_Name, Is_Root_Directory, Is_Parent_Directory, Is_Current_Directory_Name, Is_Relative_Name, Initial_Directory, Relative_Name, Compose): Add implementation and documentation. * libgnat/a-direct.adb (Containing_Directory): Modify routine to use routines from Ada.Directories.Hierarchical_File_Names and remove incorrect special case for parent directories. (Fetch_Next_Entry): Add check for current directory and parent directory and ignore them under certain circumstances. (Simple_Nmae): Add check for null result from Simple_Name_Internal and raise Name_Error. (Simple_Name_Internal): Add explicit check for root directories, sanitize trailing directory separators, and modify behavior so that current and parent directories are considered valid results. * Makefile.rtl: Add entry to GNATRTL_NONTASKING_OBJS. From-SVN: r274295 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d1e74ab0ded..244e9179973 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2019-08-12 Justin Squirek + + * libgnat/a-dhfina.adb, libgnat/a-dhfina.ads (Is_Simple_Name, + Is_Root_Directory, Is_Parent_Directory, + Is_Current_Directory_Name, Is_Relative_Name, Initial_Directory, + Relative_Name, Compose): Add implementation and documentation. + * libgnat/a-direct.adb (Containing_Directory): Modify routine to + use routines from Ada.Directories.Hierarchical_File_Names and + remove incorrect special case for parent directories. + (Fetch_Next_Entry): Add check for current directory and parent + directory and ignore them under certain circumstances. + (Simple_Nmae): Add check for null result from + Simple_Name_Internal and raise Name_Error. + (Simple_Name_Internal): Add explicit check for root directories, + sanitize trailing directory separators, and modify behavior so + that current and parent directories are considered valid + results. + * Makefile.rtl: Add entry to GNATRTL_NONTASKING_OBJS. + 2019-08-12 Eric Botcazou * freeze.adb (Freeze_Entity): Give the same error for an diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 6528df8114c..d6dd1514f4a 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -171,6 +171,7 @@ GNATRTL_NONTASKING_OBJS= \ a-cwila1$(objext) \ a-cwila9$(objext) \ a-decima$(objext) \ + a-dhfina$(objext) \ a-diocst$(objext) \ a-direct$(objext) \ a-direio$(objext) \ diff --git a/gcc/ada/libgnat/a-dhfina.adb b/gcc/ada/libgnat/a-dhfina.adb new file mode 100644 index 00000000000..df7c3454bb8 --- /dev/null +++ b/gcc/ada/libgnat/a-dhfina.adb @@ -0,0 +1,332 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.DIRECTORIES.HIERARCHICAL_FILE_NAMES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2019, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- In particular, you can freely distribute your programs built with the -- +-- GNAT Pro compiler, including any required library run-time units, using -- +-- any licensing terms of your choosing. See the AdaCore Software License -- +-- for full details. -- +-- -- +-- 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; use Ada.Characters.Handling; +with Ada.Directories.Validity; use Ada.Directories.Validity; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with System; use System; + +package body Ada.Directories.Hierarchical_File_Names is + + Dir_Separator : constant Character; + pragma Import (C, Dir_Separator, "__gnat_dir_separator"); + -- Running system default directory separator + + ----------------- + -- Subprograms -- + ----------------- + + function Equivalent_File_Names + (Left : String; + Right : String) + return Boolean; + -- Perform an OS-independent comparison between two file paths + + function Is_Absolute_Path (Name : String) return Boolean; + -- Returns True if Name is an absolute path name, i.e. it designates a + -- file or directory absolutely rather than relative to another directory. + + --------------------------- + -- Equivalent_File_Names -- + --------------------------- + + function Equivalent_File_Names + (Left : String; + Right : String) + return Boolean + is + begin + -- Check the validity of the input paths + + if not Is_Valid_Path_Name (Left) + or else not Is_Valid_Path_Name (Right) + then + return False; + end if; + + -- Normalize the paths by removing any trailing directory separators and + -- perform the comparison. + + declare + Normal_Left : constant String := + (if Index (Left, Dir_Separator & "", Strings.Backward) = Left'Last + and then not Is_Root_Directory_Name (Left) + then + Left (Left'First .. Left'Last - 1) + else + Left); + + Normal_Right : constant String := + (if Index (Right, Dir_Separator & "", Strings.Backward) = Right'Last + and then not Is_Root_Directory_Name (Right) + then + Right (Right'First .. Right'Last - 1) + else + Right); + begin + -- Within Windows we assume case insensitivity + + if not Windows then + return Normal_Left = Normal_Right; + end if; + + -- Otherwise do a straight comparison + + return To_Lower (Normal_Left) = To_Lower (Normal_Right); + end; + end Equivalent_File_Names; + + ---------------------- + -- Is_Absolute_Path -- + ---------------------- + + function Is_Absolute_Path (Name : String) return Boolean is + function Is_Absolute_Path + (Name : Address; + Length : Integer) return Integer; + pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path"); + begin + return Is_Absolute_Path (Name'Address, Name'Length) /= 0; + end Is_Absolute_Path; + + -------------------- + -- Is_Simple_Name -- + -------------------- + + function Is_Simple_Name (Name : String) return Boolean is + begin + -- Verify the file path name is valid and that it is not a root + + if not Is_Valid_Path_Name (Name) + or else Is_Root_Directory_Name (Name) + then + return False; + end if; + + -- Check for the special paths "." and "..", which are considered simple + + if Is_Parent_Directory_Name (Name) + or else Is_Current_Directory_Name (Name) + then + return True; + end if; + + -- Perform a comparison with the calculated simple path name + + return Equivalent_File_Names (Simple_Name (Name), Name); + end Is_Simple_Name; + + ---------------------------- + -- Is_Root_Directory_Name -- + ---------------------------- + + function Is_Root_Directory_Name (Name : String) return Boolean is + begin + -- Check if the path name is a root directory by looking for a slash in + -- the general case, and a drive letter in the case of Windows. + + return Name = "/" + or else + (Windows + and then + (Name = "\" + or else + (Name'Length = 3 + and then Name (Name'Last - 1) = ':' + and then Name (Name'Last) in '/' | '\' + and then (Name (Name'First) in 'a' .. 'z' + or else + Name (Name'First) in 'A' .. 'Z')) + or else + (Name'Length = 2 + and then Name (Name'Last) = ':' + and then (Name (Name'First) in 'a' .. 'z' + or else + Name (Name'First) in 'A' .. 'Z')))); + end Is_Root_Directory_Name; + + ------------------------------ + -- Is_Parent_Directory_Name -- + ------------------------------ + + function Is_Parent_Directory_Name (Name : String) return Boolean is + begin + return Name = ".."; + end Is_Parent_Directory_Name; + + ------------------------------- + -- Is_Current_Directory_Name -- + ------------------------------- + + function Is_Current_Directory_Name (Name : String) return Boolean is + begin + return Name = "."; + end Is_Current_Directory_Name; + + ------------------ + -- Is_Full_Name -- + ------------------ + + function Is_Full_Name (Name : String) return Boolean is + begin + return Equivalent_File_Names (Full_Name (Name), Name); + end Is_Full_Name; + + ---------------------- + -- Is_Relative_Name -- + ---------------------- + + function Is_Relative_Name (Name : String) return Boolean is + begin + return not Is_Absolute_Path (Name) + and then Is_Valid_Path_Name (Name); + end Is_Relative_Name; + + ----------------------- + -- Initial_Directory -- + ----------------------- + + function Initial_Directory (Name : String) return String is + Start : constant Integer := Index (Name, Dir_Separator & ""); + begin + -- Verify path name + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + end if; + + -- When there is no starting directory separator or the path name is a + -- root directory then the path name is already simple - so return it. + + if Is_Root_Directory_Name (Name) or else Start = 0 then + return Name; + end if; + + -- When the initial directory of the path name is a root directory then + -- the starting directory separator is part of the result so we must + -- return it in the slice. + + if Is_Root_Directory_Name (Name (Name'First .. Start)) then + return Name (Name'First .. Start); + end if; + + -- Otherwise we grab a slice up to the starting directory separator + + return Name (Name'First .. Start - 1); + end Initial_Directory; + + ------------------- + -- Relative_Name -- + ------------------- + + function Relative_Name (Name : String) return String is + begin + -- We cannot derive a relative name if Name does not exist + + if not Is_Relative_Name (Name) + and then not Is_Valid_Path_Name (Name) + then + raise Name_Error with "invalid relative path name """ & Name & '"'; + end if; + + -- Name only has a single part and thus cannot be made relative + + if Is_Simple_Name (Name) + or else Is_Root_Directory_Name (Name) + then + raise Name_Error with + "relative path name """ & Name & """ is composed of a single part"; + end if; + + -- Trim the input according to the initial directory and maintain proper + -- directory separation due to the fact that root directories may + -- contain separators. + + declare + Init_Dir : constant String := Initial_Directory (Name); + begin + if Init_Dir (Init_Dir'Last) = Dir_Separator then + return Name (Name'First + Init_Dir'Length .. Name'Last); + end if; + + return Name (Name'First + Init_Dir'Length + 1 .. Name'Last); + end; + end Relative_Name; + + ------------- + -- Compose -- + ------------- + + function Compose + (Directory : String := ""; + Relative_Name : String; + Extension : String := "") return String + is + -- Append a directory separator if none is present + + Separated_Dir : constant String := + (if Directory = "" then "" + elsif Directory (Directory'Last) = Dir_Separator then Directory + else Directory & Dir_Separator); + begin + -- Check that relative name is valid + + if not Is_Relative_Name (Relative_Name) then + raise Name_Error with + "invalid relative path name """ & Relative_Name & '"'; + end if; + + -- Check that directory is valid + + if Separated_Dir /= "" + and then (not Is_Valid_Path_Name (Separated_Dir & Relative_Name)) + then + raise Name_Error with + "invalid path composition """ & Separated_Dir & Relative_Name & '"'; + end if; + + -- Check that the extension is valid + + if Extension /= "" + and then not Is_Valid_Path_Name + (Separated_Dir & Relative_Name & Extension) + then + raise Name_Error with + "invalid path composition """ + & Separated_Dir & Relative_Name & Extension & '"'; + end if; + + -- Concatenate the result + + return Separated_Dir & Relative_Name & Extension; + end Compose; + +end Ada.Directories.Hierarchical_File_Names; diff --git a/gcc/ada/libgnat/a-dhfina.ads b/gcc/ada/libgnat/a-dhfina.ads index e34c664d451..fe32d01c898 100644 --- a/gcc/ada/libgnat/a-dhfina.ads +++ b/gcc/ada/libgnat/a-dhfina.ads @@ -6,41 +6,101 @@ -- -- -- S p e c -- -- -- --- This specification is derived 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. -- +-- Copyright (C) 2004-2019, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- In particular, you can freely distribute your programs built with the -- +-- GNAT Pro compiler, including any required library run-time units, using -- +-- any licensing terms of your choosing. See the AdaCore Software License -- +-- for full details. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ package Ada.Directories.Hierarchical_File_Names is - pragma Unimplemented_Unit; function Is_Simple_Name (Name : String) return Boolean; + -- Returns True if Name is a simple name, and returns False otherwise. function Is_Root_Directory_Name (Name : String) return Boolean; + -- Returns True if Name is syntactically a root (a directory that cannot + -- be decomposed further), and returns False otherwise. function Is_Parent_Directory_Name (Name : String) return Boolean; + -- Returns True if Name can be used to indicate symbolically the parent + -- directory of any directory, and returns False otherwise. function Is_Current_Directory_Name (Name : String) return Boolean; + -- Returns True if Name can be used to indicate symbolically the directory + -- itself for any directory, and returns False otherwise. function Is_Full_Name (Name : String) return Boolean; + -- Returns True if the leftmost directory part of Name is a root, and + -- returns False otherwise. function Is_Relative_Name (Name : String) return Boolean; + -- Returns True if Name allows the identification of an external file + -- (including directories and special files) but is not a full name, and + -- returns False otherwise. function Simple_Name (Name : String) return String renames Ada.Directories.Simple_Name; + -- Returns the simple name portion of the file name specified by Name. The + -- exception Name_Error is propagated if the string given as Name does not + -- allow the identification of an external file (including directories and + -- special files). function Containing_Directory (Name : String) return String renames Ada.Directories.Containing_Directory; + -- Returns the name of the containing directory of the external file + -- (including directories) identified by Name. If more than one directory + -- can contain Name, the directory name returned is implementation-defined. + -- The exception Name_Error is propagated if the string given as Name does + -- not allow the identification of an external file. The exception + -- Use_Error is propagated if the external file does not have a containing + -- directory. function Initial_Directory (Name : String) return String; + -- Returns the leftmost directory part in Name. That is, it returns a root + -- directory name (for a full name), or one of a parent directory name, a + -- current directory name, or a simple name (for a relative name). The + -- exception Name_Error is propagated if the string given as Name does not + -- allow the identification of an external file (including directories and + -- special files). function Relative_Name (Name : String) return String; + -- Returns the entire file name except the Initial_Directory portion. The + -- exception Name_Error is propagated if the string given as Name does not + -- allow the identification of an external file (including directories and + -- special files), or if Name has a single part (this includes if any of + -- Is_Simple_Name, Is_Root_Directory_Name, Is_Parent_Directory_Name, or + -- Is_Current_Directory_Name are True). function Compose (Directory : String := ""; Relative_Name : String; Extension : String := "") return String; + -- Returns the name of the external file with the specified Directory, + -- Relative_Name, and Extension. The exception Name_Error is propagated if + -- the string given as Directory is not the null string and does not allow + -- the identification of a directory, or if Is_Relative_Name + -- (Relative_Name) is False, or if the string given as Extension is not + -- the null string and is not a possible extension, or if Extension is not + -- the null string and Simple_Name (Relative_Name) is not a base name. + -- + -- The result of Compose is a full name if Is_Full_Name (Directory) is + -- True; result is a relative name otherwise. end Ada.Directories.Hierarchical_File_Names; diff --git a/gcc/ada/libgnat/a-direct.adb b/gcc/ada/libgnat/a-direct.adb index bc489ca25f8..1a1b7085ee2 100644 --- a/gcc/ada/libgnat/a-direct.adb +++ b/gcc/ada/libgnat/a-direct.adb @@ -33,6 +33,8 @@ with Ada.Calendar; use Ada.Calendar; with Ada.Calendar.Formatting; use Ada.Calendar.Formatting; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Directories.Validity; use Ada.Directories.Validity; +with Ada.Directories.Hierarchical_File_Names; +use Ada.Directories.Hierarchical_File_Names; with Ada.Strings.Fixed; with Ada.Strings.Maps; use Ada.Strings.Maps; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; @@ -224,31 +226,22 @@ package body Ada.Directories is Strings.Fixed.Index (Name, Dir_Seps, Going => Strings.Backward); begin - if Last_DS = 0 then - - -- There is no directory separator, returns "." representing - -- the current working directory. - - return "."; - -- If Name indicates a root directory, raise Use_Error, because -- it has no containing directory. - elsif Name = "/" - or else - (Windows - and then - (Name = "\" - or else - (Name'Length = 3 - and then Name (Name'Last - 1 .. Name'Last) = ":\" - and then (Name (Name'First) in 'a' .. 'z' - or else - Name (Name'First) in 'A' .. 'Z')))) + if Is_Parent_Directory_Name (Name) + or else Is_Current_Directory_Name (Name) + or else Is_Root_Directory_Name (Name) then raise Use_Error with "directory """ & Name & """ has no containing directory"; + elsif Last_DS = 0 then + -- There is no directory separator, so return ".", representing + -- the current working directory. + + return "."; + else declare Last : Positive := Last_DS - Name'First + 1; @@ -262,31 +255,14 @@ package body Ada.Directories is -- number on Windows. while Last > 1 loop - exit when - Result (Last) /= '/' - and then - Result (Last) /= Directory_Separator; - - exit when Windows - and then Last = 3 - and then Result (2) = ':' - and then - (Result (1) in 'A' .. 'Z' - or else - Result (1) in 'a' .. 'z'); + exit when Is_Root_Directory_Name (Result (1 .. Last)) + or else (Result (Last) /= Directory_Separator + and then Result (Last) /= '/'); Last := Last - 1; end loop; - -- Special case of "..": the current directory may be a root - -- directory. - - if Last = 2 and then Result (1 .. 2) = ".." then - return Containing_Directory (Current_Directory); - - else - return Result (1 .. Last); - end if; + return Result (1 .. Last); end; end if; end; @@ -806,6 +782,20 @@ package body Ada.Directories is end if; if Exists = 1 then + -- Ignore special directories "." and ".." + + if (Full_Name'Length > 1 + and then + Full_Name + (Full_Name'Last - 1 .. Full_Name'Last) = "\.") + or else + (Full_Name'Length > 2 + and then + Full_Name + (Full_Name'Last - 2 .. Full_Name'Last) = "\..") + then + Exists := 0; + end if; -- Now check if the file kind matches the filter @@ -1280,16 +1270,30 @@ package body Ada.Directories is function Simple_Name_Internal (Path : String) return String is Cut_Start : Natural := Strings.Fixed.Index (Path, Dir_Seps, Going => Strings.Backward); - Cut_End : Natural; + + -- Cut_End points to the last simple name character + + Cut_End : Natural := Path'Last; begin - -- Cut_Start pointS to the first simple name character + -- Root directories are considered simple - Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); + if Is_Root_Directory_Name (Path) then + return Path; + end if; + + -- Handle trailing directory separators + + if Cut_Start = Path'Last then + Cut_End := Path'Last - 1; + Cut_Start := Strings.Fixed.Index + (Path (Path'First .. Path'Last - 1), + Dir_Seps, Going => Strings.Backward); + end if; - -- Cut_End point to the last simple name character + -- Cut_Start points to the first simple name character - Cut_End := Path'Last; + Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); Check_For_Standard_Dirs : declare BN : constant String := Path (Cut_Start .. Cut_End); @@ -1301,7 +1305,7 @@ package body Ada.Directories is begin if BN = "." or else BN = ".." then - return ""; + return BN; elsif Has_Drive_Letter and then BN'Length > 2