From d4881d364f4a56a41ec47624f6c1076424c00179 Mon Sep 17 00:00:00 2001 From: Vincent Celier Date: Thu, 16 Jun 2005 10:34:41 +0200 Subject: [PATCH] clean.adb (Clean_Project): Correctly delete executable specified as absolute path names. 2005-06-14 Vincent Celier * 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 --- gcc/ada/clean.adb | 22 +++++-- gcc/ada/gnatcmd.adb | 25 ++++++- gcc/ada/make.adb | 157 ++++++++++++++++---------------------------- 3 files changed, 98 insertions(+), 106 deletions(-) diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 6a53dbae671..4941f916449 100644 --- a/gcc/ada/clean.adb +++ b/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 diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 31646586e59..40919620e30 100644 --- a/gcc/ada/gnatcmd.adb +++ b/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))); diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 563b7725519..cc7860d4e88 100644 --- a/gcc/ada/make.adb +++ b/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; -- 2.30.2