[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  <squirek@adacore.com>

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

1 files changed, 49 insertions, 45 deletions

diff --git a/gcc/ada/libgnat/a-direct.adb b/gcc/ada/libgnat/a-direct.adb
index bc489ca..1a1b708 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