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, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, 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;
36 with Namet; use Namet;
38 with Output; use Output;
41 with System; use System;
42 with System.Case_Util; use System.Case_Util;
43 with System.CRTL; use System.CRTL;
45 package body MLib.Tgt is
49 Empty_Argument_List : aliased Argument_List := (1 .. 0 => null);
50 Additional_Objects : Argument_List_Access := Empty_Argument_List'Access;
51 -- Used to add the generated auto-init object files for auto-initializing
52 -- stand-alone libraries.
54 Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler";
55 -- The name of the command to invoke the macro-assembler
57 VMS_Options : Argument_List := (1 .. 1 => null);
59 Gnatsym_Name : constant String := "gnatsym";
61 Gnatsym_Path : String_Access;
63 Arguments : Argument_List_Access := null;
64 Last_Argument : Natural := 0;
66 Success : Boolean := False;
68 Shared_Libgcc : aliased String := "-shared-libgcc";
70 No_Shared_Libgcc_Switch : aliased Argument_List := (1 .. 0 => null);
71 Shared_Libgcc_Switch : aliased Argument_List :=
72 (1 => Shared_Libgcc'Access);
73 Link_With_Shared_Libgcc : Argument_List_Access :=
74 No_Shared_Libgcc_Switch'Access;
80 function Archive_Builder return String is
85 -----------------------------
86 -- Archive_Builder_Options --
87 -----------------------------
89 function Archive_Builder_Options return String_List_Access is
91 return new String_List'(1 => new String'("cr"));
92 end Archive_Builder_Options;
98 function Archive_Ext return String is
103 ---------------------
104 -- Archive_Indexer --
105 ---------------------
107 function Archive_Indexer return String is
112 -----------------------------
113 -- Archive_Indexer_Options --
114 -----------------------------
116 function Archive_Indexer_Options return String_List_Access is
118 return new String_List (1 .. 0);
119 end Archive_Indexer_Options;
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 Options_2 : Argument_List;
131 Interfaces : Argument_List;
132 Lib_Filename : String;
134 Symbol_Data : Symbol_Record;
135 Driver_Name : Name_Id := No_Name;
136 Lib_Version : String := "";
137 Auto_Init : Boolean := False)
139 pragma Unreferenced (Foreign);
140 pragma Unreferenced (Afiles);
142 Lib_File : constant String :=
143 Lib_Dir & Directory_Separator & "lib" &
144 Fil.Ext_To (Lib_Filename, DLL_Ext);
146 Opts : Argument_List := Options;
147 Last_Opt : Natural := Opts'Last;
148 Opts2 : Argument_List (Options'Range);
149 Last_Opt2 : Natural := Opts2'First - 1;
151 Inter : constant Argument_List := Interfaces;
153 function Is_Interface (Obj_File : String) return Boolean;
154 -- For a Stand-Alone Library, returns True if Obj_File is the object
155 -- file name of an interface of the SAL. For other libraries, always
158 function Option_File_Name return String;
159 -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
161 function Version_String return String;
162 -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is
163 -- not Autonomous, otherwise returns "".
164 -- When Symbol_Data.Symbol_Policy is Autonomous, fails gnatmake if
165 -- Lib_Version is not the image of a positive number.
171 function Is_Interface (Obj_File : String) return Boolean is
172 ALI : constant String :=
174 (Filename => To_Lower (Base_Name (Obj_File)),
178 if Inter'Length = 0 then
181 elsif ALI'Length > 2 and then
182 ALI (ALI'First .. ALI'First + 2) = "b__"
187 for J in Inter'Range loop
188 if Inter (J).all = ALI then
197 ----------------------
198 -- Option_File_Name --
199 ----------------------
201 function Option_File_Name return String is
203 if Symbol_Data.Symbol_File = No_Name then
206 Get_Name_String (Symbol_Data.Symbol_File);
207 To_Lower (Name_Buffer (1 .. Name_Len));
208 return Name_Buffer (1 .. Name_Len);
210 end Option_File_Name;
216 function Version_String return String is
217 Version : Integer := 0;
220 or else Symbol_Data.Symbol_Policy /= Autonomous
226 Version := Integer'Value (Lib_Version);
229 raise Constraint_Error;
235 when Constraint_Error =>
236 Fail ("illegal version """, Lib_Version,
237 """ (on VMS version must be a positive number)");
243 Opt_File_Name : constant String := Option_File_Name;
244 Version : constant String := Version_String;
245 For_Linker_Opt : String_Access;
247 -- Start of processing for Build_Dynamic_Library
250 -- Invoke gcc with -shared-libgcc, but only for GCC 3 or higher
252 if GCC_Version >= 3 then
253 Link_With_Shared_Libgcc := Shared_Libgcc_Switch'Access;
255 Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access;
258 -- Option file must end with ".opt"
260 if Opt_File_Name'Length > 4
262 Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
264 For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
266 Fail ("Options File """, Opt_File_Name, """ must end with .opt");
269 VMS_Options (VMS_Options'First) := For_Linker_Opt;
271 for J in Inter'Range loop
272 To_Lower (Inter (J).all);
275 -- "gnatsym" is necessary for building the option file
277 if Gnatsym_Path = null then
278 Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name);
280 if Gnatsym_Path = null then
281 Fail (Gnatsym_Name, " not found in path");
285 -- For auto-initialization of a stand-alone library, we create
286 -- a macro-assembly file and we invoke the macro-assembler.
290 Macro_File_Name : constant String := Lib_Filename & "__init.asm";
291 Macro_File : File_Descriptor;
292 Init_Proc : String := Lib_Filename & "INIT";
293 Popen_Result : System.Address;
294 Pclose_Result : Integer;
296 OK : Boolean := True;
298 command : constant String :=
299 Macro_Name & " " & Macro_File_Name & ASCII.NUL;
300 -- The command to invoke the assembler on the generated auto-init
303 mode : constant String := "r" & ASCII.NUL;
304 -- The mode for the invocation of Popen
307 To_Upper (Init_Proc);
310 Write_Str ("Creating auto-init assembly file """);
311 Write_Str (Macro_File_Name);
315 -- Create and write the auto-init assembly file
318 First_Line : constant String :=
320 ".type " & Init_Proc & "#, @function" &
322 Second_Line : constant String :=
324 ".global " & Init_Proc & "#" &
326 Third_Line : constant String :=
328 ".global LIB$INITIALIZE#" &
330 Fourth_Line : constant String :=
332 ".section LIB$INITIALIZE#,""a"",@progbits" &
334 Fifth_Line : constant String :=
336 "data4 @fptr(" & Init_Proc & "#)" &
340 Macro_File := Create_File (Macro_File_Name, Text);
341 OK := Macro_File /= Invalid_FD;
345 (Macro_File, First_Line (First_Line'First)'Address,
347 OK := Len = First_Line'Length;
352 (Macro_File, Second_Line (Second_Line'First)'Address,
354 OK := Len = Second_Line'Length;
359 (Macro_File, Third_Line (Third_Line'First)'Address,
361 OK := Len = Third_Line'Length;
366 (Macro_File, Fourth_Line (Fourth_Line'First)'Address,
368 OK := Len = Fourth_Line'Length;
373 (Macro_File, Fifth_Line (Fifth_Line'First)'Address,
375 OK := Len = Fifth_Line'Length;
379 Close (Macro_File, OK);
383 Fail ("creation of auto-init assembly file """,
384 Macro_File_Name, """ failed");
388 -- Invoke the macro-assembler
391 Write_Str ("Assembling auto-init assembly file """);
392 Write_Str (Macro_File_Name);
396 Popen_Result := popen (command (command'First)'Address,
397 mode (mode'First)'Address);
399 if Popen_Result = Null_Address then
400 Fail ("assembly of auto-init assembly file """,
401 Macro_File_Name, """ failed");
404 -- Wait for the end of execution of the macro-assembler
406 Pclose_Result := pclose (Popen_Result);
408 if Pclose_Result < 0 then
409 Fail ("assembly of auto init assembly file """,
410 Macro_File_Name, """ failed");
413 -- Add the generated object file to the list of objects to be
414 -- included in the library.
416 Additional_Objects :=
418 (1 => new String'(Lib_Filename & "__init.obj"));
422 -- Allocate the argument list and put the symbol file name, the
423 -- reference (if any) and the policy (if not autonomous).
425 Arguments := new Argument_List (1 .. Ofiles'Length + 8);
432 Last_Argument := Last_Argument + 1;
433 Arguments (Last_Argument) := new String'("-v");
436 -- Version number (major ID)
438 if Lib_Version /= "" then
439 Last_Argument := Last_Argument + 1;
440 Arguments (Last_Argument) := new String'("-V");
441 Last_Argument := Last_Argument + 1;
442 Arguments (Last_Argument) := new String'(Version);
447 Last_Argument := Last_Argument + 1;
448 Arguments (Last_Argument) := new String'("-s");
449 Last_Argument := Last_Argument + 1;
450 Arguments (Last_Argument) := new String'(Opt_File_Name);
452 -- Reference Symbol File
454 if Symbol_Data.Reference /= No_Name then
455 Last_Argument := Last_Argument + 1;
456 Arguments (Last_Argument) := new String'("-r");
457 Last_Argument := Last_Argument + 1;
458 Arguments (Last_Argument) :=
459 new String'(Get_Name_String (Symbol_Data.Reference));
464 case Symbol_Data.Symbol_Policy is
469 Last_Argument := Last_Argument + 1;
470 Arguments (Last_Argument) := new String'("-c");
473 Last_Argument := Last_Argument + 1;
474 Arguments (Last_Argument) := new String'("-C");
477 Last_Argument := Last_Argument + 1;
478 Arguments (Last_Argument) := new String'("-R");
481 -- Add each relevant object file
483 for Index in Ofiles'Range loop
484 if Is_Interface (Ofiles (Index).all) then
485 Last_Argument := Last_Argument + 1;
486 Arguments (Last_Argument) := new String'(Ofiles (Index).all);
492 Spawn (Program_Name => Gnatsym_Path.all,
493 Args => Arguments (1 .. Last_Argument),
497 Fail ("unable to create symbol file for library """,
503 -- Move all the -l switches from Opts to Opts2
506 Index : Natural := Opts'First;
510 while Index <= Last_Opt loop
513 if Opt'Length > 2 and then
514 Opt (Opt'First .. Opt'First + 1) = "-l"
516 if Index < Last_Opt then
517 Opts (Index .. Last_Opt - 1) :=
518 Opts (Index + 1 .. Last_Opt);
521 Last_Opt := Last_Opt - 1;
523 Last_Opt2 := Last_Opt2 + 1;
524 Opts2 (Last_Opt2) := Opt;
532 -- Invoke gcc to build the library
535 (Output_File => Lib_File,
536 Objects => Ofiles & Additional_Objects.all,
537 Options => VMS_Options,
538 Options_2 => Link_With_Shared_Libgcc.all &
539 Opts (Opts'First .. Last_Opt) &
540 Opts2 (Opts2'First .. Last_Opt2) & Options_2,
541 Driver_Name => Driver_Name);
543 -- The auto-init object file need to be deleted, so that it will not
544 -- be included in the library as a regular object file, otherwise
545 -- it will be included twice when the library will be built next
546 -- time, which may lead to errors.
550 Auto_Init_Object_File_Name : constant String :=
551 Lib_Filename & "__init.obj";
556 Write_Str ("deleting auto-init object file """);
557 Write_Str (Auto_Init_Object_File_Name);
561 Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
564 end Build_Dynamic_Library;
570 function DLL_Ext return String is
579 function DLL_Prefix return String is
588 function Dynamic_Option return String is
597 function Is_Object_Ext (Ext : String) return Boolean is
606 function Is_C_Ext (Ext : String) return Boolean is
615 function Is_Archive_Ext (Ext : String) return Boolean is
617 return Ext = ".olb" or else Ext = ".exe";
624 function Libgnat return String is
625 Libgnat_A : constant String := "libgnat.a";
626 Libgnat_Olb : constant String := "libgnat.olb";
629 Name_Len := Libgnat_A'Length;
630 Name_Buffer (1 .. Name_Len) := Libgnat_A;
632 if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then
640 ------------------------
641 -- Library_Exists_For --
642 ------------------------
644 function Library_Exists_For
645 (Project : Project_Id; In_Tree : Project_Tree_Ref) return Boolean
648 if not In_Tree.Projects.Table (Project).Library then
649 Fail ("INTERNAL ERROR: Library_Exists_For called " &
650 "for non library project");
655 Lib_Dir : constant String :=
657 (In_Tree.Projects.Table (Project).Library_Dir);
658 Lib_Name : constant String :=
660 (In_Tree.Projects.Table (Project).Library_Name);
663 if In_Tree.Projects.Table (Project).Library_Kind =
666 return Is_Regular_File
667 (Lib_Dir & Directory_Separator & "lib" &
668 Fil.Ext_To (Lib_Name, Archive_Ext));
671 return Is_Regular_File
672 (Lib_Dir & Directory_Separator & "lib" &
673 Fil.Ext_To (Lib_Name, DLL_Ext));
677 end Library_Exists_For;
679 ---------------------------
680 -- Library_File_Name_For --
681 ---------------------------
683 function Library_File_Name_For
684 (Project : Project_Id;
685 In_Tree : Project_Tree_Ref) return Name_Id
688 if not In_Tree.Projects.Table (Project).Library then
689 Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
690 "for non library project");
695 Lib_Name : constant String :=
697 (In_Tree.Projects.Table (Project).Library_Name);
701 Name_Buffer (1 .. Name_Len) := "lib";
703 if In_Tree.Projects.Table (Project).Library_Kind =
705 Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
708 Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
714 end Library_File_Name_For;
720 function Object_Ext return String is
729 function PIC_Option return String is
734 -----------------------------------------------
735 -- Standalone_Library_Auto_Init_Is_Supported --
736 -----------------------------------------------
738 function Standalone_Library_Auto_Init_Is_Supported return Boolean is
741 end Standalone_Library_Auto_Init_Is_Supported;
743 ---------------------------
744 -- Support_For_Libraries --
745 ---------------------------
747 function Support_For_Libraries return Library_Support is
750 end Support_For_Libraries;