mlib.ads, mlib.adb (Build_Library): Do not use hard-coded directory separator...

2007-04-20  Vincent Celier  <celier@adacore.com>

	* mlib.ads, mlib.adb (Build_Library): Do not use hard-coded directory
	separator, use instead the proper host directory separator.
	(Copy_ALI_Files): Make sure that an already existing ALI file in the
	ALI copy dir is writable, before doing the copy.

	* mlib-utl.ads, mlib-utl.adb: 
	(Gcc): If length of command line is too long, put the list of object
	files in a response file, if this is supported by the platform.
	(Ar): If invocation of the archive builder is allowed to be done in
	chunks and building it in one shot would go above an OS dependent
	limit on the number of characters on the command line, build the archive
	in chunks.

From-SVN: r125435

gcc/ada/mlib-utl.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                     Copyright (C) 2002-2006, AdaCore                     --
+--                     Copyright (C) 2002-2007, AdaCore                     --
 --                                                                          --
 -- 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- --
@@ -26,26 +26,51 @@
 
 with MLib.Fil; use MLib.Fil;
 with MLib.Tgt; use MLib.Tgt;
-
-with Namet;    use Namet;
 with Opt;
 with Osint;
 with Output;   use Output;
 
-with GNAT;     use GNAT;
+with Interfaces.C.Strings; use Interfaces.C.Strings;
+
+with System;
 
 package body MLib.Utl is
 
    Gcc_Name : constant String := Osint.Program_Name ("gcc").all;
-   Gcc_Exec : OS_Lib.String_Access;
+   --  Default value of the "gcc" executable used in procedure Gcc
+
+   Gcc_Exec : String_Access;
+   --  The full path name of the "gcc" executable
+
+   Ar_Name : String_Access;
+   --  The name of the archive builder for the platform, set when procedure Ar
+   --  is called for the first time.
+
+   Ar_Exec : String_Access;
+   --  The full path name of the archive builder
+
+   Ar_Options : String_List_Access;
+   --  The minimum options used when invoking the archive builder
+
+   Ar_Append_Options : String_List_Access;
+   --  The options to be used when invoking the archive builder to add chunks
+   --  of object files, when building the archive in chunks.
 
-   Ar_Name    : OS_Lib.String_Access;
-   Ar_Exec    : OS_Lib.String_Access;
-   Ar_Options : OS_Lib.String_List_Access;
+   Opt_Length : Natural := 0;
+   --  The max number of options for the Archive_Builder
 
-   Ranlib_Name    : OS_Lib.String_Access;
-   Ranlib_Exec    : OS_Lib.String_Access := null;
-   Ranlib_Options : OS_Lib.String_List_Access := null;
+   Initial_Size : Natural := 0;
+   --  The minimum number of bytes for the invocation of the Archive Builder
+   --  (without name of the archive or object files).
+
+   Ranlib_Name : String_Access;
+   --  The name of the archive indexer for the platform, if there is one
+
+   Ranlib_Exec : String_Access := null;
+   --  The full path name of the archive indexer
+
+   Ranlib_Options : String_List_Access := null;
+   --  The options to be used when invoking the archive indexer, if any
 
    --------
    -- Ar --
@@ -55,19 +80,70 @@ package body MLib.Utl is
       Full_Output_File : constant String :=
                              Ext_To (Output_File, Archive_Ext);
 
-      Arguments   : OS_Lib.Argument_List_Access;
+      Arguments   : Argument_List_Access;
+      Last_Arg    : Natural := 0;
       Success     : Boolean;
       Line_Length : Natural := 0;
 
+      Maximum_Size : Integer;
+      pragma Import (C, Maximum_Size, "__gnat_link_max");
+      --  Maximum number of bytes to put in an invocation of the
+      --  Archive_Builder.
+
+      Size : Integer;
+      --  The number of bytes for the invocation of the archive builder
+
+      Current_Object : Natural;
+
+      procedure Display;
+      --  Display an invocation of the Archive Builder
+
+      -------------
+      -- Display --
+      -------------
+
+      procedure Display is
+      begin
+         if not Opt.Quiet_Output then
+            Write_Str (Ar_Name.all);
+            Line_Length := Ar_Name'Length;
+
+            for J in 1 .. Last_Arg loop
+
+               --  Make sure the Output buffer does not overflow
+
+               if Line_Length + 1 + Arguments (J)'Length > Buffer_Max then
+                  Write_Eol;
+                  Line_Length := 0;
+               end if;
+
+               Write_Char (' ');
+
+               --  Only output the first object files when not in verbose mode
+
+               if (not Opt.Verbose_Mode) and then J = Opt_Length + 3 then
+                  Write_Str ("...");
+                  exit;
+               end if;
+
+               Write_Str (Arguments (J).all);
+               Line_Length := Line_Length + 1 + Arguments (J)'Length;
+            end loop;
+
+            Write_Eol;
+         end if;
+
+      end Display;
+
    begin
       if Ar_Exec = null then
          Ar_Name := Osint.Program_Name (Archive_Builder);
-         Ar_Exec := OS_Lib.Locate_Exec_On_Path (Ar_Name.all);
+         Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
 
          if Ar_Exec = null then
             Free (Ar_Name);
             Ar_Name := new String'(Archive_Builder);
-            Ar_Exec := OS_Lib.Locate_Exec_On_Path (Ar_Name.all);
+            Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
          end if;
 
          if Ar_Exec = null then
@@ -80,17 +156,37 @@ package body MLib.Utl is
 
          Ar_Options := Archive_Builder_Options;
 
+         Initial_Size := 0;
+         for J in Ar_Options'Range loop
+            Initial_Size := Initial_Size + Ar_Options (J)'Length + 1;
+         end loop;
+
+         Ar_Append_Options := Archive_Builder_Append_Options;
+
+         Opt_Length := Ar_Options'Length;
+
+         if Ar_Append_Options /= null then
+            Opt_Length := Natural'Max (Ar_Append_Options'Length, Opt_Length);
+
+            Size := 0;
+            for J in Ar_Append_Options'Range loop
+               Size := Size + Ar_Append_Options (J)'Length + 1;
+            end loop;
+
+            Initial_Size := Integer'Max (Initial_Size, Size);
+         end if;
+
          --  ranlib
 
          Ranlib_Name := Osint.Program_Name (Archive_Indexer);
 
          if Ranlib_Name'Length > 0 then
-            Ranlib_Exec := OS_Lib.Locate_Exec_On_Path (Ranlib_Name.all);
+            Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
 
             if Ranlib_Exec = null then
                Free (Ranlib_Name);
                Ranlib_Name := new String'(Archive_Indexer);
-               Ranlib_Exec := OS_Lib.Locate_Exec_On_Path (Ranlib_Name.all);
+               Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
             end if;
 
             if Ranlib_Exec /= null and then Opt.Verbose_Mode then
@@ -103,43 +199,77 @@ package body MLib.Utl is
       end if;
 
       Arguments :=
-        new String_List (1 .. 1 + Ar_Options'Length + Objects'Length);
+        new String_List (1 .. 1 + Opt_Length + Objects'Length);
       Arguments (1 .. Ar_Options'Length) := Ar_Options.all; --  "ar cr ..."
       Arguments (Ar_Options'Length + 1) := new String'(Full_Output_File);
-      Arguments (Ar_Options'Length + 2 .. Arguments'Last) := Objects;
 
       Delete_File (Full_Output_File);
 
-      if not Opt.Quiet_Output then
-         Write_Str (Ar_Name.all);
-         Line_Length := Ar_Name'Length;
+      Size := Initial_Size + Full_Output_File'Length + 1;
 
-         for J in Arguments'Range loop
+      --  Check the full size of a call of the archive builder with all the
+      --  object files.
 
-            --  Make sure the Output buffer does not overflow
+      for J in Objects'Range loop
+         Size := Size + Objects (J)'Length + 1;
+      end loop;
 
-            if Line_Length + 1 + Arguments (J)'Length > Buffer_Max then
-               Write_Eol;
-               Line_Length := 0;
-            end if;
+      --  If the size is not too large or if it is not possible to build the
+      --  archive in chunks, build the archive in a single invocation.
 
-            Write_Char (' ');
+      if Size <= Maximum_Size or else Ar_Append_Options = null then
+         Last_Arg := Ar_Options'Length + 1 + Objects'Length;
+         Arguments (Ar_Options'Length + 2 .. Last_Arg) := Objects;
 
-            --  Only output the first object files when not in verbose mode
+         Display;
 
-            if (not Opt.Verbose_Mode) and then J = Ar_Options'Length + 3 then
-               Write_Str ("...");
-               exit;
-            end if;
+         Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
 
-            Write_Str  (Arguments (J).all);
-            Line_Length := Line_Length + 1 + Arguments (J)'Length;
+      else
+         --  Build the archive in several invocation, making sure to not
+         --  go over the maximum size for each invocation.
+
+         Last_Arg := Ar_Options'Length + 1;
+         Current_Object := Objects'First;
+         Size := Initial_Size + Full_Output_File'Length + 1;
+
+         --  First invocation
+
+         while Current_Object <= Objects'Last loop
+            Size := Size + Objects (Current_Object)'Length + 1;
+            exit when Size > Maximum_Size;
+            Last_Arg := Last_Arg + 1;
+            Arguments (Last_Arg) := Objects (Current_Object);
+            Current_Object := Current_Object + 1;
          end loop;
 
-         Write_Eol;
-      end if;
+         Display;
+
+         Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
+
+         Arguments (1 .. Ar_Append_Options'Length) := Ar_Append_Options.all;
+         Arguments
+           (Ar_Append_Options'Length + 1) := new String'(Full_Output_File);
 
-      OS_Lib.Spawn (Ar_Exec.all, Arguments.all, Success);
+         --  Appending invocation(s)
+
+         Big_Loop : while Success and then Current_Object <= Objects'Last loop
+            Last_Arg := Ar_Append_Options'Length + 1;
+            Size := Initial_Size + Full_Output_File'Length + 1;
+
+            Inner_Loop : while Current_Object <= Objects'Last loop
+               Size := Size + Objects (Current_Object)'Length + 1;
+               exit Inner_Loop when Size > Maximum_Size;
+               Last_Arg := Last_Arg + 1;
+               Arguments (Last_Arg) := Objects (Current_Object);
+               Current_Object := Current_Object + 1;
+            end loop Inner_Loop;
+
+            Display;
+
+            Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
+         end loop Big_Loop;
+      end if;
 
       if not Success then
          Fail (Ar_Name.all, " execution error.");
@@ -154,7 +284,7 @@ package body MLib.Utl is
             Write_Line (Arguments (Ar_Options'Length + 1).all);
          end if;
 
-         OS_Lib.Spawn
+         Spawn
            (Ranlib_Exec.all,
             Ranlib_Options.all & (Arguments (Ar_Options'Length + 1)),
             Success);
@@ -174,7 +304,7 @@ package body MLib.Utl is
       Success : Boolean;
 
    begin
-      OS_Lib.Delete_File (File'Address, Success);
+      Delete_File (File'Address, Success);
 
       if Opt.Verbose_Mode then
          if Success then
@@ -199,32 +329,86 @@ package body MLib.Utl is
       Options_2   : Argument_List;
       Driver_Name : Name_Id := No_Name)
    is
+      Link_Bytes : Integer := 0;
+      --  Projected number of bytes for the linker command line
+
+      Link_Max : Integer;
+      pragma Import (C, Link_Max, "__gnat_link_max");
+      --  Maximum number of bytes on the command line supported by the OS
+      --  linker. Passed this limit the response file mechanism must be used
+      --  if supported.
+
+      Object_List_File_Supported : Boolean;
+      for Object_List_File_Supported'Size use Character'Size;
+      pragma Import
+        (C, Object_List_File_Supported, "__gnat_objlist_file_supported");
+      --  Predicate indicating whether the linker has an option whereby the
+      --  names of object files can be passed to the linker in a file.
+
+      Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr;
+      pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option");
+      --  Pointer to a string representing the linker option which specifies
+      --  the response file.
+
+      Using_GNU_Linker : Boolean;
+      for Using_GNU_Linker'Size use Character'Size;
+      pragma Import (C, Using_GNU_Linker, "__gnat_using_gnu_linker");
+      --  Predicate indicating whether this target uses the GNU linker. In
+      --  this case we must output a GNU linker compatible response file.
+
+      Opening : aliased constant String := """";
+      Closing : aliased constant String := '"' & ASCII.LF;
+      --  Needed to quote object paths in object list files when GNU linker
+      --  is used.
+
+      Tname    : String_Access;
+      Tname_FD : File_Descriptor := Invalid_FD;
+      --  Temporary file used by linker to pass list of object files on
+      --  certain systems with limitations on size of arguments.
+
+      Closing_Status : Boolean;
+      --  For call to Close
+
       Arguments :
-        OS_Lib.Argument_List
+        Argument_List
           (1 .. 7 + Objects'Length + Options'Length + Options_2'Length);
 
       A       : Natural := 0;
       Success : Boolean;
 
-      Out_Opt : constant OS_Lib.String_Access :=
-                  new String'("-o");
-      Out_V   : constant OS_Lib.String_Access :=
-                  new String'(Output_File);
-      Lib_Dir : constant OS_Lib.String_Access :=
-                  new String'("-L" & Lib_Directory);
-      Lib_Opt : constant OS_Lib.String_Access :=
-                  new String'(Dynamic_Option);
+      Out_Opt : constant String_Access := new String'("-o");
+      Out_V   : constant String_Access := new String'(Output_File);
+      Lib_Dir : constant String_Access := new String'("-L" & Lib_Directory);
+      Lib_Opt : constant String_Access := new String'(Dynamic_Option);
 
-      Driver    : String_Access;
+      Driver : String_Access;
 
       type Object_Position is (First, Second, Last);
 
       Position : Object_Position;
 
+      procedure Write_RF (A : System.Address; N : Integer);
+      --  Write a string to the response file and check if it was successful.
+      --  Fail the program if it was not successful (disk full).
+
+      --------------
+      -- Write_RF --
+      --------------
+
+      procedure Write_RF (A : System.Address; N : Integer) is
+         Status : Integer;
+      begin
+         Status := Write (Tname_FD, A, N);
+
+         if Status /= N then
+            Fail ("cannot generate response file to link library: disk full");
+         end if;
+      end Write_RF;
+
    begin
       if Driver_Name = No_Name then
          if Gcc_Exec = null then
-            Gcc_Exec := OS_Lib.Locate_Exec_On_Path (Gcc_Name);
+            Gcc_Exec := Locate_Exec_On_Path (Gcc_Name);
 
             if Gcc_Exec = null then
                Fail (Gcc_Name, " not found in path");
@@ -234,30 +418,40 @@ package body MLib.Utl is
          Driver := Gcc_Exec;
 
       else
-         Driver := OS_Lib.Locate_Exec_On_Path (Get_Name_String (Driver_Name));
+         Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name));
 
          if Driver = null then
             Fail (Get_Name_String (Driver_Name), " not found in path");
          end if;
       end if;
 
+      Link_Bytes := 0;
+
       if Lib_Opt'Length /= 0 then
          A := A + 1;
          Arguments (A) := Lib_Opt;
+         Link_Bytes := Link_Bytes + Lib_Opt'Length + 1;
       end if;
 
       A := A + 1;
       Arguments (A) := Out_Opt;
+      Link_Bytes := Link_Bytes + Out_Opt'Length + 1;
 
       A := A + 1;
       Arguments (A) := Out_V;
+      Link_Bytes := Link_Bytes + Out_V'Length + 1;
 
       A := A + 1;
       Arguments (A) := Lib_Dir;
+      Link_Bytes := Link_Bytes + Lib_Dir'Length + 1;
 
       A := A + Options'Length;
       Arguments (A - Options'Length + 1 .. A) := Options;
 
+      for J in Options'Range loop
+         Link_Bytes := Link_Bytes + Options (J)'Length + 1;
+      end loop;
+
       if not Opt.Quiet_Output then
          Write_Str (Driver.all);
 
@@ -290,18 +484,102 @@ package body MLib.Utl is
          Write_Eol;
       end if;
 
-      A := A + Objects'Length;
-      Arguments (A - Objects'Length + 1 .. A) := Objects;
+      for J in Objects'Range loop
+         Link_Bytes := Link_Bytes + Objects (J)'Length + 1;
+      end loop;
+
+      for J in Options_2'Range loop
+         Link_Bytes := Link_Bytes + Options_2 (J)'Length + 1;
+      end loop;
+
+      if Object_List_File_Supported and then Link_Bytes > Link_Max then
+         --  Create a temporary file containing the object files, one object
+         --  file per line for maximal compatibility with linkers supporting
+         --  this option.
+
+         Create_Temp_File (Tname_FD, Tname);
+
+         --  If target is using the GNU linker we must add a special header
+         --  and footer in the response file.
+
+         --  The syntax is : INPUT (object1.o object2.o ... )
+
+         --  Because the GNU linker does not like name with characters such
+         --  as '!', we must put the object paths between double quotes.
+
+         if Using_GNU_Linker then
+            declare
+               GNU_Header : aliased constant String := "INPUT (";
+
+            begin
+               Write_RF (GNU_Header'Address, GNU_Header'Length);
+            end;
+         end if;
+
+         for J in Objects'Range loop
+            --  Opening quote for GNU linker
+
+            if Using_GNU_Linker then
+               Write_RF (Opening'Address, 1);
+            end if;
+
+            Write_RF
+                (Objects (J).all'Address, Objects (J).all'Length);
+
+            --  Closing quote for GNU linker
+
+            if Using_GNU_Linker then
+               Write_RF (Closing'Address, 2);
+
+            else
+               Write_RF (ASCII.LF'Address, 1);
+            end if;
+         end loop;
+
+         --  Handle GNU linker response file footer
+
+         if Using_GNU_Linker then
+            declare
+               GNU_Footer : aliased constant String := ")";
+
+            begin
+               Write_RF (GNU_Footer'Address, GNU_Footer'Length);
+            end;
+         end if;
+
+         Close (Tname_FD, Closing_Status);
+
+         if not Closing_Status then
+            Fail ("cannot generate response file to link library: disk full");
+         end if;
+
+         A := A + 1;
+         Arguments (A) :=
+           new String'(Value (Object_File_Option_Ptr) & Tname.all);
+
+      else
+         A := A + Objects'Length;
+         Arguments (A - Objects'Length + 1 .. A) := Objects;
+      end if;
 
       A := A + Options_2'Length;
       Arguments (A - Options_2'Length + 1 .. A) := Options_2;
 
-      OS_Lib.Spawn (Driver.all, Arguments (1 .. A), Success);
+      Spawn (Driver.all, Arguments (1 .. A), Success);
+
+      if Tname /= null then
+         Delete_File (Tname.all, Closing_Status);
+
+         if not Closing_Status then
+            Write_Str ("warning: could not delete response file """);
+            Write_Str (Tname.all);
+            Write_Line (""" to link library");
+         end if;
+      end if;
 
       if not Success then
          if Driver_Name = No_Name then
             Fail (Gcc_Name, " execution error");
-
          else
             Fail (Get_Name_String (Driver_Name), " execution error");
          end if;

gcc/ada/mlib-utl.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                     Copyright (C) 2001-2006, AdaCore                     --
+--                     Copyright (C) 2001-2007, AdaCore                     --
 --                                                                          --
 -- 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- --
@@ -30,8 +30,8 @@
 package MLib.Utl is
 
    procedure Delete_File (Filename : String);
-   --  Delete the file Filename
-   --  Why is this different from the standard OS_Lib routine???
+   --  Delete the file Filename and output the name of the deleted file in
+   --  verbose mode.
 
    procedure Gcc
      (Output_File : String;

gcc/ada/mlib.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                     Copyright (C) 1999-2006, AdaCore                     --
+--                     Copyright (C) 1999-2007, AdaCore                     --
 --                                                                          --
 -- 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- --
@@ -30,7 +30,6 @@ with Interfaces.C.Strings;
 with Hostparm;
 with Opt;
 with Output; use Output;
-with Namet;  use Namet;
 
 with MLib.Utl; use MLib.Utl;
 
@@ -59,7 +58,8 @@ package body MLib is
          Write_Line (Output_File);
       end if;
 
-      Ar (Output_Dir & "/lib" & Output_File & ".a", Objects => Ofiles);
+      Ar (Output_Dir & Directory_Separator &
+          "lib" & Output_File & ".a", Objects => Ofiles);
    end Build_Library;
 
    ------------------------
@@ -97,7 +97,7 @@ package body MLib is
 
    procedure Copy_ALI_Files
      (Files      : Argument_List;
-      To         : Name_Id;
+      To         : Path_Name_Type;
       Interfaces : String_List)
    is
       Success      : Boolean := False;
@@ -130,6 +130,10 @@ package body MLib is
 
          for Index in Files'Range loop
             Verbose_Copy (Index);
+            Set_Writable
+              (To_Dir &
+               Directory_Separator &
+               Base_Name (Files (Index).all));
             Copy_File
               (Files (Index).all,
                To_Dir,
@@ -169,15 +173,19 @@ package body MLib is
                if Is_Interface then
                   Success := False;
                   Verbose_Copy (Index);
+                  Set_Writable
+                    (To_Dir &
+                     Directory_Separator &
+                     Base_Name (Files (Index).all));
 
                   declare
-                     FD         : File_Descriptor;
-                     Len        : Integer;
-                     Actual_Len : Integer;
-                     S          : String_Access;
-                     Curr       : Natural;
+                     FD           : File_Descriptor;
+                     Len          : Integer;
+                     Actual_Len   : Integer;
+                     S            : String_Access;
+                     Curr         : Natural;
                      P_Line_Found : Boolean;
-                     Status     : Boolean;
+                     Status       : Boolean;
 
                   begin
                      --  Open the file

gcc/ada/mlib.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                     Copyright (C) 1999-2005, AdaCore                     --
+--                     Copyright (C) 1999-2007, AdaCore                     --
 --                                                                          --
 -- 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- --
@@ -27,9 +27,10 @@
 --  This package provides the core high level routines used by GNATMLIB
 --  and GNATMAKE to build libraries
 
+with Namet; use Namet;
+with Osint; use Osint;
+
 with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Osint;       use Osint;
-with Types;       use Types;
 
 package MLib is
 
@@ -60,7 +61,7 @@ package MLib is
 
    procedure Copy_ALI_Files
      (Files      : Argument_List;
-      To         : Name_Id;
+      To         : Path_Name_Type;
       Interfaces : String_List);
    --  Copy all ALI files Files to directory To.
    --  Mark Interfaces ALI files as interfaces, if any.