From efa760f0ca2f45209525de0e9b6939351e1a0072 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Wed, 30 May 2018 08:58:12 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 11 +++ gcc/ada/libgnat/a-direct.adb | 134 ++++++++++++++++++++++++++++++++++- gcc/ada/libgnat/a-direct.ads | 15 ++++ gcc/ada/sysdep.c | 18 +++++ 4 files changed, 176 insertions(+), 2 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d7d48ecf495..91a63bdc76d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2018-05-30 Justin Squirek + + * 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 * 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 952e96b5f62..dd8b1acee42 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 -- ------------ @@ -1288,6 +1397,21 @@ package body Ada.Directories is Directory : String; 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 074b92f4ad8..e879746e590 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 98b3901cb16..0b6a441c660 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 +} + -- 2.30.2