diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 23 | ||||
| -rw-r--r-- | gcc/ada/a-direct.adb | 81 | ||||
| -rw-r--r-- | gcc/ada/g-trasym.adb | 2 | ||||
| -rwxr-xr-x | gcc/ada/s-os_lib.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem.adb | 99 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 12 |
9 files changed, 121 insertions, 117 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cde186e..28c42da 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2009-04-20 Pascal Obry <obry@adacore.com> + + * a-direct.adb (To_Lower_If_Case_Insensitive): Removed. + Remove all calls to To_Lower_If_Case_Insensitive to preserve + the pathname original casing. + +2009-04-20 Robert Dewar <dewar@adacore.com> + + * g-trasym.adb: Minor reformatting + + * s-os_lib.adb: Minor reformatting + + * sem.adb: Minor reformatting + Minor code reorganization + + * sem_ch3.adb: Minor reformatting + + * sem_ch4.adb: Minor reformatting + + * sem_ch8.adb: Minor reformatting + + * sem_type.adb: Minor reformatting + 2009-04-20 Javier Miranda <miranda@adacore.com> * sem_disp.adb (Find_Dispatching_Type): For subprograms internally diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb index db40b8c..723833c 100644 --- a/gcc/ada/a-direct.adb +++ b/gcc/ada/a-direct.adb @@ -93,20 +93,15 @@ package body Ada.Directories is -- Get the next entry in a directory, setting Entry_Fetched if successful -- or resetting Is_Valid if not. - procedure To_Lower_If_Case_Insensitive (S : in out String); - -- Put S in lower case if file and path names are case-insensitive - --------------- -- Base_Name -- --------------- function Base_Name (Name : String) return String is - Simple : String := Simple_Name (Name); + Simple : constant String := Simple_Name (Name); -- Simple'First is guaranteed to be 1 begin - To_Lower_If_Case_Insensitive (Simple); - -- Look for the last dot in the file name and return the part of the -- file name preceding this last dot. If the first dot is the first -- character of the file name, the base name is the empty string. @@ -198,7 +193,6 @@ package body Ada.Directories is Last := Last + Extension'Length; end if; - To_Lower_If_Case_Insensitive (Result (1 .. Last)); return Result (1 .. Last); end if; end Compose; @@ -287,7 +281,6 @@ package body Ada.Directories is return Containing_Directory (Current_Directory); else - To_Lower_If_Case_Insensitive (Result (1 .. Last)); return Result (1 .. Last); end if; end; @@ -448,11 +441,9 @@ package body Ada.Directories is Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); declare - Cur : String := Normalize_Pathname (Buffer (1 .. Path_Len)); + Cur : constant String := Normalize_Pathname (Buffer (1 .. Path_Len)); begin - To_Lower_If_Case_Insensitive (Cur); - if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then return Cur (1 .. Cur'Last - 1); else @@ -790,10 +781,9 @@ package body Ada.Directories is -- Use System.OS_Lib.Normalize_Pathname declare - Value : String := Normalize_Pathname (Name); + Value : constant String := Normalize_Pathname (Name); subtype Result is String (1 .. Value'Length); begin - To_Lower_If_Case_Insensitive (Value); return Result (Value); end; end if; @@ -1061,18 +1051,14 @@ package body Ada.Directories is function Simple_Name (Name : String) return String is - function Simple_Name_CI (Path : String) return String; - -- This function does the job. The difference between Simple_Name_CI - -- and Simple_Name (the parent function) is that the former is case - -- sensitive, while the latter is not. Path and Suffix are adjusted - -- appropriately before calling Simple_Name_CI under platforms where - -- the file system is not case sensitive. + function Simple_Name_Internal (Path : String) return String; + -- This function does the job - -------------------- - -- Simple_Name_CI -- - -------------------- + -------------------------- + -- Simple_Name_Internal -- + -------------------------- - function Simple_Name_CI (Path : String) return String is + function Simple_Name_Internal (Path : String) return String is Cut_Start : Natural := Strings.Fixed.Index (Path, Dir_Seps, Going => Strings.Backward); @@ -1093,11 +1079,7 @@ package body Ada.Directories is Cut_End := Path'Last; Check_For_Standard_Dirs : declare - Offset : constant Integer := Path'First - Name'First; - BN : constant String := - Name (Cut_Start - Offset .. Cut_End - Offset); - -- Here we use Simple_Name.Name to keep the original casing - + BN : constant String := Path (Cut_Start .. Cut_End); Has_Drive_Letter : constant Boolean := System.OS_Lib.Path_Separator /= ':'; -- If Path separator is not ':' then we are on a DOS based OS @@ -1120,7 +1102,7 @@ package body Ada.Directories is return BN; end if; end Check_For_Standard_Dirs; - end Simple_Name_CI; + end Simple_Name_Internal; -- Start of processing for Simple_Name @@ -1133,23 +1115,12 @@ package body Ada.Directories is else -- Build the value to return with lower bound 1 - if Is_Path_Name_Case_Sensitive then - declare - Value : constant String := Simple_Name_CI (Name); - subtype Result is String (1 .. Value'Length); - begin - return Result (Value); - end; - - else - declare - Value : constant String := - Simple_Name_CI (Characters.Handling.To_Lower (Name)); - subtype Result is String (1 .. Value'Length); - begin - return Result (Value); - end; - end if; + declare + Value : constant String := Simple_Name_Internal (Name); + subtype Result is String (1 .. Value'Length); + begin + return Result (Value); + end; end if; end Simple_Name; @@ -1233,7 +1204,10 @@ package body Ada.Directories is -- Check the pattern begin - Pat := Compile (Pattern, Glob => True); + Pat := Compile + (Pattern, + Glob => True, + Case_Sensitive => Is_Path_Name_Case_Sensitive); exception when Error_In_Regexp => Free (Search.Value); @@ -1264,17 +1238,4 @@ package body Ada.Directories is Search.Value.Is_Valid := True; end Start_Search; - ---------------------------------- - -- To_Lower_If_Case_Insensitive -- - ---------------------------------- - - procedure To_Lower_If_Case_Insensitive (S : in out String) is - begin - if not Is_Path_Name_Case_Sensitive then - for J in S'Range loop - S (J) := To_Lower (S (J)); - end loop; - end if; - end To_Lower_If_Case_Insensitive; - end Ada.Directories; diff --git a/gcc/ada/g-trasym.adb b/gcc/ada/g-trasym.adb index 6b04800..a402d57 100644 --- a/gcc/ada/g-trasym.adb +++ b/gcc/ada/g-trasym.adb @@ -77,7 +77,7 @@ package body GNAT.Traceback.Symbolic is -- This is the procedure version of the Ada aware addr2line. It places -- in BUF a string representing the symbolic translation of the N_ADDRS -- raw addresses provided in ADDRS, looked up in debug information from - -- FILENAME. LEN points to an integer which contains the size of the + -- FILENAME. LEN points to an integer which contains the size of the -- BUF buffer at input and the result length at output. -- -- This procedure is provided by libaddr2line on targets that support diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 41d1077..e24a02e 100755 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -1833,7 +1833,8 @@ package body System.OS_Lib is -- By default, the drive letter on Windows is in upper case - if On_Windows and then Path_Len >= 2 + if On_Windows + and then Path_Len >= 2 and then Buffer (2) = ':' then System.Case_Util.To_Upper (Buffer (1 .. 1)); diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 478cb56..d1d3c91 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -83,8 +83,8 @@ package body Sem is procedure Write_Unit_Info (Unit_Num : Unit_Number_Type; - Item : Node_Id; - Prefix : String := ""); + Item : Node_Id; + Prefix : String := ""); -- Print out debugging information about the unit ------------- @@ -1359,10 +1359,15 @@ package body Sem is -- Start of processing for Semantics begin - if Debug_Unit_Walk and then Already_Analyzed then - Write_Str ("(done)"); - Write_Unit_Info (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit), - Prefix => "--> "); + if Debug_Unit_Walk then + if Already_Analyzed then + Write_Str ("(done)"); + end if; + + Write_Unit_Info + (Get_Cunit_Unit_Number (Comp_Unit), + Unit (Comp_Unit), + Prefix => "--> "); Indent; end if; @@ -1378,11 +1383,11 @@ package body Sem is -- Cleaner might be to do the kludge at the point of excluding the -- pragma (do not exclude for renamings ???) - GNAT_Mode := - GNAT_Mode - or else Is_Predefined_File_Name - (Unit_File_Name (Current_Sem_Unit), - Renamings_Included => False); + if Is_Predefined_File_Name + (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False) + then + GNAT_Mode := True; + end if; if Generic_Main then Expander_Mode_Save_And_Set (False); @@ -1416,8 +1421,8 @@ package body Sem is end if; -- Do analysis, and then append the compilation unit onto the - -- Comp_Unit_List, if appropriate. This is done after analysis, so if - -- this unit depends on some others, they have already been + -- Comp_Unit_List, if appropriate. This is done after analysis, so + -- if this unit depends on some others, they have already been -- appended. We ignore bodies, except for the main unit itself. We -- have also to guard against ill-formed subunits that have an -- improper context. @@ -1428,7 +1433,7 @@ package body Sem is null; elsif Present (Comp_Unit) - and then Nkind (Unit (Comp_Unit)) in N_Proper_Body + and then Nkind (Unit (Comp_Unit)) in N_Proper_Body and then not In_Extended_Main_Source_Unit (Comp_Unit) then null; @@ -1436,7 +1441,9 @@ package body Sem is else pragma Assert (not Ignore_Comp_Units); - if No (Comp_Unit_List) then -- Initialize if first time + -- Initialize if first time + + if No (Comp_Unit_List) then Comp_Unit_List := New_Elmt_List; end if; @@ -1474,11 +1481,17 @@ package body Sem is Restore_Opt_Config_Switches (Save_Config_Switches); Expander_Mode_Restore; - if Debug_Unit_Walk and then Already_Analyzed then + if Debug_Unit_Walk then Outdent; - Write_Str ("(done)"); - Write_Unit_Info (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit), - Prefix => "<-- "); + + if Already_Analyzed then + Write_Str ("(done)"); + end if; + + Write_Unit_Info + (Get_Cunit_Unit_Number (Comp_Unit), + Unit (Comp_Unit), + Prefix => "<-- "); end if; end Semantics; @@ -1545,11 +1558,15 @@ package body Sem is declare Unit_Num : constant Unit_Number_Type := - Get_Cunit_Unit_Number (CU); + Get_Cunit_Unit_Number (CU); begin - Write_Unit_Info (Unit_Num, Item); + if Debug_Unit_Walk then + Write_Unit_Info (Unit_Num, Item); + end if; + + -- ??? why is this commented out + -- ???pragma Assert (not Seen (Unit_Num)); - pragma Assert (not Seen (Unit_Num)); Seen (Unit_Num) := True; end; @@ -1649,11 +1666,13 @@ package body Sem is Write_Line ("Ignored units:"); Indent; + for Unit_Num in Seen'Range loop if not Seen (Unit_Num) then Write_Unit_Info (Unit_Num, Unit (Cunit (Unit_Num))); end if; end loop; + Outdent; end if; end if; @@ -1670,29 +1689,27 @@ package body Sem is procedure Write_Unit_Info (Unit_Num : Unit_Number_Type; - Item : Node_Id; - Prefix : String := "") + Item : Node_Id; + Prefix : String := "") is begin - if Debug_Unit_Walk then - Write_Str (Prefix); - Write_Unit_Name (Unit_Name (Unit_Num)); - Write_Str (", unit "); - Write_Int (Int (Unit_Num)); - Write_Str (", "); - Write_Int (Int (Item)); + Write_Str (Prefix); + Write_Unit_Name (Unit_Name (Unit_Num)); + Write_Str (", unit "); + Write_Int (Int (Unit_Num)); + Write_Str (", "); + Write_Int (Int (Item)); + Write_Str ("="); + Write_Str (Node_Kind'Image (Nkind (Item))); + + if Item /= Original_Node (Item) then + Write_Str (", orig = "); + Write_Int (Int (Original_Node (Item))); Write_Str ("="); - Write_Str (Node_Kind'Image (Nkind (Item))); - - if Item /= Original_Node (Item) then - Write_Str (", orig = "); - Write_Int (Int (Original_Node (Item))); - Write_Str ("="); - Write_Str (Node_Kind'Image (Nkind (Original_Node (Item)))); - end if; - - Write_Eol; + Write_Str (Node_Kind'Image (Nkind (Original_Node (Item)))); end if; + + Write_Eol; end Write_Unit_Info; end Sem; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index db0d12c..a7ffd89 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5922,9 +5922,9 @@ package body Sem_Ch3 is -- This is the unusual case where a type completed by a private -- derivation occurs within a package nested in a child unit, and -- the parent is declared in an ancestor. In this case, the full - -- view of the parent type will become visible in the body of the - -- enclosing child, and only then will the current type be - -- possibly non-private. We build a underlying full view that + -- view of the parent type will become visible in the body of + -- the enclosing child, and only then will the current type be + -- possibly non-private. We build a underlying full view that -- will be installed when the enclosing child body is compiled. Full_Der := diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d86cfd4..43c86e5 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -5874,7 +5874,6 @@ package body Sem_Ch4 is begin Actual := Next (First_Actual (Call)); Index := First_Index (Arr_Type); - while Present (Actual) and then Present (Index) loop if not Has_Compatible_Type (Actual, Etype (Index)) then Arr_Type := Empty; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 88eed1d..097da0c 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -788,7 +788,7 @@ package body Sem_Ch8 is I : Interp_Index; It : Interp; Typ : Entity_Id := Empty; - Seen : Boolean := False; + Seen : Boolean := False; begin Get_First_Interp (Nam, I, It); @@ -799,8 +799,9 @@ package body Sem_Ch8 is if Ekind (It.Typ) = Ekind (T) then if Ekind (T) = E_Anonymous_Access_Subprogram_Type - and then Type_Conformant - (Designated_Type (T), Designated_Type (It.Typ)) + and then + Type_Conformant + (Designated_Type (T), Designated_Type (It.Typ)) then if not Seen then Seen := True; @@ -810,8 +811,8 @@ package body Sem_Ch8 is end if; elsif Ekind (T) = E_Anonymous_Access_Type - and then Covers - (Designated_Type (T), Designated_Type (It.Typ)) + and then + Covers (Designated_Type (T), Designated_Type (It.Typ)) then if not Seen then Seen := True; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 6da8773..f9a4f1c 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -1688,26 +1688,28 @@ package body Sem_Type is and then Present (Access_Definition (Parent (N))) then if Ekind (It1.Typ) = E_Anonymous_Access_Type - or else Ekind (It1.Typ) = E_Anonymous_Access_Subprogram_Type + or else + Ekind (It1.Typ) = E_Anonymous_Access_Subprogram_Type then if Ekind (It2.Typ) = Ekind (It1.Typ) then -- True ambiguity return No_Interp; + else return It1; end if; elsif Ekind (It2.Typ) = E_Anonymous_Access_Type - or else Ekind (It2.Typ) = E_Anonymous_Access_Subprogram_Type + or else + Ekind (It2.Typ) = E_Anonymous_Access_Subprogram_Type then return It2; - else - - -- No legal interpretation. + -- No legal interpretation + else return No_Interp; end if; |