1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- O S I N T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- 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 Alloc; 27with Debug; 28with Fmap; use Fmap; 29with Gnatvsn; use Gnatvsn; 30with Hostparm; 31with Opt; use Opt; 32with Output; use Output; 33with Sdefault; use Sdefault; 34with Table; 35with Targparm; use Targparm; 36 37with Unchecked_Conversion; 38 39pragma Warnings (Off); 40-- This package is used also by gnatcoll 41with System.Case_Util; use System.Case_Util; 42with System.CRTL; 43pragma Warnings (On); 44 45with GNAT.HTable; 46 47package body Osint is 48 49 use type CRTL.size_t; 50 51 Running_Program : Program_Type := Unspecified; 52 -- comment required here ??? 53 54 Program_Set : Boolean := False; 55 -- comment required here ??? 56 57 Std_Prefix : String_Ptr; 58 -- Standard prefix, computed dynamically the first time Relocate_Path 59 -- is called, and cached for subsequent calls. 60 61 Empty : aliased String := ""; 62 No_Dir : constant String_Ptr := Empty'Access; 63 -- Used in Locate_File as a fake directory when Name is already an 64 -- absolute path. 65 66 ------------------------------------- 67 -- Use of Name_Find and Name_Enter -- 68 ------------------------------------- 69 70 -- This package creates a number of source, ALI and object file names 71 -- that are used to locate the actual file and for the purpose of message 72 -- construction. These names need not be accessible by Name_Find, and can 73 -- be therefore created by using routine Name_Enter. The files in question 74 -- are file names with a prefix directory (i.e., the files not in the 75 -- current directory). File names without a prefix directory are entered 76 -- with Name_Find because special values might be attached to the various 77 -- Info fields of the corresponding name table entry. 78 79 ----------------------- 80 -- Local Subprograms -- 81 ----------------------- 82 83 function Append_Suffix_To_File_Name 84 (Name : File_Name_Type; 85 Suffix : String) return File_Name_Type; 86 -- Appends Suffix to Name and returns the new name 87 88 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type; 89 -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time, 90 -- then returns Empty_Time_Stamp. 91 -- Round to even seconds on Windows before conversion. 92 -- Windows ALI files had timestamps rounded to even seconds historically. 93 -- The rounding was originally done in GM_Split. Now that GM_Split no 94 -- longer does it, we are rounding it here only for ALI files. 95 96 function Executable_Prefix return String_Ptr; 97 -- Returns the name of the root directory where the executable is stored. 98 -- The executable must be located in a directory called "bin", or under 99 -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if 100 -- executable is stored in directory "/foo/bar/bin", this routine returns 101 -- "/foo/bar/". Return "" if location is not recognized as described above. 102 103 function Update_Path (Path : String_Ptr) return String_Ptr; 104 -- Update the specified path to replace the prefix with the location where 105 -- GNAT is installed. See the file prefix.c in GCC for details. 106 107 procedure Locate_File 108 (N : File_Name_Type; 109 T : File_Type; 110 Dir : Natural; 111 Name : String; 112 Found : out File_Name_Type; 113 Attr : access File_Attributes); 114 -- See if the file N whose name is Name exists in directory Dir. Dir is an 115 -- index into the Lib_Search_Directories table if T = Library. Otherwise 116 -- if T = Source, Dir is an index into the Src_Search_Directories table. 117 -- Returns the File_Name_Type of the full file name if file found, or 118 -- No_File if not found. 119 -- 120 -- On exit, Found is set to the file that was found, and Attr to a cache of 121 -- its attributes (at least those that have been computed so far). Reusing 122 -- the cache will save some system calls. 123 -- 124 -- Attr is always reset in this call to Unknown_Attributes, even in case of 125 -- failure 126 127 procedure Find_File 128 (N : File_Name_Type; 129 T : File_Type; 130 Found : out File_Name_Type; 131 Attr : access File_Attributes; 132 Full_Name : Boolean := False); 133 -- A version of Find_File that also returns a cache of the file attributes 134 -- for later reuse 135 136 procedure Smart_Find_File 137 (N : File_Name_Type; 138 T : File_Type; 139 Found : out File_Name_Type; 140 Attr : out File_Attributes); 141 -- A version of Smart_Find_File that also returns a cache of the file 142 -- attributes for later reuse 143 144 function C_String_Length (S : Address) return CRTL.size_t; 145 -- Returns length of a C string (zero for a null address) 146 147 function To_Path_String_Access 148 (Path_Addr : Address; 149 Path_Len : CRTL.size_t) return String_Access; 150 -- Converts a C String to an Ada String. Are we doing this to avoid withing 151 -- Interfaces.C.Strings ??? 152 -- Caller must free result. 153 154 function Include_Dir_Default_Prefix return String_Access; 155 -- Same as exported version, except returns a String_Access 156 157 ------------------------------ 158 -- Other Local Declarations -- 159 ------------------------------ 160 161 EOL : constant Character := ASCII.LF; 162 -- End of line character 163 164 Number_File_Names : Nat := 0; 165 -- Number of file names found on command line and placed in File_Names 166 167 Look_In_Primary_Directory_For_Current_Main : Boolean := False; 168 -- When this variable is True, Find_File only looks in Primary_Directory 169 -- for the Current_Main file. This variable is always set to True for the 170 -- compiler. It is also True for gnatmake, when the source name given on 171 -- the command line has directory information. 172 173 Current_Full_Source_Name : File_Name_Type := No_File; 174 Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp; 175 Current_Full_Lib_Name : File_Name_Type := No_File; 176 Current_Full_Lib_Stamp : Time_Stamp_Type := Empty_Time_Stamp; 177 Current_Full_Obj_Name : File_Name_Type := No_File; 178 Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp; 179 -- Respectively full name (with directory info) and time stamp of the 180 -- latest source, library and object files opened by Read_Source_File and 181 -- Read_Library_Info. 182 183 package File_Name_Chars is new Table.Table ( 184 Table_Component_Type => Character, 185 Table_Index_Type => Int, 186 Table_Low_Bound => 1, 187 Table_Initial => Alloc.File_Name_Chars_Initial, 188 Table_Increment => Alloc.File_Name_Chars_Increment, 189 Table_Name => "File_Name_Chars"); 190 -- Table to store text to be printed by Dump_Source_File_Names 191 192 The_Include_Dir_Default_Prefix : String_Access := null; 193 -- Value returned by Include_Dir_Default_Prefix. We don't initialize it 194 -- here, because that causes an elaboration cycle with Sdefault; we 195 -- initialize it lazily instead. 196 197 ------------------ 198 -- Search Paths -- 199 ------------------ 200 201 Primary_Directory : constant := 0; 202 -- This is index in the tables created below for the first directory to 203 -- search in for source or library information files. This is the directory 204 -- containing the latest main input file (a source file for the compiler or 205 -- a library file for the binder). 206 207 package Src_Search_Directories is new Table.Table ( 208 Table_Component_Type => String_Ptr, 209 Table_Index_Type => Integer, 210 Table_Low_Bound => Primary_Directory, 211 Table_Initial => 10, 212 Table_Increment => 100, 213 Table_Name => "Osint.Src_Search_Directories"); 214 -- Table of names of directories in which to search for source (Compiler) 215 -- files. This table is filled in the order in which the directories are 216 -- to be searched, and then used in that order. 217 218 package Lib_Search_Directories is new Table.Table ( 219 Table_Component_Type => String_Ptr, 220 Table_Index_Type => Integer, 221 Table_Low_Bound => Primary_Directory, 222 Table_Initial => 10, 223 Table_Increment => 100, 224 Table_Name => "Osint.Lib_Search_Directories"); 225 -- Table of names of directories in which to search for library (Binder) 226 -- files. This table is filled in the order in which the directories are 227 -- to be searched and then used in that order. The reason for having two 228 -- distinct tables is that we need them both in gnatmake. 229 230 --------------------- 231 -- File Hash Table -- 232 --------------------- 233 234 -- The file hash table is provided to free the programmer from any 235 -- efficiency concern when retrieving full file names or time stamps of 236 -- source files. If the programmer calls Source_File_Data (Cache => True) 237 -- he is guaranteed that the price to retrieve the full name (i.e. with 238 -- directory info) or time stamp of the file will be payed only once, the 239 -- first time the full name is actually searched (or the first time the 240 -- time stamp is actually retrieved). This is achieved by employing a hash 241 -- table that stores as a key the File_Name_Type of the file and associates 242 -- to that File_Name_Type the full file name and time stamp of the file. 243 244 File_Cache_Enabled : Boolean := False; 245 -- Set to true if you want the enable the file data caching mechanism 246 247 type File_Hash_Num is range 0 .. 1020; 248 249 function File_Hash (F : File_Name_Type) return File_Hash_Num; 250 -- Compute hash index for use by Simple_HTable 251 252 type File_Info_Cache is record 253 File : File_Name_Type; 254 Attr : aliased File_Attributes; 255 end record; 256 257 No_File_Info_Cache : constant File_Info_Cache := (No_File, (others => 0)); 258 259 package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable ( 260 Header_Num => File_Hash_Num, 261 Element => File_Info_Cache, 262 No_Element => No_File_Info_Cache, 263 Key => File_Name_Type, 264 Hash => File_Hash, 265 Equal => "="); 266 267 function Smart_Find_File 268 (N : File_Name_Type; 269 T : File_Type) return File_Name_Type; 270 -- Exactly like Find_File except that if File_Cache_Enabled is True this 271 -- routine looks first in the hash table to see if the full name of the 272 -- file is already available. 273 274 function Smart_File_Stamp 275 (N : File_Name_Type; 276 T : File_Type) return Time_Stamp_Type; 277 -- Takes the same parameter as the routine above (N is a file name without 278 -- any prefix directory information) and behaves like File_Stamp except 279 -- that if File_Cache_Enabled is True this routine looks first in the hash 280 -- table to see if the file stamp of the file is already available. 281 282 ----------------------------- 283 -- Add_Default_Search_Dirs -- 284 ----------------------------- 285 286 procedure Add_Default_Search_Dirs is 287 Search_Dir : String_Access; 288 Search_Path : String_Access; 289 Path_File_Name : String_Access; 290 291 procedure Add_Search_Dir 292 (Search_Dir : String; 293 Additional_Source_Dir : Boolean); 294 procedure Add_Search_Dir 295 (Search_Dir : String_Access; 296 Additional_Source_Dir : Boolean); 297 -- Add a source search dir or a library search dir, depending on the 298 -- value of Additional_Source_Dir. 299 300 procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean); 301 -- Open a path file and read the directory to search, one per line 302 303 function Get_Libraries_From_Registry return String_Ptr; 304 -- On Windows systems, get the list of installed standard libraries 305 -- from the registry key: 306 -- 307 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\ 308 -- GNAT\Standard Libraries 309 -- Return an empty string on other systems. 310 -- 311 -- Note that this is an undocumented legacy feature, and that it 312 -- works only when using the default runtime library (i.e. no --RTS= 313 -- command line switch). 314 315 -------------------- 316 -- Add_Search_Dir -- 317 -------------------- 318 319 procedure Add_Search_Dir 320 (Search_Dir : String; 321 Additional_Source_Dir : Boolean) 322 is 323 begin 324 if Additional_Source_Dir then 325 Add_Src_Search_Dir (Search_Dir); 326 else 327 Add_Lib_Search_Dir (Search_Dir); 328 end if; 329 end Add_Search_Dir; 330 331 procedure Add_Search_Dir 332 (Search_Dir : String_Access; 333 Additional_Source_Dir : Boolean) 334 is 335 begin 336 if Additional_Source_Dir then 337 Add_Src_Search_Dir (Search_Dir.all); 338 else 339 Add_Lib_Search_Dir (Search_Dir.all); 340 end if; 341 end Add_Search_Dir; 342 343 ------------------------ 344 -- Get_Dirs_From_File -- 345 ------------------------ 346 347 procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is 348 File_FD : File_Descriptor; 349 Buffer : constant String := Path_File_Name.all & ASCII.NUL; 350 Len : Natural; 351 Actual_Len : Natural; 352 S : String_Access; 353 Curr : Natural; 354 First : Natural; 355 Ch : Character; 356 357 Status : Boolean; 358 pragma Warnings (Off, Status); 359 -- For the call to Close where status is ignored 360 361 begin 362 File_FD := Open_Read (Buffer'Address, Binary); 363 364 -- If we cannot open the file, we ignore it, we don't fail 365 366 if File_FD = Invalid_FD then 367 return; 368 end if; 369 370 Len := Integer (File_Length (File_FD)); 371 372 S := new String (1 .. Len); 373 374 -- Read the file. Note that the loop is probably not necessary any 375 -- more since the whole file is read in at once on all targets. But 376 -- it is harmless and might be needed in future. 377 378 Curr := 1; 379 Actual_Len := Len; 380 while Curr <= Len and then Actual_Len /= 0 loop 381 Actual_Len := Read (File_FD, S (Curr)'Address, Len); 382 Curr := Curr + Actual_Len; 383 end loop; 384 385 -- We are done with the file, so we close it (ignore any error on 386 -- the close, since we have successfully read the file). 387 388 Close (File_FD, Status); 389 390 -- Now, we read line by line 391 392 First := 1; 393 Curr := 0; 394 while Curr < Len loop 395 Ch := S (Curr + 1); 396 397 if Ch = ASCII.CR or else Ch = ASCII.LF 398 or else Ch = ASCII.FF or else Ch = ASCII.VT 399 then 400 if First <= Curr then 401 Add_Search_Dir (S (First .. Curr), Additional_Source_Dir); 402 end if; 403 404 First := Curr + 2; 405 end if; 406 407 Curr := Curr + 1; 408 end loop; 409 410 -- Last line is a special case, if the file does not end with 411 -- an end of line mark. 412 413 if First <= S'Last then 414 Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir); 415 end if; 416 end Get_Dirs_From_File; 417 418 --------------------------------- 419 -- Get_Libraries_From_Registry -- 420 --------------------------------- 421 422 function Get_Libraries_From_Registry return String_Ptr is 423 function C_Get_Libraries_From_Registry return Address; 424 pragma Import (C, C_Get_Libraries_From_Registry, 425 "__gnat_get_libraries_from_registry"); 426 427 Result_Ptr : Address; 428 Result_Length : CRTL.size_t; 429 Out_String : String_Ptr; 430 431 begin 432 Result_Ptr := C_Get_Libraries_From_Registry; 433 Result_Length := CRTL.strlen (Result_Ptr); 434 435 Out_String := new String (1 .. Integer (Result_Length)); 436 CRTL.strncpy (Out_String.all'Address, Result_Ptr, Result_Length); 437 438 CRTL.free (Result_Ptr); 439 440 return Out_String; 441 end Get_Libraries_From_Registry; 442 443 -- Start of processing for Add_Default_Search_Dirs 444 445 begin 446 -- If there was a -gnateO switch, add all object directories from the 447 -- file given in argument to the library search list. 448 449 if Object_Path_File_Name /= null then 450 Path_File_Name := String_Access (Object_Path_File_Name); 451 pragma Assert (Path_File_Name'Length > 0); 452 Get_Dirs_From_File (Additional_Source_Dir => False); 453 end if; 454 455 -- After the locations specified on the command line, the next places 456 -- to look for files are the directories specified by the appropriate 457 -- environment variable. Get this value, extract the directory names 458 -- and store in the tables. 459 460 -- Check for eventual project path file env vars 461 462 Path_File_Name := Getenv (Project_Include_Path_File); 463 464 if Path_File_Name'Length > 0 then 465 Get_Dirs_From_File (Additional_Source_Dir => True); 466 end if; 467 468 Path_File_Name := Getenv (Project_Objects_Path_File); 469 470 if Path_File_Name'Length > 0 then 471 Get_Dirs_From_File (Additional_Source_Dir => False); 472 end if; 473 474 -- Put path name in canonical form 475 476 for Additional_Source_Dir in False .. True loop 477 if Additional_Source_Dir then 478 Search_Path := Getenv (Ada_Include_Path); 479 480 else 481 Search_Path := Getenv (Ada_Objects_Path); 482 483 end if; 484 485 Get_Next_Dir_In_Path_Init (Search_Path); 486 loop 487 Search_Dir := Get_Next_Dir_In_Path (Search_Path); 488 exit when Search_Dir = null; 489 Add_Search_Dir (Search_Dir, Additional_Source_Dir); 490 end loop; 491 end loop; 492 493 -- For the compiler, if --RTS= was specified, add the runtime 494 -- directories. 495 496 if RTS_Src_Path_Name /= null and then RTS_Lib_Path_Name /= null then 497 Add_Search_Dirs (RTS_Src_Path_Name, Include); 498 Add_Search_Dirs (RTS_Lib_Path_Name, Objects); 499 500 else 501 if not Opt.No_Stdinc then 502 503 -- For WIN32 systems, look for any system libraries defined in 504 -- the registry. These are added to both source and object 505 -- directories. 506 507 Search_Path := String_Access (Get_Libraries_From_Registry); 508 509 Get_Next_Dir_In_Path_Init (Search_Path); 510 loop 511 Search_Dir := Get_Next_Dir_In_Path (Search_Path); 512 exit when Search_Dir = null; 513 Add_Search_Dir (Search_Dir, False); 514 Add_Search_Dir (Search_Dir, True); 515 end loop; 516 517 -- The last place to look are the defaults 518 519 Search_Path := 520 Read_Default_Search_Dirs 521 (String_Access (Update_Path (Search_Dir_Prefix)), 522 Include_Search_File, 523 String_Access (Update_Path (Include_Dir_Default_Name))); 524 525 Get_Next_Dir_In_Path_Init (Search_Path); 526 loop 527 Search_Dir := Get_Next_Dir_In_Path (Search_Path); 528 exit when Search_Dir = null; 529 Add_Search_Dir (Search_Dir, True); 530 end loop; 531 end if; 532 533 -- Even when -nostdlib is used, we still want to have visibility on 534 -- the run-time object directory, as it is used by gnatbind to find 535 -- the run-time ALI files in "real" ZFP set up. 536 537 if not Opt.RTS_Switch then 538 Search_Path := 539 Read_Default_Search_Dirs 540 (String_Access (Update_Path (Search_Dir_Prefix)), 541 Objects_Search_File, 542 String_Access (Update_Path (Object_Dir_Default_Name))); 543 544 Get_Next_Dir_In_Path_Init (Search_Path); 545 loop 546 Search_Dir := Get_Next_Dir_In_Path (Search_Path); 547 exit when Search_Dir = null; 548 Add_Search_Dir (Search_Dir, False); 549 end loop; 550 end if; 551 end if; 552 end Add_Default_Search_Dirs; 553 554 -------------- 555 -- Add_File -- 556 -------------- 557 558 procedure Add_File (File_Name : String; Index : Int := No_Index) is 559 begin 560 Number_File_Names := Number_File_Names + 1; 561 562 -- As Add_File may be called for mains specified inside a project file, 563 -- File_Names may be too short and needs to be extended. 564 565 if Number_File_Names > File_Names'Last then 566 File_Names := new File_Name_Array'(File_Names.all & File_Names.all); 567 File_Indexes := 568 new File_Index_Array'(File_Indexes.all & File_Indexes.all); 569 end if; 570 571 File_Names (Number_File_Names) := new String'(File_Name); 572 File_Indexes (Number_File_Names) := Index; 573 end Add_File; 574 575 ------------------------ 576 -- Add_Lib_Search_Dir -- 577 ------------------------ 578 579 procedure Add_Lib_Search_Dir (Dir : String) is 580 begin 581 if Dir'Length = 0 then 582 Fail ("missing library directory name"); 583 end if; 584 585 declare 586 Norm : String_Ptr := Normalize_Directory_Name (Dir); 587 588 begin 589 -- Do nothing if the directory is already in the list. This saves 590 -- system calls and avoid unneeded work 591 592 for D in Lib_Search_Directories.First .. 593 Lib_Search_Directories.Last 594 loop 595 if Lib_Search_Directories.Table (D).all = Norm.all then 596 Free (Norm); 597 return; 598 end if; 599 end loop; 600 601 Lib_Search_Directories.Increment_Last; 602 Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm; 603 end; 604 end Add_Lib_Search_Dir; 605 606 --------------------- 607 -- Add_Search_Dirs -- 608 --------------------- 609 610 procedure Add_Search_Dirs 611 (Search_Path : String_Ptr; 612 Path_Type : Search_File_Type) 613 is 614 Current_Search_Path : String_Access; 615 616 begin 617 Get_Next_Dir_In_Path_Init (String_Access (Search_Path)); 618 loop 619 Current_Search_Path := 620 Get_Next_Dir_In_Path (String_Access (Search_Path)); 621 exit when Current_Search_Path = null; 622 623 if Path_Type = Include then 624 Add_Src_Search_Dir (Current_Search_Path.all); 625 else 626 Add_Lib_Search_Dir (Current_Search_Path.all); 627 end if; 628 end loop; 629 end Add_Search_Dirs; 630 631 ------------------------ 632 -- Add_Src_Search_Dir -- 633 ------------------------ 634 635 procedure Add_Src_Search_Dir (Dir : String) is 636 begin 637 if Dir'Length = 0 then 638 Fail ("missing source directory name"); 639 end if; 640 641 Src_Search_Directories.Increment_Last; 642 Src_Search_Directories.Table (Src_Search_Directories.Last) := 643 Normalize_Directory_Name (Dir); 644 end Add_Src_Search_Dir; 645 646 -------------------------------- 647 -- Append_Suffix_To_File_Name -- 648 -------------------------------- 649 650 function Append_Suffix_To_File_Name 651 (Name : File_Name_Type; 652 Suffix : String) return File_Name_Type 653 is 654 begin 655 Get_Name_String (Name); 656 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; 657 Name_Len := Name_Len + Suffix'Length; 658 return Name_Find; 659 end Append_Suffix_To_File_Name; 660 661 --------------------- 662 -- C_String_Length -- 663 --------------------- 664 665 function C_String_Length (S : Address) return CRTL.size_t is 666 begin 667 if S = Null_Address then 668 return 0; 669 else 670 return CRTL.strlen (S); 671 end if; 672 end C_String_Length; 673 674 ------------------------------ 675 -- Canonical_Case_File_Name -- 676 ------------------------------ 677 678 procedure Canonical_Case_File_Name (S : in out String) is 679 begin 680 if not File_Names_Case_Sensitive then 681 To_Lower (S); 682 end if; 683 end Canonical_Case_File_Name; 684 685 --------------------------------- 686 -- Canonical_Case_Env_Var_Name -- 687 --------------------------------- 688 689 procedure Canonical_Case_Env_Var_Name (S : in out String) is 690 begin 691 if not Env_Vars_Case_Sensitive then 692 To_Lower (S); 693 end if; 694 end Canonical_Case_Env_Var_Name; 695 696 --------------------------- 697 -- Create_File_And_Check -- 698 --------------------------- 699 700 procedure Create_File_And_Check 701 (Fdesc : out File_Descriptor; 702 Fmode : Mode) 703 is 704 begin 705 Output_File_Name := Name_Enter; 706 Fdesc := Create_File (Name_Buffer'Address, Fmode); 707 708 if Fdesc = Invalid_FD then 709 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len)); 710 end if; 711 end Create_File_And_Check; 712 713 ----------------------------------- 714 -- Open_File_To_Append_And_Check -- 715 ----------------------------------- 716 717 procedure Open_File_To_Append_And_Check 718 (Fdesc : out File_Descriptor; 719 Fmode : Mode) 720 is 721 begin 722 Output_File_Name := Name_Enter; 723 Fdesc := Open_Append (Name_Buffer'Address, Fmode); 724 725 if Fdesc = Invalid_FD then 726 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len)); 727 end if; 728 end Open_File_To_Append_And_Check; 729 730 ------------------------ 731 -- Current_File_Index -- 732 ------------------------ 733 734 function Current_File_Index return Int is 735 begin 736 return File_Indexes (Current_File_Name_Index); 737 end Current_File_Index; 738 739 -------------------------------- 740 -- Current_Library_File_Stamp -- 741 -------------------------------- 742 743 function Current_Library_File_Stamp return Time_Stamp_Type is 744 begin 745 return Current_Full_Lib_Stamp; 746 end Current_Library_File_Stamp; 747 748 ------------------------------- 749 -- Current_Object_File_Stamp -- 750 ------------------------------- 751 752 function Current_Object_File_Stamp return Time_Stamp_Type is 753 begin 754 return Current_Full_Obj_Stamp; 755 end Current_Object_File_Stamp; 756 757 ------------------------------- 758 -- Current_Source_File_Stamp -- 759 ------------------------------- 760 761 function Current_Source_File_Stamp return Time_Stamp_Type is 762 begin 763 return Current_Full_Source_Stamp; 764 end Current_Source_File_Stamp; 765 766 ---------------------------- 767 -- Dir_In_Obj_Search_Path -- 768 ---------------------------- 769 770 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is 771 begin 772 if Opt.Look_In_Primary_Dir then 773 return 774 Lib_Search_Directories.Table (Primary_Directory + Position - 1); 775 else 776 return Lib_Search_Directories.Table (Primary_Directory + Position); 777 end if; 778 end Dir_In_Obj_Search_Path; 779 780 ---------------------------- 781 -- Dir_In_Src_Search_Path -- 782 ---------------------------- 783 784 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is 785 begin 786 if Opt.Look_In_Primary_Dir then 787 return 788 Src_Search_Directories.Table (Primary_Directory + Position - 1); 789 else 790 return Src_Search_Directories.Table (Primary_Directory + Position); 791 end if; 792 end Dir_In_Src_Search_Path; 793 794 ----------------------------------------- 795 -- Dump_Command_Line_Source_File_Names -- 796 ----------------------------------------- 797 798 procedure Dump_Command_Line_Source_File_Names is 799 begin 800 for J in 1 .. Number_Of_Files loop 801 Write_Str (File_Names (J).all & " "); 802 end loop; 803 end Dump_Command_Line_Source_File_Names; 804 805 ---------------------------- 806 -- Dump_Source_File_Names -- 807 ---------------------------- 808 809 procedure Dump_Source_File_Names is 810 subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last; 811 begin 812 Write_Str (String (File_Name_Chars.Table (Rng))); 813 end Dump_Source_File_Names; 814 815 --------------------- 816 -- Executable_Name -- 817 --------------------- 818 819 function Executable_Name 820 (Name : File_Name_Type; 821 Only_If_No_Suffix : Boolean := False) return File_Name_Type 822 is 823 Exec_Suffix : String_Access; 824 Add_Suffix : Boolean; 825 826 begin 827 if Name = No_File then 828 return No_File; 829 end if; 830 831 if Executable_Extension_On_Target = No_Name then 832 Exec_Suffix := Get_Target_Executable_Suffix; 833 else 834 Get_Name_String (Executable_Extension_On_Target); 835 Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); 836 end if; 837 838 if Exec_Suffix'Length /= 0 then 839 Get_Name_String (Name); 840 841 Add_Suffix := True; 842 if Only_If_No_Suffix then 843 for J in reverse 1 .. Name_Len loop 844 if Name_Buffer (J) = '.' then 845 Add_Suffix := False; 846 exit; 847 848 elsif Is_Directory_Separator (Name_Buffer (J)) then 849 exit; 850 end if; 851 end loop; 852 end if; 853 854 if Add_Suffix then 855 declare 856 Buffer : String := Name_Buffer (1 .. Name_Len); 857 858 begin 859 -- Get the file name in canonical case to accept as is. Names 860 -- end with ".EXE" on Windows. 861 862 Canonical_Case_File_Name (Buffer); 863 864 -- If Executable doesn't end with the executable suffix, add it 865 866 if Buffer'Length <= Exec_Suffix'Length 867 or else 868 Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last) 869 /= Exec_Suffix.all 870 then 871 Name_Buffer 872 (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) := 873 Exec_Suffix.all; 874 Name_Len := Name_Len + Exec_Suffix'Length; 875 Free (Exec_Suffix); 876 return Name_Find; 877 end if; 878 end; 879 end if; 880 end if; 881 882 Free (Exec_Suffix); 883 return Name; 884 end Executable_Name; 885 886 function Executable_Name 887 (Name : String; 888 Only_If_No_Suffix : Boolean := False) return String 889 is 890 Exec_Suffix : String_Access; 891 Add_Suffix : Boolean; 892 Canonical_Name : String := Name; 893 894 begin 895 if Executable_Extension_On_Target = No_Name then 896 Exec_Suffix := Get_Target_Executable_Suffix; 897 else 898 Get_Name_String (Executable_Extension_On_Target); 899 Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); 900 end if; 901 902 if Exec_Suffix'Length = 0 then 903 Free (Exec_Suffix); 904 return Name; 905 906 else 907 declare 908 Suffix : constant String := Exec_Suffix.all; 909 910 begin 911 Free (Exec_Suffix); 912 Canonical_Case_File_Name (Canonical_Name); 913 914 Add_Suffix := True; 915 if Only_If_No_Suffix then 916 for J in reverse Canonical_Name'Range loop 917 if Canonical_Name (J) = '.' then 918 Add_Suffix := False; 919 exit; 920 921 elsif Is_Directory_Separator (Canonical_Name (J)) then 922 exit; 923 end if; 924 end loop; 925 end if; 926 927 if Add_Suffix and then 928 (Canonical_Name'Length <= Suffix'Length 929 or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1 930 .. Canonical_Name'Last) /= Suffix) 931 then 932 declare 933 Result : String (1 .. Name'Length + Suffix'Length); 934 begin 935 Result (1 .. Name'Length) := Name; 936 Result (Name'Length + 1 .. Result'Last) := Suffix; 937 return Result; 938 end; 939 else 940 return Name; 941 end if; 942 end; 943 end if; 944 end Executable_Name; 945 946 ----------------------- 947 -- Executable_Prefix -- 948 ----------------------- 949 950 function Executable_Prefix return String_Ptr is 951 952 function Get_Install_Dir (Exec : String) return String_Ptr; 953 -- S is the executable name preceded by the absolute or relative 954 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc". 955 956 --------------------- 957 -- Get_Install_Dir -- 958 --------------------- 959 960 function Get_Install_Dir (Exec : String) return String_Ptr is 961 Full_Path : constant String := Normalize_Pathname (Exec); 962 -- Use the full path, so that we find "lib" or "bin", even when 963 -- the tool has been invoked with a relative path, as in 964 -- "./gnatls -v" invoked in the GNAT bin directory. 965 966 begin 967 for J in reverse Full_Path'Range loop 968 if Is_Directory_Separator (Full_Path (J)) then 969 if J < Full_Path'Last - 5 then 970 if (To_Lower (Full_Path (J + 1)) = 'l' 971 and then To_Lower (Full_Path (J + 2)) = 'i' 972 and then To_Lower (Full_Path (J + 3)) = 'b') 973 or else 974 (To_Lower (Full_Path (J + 1)) = 'b' 975 and then To_Lower (Full_Path (J + 2)) = 'i' 976 and then To_Lower (Full_Path (J + 3)) = 'n') 977 then 978 return new String'(Full_Path (Full_Path'First .. J)); 979 end if; 980 end if; 981 end if; 982 end loop; 983 984 return new String'(""); 985 end Get_Install_Dir; 986 987 -- Start of processing for Executable_Prefix 988 989 begin 990 if Exec_Name = null then 991 Exec_Name := new String (1 .. Len_Arg (0)); 992 Osint.Fill_Arg (Exec_Name (1)'Address, 0); 993 end if; 994 995 -- First determine if a path prefix was placed in front of the 996 -- executable name. 997 998 for J in reverse Exec_Name'Range loop 999 if Is_Directory_Separator (Exec_Name (J)) then 1000 return Get_Install_Dir (Exec_Name.all); 1001 end if; 1002 end loop; 1003 1004 -- If we come here, the user has typed the executable name with no 1005 -- directory prefix. 1006 1007 return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all); 1008 end Executable_Prefix; 1009 1010 ------------------ 1011 -- Exit_Program -- 1012 ------------------ 1013 1014 procedure Exit_Program (Exit_Code : Exit_Code_Type) is 1015 begin 1016 -- The program will exit with the following status: 1017 1018 -- 0 if the object file has been generated (with or without warnings) 1019 -- 1 if recompilation was not needed (smart recompilation) 1020 -- 2 if gnat1 has been killed by a signal (detected by GCC) 1021 -- 4 for a fatal error 1022 -- 5 if there were errors 1023 -- 6 if no code has been generated (spec) 1024 1025 -- Note that exit code 3 is not used and must not be used as this is 1026 -- the code returned by a program aborted via C abort() routine on 1027 -- Windows. GCC checks for that case and thinks that the child process 1028 -- has been aborted. This code (exit code 3) used to be the code used 1029 -- for E_No_Code, but E_No_Code was changed to 6 for this reason. 1030 1031 case Exit_Code is 1032 when E_Success => OS_Exit (0); 1033 when E_Warnings => OS_Exit (0); 1034 when E_No_Compile => OS_Exit (1); 1035 when E_Fatal => OS_Exit (4); 1036 when E_Errors => OS_Exit (5); 1037 when E_No_Code => OS_Exit (6); 1038 when E_Abort => OS_Abort; 1039 end case; 1040 end Exit_Program; 1041 1042 ---------- 1043 -- Fail -- 1044 ---------- 1045 1046 procedure Fail (S : String) is 1047 begin 1048 -- We use Output in case there is a special output set up. In this case 1049 -- Set_Standard_Error will have no immediate effect. 1050 1051 Set_Standard_Error; 1052 Osint.Write_Program_Name; 1053 Write_Str (": "); 1054 Write_Str (S); 1055 Write_Eol; 1056 1057 Exit_Program (E_Fatal); 1058 end Fail; 1059 1060 --------------- 1061 -- File_Hash -- 1062 --------------- 1063 1064 function File_Hash (F : File_Name_Type) return File_Hash_Num is 1065 begin 1066 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length); 1067 end File_Hash; 1068 1069 ----------------- 1070 -- File_Length -- 1071 ----------------- 1072 1073 function File_Length 1074 (Name : C_File_Name; 1075 Attr : access File_Attributes) return Long_Integer 1076 is 1077 function Internal 1078 (F : Integer; 1079 N : C_File_Name; 1080 A : System.Address) return CRTL.int64; 1081 pragma Import (C, Internal, "__gnat_file_length_attr"); 1082 1083 begin 1084 -- The conversion from int64 to Long_Integer is ok here as this 1085 -- routine is only to be used by the compiler and we do not expect 1086 -- a unit to be larger than a 32bit integer. 1087 1088 return Long_Integer (Internal (-1, Name, Attr.all'Address)); 1089 end File_Length; 1090 1091 --------------------- 1092 -- File_Time_Stamp -- 1093 --------------------- 1094 1095 function File_Time_Stamp 1096 (Name : C_File_Name; 1097 Attr : access File_Attributes) return OS_Time 1098 is 1099 function Internal (N : C_File_Name; A : System.Address) return OS_Time; 1100 pragma Import (C, Internal, "__gnat_file_time_name_attr"); 1101 begin 1102 return Internal (Name, Attr.all'Address); 1103 end File_Time_Stamp; 1104 1105 function File_Time_Stamp 1106 (Name : Path_Name_Type; 1107 Attr : access File_Attributes) return Time_Stamp_Type 1108 is 1109 begin 1110 if Name = No_Path then 1111 return Empty_Time_Stamp; 1112 end if; 1113 1114 Get_Name_String (Name); 1115 Name_Buffer (Name_Len + 1) := ASCII.NUL; 1116 return OS_Time_To_GNAT_Time 1117 (File_Time_Stamp (Name_Buffer'Address, Attr)); 1118 end File_Time_Stamp; 1119 1120 ---------------- 1121 -- File_Stamp -- 1122 ---------------- 1123 1124 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is 1125 begin 1126 if Name = No_File then 1127 return Empty_Time_Stamp; 1128 end if; 1129 1130 Get_Name_String (Name); 1131 1132 -- File_Time_Stamp will always return Invalid_Time if the file does 1133 -- not exist, and OS_Time_To_GNAT_Time will convert this value to 1134 -- Empty_Time_Stamp. Therefore we do not need to first test whether 1135 -- the file actually exists, which saves a system call. 1136 1137 return OS_Time_To_GNAT_Time 1138 (File_Time_Stamp (Name_Buffer (1 .. Name_Len))); 1139 end File_Stamp; 1140 1141 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is 1142 begin 1143 return File_Stamp (File_Name_Type (Name)); 1144 end File_Stamp; 1145 1146 --------------- 1147 -- Find_File -- 1148 --------------- 1149 1150 function Find_File 1151 (N : File_Name_Type; 1152 T : File_Type; 1153 Full_Name : Boolean := False) return File_Name_Type 1154 is 1155 Attr : aliased File_Attributes; 1156 Found : File_Name_Type; 1157 begin 1158 Find_File (N, T, Found, Attr'Access, Full_Name); 1159 return Found; 1160 end Find_File; 1161 1162 --------------- 1163 -- Find_File -- 1164 --------------- 1165 1166 procedure Find_File 1167 (N : File_Name_Type; 1168 T : File_Type; 1169 Found : out File_Name_Type; 1170 Attr : access File_Attributes; 1171 Full_Name : Boolean := False) 1172 is 1173 begin 1174 Get_Name_String (N); 1175 1176 declare 1177 File_Name : String renames Name_Buffer (1 .. Name_Len); 1178 File : File_Name_Type := No_File; 1179 Last_Dir : Natural; 1180 1181 begin 1182 -- If we are looking for a config file, look only in the current 1183 -- directory, i.e. return input argument unchanged. Also look only in 1184 -- the current directory if we are looking for a .dg file (happens in 1185 -- -gnatD mode). 1186 1187 if T = Config 1188 or else (Debug_Generated_Code 1189 and then Name_Len > 3 1190 and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg") 1191 then 1192 Found := N; 1193 Attr.all := Unknown_Attributes; 1194 1195 if T = Config then 1196 if Full_Name then 1197 declare 1198 Full_Path : constant String := 1199 Normalize_Pathname (Get_Name_String (N)); 1200 Full_Size : constant Natural := Full_Path'Length; 1201 1202 begin 1203 Name_Buffer (1 .. Full_Size) := Full_Path; 1204 Name_Len := Full_Size; 1205 Found := Name_Find; 1206 end; 1207 end if; 1208 1209 -- Check that it is a file, not a directory 1210 1211 if not Is_Regular_File (Get_Name_String (Found)) then 1212 Found := No_File; 1213 end if; 1214 end if; 1215 1216 return; 1217 1218 -- If we are trying to find the current main file just look in the 1219 -- directory where the user said it was. 1220 1221 elsif Look_In_Primary_Directory_For_Current_Main 1222 and then Current_Main = N 1223 then 1224 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr); 1225 return; 1226 1227 -- Otherwise do standard search for source file 1228 1229 else 1230 -- Check the mapping of this file name 1231 1232 File := Mapped_Path_Name (N); 1233 1234 -- If the file name is mapped to a path name, return the 1235 -- corresponding path name 1236 1237 if File /= No_File then 1238 1239 -- For locally removed file, Error_Name is returned; then 1240 -- return No_File, indicating the file is not a source. 1241 1242 if File = Error_File_Name then 1243 Found := No_File; 1244 else 1245 Found := File; 1246 end if; 1247 1248 Attr.all := Unknown_Attributes; 1249 return; 1250 end if; 1251 1252 -- First place to look is in the primary directory (i.e. the same 1253 -- directory as the source) unless this has been disabled with -I- 1254 1255 if Opt.Look_In_Primary_Dir then 1256 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr); 1257 1258 if Found /= No_File then 1259 return; 1260 end if; 1261 end if; 1262 1263 -- Finally look in directories specified with switches -I/-aI/-aO 1264 1265 if T = Library then 1266 Last_Dir := Lib_Search_Directories.Last; 1267 else 1268 Last_Dir := Src_Search_Directories.Last; 1269 end if; 1270 1271 for D in Primary_Directory + 1 .. Last_Dir loop 1272 Locate_File (N, T, D, File_Name, Found, Attr); 1273 1274 if Found /= No_File then 1275 return; 1276 end if; 1277 end loop; 1278 1279 Attr.all := Unknown_Attributes; 1280 Found := No_File; 1281 end if; 1282 end; 1283 end Find_File; 1284 1285 ----------------------- 1286 -- Find_Program_Name -- 1287 ----------------------- 1288 1289 procedure Find_Program_Name is 1290 Command_Name : String (1 .. Len_Arg (0)); 1291 Cindex1 : Integer := Command_Name'First; 1292 Cindex2 : Integer := Command_Name'Last; 1293 1294 begin 1295 Fill_Arg (Command_Name'Address, 0); 1296 1297 if Command_Name = "" then 1298 Name_Len := 0; 1299 return; 1300 end if; 1301 1302 -- The program name might be specified by a full path name. However, 1303 -- we don't want to print that all out in an error message, so the 1304 -- path might need to be stripped away. 1305 1306 for J in reverse Cindex1 .. Cindex2 loop 1307 if Is_Directory_Separator (Command_Name (J)) then 1308 Cindex1 := J + 1; 1309 exit; 1310 end if; 1311 end loop; 1312 1313 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the 1314 -- POSIX command "basename argv[0]" 1315 1316 -- Strip off any executable extension (usually nothing or .exe) 1317 -- but formally reported by autoconf in the variable EXEEXT 1318 1319 if Cindex2 - Cindex1 >= 4 then 1320 if To_Lower (Command_Name (Cindex2 - 3)) = '.' 1321 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e' 1322 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x' 1323 and then To_Lower (Command_Name (Cindex2)) = 'e' 1324 then 1325 Cindex2 := Cindex2 - 4; 1326 end if; 1327 end if; 1328 1329 Name_Len := Cindex2 - Cindex1 + 1; 1330 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2); 1331 end Find_Program_Name; 1332 1333 ------------------------ 1334 -- Full_Lib_File_Name -- 1335 ------------------------ 1336 1337 procedure Full_Lib_File_Name 1338 (N : File_Name_Type; 1339 Lib_File : out File_Name_Type; 1340 Attr : out File_Attributes) 1341 is 1342 A : aliased File_Attributes; 1343 begin 1344 -- ??? seems we could use Smart_Find_File here 1345 Find_File (N, Library, Lib_File, A'Access); 1346 Attr := A; 1347 end Full_Lib_File_Name; 1348 1349 ------------------------ 1350 -- Full_Lib_File_Name -- 1351 ------------------------ 1352 1353 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is 1354 Attr : File_Attributes; 1355 File : File_Name_Type; 1356 begin 1357 Full_Lib_File_Name (N, File, Attr); 1358 return File; 1359 end Full_Lib_File_Name; 1360 1361 ---------------------------- 1362 -- Full_Library_Info_Name -- 1363 ---------------------------- 1364 1365 function Full_Library_Info_Name return File_Name_Type is 1366 begin 1367 return Current_Full_Lib_Name; 1368 end Full_Library_Info_Name; 1369 1370 --------------------------- 1371 -- Full_Object_File_Name -- 1372 --------------------------- 1373 1374 function Full_Object_File_Name return File_Name_Type is 1375 begin 1376 return Current_Full_Obj_Name; 1377 end Full_Object_File_Name; 1378 1379 ---------------------- 1380 -- Full_Source_Name -- 1381 ---------------------- 1382 1383 function Full_Source_Name return File_Name_Type is 1384 begin 1385 return Current_Full_Source_Name; 1386 end Full_Source_Name; 1387 1388 ---------------------- 1389 -- Full_Source_Name -- 1390 ---------------------- 1391 1392 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is 1393 begin 1394 return Smart_Find_File (N, Source); 1395 end Full_Source_Name; 1396 1397 ---------------------- 1398 -- Full_Source_Name -- 1399 ---------------------- 1400 1401 procedure Full_Source_Name 1402 (N : File_Name_Type; 1403 Full_File : out File_Name_Type; 1404 Attr : access File_Attributes) is 1405 begin 1406 Smart_Find_File (N, Source, Full_File, Attr.all); 1407 end Full_Source_Name; 1408 1409 ------------------- 1410 -- Get_Directory -- 1411 ------------------- 1412 1413 function Get_Directory (Name : File_Name_Type) return File_Name_Type is 1414 begin 1415 Get_Name_String (Name); 1416 1417 for J in reverse 1 .. Name_Len loop 1418 if Is_Directory_Separator (Name_Buffer (J)) then 1419 Name_Len := J; 1420 return Name_Find; 1421 end if; 1422 end loop; 1423 1424 Name_Len := Hostparm.Normalized_CWD'Length; 1425 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD; 1426 return Name_Find; 1427 end Get_Directory; 1428 1429 ------------------------------ 1430 -- Get_First_Main_File_Name -- 1431 ------------------------------ 1432 1433 function Get_First_Main_File_Name return String is 1434 begin 1435 return File_Names (1).all; 1436 end Get_First_Main_File_Name; 1437 1438 -------------------------- 1439 -- Get_Next_Dir_In_Path -- 1440 -------------------------- 1441 1442 Search_Path_Pos : Integer; 1443 -- Keeps track of current position in search path. Initialized by the 1444 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path. 1445 1446 function Get_Next_Dir_In_Path 1447 (Search_Path : String_Access) return String_Access 1448 is 1449 Lower_Bound : Positive := Search_Path_Pos; 1450 Upper_Bound : Positive; 1451 1452 begin 1453 loop 1454 while Lower_Bound <= Search_Path'Last 1455 and then Search_Path.all (Lower_Bound) = Path_Separator 1456 loop 1457 Lower_Bound := Lower_Bound + 1; 1458 end loop; 1459 1460 exit when Lower_Bound > Search_Path'Last; 1461 1462 Upper_Bound := Lower_Bound; 1463 while Upper_Bound <= Search_Path'Last 1464 and then Search_Path.all (Upper_Bound) /= Path_Separator 1465 loop 1466 Upper_Bound := Upper_Bound + 1; 1467 end loop; 1468 1469 Search_Path_Pos := Upper_Bound; 1470 return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1)); 1471 end loop; 1472 1473 return null; 1474 end Get_Next_Dir_In_Path; 1475 1476 ------------------------------- 1477 -- Get_Next_Dir_In_Path_Init -- 1478 ------------------------------- 1479 1480 procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is 1481 begin 1482 Search_Path_Pos := Search_Path'First; 1483 end Get_Next_Dir_In_Path_Init; 1484 1485 -------------------------------------- 1486 -- Get_Primary_Src_Search_Directory -- 1487 -------------------------------------- 1488 1489 function Get_Primary_Src_Search_Directory return String_Ptr is 1490 begin 1491 return Src_Search_Directories.Table (Primary_Directory); 1492 end Get_Primary_Src_Search_Directory; 1493 1494 ------------------------ 1495 -- Get_RTS_Search_Dir -- 1496 ------------------------ 1497 1498 function Get_RTS_Search_Dir 1499 (Search_Dir : String; 1500 File_Type : Search_File_Type) return String_Ptr 1501 is 1502 procedure Get_Current_Dir 1503 (Dir : System.Address; 1504 Length : System.Address); 1505 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); 1506 1507 Max_Path : Integer; 1508 pragma Import (C, Max_Path, "__gnat_max_path_len"); 1509 -- Maximum length of a path name 1510 1511 Current_Dir : String_Ptr; 1512 Default_Search_Dir : String_Access; 1513 Default_Suffix_Dir : String_Access; 1514 Local_Search_Dir : String_Access; 1515 Norm_Search_Dir : String_Access; 1516 Result_Search_Dir : String_Access; 1517 Search_File : String_Access; 1518 Temp_String : String_Ptr; 1519 1520 begin 1521 -- Add a directory separator at the end of the directory if necessary 1522 -- so that we can directly append a file to the directory 1523 1524 if not Is_Directory_Separator (Search_Dir (Search_Dir'Last)) then 1525 Local_Search_Dir := 1526 new String'(Search_Dir & String'(1 => Directory_Separator)); 1527 else 1528 Local_Search_Dir := new String'(Search_Dir); 1529 end if; 1530 1531 if File_Type = Include then 1532 Search_File := Include_Search_File; 1533 Default_Suffix_Dir := new String'("adainclude"); 1534 else 1535 Search_File := Objects_Search_File; 1536 Default_Suffix_Dir := new String'("adalib"); 1537 end if; 1538 1539 Norm_Search_Dir := Local_Search_Dir; 1540 1541 if Is_Absolute_Path (Norm_Search_Dir.all) then 1542 1543 -- We first verify if there is a directory Include_Search_Dir 1544 -- containing default search directories 1545 1546 Result_Search_Dir := 1547 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); 1548 Default_Search_Dir := 1549 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); 1550 Free (Norm_Search_Dir); 1551 1552 if Result_Search_Dir /= null then 1553 return String_Ptr (Result_Search_Dir); 1554 elsif Is_Directory (Default_Search_Dir.all) then 1555 return String_Ptr (Default_Search_Dir); 1556 else 1557 return null; 1558 end if; 1559 1560 -- Search in the current directory 1561 1562 else 1563 -- Get the current directory 1564 1565 declare 1566 Buffer : String (1 .. Max_Path + 2); 1567 Path_Len : Natural := Max_Path; 1568 1569 begin 1570 Get_Current_Dir (Buffer'Address, Path_Len'Address); 1571 1572 if Path_Len = 0 then 1573 raise Program_Error; 1574 end if; 1575 1576 if not Is_Directory_Separator (Buffer (Path_Len)) then 1577 Path_Len := Path_Len + 1; 1578 Buffer (Path_Len) := Directory_Separator; 1579 end if; 1580 1581 Current_Dir := new String'(Buffer (1 .. Path_Len)); 1582 end; 1583 1584 Norm_Search_Dir := 1585 new String'(Current_Dir.all & Local_Search_Dir.all); 1586 1587 Result_Search_Dir := 1588 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); 1589 1590 Default_Search_Dir := 1591 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); 1592 1593 Free (Norm_Search_Dir); 1594 1595 if Result_Search_Dir /= null then 1596 return String_Ptr (Result_Search_Dir); 1597 1598 elsif Is_Directory (Default_Search_Dir.all) then 1599 return String_Ptr (Default_Search_Dir); 1600 1601 else 1602 -- Search in Search_Dir_Prefix/Search_Dir 1603 1604 Norm_Search_Dir := 1605 new String' 1606 (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all); 1607 1608 Result_Search_Dir := 1609 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); 1610 1611 Default_Search_Dir := 1612 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); 1613 1614 Free (Norm_Search_Dir); 1615 1616 if Result_Search_Dir /= null then 1617 return String_Ptr (Result_Search_Dir); 1618 1619 elsif Is_Directory (Default_Search_Dir.all) then 1620 return String_Ptr (Default_Search_Dir); 1621 1622 else 1623 -- We finally search in Search_Dir_Prefix/rts-Search_Dir 1624 1625 Temp_String := 1626 new String'(Update_Path (Search_Dir_Prefix).all & "rts-"); 1627 1628 Norm_Search_Dir := 1629 new String'(Temp_String.all & Local_Search_Dir.all); 1630 1631 Result_Search_Dir := 1632 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); 1633 1634 Default_Search_Dir := 1635 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); 1636 Free (Norm_Search_Dir); 1637 1638 if Result_Search_Dir /= null then 1639 return String_Ptr (Result_Search_Dir); 1640 1641 elsif Is_Directory (Default_Search_Dir.all) then 1642 return String_Ptr (Default_Search_Dir); 1643 1644 else 1645 return null; 1646 end if; 1647 end if; 1648 end if; 1649 end if; 1650 end Get_RTS_Search_Dir; 1651 1652 -------------------------------- 1653 -- Include_Dir_Default_Prefix -- 1654 -------------------------------- 1655 1656 function Include_Dir_Default_Prefix return String_Access is 1657 begin 1658 if The_Include_Dir_Default_Prefix = null then 1659 The_Include_Dir_Default_Prefix := 1660 String_Access (Update_Path (Include_Dir_Default_Name)); 1661 end if; 1662 1663 return The_Include_Dir_Default_Prefix; 1664 end Include_Dir_Default_Prefix; 1665 1666 function Include_Dir_Default_Prefix return String is 1667 begin 1668 return Include_Dir_Default_Prefix.all; 1669 end Include_Dir_Default_Prefix; 1670 1671 ---------------- 1672 -- Initialize -- 1673 ---------------- 1674 1675 procedure Initialize is 1676 begin 1677 Number_File_Names := 0; 1678 Current_File_Name_Index := 0; 1679 1680 Src_Search_Directories.Init; 1681 Lib_Search_Directories.Init; 1682 1683 -- Start off by setting all suppress options, to False. The special 1684 -- overflow fields are set to Not_Set (they will be set by -gnatp, or 1685 -- by -gnato, or, if neither of these appear, in Adjust_Global_Switches 1686 -- in Gnat1drv). 1687 1688 Suppress_Options := ((others => False), Not_Set, Not_Set); 1689 1690 -- Reserve the first slot in the search paths table. This is the 1691 -- directory of the main source file or main library file and is filled 1692 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the 1693 -- directory specified for this main source or library file. This is the 1694 -- directory which is searched first by default. This default search is 1695 -- inhibited by the option -I- for both source and library files. 1696 1697 Src_Search_Directories.Set_Last (Primary_Directory); 1698 Src_Search_Directories.Table (Primary_Directory) := new String'(""); 1699 1700 Lib_Search_Directories.Set_Last (Primary_Directory); 1701 Lib_Search_Directories.Table (Primary_Directory) := new String'(""); 1702 end Initialize; 1703 1704 ------------------ 1705 -- Is_Directory -- 1706 ------------------ 1707 1708 function Is_Directory 1709 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1710 is 1711 function Internal (N : C_File_Name; A : System.Address) return Integer; 1712 pragma Import (C, Internal, "__gnat_is_directory_attr"); 1713 begin 1714 return Internal (Name, Attr.all'Address) /= 0; 1715 end Is_Directory; 1716 1717 ---------------------------- 1718 -- Is_Directory_Separator -- 1719 ---------------------------- 1720 1721 function Is_Directory_Separator (C : Character) return Boolean is 1722 begin 1723 -- In addition to the default directory_separator allow the '/' to 1724 -- act as separator since this is allowed in MS-DOS and Windows. 1725 1726 return C = Directory_Separator or else C = '/'; 1727 end Is_Directory_Separator; 1728 1729 ------------------------- 1730 -- Is_Readonly_Library -- 1731 ------------------------- 1732 1733 function Is_Readonly_Library (File : File_Name_Type) return Boolean is 1734 begin 1735 Get_Name_String (File); 1736 1737 pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali"); 1738 1739 return not Is_Writable_File (Name_Buffer (1 .. Name_Len)); 1740 end Is_Readonly_Library; 1741 1742 ------------------------ 1743 -- Is_Executable_File -- 1744 ------------------------ 1745 1746 function Is_Executable_File 1747 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1748 is 1749 function Internal (N : C_File_Name; A : System.Address) return Integer; 1750 pragma Import (C, Internal, "__gnat_is_executable_file_attr"); 1751 begin 1752 return Internal (Name, Attr.all'Address) /= 0; 1753 end Is_Executable_File; 1754 1755 ---------------------- 1756 -- Is_Readable_File -- 1757 ---------------------- 1758 1759 function Is_Readable_File 1760 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1761 is 1762 function Internal (N : C_File_Name; A : System.Address) return Integer; 1763 pragma Import (C, Internal, "__gnat_is_readable_file_attr"); 1764 begin 1765 return Internal (Name, Attr.all'Address) /= 0; 1766 end Is_Readable_File; 1767 1768 --------------------- 1769 -- Is_Regular_File -- 1770 --------------------- 1771 1772 function Is_Regular_File 1773 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1774 is 1775 function Internal (N : C_File_Name; A : System.Address) return Integer; 1776 pragma Import (C, Internal, "__gnat_is_regular_file_attr"); 1777 begin 1778 return Internal (Name, Attr.all'Address) /= 0; 1779 end Is_Regular_File; 1780 1781 ---------------------- 1782 -- Is_Symbolic_Link -- 1783 ---------------------- 1784 1785 function Is_Symbolic_Link 1786 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1787 is 1788 function Internal (N : C_File_Name; A : System.Address) return Integer; 1789 pragma Import (C, Internal, "__gnat_is_symbolic_link_attr"); 1790 begin 1791 return Internal (Name, Attr.all'Address) /= 0; 1792 end Is_Symbolic_Link; 1793 1794 ---------------------- 1795 -- Is_Writable_File -- 1796 ---------------------- 1797 1798 function Is_Writable_File 1799 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1800 is 1801 function Internal (N : C_File_Name; A : System.Address) return Integer; 1802 pragma Import (C, Internal, "__gnat_is_writable_file_attr"); 1803 begin 1804 return Internal (Name, Attr.all'Address) /= 0; 1805 end Is_Writable_File; 1806 1807 ------------------- 1808 -- Lib_File_Name -- 1809 ------------------- 1810 1811 function Lib_File_Name 1812 (Source_File : File_Name_Type; 1813 Munit_Index : Nat := 0) return File_Name_Type 1814 is 1815 begin 1816 Get_Name_String (Source_File); 1817 1818 for J in reverse 2 .. Name_Len loop 1819 if Name_Buffer (J) = '.' then 1820 Name_Len := J - 1; 1821 exit; 1822 end if; 1823 end loop; 1824 1825 if Munit_Index /= 0 then 1826 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); 1827 Add_Nat_To_Name_Buffer (Munit_Index); 1828 end if; 1829 1830 Add_Char_To_Name_Buffer ('.'); 1831 Add_Str_To_Name_Buffer (ALI_Suffix.all); 1832 return Name_Find; 1833 end Lib_File_Name; 1834 1835 ----------------- 1836 -- Locate_File -- 1837 ----------------- 1838 1839 procedure Locate_File 1840 (N : File_Name_Type; 1841 T : File_Type; 1842 Dir : Natural; 1843 Name : String; 1844 Found : out File_Name_Type; 1845 Attr : access File_Attributes) 1846 is 1847 Dir_Name : String_Ptr; 1848 1849 begin 1850 -- If Name is already an absolute path, do not look for a directory 1851 1852 if Is_Absolute_Path (Name) then 1853 Dir_Name := No_Dir; 1854 1855 elsif T = Library then 1856 Dir_Name := Lib_Search_Directories.Table (Dir); 1857 1858 else 1859 pragma Assert (T /= Config); 1860 Dir_Name := Src_Search_Directories.Table (Dir); 1861 end if; 1862 1863 declare 1864 Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1); 1865 1866 begin 1867 Full_Name (1 .. Dir_Name'Length) := Dir_Name.all; 1868 Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name; 1869 Full_Name (Full_Name'Last) := ASCII.NUL; 1870 1871 Attr.all := Unknown_Attributes; 1872 1873 if not Is_Regular_File (Full_Name'Address, Attr) then 1874 Found := No_File; 1875 1876 else 1877 -- If the file is in the current directory then return N itself 1878 1879 if Dir_Name'Length = 0 then 1880 Found := N; 1881 else 1882 Name_Len := Full_Name'Length - 1; 1883 Name_Buffer (1 .. Name_Len) := 1884 Full_Name (1 .. Full_Name'Last - 1); 1885 Found := Name_Find; -- ??? Was Name_Enter, no obvious reason 1886 end if; 1887 end if; 1888 end; 1889 end Locate_File; 1890 1891 ------------------------------- 1892 -- Matching_Full_Source_Name -- 1893 ------------------------------- 1894 1895 function Matching_Full_Source_Name 1896 (N : File_Name_Type; 1897 T : Time_Stamp_Type) return File_Name_Type 1898 is 1899 begin 1900 Get_Name_String (N); 1901 1902 declare 1903 File_Name : constant String := Name_Buffer (1 .. Name_Len); 1904 File : File_Name_Type := No_File; 1905 Attr : aliased File_Attributes; 1906 Last_Dir : Natural; 1907 1908 begin 1909 if Opt.Look_In_Primary_Dir then 1910 Locate_File 1911 (N, Source, Primary_Directory, File_Name, File, Attr'Access); 1912 1913 if File /= No_File and then T = File_Stamp (N) then 1914 return File; 1915 end if; 1916 end if; 1917 1918 Last_Dir := Src_Search_Directories.Last; 1919 1920 for D in Primary_Directory + 1 .. Last_Dir loop 1921 Locate_File (N, Source, D, File_Name, File, Attr'Access); 1922 1923 if File /= No_File and then T = File_Stamp (File) then 1924 return File; 1925 end if; 1926 end loop; 1927 1928 return No_File; 1929 end; 1930 end Matching_Full_Source_Name; 1931 1932 ---------------- 1933 -- More_Files -- 1934 ---------------- 1935 1936 function More_Files return Boolean is 1937 begin 1938 return (Current_File_Name_Index < Number_File_Names); 1939 end More_Files; 1940 1941 ------------------------------- 1942 -- Nb_Dir_In_Obj_Search_Path -- 1943 ------------------------------- 1944 1945 function Nb_Dir_In_Obj_Search_Path return Natural is 1946 begin 1947 if Opt.Look_In_Primary_Dir then 1948 return Lib_Search_Directories.Last - Primary_Directory + 1; 1949 else 1950 return Lib_Search_Directories.Last - Primary_Directory; 1951 end if; 1952 end Nb_Dir_In_Obj_Search_Path; 1953 1954 ------------------------------- 1955 -- Nb_Dir_In_Src_Search_Path -- 1956 ------------------------------- 1957 1958 function Nb_Dir_In_Src_Search_Path return Natural is 1959 begin 1960 if Opt.Look_In_Primary_Dir then 1961 return Src_Search_Directories.Last - Primary_Directory + 1; 1962 else 1963 return Src_Search_Directories.Last - Primary_Directory; 1964 end if; 1965 end Nb_Dir_In_Src_Search_Path; 1966 1967 -------------------- 1968 -- Next_Main_File -- 1969 -------------------- 1970 1971 function Next_Main_File return File_Name_Type is 1972 File_Name : String_Ptr; 1973 Dir_Name : String_Ptr; 1974 Fptr : Natural; 1975 1976 begin 1977 pragma Assert (More_Files); 1978 1979 Current_File_Name_Index := Current_File_Name_Index + 1; 1980 1981 -- Get the file and directory name 1982 1983 File_Name := File_Names (Current_File_Name_Index); 1984 Fptr := File_Name'First; 1985 1986 for J in reverse File_Name'Range loop 1987 if Is_Directory_Separator (File_Name (J)) then 1988 if J = File_Name'Last then 1989 Fail ("File name missing"); 1990 end if; 1991 1992 Fptr := J + 1; 1993 exit; 1994 end if; 1995 end loop; 1996 1997 -- Save name of directory in which main unit resides for use in 1998 -- locating other units 1999 2000 Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1)); 2001 2002 case Running_Program is 2003 when Compiler => 2004 Src_Search_Directories.Table (Primary_Directory) := Dir_Name; 2005 Look_In_Primary_Directory_For_Current_Main := True; 2006 2007 when Make => 2008 Src_Search_Directories.Table (Primary_Directory) := Dir_Name; 2009 2010 if Fptr > File_Name'First then 2011 Look_In_Primary_Directory_For_Current_Main := True; 2012 end if; 2013 2014 when Binder 2015 | Gnatls 2016 => 2017 Dir_Name := Normalize_Directory_Name (Dir_Name.all); 2018 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name; 2019 2020 when Unspecified => 2021 null; 2022 end case; 2023 2024 Name_Len := File_Name'Last - Fptr + 1; 2025 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last); 2026 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 2027 Current_Main := Name_Find; 2028 2029 -- In the gnatmake case, the main file may have not have the 2030 -- extension. Try ".adb" first then ".ads" 2031 2032 if Running_Program = Make then 2033 declare 2034 Orig_Main : constant File_Name_Type := Current_Main; 2035 2036 begin 2037 if Strip_Suffix (Orig_Main) = Orig_Main then 2038 Current_Main := 2039 Append_Suffix_To_File_Name (Orig_Main, ".adb"); 2040 2041 if Full_Source_Name (Current_Main) = No_File then 2042 Current_Main := 2043 Append_Suffix_To_File_Name (Orig_Main, ".ads"); 2044 2045 if Full_Source_Name (Current_Main) = No_File then 2046 Current_Main := Orig_Main; 2047 end if; 2048 end if; 2049 end if; 2050 end; 2051 end if; 2052 2053 return Current_Main; 2054 end Next_Main_File; 2055 2056 ------------------------------ 2057 -- Normalize_Directory_Name -- 2058 ------------------------------ 2059 2060 function Normalize_Directory_Name (Directory : String) return String_Ptr is 2061 2062 function Is_Quoted (Path : String) return Boolean; 2063 pragma Inline (Is_Quoted); 2064 -- Returns true if Path is quoted (either double or single quotes) 2065 2066 --------------- 2067 -- Is_Quoted -- 2068 --------------- 2069 2070 function Is_Quoted (Path : String) return Boolean is 2071 First : constant Character := Path (Path'First); 2072 Last : constant Character := Path (Path'Last); 2073 2074 begin 2075 if (First = ''' and then Last = ''') 2076 or else 2077 (First = '"' and then Last = '"') 2078 then 2079 return True; 2080 else 2081 return False; 2082 end if; 2083 end Is_Quoted; 2084 2085 Result : String_Ptr; 2086 2087 -- Start of processing for Normalize_Directory_Name 2088 2089 begin 2090 if Directory'Length = 0 then 2091 Result := new String'(Hostparm.Normalized_CWD); 2092 2093 elsif Is_Directory_Separator (Directory (Directory'Last)) then 2094 Result := new String'(Directory); 2095 2096 elsif Is_Quoted (Directory) then 2097 2098 -- This is a quoted string, it certainly means that the directory 2099 -- contains some spaces for example. We can safely remove the quotes 2100 -- here as the OS_Lib.Normalize_Arguments will be called before any 2101 -- spawn routines. This ensure that quotes will be added when needed. 2102 2103 Result := new String (1 .. Directory'Length - 1); 2104 Result (1 .. Directory'Length - 2) := 2105 Directory (Directory'First + 1 .. Directory'Last - 1); 2106 Result (Result'Last) := Directory_Separator; 2107 2108 else 2109 Result := new String (1 .. Directory'Length + 1); 2110 Result (1 .. Directory'Length) := Directory; 2111 Result (Directory'Length + 1) := Directory_Separator; 2112 end if; 2113 2114 return Result; 2115 end Normalize_Directory_Name; 2116 2117 --------------------- 2118 -- Number_Of_Files -- 2119 --------------------- 2120 2121 function Number_Of_Files return Nat is 2122 begin 2123 return Number_File_Names; 2124 end Number_Of_Files; 2125 2126 ------------------------------- 2127 -- Object_Dir_Default_Prefix -- 2128 ------------------------------- 2129 2130 function Object_Dir_Default_Prefix return String is 2131 Object_Dir : String_Access := 2132 String_Access (Update_Path (Object_Dir_Default_Name)); 2133 2134 begin 2135 if Object_Dir = null then 2136 return ""; 2137 2138 else 2139 declare 2140 Result : constant String := Object_Dir.all; 2141 begin 2142 Free (Object_Dir); 2143 return Result; 2144 end; 2145 end if; 2146 end Object_Dir_Default_Prefix; 2147 2148 ---------------------- 2149 -- Object_File_Name -- 2150 ---------------------- 2151 2152 function Object_File_Name (N : File_Name_Type) return File_Name_Type is 2153 begin 2154 if N = No_File then 2155 return No_File; 2156 end if; 2157 2158 Get_Name_String (N); 2159 Name_Len := Name_Len - ALI_Suffix'Length - 1; 2160 2161 for J in Target_Object_Suffix'Range loop 2162 Name_Len := Name_Len + 1; 2163 Name_Buffer (Name_Len) := Target_Object_Suffix (J); 2164 end loop; 2165 2166 return Name_Enter; 2167 end Object_File_Name; 2168 2169 ------------------------------- 2170 -- OS_Exit_Through_Exception -- 2171 ------------------------------- 2172 2173 procedure OS_Exit_Through_Exception (Status : Integer) is 2174 begin 2175 Current_Exit_Status := Status; 2176 raise Types.Terminate_Program; 2177 end OS_Exit_Through_Exception; 2178 2179 -------------------------- 2180 -- OS_Time_To_GNAT_Time -- 2181 -------------------------- 2182 2183 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is 2184 GNAT_Time : Time_Stamp_Type; 2185 2186 type Underlying_OS_Time is 2187 range -(2 ** (Standard'Address_Size - Integer'(1))) .. 2188 +(2 ** (Standard'Address_Size - Integer'(1)) - 1); 2189 -- Underlying_OS_Time is a redeclaration of OS_Time to allow integer 2190 -- manipulation. Remove this in favor of To_Ada/To_C once newer 2191 -- GNAT releases are available with these functions. 2192 2193 function To_Int is 2194 new Unchecked_Conversion (OS_Time, Underlying_OS_Time); 2195 function From_Int is 2196 new Unchecked_Conversion (Underlying_OS_Time, OS_Time); 2197 2198 TI : Underlying_OS_Time := To_Int (T); 2199 Y : Year_Type; 2200 Mo : Month_Type; 2201 D : Day_Type; 2202 H : Hour_Type; 2203 Mn : Minute_Type; 2204 S : Second_Type; 2205 2206 begin 2207 if T = Invalid_Time then 2208 return Empty_Time_Stamp; 2209 end if; 2210 2211 if On_Windows and then TI mod 2 > 0 then 2212 -- Windows ALI files had timestamps rounded to even seconds 2213 -- historically. The rounding was originally done in GM_Split. 2214 -- Now that GM_Split no longer does it, we are rounding it here 2215 -- only for ALI files. 2216 2217 TI := TI + 1; 2218 end if; 2219 2220 GM_Split (From_Int (TI), Y, Mo, D, H, Mn, S); 2221 2222 Make_Time_Stamp 2223 (Year => Nat (Y), 2224 Month => Nat (Mo), 2225 Day => Nat (D), 2226 Hour => Nat (H), 2227 Minutes => Nat (Mn), 2228 Seconds => Nat (S), 2229 TS => GNAT_Time); 2230 2231 return GNAT_Time; 2232 end OS_Time_To_GNAT_Time; 2233 2234 ----------------- 2235 -- Prep_Suffix -- 2236 ----------------- 2237 2238 function Prep_Suffix return String is 2239 begin 2240 return ".prep"; 2241 end Prep_Suffix; 2242 2243 ------------------ 2244 -- Program_Name -- 2245 ------------------ 2246 2247 function Program_Name (Nam : String; Prog : String) return String_Access is 2248 End_Of_Prefix : Natural := 0; 2249 Start_Of_Prefix : Positive := 1; 2250 Start_Of_Suffix : Positive; 2251 2252 begin 2253 -- Get the name of the current program being executed 2254 2255 Find_Program_Name; 2256 2257 Start_Of_Suffix := Name_Len + 1; 2258 2259 -- Find the target prefix if any, for the cross compilation case. 2260 -- For instance in "powerpc-elf-gcc" the target prefix is 2261 -- "powerpc-elf-" 2262 -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1" 2263 2264 for J in reverse 1 .. Name_Len loop 2265 if Is_Directory_Separator (Name_Buffer (J)) 2266 or else Name_Buffer (J) = ':' 2267 then 2268 Start_Of_Prefix := J + 1; 2269 exit; 2270 end if; 2271 end loop; 2272 2273 -- Find End_Of_Prefix 2274 2275 for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop 2276 if Name_Buffer (J .. J + Prog'Length - 1) = Prog then 2277 End_Of_Prefix := J - 1; 2278 exit; 2279 end if; 2280 end loop; 2281 2282 if End_Of_Prefix > 1 then 2283 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1; 2284 end if; 2285 2286 -- Create the new program name 2287 2288 return new String' 2289 (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix) 2290 & Nam 2291 & Name_Buffer (Start_Of_Suffix .. Name_Len)); 2292 end Program_Name; 2293 2294 ------------------------------ 2295 -- Read_Default_Search_Dirs -- 2296 ------------------------------ 2297 2298 function Read_Default_Search_Dirs 2299 (Search_Dir_Prefix : String_Access; 2300 Search_File : String_Access; 2301 Search_Dir_Default_Name : String_Access) return String_Access 2302 is 2303 Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length; 2304 Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1); 2305 File_FD : File_Descriptor; 2306 S, S1 : String_Access; 2307 Len : Integer; 2308 Curr : Integer; 2309 Actual_Len : Integer; 2310 J1 : Integer; 2311 2312 Prev_Was_Separator : Boolean; 2313 Nb_Relative_Dir : Integer; 2314 2315 function Is_Relative (S : String; K : Positive) return Boolean; 2316 pragma Inline (Is_Relative); 2317 -- Returns True if a relative directory specification is found 2318 -- in S at position K, False otherwise. 2319 2320 ----------------- 2321 -- Is_Relative -- 2322 ----------------- 2323 2324 function Is_Relative (S : String; K : Positive) return Boolean is 2325 begin 2326 return not Is_Absolute_Path (S (K .. S'Last)); 2327 end Is_Relative; 2328 2329 -- Start of processing for Read_Default_Search_Dirs 2330 2331 begin 2332 -- Construct a C compatible character string buffer 2333 2334 Buffer (1 .. Search_Dir_Prefix.all'Length) 2335 := Search_Dir_Prefix.all; 2336 Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1) 2337 := Search_File.all; 2338 Buffer (Buffer'Last) := ASCII.NUL; 2339 2340 File_FD := Open_Read (Buffer'Address, Binary); 2341 if File_FD = Invalid_FD then 2342 return Search_Dir_Default_Name; 2343 end if; 2344 2345 Len := Integer (File_Length (File_FD)); 2346 2347 -- An extra character for a trailing Path_Separator is allocated 2348 2349 S := new String (1 .. Len + 1); 2350 S (Len + 1) := Path_Separator; 2351 2352 -- Read the file. Note that the loop is probably not necessary since the 2353 -- whole file is read at once but the loop is harmless and that way we 2354 -- are sure to accommodate systems where this is not the case. 2355 2356 Curr := 1; 2357 Actual_Len := Len; 2358 while Actual_Len /= 0 loop 2359 Actual_Len := Read (File_FD, S (Curr)'Address, Len); 2360 Curr := Curr + Actual_Len; 2361 end loop; 2362 2363 -- Process the file, dealing with path separators 2364 2365 Prev_Was_Separator := True; 2366 Nb_Relative_Dir := 0; 2367 for J in 1 .. Len loop 2368 2369 -- Treat any control character as a path separator. Note that we do 2370 -- not treat space as a path separator (we used to treat space as a 2371 -- path separator in an earlier version). That way space can appear 2372 -- as a legitimate character in a path name. 2373 2374 -- Why do we treat all control characters as path separators??? 2375 2376 if S (J) in ASCII.NUL .. ASCII.US then 2377 S (J) := Path_Separator; 2378 end if; 2379 2380 -- Test for explicit path separator (or control char as above) 2381 2382 if S (J) = Path_Separator then 2383 Prev_Was_Separator := True; 2384 2385 -- If not path separator, register use of relative directory 2386 2387 else 2388 if Prev_Was_Separator and then Is_Relative (S.all, J) then 2389 Nb_Relative_Dir := Nb_Relative_Dir + 1; 2390 end if; 2391 2392 Prev_Was_Separator := False; 2393 end if; 2394 end loop; 2395 2396 if Nb_Relative_Dir = 0 then 2397 return S; 2398 end if; 2399 2400 -- Add the Search_Dir_Prefix to all relative paths 2401 2402 S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len); 2403 J1 := 1; 2404 Prev_Was_Separator := True; 2405 for J in 1 .. Len + 1 loop 2406 if S (J) = Path_Separator then 2407 Prev_Was_Separator := True; 2408 2409 else 2410 if Prev_Was_Separator and then Is_Relative (S.all, J) then 2411 S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all; 2412 J1 := J1 + Prefix_Len; 2413 end if; 2414 2415 Prev_Was_Separator := False; 2416 end if; 2417 S1 (J1) := S (J); 2418 J1 := J1 + 1; 2419 end loop; 2420 2421 Free (S); 2422 return S1; 2423 end Read_Default_Search_Dirs; 2424 2425 ----------------------- 2426 -- Read_Library_Info -- 2427 ----------------------- 2428 2429 function Read_Library_Info 2430 (Lib_File : File_Name_Type; 2431 Fatal_Err : Boolean := False) return Text_Buffer_Ptr 2432 is 2433 File : File_Name_Type; 2434 Attr : aliased File_Attributes; 2435 begin 2436 Find_File (Lib_File, Library, File, Attr'Access); 2437 return Read_Library_Info_From_Full 2438 (Full_Lib_File => File, 2439 Lib_File_Attr => Attr'Access, 2440 Fatal_Err => Fatal_Err); 2441 end Read_Library_Info; 2442 2443 --------------------------------- 2444 -- Read_Library_Info_From_Full -- 2445 --------------------------------- 2446 2447 function Read_Library_Info_From_Full 2448 (Full_Lib_File : File_Name_Type; 2449 Lib_File_Attr : access File_Attributes; 2450 Fatal_Err : Boolean := False) return Text_Buffer_Ptr 2451 is 2452 Lib_FD : File_Descriptor; 2453 -- The file descriptor for the current library file. A negative value 2454 -- indicates failure to open the specified source file. 2455 2456 Len : Integer; 2457 -- Length of source file text (ALI). If it doesn't fit in an integer 2458 -- we're probably stuck anyway (>2 gigs of source seems a lot, and 2459 -- there are other places in the compiler that make this assumption). 2460 2461 Text : Text_Buffer_Ptr; 2462 -- Allocated text buffer 2463 2464 Status : Boolean; 2465 pragma Warnings (Off, Status); 2466 -- For the calls to Close 2467 2468 begin 2469 Current_Full_Lib_Name := Full_Lib_File; 2470 Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name); 2471 2472 if Current_Full_Lib_Name = No_File then 2473 if Fatal_Err then 2474 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); 2475 else 2476 Current_Full_Obj_Stamp := Empty_Time_Stamp; 2477 return null; 2478 end if; 2479 end if; 2480 2481 Get_Name_String (Current_Full_Lib_Name); 2482 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2483 2484 -- Open the library FD, note that we open in binary mode, because as 2485 -- documented in the spec, the caller is expected to handle either 2486 -- DOS or Unix mode files, and there is no point in wasting time on 2487 -- text translation when it is not required. 2488 2489 Lib_FD := Open_Read (Name_Buffer'Address, Binary); 2490 2491 if Lib_FD = Invalid_FD then 2492 if Fatal_Err then 2493 Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len)); 2494 else 2495 Current_Full_Obj_Stamp := Empty_Time_Stamp; 2496 return null; 2497 end if; 2498 end if; 2499 2500 -- Compute the length of the file (potentially also preparing other data 2501 -- like the timestamp and whether the file is read-only, for future use) 2502 2503 Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr)); 2504 2505 -- Check for object file consistency if requested 2506 2507 if Opt.Check_Object_Consistency then 2508 -- On most systems, this does not result in an extra system call 2509 2510 Current_Full_Lib_Stamp := 2511 OS_Time_To_GNAT_Time 2512 (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr)); 2513 2514 -- ??? One system call here 2515 2516 Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name); 2517 2518 if Current_Full_Obj_Stamp (1) = ' ' then 2519 2520 -- When the library is readonly always assume object is consistent 2521 -- The call to Is_Writable_File only results in a system call on 2522 -- some systems, but in most cases it has already been computed as 2523 -- part of the call to File_Length above. 2524 2525 Get_Name_String (Current_Full_Lib_Name); 2526 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2527 2528 if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then 2529 Current_Full_Obj_Stamp := Current_Full_Lib_Stamp; 2530 2531 elsif Fatal_Err then 2532 Get_Name_String (Current_Full_Obj_Name); 2533 Close (Lib_FD, Status); 2534 2535 -- No need to check the status, we fail anyway 2536 2537 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); 2538 2539 else 2540 Current_Full_Obj_Stamp := Empty_Time_Stamp; 2541 Close (Lib_FD, Status); 2542 2543 -- No need to check the status, we return null anyway 2544 2545 return null; 2546 end if; 2547 2548 elsif Current_Full_Obj_Stamp < Current_Full_Lib_Stamp then 2549 Close (Lib_FD, Status); 2550 2551 -- No need to check the status, we return null anyway 2552 2553 return null; 2554 end if; 2555 end if; 2556 2557 -- Read data from the file 2558 2559 declare 2560 Actual_Len : Integer := 0; 2561 2562 Lo : constant Text_Ptr := 0; 2563 -- Low bound for allocated text buffer 2564 2565 Hi : Text_Ptr := Text_Ptr (Len); 2566 -- High bound for allocated text buffer. Note length is Len + 1 2567 -- which allows for extra EOF character at the end of the buffer. 2568 2569 begin 2570 -- Allocate text buffer. Note extra character at end for EOF 2571 2572 Text := new Text_Buffer (Lo .. Hi); 2573 2574 -- Some systems have file types that require one read per line, 2575 -- so read until we get the Len bytes or until there are no more 2576 -- characters. 2577 2578 Hi := Lo; 2579 loop 2580 Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len); 2581 Hi := Hi + Text_Ptr (Actual_Len); 2582 exit when Actual_Len = Len or else Actual_Len <= 0; 2583 end loop; 2584 2585 Text (Hi) := EOF; 2586 end; 2587 2588 -- Read is complete, close file and we are done 2589 2590 Close (Lib_FD, Status); 2591 -- The status should never be False. But, if it is, what can we do? 2592 -- So, we don't test it. 2593 2594 return Text; 2595 2596 end Read_Library_Info_From_Full; 2597 2598 ---------------------- 2599 -- Read_Source_File -- 2600 ---------------------- 2601 2602 procedure Read_Source_File 2603 (N : File_Name_Type; 2604 Lo : Source_Ptr; 2605 Hi : out Source_Ptr; 2606 Src : out Source_Buffer_Ptr; 2607 FD : out File_Descriptor; 2608 T : File_Type := Source) 2609 is 2610 Len : Integer; 2611 -- Length of file, assume no more than 2 gigabytes of source 2612 2613 Actual_Len : Integer; 2614 2615 Status : Boolean; 2616 pragma Warnings (Off, Status); 2617 -- For the call to Close 2618 2619 begin 2620 Current_Full_Source_Name := Find_File (N, T, Full_Name => True); 2621 Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name); 2622 2623 if Current_Full_Source_Name = No_File then 2624 2625 -- If we were trying to access the main file and we could not find 2626 -- it, we have an error. 2627 2628 if N = Current_Main then 2629 Get_Name_String (N); 2630 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); 2631 end if; 2632 2633 FD := Null_FD; 2634 Src := null; 2635 Hi := No_Location; 2636 return; 2637 end if; 2638 2639 Get_Name_String (Current_Full_Source_Name); 2640 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2641 2642 -- Open the source FD, note that we open in binary mode, because as 2643 -- documented in the spec, the caller is expected to handle either 2644 -- DOS or Unix mode files, and there is no point in wasting time on 2645 -- text translation when it is not required. 2646 2647 FD := Open_Read (Name_Buffer'Address, Binary); 2648 2649 if FD = Invalid_FD then 2650 Src := null; 2651 Hi := No_Location; 2652 return; 2653 end if; 2654 2655 -- If it's a Source file, print out the file name, if requested, and if 2656 -- it's not part of the runtimes, store it in File_Name_Chars. We don't 2657 -- want to print non-Source files, like GNAT-TEMP-000001.TMP used to 2658 -- pass information from gprbuild to gcc. We don't want to save runtime 2659 -- file names, because we don't want users to send them in bug reports. 2660 2661 if T = Source then 2662 declare 2663 Name : String renames Name_Buffer (1 .. Name_Len); 2664 Inc : String renames Include_Dir_Default_Prefix.all; 2665 2666 Part_Of_Runtimes : constant Boolean := 2667 Inc /= "" 2668 and then Inc'Length < Name_Len 2669 and then Name_Buffer (1 .. Inc'Length) = Inc; 2670 2671 begin 2672 if Debug.Debug_Flag_Dot_N then 2673 Write_Line (Name); 2674 end if; 2675 2676 if not Part_Of_Runtimes then 2677 File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name)); 2678 File_Name_Chars.Append (ASCII.LF); 2679 end if; 2680 end; 2681 end if; 2682 2683 -- Prepare to read data from the file 2684 2685 Len := Integer (File_Length (FD)); 2686 2687 -- Set Hi so that length is one more than the physical length, 2688 -- allowing for the extra EOF character at the end of the buffer 2689 2690 Hi := Lo + Source_Ptr (Len); 2691 2692 -- Do the actual read operation 2693 2694 declare 2695 Var_Ptr : constant Source_Buffer_Ptr_Var := 2696 new Source_Buffer (Lo .. Hi); 2697 -- Allocate source buffer, allowing extra character at end for EOF 2698 begin 2699 -- Some systems have file types that require one read per line, 2700 -- so read until we get the Len bytes or until there are no more 2701 -- characters. 2702 2703 Hi := Lo; 2704 loop 2705 Actual_Len := Read (FD, Var_Ptr (Hi)'Address, Len); 2706 Hi := Hi + Source_Ptr (Actual_Len); 2707 exit when Actual_Len = Len or else Actual_Len <= 0; 2708 end loop; 2709 2710 Var_Ptr (Hi) := EOF; 2711 Src := Var_Ptr.all'Access; 2712 end; 2713 2714 -- Read is complete, get time stamp and close file and we are done 2715 2716 Close (FD, Status); 2717 2718 -- The status should never be False. But, if it is, what can we do? 2719 -- So, we don't test it. 2720 2721 -- ???We don't really need to return Hi anymore; We could get rid of 2722 -- it. We could also make this into a function. 2723 2724 pragma Assert (Hi = Src'Last); 2725 end Read_Source_File; 2726 2727 ------------------- 2728 -- Relocate_Path -- 2729 ------------------- 2730 2731 function Relocate_Path 2732 (Prefix : String; 2733 Path : String) return String_Ptr 2734 is 2735 S : String_Ptr; 2736 2737 procedure set_std_prefix (S : String; Len : Integer); 2738 pragma Import (C, set_std_prefix); 2739 2740 begin 2741 if Std_Prefix = null then 2742 Std_Prefix := Executable_Prefix; 2743 2744 if Std_Prefix.all /= "" then 2745 2746 -- Remove trailing directory separator when calling set_std_prefix 2747 2748 set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1); 2749 end if; 2750 end if; 2751 2752 if Path'Last >= Prefix'Last and then Path (Prefix'Range) = Prefix then 2753 if Std_Prefix.all /= "" then 2754 S := new String 2755 (1 .. Std_Prefix'Length + Path'Last - Prefix'Last); 2756 S (1 .. Std_Prefix'Length) := Std_Prefix.all; 2757 S (Std_Prefix'Length + 1 .. S'Last) := 2758 Path (Prefix'Last + 1 .. Path'Last); 2759 return S; 2760 end if; 2761 end if; 2762 2763 return new String'(Path); 2764 end Relocate_Path; 2765 2766 ----------------- 2767 -- Set_Program -- 2768 ----------------- 2769 2770 procedure Set_Program (P : Program_Type) is 2771 begin 2772 if Program_Set then 2773 Fail ("Set_Program called twice"); 2774 end if; 2775 2776 Program_Set := True; 2777 Running_Program := P; 2778 end Set_Program; 2779 2780 ---------------- 2781 -- Shared_Lib -- 2782 ---------------- 2783 2784 function Shared_Lib (Name : String) return String is 2785 Library : String (1 .. Name'Length + Library_Version'Length + 3); 2786 -- 3 = 2 for "-l" + 1 for "-" before lib version 2787 2788 begin 2789 Library (1 .. 2) := "-l"; 2790 Library (3 .. 2 + Name'Length) := Name; 2791 Library (3 + Name'Length) := '-'; 2792 Library (4 + Name'Length .. Library'Last) := Library_Version; 2793 return Library; 2794 end Shared_Lib; 2795 2796 ---------------------- 2797 -- Smart_File_Stamp -- 2798 ---------------------- 2799 2800 function Smart_File_Stamp 2801 (N : File_Name_Type; 2802 T : File_Type) return Time_Stamp_Type 2803 is 2804 File : File_Name_Type; 2805 Attr : aliased File_Attributes; 2806 2807 begin 2808 if not File_Cache_Enabled then 2809 Find_File (N, T, File, Attr'Access); 2810 else 2811 Smart_Find_File (N, T, File, Attr); 2812 end if; 2813 2814 if File = No_File then 2815 return Empty_Time_Stamp; 2816 else 2817 Get_Name_String (File); 2818 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2819 return 2820 OS_Time_To_GNAT_Time 2821 (File_Time_Stamp (Name_Buffer'Address, Attr'Access)); 2822 end if; 2823 end Smart_File_Stamp; 2824 2825 --------------------- 2826 -- Smart_Find_File -- 2827 --------------------- 2828 2829 function Smart_Find_File 2830 (N : File_Name_Type; 2831 T : File_Type) return File_Name_Type 2832 is 2833 File : File_Name_Type; 2834 Attr : File_Attributes; 2835 begin 2836 Smart_Find_File (N, T, File, Attr); 2837 return File; 2838 end Smart_Find_File; 2839 2840 --------------------- 2841 -- Smart_Find_File -- 2842 --------------------- 2843 2844 procedure Smart_Find_File 2845 (N : File_Name_Type; 2846 T : File_Type; 2847 Found : out File_Name_Type; 2848 Attr : out File_Attributes) 2849 is 2850 Info : File_Info_Cache; 2851 2852 begin 2853 if not File_Cache_Enabled then 2854 Find_File (N, T, Info.File, Info.Attr'Access); 2855 2856 else 2857 Info := File_Name_Hash_Table.Get (N); 2858 2859 if Info.File = No_File then 2860 Find_File (N, T, Info.File, Info.Attr'Access); 2861 File_Name_Hash_Table.Set (N, Info); 2862 end if; 2863 end if; 2864 2865 Found := Info.File; 2866 Attr := Info.Attr; 2867 end Smart_Find_File; 2868 2869 ---------------------- 2870 -- Source_File_Data -- 2871 ---------------------- 2872 2873 procedure Source_File_Data (Cache : Boolean) is 2874 begin 2875 File_Cache_Enabled := Cache; 2876 end Source_File_Data; 2877 2878 ----------------------- 2879 -- Source_File_Stamp -- 2880 ----------------------- 2881 2882 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is 2883 begin 2884 return Smart_File_Stamp (N, Source); 2885 end Source_File_Stamp; 2886 2887 --------------------- 2888 -- Strip_Directory -- 2889 --------------------- 2890 2891 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is 2892 begin 2893 Get_Name_String (Name); 2894 2895 for J in reverse 1 .. Name_Len - 1 loop 2896 2897 -- If we find the last directory separator 2898 2899 if Is_Directory_Separator (Name_Buffer (J)) then 2900 2901 -- Return part of Name that follows this last directory separator 2902 2903 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len); 2904 Name_Len := Name_Len - J; 2905 return Name_Find; 2906 end if; 2907 end loop; 2908 2909 -- There were no directory separator, just return Name 2910 2911 return Name; 2912 end Strip_Directory; 2913 2914 ------------------ 2915 -- Strip_Suffix -- 2916 ------------------ 2917 2918 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is 2919 begin 2920 Get_Name_String (Name); 2921 2922 for J in reverse 2 .. Name_Len loop 2923 2924 -- If we found the last '.', return part of Name that precedes it 2925 2926 if Name_Buffer (J) = '.' then 2927 Name_Len := J - 1; 2928 return Name_Enter; 2929 end if; 2930 end loop; 2931 2932 return Name; 2933 end Strip_Suffix; 2934 2935 --------------------------- 2936 -- To_Canonical_File_List -- 2937 --------------------------- 2938 2939 function To_Canonical_File_List 2940 (Wildcard_Host_File : String; 2941 Only_Dirs : Boolean) return String_Access_List_Access 2942 is 2943 function To_Canonical_File_List_Init 2944 (Host_File : Address; 2945 Only_Dirs : Integer) return Integer; 2946 pragma Import (C, To_Canonical_File_List_Init, 2947 "__gnat_to_canonical_file_list_init"); 2948 2949 function To_Canonical_File_List_Next return Address; 2950 pragma Import (C, To_Canonical_File_List_Next, 2951 "__gnat_to_canonical_file_list_next"); 2952 2953 procedure To_Canonical_File_List_Free; 2954 pragma Import (C, To_Canonical_File_List_Free, 2955 "__gnat_to_canonical_file_list_free"); 2956 2957 Num_Files : Integer; 2958 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1); 2959 2960 begin 2961 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) := 2962 Wildcard_Host_File; 2963 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL; 2964 2965 -- Do the expansion and say how many there are 2966 2967 Num_Files := To_Canonical_File_List_Init 2968 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs)); 2969 2970 declare 2971 Canonical_File_List : String_Access_List (1 .. Num_Files); 2972 Canonical_File_Addr : Address; 2973 Canonical_File_Len : CRTL.size_t; 2974 2975 begin 2976 -- Retrieve the expanded directory names and build the list 2977 2978 for J in 1 .. Num_Files loop 2979 Canonical_File_Addr := To_Canonical_File_List_Next; 2980 Canonical_File_Len := C_String_Length (Canonical_File_Addr); 2981 Canonical_File_List (J) := To_Path_String_Access 2982 (Canonical_File_Addr, Canonical_File_Len); 2983 end loop; 2984 2985 -- Free up the storage 2986 2987 To_Canonical_File_List_Free; 2988 2989 return new String_Access_List'(Canonical_File_List); 2990 end; 2991 end To_Canonical_File_List; 2992 2993 ---------------------- 2994 -- To_Host_Dir_Spec -- 2995 ---------------------- 2996 2997 function To_Host_Dir_Spec 2998 (Canonical_Dir : String; 2999 Prefix_Style : Boolean) return String_Access 3000 is 3001 function To_Host_Dir_Spec 3002 (Canonical_Dir : Address; 3003 Prefix_Flag : Integer) return Address; 3004 pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec"); 3005 3006 C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1); 3007 Host_Dir_Addr : Address; 3008 Host_Dir_Len : CRTL.size_t; 3009 3010 begin 3011 C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir; 3012 C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL; 3013 3014 if Prefix_Style then 3015 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1); 3016 else 3017 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0); 3018 end if; 3019 Host_Dir_Len := C_String_Length (Host_Dir_Addr); 3020 3021 if Host_Dir_Len = 0 then 3022 return null; 3023 else 3024 return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len); 3025 end if; 3026 end To_Host_Dir_Spec; 3027 3028 ----------------------- 3029 -- To_Host_File_Spec -- 3030 ----------------------- 3031 3032 function To_Host_File_Spec 3033 (Canonical_File : String) return String_Access 3034 is 3035 function To_Host_File_Spec (Canonical_File : Address) return Address; 3036 pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec"); 3037 3038 C_Canonical_File : String (1 .. Canonical_File'Length + 1); 3039 Host_File_Addr : Address; 3040 Host_File_Len : CRTL.size_t; 3041 3042 begin 3043 C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File; 3044 C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL; 3045 3046 Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address); 3047 Host_File_Len := C_String_Length (Host_File_Addr); 3048 3049 if Host_File_Len = 0 then 3050 return null; 3051 else 3052 return To_Path_String_Access 3053 (Host_File_Addr, Host_File_Len); 3054 end if; 3055 end To_Host_File_Spec; 3056 3057 --------------------------- 3058 -- To_Path_String_Access -- 3059 --------------------------- 3060 3061 function To_Path_String_Access 3062 (Path_Addr : Address; 3063 Path_Len : CRTL.size_t) return String_Access 3064 is 3065 subtype Path_String is String (1 .. Integer (Path_Len)); 3066 type Path_String_Access is access Path_String; 3067 3068 function Address_To_Access is new 3069 Unchecked_Conversion (Source => Address, 3070 Target => Path_String_Access); 3071 3072 Path_Access : constant Path_String_Access := 3073 Address_To_Access (Path_Addr); 3074 3075 Return_Val : String_Access; 3076 3077 begin 3078 Return_Val := new String (1 .. Integer (Path_Len)); 3079 3080 for J in 1 .. Integer (Path_Len) loop 3081 Return_Val (J) := Path_Access (J); 3082 end loop; 3083 3084 return Return_Val; 3085 end To_Path_String_Access; 3086 3087 ----------------- 3088 -- Update_Path -- 3089 ----------------- 3090 3091 function Update_Path (Path : String_Ptr) return String_Ptr is 3092 3093 function C_Update_Path (Path, Component : Address) return Address; 3094 pragma Import (C, C_Update_Path, "update_path"); 3095 3096 In_Length : constant Integer := Path'Length; 3097 In_String : String (1 .. In_Length + 1); 3098 Component_Name : aliased String := "GCC" & ASCII.NUL; 3099 Result_Ptr : Address; 3100 Result_Length : CRTL.size_t; 3101 Out_String : String_Ptr; 3102 3103 begin 3104 In_String (1 .. In_Length) := Path.all; 3105 In_String (In_Length + 1) := ASCII.NUL; 3106 Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address); 3107 Result_Length := CRTL.strlen (Result_Ptr); 3108 3109 Out_String := new String (1 .. Integer (Result_Length)); 3110 CRTL.strncpy (Out_String.all'Address, Result_Ptr, Result_Length); 3111 return Out_String; 3112 end Update_Path; 3113 3114 ---------------- 3115 -- Write_Info -- 3116 ---------------- 3117 3118 procedure Write_Info (Info : String) is 3119 begin 3120 Write_With_Check (Info'Address, Info'Length); 3121 Write_With_Check (EOL'Address, 1); 3122 end Write_Info; 3123 3124 ------------------------ 3125 -- Write_Program_Name -- 3126 ------------------------ 3127 3128 procedure Write_Program_Name is 3129 Save_Buffer : constant String (1 .. Name_Len) := 3130 Name_Buffer (1 .. Name_Len); 3131 3132 begin 3133 Find_Program_Name; 3134 3135 -- Convert the name to lower case so error messages are the same on 3136 -- all systems. 3137 3138 for J in 1 .. Name_Len loop 3139 if Name_Buffer (J) in 'A' .. 'Z' then 3140 Name_Buffer (J) := 3141 Character'Val (Character'Pos (Name_Buffer (J)) + 32); 3142 end if; 3143 end loop; 3144 3145 Write_Str (Name_Buffer (1 .. Name_Len)); 3146 3147 -- Restore Name_Buffer which was clobbered by the call to 3148 -- Find_Program_Name 3149 3150 Name_Len := Save_Buffer'Last; 3151 Name_Buffer (1 .. Name_Len) := Save_Buffer; 3152 end Write_Program_Name; 3153 3154 ---------------------- 3155 -- Write_With_Check -- 3156 ---------------------- 3157 3158 procedure Write_With_Check (A : Address; N : Integer) is 3159 Ignore : Boolean; 3160 begin 3161 if N = Write (Output_FD, A, N) then 3162 return; 3163 else 3164 Write_Str ("error: disk full writing "); 3165 Write_Name_Decoded (Output_File_Name); 3166 Write_Eol; 3167 Name_Len := Name_Len + 1; 3168 Name_Buffer (Name_Len) := ASCII.NUL; 3169 Delete_File (Name_Buffer'Address, Ignore); 3170 Exit_Program (E_Fatal); 3171 end if; 3172 end Write_With_Check; 3173 3174---------------------------- 3175-- Package Initialization -- 3176---------------------------- 3177 3178 procedure Reset_File_Attributes (Attr : System.Address); 3179 pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes"); 3180 3181begin 3182 Initialization : declare 3183 3184 function Get_Default_Identifier_Character_Set return Character; 3185 pragma Import (C, Get_Default_Identifier_Character_Set, 3186 "__gnat_get_default_identifier_character_set"); 3187 -- Function to determine the default identifier character set, 3188 -- which is system dependent. See Opt package spec for a list of 3189 -- the possible character codes and their interpretations. 3190 3191 function Get_Maximum_File_Name_Length return Int; 3192 pragma Import (C, Get_Maximum_File_Name_Length, 3193 "__gnat_get_maximum_file_name_length"); 3194 -- Function to get maximum file name length for system 3195 3196 Sizeof_File_Attributes : Integer; 3197 pragma Import (C, Sizeof_File_Attributes, 3198 "__gnat_size_of_file_attributes"); 3199 3200 begin 3201 pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size); 3202 3203 Reset_File_Attributes (Unknown_Attributes'Address); 3204 3205 Identifier_Character_Set := Get_Default_Identifier_Character_Set; 3206 Maximum_File_Name_Length := Get_Maximum_File_Name_Length; 3207 3208 -- Following should be removed by having above function return 3209 -- Integer'Last as indication of no maximum instead of -1 ??? 3210 3211 if Maximum_File_Name_Length = -1 then 3212 Maximum_File_Name_Length := Int'Last; 3213 end if; 3214 3215 Src_Search_Directories.Set_Last (Primary_Directory); 3216 Src_Search_Directories.Table (Primary_Directory) := new String'(""); 3217 3218 Lib_Search_Directories.Set_Last (Primary_Directory); 3219 Lib_Search_Directories.Table (Primary_Directory) := new String'(""); 3220 3221 Osint.Initialize; 3222 end Initialization; 3223 3224end Osint; 3225