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