+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
-- 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.
Last := Last + Extension'Length;
end if;
- To_Lower_If_Case_Insensitive (Result (1 .. Last));
return Result (1 .. Last);
end if;
end Compose;
return Containing_Directory (Current_Directory);
else
- To_Lower_If_Case_Insensitive (Result (1 .. Last));
return Result (1 .. Last);
end if;
end;
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
-- 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;
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);
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
return BN;
end if;
end Check_For_Standard_Dirs;
- end Simple_Name_CI;
+ end Simple_Name_Internal;
-- Start of processing for Simple_Name
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;
-- 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);
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;
-- 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
-- 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));
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
-------------
-- 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;
-- 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);
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.
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;
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;
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;
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;
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;
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;
-- 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 :=
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;
I : Interp_Index;
It : Interp;
Typ : Entity_Id := Empty;
- Seen : Boolean := False;
+ Seen : Boolean := False;
begin
Get_First_Interp (Nam, I, It);
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;
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;
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;
projects / thirdparty / gcc.git / commitdiff
