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