1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                    M L I B . T G T . S P E C I F I C                     --
6--                           (Alpha VMS Version)                            --
7--                                                                          --
8--                                 B o d y                                  --
9--                                                                          --
10--          Copyright (C) 2003-2011, 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 3,  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 COPYING3.  If not, go to --
20-- http://www.gnu.org/licenses for a complete copy of the license.          --
21--                                                                          --
22-- GNAT was originally developed  by the GNAT team at  New York University. --
23-- Extensive contributions were provided by Ada Core Technologies Inc.      --
24--                                                                          --
25------------------------------------------------------------------------------
26
27--  This is the Alpha VMS version of the body
28
29with Ada.Characters.Handling; use Ada.Characters.Handling;
30
31with MLib.Fil;
32with MLib.Utl;
33
34with MLib.Tgt.VMS_Common; use MLib.Tgt.VMS_Common;
35
36with Opt;      use Opt;
37with Output;   use Output;
38
39with GNAT.Directory_Operations; use GNAT.Directory_Operations;
40
41with System;           use System;
42with System.Case_Util; use System.Case_Util;
43with System.CRTL;      use System.CRTL;
44
45package body MLib.Tgt.Specific is
46
47   --  Non default subprogram. See comment in mlib-tgt.ads
48
49   procedure Build_Dynamic_Library
50     (Ofiles       : Argument_List;
51      Options      : Argument_List;
52      Interfaces   : Argument_List;
53      Lib_Filename : String;
54      Lib_Dir      : String;
55      Symbol_Data  : Symbol_Record;
56      Driver_Name  : Name_Id := No_Name;
57      Lib_Version  : String  := "";
58      Auto_Init    : Boolean := False);
59
60   --  Local variables
61
62   Empty_Argument_List : aliased Argument_List := (1 .. 0 => null);
63   Additional_Objects  : Argument_List_Access := Empty_Argument_List'Access;
64   --  Used to add the generated auto-init object files for auto-initializing
65   --  stand-alone libraries.
66
67   Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler";
68   --  The name of the command to invoke the macro-assembler
69
70   VMS_Options : Argument_List := (1 .. 1 => null);
71
72   Gnatsym_Name : constant String := "gnatsym";
73
74   Gnatsym_Path : String_Access;
75
76   Arguments : Argument_List_Access := null;
77   Last_Argument : Natural := 0;
78
79   Success : Boolean := False;
80
81   Shared_Libgcc : aliased String := "-shared-libgcc";
82
83   Shared_Libgcc_Switch : constant Argument_List :=
84                            (1 => Shared_Libgcc'Access);
85
86   ---------------------------
87   -- Build_Dynamic_Library --
88   ---------------------------
89
90   procedure Build_Dynamic_Library
91     (Ofiles       : Argument_List;
92      Options      : Argument_List;
93      Interfaces   : Argument_List;
94      Lib_Filename : String;
95      Lib_Dir      : String;
96      Symbol_Data  : Symbol_Record;
97      Driver_Name  : Name_Id := No_Name;
98      Lib_Version  : String  := "";
99      Auto_Init    : Boolean := False)
100   is
101
102      Lib_File : constant String :=
103                   Lib_Dir & Directory_Separator & "lib" &
104                   Fil.Ext_To (Lib_Filename, DLL_Ext);
105
106      Opts      : Argument_List := Options;
107      Last_Opt  : Natural       := Opts'Last;
108      Opts2     : Argument_List (Options'Range);
109      Last_Opt2 : Natural       := Opts2'First - 1;
110
111      Inter : constant Argument_List := Interfaces;
112
113      function Is_Interface (Obj_File : String) return Boolean;
114      --  For a Stand-Alone Library, returns True if Obj_File is the object
115      --  file name of an interface of the SAL. For other libraries, always
116      --  return True.
117
118      function Option_File_Name return String;
119      --  Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
120
121      function Version_String return String;
122      --  Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is
123      --  not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy
124      --  is Autonomous, fails gnatmake if Lib_Version is not the image of a
125      --  positive number.
126
127      ------------------
128      -- Is_Interface --
129      ------------------
130
131      function Is_Interface (Obj_File : String) return Boolean is
132         ALI : constant String :=
133                 Fil.Ext_To
134                  (Filename => To_Lower (Base_Name (Obj_File)),
135                   New_Ext  => "ali");
136
137      begin
138         if Inter'Length = 0 then
139            return True;
140
141         elsif ALI'Length > 2 and then
142               ALI (ALI'First .. ALI'First + 2) = "b__"
143         then
144            return True;
145
146         else
147            for J in Inter'Range loop
148               if Inter (J).all = ALI then
149                  return True;
150               end if;
151            end loop;
152
153            return False;
154         end if;
155      end Is_Interface;
156
157      ----------------------
158      -- Option_File_Name --
159      ----------------------
160
161      function Option_File_Name return String is
162      begin
163         if Symbol_Data.Symbol_File = No_Path then
164            return "symvec.opt";
165         else
166            Get_Name_String (Symbol_Data.Symbol_File);
167            To_Lower (Name_Buffer (1 .. Name_Len));
168            return Name_Buffer (1 .. Name_Len);
169         end if;
170      end Option_File_Name;
171
172      --------------------
173      -- Version_String --
174      --------------------
175
176      function Version_String return String is
177         Version : Integer := 0;
178
179      begin
180         if Lib_Version = ""
181           or else Symbol_Data.Symbol_Policy /= Autonomous
182         then
183            return "";
184
185         else
186            begin
187               Version := Integer'Value (Lib_Version);
188
189               if Version <= 0 then
190                  raise Constraint_Error;
191               end if;
192
193               return Lib_Version;
194
195            exception
196               when Constraint_Error =>
197                  Fail ("illegal version """
198                        & Lib_Version
199                        & """ (on VMS version must be a positive number)");
200                  return "";
201            end;
202         end if;
203      end Version_String;
204
205      ---------------------
206      -- Local Variables --
207      ---------------------
208
209      Opt_File_Name  : constant String := Option_File_Name;
210      Version        : constant String := Version_String;
211      For_Linker_Opt : String_Access;
212
213   --  Start of processing for Build_Dynamic_Library
214
215   begin
216      --  If option file name does not ends with ".opt", append "/OPTIONS"
217      --  to its specification for the VMS linker.
218
219      if Opt_File_Name'Length > 4
220        and then
221          Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
222      then
223         For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
224      else
225         For_Linker_Opt :=
226           new String'("--for-linker=" & Opt_File_Name & "/OPTIONS");
227      end if;
228
229      VMS_Options (VMS_Options'First) := For_Linker_Opt;
230
231      for J in Inter'Range loop
232         To_Lower (Inter (J).all);
233      end loop;
234
235      --  "gnatsym" is necessary for building the option file
236
237      if Gnatsym_Path = null then
238         Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name);
239
240         if Gnatsym_Path = null then
241            Fail (Gnatsym_Name & " not found in path");
242         end if;
243      end if;
244
245      --  For auto-initialization of a stand-alone library, we create
246      --  a macro-assembly file and we invoke the macro-assembler.
247
248      if Auto_Init then
249         declare
250            Macro_File_Name : constant String := Lib_Filename & "__init.asm";
251            Macro_File      : File_Descriptor;
252            Init_Proc       : constant String := Init_Proc_Name (Lib_Filename);
253            Popen_Result    : System.Address;
254            Pclose_Result   : Integer;
255            Len             : Natural;
256            OK              : Boolean := True;
257
258            command  : constant String :=
259                         Macro_Name & " " & Macro_File_Name & ASCII.NUL;
260            --  The command to invoke the assembler on the generated auto-init
261            --  assembly file.
262
263            mode : constant String := "r" & ASCII.NUL;
264            --  The mode for the invocation of Popen
265
266         begin
267            if Verbose_Mode then
268               Write_Str ("Creating auto-init assembly file """);
269               Write_Str (Macro_File_Name);
270               Write_Line ("""");
271            end if;
272
273            --  Create and write the auto-init assembly file
274
275            declare
276               use ASCII;
277
278               --  Output a dummy transfer address for debugging
279               --  followed by the LIB$INITIALIZE section.
280
281               Lines : constant String :=
282                 HT & ".text" & LF &
283                 HT & ".align 4" & LF &
284                 HT & ".globl __main" & LF &
285                 HT & ".ent __main" & LF &
286                 "__main..en:" & LF &
287                 HT & ".base $27" & LF &
288                 HT & ".frame $29,0,$26,8" & LF &
289                 HT & "ret $31,($26),1" & LF &
290                 HT & ".link" & LF &
291                 "__main:" & LF &
292                 HT & ".pdesc __main..en,null" & LF &
293                 HT & ".end __main" & LF & LF &
294                 HT & ".section LIB$INITIALIZE,GBL,NOWRT" & LF &
295                 HT & ".long " & Init_Proc & LF;
296
297            begin
298               Macro_File := Create_File (Macro_File_Name, Text);
299               OK := Macro_File /= Invalid_FD;
300
301               if OK then
302                  Len := Write
303                    (Macro_File, Lines (Lines'First)'Address,
304                     Lines'Length);
305                  OK := Len = Lines'Length;
306               end if;
307
308               if OK then
309                  Close (Macro_File, OK);
310               end if;
311
312               if not OK then
313                  Fail ("creation of auto-init assembly file """
314                        & Macro_File_Name
315                        & """ failed");
316               end if;
317            end;
318
319            --  Invoke the macro-assembler
320
321            if Verbose_Mode then
322               Write_Str ("Assembling auto-init assembly file """);
323               Write_Str (Macro_File_Name);
324               Write_Line ("""");
325            end if;
326
327            Popen_Result := popen (command (command'First)'Address,
328                                   mode (mode'First)'Address);
329
330            if Popen_Result = Null_Address then
331               Fail ("assembly of auto-init assembly file """
332                     & Macro_File_Name
333                     & """ failed");
334            end if;
335
336            --  Wait for the end of execution of the macro-assembler
337
338            Pclose_Result := pclose (Popen_Result);
339
340            if Pclose_Result < 0 then
341               Fail ("assembly of auto init assembly file """
342                     & Macro_File_Name
343                     & """ failed");
344            end if;
345
346            --  Add the generated object file to the list of objects to be
347            --  included in the library.
348
349            Additional_Objects :=
350              new Argument_List'
351                (1 => new String'(Lib_Filename & "__init.obj"));
352         end;
353      end if;
354
355      --  Allocate the argument list and put the symbol file name, the
356      --  reference (if any) and the policy (if not autonomous).
357
358      Arguments := new Argument_List (1 .. Ofiles'Length + 8);
359
360      Last_Argument := 0;
361
362      --  Verbosity
363
364      if Verbose_Mode then
365         Last_Argument := Last_Argument + 1;
366         Arguments (Last_Argument) := new String'("-v");
367      end if;
368
369      --  Version number (major ID)
370
371      if Lib_Version /= "" then
372         Last_Argument := Last_Argument + 1;
373         Arguments (Last_Argument) := new String'("-V");
374         Last_Argument := Last_Argument + 1;
375         Arguments (Last_Argument) := new String'(Version);
376      end if;
377
378      --  Symbol file
379
380      Last_Argument := Last_Argument + 1;
381      Arguments (Last_Argument) := new String'("-s");
382      Last_Argument := Last_Argument + 1;
383      Arguments (Last_Argument) := new String'(Opt_File_Name);
384
385      --  Reference Symbol File
386
387      if Symbol_Data.Reference /= No_Path then
388         Last_Argument := Last_Argument + 1;
389         Arguments (Last_Argument) := new String'("-r");
390         Last_Argument := Last_Argument + 1;
391         Arguments (Last_Argument) :=
392           new String'(Get_Name_String (Symbol_Data.Reference));
393      end if;
394
395      --  Policy
396
397      case Symbol_Data.Symbol_Policy is
398         when Autonomous =>
399            null;
400
401         when Compliant =>
402            Last_Argument := Last_Argument + 1;
403            Arguments (Last_Argument) := new String'("-c");
404
405         when Controlled =>
406            Last_Argument := Last_Argument + 1;
407            Arguments (Last_Argument) := new String'("-C");
408
409         when Restricted =>
410            Last_Argument := Last_Argument + 1;
411            Arguments (Last_Argument) := new String'("-R");
412
413         when Direct =>
414            Last_Argument := Last_Argument + 1;
415            Arguments (Last_Argument) := new String'("-D");
416
417      end case;
418
419      --  Add each relevant object file
420
421      for Index in Ofiles'Range loop
422         if Is_Interface (Ofiles (Index).all) then
423            Last_Argument := Last_Argument + 1;
424            Arguments (Last_Argument) := new String'(Ofiles (Index).all);
425         end if;
426      end loop;
427
428      --  Spawn gnatsym
429
430      Spawn (Program_Name => Gnatsym_Path.all,
431             Args         => Arguments (1 .. Last_Argument),
432             Success      => Success);
433
434      if not Success then
435         Fail ("unable to create symbol file for library """
436               & Lib_Filename
437               & """");
438      end if;
439
440      Free (Arguments);
441
442      --  Move all the -l switches from Opts to Opts2
443
444      declare
445         Index : Natural := Opts'First;
446         Opt   : String_Access;
447
448      begin
449         while Index <= Last_Opt loop
450            Opt := Opts (Index);
451
452            if Opt'Length > 2 and then
453              Opt (Opt'First .. Opt'First + 1) = "-l"
454            then
455               if Index < Last_Opt then
456                  Opts (Index .. Last_Opt - 1) :=
457                    Opts (Index + 1 .. Last_Opt);
458               end if;
459
460               Last_Opt := Last_Opt - 1;
461
462               Last_Opt2 := Last_Opt2 + 1;
463               Opts2 (Last_Opt2) := Opt;
464
465            else
466               Index := Index + 1;
467            end if;
468         end loop;
469      end;
470
471      --  Invoke gcc to build the library
472
473      Utl.Gcc
474        (Output_File => Lib_File,
475         Objects     => Ofiles & Additional_Objects.all,
476         Options     => VMS_Options,
477         Options_2   => Shared_Libgcc_Switch &
478                        Opts (Opts'First .. Last_Opt) &
479                        Opts2 (Opts2'First .. Last_Opt2),
480         Driver_Name => Driver_Name);
481
482      --  The auto-init object file need to be deleted, so that it will not
483      --  be included in the library as a regular object file, otherwise
484      --  it will be included twice when the library will be built next
485      --  time, which may lead to errors.
486
487      if Auto_Init then
488         declare
489            Auto_Init_Object_File_Name : constant String :=
490                                           Lib_Filename & "__init.obj";
491            Disregard : Boolean;
492
493         begin
494            if Verbose_Mode then
495               Write_Str ("deleting auto-init object file """);
496               Write_Str (Auto_Init_Object_File_Name);
497               Write_Line ("""");
498            end if;
499
500            Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
501         end;
502      end if;
503   end Build_Dynamic_Library;
504
505--  Package initialization
506
507begin
508   Build_Dynamic_Library_Ptr    := Build_Dynamic_Library'Access;
509end MLib.Tgt.Specific;
510