1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- M L I B . T G T . S P E C I F I C -- 6-- (Alpha VMS Version) -- 7-- -- 8-- B o d y -- 9-- -- 10-- Copyright (C) 2003-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 Alpha 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 179 begin 180 if Lib_Version = "" 181 or else Symbol_Data.Symbol_Policy /= Autonomous 182 then 183 return ""; 184 185 else 186 begin 187 Version := Integer'Value (Lib_Version); 188 189 if Version <= 0 then 190 raise Constraint_Error; 191 end if; 192 193 return Lib_Version; 194 195 exception 196 when Constraint_Error => 197 Fail ("illegal version """ 198 & Lib_Version 199 & """ (on VMS version must be a positive number)"); 200 return ""; 201 end; 202 end if; 203 end Version_String; 204 205 --------------------- 206 -- Local Variables -- 207 --------------------- 208 209 Opt_File_Name : constant String := Option_File_Name; 210 Version : constant String := Version_String; 211 For_Linker_Opt : String_Access; 212 213 -- Start of processing for Build_Dynamic_Library 214 215 begin 216 -- If option file name does not ends with ".opt", append "/OPTIONS" 217 -- to its specification for the VMS linker. 218 219 if Opt_File_Name'Length > 4 220 and then 221 Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" 222 then 223 For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); 224 else 225 For_Linker_Opt := 226 new String'("--for-linker=" & Opt_File_Name & "/OPTIONS"); 227 end if; 228 229 VMS_Options (VMS_Options'First) := For_Linker_Opt; 230 231 for J in Inter'Range loop 232 To_Lower (Inter (J).all); 233 end loop; 234 235 -- "gnatsym" is necessary for building the option file 236 237 if Gnatsym_Path = null then 238 Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name); 239 240 if Gnatsym_Path = null then 241 Fail (Gnatsym_Name & " not found in path"); 242 end if; 243 end if; 244 245 -- For auto-initialization of a stand-alone library, we create 246 -- a macro-assembly file and we invoke the macro-assembler. 247 248 if Auto_Init then 249 declare 250 Macro_File_Name : constant String := Lib_Filename & "__init.asm"; 251 Macro_File : File_Descriptor; 252 Init_Proc : constant String := Init_Proc_Name (Lib_Filename); 253 Popen_Result : System.Address; 254 Pclose_Result : Integer; 255 Len : Natural; 256 OK : Boolean := True; 257 258 command : constant String := 259 Macro_Name & " " & Macro_File_Name & ASCII.NUL; 260 -- The command to invoke the assembler on the generated auto-init 261 -- assembly file. 262 263 mode : constant String := "r" & ASCII.NUL; 264 -- The mode for the invocation of Popen 265 266 begin 267 if Verbose_Mode then 268 Write_Str ("Creating auto-init assembly file """); 269 Write_Str (Macro_File_Name); 270 Write_Line (""""); 271 end if; 272 273 -- Create and write the auto-init assembly file 274 275 declare 276 use ASCII; 277 278 -- Output a dummy transfer address for debugging 279 -- followed by the LIB$INITIALIZE section. 280 281 Lines : constant String := 282 HT & ".text" & LF & 283 HT & ".align 4" & LF & 284 HT & ".globl __main" & LF & 285 HT & ".ent __main" & LF & 286 "__main..en:" & LF & 287 HT & ".base $27" & LF & 288 HT & ".frame $29,0,$26,8" & LF & 289 HT & "ret $31,($26),1" & LF & 290 HT & ".link" & LF & 291 "__main:" & LF & 292 HT & ".pdesc __main..en,null" & LF & 293 HT & ".end __main" & LF & LF & 294 HT & ".section LIB$INITIALIZE,GBL,NOWRT" & LF & 295 HT & ".long " & Init_Proc & LF; 296 297 begin 298 Macro_File := Create_File (Macro_File_Name, Text); 299 OK := Macro_File /= Invalid_FD; 300 301 if OK then 302 Len := Write 303 (Macro_File, Lines (Lines'First)'Address, 304 Lines'Length); 305 OK := Len = Lines'Length; 306 end if; 307 308 if OK then 309 Close (Macro_File, OK); 310 end if; 311 312 if not OK then 313 Fail ("creation of auto-init assembly file """ 314 & Macro_File_Name 315 & """ failed"); 316 end if; 317 end; 318 319 -- Invoke the macro-assembler 320 321 if Verbose_Mode then 322 Write_Str ("Assembling auto-init assembly file """); 323 Write_Str (Macro_File_Name); 324 Write_Line (""""); 325 end if; 326 327 Popen_Result := popen (command (command'First)'Address, 328 mode (mode'First)'Address); 329 330 if Popen_Result = Null_Address then 331 Fail ("assembly of auto-init assembly file """ 332 & Macro_File_Name 333 & """ failed"); 334 end if; 335 336 -- Wait for the end of execution of the macro-assembler 337 338 Pclose_Result := pclose (Popen_Result); 339 340 if Pclose_Result < 0 then 341 Fail ("assembly of auto init assembly file """ 342 & Macro_File_Name 343 & """ failed"); 344 end if; 345 346 -- Add the generated object file to the list of objects to be 347 -- included in the library. 348 349 Additional_Objects := 350 new Argument_List' 351 (1 => new String'(Lib_Filename & "__init.obj")); 352 end; 353 end if; 354 355 -- Allocate the argument list and put the symbol file name, the 356 -- reference (if any) and the policy (if not autonomous). 357 358 Arguments := new Argument_List (1 .. Ofiles'Length + 8); 359 360 Last_Argument := 0; 361 362 -- Verbosity 363 364 if Verbose_Mode then 365 Last_Argument := Last_Argument + 1; 366 Arguments (Last_Argument) := new String'("-v"); 367 end if; 368 369 -- Version number (major ID) 370 371 if Lib_Version /= "" then 372 Last_Argument := Last_Argument + 1; 373 Arguments (Last_Argument) := new String'("-V"); 374 Last_Argument := Last_Argument + 1; 375 Arguments (Last_Argument) := new String'(Version); 376 end if; 377 378 -- Symbol file 379 380 Last_Argument := Last_Argument + 1; 381 Arguments (Last_Argument) := new String'("-s"); 382 Last_Argument := Last_Argument + 1; 383 Arguments (Last_Argument) := new String'(Opt_File_Name); 384 385 -- Reference Symbol File 386 387 if Symbol_Data.Reference /= No_Path then 388 Last_Argument := Last_Argument + 1; 389 Arguments (Last_Argument) := new String'("-r"); 390 Last_Argument := Last_Argument + 1; 391 Arguments (Last_Argument) := 392 new String'(Get_Name_String (Symbol_Data.Reference)); 393 end if; 394 395 -- Policy 396 397 case Symbol_Data.Symbol_Policy is 398 when Autonomous => 399 null; 400 401 when Compliant => 402 Last_Argument := Last_Argument + 1; 403 Arguments (Last_Argument) := new String'("-c"); 404 405 when Controlled => 406 Last_Argument := Last_Argument + 1; 407 Arguments (Last_Argument) := new String'("-C"); 408 409 when Restricted => 410 Last_Argument := Last_Argument + 1; 411 Arguments (Last_Argument) := new String'("-R"); 412 413 when Direct => 414 Last_Argument := Last_Argument + 1; 415 Arguments (Last_Argument) := new String'("-D"); 416 417 end case; 418 419 -- Add each relevant object file 420 421 for Index in Ofiles'Range loop 422 if Is_Interface (Ofiles (Index).all) then 423 Last_Argument := Last_Argument + 1; 424 Arguments (Last_Argument) := new String'(Ofiles (Index).all); 425 end if; 426 end loop; 427 428 -- Spawn gnatsym 429 430 Spawn (Program_Name => Gnatsym_Path.all, 431 Args => Arguments (1 .. Last_Argument), 432 Success => Success); 433 434 if not Success then 435 Fail ("unable to create symbol file for library """ 436 & Lib_Filename 437 & """"); 438 end if; 439 440 Free (Arguments); 441 442 -- Move all the -l switches from Opts to Opts2 443 444 declare 445 Index : Natural := Opts'First; 446 Opt : String_Access; 447 448 begin 449 while Index <= Last_Opt loop 450 Opt := Opts (Index); 451 452 if Opt'Length > 2 and then 453 Opt (Opt'First .. Opt'First + 1) = "-l" 454 then 455 if Index < Last_Opt then 456 Opts (Index .. Last_Opt - 1) := 457 Opts (Index + 1 .. Last_Opt); 458 end if; 459 460 Last_Opt := Last_Opt - 1; 461 462 Last_Opt2 := Last_Opt2 + 1; 463 Opts2 (Last_Opt2) := Opt; 464 465 else 466 Index := Index + 1; 467 end if; 468 end loop; 469 end; 470 471 -- Invoke gcc to build the library 472 473 Utl.Gcc 474 (Output_File => Lib_File, 475 Objects => Ofiles & Additional_Objects.all, 476 Options => VMS_Options, 477 Options_2 => Shared_Libgcc_Switch & 478 Opts (Opts'First .. Last_Opt) & 479 Opts2 (Opts2'First .. Last_Opt2), 480 Driver_Name => Driver_Name); 481 482 -- The auto-init object file need to be deleted, so that it will not 483 -- be included in the library as a regular object file, otherwise 484 -- it will be included twice when the library will be built next 485 -- time, which may lead to errors. 486 487 if Auto_Init then 488 declare 489 Auto_Init_Object_File_Name : constant String := 490 Lib_Filename & "__init.obj"; 491 Disregard : Boolean; 492 493 begin 494 if Verbose_Mode then 495 Write_Str ("deleting auto-init object file """); 496 Write_Str (Auto_Init_Object_File_Name); 497 Write_Line (""""); 498 end if; 499 500 Delete_File (Auto_Init_Object_File_Name, Success => Disregard); 501 end; 502 end if; 503 end Build_Dynamic_Library; 504 505-- Package initialization 506 507begin 508 Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; 509end MLib.Tgt.Specific; 510