1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                             M L I B . T G T                              --
6--                             (True64 Version)                             --
7--                                                                          --
8--                                 B o d y                                  --
9--                                                                          --
10--              Copyright (C) 2002-2003 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,  59 Temple Place - Suite 330,  Boston, --
21-- MA 02111-1307, 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 True64 version of the body.
32
33with MLib.Fil;
34with MLib.Utl;
35with Namet;  use Namet;
36with Opt;
37with Output; use Output;
38with Prj.Com;
39with System;
40
41package body MLib.Tgt is
42
43   use GNAT;
44   use MLib;
45
46   Expect_Unresolved : aliased String := "-Wl,-expect_unresolved,*";
47
48   No_Arguments        : aliased Argument_List         := (1 .. 0 => null);
49   Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access;
50
51   Wl_Init_String : aliased String         := "-Wl,-init";
52   Wl_Init        : constant String_Access := Wl_Init_String'Access;
53   Wl_Fini_String : aliased String         := "-Wl,-fini";
54   Wl_Fini        : constant String_Access := Wl_Fini_String'Access;
55
56   Init_Fini_List :  constant Argument_List_Access :=
57                       new Argument_List'(1 => Wl_Init,
58                                          2 => null,
59                                          3 => Wl_Fini,
60                                          4 => null);
61   --  Used to put switches for automatic elaboration/finalization
62
63   ---------------------
64   -- Archive_Builder --
65   ---------------------
66
67   function Archive_Builder return String is
68   begin
69      return "ar";
70   end Archive_Builder;
71
72   -----------------------------
73   -- Archive_Builder_Options --
74   -----------------------------
75
76   function Archive_Builder_Options return String_List_Access is
77   begin
78      return new String_List'(1 => new String'("cr"));
79   end Archive_Builder_Options;
80
81   -----------------
82   -- Archive_Ext --
83   -----------------
84
85   function Archive_Ext return  String is
86   begin
87      return "a";
88   end Archive_Ext;
89
90   ---------------------
91   -- Archive_Indexer --
92   ---------------------
93
94   function Archive_Indexer return String is
95   begin
96      return "ranlib";
97   end Archive_Indexer;
98
99   ---------------------------
100   -- Build_Dynamic_Library --
101   ---------------------------
102
103   procedure Build_Dynamic_Library
104     (Ofiles       : Argument_List;
105      Foreign      : Argument_List;
106      Afiles       : Argument_List;
107      Options      : Argument_List;
108      Interfaces   : Argument_List;
109      Lib_Filename : String;
110      Lib_Dir      : String;
111      Symbol_Data  : Symbol_Record;
112      Driver_Name  : Name_Id := No_Name;
113      Lib_Address  : String  := "";
114      Lib_Version  : String  := "";
115      Relocatable  : Boolean := False;
116      Auto_Init    : Boolean := False)
117   is
118      pragma Unreferenced (Foreign);
119      pragma Unreferenced (Afiles);
120      pragma Unreferenced (Interfaces);
121      pragma Unreferenced (Symbol_Data);
122      pragma Unreferenced (Lib_Address);
123      pragma Unreferenced (Relocatable);
124
125      Lib_File : constant String :=
126        Lib_Dir & Directory_Separator & "lib" &
127        Fil.Ext_To (Lib_Filename, DLL_Ext);
128
129      Version_Arg          : String_Access;
130      Symbolic_Link_Needed : Boolean := False;
131
132      Init_Fini : Argument_List_Access := Empty_Argument_List;
133
134   begin
135      if Opt.Verbose_Mode then
136         Write_Str ("building relocatable shared library ");
137         Write_Line (Lib_File);
138      end if;
139
140      --  If specified, add automatic elaboration/finalization
141
142      if Auto_Init then
143         Init_Fini := Init_Fini_List;
144         Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init");
145         Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final");
146      end if;
147
148      if Lib_Version = "" then
149         Utl.Gcc
150           (Output_File => Lib_File,
151            Objects     => Ofiles,
152            Options     =>
153              Options &
154              Expect_Unresolved'Access &
155              Init_Fini.all,
156            Driver_Name => Driver_Name);
157
158      else
159         Version_Arg := new String'("-Wl,-soname," & Lib_Version);
160
161         if Is_Absolute_Path (Lib_Version) then
162            Utl.Gcc
163              (Output_File => Lib_Version,
164               Objects     => Ofiles,
165               Options     =>
166                 Options &
167                 Version_Arg &
168                 Expect_Unresolved'Access &
169                 Init_Fini.all,
170               Driver_Name => Driver_Name);
171            Symbolic_Link_Needed := Lib_Version /= Lib_File;
172
173         else
174            Utl.Gcc
175              (Output_File => Lib_Dir & Directory_Separator & Lib_Version,
176               Objects     => Ofiles,
177               Options     =>
178                 Options &
179                 Version_Arg &
180                 Expect_Unresolved'Access &
181                 Init_Fini.all,
182               Driver_Name => Driver_Name);
183            Symbolic_Link_Needed :=
184              Lib_Dir & Directory_Separator & Lib_Version /= Lib_File;
185         end if;
186
187         if Symbolic_Link_Needed then
188            declare
189               Success : Boolean;
190               Oldpath : String (1 .. Lib_Version'Length + 1);
191               Newpath : String (1 .. Lib_File'Length + 1);
192
193               Result : Integer;
194               pragma Unreferenced (Result);
195
196               function Symlink
197                 (Oldpath : System.Address;
198                  Newpath : System.Address)
199                  return    Integer;
200               pragma Import (C, Symlink, "__gnat_symlink");
201
202            begin
203               Oldpath (1 .. Lib_Version'Length) := Lib_Version;
204               Oldpath (Oldpath'Last)            := ASCII.NUL;
205               Newpath (1 .. Lib_File'Length)    := Lib_File;
206               Newpath (Newpath'Last)            := ASCII.NUL;
207
208               Delete_File (Lib_File, Success);
209
210               Result := Symlink (Oldpath'Address, Newpath'Address);
211            end;
212         end if;
213      end if;
214   end Build_Dynamic_Library;
215
216   -------------------------
217   -- Default_DLL_Address --
218   -------------------------
219
220   function Default_DLL_Address return String is
221   begin
222      return "";
223   end Default_DLL_Address;
224
225   -------------
226   -- DLL_Ext --
227   -------------
228
229   function DLL_Ext return String is
230   begin
231      return "so";
232   end DLL_Ext;
233
234   --------------------
235   -- Dynamic_Option --
236   --------------------
237
238   function Dynamic_Option return String is
239   begin
240      return "-shared";
241   end Dynamic_Option;
242
243   -------------------
244   -- Is_Object_Ext --
245   -------------------
246
247   function Is_Object_Ext (Ext : String) return Boolean is
248   begin
249      return Ext = ".o";
250   end Is_Object_Ext;
251
252   --------------
253   -- Is_C_Ext --
254   --------------
255
256   function Is_C_Ext (Ext : String) return Boolean is
257   begin
258      return Ext = ".c";
259   end Is_C_Ext;
260
261   --------------------
262   -- Is_Archive_Ext --
263   --------------------
264
265   function Is_Archive_Ext (Ext : String) return Boolean is
266   begin
267      return Ext = ".a" or else Ext = ".so";
268   end Is_Archive_Ext;
269
270   -------------
271   -- Libgnat --
272   -------------
273
274   function Libgnat return String is
275   begin
276      return "libgnat.a";
277   end Libgnat;
278
279   ------------------------
280   -- Library_Exists_For --
281   ------------------------
282
283   function Library_Exists_For (Project : Project_Id) return Boolean is
284   begin
285      if not Projects.Table (Project).Library then
286         Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
287                       "for non library project");
288         return False;
289
290      else
291         declare
292            Lib_Dir : constant String :=
293              Get_Name_String (Projects.Table (Project).Library_Dir);
294            Lib_Name : constant String :=
295              Get_Name_String (Projects.Table (Project).Library_Name);
296
297         begin
298            if Projects.Table (Project).Library_Kind = Static then
299               return Is_Regular_File
300                 (Lib_Dir & Directory_Separator & "lib" &
301                  Fil.Ext_To (Lib_Name, Archive_Ext));
302
303            else
304               return Is_Regular_File
305                 (Lib_Dir & Directory_Separator & "lib" &
306                  Fil.Ext_To (Lib_Name, DLL_Ext));
307            end if;
308         end;
309      end if;
310   end Library_Exists_For;
311
312   ---------------------------
313   -- Library_File_Name_For --
314   ---------------------------
315
316   function Library_File_Name_For (Project : Project_Id) return Name_Id is
317   begin
318      if not Projects.Table (Project).Library then
319         Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
320                       "for non library project");
321         return No_Name;
322
323      else
324         declare
325            Lib_Name : constant String :=
326              Get_Name_String (Projects.Table (Project).Library_Name);
327
328         begin
329            Name_Len := 3;
330            Name_Buffer (1 .. Name_Len) := "lib";
331
332            if Projects.Table (Project).Library_Kind = Static then
333               Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
334
335            else
336               Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
337            end if;
338
339            return Name_Find;
340         end;
341      end if;
342   end Library_File_Name_For;
343
344   --------------------------------
345   -- Linker_Library_Path_Option --
346   --------------------------------
347
348   function Linker_Library_Path_Option return String_Access is
349   begin
350      return new String'("-Wl,-rpath,");
351   end Linker_Library_Path_Option;
352
353   ----------------
354   -- Object_Ext --
355   ----------------
356
357   function Object_Ext return String is
358   begin
359      return "o";
360   end Object_Ext;
361
362   ----------------
363   -- PIC_Option --
364   ----------------
365
366   function PIC_Option return String is
367   begin
368      return "";
369   end PIC_Option;
370
371   -----------------------------------------------
372   -- Standalone_Library_Auto_Init_Is_Supported --
373   -----------------------------------------------
374
375   function Standalone_Library_Auto_Init_Is_Supported return Boolean is
376   begin
377      return True;
378   end Standalone_Library_Auto_Init_Is_Supported;
379
380   ---------------------------
381   -- Support_For_Libraries --
382   ---------------------------
383
384   function Support_For_Libraries return Library_Support is
385   begin
386      return Full;
387   end Support_For_Libraries;
388
389end MLib.Tgt;
390