gnatlink.adb (Process_Binder_File): If -shared is specified, invoke gcc to link with option -shared-libgcc.

2006-02-13  Vincent Celier  <celier@adacore.com>

	* gnatlink.adb (Process_Binder_File): If -shared is specified, invoke
	gcc to link with option -shared-libgcc.
	(Gnatlink): Remove duplicate switches -shared-libgcc

From-SVN: r111046

1 files changed, 46 insertions, 14 deletions

diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb
index a099217..a2e6382 100644
--- a/gcc/ada/gnatlink.adb
+++ b/gcc/ada/gnatlink.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1996-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1996-2006, 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- --
@@ -52,6 +52,11 @@ with System.CRTL;
 procedure Gnatlink is
    pragma Ident (Gnatvsn.Gnat_Static_Version_String);
 
+   Shared_Libgcc_String : constant String := "-shared-libgcc";
+   Shared_Libgcc        : constant String_Access :=
+                            new String'(Shared_Libgcc_String);
+   --  Used to invoke gcc when the binder is invoked with -shared
+
    package Gcc_Linker_Options is new Table.Table (
      Table_Component_Type => String_Access,
      Table_Index_Type     => Integer,
@@ -174,22 +179,22 @@ procedure Gnatlink is
    Object_List_File_Required : Boolean := False;
    --  Set to True to force generation of a response file
 
-   function Base_Name (File_Name : in String) return String;
+   function Base_Name (File_Name : String) return String;
    --  Return just the file name part without the extension (if present)
 
-   procedure Delete (Name : in String);
+   procedure Delete (Name : String);
    --  Wrapper to unlink as status is ignored by this application
 
-   procedure Error_Msg (Message : in String);
+   procedure Error_Msg (Message : String);
    --  Output the error or warning Message
 
-   procedure Exit_With_Error (Error : in String);
+   procedure Exit_With_Error (Error : String);
    --  Output Error and exit program with a fatal condition
 
    procedure Process_Args;
    --  Go through all the arguments and build option tables
 
-   procedure Process_Binder_File (Name : in String);
+   procedure Process_Binder_File (Name : String);
    --  Reads the binder file and extracts linker arguments
 
    procedure Write_Header;
@@ -202,7 +207,7 @@ procedure Gnatlink is
    -- Base_Name --
    ---------------
 
-   function Base_Name (File_Name : in String) return String is
+   function Base_Name (File_Name : String) return String is
       Findex1 : Natural;
       Findex2 : Natural;
 
@@ -237,7 +242,7 @@ procedure Gnatlink is
    -- Delete --
    ------------
 
-   procedure Delete (Name : in String) is
+   procedure Delete (Name : String) is
       Status : int;
       pragma Unreferenced (Status);
    begin
@@ -249,7 +254,7 @@ procedure Gnatlink is
    -- Error_Msg --
    ---------------
 
-   procedure Error_Msg (Message : in String) is
+   procedure Error_Msg (Message : String) is
    begin
       Write_Str (Base_Name (Command_Name));
       Write_Str (": ");
@@ -261,7 +266,7 @@ procedure Gnatlink is
    -- Exit_With_Error --
    ---------------------
 
-   procedure Exit_With_Error (Error : in String) is
+   procedure Exit_With_Error (Error : String) is
    begin
       Error_Msg (Error);
       Exit_Program (E_Fatal);
@@ -626,7 +631,7 @@ procedure Gnatlink is
    -- Process_Binder_File --
    -------------------------
 
-   procedure Process_Binder_File (Name : in String) is
+   procedure Process_Binder_File (Name : String) is
       Fd : FILEs;
       --  Binder file's descriptor
 
@@ -729,7 +734,7 @@ procedure Gnatlink is
       function Index (S, Pattern : String) return Natural;
       --  Return the last occurrence of Pattern in S, or 0 if none
 
-      function Is_Option_Present (Opt : in String) return Boolean;
+      function Is_Option_Present (Opt : String) return Boolean;
       --  Return true if the option Opt is already present in
       --  Linker_Options table.
 
@@ -791,7 +796,7 @@ procedure Gnatlink is
       -- Is_Option_Present --
       -----------------------
 
-      function Is_Option_Present (Opt : in String) return Boolean is
+      function Is_Option_Present (Opt : String) return Boolean is
       begin
          for I in 1 .. Linker_Options.Last loop
 
@@ -931,7 +936,9 @@ procedure Gnatlink is
 
          --  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.
 
@@ -999,6 +1006,7 @@ procedure Gnatlink is
 
          declare
             N : Integer;
+
          begin
             N := Objs_End - Objs_Begin + 1;
 
@@ -1288,6 +1296,13 @@ procedure Gnatlink is
          end loop;
       end if;
 
+      --  If -shared was specified, invoke gcc with -shared-libgcc
+
+      if GNAT_Shared then
+         Linker_Options.Increment_Last;
+         Linker_Options.Table (Linker_Options.Last) := Shared_Libgcc;
+      end if;
+
       Status := fclose (Fd);
    end Process_Binder_File;
 
@@ -1302,7 +1317,9 @@ procedure Gnatlink is
          Write_Str ("GNATLINK ");
          Write_Str (Gnat_Version_String);
          Write_Eol;
-         Write_Str ("Copyright 1995-2005 Free Software Foundation, Inc");
+         Write_Str ("Copyright 1995-" &
+                    Current_Year &
+                    ", Free Software Foundation, Inc");
          Write_Eol;
       end if;
    end Write_Header;
@@ -1710,6 +1727,7 @@ begin
 
          Clean_Link_Option_Set : declare
             J : Natural := Linker_Options.First;
+            Shared_Libgcc_Seen : Boolean := False;
 
          begin
             while J <= Linker_Options.Last loop
@@ -1731,6 +1749,20 @@ begin
                   end if;
                end if;
 
+               --  Remove duplicate -shared-libgcc switch
+
+               if Linker_Options.Table (J).all = Shared_Libgcc_String then
+                  if Shared_Libgcc_Seen then
+                     Linker_Options.Table (J .. Linker_Options.Last - 1) :=
+                       Linker_Options.Table (J + 1 .. Linker_Options.Last);
+                     Linker_Options.Decrement_Last;
+                     Num_Args := Num_Args - 1;
+
+                  else
+                     Shared_Libgcc_Seen := True;
+                  end if;
+               end if;
+
                --  Here we just check for a canonical form that matches the
                --  pragma Linker_Options set in the NT runtime.