1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
6 -- (Alpha VMS Version) --
10 -- Copyright (C) 2003-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 Alpha 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
;
42 with System
; use System
;
43 with System
.Case_Util
; use System
.Case_Util
;
44 with System
.CRTL
; use System
.CRTL
;
46 package body MLib
.Tgt
is
50 Empty_Argument_List
: aliased Argument_List
:= (1 .. 0 => null);
51 Additional_Objects
: Argument_List_Access
:= Empty_Argument_List
'Access;
52 -- Used to add the generated auto-init object files for auto-initializing
53 -- stand-alone libraries.
55 Macro_Name
: constant String := "mcr gnu:[bin]gcc -c -x assembler";
56 -- The name of the command to invoke the macro-assembler
58 VMS_Options
: Argument_List
:= (1 .. 1 => null);
60 Gnatsym_Name
: constant String := "gnatsym";
62 Gnatsym_Path
: String_Access
;
64 Arguments
: Argument_List_Access
:= null;
65 Last_Argument
: Natural := 0;
67 Success
: Boolean := False;
69 Shared_Libgcc
: aliased String := "-shared-libgcc";
71 No_Shared_Libgcc_Switch
: aliased Argument_List
:= (1 .. 0 => null);
72 Shared_Libgcc_Switch
: aliased Argument_List
:=
73 (1 => Shared_Libgcc
'Access);
74 Link_With_Shared_Libgcc
: Argument_List_Access
:=
75 No_Shared_Libgcc_Switch
'Access;
81 function Archive_Builder
return String is
86 -----------------------------
87 -- Archive_Builder_Options --
88 -----------------------------
90 function Archive_Builder_Options
return String_List_Access
is
92 return new String_List
'(1 => new String'("cr"));
93 end Archive_Builder_Options
;
99 function Archive_Ext
return String is
104 ---------------------
105 -- Archive_Indexer --
106 ---------------------
108 function Archive_Indexer
return String is
113 -----------------------------
114 -- Archive_Indexer_Options --
115 -----------------------------
117 function Archive_Indexer_Options
return String_List_Access
is
119 return new String_List
(1 .. 0);
120 end Archive_Indexer_Options
;
122 ---------------------------
123 -- Build_Dynamic_Library --
124 ---------------------------
126 procedure Build_Dynamic_Library
127 (Ofiles
: Argument_List
;
128 Foreign
: Argument_List
;
129 Afiles
: Argument_List
;
130 Options
: Argument_List
;
131 Options_2
: Argument_List
;
132 Interfaces
: Argument_List
;
133 Lib_Filename
: String;
135 Symbol_Data
: Symbol_Record
;
136 Driver_Name
: Name_Id
:= No_Name
;
137 Lib_Version
: String := "";
138 Auto_Init
: Boolean := False)
140 pragma Unreferenced
(Foreign
);
141 pragma Unreferenced
(Afiles
);
143 Lib_File
: constant String :=
144 Lib_Dir
& Directory_Separator
& "lib" &
145 Fil
.Ext_To
(Lib_Filename
, DLL_Ext
);
147 Opts
: Argument_List
:= Options
;
148 Last_Opt
: Natural := Opts
'Last;
149 Opts2
: Argument_List
(Options
'Range);
150 Last_Opt2
: Natural := Opts2
'First - 1;
152 Inter
: constant Argument_List
:= Interfaces
;
154 function Is_Interface
(Obj_File
: String) return Boolean;
155 -- For a Stand-Alone Library, returns True if Obj_File is the object
156 -- file name of an interface of the SAL. For other libraries, always
159 function Option_File_Name
return String;
160 -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
162 function Version_String
return String;
163 -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is
164 -- not Autonomous, otherwise returns "".
165 -- When Symbol_Data.Symbol_Policy is Autonomous, fails gnatmake if
166 -- Lib_Version is not the image of a positive number.
172 function Is_Interface
(Obj_File
: String) return Boolean is
173 ALI
: constant String :=
175 (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
207 Get_Name_String
(Symbol_Data
.Symbol_File
);
208 To_Lower
(Name_Buffer
(1 .. Name_Len
));
209 return Name_Buffer
(1 .. Name_Len
);
211 end Option_File_Name
;
217 function Version_String
return String is
218 Version
: Integer := 0;
221 or else Symbol_Data
.Symbol_Policy
/= Autonomous
227 Version
:= Integer'Value (Lib_Version
);
230 raise Constraint_Error
;
236 when Constraint_Error
=>
237 Fail
("illegal version """, Lib_Version
,
238 """ (on VMS version must be a positive number)");
244 Opt_File_Name
: constant String := Option_File_Name
;
245 Version
: constant String := Version_String
;
246 For_Linker_Opt
: String_Access
;
248 -- Start of processing for Build_Dynamic_Library
251 -- Invoke gcc with -shared-libgcc, but only for GCC 3 or higher
253 if GCC_Version
>= 3 then
254 Link_With_Shared_Libgcc
:= Shared_Libgcc_Switch
'Access;
256 Link_With_Shared_Libgcc
:= No_Shared_Libgcc_Switch
'Access;
259 -- If option file name does not ends with ".opt", append "/OPTIONS"
260 -- to its specification for the VMS linker.
262 if Opt_File_Name
'Length > 4
264 Opt_File_Name
(Opt_File_Name
'Last - 3 .. Opt_File_Name
'Last) = ".opt"
266 For_Linker_Opt
:= new String'("--for-linker=" & Opt_File_Name);
269 new String'("--for-linker=" & Opt_File_Name
& "/OPTIONS");
272 VMS_Options
(VMS_Options
'First) := For_Linker_Opt
;
274 for J
in Inter
'Range loop
275 To_Lower
(Inter
(J
).all);
278 -- "gnatsym" is necessary for building the option file
280 if Gnatsym_Path
= null then
281 Gnatsym_Path
:= OS_Lib
.Locate_Exec_On_Path
(Gnatsym_Name
);
283 if Gnatsym_Path
= null then
284 Fail
(Gnatsym_Name
, " not found in path");
288 -- For auto-initialization of a stand-alone library, we create
289 -- a macro-assembly file and we invoke the macro-assembler.
293 Macro_File_Name
: constant String := Lib_Filename
& "$init.asm";
294 Macro_File
: File_Descriptor
;
295 Init_Proc
: String := Lib_Filename
& "INIT";
296 Popen_Result
: System
.Address
;
297 Pclose_Result
: Integer;
299 OK
: Boolean := True;
301 command
: constant String :=
302 Macro_Name
& " " & Macro_File_Name
& ASCII
.NUL
;
303 -- The command to invoke the assembler on the generated auto-init
306 mode
: constant String := "r" & ASCII
.NUL
;
307 -- The mode for the invocation of Popen
310 To_Upper
(Init_Proc
);
313 Write_Str
("Creating auto-init assembly file """);
314 Write_Str
(Macro_File_Name
);
318 -- Create and write the auto-init assembly file
321 First_Line
: constant String :=
322 ASCII
.HT
& ".section LIB$INITIALIZE,GBL,NOWRT" &
324 Second_Line
: constant String :=
325 ASCII
.HT
& ".long " & Init_Proc
& ASCII
.LF
;
326 -- First and second lines of the auto-init assembly file
329 Macro_File
:= Create_File
(Macro_File_Name
, Text
);
330 OK
:= Macro_File
/= Invalid_FD
;
334 (Macro_File
, First_Line
(First_Line
'First)'Address,
336 OK
:= Len
= First_Line
'Length;
341 (Macro_File
, Second_Line
(Second_Line
'First)'Address,
343 OK
:= Len
= Second_Line
'Length;
347 Close
(Macro_File
, OK
);
351 Fail
("creation of auto-init assembly file """,
352 Macro_File_Name
, """ failed");
356 -- Invoke the macro-assembler
359 Write_Str
("Assembling auto-init assembly file """);
360 Write_Str
(Macro_File_Name
);
364 Popen_Result
:= popen
(command
(command
'First)'Address,
365 mode
(mode
'First)'Address);
367 if Popen_Result
= Null_Address
then
368 Fail
("assembly of auto-init assembly file """,
369 Macro_File_Name
, """ failed");
372 -- Wait for the end of execution of the macro-assembler
374 Pclose_Result
:= pclose
(Popen_Result
);
376 if Pclose_Result
< 0 then
377 Fail
("assembly of auto init assembly file """,
378 Macro_File_Name
, """ failed");
381 -- Add the generated object file to the list of objects to be
382 -- included in the library.
384 Additional_Objects
:=
386 (1 => new String'(Lib_Filename
& "$init.obj"));
390 -- Allocate the argument list and put the symbol file name, the
391 -- reference (if any) and the policy (if not autonomous).
393 Arguments
:= new Argument_List
(1 .. Ofiles
'Length + 8);
400 Last_Argument
:= Last_Argument
+ 1;
401 Arguments
(Last_Argument
) := new String'("-v");
404 -- Version number (major ID)
406 if Lib_Version /= "" then
407 Last_Argument := Last_Argument + 1;
408 Arguments (Last_Argument) := new String'("-V");
409 Last_Argument
:= Last_Argument
+ 1;
410 Arguments
(Last_Argument
) := new String'(Version);
415 Last_Argument := Last_Argument + 1;
416 Arguments (Last_Argument) := new String'("-s");
417 Last_Argument
:= Last_Argument
+ 1;
418 Arguments
(Last_Argument
) := new String'(Opt_File_Name);
420 -- Reference Symbol File
422 if Symbol_Data.Reference /= No_Name then
423 Last_Argument := Last_Argument + 1;
424 Arguments (Last_Argument) := new String'("-r");
425 Last_Argument
:= Last_Argument
+ 1;
426 Arguments
(Last_Argument
) :=
427 new String'(Get_Name_String (Symbol_Data.Reference));
432 case Symbol_Data.Symbol_Policy is
437 Last_Argument := Last_Argument + 1;
438 Arguments (Last_Argument) := new String'("-c");
441 Last_Argument
:= Last_Argument
+ 1;
442 Arguments
(Last_Argument
) := new String'("-C");
445 Last_Argument := Last_Argument + 1;
446 Arguments (Last_Argument) := new String'("-R");
449 -- Add each relevant object file
451 for Index
in Ofiles
'Range loop
452 if Is_Interface
(Ofiles
(Index
).all) then
453 Last_Argument
:= Last_Argument
+ 1;
454 Arguments
(Last_Argument
) := new String'(Ofiles (Index).all);
460 Spawn (Program_Name => Gnatsym_Path.all,
461 Args => Arguments (1 .. Last_Argument),
465 Fail ("unable to create symbol file for library """,
471 -- Move all the -l switches from Opts to Opts2
474 Index : Natural := Opts'First;
478 while Index <= Last_Opt loop
481 if Opt'Length > 2 and then
482 Opt (Opt'First .. Opt'First + 1) = "-l"
484 if Index < Last_Opt then
485 Opts (Index .. Last_Opt - 1) :=
486 Opts (Index + 1 .. Last_Opt);
489 Last_Opt := Last_Opt - 1;
491 Last_Opt2 := Last_Opt2 + 1;
492 Opts2 (Last_Opt2) := Opt;
500 -- Invoke gcc to build the library
503 (Output_File => Lib_File,
504 Objects => Ofiles & Additional_Objects.all,
505 Options => VMS_Options,
506 Options_2 => Link_With_Shared_Libgcc.all &
507 Opts (Opts'First .. Last_Opt) &
508 Opts2 (Opts2'First .. Last_Opt2) & Options_2,
509 Driver_Name => Driver_Name);
511 -- The auto-init object file need to be deleted, so that it will not
512 -- be included in the library as a regular object file, otherwise
513 -- it will be included twice when the library will be built next
514 -- time, which may lead to errors.
518 Auto_Init_Object_File_Name : constant String :=
519 Lib_Filename & "$init.obj";
524 Write_Str ("deleting auto-init object file """);
525 Write_Str (Auto_Init_Object_File_Name);
529 Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
532 end Build_Dynamic_Library;
538 function DLL_Ext return String is
547 function Dynamic_Option return String is
556 function Is_Object_Ext (Ext : String) return Boolean is
565 function Is_C_Ext (Ext : String) return Boolean is
574 function Is_Archive_Ext (Ext : String) return Boolean is
576 return Ext = ".olb" or else Ext = ".exe";
583 function Libgnat return String is
584 Libgnat_A : constant String := "libgnat.a";
585 Libgnat_Olb : constant String := "libgnat.olb";
588 Name_Len := Libgnat_A'Length;
589 Name_Buffer (1 .. Name_Len) := Libgnat_A;
591 if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then
599 ------------------------
600 -- Library_Exists_For --
601 ------------------------
603 function Library_Exists_For
604 (Project : Project_Id; In_Tree : Project_Tree_Ref) return Boolean
607 if not In_Tree.Projects.Table (Project).Library then
608 Fail ("INTERNAL ERROR: Library_Exists_For called " &
609 "for non library project");
614 Lib_Dir : constant String :=
616 (In_Tree.Projects.Table (Project).Library_Dir);
617 Lib_Name : constant String :=
619 (In_Tree.Projects.Table (Project).Library_Name);
622 if In_Tree.Projects.Table (Project).Library_Kind =
625 return Is_Regular_File
626 (Lib_Dir & Directory_Separator & "lib" &
627 Fil.Ext_To (Lib_Name, Archive_Ext));
630 return Is_Regular_File
631 (Lib_Dir & Directory_Separator & "lib" &
632 Fil.Ext_To (Lib_Name, DLL_Ext));
636 end Library_Exists_For;
638 ---------------------------
639 -- Library_File_Name_For --
640 ---------------------------
642 function Library_File_Name_For
643 (Project : Project_Id;
644 In_Tree : Project_Tree_Ref) return Name_Id
647 if not In_Tree.Projects.Table (Project).Library then
648 Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
649 "for non library project");
654 Lib_Name : constant String :=
656 (In_Tree.Projects.Table (Project).Library_Name);
660 Name_Buffer (1 .. Name_Len) := "lib";
662 if In_Tree.Projects.Table (Project).Library_Kind =
665 Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
668 Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
674 end Library_File_Name_For;
680 function Object_Ext return String is
689 function PIC_Option return String is
694 -----------------------------------------------
695 -- Standalone_Library_Auto_Init_Is_Supported --
696 -----------------------------------------------
698 function Standalone_Library_Auto_Init_Is_Supported return Boolean is
701 end Standalone_Library_Auto_Init_Is_Supported;
703 ---------------------------
704 -- Support_For_Libraries --
705 ---------------------------
707 function Support_For_Libraries return Library_Support is
710 end Support_For_Libraries;