1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 2003, Ada Core Technologies, Inc. --
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. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 -- This package provides a set of target dependent routines to build
29 -- static, dynamic and shared libraries.
31 -- This is the VMS version of the body.
33 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
34 with Ada
.Text_IO
; use Ada
.Text_IO
;
36 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
40 with Namet
; use Namet
;
42 with Output
; use Output
;
44 with System
; use System
;
45 with System
.Case_Util
; use System
.Case_Util
;
47 package body MLib
.Tgt
is
51 Empty_Argument_List
: aliased Argument_List
:= (1 .. 0 => null);
52 Additional_Objects
: Argument_List_Access
:= Empty_Argument_List
'Access;
53 -- Used to add the generated auto-init object files for auto-initializing
54 -- stand-alone libraries.
56 Macro_Name
: constant String := "macro";
57 -- The name of the command to invoke the macro-assembler
59 -- Options to use when invoking gcc to build the dynamic library
61 No_Start_Files
: aliased String := "-nostartfiles";
63 VMS_Options
: Argument_List
:=
64 (No_Start_Files
'Access, null);
66 Gnatsym_Name
: constant String := "gnatsym";
68 Gnatsym_Path
: String_Access
;
70 Arguments
: Argument_List_Access
:= null;
71 Last_Argument
: Natural := 0;
73 Success
: Boolean := False;
75 ------------------------------
76 -- Target dependent section --
77 ------------------------------
79 function Popen
(Command
, Mode
: System
.Address
) return System
.Address
;
80 pragma Import
(C
, Popen
);
82 function Pclose
(File
: System
.Address
) return Integer;
83 pragma Import
(C
, Pclose
);
89 function Archive_Builder
return String is
94 -----------------------------
95 -- Archive_Builder_Options --
96 -----------------------------
98 function Archive_Builder_Options
return String_List_Access
is
100 return new String_List
'(1 => new String'("cr"));
101 end Archive_Builder_Options
;
107 function Archive_Ext
return String is
112 ---------------------
113 -- Archive_Indexer --
114 ---------------------
116 function Archive_Indexer
return String is
121 ---------------------------
122 -- Build_Dynamic_Library --
123 ---------------------------
125 procedure Build_Dynamic_Library
126 (Ofiles
: Argument_List
;
127 Foreign
: Argument_List
;
128 Afiles
: Argument_List
;
129 Options
: Argument_List
;
130 Interfaces
: Argument_List
;
131 Lib_Filename
: String;
133 Symbol_Data
: Symbol_Record
;
134 Driver_Name
: Name_Id
:= No_Name
;
135 Lib_Address
: String := "";
136 Lib_Version
: String := "";
137 Relocatable
: Boolean := False;
138 Auto_Init
: Boolean := False)
140 pragma Unreferenced
(Foreign
);
141 pragma Unreferenced
(Afiles
);
142 pragma Unreferenced
(Lib_Address
);
143 pragma Unreferenced
(Relocatable
);
147 Lib_File
: constant String :=
148 Lib_Dir
& Directory_Separator
& "lib" &
149 Fil
.Ext_To
(Lib_Filename
, DLL_Ext
);
151 Opts
: Argument_List
:= Options
;
152 Last_Opt
: Natural := Opts
'Last;
153 Opts2
: Argument_List
(Options
'Range);
154 Last_Opt2
: Natural := Opts2
'First - 1;
155 Inter
: Argument_List
:= Interfaces
;
157 function Is_Interface
(Obj_File
: String) return Boolean;
158 -- For a Stand-Alone Library, returns True if Obj_File is the object
159 -- file name of an interface of the SAL.
160 -- For other libraries, always return True.
162 function Option_File_Name
return String;
163 -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
165 function Version_String
return String;
166 -- Returns Lib_Version if not empty, otherwise returns "1".
167 -- Fails gnatmake if Lib_Version is not the image of a positive number.
173 function Is_Interface
(Obj_File
: String) return Boolean is
174 ALI
: constant String :=
176 (Filename
=> To_Lower
(Base_Name
(Obj_File
)),
179 if Inter
'Length = 0 then
182 elsif ALI
'Length > 2 and then
183 ALI
(ALI
'First .. ALI
'First + 1) = "b$"
188 for J
in Inter
'Range loop
189 if Inter
(J
).all = ALI
then
198 ----------------------
199 -- Option_File_Name --
200 ----------------------
202 function Option_File_Name
return String is
204 if Symbol_Data
.Symbol_File
= No_Name
then
208 return Get_Name_String
(Symbol_Data
.Symbol_File
);
210 end Option_File_Name
;
216 function Version_String
return String is
217 Version
: Integer := 0;
219 if Lib_Version
= "" then
224 Version
:= Integer'Value (Lib_Version
);
227 raise Constraint_Error
;
233 when Constraint_Error
=>
234 Fail
("illegal version """, Lib_Version
,
235 """ (on VMS version must be a positive number)");
241 Opt_File_Name
: constant String := Option_File_Name
;
242 For_Linker_Opt
: constant String_Access
:=
243 new String'("--for-linker=" & Opt_File_Name);
244 Version : constant String := Version_String;
247 VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
249 for J in Inter'Range loop
250 To_Lower (Inter (J).all);
253 -- "gnatsym" is necessary for building the option file
255 if Gnatsym_Path = null then
256 Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name);
258 if Gnatsym_Path = null then
259 Fail (Gnatsym_Name, " not found in path");
263 -- For auto-initialization of a stand-alone library, we create
264 -- a macro-assembly file and we invoke the macro-assembler.
268 Macro_File_Name : constant String := Lib_Filename & "$init.mar";
269 Macro_File : Ada.Text_IO.File_Type;
270 Init_Proc : String := Lib_Filename & "INIT";
271 Popen_Result : System.Address;
272 Pclose_Result : Integer;
274 Command : constant String :=
275 Macro_Name & " " & Macro_File_Name & ASCII.NUL;
276 -- The command to invoke the macro-assembler on the generated
279 Mode : constant String := "r" & ASCII.NUL;
280 -- The mode for the invocation of Popen
283 To_Upper (Init_Proc);
286 Write_Str ("Creating auto-init assembly file """);
287 Write_Str (Macro_File_Name);
292 Create (Macro_File, Out_File, Macro_File_Name);
294 Put_Line (Macro_File, ASCII.HT & ".EXTRN LIB$INITIALIZE");
295 Put_Line (Macro_File, ASCII.HT & ".EXTRN " & Init_Proc);
298 ASCII.HT & ".PSECT LIB$INITIALIZE USR,GBL,NOEXE,NOWRT,LONG");
299 Put_Line (Macro_File, ASCII.HT & ".ADDRESS " & Init_Proc);
300 Put_Line (Macro_File, ASCII.HT & ".END");
306 Fail ("creation of auto-init assembly file """,
307 Macro_File_Name, """ failed");
310 -- Invoke the macro-assembler
313 Write_Str ("Assembling auto-init assembly file """);
314 Write_Str (Macro_File_Name);
318 Popen_Result := Popen (Command (Command'First)'Address,
319 Mode (Mode'First)'Address);
321 if Popen_Result = Null_Address then
322 Fail ("assembly of auto-init assembly file """,
323 Macro_File_Name, """ failed");
326 -- Wait for the end of execution of the macro-assembler
328 Pclose_Result := Pclose (Popen_Result);
330 if Pclose_Result < 0 then
331 Fail ("assembly of auto init assembly file """,
332 Macro_File_Name, """ failed");
335 -- Add the generated object file to the list of objects to be
336 -- included in the library.
338 Additional_Objects :=
340 (1 => new String'(Lib_Filename & "$init.obj"));
344 -- Allocate the argument list and put the symbol file name, the
345 -- reference (if any) and the policy (if not autonomous).
347 Arguments := new Argument_List (1 .. Ofiles'Length + 8);
354 Last_Argument := Last_Argument + 1;
355 Arguments (Last_Argument) := new String'("-v");
358 -- Version number (major ID)
360 if Lib_Version
/= "" then
361 Last_Argument
:= Last_Argument
+ 1;
362 Arguments
(Last_Argument
) := new String'("-V");
363 Last_Argument := Last_Argument + 1;
364 Arguments (Last_Argument) := new String'(Version
);
369 Last_Argument
:= Last_Argument
+ 1;
370 Arguments
(Last_Argument
) := new String'("-s");
371 Last_Argument := Last_Argument + 1;
372 Arguments (Last_Argument) := new String'(Opt_File_Name
);
374 -- Reference Symbol File
376 if Symbol_Data
.Reference
/= No_Name
then
377 Last_Argument
:= Last_Argument
+ 1;
378 Arguments
(Last_Argument
) := new String'("-r");
379 Last_Argument := Last_Argument + 1;
380 Arguments (Last_Argument) :=
381 new String'(Get_Name_String
(Symbol_Data
.Reference
));
386 case Symbol_Data
.Symbol_Policy
is
391 Last_Argument
:= Last_Argument
+ 1;
392 Arguments
(Last_Argument
) := new String'("-c");
395 Last_Argument := Last_Argument + 1;
396 Arguments (Last_Argument) := new String'("-C");
399 -- Add each relevant object file
401 for Index
in Ofiles
'Range loop
402 if Is_Interface
(Ofiles
(Index
).all) then
403 Last_Argument
:= Last_Argument
+ 1;
404 Arguments
(Last_Argument
) := new String'(Ofiles (Index).all);
410 Spawn (Program_Name => Gnatsym_Path.all,
411 Args => Arguments (1 .. Last_Argument),
415 Fail ("unable to create symbol file for library """,
421 -- Move all the -l switches from Opts to Opts2
424 Index : Natural := Opts'First;
427 while Index <= Last_Opt loop
430 if Opt'Length > 2 and then
431 Opt (Opt'First .. Opt'First + 1) = "-l"
433 if Index < Last_Opt then
434 Opts (Index .. Last_Opt - 1) :=
435 Opts (Index + 1 .. Last_Opt);
438 Last_Opt := Last_Opt - 1;
440 Last_Opt2 := Last_Opt2 + 1;
441 Opts2 (Last_Opt2) := Opt;
449 -- Invoke gcc to build the library
452 (Output_File => Lib_File,
453 Objects => Ofiles & Additional_Objects.all,
454 Options => VMS_Options,
455 Options_2 => Opts (Opts'First .. Last_Opt) &
456 Opts2 (Opts2'First .. Last_Opt2),
457 Driver_Name => Driver_Name);
459 -- The auto-init object file need to be deleted, so that it will not
460 -- be included in the library as a regular object file, otherwise
461 -- it will be included twice when the library will be built next
462 -- time, which may lead to errors.
466 Auto_Init_Object_File_Name : constant String :=
467 Lib_Filename & "$init.obj";
472 Write_Str ("deleting auto-init object file """);
473 Write_Str (Auto_Init_Object_File_Name);
477 Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
480 end Build_Dynamic_Library;
482 -------------------------
483 -- Default_DLL_Address --
484 -------------------------
486 function Default_DLL_Address return String is
489 end Default_DLL_Address;
495 function DLL_Ext return String is
504 function Dynamic_Option return String is
513 function Is_Object_Ext (Ext : String) return Boolean is
522 function Is_C_Ext (Ext : String) return Boolean is
531 function Is_Archive_Ext (Ext : String) return Boolean is
533 return Ext = ".olb" or else Ext = ".exe";
540 function Libgnat return String is
541 Libgnat_A : constant String := "libgnat.a";
542 Libgnat_Olb : constant String := "libgnat.olb";
545 Name_Len := Libgnat_A'Length;
546 Name_Buffer (1 .. Name_Len) := Libgnat_A;
548 if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then
556 ------------------------
557 -- Library_Exists_For --
558 ------------------------
560 function Library_Exists_For (Project : Project_Id) return Boolean is
562 if not Projects.Table (Project).Library then
563 Fail ("INTERNAL ERROR: Library_Exists_For called " &
564 "for non library project");
569 Lib_Dir : constant String :=
570 Get_Name_String (Projects.Table (Project).Library_Dir);
571 Lib_Name : constant String :=
572 Get_Name_String (Projects.Table (Project).Library_Name);
575 if Projects.Table (Project).Library_Kind = Static then
576 return Is_Regular_File
577 (Lib_Dir & Directory_Separator & "lib" &
578 Fil.Ext_To (Lib_Name, Archive_Ext));
581 return Is_Regular_File
582 (Lib_Dir & Directory_Separator & "lib" &
583 Fil.Ext_To (Lib_Name, DLL_Ext));
587 end Library_Exists_For;
589 ---------------------------
590 -- Library_File_Name_For --
591 ---------------------------
593 function Library_File_Name_For (Project : Project_Id) return Name_Id is
595 if not Projects.Table (Project).Library then
596 Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
597 "for non library project");
602 Lib_Name : constant String :=
603 Get_Name_String (Projects.Table (Project).Library_Name);
607 Name_Buffer (1 .. Name_Len) := "lib";
609 if Projects.Table (Project).Library_Kind = Static then
610 Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
613 Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
619 end Library_File_Name_For;
621 --------------------------------
622 -- Linker_Library_Path_Option --
623 --------------------------------
625 function Linker_Library_Path_Option return String_Access is
628 end Linker_Library_Path_Option;
634 function Object_Ext return String is
643 function PIC_Option return String is
648 -----------------------------------------------
649 -- Standalone_Library_Auto_Init_Is_Supported --
650 -----------------------------------------------
652 function Standalone_Library_Auto_Init_Is_Supported return Boolean is
655 end Standalone_Library_Auto_Init_Is_Supported;
657 ---------------------------
658 -- Support_For_Libraries --
659 ---------------------------
661 function Support_For_Libraries return Library_Support is
664 end Support_For_Libraries;