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