[Ada] ACATS 4.1G - CXAG003 - Name_Case_Equivalence doesn't exist

Implement a missing portion of Ada 2005's AI05-0049-1 for subprogram
Ada.Directories.Name_Case_Equivalence so that user programs can account for
operating system differences in case sensitivity.

------------
-- Source --
------------

--  main.adb

with Ada.Directories; use Ada.Directories;
with Ada.Text_IO;     use Ada.Text_IO;
procedure Main is
begin

  --  Directory layout:
  --     /empty +-- Nothing...
  --
  --     /mutliplefiles +-- "TEST1.TXT"
  --                    |
  --                "test1.txt"
  --
  --     /singlefile +-- "test1.txt"
  --
  --     /noncasable +-- "!"
  --

  Put_Line (Name_Case_Equivalence ("./empty")'Image);
  Put_Line (Name_Case_Equivalence ("./multiplefiles")'Image);
  Put_Line (Name_Case_Equivalence ("./singlefile")'Image);
  Put_Line (Name_Case_Equivalence ("./multiplefiles/test1.txt")'Image);
  Put_Line (Name_Case_Equivalence ("./singlefile/test1.txt")'Image);
  Put_Line (Name_Case_Equivalence ("./noncaseable/!")'Image);
end;

----------------------------
-- Compilation and Output --
----------------------------

& gnatmake -q main.adb
& main
CASE_SENSITIVE
CASE_SENSITIVE
CASE_SENSITIVE
CASE_SENSITIVE
CASE_SENSITIVE
CASE_SENSITIVE

2018-05-30  Justin Squirek  <squirek@adacore.com>

gcc/ada/

	* libgnat/a-direct.adb, libgnat/a-direct.ads (Name_Case_Equivalence):
	Add implementation.
	(Start_Search): Modify to use Start_Search_Internal
	(Start_Search_Internal): Add to break out an extra flag for searching
	case insensative due to the potential for directories within the same
	OS to allow different casing schemes.
	* sysdep.c (__gnat_name_case_equivalence): Add as a default fallback
	for when the more precise solution fails.

From-SVN: r260942

4 files changed, 176 insertions, 2 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d7d48ec..91a63bd 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,14 @@
+2018-05-30  Justin Squirek  <squirek@adacore.com>
+
+	* libgnat/a-direct.adb, libgnat/a-direct.ads (Name_Case_Equivalence):
+	Add implementation.
+	(Start_Search): Modify to use Start_Search_Internal
+	(Start_Search_Internal): Add to break out an extra flag for searching
+	case insensative due to the potential for directories within the same
+	OS to allow different casing schemes.
+	* sysdep.c (__gnat_name_case_equivalence): Add as a default fallback
+	for when the more precise solution fails.
+
 2018-05-30  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* checks.adb, exp_ch5.adb, exp_ch7.adb, exp_unst.adb, sem_eval.adb:
diff --git a/gcc/ada/libgnat/a-direct.adb b/gcc/ada/libgnat/a-direct.adb
index 952e96b..dd8b1ac 100644
--- a/gcc/ada/libgnat/a-direct.adb
+++ b/gcc/ada/libgnat/a-direct.adb
@@ -38,6 +38,8 @@ with Ada.Strings.Maps;           use Ada.Strings.Maps;
 with Ada.Strings.Unbounded;      use Ada.Strings.Unbounded;
 with Ada.Unchecked_Deallocation;
 
+with Interfaces.C;
+
 with System;                 use System;
 with System.CRTL;            use System.CRTL;
 with System.File_Attributes; use System.File_Attributes;
@@ -91,6 +93,16 @@ package body Ada.Directories is
    --  Get the next entry in a directory, setting Entry_Fetched if successful
    --  or resetting Is_Valid if not.
 
+   procedure Start_Search_Internal
+     (Search                 : in out Search_Type;
+      Directory              : String;
+      Pattern                : String;
+      Filter                 : Filter_Type := (others => True);
+      Force_Case_Insensitive : Boolean);
+   --  Similar to Start_Search except we can force a search to be
+   --  case-insensitive, which is important for detecting the name-case
+   --  equivalence for a given directory.
+
    ---------------
    -- Base_Name --
    ---------------
@@ -1057,6 +1069,103 @@ package body Ada.Directories is
       return Search.Value.Is_Valid;
    end More_Entries;
 
+   ---------------------------
+   -- Name_Case_Equivalence --
+   ---------------------------
+
+   function Name_Case_Equivalence (Name : String) return Name_Case_Kind is
+      Dir_Path  : Unbounded_String := To_Unbounded_String (Name);
+      S         : Search_Type;
+      Test_File : Directory_Entry_Type;
+
+      function GNAT_name_case_equivalence return Interfaces.C.int;
+      pragma Import
+        (C, GNAT_name_case_equivalence, "__gnat_name_case_equivalence");
+
+   begin
+      --  Check for the invalid case
+
+      if not Is_Valid_Path_Name (Name) then
+         raise Name_Error with "invalid path name """ & Name & '"';
+      end if;
+
+      --  We were passed a "full path" to a file and not a directory, so obtain
+      --  the containing directory.
+
+      if Is_Regular_File (Name) then
+         Dir_Path := To_Unbounded_String (Containing_Directory (Name));
+      end if;
+
+      --  Since we must obtain a file within the Name directory, let's grab the
+      --  first for our test. When the directory is empty, Get_Next_Entry will
+      --  fall through to a Status_Error where we then take the imprecise
+      --  default for the host OS.
+
+      Start_Search (Search    => S,
+                    Directory => To_String (Dir_Path),
+                    Pattern   => "",
+                    Filter    => (Directory => False, others => True));
+
+      loop
+         Get_Next_Entry (S, Test_File);
+
+         --  Check if we have found a "caseable" file
+
+         exit when To_Lower (Simple_Name (Test_File)) /=
+                     To_Upper (Simple_Name (Test_File));
+      end loop;
+
+      End_Search (S);
+
+      --  Search for files within the directory with the same name, but
+      --  differing cases.
+
+      Start_Search_Internal
+        (Search                 => S,
+         Directory              => To_String (Dir_Path),
+         Pattern                => Simple_Name (Test_File),
+         Filter                 => (Directory => False, others => True),
+         Force_Case_Insensitive => True);
+
+      --  We will find at least one match due to the search hitting our test
+      --  file.
+
+      Get_Next_Entry (S, Test_File);
+
+      begin
+         --  If we hit two then we know we have a case-sensitive directory
+
+         Get_Next_Entry (S, Test_File);
+         End_Search (S);
+
+         return Case_Sensitive;
+      exception
+         when Status_Error =>
+            null;
+      end;
+
+      --  Finally, we have a file in the directory whose name is unique and
+      --  "caseable". Let's test to see if the OS is able to identify the file
+      --  in multiple cases, which will give us our result without having to
+      --  resort to defaults.
+
+      if Exists (To_String (Dir_Path) & Directory_Separator
+                  & To_Lower (Simple_Name (Test_File)))
+        and then Exists (To_String (Dir_Path) & Directory_Separator
+                          & To_Upper (Simple_Name (Test_File)))
+      then
+         return Case_Preserving;
+      end if;
+
+      return Case_Sensitive;
+   exception
+      when Status_Error =>
+         --  There is no unobtrusive way to check for the directory's casing so
+         --  return the OS default.
+
+         return Name_Case_Kind'Val (Integer (GNAT_name_case_equivalence));
+   end Name_Case_Equivalence;
+
    ------------
    -- Rename --
    ------------
@@ -1289,6 +1398,21 @@ package body Ada.Directories is
       Pattern   : String;
       Filter    : Filter_Type := (others => True))
    is
+   begin
+      Start_Search_Internal (Search, Directory, Pattern, Filter, False);
+   end Start_Search;
+
+   ---------------------------
+   -- Start_Search_Internal --
+   ---------------------------
+
+   procedure Start_Search_Internal
+     (Search                 : in out Search_Type;
+      Directory              : String;
+      Pattern                : String;
+      Filter                 : Filter_Type := (others => True);
+      Force_Case_Insensitive : Boolean)
+   is
       function opendir (file_name : String) return DIRs;
       pragma Import (C, opendir, "__gnat_opendir");
 
@@ -1306,11 +1430,17 @@ package body Ada.Directories is
 
       --  Check the pattern
 
+      declare
+         Case_Sensitive : Boolean := Is_Path_Name_Case_Sensitive;
       begin
+         if Force_Case_Insensitive then
+            Case_Sensitive := False;
+         end if;
+
          Pat := Compile
            (Pattern,
             Glob           => True,
-            Case_Sensitive => Is_Path_Name_Case_Sensitive);
+            Case_Sensitive => Case_Sensitive);
       exception
          when Error_In_Regexp =>
             Free (Search.Value);
@@ -1339,6 +1469,6 @@ package body Ada.Directories is
       Search.Value.Pattern  := Pat;
       Search.Value.Dir      := Dir;
       Search.Value.Is_Valid := True;
-   end Start_Search;
+   end Start_Search_Internal;
 
 end Ada.Directories;
diff --git a/gcc/ada/libgnat/a-direct.ads b/gcc/ada/libgnat/a-direct.ads
index 074b92f..e879746 100644
--- a/gcc/ada/libgnat/a-direct.ads
+++ b/gcc/ada/libgnat/a-direct.ads
@@ -231,6 +231,11 @@ package Ada.Directories is
    -- File and directory name operations --
    ----------------------------------------
 
+   type Name_Case_Kind is
+      (Unknown, Case_Sensitive, Case_Insensitive, Case_Preserving);
+   --  The type Name_Case_Kind represents the kind of file-name equivalence
+   --  rule for directories.
+
    function Full_Name (Name : String) return String;
    --  Returns the full name corresponding to the file name specified by Name.
    --  The exception Name_Error is propagated if the string given as Name does
@@ -281,6 +286,16 @@ package Ada.Directories is
    --  Name is not a possible simple name (if Extension is null) or base name
    --  (if Extension is non-null).
 
+   function Name_Case_Equivalence (Name : String) return Name_Case_Kind;
+   --  Returns the file-name equivalence rule for the directory containing
+   --  Name. Raises Name_Error if Name is not a full name. Returns
+   --  Case_Sensitive if file names that differ only in the case of letters are
+   --  considered different names. If file names that differ only in the case
+   --  of letters are considered the same name, then Case_Preserving is
+   --  returned if names have the case of the file name used when a file is
+   --  created; and Case_Insensitive is returned otherwise. Returns Unknown if
+   --  the file-name equivalence is not known.
+
    --------------------------------
    -- File and directory queries --
    --------------------------------
diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c
index 98b3901..0b6a441 100644
--- a/gcc/ada/sysdep.c
+++ b/gcc/ada/sysdep.c
@@ -1049,3 +1049,21 @@ _getpagesize (void)
   return getpagesize ();
 }
 #endif
+
+int
+__gnat_name_case_equivalence ()
+{
+  /*  the values here must be synchronized with Ada.Directories.Name_Case_Kind:
+
+      Unknown          = 0
+      Case_Sensitive   = 1
+      Case_Insensitive = 2
+      Case_Preserving  = 3  */
+
+#if defined (__APPLE__) || defined (WIN32)
+  return 3;
+#else
+  return 1;
+#endif
+}
+