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