Skip to content

R
riscv-gcc-1
Commit d4881d36 by Vincent Celier Committed by Arnaud Charlet
Options

clean.adb (Clean_Project): Correctly delete executable specified as absolute path names. 

2005-06-14  Vincent Celier  <celier@adacore.com>

	* clean.adb (Clean_Project): Correctly delete executable specified as
	absolute path names.

	* make.adb (Gnatmake): Allow relative executable path names with
	directory information even when project files are used.
	(Change_To_Object_Directory): Fail gracefully when unable to change
	current working directory to object directory of a project.
	(Gnatmake): Remove exception handler that could no longer be exercized
	(Compile_Sources.Compile): Use deep copies of arguments, as some of them
	may be deallocated by Normalize_Arguments.
	(Collect_Arguments): Eliminate empty arguments

	* gnatcmd.adb (All_Projects): New Boolean flag, initialized to False,
	and set to True when -U is used for GNAT PRETTY or GNAT METRIC.
	(Check_Project): Return False when Project is No_Project. Return True
	when All_Projects is True.
	(GNATCmd): Recognize switch -U for GNAT PRETTY and GNAT METRIC and set
	All_Projects to True.
	Minor reformatting

From-SVN: r101028
parent d8b9660d
Showing with 98 additions and 106 deletions
gcc/ada/clean.adb
......@@ -884,7 +884,8 @@ package body Clean is
if Project = Main_Project and then Data.Exec_Directory /= No_Name then
declare
Exec_Dir : constant String :=
Get_Name_String (Data.Exec_Directory);
Get_Name_String (Data.Exec_Directory);
begin
Change_Dir (Exec_Dir);
......@@ -899,9 +900,22 @@ package body Clean is
Main_Source_File,
Current_File_Index);
if Is_Regular_File (Get_Name_String (Executable)) then
Delete (Exec_Dir, Get_Name_String (Executable));
end if;
declare
Exec_File_Name : constant String :=
Get_Name_String (Executable);
begin
if Is_Absolute_Path (Name => Exec_File_Name) then
if Is_Regular_File (Exec_File_Name) then
Delete ("", Exec_File_Name);
end if;
else
if Is_Regular_File (Exec_File_Name) then
Delete (Exec_Dir, Exec_File_Name);
end if;
end if;
end;
end if;
if Data.Object_Directory /= No_Name then
......
gcc/ada/gnatcmd.adb
......@@ -149,12 +149,22 @@ procedure GNATCmd is
----------------------------------
The_Command : Command_Type;
-- The command specified in the invocation of the GNAT driver
Command_Arg : Positive := 1;
-- The index of the command in the arguments of the GNAT driver
My_Exit_Status : Exit_Status := Success;
-- The exit status of the spawned tool. Used to set the correct VMS
-- exit status.
Current_Work_Dir : constant String := Get_Current_Dir;
-- The path of the working directory
All_Projects : Boolean := False;
-- Flag used for GNAT PRETTY and GNAT METRIC to indicate that
-- the underlying tool (gnatpp or gnatmetric) should be invoked for all
-- sources of all projects.
-----------------------
-- Local Subprograms --
......@@ -336,7 +346,7 @@ procedure GNATCmd is
else
-- For gnatpp and gnatmetric, put all sources
-- of the project.
-- of the project, or of all projects if -U was specified.
for Kind in Spec_Or_Body loop
......@@ -425,7 +435,10 @@ procedure GNATCmd is
Root_Project : Project_Id) return Boolean
is
begin
if Project = Root_Project then
if Project = No_Project then
return False;
elsif All_Projects or Project = Root_Project then
return True;
elsif The_Command = Metric then
......@@ -1526,6 +1539,13 @@ begin
Remove_Switch (Arg_Num);
elsif (The_Command = Pretty or else The_Command = Metric)
and then Argv'Length = 2
and then Argv (2) = 'U'
then
All_Projects := True;
Remove_Switch (Arg_Num);
else
Arg_Num := Arg_Num + 1;
end if;
......@@ -1710,6 +1730,7 @@ begin
First_Switches.Increment_Last;
First_Switches.Table (First_Switches.Last) :=
new String'("-C" & Get_Name_String (CP_File));
else
Add_To_Carg_Switches
(new String'("-gnatec=" & Get_Name_String (CP_File)));
......
gcc/ada/make.adb
......@@ -1065,32 +1065,41 @@ package body Make is
--------------------------------
procedure Change_To_Object_Directory (Project : Project_Id) is
Actual_Project : Project_Id;
begin
-- Nothing to do if the current working directory is alresdy the one
-- we want.
-- For sources outside of any project, compilation occurs in the object
-- directory of the main project, otherwise we use the project given.
if Project = No_Project then
Actual_Project := Main_Project;
else
Actual_Project := Project;
end if;
if Project_Object_Directory /= Project then
Project_Object_Directory := Project;
-- Nothing to do if the current working directory is already the correct
-- object directory.
-- If in a real project, set the working directory to the object
-- directory of the project.
if Project_Object_Directory /= Actual_Project then
Project_Object_Directory := Actual_Project;
if Project /= No_Project then
Change_Dir
(Get_Name_String
(Project_Tree.Projects.Table
(Project).Object_Directory));
-- Set the working directory to the object directory of the actual
-- project.
-- Otherwise, for sources outside of any project, set the working
-- directory to the object directory of the main project.
Change_Dir
(Get_Name_String
(Project_Tree.Projects.Table
(Actual_Project).Object_Directory));
elsif Main_Project /= No_Project then
Change_Dir
(Get_Name_String
(Project_Tree.Projects.Table
(Main_Project).Object_Directory));
end if;
end if;
exception
-- Fail if unable to change to the object directory
when Directory_Error =>
Make_Failed ("unable to change to object directory of project " &
Get_Name_String (Project_Tree.Projects.Table
(Actual_Project).Display_Name));
end Change_To_Object_Directory;
-----------
......@@ -1823,6 +1832,7 @@ package body Make is
declare
New_Args : Argument_List (1 .. Number);
Last_New : Natural := 0;
begin
Current := Switches.Values;
......@@ -1831,17 +1841,24 @@ package body Make is
Element := Project_Tree.String_Elements.
Table (Current);
Get_Name_String (Element.Value);
New_Args (Index) :=
new String'(Name_Buffer (1 .. Name_Len));
Test_If_Relative_Path
(New_Args (Index), Parent => Data.Dir_Path);
if Name_Len > 0 then
Last_New := Last_New + 1;
New_Args (Last_New) :=
new String'(Name_Buffer (1 .. Name_Len));
Test_If_Relative_Path
(New_Args (Last_New),
Parent => Data.Dir_Path);
end if;
Current := Element.Next;
end loop;
Add_Arguments
(Configuration_Pragmas_Switch
(Arguments_Project) &
New_Args & The_Saved_Gcc_Switches.all);
New_Args (1 .. Last_New) &
The_Saved_Gcc_Switches.all);
end;
end;
......@@ -2312,6 +2329,7 @@ package body Make is
Comp_Args : Argument_List (Args'First .. Args'Last + 9);
Comp_Next : Integer := Args'First;
Comp_Last : Integer;
Arg_Index : Integer;
function Ada_File_Name (Name : Name_Id) return Boolean;
-- Returns True if Name is the name of an ada source file
......@@ -2376,14 +2394,21 @@ package body Make is
and then S = Strip_Directory (S)
then
Comp_Last := Comp_Next + Args'Length - 3;
Comp_Args (Comp_Next .. Comp_Last) :=
Args (Args'First + 1 .. Args'Last - 1);
Arg_Index := Args'First + 1;
else
Comp_Last := Comp_Next + Args'Length - 1;
Comp_Args (Comp_Next .. Comp_Last) := Args;
Arg_Index := Args'First;
end if;
-- Make a deep copy of the arguments, because Normalize_Arguments
-- may deallocate some arguments.
for J in Comp_Next .. Comp_Last loop
Comp_Args (J) := new String'(Args (Arg_Index).all);
Arg_Index := Arg_Index + 1;
end loop;
-- Set -gnatpg for predefined files (for this purpose the renamings
-- such as Text_IO do not count as predefined). Note that we strip
-- the directory name from the source file name becase the call to
......@@ -4156,60 +4181,8 @@ package body Make is
then
-- Change current directory to object directory of main project
begin
Project_Object_Directory := No_Project;
Change_To_Object_Directory (Main_Project);
exception
when Directory_Error =>
-- This should never happen. But, if it does, display the
-- content of the parent directory of the obj dir.
declare
Parent : constant Dir_Name_Str :=
Dir_Name
(Get_Name_String
(Project_Tree.Projects.Table
(Main_Project).Object_Directory));
Dir : Dir_Type;
Str : String (1 .. 200);
Last : Natural;
begin
Write_Str ("Contents of directory """);
Write_Str (Parent);
Write_Line (""":");
Open (Dir, Parent);
loop
Read (Dir, Str, Last);
exit when Last = 0;
Write_Str (" ");
Write_Line (Str (1 .. Last));
end loop;
Close (Dir);
exception
when X : others =>
Write_Line ("(unexpected exception)");
Write_Line (Exception_Information (X));
if Is_Open (Dir) then
Close (Dir);
end if;
end;
Make_Failed
("unable to change working directory to """,
Get_Name_String
(Project_Tree.Projects.Table
(Main_Project).Object_Directory),
"""");
end;
Project_Object_Directory := No_Project;
Change_To_Object_Directory (Main_Project);
end if;
-- Source file lookups should be cached for efficiency.
......@@ -4498,15 +4471,6 @@ package body Make is
begin
if not Is_Absolute_Path (Exec_File_Name) then
for Index in Exec_File_Name'Range loop
if Exec_File_Name (Index) = Directory_Separator then
Make_Failed ("relative executable (""",
Exec_File_Name,
""") with directory part not " &
"allowed when using project files");
end if;
end loop;
Get_Name_String
(Project_Tree.Projects.Table
(Main_Project).Exec_Directory);
......@@ -4743,17 +4707,9 @@ package body Make is
begin
if not Is_Absolute_Path (Exec_File_Name) then
for Index in Exec_File_Name'Range loop
if Exec_File_Name (Index) = Directory_Separator then
Make_Failed ("relative executable (""",
Exec_File_Name,
""") with directory part not " &
"allowed when using project files");
end if;
end loop;
Get_Name_String (Project_Tree.Projects.Table
(Main_Project).Exec_Directory);
(Main_Project).Exec_Directory);
if
Name_Buffer (Name_Len) /= Directory_Separator
......@@ -4768,8 +4724,9 @@ package body Make is
Name_Len := Name_Len + Exec_File_Name'Length;
Executable := Name_Find;
Non_Std_Executable := True;
end if;
Non_Std_Executable := True;
end;
end if;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment