1------------------------------------------------------------------------------ 2-- -- 3-- GPR PROJECT MANAGER -- 4-- -- 5-- Copyright (C) 2001-2016, Free Software Foundation, Inc. -- 6-- -- 7-- This library is free software; you can redistribute it and/or modify it -- 8-- under terms of the GNU General Public License as published by the Free -- 9-- Software Foundation; either version 3, or (at your option) any later -- 10-- version. This library is distributed in the hope that it will be useful, -- 11-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 12-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 13-- -- 14-- As a special exception under Section 7 of GPL version 3, you are granted -- 15-- additional permissions described in the GCC Runtime Library Exception, -- 16-- version 3.1, as published by the Free Software Foundation. -- 17-- -- 18-- You should have received a copy of the GNU General Public License and -- 19-- a copy of the GCC Runtime Library Exception along with this program; -- 20-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 21-- <http://www.gnu.org/licenses/>. -- 22-- -- 23------------------------------------------------------------------------------ 24 25with Ada.Command_Line; use Ada.Command_Line; 26with Ada.Directories; use Ada.Directories; 27 28with GNAT.Case_Util; use GNAT.Case_Util; 29 30with System.CRTL; 31 32with GPR.Names; use GPR.Names; 33with GPR.Output; use GPR.Output; 34 35package body GPR.Osint is 36 37 Current_Full_Lib_Name : File_Name_Type := No_File; 38 39 function File_Length 40 (Name : C_File_Name; 41 Attr : access File_Attributes) return Long_Integer; 42 -- Return the length (number of bytes) of the file 43 44 procedure Find_File 45 (N : File_Name_Type; 46 Found : out File_Name_Type; 47 Attr : access File_Attributes); 48 49 function Is_Regular_File 50 (Name : C_File_Name; 51 Attr : access File_Attributes) return Boolean; 52 53 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type; 54 55 ------------------------------ 56 -- Canonical_Case_File_Name -- 57 ------------------------------ 58 59 procedure Canonical_Case_File_Name (S : in out String) is 60 begin 61 if not File_Names_Case_Sensitive then 62 To_Lower (S); 63 end if; 64 end Canonical_Case_File_Name; 65 66 --------------------------------- 67 -- Canonical_Case_Env_Var_Name -- 68 --------------------------------- 69 70 procedure Canonical_Case_Env_Var_Name (S : in out String) is 71 begin 72 if not Env_Vars_Case_Sensitive then 73 To_Lower (S); 74 end if; 75 end Canonical_Case_Env_Var_Name; 76 77 --------------------- 78 -- Executable_Name -- 79 --------------------- 80 81 function Executable_Name 82 (Name : File_Name_Type; 83 Only_If_No_Suffix : Boolean := False) return File_Name_Type 84 is 85 Exec_Suffix : String_Access; 86 Add_Suffix : Boolean; 87 88 begin 89 if Name = No_File then 90 return No_File; 91 end if; 92 93 if Executable_Extension_On_Target = No_Name then 94 Exec_Suffix := Get_Target_Executable_Suffix; 95 else 96 Get_Name_String (Executable_Extension_On_Target); 97 Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); 98 end if; 99 100 if Exec_Suffix'Length /= 0 then 101 Get_Name_String (Name); 102 103 Add_Suffix := True; 104 if Only_If_No_Suffix then 105 for J in reverse 1 .. Name_Len loop 106 if Name_Buffer (J) = '.' then 107 Add_Suffix := False; 108 exit; 109 end if; 110 111 exit when Is_Directory_Separator (Name_Buffer (J)); 112 end loop; 113 end if; 114 115 if Add_Suffix then 116 declare 117 Buffer : String := Name_Buffer (1 .. Name_Len); 118 119 begin 120 -- Get the file name in canonical case to accept as is. Names 121 -- end with ".EXE" on Windows. 122 123 Canonical_Case_File_Name (Buffer); 124 125 -- If Executable doesn't end with the executable suffix, add it 126 127 if Buffer'Length <= Exec_Suffix'Length 128 or else 129 Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last) 130 /= Exec_Suffix.all 131 then 132 Name_Buffer 133 (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) := 134 Exec_Suffix.all; 135 Name_Len := Name_Len + Exec_Suffix'Length; 136 Free (Exec_Suffix); 137 return Name_Find; 138 end if; 139 end; 140 end if; 141 end if; 142 143 Free (Exec_Suffix); 144 return Name; 145 end Executable_Name; 146 147 ------------------ 148 -- Exit_Program -- 149 ------------------ 150 151 procedure Exit_Program (Exit_Code : Exit_Code_Type) is 152 begin 153 -- The program will exit with the following status: 154 155 -- 0 if the object file has been generated (with or without warnings) 156 -- 1 if recompilation was not needed (smart recompilation) 157 -- 2 if gnat1 has been killed by a signal (detected by GCC) 158 -- 4 for a fatal error 159 -- 5 if there were errors 160 -- 6 if no code has been generated (spec) 161 162 -- Note that exit code 3 is not used and must not be used as this is 163 -- the code returned by a program aborted via C abort() routine on 164 -- Windows. GCC checks for that case and thinks that the child process 165 -- has been aborted. This code (exit code 3) used to be the code used 166 -- for E_No_Code, but E_No_Code was changed to 6 for this reason. 167 168 case Exit_Code is 169 when E_Success => OS_Exit (0); 170 when E_Warnings => OS_Exit (0); 171 when E_No_Compile => OS_Exit (1); 172 when E_Fatal => OS_Exit (4); 173 when E_Errors => OS_Exit (5); 174 when E_No_Code => OS_Exit (6); 175 when E_Abort => OS_Abort; 176 end case; 177 end Exit_Program; 178 179 ---------- 180 -- Fail -- 181 ---------- 182 183 procedure Fail (S : String) is 184 Fatal_Exit : constant := 4; 185 begin 186 Set_Standard_Error; 187 Write_Str (Simple_Name (Command_Name)); 188 Write_Str (": "); 189 Write_Line (S); 190 191 OS_Exit (Fatal_Exit); 192 end Fail; 193 194 ----------------- 195 -- File_Length -- 196 ----------------- 197 198 function File_Length 199 (Name : C_File_Name; 200 Attr : access File_Attributes) return Long_Integer 201 is 202 function Internal 203 (F : Integer; 204 N : C_File_Name; 205 A : System.Address) return System.CRTL.int64; 206 pragma Import (C, Internal, "__gnat_file_length_attr"); 207 208 begin 209 -- The conversion from int64 to Long_Integer is ok here as this 210 -- routine is only to be used by the compiler and we do not expect 211 -- a unit to be larger than a 32bit integer. 212 213 return Long_Integer (Internal (-1, Name, Attr.all'Address)); 214 end File_Length; 215 216 ---------------- 217 -- File_Stamp -- 218 ---------------- 219 220 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is 221 begin 222 if Name = No_File then 223 return Empty_Time_Stamp; 224 end if; 225 226 Get_Name_String (Name); 227 228 -- File_Time_Stamp will always return Invalid_Time if the file does 229 -- not exist, and OS_Time_To_GNAT_Time will convert this value to 230 -- Empty_Time_Stamp. Therefore we do not need to first test whether 231 -- the file actually exists, which saves a system call. 232 233 return OS_Time_To_GNAT_Time 234 (File_Time_Stamp (Name_Buffer (1 .. Name_Len))); 235 end File_Stamp; 236 237 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is 238 begin 239 return File_Stamp (File_Name_Type (Name)); 240 end File_Stamp; 241 242 --------------------- 243 -- File_Time_Stamp -- 244 --------------------- 245 246 function File_Time_Stamp 247 (Name : C_File_Name; 248 Attr : access File_Attributes) return OS_Time 249 is 250 function Internal (N : C_File_Name; A : System.Address) return OS_Time; 251 pragma Import (C, Internal, "__gnat_file_time_name_attr"); 252 begin 253 return Internal (Name, Attr.all'Address); 254 end File_Time_Stamp; 255 256 function File_Time_Stamp 257 (Name : Path_Name_Type; 258 Attr : access File_Attributes) return Time_Stamp_Type 259 is 260 begin 261 if Name = No_Path then 262 return Empty_Time_Stamp; 263 end if; 264 265 Get_Name_String (Name); 266 Name_Buffer (Name_Len + 1) := ASCII.NUL; 267 return OS_Time_To_GNAT_Time 268 (File_Time_Stamp (Name_Buffer'Address, Attr)); 269 end File_Time_Stamp; 270 271 --------------- 272 -- Find_File -- 273 --------------- 274 275 procedure Find_File 276 (N : File_Name_Type; 277 Found : out File_Name_Type; 278 Attr : access File_Attributes) 279 is 280 begin 281 Attr.all := Unknown_Attributes; 282 Get_Name_String (N); 283 Name_Buffer (Name_Len + 1) := ASCII.NUL; 284 285 if not Is_Regular_File (Name_Buffer (1)'Address, Attr) then 286 Found := No_File; 287 Attr.all := Unknown_Attributes; 288 289 else 290 Found := N; 291 end if; 292 end Find_File; 293 294 ------------------- 295 -- Get_Directory -- 296 ------------------- 297 298 function Get_Directory (Name : File_Name_Type) return File_Name_Type is 299 begin 300 Get_Name_String (Name); 301 302 for J in reverse 1 .. Name_Len loop 303 if Is_Directory_Separator (Name_Buffer (J)) then 304 Name_Len := J; 305 return Name_Find; 306 end if; 307 end loop; 308 309 Name_Len := 2; 310 Name_Buffer (1) := '.'; 311 Name_Buffer (2) := Directory_Separator; 312 return Name_Find; 313 end Get_Directory; 314 315 ---------------------------- 316 -- Is_Directory_Separator -- 317 ---------------------------- 318 319 function Is_Directory_Separator (C : Character) return Boolean is 320 begin 321 return C = Directory_Separator or else C = '/'; 322 end Is_Directory_Separator; 323 324 --------------------- 325 -- Is_Regular_File -- 326 --------------------- 327 328 function Is_Regular_File 329 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 330 is 331 function Internal (N : C_File_Name; A : System.Address) return Integer; 332 pragma Import (C, Internal, "__gnat_is_regular_file_attr"); 333 begin 334 return Internal (Name, Attr.all'Address) /= 0; 335 end Is_Regular_File; 336 337 -------------------------- 338 -- OS_Time_To_GNAT_Time -- 339 -------------------------- 340 341 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is 342 TS : Time_Stamp_Type; 343 344 Y : Year_Type; 345 Mo : Month_Type; 346 D : Day_Type; 347 H : Hour_Type; 348 Mn : Minute_Type; 349 S : Second_Type; 350 351 Z : constant := Character'Pos ('0'); 352 353 begin 354 if T = Invalid_Time then 355 return Empty_Time_Stamp; 356 end if; 357 358 GM_Split (T, Y, Mo, D, H, Mn, S); 359 360 TS (01) := Character'Val (Z + Y / 1000); 361 TS (02) := Character'Val (Z + (Y / 100) mod 10); 362 TS (03) := Character'Val (Z + (Y / 10) mod 10); 363 TS (04) := Character'Val (Z + Y mod 10); 364 TS (05) := Character'Val (Z + Mo / 10); 365 TS (06) := Character'Val (Z + Mo mod 10); 366 TS (07) := Character'Val (Z + D / 10); 367 TS (08) := Character'Val (Z + D mod 10); 368 TS (09) := Character'Val (Z + H / 10); 369 TS (10) := Character'Val (Z + H mod 10); 370 TS (11) := Character'Val (Z + Mn / 10); 371 TS (12) := Character'Val (Z + Mn mod 10); 372 TS (13) := Character'Val (Z + S / 10); 373 TS (14) := Character'Val (Z + S mod 10); 374 375 return TS; 376 end OS_Time_To_GNAT_Time; 377 378 ----------------------- 379 -- Read_Library_Info -- 380 ----------------------- 381 382 function Read_Library_Info 383 (Lib_File : File_Name_Type; 384 Fatal_Err : Boolean := False) return Text_Buffer_Ptr 385 is 386 File : File_Name_Type; 387 Attr : aliased File_Attributes; 388 begin 389 Find_File (Lib_File, File, Attr'Access); 390 return Read_Library_Info_From_Full 391 (Full_Lib_File => File, 392 Lib_File_Attr => Attr'Access, 393 Fatal_Err => Fatal_Err); 394 end Read_Library_Info; 395 396 --------------------------------- 397 -- Read_Library_Info_From_Full -- 398 --------------------------------- 399 400 function Read_Library_Info_From_Full 401 (Full_Lib_File : File_Name_Type; 402 Lib_File_Attr : access File_Attributes; 403 Fatal_Err : Boolean := False) return Text_Buffer_Ptr 404 is 405 Lib_FD : File_Descriptor; 406 -- The file descriptor for the current library file. A negative value 407 -- indicates failure to open the specified source file. 408 409 Len : Integer; 410 -- Length of source file text (ALI). If it doesn't fit in an integer 411 -- we're probably stuck anyway (>2 gigs of source seems a lot, and 412 -- there are other places in the compiler that make this assumption). 413 414 Text : Text_Buffer_Ptr; 415 -- Allocated text buffer 416 417 Status : Boolean; 418 pragma Warnings (Off, Status); 419 -- For the calls to Close 420 421 begin 422 Current_Full_Lib_Name := Full_Lib_File; 423 424 if Current_Full_Lib_Name = No_File then 425 if Fatal_Err then 426 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); 427 else 428 return null; 429 end if; 430 end if; 431 432 Get_Name_String (Current_Full_Lib_Name); 433 Name_Buffer (Name_Len + 1) := ASCII.NUL; 434 435 -- Open the library FD, note that we open in binary mode, because as 436 -- documented in the spec, the caller is expected to handle either 437 -- DOS or Unix mode files, and there is no point in wasting time on 438 -- text translation when it is not required. 439 440 Lib_FD := Open_Read (Name_Buffer'Address, Binary); 441 442 if Lib_FD = Invalid_FD then 443 if Fatal_Err then 444 Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len)); 445 else 446 return null; 447 end if; 448 end if; 449 450 -- Compute the length of the file (potentially also preparing other data 451 -- like the timestamp and whether the file is read-only, for future use) 452 453 Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr)); 454 455 -- Read data from the file 456 457 declare 458 Actual_Len : Integer := 0; 459 460 Lo : constant Text_Ptr := 0; 461 -- Low bound for allocated text buffer 462 463 Hi : Text_Ptr := Text_Ptr (Len); 464 -- High bound for allocated text buffer. Note length is Len + 1 465 -- which allows for extra EOF character at the end of the buffer. 466 467 begin 468 -- Allocate text buffer. Note extra character at end for EOF 469 470 Text := new Text_Buffer (Lo .. Hi); 471 472 -- Some systems have file types that require one read per line, 473 -- so read until we get the Len bytes or until there are no more 474 -- characters. 475 476 Hi := Lo; 477 loop 478 Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len); 479 Hi := Hi + Text_Ptr (Actual_Len); 480 exit when Actual_Len = Len or else Actual_Len <= 0; 481 end loop; 482 483 Text (Hi) := EOF; 484 end; 485 486 -- Read is complete, close file and we are done 487 488 Close (Lib_FD, Status); 489 -- The status should never be False. But, if it is, what can we do? 490 -- So, we don't test it. 491 492 return Text; 493 494 end Read_Library_Info_From_Full; 495 496 ------------------ 497 -- Strip_Suffix -- 498 ------------------ 499 500 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is 501 begin 502 Get_Name_String (Name); 503 504 for J in reverse 2 .. Name_Len loop 505 506 -- If we found the last '.', return part of Name that precedes it 507 508 if Name_Buffer (J) = '.' then 509 Name_Len := J - 1; 510 return File_Name_Type (Name_Enter); 511 end if; 512 end loop; 513 514 return Name; 515 end Strip_Suffix; 516 517---------------------------- 518-- Package Initialization -- 519---------------------------- 520 521 procedure Reset_File_Attributes (Attr : System.Address); 522 pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes"); 523 524begin 525 Reset_File_Attributes (Unknown_Attributes'Address); 526end GPR.Osint; 527