gcc/ada/mlib-tgt-mingw.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             M L I B . T G T                              --
   6 --                            (Windows Version)                             --
   7 --                                                                          --
   8 --                                 B o d y                                  --
   9 --                                                                          --
  10 --          Copyright (C) 2002-2005, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, USA.                                              --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 --  This package provides a set of target dependent routines to build
  29 --  static, dynamic and shared libraries.
  30
  31 --  This is the Windows version of the body. Works only with GCC versions
  32 --  supporting the "-shared" option.
  33
  34 with Ada.Characters.Handling; use Ada.Characters.Handling;
  35 with Ada.Text_IO;             use Ada; use Ada.Text_IO;
  36 with GNAT.OS_Lib;             use GNAT.OS_Lib;
  37
  38 with Namet;  use Namet;
  39 with Opt;
  40 with Output; use Output;
  41 with Prj.Com;
  42
  43 with MLib.Fil;
  44 with MLib.Utl;
  45
  46 package body MLib.Tgt is
  47
  48    package Files renames MLib.Fil;
  49    package Tools renames MLib.Utl;
  50
  51    ---------------------
  52    -- Archive_Builder --
  53    ---------------------
  54
  55    function Archive_Builder return String is
  56    begin
  57       return "ar";
  58    end Archive_Builder;
  59
  60    -----------------------------
  61    -- Archive_Builder_Options --
  62    -----------------------------
  63
  64    function Archive_Builder_Options return String_List_Access is
  65    begin
  66       return new String_List'(1 => new String'("cr"));
  67    end Archive_Builder_Options;
  68
  69    -----------------
  70    -- Archive_Ext --
  71    -----------------
  72
  73    function Archive_Ext return  String is
  74    begin
  75       return "a";
  76    end Archive_Ext;
  77
  78    ---------------------
  79    -- Archive_Indexer --
  80    ---------------------
  81
  82    function Archive_Indexer return String is
  83    begin
  84       return "ranlib";
  85    end Archive_Indexer;
  86
  87    -----------------------------
  88    -- Archive_Indexer_Options --
  89    -----------------------------
  90
  91    function Archive_Indexer_Options return String_List_Access is
  92    begin
  93       return new String_List (1 .. 0);
  94    end Archive_Indexer_Options;
  95
  96    ---------------------------
  97    -- Build_Dynamic_Library --
  98    ---------------------------
  99
 100    procedure Build_Dynamic_Library
 101      (Ofiles       : Argument_List;
 102       Foreign      : Argument_List;
 103       Afiles       : Argument_List;
 104       Options      : Argument_List;
 105       Options_2    : Argument_List;
 106       Interfaces   : Argument_List;
 107       Lib_Filename : String;
 108       Lib_Dir      : String;
 109       Symbol_Data  : Symbol_Record;
 110       Driver_Name  : Name_Id := No_Name;
 111       Lib_Version  : String  := "";
 112       Auto_Init    : Boolean := False)
 113    is
 114       pragma Unreferenced (Foreign);
 115       pragma Unreferenced (Afiles);
 116       pragma Unreferenced (Symbol_Data);
 117       pragma Unreferenced (Interfaces);
 118       pragma Unreferenced (Lib_Version);
 119
 120       Lib_File : constant String :=
 121                    Lib_Dir & Directory_Separator &
 122                    Files.Ext_To (Lib_Filename, DLL_Ext);
 123
 124    --  Start of processing for Build_Dynamic_Library
 125
 126    begin
 127       if Opt.Verbose_Mode then
 128          Write_Str ("building relocatable shared library ");
 129          Write_Line (Lib_File);
 130       end if;
 131
 132       --  Generate auto-init routine if in Auto_Init mode
 133
 134       if Auto_Init then
 135          declare
 136             Compile_Only  : aliased String := "-c";
 137             GCC           : constant String_Access :=
 138                               Locate_Exec_On_Path ("gcc.exe");
 139             Filename      : constant String := To_Lower (Lib_Filename);
 140             Autoinit_Spec : constant String := Filename & "_autoinit.ads";
 141             Autoinit_Body : aliased String  := Filename & "_autoinit.adb";
 142             Autoinit_Obj  : aliased String  := Filename & "_autoinit.o";
 143             Autoinit_Ali  : constant String := Filename & "_autoinit.ali";
 144             Init_Proc     : constant String := Lib_Filename & "init";
 145             Final_Proc    : constant String := Lib_Filename & "final";
 146             Autoinit_Opt  : constant Argument_List :=
 147                               (1 => Autoinit_Obj'Unchecked_Access);
 148             Arguments     : constant Argument_List (1 .. 2) :=
 149                               (Compile_Only'Unchecked_Access,
 150                                Autoinit_Body'Unchecked_Access);
 151             File          : Text_IO.File_Type;
 152             Success       : Boolean;
 153
 154          begin
 155             if Opt.Verbose_Mode then
 156                Write_Str ("Creating auto-init Ada file """);
 157                Write_Str (Autoinit_Spec);
 158                Write_Str (""" and """);
 159                Write_Str (Autoinit_Body);
 160                Write_Line ("""");
 161             end if;
 162
 163             --  Create the spec
 164
 165             Create (File, Out_File, Autoinit_Spec);
 166
 167             Put_Line (File, "package " & Lib_Filename & "_autoinit is");
 168             New_Line (File);
 169             Put_Line (File, "   type HINSTANCE is new Integer;");
 170             Put_Line (File, "   type DWORD     is new Integer;");
 171             Put_Line (File, "   type LPVOID    is new Integer;");
 172             Put_Line (File, "   type BOOL      is new Integer;");
 173             New_Line (File);
 174             Put_Line (File, "   function DllMain");
 175             Put_Line (File, "     (hinstdll    : HINSTANCE;");
 176             Put_Line (File, "      fdwreason   : DWORD;");
 177             Put_Line (File, "      lpvreserved : LPVOID)");
 178             Put_Line (File, "      return BOOL;");
 179             Put_Line
 180               (File, "   pragma Export (Stdcall, DllMain, ""DllMain"");");
 181             New_Line (File);
 182             Put_Line (File, "end " & Lib_Filename & "_autoinit;");
 183
 184             Close (File);
 185
 186             --  Create the body
 187
 188             Create (File, Out_File, Autoinit_Body);
 189
 190             Put_Line (File, "package body " & Lib_Filename & "_autoinit is");
 191             New_Line (File);
 192             Put_Line (File, "   DLL_PROCESS_DETACH : constant := 0;");
 193             Put_Line (File, "   DLL_PROCESS_ATTACH : constant := 1;");
 194             Put_Line (File, "   DLL_THREAD_ATTACH  : constant := 2;");
 195             Put_Line (File, "   DLL_THREAD_DETACH  : constant := 3;");
 196             New_Line (File);
 197             Put_Line (File, "   procedure " & Init_Proc & ";");
 198             Put      (File, "   pragma Import (C, " & Init_Proc);
 199             Put_Line (File, ", """ & Init_Proc & """);");
 200             New_Line (File);
 201             Put_Line (File, "   procedure " & Final_Proc & ";");
 202             Put      (File, "   pragma Import (C, " & Final_Proc);
 203             Put_Line (File, ", """ & Final_Proc & """);");
 204             New_Line (File);
 205             Put_Line (File, "   function DllMain");
 206             Put_Line (File, "     (hinstdll    : HINSTANCE;");
 207             Put_Line (File, "      fdwreason   : DWORD;");
 208             Put_Line (File, "      lpvreserved : LPVOID)");
 209             Put_Line (File, "      return BOOL");
 210             Put_Line (File, "   is");
 211             Put_Line (File, "      pragma Unreferenced (hinstDLL);");
 212             Put_Line (File, "      pragma Unreferenced (lpvReserved);");
 213             Put_Line (File, "   begin");
 214             Put_Line (File, "      case fdwReason is");
 215             Put_Line (File, "         when DLL_PROCESS_ATTACH =>");
 216             Put_Line (File, "            " & Init_Proc & ";");
 217             Put_Line (File, "         when DLL_PROCESS_DETACH =>");
 218             Put_Line (File, "            " & Final_Proc & ";");
 219             Put_Line (File, "         when DLL_THREAD_ATTACH =>");
 220             Put_Line (File, "            null;");
 221             Put_Line (File, "         when DLL_THREAD_DETACH =>");
 222             Put_Line (File, "            null;");
 223             Put_Line (File, "         when others =>");
 224             Put_Line (File, "            null;");
 225             Put_Line (File, "      end case;");
 226             Put_Line (File, "      return 1;");
 227             Put_Line (File, "   exception");
 228             Put_Line (File, "      when others =>");
 229             Put_Line (File, "         return 0;");
 230             Put_Line (File, "   end DllMain;");
 231             New_Line (File);
 232             Put_Line (File, "end " & Lib_Filename & "_autoinit;");
 233
 234             Close (File);
 235
 236             --  Compile the auto-init file
 237
 238             Spawn (GCC.all, Arguments, Success);
 239
 240             if not Success then
 241                Fail ("unable to compile the auto-init unit for library """,
 242                      Lib_Filename, """");
 243             end if;
 244
 245             --  Build the SAL library
 246
 247             Tools.Gcc
 248               (Output_File => Lib_File,
 249                Objects     => Ofiles,
 250                Options     => Tools.No_Argument_List,
 251                Options_2   => Options & Options_2 & Autoinit_Opt,
 252                Driver_Name => Driver_Name);
 253
 254             --  Remove generated files
 255
 256             if Opt.Verbose_Mode then
 257                Write_Str ("deleting auto-init generated files");
 258                Write_Eol;
 259             end if;
 260
 261             Delete_File (Autoinit_Spec, Success);
 262             Delete_File (Autoinit_Body, Success);
 263             Delete_File (Autoinit_Obj, Success);
 264             Delete_File (Autoinit_Ali, Success);
 265          end;
 266
 267       else
 268          Tools.Gcc
 269            (Output_File => Lib_File,
 270             Objects     => Ofiles,
 271             Options     => Tools.No_Argument_List,
 272             Options_2   => Options & Options_2,
 273             Driver_Name => Driver_Name);
 274       end if;
 275    end Build_Dynamic_Library;
 276
 277    -------------
 278    -- DLL_Ext --
 279    -------------
 280
 281    function DLL_Ext return String is
 282    begin
 283       return "dll";
 284    end DLL_Ext;
 285
 286    --------------------
 287    -- Dynamic_Option --
 288    --------------------
 289
 290    function Dynamic_Option return String is
 291    begin
 292       return "-shared";
 293    end Dynamic_Option;
 294
 295    -------------------
 296    -- Is_Object_Ext --
 297    -------------------
 298
 299    function Is_Object_Ext (Ext : String) return Boolean is
 300    begin
 301       return Ext = ".o";
 302    end Is_Object_Ext;
 303
 304    --------------
 305    -- Is_C_Ext --
 306    --------------
 307
 308    function Is_C_Ext (Ext : String) return Boolean is
 309    begin
 310       return Ext = ".c";
 311    end Is_C_Ext;
 312
 313    --------------------
 314    -- Is_Archive_Ext --
 315    --------------------
 316
 317    function Is_Archive_Ext (Ext : String) return Boolean is
 318    begin
 319       return Ext = ".a" or else Ext = ".dll";
 320    end Is_Archive_Ext;
 321
 322    -------------
 323    -- Libgnat --
 324    -------------
 325
 326    function Libgnat return String is
 327    begin
 328       return "libgnat.a";
 329    end Libgnat;
 330
 331    ------------------------
 332    -- Library_Exists_For --
 333    ------------------------
 334
 335    function Library_Exists_For
 336      (Project : Project_Id; In_Tree : Project_Tree_Ref) return Boolean is
 337    begin
 338       if not In_Tree.Projects.Table (Project).Library then
 339          Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
 340                        "for non library project");
 341          return False;
 342
 343       else
 344          declare
 345             Lib_Dir : constant String :=
 346               Get_Name_String
 347                 (In_Tree.Projects.Table (Project).Library_Dir);
 348             Lib_Name : constant String :=
 349               Get_Name_String
 350                 (In_Tree.Projects.Table (Project).Library_Name);
 351
 352          begin
 353             if In_Tree.Projects.Table (Project).Library_Kind =
 354               Static
 355             then
 356                return Is_Regular_File
 357                  (Lib_Dir & Directory_Separator & "lib" &
 358                   MLib.Fil.Ext_To (Lib_Name, Archive_Ext));
 359
 360             else
 361                return Is_Regular_File
 362                  (Lib_Dir & Directory_Separator &
 363                   MLib.Fil.Ext_To (Lib_Name, DLL_Ext));
 364             end if;
 365          end;
 366       end if;
 367    end Library_Exists_For;
 368
 369    ---------------------------
 370    -- Library_File_Name_For --
 371    ---------------------------
 372
 373    function Library_File_Name_For
 374      (Project : Project_Id;
 375       In_Tree : Project_Tree_Ref) return Name_Id is
 376    begin
 377       if not In_Tree.Projects.Table (Project).Library then
 378          Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
 379                        "for non library project");
 380          return No_Name;
 381
 382       else
 383          declare
 384             Lib_Name : constant String :=
 385               Get_Name_String
 386                 (In_Tree.Projects.Table (Project).Library_Name);
 387
 388          begin
 389             if In_Tree.Projects.Table (Project).Library_Kind =
 390               Static
 391             then
 392                Name_Len := 3;
 393                Name_Buffer (1 .. Name_Len) := "lib";
 394                Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
 395
 396             else
 397                Name_Len := 0;
 398                Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
 399             end if;
 400
 401             return Name_Find;
 402          end;
 403       end if;
 404    end Library_File_Name_For;
 405
 406    ----------------
 407    -- Object_Ext --
 408    ----------------
 409
 410    function Object_Ext return String is
 411    begin
 412       return "o";
 413    end Object_Ext;
 414
 415    ----------------
 416    -- PIC_Option --
 417    ----------------
 418
 419    function PIC_Option return String is
 420    begin
 421       return "";
 422    end PIC_Option;
 423
 424    -----------------------------------------------
 425    -- Standalone_Library_Auto_Init_Is_Supported --
 426    -----------------------------------------------
 427
 428    function Standalone_Library_Auto_Init_Is_Supported return Boolean is
 429    begin
 430       return True;
 431    end Standalone_Library_Auto_Init_Is_Supported;
 432
 433    ---------------------------
 434    -- Support_For_Libraries --
 435    ---------------------------
 436
 437    function Support_For_Libraries return Library_Support is
 438    begin
 439       return Full;
 440    end Support_For_Libraries;
 441
 442 end MLib.Tgt;