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

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;