1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- M L I B -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1999-2009, AdaCore -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Ada.Characters.Handling; use Ada.Characters.Handling; 27with Interfaces.C.Strings; 28with System; 29 30with Hostparm; 31with Opt; 32with Output; use Output; 33 34with MLib.Utl; use MLib.Utl; 35 36with Prj.Com; 37 38with GNAT.Directory_Operations; use GNAT.Directory_Operations; 39 40package body MLib is 41 42 ------------------- 43 -- Build_Library -- 44 ------------------- 45 46 procedure Build_Library 47 (Ofiles : Argument_List; 48 Output_File : String; 49 Output_Dir : String) 50 is 51 begin 52 if Opt.Verbose_Mode and not Opt.Quiet_Output then 53 Write_Line ("building a library..."); 54 Write_Str (" make "); 55 Write_Line (Output_File); 56 end if; 57 58 Ar (Output_Dir & 59 "lib" & Output_File & ".a", Objects => Ofiles); 60 end Build_Library; 61 62 ------------------------ 63 -- Check_Library_Name -- 64 ------------------------ 65 66 procedure Check_Library_Name (Name : String) is 67 begin 68 if Name'Length = 0 then 69 Prj.Com.Fail ("library name cannot be empty"); 70 end if; 71 72 if Name'Length > Max_Characters_In_Library_Name then 73 Prj.Com.Fail ("illegal library name """ 74 & Name 75 & """: too long"); 76 end if; 77 78 if not Is_Letter (Name (Name'First)) then 79 Prj.Com.Fail ("illegal library name """ 80 & Name 81 & """: should start with a letter"); 82 end if; 83 84 for Index in Name'Range loop 85 if not Is_Alphanumeric (Name (Index)) then 86 Prj.Com.Fail ("illegal library name """ 87 & Name 88 & """: should include only letters and digits"); 89 end if; 90 end loop; 91 end Check_Library_Name; 92 93 -------------------- 94 -- Copy_ALI_Files -- 95 -------------------- 96 97 procedure Copy_ALI_Files 98 (Files : Argument_List; 99 To : Path_Name_Type; 100 Interfaces : String_List) 101 is 102 Success : Boolean := False; 103 To_Dir : constant String := Get_Name_String (To); 104 Is_Interface : Boolean := False; 105 106 procedure Verbose_Copy (Index : Positive); 107 -- In verbose mode, output a message that the indexed file is copied 108 -- to the destination directory. 109 110 ------------------ 111 -- Verbose_Copy -- 112 ------------------ 113 114 procedure Verbose_Copy (Index : Positive) is 115 begin 116 if Opt.Verbose_Mode then 117 Write_Str ("Copying """); 118 Write_Str (Files (Index).all); 119 Write_Str (""" to """); 120 Write_Str (To_Dir); 121 Write_Line (""""); 122 end if; 123 end Verbose_Copy; 124 125 -- Start of processing for Copy_ALI_Files 126 127 begin 128 if Interfaces'Length = 0 then 129 130 -- If there are no Interfaces, copy all the ALI files as is 131 132 for Index in Files'Range loop 133 Verbose_Copy (Index); 134 Set_Writable 135 (To_Dir & 136 Directory_Separator & 137 Base_Name (Files (Index).all)); 138 Copy_File 139 (Files (Index).all, 140 To_Dir, 141 Success, 142 Mode => Overwrite, 143 Preserve => Preserve); 144 145 exit when not Success; 146 end loop; 147 148 else 149 -- Copy only the interface ALI file, and put the special indicator 150 -- "SL" on the P line. 151 152 for Index in Files'Range loop 153 154 declare 155 File_Name : String := Base_Name (Files (Index).all); 156 157 begin 158 Canonical_Case_File_Name (File_Name); 159 160 -- Check if this is one of the interface ALIs 161 162 Is_Interface := False; 163 164 for Index in Interfaces'Range loop 165 if File_Name = Interfaces (Index).all then 166 Is_Interface := True; 167 exit; 168 end if; 169 end loop; 170 171 -- If it is an interface ALI, copy line by line. Insert 172 -- the interface indication at the end of the P line. 173 -- Do not copy ALI files that are not Interfaces. 174 175 if Is_Interface then 176 Success := False; 177 Verbose_Copy (Index); 178 Set_Writable 179 (To_Dir & 180 Directory_Separator & 181 Base_Name (Files (Index).all)); 182 183 declare 184 FD : File_Descriptor; 185 Len : Integer; 186 Actual_Len : Integer; 187 S : String_Access; 188 Curr : Natural; 189 P_Line_Found : Boolean; 190 Status : Boolean; 191 192 begin 193 -- Open the file 194 195 Name_Len := Files (Index)'Length; 196 Name_Buffer (1 .. Name_Len) := Files (Index).all; 197 Name_Len := Name_Len + 1; 198 Name_Buffer (Name_Len) := ASCII.NUL; 199 200 FD := Open_Read (Name_Buffer'Address, Binary); 201 202 if FD /= Invalid_FD then 203 Len := Integer (File_Length (FD)); 204 205 -- ??? Why "+3" here 206 207 S := new String (1 .. Len + 3); 208 209 -- Read the file. Note that the loop is not necessary 210 -- since the whole file is read at once except on VMS. 211 212 Curr := S'First; 213 while Curr <= Len loop 214 Actual_Len := Read (FD, S (Curr)'Address, Len); 215 216 -- Exit if we could not read for some reason 217 218 exit when Actual_Len = 0; 219 220 Curr := Curr + Actual_Len; 221 end loop; 222 223 -- We are done with the input file, so we close it 224 -- ignoring any bad status. 225 226 Close (FD, Status); 227 228 P_Line_Found := False; 229 230 -- Look for the P line. When found, add marker SL 231 -- at the beginning of the P line. 232 233 for Index in 1 .. Len - 3 loop 234 if (S (Index) = ASCII.LF 235 or else 236 S (Index) = ASCII.CR) 237 and then S (Index + 1) = 'P' 238 then 239 S (Index + 5 .. Len + 3) := S (Index + 2 .. Len); 240 S (Index + 2 .. Index + 4) := " SL"; 241 P_Line_Found := True; 242 exit; 243 end if; 244 end loop; 245 246 if P_Line_Found then 247 248 -- Create new modified ALI file 249 250 Name_Len := To_Dir'Length; 251 Name_Buffer (1 .. Name_Len) := To_Dir; 252 Name_Len := Name_Len + 1; 253 Name_Buffer (Name_Len) := Directory_Separator; 254 Name_Buffer 255 (Name_Len + 1 .. Name_Len + File_Name'Length) := 256 File_Name; 257 Name_Len := Name_Len + File_Name'Length + 1; 258 Name_Buffer (Name_Len) := ASCII.NUL; 259 260 FD := Create_File (Name_Buffer'Address, Binary); 261 262 -- Write the modified text and close the newly 263 -- created file. 264 265 if FD /= Invalid_FD then 266 Actual_Len := Write (FD, S (1)'Address, Len + 3); 267 268 Close (FD, Status); 269 270 -- Set Success to True only if the newly 271 -- created file has been correctly written. 272 273 Success := Status and then Actual_Len = Len + 3; 274 275 if Success then 276 277 -- Set_Read_Only is used here, rather than 278 -- Set_Non_Writable, so that gprbuild can 279 -- he compiled with older compilers. 280 281 Set_Read_Only 282 (Name_Buffer (1 .. Name_Len - 1)); 283 end if; 284 end if; 285 end if; 286 end if; 287 end; 288 289 -- This is not an interface ALI 290 291 else 292 Success := True; 293 end if; 294 end; 295 296 if not Success then 297 Prj.Com.Fail ("could not copy ALI files to library dir"); 298 end if; 299 end loop; 300 end if; 301 end Copy_ALI_Files; 302 303 ---------------------- 304 -- Create_Sym_Links -- 305 ---------------------- 306 307 procedure Create_Sym_Links 308 (Lib_Path : String; 309 Lib_Version : String; 310 Lib_Dir : String; 311 Maj_Version : String) 312 is 313 function Symlink 314 (Oldpath : System.Address; 315 Newpath : System.Address) return Integer; 316 pragma Import (C, Symlink, "__gnat_symlink"); 317 318 Version_Path : String_Access; 319 320 Success : Boolean; 321 Result : Integer; 322 pragma Unreferenced (Success, Result); 323 324 begin 325 Version_Path := new String (1 .. Lib_Version'Length + 1); 326 Version_Path (1 .. Lib_Version'Length) := Lib_Version; 327 Version_Path (Version_Path'Last) := ASCII.NUL; 328 329 if Maj_Version'Length = 0 then 330 declare 331 Newpath : String (1 .. Lib_Path'Length + 1); 332 begin 333 Newpath (1 .. Lib_Path'Length) := Lib_Path; 334 Newpath (Newpath'Last) := ASCII.NUL; 335 Delete_File (Lib_Path, Success); 336 Result := Symlink (Version_Path (1)'Address, Newpath'Address); 337 end; 338 339 else 340 declare 341 Newpath1 : String (1 .. Lib_Path'Length + 1); 342 Maj_Path : constant String := 343 Lib_Dir & Directory_Separator & Maj_Version; 344 Newpath2 : String (1 .. Maj_Path'Length + 1); 345 Maj_Ver : String (1 .. Maj_Version'Length + 1); 346 347 begin 348 Newpath1 (1 .. Lib_Path'Length) := Lib_Path; 349 Newpath1 (Newpath1'Last) := ASCII.NUL; 350 351 Newpath2 (1 .. Maj_Path'Length) := Maj_Path; 352 Newpath2 (Newpath2'Last) := ASCII.NUL; 353 354 Maj_Ver (1 .. Maj_Version'Length) := Maj_Version; 355 Maj_Ver (Maj_Ver'Last) := ASCII.NUL; 356 357 Delete_File (Maj_Path, Success); 358 359 Result := Symlink (Version_Path (1)'Address, Newpath2'Address); 360 361 Delete_File (Lib_Path, Success); 362 363 Result := Symlink (Maj_Ver'Address, Newpath1'Address); 364 end; 365 end if; 366 end Create_Sym_Links; 367 368 -------------------------------- 369 -- Linker_Library_Path_Option -- 370 -------------------------------- 371 372 function Linker_Library_Path_Option return String_Access is 373 374 Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr; 375 pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option"); 376 -- Pointer to string representing the native linker option which 377 -- specifies the path where the dynamic loader should find shared 378 -- libraries. Equal to null string if this system doesn't support it. 379 380 S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr); 381 382 begin 383 if S'Length = 0 then 384 return null; 385 else 386 return new String'(S); 387 end if; 388 end Linker_Library_Path_Option; 389 390 ------------------- 391 -- Major_Id_Name -- 392 ------------------- 393 394 function Major_Id_Name 395 (Lib_Filename : String; 396 Lib_Version : String) 397 return String 398 is 399 Maj_Version : constant String := Lib_Version; 400 Last_Maj : Positive; 401 Last : Positive; 402 Ok_Maj : Boolean := False; 403 404 begin 405 Last_Maj := Maj_Version'Last; 406 while Last_Maj > Maj_Version'First loop 407 if Maj_Version (Last_Maj) in '0' .. '9' then 408 Last_Maj := Last_Maj - 1; 409 410 else 411 Ok_Maj := Last_Maj /= Maj_Version'Last and then 412 Maj_Version (Last_Maj) = '.'; 413 414 if Ok_Maj then 415 Last_Maj := Last_Maj - 1; 416 end if; 417 418 exit; 419 end if; 420 end loop; 421 422 if Ok_Maj then 423 Last := Last_Maj; 424 while Last > Maj_Version'First loop 425 if Maj_Version (Last) in '0' .. '9' then 426 Last := Last - 1; 427 428 else 429 Ok_Maj := Last /= Last_Maj and then 430 Maj_Version (Last) = '.'; 431 432 if Ok_Maj then 433 Last := Last - 1; 434 Ok_Maj := 435 Maj_Version (Maj_Version'First .. Last) = Lib_Filename; 436 end if; 437 438 exit; 439 end if; 440 end loop; 441 end if; 442 443 if Ok_Maj then 444 return Maj_Version (Maj_Version'First .. Last_Maj); 445 else 446 return ""; 447 end if; 448 end Major_Id_Name; 449 450 ------------------------------- 451 -- Separate_Run_Path_Options -- 452 ------------------------------- 453 454 function Separate_Run_Path_Options return Boolean is 455 Separate_Paths : Boolean; 456 for Separate_Paths'Size use Character'Size; 457 pragma Import (C, Separate_Paths, "__gnat_separate_run_path_options"); 458 begin 459 return Separate_Paths; 460 end Separate_Run_Path_Options; 461 462-- Package elaboration 463 464begin 465 -- Copy_Attributes always fails on VMS 466 467 if Hostparm.OpenVMS then 468 Preserve := None; 469 end if; 470end MLib; 471