path: root/gcc/ada/mdll.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                 M D L L                                  --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2024, 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- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This package provides the core high level routines used by GNATDLL
--  to build Windows DLL.

with Ada.Text_IO;

with GNAT.Directory_Operations;
with MDLL.Utl;
with MDLL.Fil;

package body MDLL is

   use Ada;
   use GNAT;

   --  Convention used for the library names on Windows:
   --  DLL:            <name>.dll
   --  Import library: lib<name>.dll

   function Get_Dll_Name (Lib_Filename : String) return String;
   --  Returns <Lib_Filename> if it contains a file extension otherwise it
   --  returns <Lib_Filename>.dll.

   ---------------------------
   -- Build_Dynamic_Library --
   ---------------------------

   procedure Build_Dynamic_Library
     (Ofiles        : Argument_List;
      Afiles        : Argument_List;
      Options       : Argument_List;
      Bargs_Options : Argument_List;
      Largs_Options : Argument_List;
      Lib_Filename  : String;
      Def_Filename  : String;
      Lib_Address   : String  := "";
      Build_Import  : Boolean := False;
      Relocatable   : Boolean := False;
      Map_File      : Boolean := False)
   is

      use type OS_Lib.Argument_List;

      Base_Filename : constant String := MDLL.Fil.Ext_To (Lib_Filename);

      Def_File : aliased constant String := Def_Filename;
      Jnk_File : aliased          String := Base_Filename & ".jnk";
      Bas_File : aliased constant String := Base_Filename & ".base";
      Dll_File : aliased          String := Get_Dll_Name (Lib_Filename);
      Exp_File : aliased          String := Base_Filename & ".exp";
      Lib_File : aliased constant String := "lib" & Base_Filename & ".dll.a";

      Bas_Opt  : aliased String := "-Wl,--base-file," & Bas_File;
      Lib_Opt  : aliased String := "-mdll";
      Out_Opt  : aliased String := "-o";
      Adr_Opt  : aliased String := "-Wl,--image-base=" & Lib_Address;
      Map_Opt  : aliased String := "-Wl,-Map," & Lib_Filename & ".map";

      L_Afiles : Argument_List := Afiles;
      --  Local afiles list. This list can be reordered to ensure that the
      --  binder ALI file is not the first entry in this list.

      All_Options : constant Argument_List := Options & Largs_Options;

      procedure Build_Reloc_DLL;
      --  Build a relocatable DLL with only objects file specified. This uses
      --  the well known five step build (see GNAT User's Guide).

      procedure Ada_Build_Reloc_DLL;
      --  Build a relocatable DLL with Ada code. This uses the well known five
      --  step build (see GNAT User's Guide).

      procedure Build_Non_Reloc_DLL;
      --  Build a non relocatable DLL containing no Ada code

      procedure Ada_Build_Non_Reloc_DLL;
      --  Build a non relocatable DLL with Ada code

      ---------------------
      -- Build_Reloc_DLL --
      ---------------------

      procedure Build_Reloc_DLL is

         Objects_Exp_File : constant OS_Lib.Argument_List :=
                              Exp_File'Unchecked_Access & Ofiles;
         --  Objects plus the export table (.exp) file

         Success : Boolean;
         pragma Warnings (Off, Success);

      begin
         if not Quiet then
            Text_IO.Put_Line ("building relocatable DLL...");
            Text_IO.Put ("make " & Dll_File);

            if Build_Import then
               Text_IO.Put_Line (" and " & Lib_File);
            else
               Text_IO.New_Line;
            end if;
         end if;

         --  1) Build base file with objects files

         Utl.Gcc (Output_File => Jnk_File,
                  Files       => Ofiles,
                  Options     => All_Options,
                  Base_File   => Bas_File,
                  Build_Lib   => True);

         --  2) Build exp from base file

         Utl.Dlltool (Def_File, Dll_File, Lib_File,
                      Base_File    => Bas_File,
                      Exp_Table    => Exp_File,
                      Build_Import => False);

         --  3) Build base file with exp file and objects files

         Utl.Gcc (Output_File => Jnk_File,
                  Files       => Objects_Exp_File,
                  Options     => All_Options,
                  Base_File   => Bas_File,
                  Build_Lib   => True);

         --  4) Build new exp from base file and the lib file (.a)

         Utl.Dlltool (Def_File, Dll_File, Lib_File,
                      Base_File    => Bas_File,
                      Exp_Table    => Exp_File,
                      Build_Import => Build_Import);

         --  5) Build the dynamic library

         declare
            Params      : constant OS_Lib.Argument_List :=
                            Map_Opt'Unchecked_Access &
                            Adr_Opt'Unchecked_Access & All_Options;
            First_Param : Positive := Params'First + 1;

         begin
            if Map_File then
               First_Param := Params'First;
            end if;

            Utl.Gcc
              (Output_File => Dll_File,
               Files       => Objects_Exp_File,
               Options     => Params (First_Param .. Params'Last),
               Build_Lib   => True);
         end;

         OS_Lib.Delete_File (Exp_File, Success);
         OS_Lib.Delete_File (Bas_File, Success);
         OS_Lib.Delete_File (Jnk_File, Success);

      exception
         when others =>
            OS_Lib.Delete_File (Exp_File, Success);
            OS_Lib.Delete_File (Bas_File, Success);
            OS_Lib.Delete_File (Jnk_File, Success);
            raise;
      end Build_Reloc_DLL;

      -------------------------
      -- Ada_Build_Reloc_DLL --
      -------------------------

      procedure Ada_Build_Reloc_DLL is
         Success : Boolean;
         pragma Warnings (Off, Success);

      begin
         if not Quiet then
            Text_IO.Put_Line ("Building relocatable DLL...");
            Text_IO.Put ("make " & Dll_File);

            if Build_Import then
               Text_IO.Put_Line (" and " & Lib_File);
            else
               Text_IO.New_Line;
            end if;
         end if;

         --  1) Build base file with objects files

         Utl.Gnatbind (L_Afiles, Options & Bargs_Options);

         declare
            Params : constant OS_Lib.Argument_List :=
                       Out_Opt'Unchecked_Access &
                       Jnk_File'Unchecked_Access &
                       Lib_Opt'Unchecked_Access &
                       Bas_Opt'Unchecked_Access &
                       Ofiles &
                       All_Options;
         begin
            Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
         end;

         --  2) Build exp from base file

         Utl.Dlltool (Def_File, Dll_File, Lib_File,
                      Base_File    => Bas_File,
                      Exp_Table    => Exp_File,
                      Build_Import => False);

         --  3) Build base file with exp file and objects files

         Utl.Gnatbind (L_Afiles, Options & Bargs_Options);

         declare
            Params : constant OS_Lib.Argument_List :=
                       Out_Opt'Unchecked_Access &
                       Jnk_File'Unchecked_Access &
                       Lib_Opt'Unchecked_Access &
                       Bas_Opt'Unchecked_Access &
                       Exp_File'Unchecked_Access &
                       Ofiles &
                       All_Options;
         begin
            Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
         end;

         --  4) Build new exp from base file and the lib file (.a)

         Utl.Dlltool (Def_File, Dll_File, Lib_File,
                      Base_File    => Bas_File,
                      Exp_Table    => Exp_File,
                      Build_Import => Build_Import);

         --  5) Build the dynamic library

         Utl.Gnatbind (L_Afiles, Options & Bargs_Options);

         declare
            Params      : constant OS_Lib.Argument_List :=
                            Map_Opt'Unchecked_Access &
                            Out_Opt'Unchecked_Access &
                            Dll_File'Unchecked_Access &
                            Lib_Opt'Unchecked_Access &
                            Exp_File'Unchecked_Access &
                            Adr_Opt'Unchecked_Access &
                            Ofiles &
                            All_Options;
            First_Param : Positive := Params'First + 1;

         begin
            if Map_File then
               First_Param := Params'First;
            end if;

            Utl.Gnatlink
              (L_Afiles (L_Afiles'Last).all,
               Params (First_Param .. Params'Last));
         end;

         OS_Lib.Delete_File (Exp_File, Success);
         OS_Lib.Delete_File (Bas_File, Success);
         OS_Lib.Delete_File (Jnk_File, Success);

      exception
         when others =>
            OS_Lib.Delete_File (Exp_File, Success);
            OS_Lib.Delete_File (Bas_File, Success);
            OS_Lib.Delete_File (Jnk_File, Success);
            raise;
      end Ada_Build_Reloc_DLL;

      -------------------------
      -- Build_Non_Reloc_DLL --
      -------------------------

      procedure Build_Non_Reloc_DLL is
         Success : Boolean;
         pragma Warnings (Off, Success);

      begin
         if not Quiet then
            Text_IO.Put_Line ("building non relocatable DLL...");
            Text_IO.Put ("make " & Dll_File &
                         " using address " & Lib_Address);

            if Build_Import then
               Text_IO.Put_Line (" and " & Lib_File);
            else
               Text_IO.New_Line;
            end if;
         end if;

         --  Build exp table and the lib .a file

         Utl.Dlltool (Def_File, Dll_File, Lib_File,
                      Exp_Table    => Exp_File,
                      Build_Import => Build_Import);

         --  Build the DLL

         declare
            Params : OS_Lib.Argument_List :=
                       Adr_Opt'Unchecked_Access & All_Options;
         begin
            if Map_File then
               Params := Map_Opt'Unchecked_Access & Params;
            end if;

            Utl.Gcc (Output_File => Dll_File,
                     Files       => Exp_File'Unchecked_Access & Ofiles,
                     Options     => Params,
                     Build_Lib   => True);
         end;

         OS_Lib.Delete_File (Exp_File, Success);

      exception
         when others =>
            OS_Lib.Delete_File (Exp_File, Success);
            raise;
      end Build_Non_Reloc_DLL;

      -----------------------------
      -- Ada_Build_Non_Reloc_DLL --
      -----------------------------

      --  Build a non relocatable DLL with Ada code

      procedure Ada_Build_Non_Reloc_DLL is
         Success : Boolean;
         pragma Warnings (Off, Success);

      begin
         if not Quiet then
            Text_IO.Put_Line ("building non relocatable DLL...");
            Text_IO.Put ("make " & Dll_File &
                         " using address " & Lib_Address);

            if Build_Import then
               Text_IO.Put_Line (" and " & Lib_File);
            else
               Text_IO.New_Line;
            end if;
         end if;

         --  Build exp table and the lib .a file

         Utl.Dlltool (Def_File, Dll_File, Lib_File,
                      Exp_Table    => Exp_File,
                      Build_Import => Build_Import);

         --  Build the DLL

         Utl.Gnatbind (L_Afiles, Options & Bargs_Options);

         declare
            Params : OS_Lib.Argument_List :=
                       Out_Opt'Unchecked_Access &
                       Dll_File'Unchecked_Access &
                       Lib_Opt'Unchecked_Access &
                       Exp_File'Unchecked_Access &
                       Adr_Opt'Unchecked_Access &
                       Ofiles &
                       All_Options;
         begin
            if Map_File then
               Params := Map_Opt'Unchecked_Access & Params;
            end if;

            Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
         end;

         OS_Lib.Delete_File (Exp_File, Success);

      exception
         when others =>
            OS_Lib.Delete_File (Exp_File, Success);
            raise;
      end Ada_Build_Non_Reloc_DLL;

   --  Start of processing for Build_Dynamic_Library

   begin
      --  On Windows the binder file must not be in the first position in the
      --  list. This is due to the way DLL's are built on Windows. We swap the
      --  first ali with the last one if it is the case.

      if L_Afiles'Length > 1 then
         declare
            Filename : constant String :=
                         Directory_Operations.Base_Name
                           (L_Afiles (L_Afiles'First).all);
            First    : constant Positive := Filename'First;

         begin
            if Filename (First .. First + 1) = "b~" then
               L_Afiles (L_Afiles'Last) := Afiles (Afiles'First);
               L_Afiles (L_Afiles'First) := Afiles (Afiles'Last);
            end if;
         end;
      end if;

      case Relocatable is
         when True =>
            if L_Afiles'Length = 0 then
               Build_Reloc_DLL;
            else
               Ada_Build_Reloc_DLL;
            end if;

         when False =>
            if L_Afiles'Length = 0 then
               Build_Non_Reloc_DLL;
            else
               Ada_Build_Non_Reloc_DLL;
            end if;
      end case;
   end Build_Dynamic_Library;

   --------------------------
   -- Build_Import_Library --
   --------------------------

   procedure Build_Import_Library
     (Lib_Filename : String;
      Def_Filename : String)
   is
      function Strip_Lib_Prefix (Filename : String) return String;
      --  Return Filename without the lib prefix if present

      ----------------------
      -- Strip_Lib_Prefix --
      ----------------------

      function Strip_Lib_Prefix (Filename : String) return String is
      begin
         if Filename (Filename'First .. Filename'First + 2) = "lib" then
            return Filename (Filename'First + 3 .. Filename'Last);
         else
            return Filename;
         end if;
      end Strip_Lib_Prefix;

      --  Local variables

      Def_File      : String renames Def_Filename;
      Dll_File      : constant String := Get_Dll_Name (Lib_Filename);
      Base_Filename : constant String :=
                        MDLL.Fil.Ext_To (Strip_Lib_Prefix (Lib_Filename));
      Lib_File      : constant String := "lib" & Base_Filename & ".dll.a";

   --  Start of processing for Build_Import_Library

   begin
      if not Quiet then
         Text_IO.Put_Line ("Building import library...");
         Text_IO.Put_Line
           ("make " & Lib_File & " to use dynamic library " & Dll_File);
      end if;

      Utl.Dlltool
        (Def_File, Dll_File, Lib_File, Build_Import => True);
   end Build_Import_Library;

   ------------------
   -- Get_Dll_Name --
   ------------------

   function Get_Dll_Name (Lib_Filename : String) return String is
   begin
      if MDLL.Fil.Get_Ext (Lib_Filename) = "" then
         return Lib_Filename & ".dll";
      else
         return Lib_Filename;
      end if;
   end Get_Dll_Name;

end MDLL;