1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
6 -- (Integrity VMS Version) --
10 -- Copyright (C) 2004-2005 Free Software Foundation, 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 is the Integrity VMS version of the body
30 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
32 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
33 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
37 with Namet
; use Namet
;
39 with Output
; use Output
;
41 with System
; use System
;
42 with System
.Case_Util
; use System
.Case_Util
;
44 package body MLib
.Tgt
is
48 Empty_Argument_List
: aliased Argument_List
:= (1 .. 0 => null);
49 Additional_Objects
: Argument_List_Access
:= Empty_Argument_List
'Access;
50 -- Used to add the generated auto-init object files for auto-initializing
51 -- stand-alone libraries.
53 Macro_Name
: constant String := "mcr gnu:[bin]gcc -c -x assembler";
54 -- The name of the command to invoke the macro-assembler
56 VMS_Options
: Argument_List
:= (1 .. 1 => null);
58 Gnatsym_Name
: constant String := "gnatsym";
60 Gnatsym_Path
: String_Access
;
62 Arguments
: Argument_List_Access
:= null;
63 Last_Argument
: Natural := 0;
65 Success
: Boolean := False;
67 Shared_Libgcc
: aliased String := "-shared-libgcc";
69 No_Shared_Libgcc_Switch
: aliased Argument_List
:= (1 .. 0 => null);
70 Shared_Libgcc_Switch
: aliased Argument_List
:=
71 (1 => Shared_Libgcc
'Access);
72 Link_With_Shared_Libgcc
: Argument_List_Access
:=
73 No_Shared_Libgcc_Switch
'Access;
75 ------------------------------
76 -- Target dependent section --
77 ------------------------------
79 function Popen
(Command
, Mode
: System
.Address
) return System
.Address
;
80 pragma Import
(C
, Popen
, "decc$popen");
82 function Pclose
(File
: System
.Address
) return Integer;
83 pragma Import
(C
, Pclose
, "decc$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 -- Archive_Indexer_Options --
123 -----------------------------
125 function Archive_Indexer_Options
return String_List_Access
is
127 return new String_List
(1 .. 0);
128 end Archive_Indexer_Options
;
130 ---------------------------
131 -- Build_Dynamic_Library --
132 ---------------------------
134 procedure Build_Dynamic_Library
135 (Ofiles
: Argument_List
;
136 Foreign
: Argument_List
;
137 Afiles
: Argument_List
;
138 Options
: Argument_List
;
139 Options_2
: Argument_List
;
140 Interfaces
: Argument_List
;
141 Lib_Filename
: String;
143 Symbol_Data
: Symbol_Record
;
144 Driver_Name
: Name_Id
:= No_Name
;
145 Lib_Version
: String := "";
146 Auto_Init
: Boolean := False)
148 pragma Unreferenced
(Foreign
);
149 pragma Unreferenced
(Afiles
);
151 Lib_File
: constant String :=
152 Lib_Dir
& Directory_Separator
& "lib" &
153 Fil
.Ext_To
(Lib_Filename
, DLL_Ext
);
155 Opts
: Argument_List
:= Options
;
156 Last_Opt
: Natural := Opts
'Last;
157 Opts2
: Argument_List
(Options
'Range);
158 Last_Opt2
: Natural := Opts2
'First - 1;
160 Inter
: constant Argument_List
:= Interfaces
;
162 function Is_Interface
(Obj_File
: String) return Boolean;
163 -- For a Stand-Alone Library, returns True if Obj_File is the object
164 -- file name of an interface of the SAL. For other libraries, always
167 function Option_File_Name
return String;
168 -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
170 function Version_String
return String;
171 -- Returns Lib_Version if not empty, otherwise returns "1".
172 -- Fails gnatmake if Lib_Version is not the image of a positive number.
178 function Is_Interface
(Obj_File
: String) return Boolean is
179 ALI
: constant String :=
181 (Filename
=> To_Lower
(Base_Name
(Obj_File
)),
185 if Inter
'Length = 0 then
188 elsif ALI
'Length > 2 and then
189 ALI
(ALI
'First .. ALI
'First + 1) = "b$"
194 for J
in Inter
'Range loop
195 if Inter
(J
).all = ALI
then
204 ----------------------
205 -- Option_File_Name --
206 ----------------------
208 function Option_File_Name
return String is
210 if Symbol_Data
.Symbol_File
= No_Name
then
213 Get_Name_String
(Symbol_Data
.Symbol_File
);
214 To_Lower
(Name_Buffer
(1 .. Name_Len
));
215 return Name_Buffer
(1 .. Name_Len
);
217 end Option_File_Name
;
223 function Version_String
return String is
224 Version
: Integer := 0;
226 if Lib_Version
= "" then
231 Version
:= Integer'Value (Lib_Version
);
234 raise Constraint_Error
;
240 when Constraint_Error
=>
241 Fail
("illegal version """, Lib_Version
,
242 """ (on VMS version must be a positive number)");
248 Opt_File_Name
: constant String := Option_File_Name
;
249 Version
: constant String := Version_String
;
250 For_Linker_Opt
: String_Access
;
252 -- Start of processing for Build_Dynamic_Library
255 -- Invoke gcc with -shared-libgcc, but only for GCC 3 or higher
257 if GCC_Version
>= 3 then
258 Link_With_Shared_Libgcc
:= Shared_Libgcc_Switch
'Access;
260 Link_With_Shared_Libgcc
:= No_Shared_Libgcc_Switch
'Access;
263 -- Option file must end with ".opt"
265 if Opt_File_Name
'Length > 4
267 Opt_File_Name
(Opt_File_Name
'Last - 3 .. Opt_File_Name
'Last) = ".opt"
269 For_Linker_Opt
:= new String'("--for-linker=" & Opt_File_Name);
271 Fail ("Options File """, Opt_File_Name, """ must end with .opt");
274 VMS_Options (VMS_Options'First) := For_Linker_Opt;
276 for J in Inter'Range loop
277 To_Lower (Inter (J).all);
280 -- "gnatsym" is necessary for building the option file
282 if Gnatsym_Path = null then
283 Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name);
285 if Gnatsym_Path = null then
286 Fail (Gnatsym_Name, " not found in path");
290 -- For auto-initialization of a stand-alone library, we create
291 -- a macro-assembly file and we invoke the macro-assembler.
295 Macro_File_Name : constant String := Lib_Filename & "$init.asm";
296 Macro_File : File_Descriptor;
297 Init_Proc : String := Lib_Filename & "INIT";
298 Popen_Result : System.Address;
299 Pclose_Result : Integer;
301 OK : Boolean := True;
303 Command : constant String :=
304 Macro_Name & " " & Macro_File_Name & ASCII.NUL;
305 -- The command to invoke the assembler on the generated auto-init
308 Mode : constant String := "r" & ASCII.NUL;
309 -- The mode for the invocation of Popen
312 To_Upper (Init_Proc);
315 Write_Str ("Creating auto-init assembly file """);
316 Write_Str (Macro_File_Name);
320 -- Create and write the auto-init assembly file
323 First_Line : constant String :=
325 ".type " & Init_Proc & "#, @function" &
327 Second_Line : constant String :=
329 ".global " & Init_Proc & "#" &
331 Third_Line : constant String :=
333 ".global LIB$INITIALIZE#" &
335 Fourth_Line : constant String :=
337 ".section LIB$INITIALIZE#,""a"",@progbits" &
339 Fifth_Line : constant String :=
341 "data4 @fptr(" & Init_Proc & "#)" &
345 Macro_File := Create_File (Macro_File_Name, Text);
346 OK := Macro_File /= Invalid_FD;
350 (Macro_File, First_Line (First_Line'First)'Address,
352 OK := Len = First_Line'Length;
357 (Macro_File, Second_Line (Second_Line'First)'Address,
359 OK := Len = Second_Line'Length;
364 (Macro_File, Third_Line (Third_Line'First)'Address,
366 OK := Len = Third_Line'Length;
371 (Macro_File, Fourth_Line (Fourth_Line'First)'Address,
373 OK := Len = Fourth_Line'Length;
378 (Macro_File, Fifth_Line (Fifth_Line'First)'Address,
380 OK := Len = Fifth_Line'Length;
384 Close (Macro_File, OK);
388 Fail ("creation of auto-init assembly file """,
389 Macro_File_Name, """ failed");
393 -- Invoke the macro-assembler
396 Write_Str ("Assembling auto-init assembly file """);
397 Write_Str (Macro_File_Name);
401 Popen_Result := Popen (Command (Command'First)'Address,
402 Mode (Mode'First)'Address);
404 if Popen_Result = Null_Address then
405 Fail ("assembly of auto-init assembly file """,
406 Macro_File_Name, """ failed");
409 -- Wait for the end of execution of the macro-assembler
411 Pclose_Result := Pclose (Popen_Result);
413 if Pclose_Result < 0 then
414 Fail ("assembly of auto init assembly file """,
415 Macro_File_Name, """ failed");
418 -- Add the generated object file to the list of objects to be
419 -- included in the library.
421 Additional_Objects :=
423 (1 => new String'(Lib_Filename & "$init.obj"));
427 -- Allocate the argument list and put the symbol file name, the
428 -- reference (if any) and the policy (if not autonomous).
430 Arguments := new Argument_List (1 .. Ofiles'Length + 8);
437 Last_Argument := Last_Argument + 1;
438 Arguments (Last_Argument) := new String'("-v");
441 -- Version number (major ID)
443 if Lib_Version
/= "" then
444 Last_Argument
:= Last_Argument
+ 1;
445 Arguments
(Last_Argument
) := new String'("-V");
446 Last_Argument := Last_Argument + 1;
447 Arguments (Last_Argument) := new String'(Version
);
452 Last_Argument
:= Last_Argument
+ 1;
453 Arguments
(Last_Argument
) := new String'("-s");
454 Last_Argument := Last_Argument + 1;
455 Arguments (Last_Argument) := new String'(Opt_File_Name
);
457 -- Reference Symbol File
459 if Symbol_Data
.Reference
/= No_Name
then
460 Last_Argument
:= Last_Argument
+ 1;
461 Arguments
(Last_Argument
) := new String'("-r");
462 Last_Argument := Last_Argument + 1;
463 Arguments (Last_Argument) :=
464 new String'(Get_Name_String
(Symbol_Data
.Reference
));
469 case Symbol_Data
.Symbol_Policy
is
474 Last_Argument
:= Last_Argument
+ 1;
475 Arguments
(Last_Argument
) := new String'("-c");
478 Last_Argument := Last_Argument + 1;
479 Arguments (Last_Argument) := new String'("-C");
482 Last_Argument
:= Last_Argument
+ 1;
483 Arguments
(Last_Argument
) := new String'("-R");
486 -- Add each relevant object file
488 for Index in Ofiles'Range loop
489 if Is_Interface (Ofiles (Index).all) then
490 Last_Argument := Last_Argument + 1;
491 Arguments (Last_Argument) := new String'(Ofiles
(Index
).all);
497 Spawn
(Program_Name
=> Gnatsym_Path
.all,
498 Args
=> Arguments
(1 .. Last_Argument
),
502 Fail
("unable to create symbol file for library """,
508 -- Move all the -l switches from Opts to Opts2
511 Index
: Natural := Opts
'First;
515 while Index
<= Last_Opt
loop
518 if Opt
'Length > 2 and then
519 Opt
(Opt
'First .. Opt
'First + 1) = "-l"
521 if Index
< Last_Opt
then
522 Opts
(Index
.. Last_Opt
- 1) :=
523 Opts
(Index
+ 1 .. Last_Opt
);
526 Last_Opt
:= Last_Opt
- 1;
528 Last_Opt2
:= Last_Opt2
+ 1;
529 Opts2
(Last_Opt2
) := Opt
;
537 -- Invoke gcc to build the library
540 (Output_File
=> Lib_File
,
541 Objects
=> Ofiles
& Additional_Objects
.all,
542 Options
=> VMS_Options
,
543 Options_2
=> Link_With_Shared_Libgcc
.all &
544 Opts
(Opts
'First .. Last_Opt
) &
545 Opts2
(Opts2
'First .. Last_Opt2
) & Options_2
,
546 Driver_Name
=> Driver_Name
);
548 -- The auto-init object file need to be deleted, so that it will not
549 -- be included in the library as a regular object file, otherwise
550 -- it will be included twice when the library will be built next
551 -- time, which may lead to errors.
555 Auto_Init_Object_File_Name
: constant String :=
556 Lib_Filename
& "$init.obj";
561 Write_Str
("deleting auto-init object file """);
562 Write_Str
(Auto_Init_Object_File_Name
);
566 Delete_File
(Auto_Init_Object_File_Name
, Success
=> Disregard
);
569 end Build_Dynamic_Library
;
575 function DLL_Ext
return String is
584 function Dynamic_Option
return String is
593 function Is_Object_Ext
(Ext
: String) return Boolean is
602 function Is_C_Ext
(Ext
: String) return Boolean is
611 function Is_Archive_Ext
(Ext
: String) return Boolean is
613 return Ext
= ".olb" or else Ext
= ".exe";
620 function Libgnat
return String is
621 Libgnat_A
: constant String := "libgnat.a";
622 Libgnat_Olb
: constant String := "libgnat.olb";
625 Name_Len
:= Libgnat_A
'Length;
626 Name_Buffer
(1 .. Name_Len
) := Libgnat_A
;
628 if Osint
.Find_File
(Name_Enter
, Osint
.Library
) /= No_File
then
636 ------------------------
637 -- Library_Exists_For --
638 ------------------------
640 function Library_Exists_For
(Project
: Project_Id
) return Boolean is
642 if not Projects
.Table
(Project
).Library
then
643 Fail
("INTERNAL ERROR: Library_Exists_For called " &
644 "for non library project");
649 Lib_Dir
: constant String :=
650 Get_Name_String
(Projects
.Table
(Project
).Library_Dir
);
651 Lib_Name
: constant String :=
652 Get_Name_String
(Projects
.Table
(Project
).Library_Name
);
655 if Projects
.Table
(Project
).Library_Kind
= Static
then
656 return Is_Regular_File
657 (Lib_Dir
& Directory_Separator
& "lib" &
658 Fil
.Ext_To
(Lib_Name
, Archive_Ext
));
661 return Is_Regular_File
662 (Lib_Dir
& Directory_Separator
& "lib" &
663 Fil
.Ext_To
(Lib_Name
, DLL_Ext
));
667 end Library_Exists_For
;
669 ---------------------------
670 -- Library_File_Name_For --
671 ---------------------------
673 function Library_File_Name_For
(Project
: Project_Id
) return Name_Id
is
675 if not Projects
.Table
(Project
).Library
then
676 Prj
.Com
.Fail
("INTERNAL ERROR: Library_File_Name_For called " &
677 "for non library project");
682 Lib_Name
: constant String :=
683 Get_Name_String
(Projects
.Table
(Project
).Library_Name
);
687 Name_Buffer
(1 .. Name_Len
) := "lib";
689 if Projects
.Table
(Project
).Library_Kind
= Static
then
690 Add_Str_To_Name_Buffer
(Fil
.Ext_To
(Lib_Name
, Archive_Ext
));
693 Add_Str_To_Name_Buffer
(Fil
.Ext_To
(Lib_Name
, DLL_Ext
));
699 end Library_File_Name_For
;
705 function Object_Ext
return String is
714 function PIC_Option
return String is
719 -----------------------------------------------
720 -- Standalone_Library_Auto_Init_Is_Supported --
721 -----------------------------------------------
723 function Standalone_Library_Auto_Init_Is_Supported
return Boolean is
726 end Standalone_Library_Auto_Init_Is_Supported
;
728 ---------------------------
729 -- Support_For_Libraries --
730 ---------------------------
732 function Support_For_Libraries
return Library_Support
is
735 end Support_For_Libraries
;