1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                    M L I B . T G T . S P E C I F I C                     --
6--                         (Integrity VMS Version)                          --
7--                                                                          --
8--                                 B o d y                                  --
9--                                                                          --
10--          Copyright (C) 2004-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 Integrity 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      begin
179         if Lib_Version = ""
180           or else Symbol_Data.Symbol_Policy /= Autonomous
181         then
182            return "";
183
184         else
185            begin
186               Version := Integer'Value (Lib_Version);
187
188               if Version <= 0 then
189                  raise Constraint_Error;
190               end if;
191
192               return Lib_Version;
193
194            exception
195               when Constraint_Error =>
196                  Fail ("illegal version """
197                        & Lib_Version
198                        & """ (on VMS version must be a positive number)");
199                  return "";
200            end;
201         end if;
202      end Version_String;
203
204      ---------------------
205      -- Local Variables --
206      ---------------------
207
208      Opt_File_Name  : constant String := Option_File_Name;
209      Version        : constant String := Version_String;
210      For_Linker_Opt : String_Access;
211
212   --  Start of processing for Build_Dynamic_Library
213
214   begin
215      --  Option file must end with ".opt"
216
217      if Opt_File_Name'Length > 4
218        and then
219          Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
220      then
221         For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
222      else
223         Fail ("Options File """ & Opt_File_Name & """ must end with .opt");
224      end if;
225
226      VMS_Options (VMS_Options'First) := For_Linker_Opt;
227
228      for J in Inter'Range loop
229         To_Lower (Inter (J).all);
230      end loop;
231
232      --  "gnatsym" is necessary for building the option file
233
234      if Gnatsym_Path = null then
235         Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name);
236
237         if Gnatsym_Path = null then
238            Fail (Gnatsym_Name & " not found in path");
239         end if;
240      end if;
241
242      --  For auto-initialization of a stand-alone library, we create
243      --  a macro-assembly file and we invoke the macro-assembler.
244
245      if Auto_Init then
246         declare
247            Macro_File_Name : constant String := Lib_Filename & "__init.asm";
248            Macro_File      : File_Descriptor;
249            Init_Proc       : constant String := Init_Proc_Name (Lib_Filename);
250            Popen_Result    : System.Address;
251            Pclose_Result   : Integer;
252            Len             : Natural;
253            OK              : Boolean := True;
254
255            command : constant String :=
256                        Macro_Name & " " & Macro_File_Name & ASCII.NUL;
257            --  The command to invoke the assembler on the generated auto-init
258            --  assembly file.
259            --  Why odd lower case name ???
260
261            mode : constant String := "r" & ASCII.NUL;
262            --  The mode for the invocation of Popen
263            --  Why odd lower case name ???
264
265         begin
266            if Verbose_Mode then
267               Write_Str ("Creating auto-init assembly file """);
268               Write_Str (Macro_File_Name);
269               Write_Line ("""");
270            end if;
271
272            --  Create and write the auto-init assembly file
273
274            declare
275               use ASCII;
276
277               --  Output a dummy transfer address for debugging
278               --  followed by the LIB$INITIALIZE section.
279
280               Lines : constant String :=
281                 HT & ".pred.safe_across_calls p1-p5,p16-p63" & LF &
282                 HT & ".text" & LF &
283                 HT & ".align 16" & LF &
284                 HT & ".global __main#" & LF &
285                 HT & ".proc __main#" & LF &
286                      "__main:" & LF &
287                 HT & ".prologue" & LF &
288                 HT & ".body" & LF &
289                 HT & ".mib" & LF &
290                 HT & "nop 0" & LF &
291                 HT & "nop 0" & LF &
292                 HT & "br.ret.sptk.many b0" & LF &
293                 HT & ".endp __main#" & LF & LF &
294                 HT & ".type " & Init_Proc & "#, @function" & LF &
295                 HT & ".global " & Init_Proc & "#" & LF &
296                 HT & ".global LIB$INITIALIZE#" & LF &
297                 HT & ".section LIB$INITIALIZE#,""a"",@progbits" & LF &
298                 HT & "data4 @fptr(" & Init_Proc & "#)" & LF;
299
300            begin
301               Macro_File := Create_File (Macro_File_Name, Text);
302               OK := Macro_File /= Invalid_FD;
303
304               if OK then
305                  Len := Write
306                    (Macro_File, Lines (Lines'First)'Address,
307                     Lines'Length);
308                  OK := Len = Lines'Length;
309               end if;
310
311               if OK then
312                  Close (Macro_File, OK);
313               end if;
314
315               if not OK then
316                  Fail ("creation of auto-init assembly file """
317                        & Macro_File_Name
318                        & """ failed");
319               end if;
320            end;
321
322            --  Invoke the macro-assembler
323
324            if Verbose_Mode then
325               Write_Str ("Assembling auto-init assembly file """);
326               Write_Str (Macro_File_Name);
327               Write_Line ("""");
328            end if;
329
330            Popen_Result := popen (command (command'First)'Address,
331                                   mode (mode'First)'Address);
332
333            if Popen_Result = Null_Address then
334               Fail ("assembly of auto-init assembly file """
335                     & Macro_File_Name
336                     & """ failed");
337            end if;
338
339            --  Wait for the end of execution of the macro-assembler
340
341            Pclose_Result := pclose (Popen_Result);
342
343            if Pclose_Result < 0 then
344               Fail ("assembly of auto init assembly file """
345                     & Macro_File_Name
346                     & """ failed");
347            end if;
348
349            --  Add the generated object file to the list of objects to be
350            --  included in the library.
351
352            Additional_Objects :=
353              new Argument_List'
354                (1 => new String'(Lib_Filename & "__init.obj"));
355         end;
356      end if;
357
358      --  Allocate the argument list and put the symbol file name, the
359      --  reference (if any) and the policy (if not autonomous).
360
361      Arguments := new Argument_List (1 .. Ofiles'Length + 8);
362
363      Last_Argument := 0;
364
365      --  Verbosity
366
367      if Verbose_Mode then
368         Last_Argument := Last_Argument + 1;
369         Arguments (Last_Argument) := new String'("-v");
370      end if;
371
372      --  Version number (major ID)
373
374      if Lib_Version /= "" then
375         Last_Argument := Last_Argument + 1;
376         Arguments (Last_Argument) := new String'("-V");
377         Last_Argument := Last_Argument + 1;
378         Arguments (Last_Argument) := new String'(Version);
379      end if;
380
381      --  Symbol file
382
383      Last_Argument := Last_Argument + 1;
384      Arguments (Last_Argument) := new String'("-s");
385      Last_Argument := Last_Argument + 1;
386      Arguments (Last_Argument) := new String'(Opt_File_Name);
387
388      --  Reference Symbol File
389
390      if Symbol_Data.Reference /= No_Path then
391         Last_Argument := Last_Argument + 1;
392         Arguments (Last_Argument) := new String'("-r");
393         Last_Argument := Last_Argument + 1;
394         Arguments (Last_Argument) :=
395           new String'(Get_Name_String (Symbol_Data.Reference));
396      end if;
397
398      --  Policy
399
400      case Symbol_Data.Symbol_Policy is
401         when Autonomous =>
402            null;
403
404         when Compliant =>
405            Last_Argument := Last_Argument + 1;
406            Arguments (Last_Argument) := new String'("-c");
407
408         when Controlled =>
409            Last_Argument := Last_Argument + 1;
410            Arguments (Last_Argument) := new String'("-C");
411
412         when Restricted =>
413            Last_Argument := Last_Argument + 1;
414            Arguments (Last_Argument) := new String'("-R");
415
416         when Direct =>
417            Last_Argument := Last_Argument + 1;
418            Arguments (Last_Argument) := new String'("-D");
419      end case;
420
421      --  Add each relevant object file
422
423      for Index in Ofiles'Range loop
424         if Is_Interface (Ofiles (Index).all) then
425            Last_Argument := Last_Argument + 1;
426            Arguments (Last_Argument) := new String'(Ofiles (Index).all);
427         end if;
428      end loop;
429
430      --  Spawn gnatsym
431
432      Spawn (Program_Name => Gnatsym_Path.all,
433             Args         => Arguments (1 .. Last_Argument),
434             Success      => Success);
435
436      if not Success then
437         Fail ("unable to create symbol file for library """
438               & Lib_Filename
439               & """");
440      end if;
441
442      Free (Arguments);
443
444      --  Move all the -l switches from Opts to Opts2
445
446      declare
447         Index : Natural := Opts'First;
448         Opt   : String_Access;
449
450      begin
451         while Index <= Last_Opt loop
452            Opt := Opts (Index);
453
454            if Opt'Length > 2 and then
455              Opt (Opt'First .. Opt'First + 1) = "-l"
456            then
457               if Index < Last_Opt then
458                  Opts (Index .. Last_Opt - 1) :=
459                    Opts (Index + 1 .. Last_Opt);
460               end if;
461
462               Last_Opt := Last_Opt - 1;
463
464               Last_Opt2 := Last_Opt2 + 1;
465               Opts2 (Last_Opt2) := Opt;
466
467            else
468               Index := Index + 1;
469            end if;
470         end loop;
471      end;
472
473      --  Invoke gcc to build the library
474
475      Utl.Gcc
476        (Output_File => Lib_File,
477         Objects     => Ofiles & Additional_Objects.all,
478         Options     => VMS_Options,
479         Options_2   => Shared_Libgcc_Switch &
480                        Opts (Opts'First .. Last_Opt) &
481                        Opts2 (Opts2'First .. Last_Opt2),
482         Driver_Name => Driver_Name);
483
484      --  The auto-init object file need to be deleted, so that it will not
485      --  be included in the library as a regular object file, otherwise
486      --  it will be included twice when the library will be built next
487      --  time, which may lead to errors.
488
489      if Auto_Init then
490         declare
491            Auto_Init_Object_File_Name : constant String :=
492                                           Lib_Filename & "__init.obj";
493
494            Disregard : Boolean;
495            pragma Warnings (Off, Disregard);
496
497         begin
498            if Verbose_Mode then
499               Write_Str ("deleting auto-init object file """);
500               Write_Str (Auto_Init_Object_File_Name);
501               Write_Line ("""");
502            end if;
503
504            Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
505         end;
506      end if;
507   end Build_Dynamic_Library;
508
509--  Package initialization
510
511begin
512   Build_Dynamic_Library_Ptr    := Build_Dynamic_Library'Access;
513end MLib.Tgt.Specific;
514