PR ada/52494

[pf3gnuchains/gcc-fork.git] / gcc / ada / gnatcmd.adb

diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb
index 1f0ce8b..8798399 100644 (file)
--- a/gcc/ada/gnatcmd.adb
+++ b/gcc/ada/gnatcmd.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1996-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1996-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -34,13 +34,14 @@ with MLib.Fil;
 with Namet;    use Namet;
 with Opt;      use Opt;
 with Osint;    use Osint;
-with Output;
+with Output;   use Output;
 with Prj;      use Prj;
 with Prj.Env;
 with Prj.Ext;  use Prj.Ext;
 with Prj.Pars;
 with Prj.Tree; use Prj.Tree;
 with Prj.Util; use Prj.Util;
+with Sdefault;
 with Sinput.P;
 with Snames;   use Snames;
 with Table;
@@ -67,6 +68,10 @@ procedure GNATCmd is
    B_Start : String_Ptr    := new String'("b~");
    --  Prefix of binder generated file, changed to b__ for VMS
 
+   Project_Tree : constant Project_Tree_Ref :=
+                    new Project_Tree_Data (Is_Root_Tree => True);
+   --  The project tree
+
    Old_Project_File_Used : Boolean := False;
    --  This flag indicates a switch -p (for gnatxref and gnatfind) for
    --  an old fashioned project file. -p cannot be used in conjunction
@@ -197,6 +202,9 @@ procedure GNATCmd is
    --  indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric)
    --  should be invoked for all sources of all projects.
 
+   Max_OpenVMS_Logical_Length : constant Integer := 255;
+   --  The maximum length of OpenVMS logicals
+
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -766,7 +774,7 @@ procedure GNATCmd is
          while Proj /= null loop
             if Proj.Project.Config_File_Temp then
                Delete_Temporary_File
-                 (Project_Tree, Proj.Project.Config_File_Name);
+                 (Project_Tree.Shared, Proj.Project.Config_File_Name);
             end if;
 
             Proj := Proj.Next;
@@ -777,7 +785,7 @@ procedure GNATCmd is
       --  has been created, delete this temporary file.
 
       if Temp_File_Name /= No_Path then
-         Delete_Temporary_File (Project_Tree, Temp_File_Name);
+         Delete_Temporary_File (Project_Tree.Shared, Temp_File_Name);
       end if;
    end Delete_Temp_Config_Files;
 
@@ -860,11 +868,20 @@ procedure GNATCmd is
       if Return_Code /= 0 then
          Get_Line (File, Line, Last);
 
-         if not Keep_Temporary_Files then
-            Delete (File);
-         else
-            Close (File);
-         end if;
+         begin
+            if not Keep_Temporary_Files then
+               Delete (File);
+            else
+               Close (File);
+            end if;
+
+         --  Don't crash if it is not possible to delete or close the file,
+         --  just ignore the situation.
+
+         exception
+            when others =>
+               null;
+         end;
 
          Put_Line (Standard_Error, Line (1 .. Last));
          Put_Line
@@ -913,11 +930,20 @@ procedure GNATCmd is
             end if;
          end loop;
 
-         if not Keep_Temporary_Files then
-            Delete (File);
-         else
-            Close (File);
-         end if;
+         begin
+            if not Keep_Temporary_Files then
+               Delete (File);
+            else
+               Close (File);
+            end if;
+
+         --  Don't crash if it is not possible to delete or close the file,
+         --  just ignore the situation.
+
+         exception
+            when others =>
+               null;
+         end;
       end if;
    end Get_Closure;
 
@@ -1286,7 +1312,10 @@ procedure GNATCmd is
    is
    begin
       Makeutl.Test_If_Relative_Path
-        (Switch, Parent, Including_Non_Switch => False, Including_RTS => True);
+        (Switch, Parent,
+         Do_Fail              => Osint.Fail'Access,
+         Including_Non_Switch => False,
+         Including_RTS        => True);
    end Test_If_Relative_Path;
 
    -------------------
@@ -1346,6 +1375,10 @@ procedure GNATCmd is
 --  Start of processing for GNATCmd
 
 begin
+   --  All output from GNATCmd is debugging or error output: send to stderr
+
+   Set_Standard_Error;
+
    --  Initializations
 
    Csets.Initialize;
@@ -1353,7 +1386,8 @@ begin
 
    Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
    Prj.Env.Initialize_Default_Project_Path
-     (Root_Environment.Project_Path, Target_Name => "");
+     (Root_Environment.Project_Path,
+      Target_Name => Sdefault.Target_Name.all);
 
    Project_Node_Tree := new Project_Node_Tree_Data;
    Prj.Tree.Initialize (Project_Node_Tree);
@@ -1393,6 +1427,15 @@ begin
       Add_Str_To_Name_Buffer (Argument (J));
    end loop;
 
+   --  On OpenVMS, setenv creates a logical whose length is limited to
+   --  255 bytes.
+
+   if OpenVMS and then Name_Len > Max_OpenVMS_Logical_Length then
+      Name_Buffer (Max_OpenVMS_Logical_Length - 2
+                     .. Max_OpenVMS_Logical_Length) := "...";
+      Name_Len := Max_OpenVMS_Logical_Length;
+   end if;
+
    Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
 
    --  Add the directory where the GNAT driver is invoked in front of the path,
@@ -1862,6 +1905,10 @@ begin
             Env               => Root_Environment,
             Packages_To_Check => Packages_To_Check);
 
+         --  Prj.Pars.Parse calls Set_Standard_Output, reset to stderr
+
+         Set_Standard_Error;
+
          if Project = Prj.No_Project then
             Fail ("""" & Project_File.all & """ processing failed");
          end if;
@@ -2044,7 +2091,7 @@ begin
             begin
                if Pkg /= No_Package then
 
-                  --  First, check if there is a single main specified.
+                  --  First, check if there is a single main specified
 
                   for J in 1  .. Last_Switches.Last loop
                      if Last_Switches.Table (J) (1) /= '-' then
@@ -2598,7 +2645,7 @@ begin
 exception
    when Error_Exit =>
       if not Keep_Temporary_Files then
-         Prj.Delete_All_Temp_Files (Project_Tree);
+         Prj.Delete_All_Temp_Files (Project_Tree.Shared);
          Delete_Temp_Config_Files;
       end if;
 
@@ -2606,7 +2653,7 @@ exception
 
    when Normal_Exit =>
       if not Keep_Temporary_Files then
-         Prj.Delete_All_Temp_Files (Project_Tree);
+         Prj.Delete_All_Temp_Files (Project_Tree.Shared);
          Delete_Temp_Config_Files;
       end if;