1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- O S I N T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2018, 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_Source_File_Names -- 792 ---------------------------- 793 794 procedure Dump_Source_File_Names is 795 subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last; 796 begin 797 Write_Str (String (File_Name_Chars.Table (Rng))); 798 end Dump_Source_File_Names; 799 800 --------------------- 801 -- Executable_Name -- 802 --------------------- 803 804 function Executable_Name 805 (Name : File_Name_Type; 806 Only_If_No_Suffix : Boolean := False) return File_Name_Type 807 is 808 Exec_Suffix : String_Access; 809 Add_Suffix : Boolean; 810 811 begin 812 if Name = No_File then 813 return No_File; 814 end if; 815 816 if Executable_Extension_On_Target = No_Name then 817 Exec_Suffix := Get_Target_Executable_Suffix; 818 else 819 Get_Name_String (Executable_Extension_On_Target); 820 Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); 821 end if; 822 823 if Exec_Suffix'Length /= 0 then 824 Get_Name_String (Name); 825 826 Add_Suffix := True; 827 if Only_If_No_Suffix then 828 for J in reverse 1 .. Name_Len loop 829 if Name_Buffer (J) = '.' then 830 Add_Suffix := False; 831 exit; 832 833 elsif Name_Buffer (J) = '/' or else 834 Name_Buffer (J) = Directory_Separator 835 then 836 exit; 837 end if; 838 end loop; 839 end if; 840 841 if Add_Suffix then 842 declare 843 Buffer : String := Name_Buffer (1 .. Name_Len); 844 845 begin 846 -- Get the file name in canonical case to accept as is. Names 847 -- end with ".EXE" on Windows. 848 849 Canonical_Case_File_Name (Buffer); 850 851 -- If Executable doesn't end with the executable suffix, add it 852 853 if Buffer'Length <= Exec_Suffix'Length 854 or else 855 Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last) 856 /= Exec_Suffix.all 857 then 858 Name_Buffer 859 (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) := 860 Exec_Suffix.all; 861 Name_Len := Name_Len + Exec_Suffix'Length; 862 Free (Exec_Suffix); 863 return Name_Find; 864 end if; 865 end; 866 end if; 867 end if; 868 869 Free (Exec_Suffix); 870 return Name; 871 end Executable_Name; 872 873 function Executable_Name 874 (Name : String; 875 Only_If_No_Suffix : Boolean := False) return String 876 is 877 Exec_Suffix : String_Access; 878 Add_Suffix : Boolean; 879 Canonical_Name : String := Name; 880 881 begin 882 if Executable_Extension_On_Target = No_Name then 883 Exec_Suffix := Get_Target_Executable_Suffix; 884 else 885 Get_Name_String (Executable_Extension_On_Target); 886 Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); 887 end if; 888 889 if Exec_Suffix'Length = 0 then 890 Free (Exec_Suffix); 891 return Name; 892 893 else 894 declare 895 Suffix : constant String := Exec_Suffix.all; 896 897 begin 898 Free (Exec_Suffix); 899 Canonical_Case_File_Name (Canonical_Name); 900 901 Add_Suffix := True; 902 if Only_If_No_Suffix then 903 for J in reverse Canonical_Name'Range loop 904 if Canonical_Name (J) = '.' then 905 Add_Suffix := False; 906 exit; 907 908 elsif Canonical_Name (J) = '/' or else 909 Canonical_Name (J) = Directory_Separator 910 then 911 exit; 912 end if; 913 end loop; 914 end if; 915 916 if Add_Suffix and then 917 (Canonical_Name'Length <= Suffix'Length 918 or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1 919 .. Canonical_Name'Last) /= Suffix) 920 then 921 declare 922 Result : String (1 .. Name'Length + Suffix'Length); 923 begin 924 Result (1 .. Name'Length) := Name; 925 Result (Name'Length + 1 .. Result'Last) := Suffix; 926 return Result; 927 end; 928 else 929 return Name; 930 end if; 931 end; 932 end if; 933 end Executable_Name; 934 935 ----------------------- 936 -- Executable_Prefix -- 937 ----------------------- 938 939 function Executable_Prefix return String_Ptr is 940 941 function Get_Install_Dir (Exec : String) return String_Ptr; 942 -- S is the executable name preceded by the absolute or relative 943 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc". 944 945 --------------------- 946 -- Get_Install_Dir -- 947 --------------------- 948 949 function Get_Install_Dir (Exec : String) return String_Ptr is 950 Full_Path : constant String := Normalize_Pathname (Exec); 951 -- Use the full path, so that we find "lib" or "bin", even when 952 -- the tool has been invoked with a relative path, as in 953 -- "./gnatls -v" invoked in the GNAT bin directory. 954 955 begin 956 for J in reverse Full_Path'Range loop 957 if Is_Directory_Separator (Full_Path (J)) then 958 if J < Full_Path'Last - 5 then 959 if (To_Lower (Full_Path (J + 1)) = 'l' 960 and then To_Lower (Full_Path (J + 2)) = 'i' 961 and then To_Lower (Full_Path (J + 3)) = 'b') 962 or else 963 (To_Lower (Full_Path (J + 1)) = 'b' 964 and then To_Lower (Full_Path (J + 2)) = 'i' 965 and then To_Lower (Full_Path (J + 3)) = 'n') 966 then 967 return new String'(Full_Path (Full_Path'First .. J)); 968 end if; 969 end if; 970 end if; 971 end loop; 972 973 return new String'(""); 974 end Get_Install_Dir; 975 976 -- Start of processing for Executable_Prefix 977 978 begin 979 if Exec_Name = null then 980 Exec_Name := new String (1 .. Len_Arg (0)); 981 Osint.Fill_Arg (Exec_Name (1)'Address, 0); 982 end if; 983 984 -- First determine if a path prefix was placed in front of the 985 -- executable name. 986 987 for J in reverse Exec_Name'Range loop 988 if Is_Directory_Separator (Exec_Name (J)) then 989 return Get_Install_Dir (Exec_Name.all); 990 end if; 991 end loop; 992 993 -- If we come here, the user has typed the executable name with no 994 -- directory prefix. 995 996 return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all); 997 end Executable_Prefix; 998 999 ------------------ 1000 -- Exit_Program -- 1001 ------------------ 1002 1003 procedure Exit_Program (Exit_Code : Exit_Code_Type) is 1004 begin 1005 -- The program will exit with the following status: 1006 1007 -- 0 if the object file has been generated (with or without warnings) 1008 -- 1 if recompilation was not needed (smart recompilation) 1009 -- 2 if gnat1 has been killed by a signal (detected by GCC) 1010 -- 4 for a fatal error 1011 -- 5 if there were errors 1012 -- 6 if no code has been generated (spec) 1013 1014 -- Note that exit code 3 is not used and must not be used as this is 1015 -- the code returned by a program aborted via C abort() routine on 1016 -- Windows. GCC checks for that case and thinks that the child process 1017 -- has been aborted. This code (exit code 3) used to be the code used 1018 -- for E_No_Code, but E_No_Code was changed to 6 for this reason. 1019 1020 case Exit_Code is 1021 when E_Success => OS_Exit (0); 1022 when E_Warnings => OS_Exit (0); 1023 when E_No_Compile => OS_Exit (1); 1024 when E_Fatal => OS_Exit (4); 1025 when E_Errors => OS_Exit (5); 1026 when E_No_Code => OS_Exit (6); 1027 when E_Abort => OS_Abort; 1028 end case; 1029 end Exit_Program; 1030 1031 ---------- 1032 -- Fail -- 1033 ---------- 1034 1035 procedure Fail (S : String) is 1036 begin 1037 -- We use Output in case there is a special output set up. In this case 1038 -- Set_Standard_Error will have no immediate effect. 1039 1040 Set_Standard_Error; 1041 Osint.Write_Program_Name; 1042 Write_Str (": "); 1043 Write_Str (S); 1044 Write_Eol; 1045 1046 Exit_Program (E_Fatal); 1047 end Fail; 1048 1049 --------------- 1050 -- File_Hash -- 1051 --------------- 1052 1053 function File_Hash (F : File_Name_Type) return File_Hash_Num is 1054 begin 1055 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length); 1056 end File_Hash; 1057 1058 ----------------- 1059 -- File_Length -- 1060 ----------------- 1061 1062 function File_Length 1063 (Name : C_File_Name; 1064 Attr : access File_Attributes) return Long_Integer 1065 is 1066 function Internal 1067 (F : Integer; 1068 N : C_File_Name; 1069 A : System.Address) return CRTL.int64; 1070 pragma Import (C, Internal, "__gnat_file_length_attr"); 1071 1072 begin 1073 -- The conversion from int64 to Long_Integer is ok here as this 1074 -- routine is only to be used by the compiler and we do not expect 1075 -- a unit to be larger than a 32bit integer. 1076 1077 return Long_Integer (Internal (-1, Name, Attr.all'Address)); 1078 end File_Length; 1079 1080 --------------------- 1081 -- File_Time_Stamp -- 1082 --------------------- 1083 1084 function File_Time_Stamp 1085 (Name : C_File_Name; 1086 Attr : access File_Attributes) return OS_Time 1087 is 1088 function Internal (N : C_File_Name; A : System.Address) return OS_Time; 1089 pragma Import (C, Internal, "__gnat_file_time_name_attr"); 1090 begin 1091 return Internal (Name, Attr.all'Address); 1092 end File_Time_Stamp; 1093 1094 function File_Time_Stamp 1095 (Name : Path_Name_Type; 1096 Attr : access File_Attributes) return Time_Stamp_Type 1097 is 1098 begin 1099 if Name = No_Path then 1100 return Empty_Time_Stamp; 1101 end if; 1102 1103 Get_Name_String (Name); 1104 Name_Buffer (Name_Len + 1) := ASCII.NUL; 1105 return OS_Time_To_GNAT_Time 1106 (File_Time_Stamp (Name_Buffer'Address, Attr)); 1107 end File_Time_Stamp; 1108 1109 ---------------- 1110 -- File_Stamp -- 1111 ---------------- 1112 1113 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is 1114 begin 1115 if Name = No_File then 1116 return Empty_Time_Stamp; 1117 end if; 1118 1119 Get_Name_String (Name); 1120 1121 -- File_Time_Stamp will always return Invalid_Time if the file does 1122 -- not exist, and OS_Time_To_GNAT_Time will convert this value to 1123 -- Empty_Time_Stamp. Therefore we do not need to first test whether 1124 -- the file actually exists, which saves a system call. 1125 1126 return OS_Time_To_GNAT_Time 1127 (File_Time_Stamp (Name_Buffer (1 .. Name_Len))); 1128 end File_Stamp; 1129 1130 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is 1131 begin 1132 return File_Stamp (File_Name_Type (Name)); 1133 end File_Stamp; 1134 1135 --------------- 1136 -- Find_File -- 1137 --------------- 1138 1139 function Find_File 1140 (N : File_Name_Type; 1141 T : File_Type; 1142 Full_Name : Boolean := False) return File_Name_Type 1143 is 1144 Attr : aliased File_Attributes; 1145 Found : File_Name_Type; 1146 begin 1147 Find_File (N, T, Found, Attr'Access, Full_Name); 1148 return Found; 1149 end Find_File; 1150 1151 --------------- 1152 -- Find_File -- 1153 --------------- 1154 1155 procedure Find_File 1156 (N : File_Name_Type; 1157 T : File_Type; 1158 Found : out File_Name_Type; 1159 Attr : access File_Attributes; 1160 Full_Name : Boolean := False) 1161 is 1162 begin 1163 Get_Name_String (N); 1164 1165 declare 1166 File_Name : String renames Name_Buffer (1 .. Name_Len); 1167 File : File_Name_Type := No_File; 1168 Last_Dir : Natural; 1169 1170 begin 1171 -- If we are looking for a config file, look only in the current 1172 -- directory, i.e. return input argument unchanged. Also look only in 1173 -- the current directory if we are looking for a .dg file (happens in 1174 -- -gnatD mode). 1175 1176 if T = Config 1177 or else (Debug_Generated_Code 1178 and then Name_Len > 3 1179 and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg") 1180 then 1181 Found := N; 1182 Attr.all := Unknown_Attributes; 1183 1184 if T = Config then 1185 if Full_Name then 1186 declare 1187 Full_Path : constant String := 1188 Normalize_Pathname (Get_Name_String (N)); 1189 Full_Size : constant Natural := Full_Path'Length; 1190 1191 begin 1192 Name_Buffer (1 .. Full_Size) := Full_Path; 1193 Name_Len := Full_Size; 1194 Found := Name_Find; 1195 end; 1196 end if; 1197 1198 -- Check that it is a file, not a directory 1199 1200 if not Is_Regular_File (Get_Name_String (Found)) then 1201 Found := No_File; 1202 end if; 1203 end if; 1204 1205 return; 1206 1207 -- If we are trying to find the current main file just look in the 1208 -- directory where the user said it was. 1209 1210 elsif Look_In_Primary_Directory_For_Current_Main 1211 and then Current_Main = N 1212 then 1213 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr); 1214 return; 1215 1216 -- Otherwise do standard search for source file 1217 1218 else 1219 -- Check the mapping of this file name 1220 1221 File := Mapped_Path_Name (N); 1222 1223 -- If the file name is mapped to a path name, return the 1224 -- corresponding path name 1225 1226 if File /= No_File then 1227 1228 -- For locally removed file, Error_Name is returned; then 1229 -- return No_File, indicating the file is not a source. 1230 1231 if File = Error_File_Name then 1232 Found := No_File; 1233 else 1234 Found := File; 1235 end if; 1236 1237 Attr.all := Unknown_Attributes; 1238 return; 1239 end if; 1240 1241 -- First place to look is in the primary directory (i.e. the same 1242 -- directory as the source) unless this has been disabled with -I- 1243 1244 if Opt.Look_In_Primary_Dir then 1245 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr); 1246 1247 if Found /= No_File then 1248 return; 1249 end if; 1250 end if; 1251 1252 -- Finally look in directories specified with switches -I/-aI/-aO 1253 1254 if T = Library then 1255 Last_Dir := Lib_Search_Directories.Last; 1256 else 1257 Last_Dir := Src_Search_Directories.Last; 1258 end if; 1259 1260 for D in Primary_Directory + 1 .. Last_Dir loop 1261 Locate_File (N, T, D, File_Name, Found, Attr); 1262 1263 if Found /= No_File then 1264 return; 1265 end if; 1266 end loop; 1267 1268 Attr.all := Unknown_Attributes; 1269 Found := No_File; 1270 end if; 1271 end; 1272 end Find_File; 1273 1274 ----------------------- 1275 -- Find_Program_Name -- 1276 ----------------------- 1277 1278 procedure Find_Program_Name is 1279 Command_Name : String (1 .. Len_Arg (0)); 1280 Cindex1 : Integer := Command_Name'First; 1281 Cindex2 : Integer := Command_Name'Last; 1282 1283 begin 1284 Fill_Arg (Command_Name'Address, 0); 1285 1286 if Command_Name = "" then 1287 Name_Len := 0; 1288 return; 1289 end if; 1290 1291 -- The program name might be specified by a full path name. However, 1292 -- we don't want to print that all out in an error message, so the 1293 -- path might need to be stripped away. 1294 1295 for J in reverse Cindex1 .. Cindex2 loop 1296 if Is_Directory_Separator (Command_Name (J)) then 1297 Cindex1 := J + 1; 1298 exit; 1299 end if; 1300 end loop; 1301 1302 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the 1303 -- POSIX command "basename argv[0]" 1304 1305 -- Strip off any executable extension (usually nothing or .exe) 1306 -- but formally reported by autoconf in the variable EXEEXT 1307 1308 if Cindex2 - Cindex1 >= 4 then 1309 if To_Lower (Command_Name (Cindex2 - 3)) = '.' 1310 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e' 1311 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x' 1312 and then To_Lower (Command_Name (Cindex2)) = 'e' 1313 then 1314 Cindex2 := Cindex2 - 4; 1315 end if; 1316 end if; 1317 1318 Name_Len := Cindex2 - Cindex1 + 1; 1319 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2); 1320 end Find_Program_Name; 1321 1322 ------------------------ 1323 -- Full_Lib_File_Name -- 1324 ------------------------ 1325 1326 procedure Full_Lib_File_Name 1327 (N : File_Name_Type; 1328 Lib_File : out File_Name_Type; 1329 Attr : out File_Attributes) 1330 is 1331 A : aliased File_Attributes; 1332 begin 1333 -- ??? seems we could use Smart_Find_File here 1334 Find_File (N, Library, Lib_File, A'Access); 1335 Attr := A; 1336 end Full_Lib_File_Name; 1337 1338 ------------------------ 1339 -- Full_Lib_File_Name -- 1340 ------------------------ 1341 1342 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is 1343 Attr : File_Attributes; 1344 File : File_Name_Type; 1345 begin 1346 Full_Lib_File_Name (N, File, Attr); 1347 return File; 1348 end Full_Lib_File_Name; 1349 1350 ---------------------------- 1351 -- Full_Library_Info_Name -- 1352 ---------------------------- 1353 1354 function Full_Library_Info_Name return File_Name_Type is 1355 begin 1356 return Current_Full_Lib_Name; 1357 end Full_Library_Info_Name; 1358 1359 --------------------------- 1360 -- Full_Object_File_Name -- 1361 --------------------------- 1362 1363 function Full_Object_File_Name return File_Name_Type is 1364 begin 1365 return Current_Full_Obj_Name; 1366 end Full_Object_File_Name; 1367 1368 ---------------------- 1369 -- Full_Source_Name -- 1370 ---------------------- 1371 1372 function Full_Source_Name return File_Name_Type is 1373 begin 1374 return Current_Full_Source_Name; 1375 end Full_Source_Name; 1376 1377 ---------------------- 1378 -- Full_Source_Name -- 1379 ---------------------- 1380 1381 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is 1382 begin 1383 return Smart_Find_File (N, Source); 1384 end Full_Source_Name; 1385 1386 ---------------------- 1387 -- Full_Source_Name -- 1388 ---------------------- 1389 1390 procedure Full_Source_Name 1391 (N : File_Name_Type; 1392 Full_File : out File_Name_Type; 1393 Attr : access File_Attributes) is 1394 begin 1395 Smart_Find_File (N, Source, Full_File, Attr.all); 1396 end Full_Source_Name; 1397 1398 ------------------- 1399 -- Get_Directory -- 1400 ------------------- 1401 1402 function Get_Directory (Name : File_Name_Type) return File_Name_Type is 1403 begin 1404 Get_Name_String (Name); 1405 1406 for J in reverse 1 .. Name_Len loop 1407 if Is_Directory_Separator (Name_Buffer (J)) then 1408 Name_Len := J; 1409 return Name_Find; 1410 end if; 1411 end loop; 1412 1413 Name_Len := Hostparm.Normalized_CWD'Length; 1414 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD; 1415 return Name_Find; 1416 end Get_Directory; 1417 1418 -------------------------- 1419 -- Get_Next_Dir_In_Path -- 1420 -------------------------- 1421 1422 Search_Path_Pos : Integer; 1423 -- Keeps track of current position in search path. Initialized by the 1424 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path. 1425 1426 function Get_Next_Dir_In_Path 1427 (Search_Path : String_Access) return String_Access 1428 is 1429 Lower_Bound : Positive := Search_Path_Pos; 1430 Upper_Bound : Positive; 1431 1432 begin 1433 loop 1434 while Lower_Bound <= Search_Path'Last 1435 and then Search_Path.all (Lower_Bound) = Path_Separator 1436 loop 1437 Lower_Bound := Lower_Bound + 1; 1438 end loop; 1439 1440 exit when Lower_Bound > Search_Path'Last; 1441 1442 Upper_Bound := Lower_Bound; 1443 while Upper_Bound <= Search_Path'Last 1444 and then Search_Path.all (Upper_Bound) /= Path_Separator 1445 loop 1446 Upper_Bound := Upper_Bound + 1; 1447 end loop; 1448 1449 Search_Path_Pos := Upper_Bound; 1450 return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1)); 1451 end loop; 1452 1453 return null; 1454 end Get_Next_Dir_In_Path; 1455 1456 ------------------------------- 1457 -- Get_Next_Dir_In_Path_Init -- 1458 ------------------------------- 1459 1460 procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is 1461 begin 1462 Search_Path_Pos := Search_Path'First; 1463 end Get_Next_Dir_In_Path_Init; 1464 1465 -------------------------------------- 1466 -- Get_Primary_Src_Search_Directory -- 1467 -------------------------------------- 1468 1469 function Get_Primary_Src_Search_Directory return String_Ptr is 1470 begin 1471 return Src_Search_Directories.Table (Primary_Directory); 1472 end Get_Primary_Src_Search_Directory; 1473 1474 ------------------------ 1475 -- Get_RTS_Search_Dir -- 1476 ------------------------ 1477 1478 function Get_RTS_Search_Dir 1479 (Search_Dir : String; 1480 File_Type : Search_File_Type) return String_Ptr 1481 is 1482 procedure Get_Current_Dir 1483 (Dir : System.Address; 1484 Length : System.Address); 1485 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); 1486 1487 Max_Path : Integer; 1488 pragma Import (C, Max_Path, "__gnat_max_path_len"); 1489 -- Maximum length of a path name 1490 1491 Current_Dir : String_Ptr; 1492 Default_Search_Dir : String_Access; 1493 Default_Suffix_Dir : String_Access; 1494 Local_Search_Dir : String_Access; 1495 Norm_Search_Dir : String_Access; 1496 Result_Search_Dir : String_Access; 1497 Search_File : String_Access; 1498 Temp_String : String_Ptr; 1499 1500 begin 1501 -- Add a directory separator at the end of the directory if necessary 1502 -- so that we can directly append a file to the directory 1503 1504 if Search_Dir (Search_Dir'Last) /= Directory_Separator then 1505 Local_Search_Dir := 1506 new String'(Search_Dir & String'(1 => Directory_Separator)); 1507 else 1508 Local_Search_Dir := new String'(Search_Dir); 1509 end if; 1510 1511 if File_Type = Include then 1512 Search_File := Include_Search_File; 1513 Default_Suffix_Dir := new String'("adainclude"); 1514 else 1515 Search_File := Objects_Search_File; 1516 Default_Suffix_Dir := new String'("adalib"); 1517 end if; 1518 1519 Norm_Search_Dir := Local_Search_Dir; 1520 1521 if Is_Absolute_Path (Norm_Search_Dir.all) then 1522 1523 -- We first verify if there is a directory Include_Search_Dir 1524 -- containing default search directories 1525 1526 Result_Search_Dir := 1527 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); 1528 Default_Search_Dir := 1529 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); 1530 Free (Norm_Search_Dir); 1531 1532 if Result_Search_Dir /= null then 1533 return String_Ptr (Result_Search_Dir); 1534 elsif Is_Directory (Default_Search_Dir.all) then 1535 return String_Ptr (Default_Search_Dir); 1536 else 1537 return null; 1538 end if; 1539 1540 -- Search in the current directory 1541 1542 else 1543 -- Get the current directory 1544 1545 declare 1546 Buffer : String (1 .. Max_Path + 2); 1547 Path_Len : Natural := Max_Path; 1548 1549 begin 1550 Get_Current_Dir (Buffer'Address, Path_Len'Address); 1551 1552 if Path_Len = 0 then 1553 raise Program_Error; 1554 end if; 1555 1556 if Buffer (Path_Len) /= Directory_Separator then 1557 Path_Len := Path_Len + 1; 1558 Buffer (Path_Len) := Directory_Separator; 1559 end if; 1560 1561 Current_Dir := new String'(Buffer (1 .. Path_Len)); 1562 end; 1563 1564 Norm_Search_Dir := 1565 new String'(Current_Dir.all & Local_Search_Dir.all); 1566 1567 Result_Search_Dir := 1568 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); 1569 1570 Default_Search_Dir := 1571 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); 1572 1573 Free (Norm_Search_Dir); 1574 1575 if Result_Search_Dir /= null then 1576 return String_Ptr (Result_Search_Dir); 1577 1578 elsif Is_Directory (Default_Search_Dir.all) then 1579 return String_Ptr (Default_Search_Dir); 1580 1581 else 1582 -- Search in Search_Dir_Prefix/Search_Dir 1583 1584 Norm_Search_Dir := 1585 new String' 1586 (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all); 1587 1588 Result_Search_Dir := 1589 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); 1590 1591 Default_Search_Dir := 1592 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); 1593 1594 Free (Norm_Search_Dir); 1595 1596 if Result_Search_Dir /= null then 1597 return String_Ptr (Result_Search_Dir); 1598 1599 elsif Is_Directory (Default_Search_Dir.all) then 1600 return String_Ptr (Default_Search_Dir); 1601 1602 else 1603 -- We finally search in Search_Dir_Prefix/rts-Search_Dir 1604 1605 Temp_String := 1606 new String'(Update_Path (Search_Dir_Prefix).all & "rts-"); 1607 1608 Norm_Search_Dir := 1609 new String'(Temp_String.all & Local_Search_Dir.all); 1610 1611 Result_Search_Dir := 1612 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); 1613 1614 Default_Search_Dir := 1615 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); 1616 Free (Norm_Search_Dir); 1617 1618 if Result_Search_Dir /= null then 1619 return String_Ptr (Result_Search_Dir); 1620 1621 elsif Is_Directory (Default_Search_Dir.all) then 1622 return String_Ptr (Default_Search_Dir); 1623 1624 else 1625 return null; 1626 end if; 1627 end if; 1628 end if; 1629 end if; 1630 end Get_RTS_Search_Dir; 1631 1632 -------------------------------- 1633 -- Include_Dir_Default_Prefix -- 1634 -------------------------------- 1635 1636 function Include_Dir_Default_Prefix return String_Access is 1637 begin 1638 if The_Include_Dir_Default_Prefix = null then 1639 The_Include_Dir_Default_Prefix := 1640 String_Access (Update_Path (Include_Dir_Default_Name)); 1641 end if; 1642 1643 return The_Include_Dir_Default_Prefix; 1644 end Include_Dir_Default_Prefix; 1645 1646 function Include_Dir_Default_Prefix return String is 1647 begin 1648 return Include_Dir_Default_Prefix.all; 1649 end Include_Dir_Default_Prefix; 1650 1651 ---------------- 1652 -- Initialize -- 1653 ---------------- 1654 1655 procedure Initialize is 1656 begin 1657 Number_File_Names := 0; 1658 Current_File_Name_Index := 0; 1659 1660 Src_Search_Directories.Init; 1661 Lib_Search_Directories.Init; 1662 1663 -- Start off by setting all suppress options, to False. The special 1664 -- overflow fields are set to Not_Set (they will be set by -gnatp, or 1665 -- by -gnato, or, if neither of these appear, in Adjust_Global_Switches 1666 -- in Gnat1drv). 1667 1668 Suppress_Options := ((others => False), Not_Set, Not_Set); 1669 1670 -- Reserve the first slot in the search paths table. This is the 1671 -- directory of the main source file or main library file and is filled 1672 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the 1673 -- directory specified for this main source or library file. This is the 1674 -- directory which is searched first by default. This default search is 1675 -- inhibited by the option -I- for both source and library files. 1676 1677 Src_Search_Directories.Set_Last (Primary_Directory); 1678 Src_Search_Directories.Table (Primary_Directory) := new String'(""); 1679 1680 Lib_Search_Directories.Set_Last (Primary_Directory); 1681 Lib_Search_Directories.Table (Primary_Directory) := new String'(""); 1682 end Initialize; 1683 1684 ------------------ 1685 -- Is_Directory -- 1686 ------------------ 1687 1688 function Is_Directory 1689 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1690 is 1691 function Internal (N : C_File_Name; A : System.Address) return Integer; 1692 pragma Import (C, Internal, "__gnat_is_directory_attr"); 1693 begin 1694 return Internal (Name, Attr.all'Address) /= 0; 1695 end Is_Directory; 1696 1697 ---------------------------- 1698 -- Is_Directory_Separator -- 1699 ---------------------------- 1700 1701 function Is_Directory_Separator (C : Character) return Boolean is 1702 begin 1703 -- In addition to the default directory_separator allow the '/' to 1704 -- act as separator since this is allowed in MS-DOS and Windows. 1705 1706 return C = Directory_Separator or else C = '/'; 1707 end Is_Directory_Separator; 1708 1709 ------------------------- 1710 -- Is_Readonly_Library -- 1711 ------------------------- 1712 1713 function Is_Readonly_Library (File : File_Name_Type) return Boolean is 1714 begin 1715 Get_Name_String (File); 1716 1717 pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali"); 1718 1719 return not Is_Writable_File (Name_Buffer (1 .. Name_Len)); 1720 end Is_Readonly_Library; 1721 1722 ------------------------ 1723 -- Is_Executable_File -- 1724 ------------------------ 1725 1726 function Is_Executable_File 1727 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1728 is 1729 function Internal (N : C_File_Name; A : System.Address) return Integer; 1730 pragma Import (C, Internal, "__gnat_is_executable_file_attr"); 1731 begin 1732 return Internal (Name, Attr.all'Address) /= 0; 1733 end Is_Executable_File; 1734 1735 ---------------------- 1736 -- Is_Readable_File -- 1737 ---------------------- 1738 1739 function Is_Readable_File 1740 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1741 is 1742 function Internal (N : C_File_Name; A : System.Address) return Integer; 1743 pragma Import (C, Internal, "__gnat_is_readable_file_attr"); 1744 begin 1745 return Internal (Name, Attr.all'Address) /= 0; 1746 end Is_Readable_File; 1747 1748 --------------------- 1749 -- Is_Regular_File -- 1750 --------------------- 1751 1752 function Is_Regular_File 1753 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1754 is 1755 function Internal (N : C_File_Name; A : System.Address) return Integer; 1756 pragma Import (C, Internal, "__gnat_is_regular_file_attr"); 1757 begin 1758 return Internal (Name, Attr.all'Address) /= 0; 1759 end Is_Regular_File; 1760 1761 ---------------------- 1762 -- Is_Symbolic_Link -- 1763 ---------------------- 1764 1765 function Is_Symbolic_Link 1766 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1767 is 1768 function Internal (N : C_File_Name; A : System.Address) return Integer; 1769 pragma Import (C, Internal, "__gnat_is_symbolic_link_attr"); 1770 begin 1771 return Internal (Name, Attr.all'Address) /= 0; 1772 end Is_Symbolic_Link; 1773 1774 ---------------------- 1775 -- Is_Writable_File -- 1776 ---------------------- 1777 1778 function Is_Writable_File 1779 (Name : C_File_Name; Attr : access File_Attributes) return Boolean 1780 is 1781 function Internal (N : C_File_Name; A : System.Address) return Integer; 1782 pragma Import (C, Internal, "__gnat_is_writable_file_attr"); 1783 begin 1784 return Internal (Name, Attr.all'Address) /= 0; 1785 end Is_Writable_File; 1786 1787 ------------------- 1788 -- Lib_File_Name -- 1789 ------------------- 1790 1791 function Lib_File_Name 1792 (Source_File : File_Name_Type; 1793 Munit_Index : Nat := 0) return File_Name_Type 1794 is 1795 begin 1796 Get_Name_String (Source_File); 1797 1798 for J in reverse 2 .. Name_Len loop 1799 if Name_Buffer (J) = '.' then 1800 Name_Len := J - 1; 1801 exit; 1802 end if; 1803 end loop; 1804 1805 if Munit_Index /= 0 then 1806 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); 1807 Add_Nat_To_Name_Buffer (Munit_Index); 1808 end if; 1809 1810 Add_Char_To_Name_Buffer ('.'); 1811 Add_Str_To_Name_Buffer (ALI_Suffix.all); 1812 return Name_Find; 1813 end Lib_File_Name; 1814 1815 ----------------- 1816 -- Locate_File -- 1817 ----------------- 1818 1819 procedure Locate_File 1820 (N : File_Name_Type; 1821 T : File_Type; 1822 Dir : Natural; 1823 Name : String; 1824 Found : out File_Name_Type; 1825 Attr : access File_Attributes) 1826 is 1827 Dir_Name : String_Ptr; 1828 1829 begin 1830 -- If Name is already an absolute path, do not look for a directory 1831 1832 if Is_Absolute_Path (Name) then 1833 Dir_Name := No_Dir; 1834 1835 elsif T = Library then 1836 Dir_Name := Lib_Search_Directories.Table (Dir); 1837 1838 else 1839 pragma Assert (T /= Config); 1840 Dir_Name := Src_Search_Directories.Table (Dir); 1841 end if; 1842 1843 declare 1844 Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1); 1845 1846 begin 1847 Full_Name (1 .. Dir_Name'Length) := Dir_Name.all; 1848 Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name; 1849 Full_Name (Full_Name'Last) := ASCII.NUL; 1850 1851 Attr.all := Unknown_Attributes; 1852 1853 if not Is_Regular_File (Full_Name'Address, Attr) then 1854 Found := No_File; 1855 1856 else 1857 -- If the file is in the current directory then return N itself 1858 1859 if Dir_Name'Length = 0 then 1860 Found := N; 1861 else 1862 Name_Len := Full_Name'Length - 1; 1863 Name_Buffer (1 .. Name_Len) := 1864 Full_Name (1 .. Full_Name'Last - 1); 1865 Found := Name_Find; -- ??? Was Name_Enter, no obvious reason 1866 end if; 1867 end if; 1868 end; 1869 end Locate_File; 1870 1871 ------------------------------- 1872 -- Matching_Full_Source_Name -- 1873 ------------------------------- 1874 1875 function Matching_Full_Source_Name 1876 (N : File_Name_Type; 1877 T : Time_Stamp_Type) return File_Name_Type 1878 is 1879 begin 1880 Get_Name_String (N); 1881 1882 declare 1883 File_Name : constant String := Name_Buffer (1 .. Name_Len); 1884 File : File_Name_Type := No_File; 1885 Attr : aliased File_Attributes; 1886 Last_Dir : Natural; 1887 1888 begin 1889 if Opt.Look_In_Primary_Dir then 1890 Locate_File 1891 (N, Source, Primary_Directory, File_Name, File, Attr'Access); 1892 1893 if File /= No_File and then T = File_Stamp (N) then 1894 return File; 1895 end if; 1896 end if; 1897 1898 Last_Dir := Src_Search_Directories.Last; 1899 1900 for D in Primary_Directory + 1 .. Last_Dir loop 1901 Locate_File (N, Source, D, File_Name, File, Attr'Access); 1902 1903 if File /= No_File and then T = File_Stamp (File) then 1904 return File; 1905 end if; 1906 end loop; 1907 1908 return No_File; 1909 end; 1910 end Matching_Full_Source_Name; 1911 1912 ---------------- 1913 -- More_Files -- 1914 ---------------- 1915 1916 function More_Files return Boolean is 1917 begin 1918 return (Current_File_Name_Index < Number_File_Names); 1919 end More_Files; 1920 1921 ------------------------------- 1922 -- Nb_Dir_In_Obj_Search_Path -- 1923 ------------------------------- 1924 1925 function Nb_Dir_In_Obj_Search_Path return Natural is 1926 begin 1927 if Opt.Look_In_Primary_Dir then 1928 return Lib_Search_Directories.Last - Primary_Directory + 1; 1929 else 1930 return Lib_Search_Directories.Last - Primary_Directory; 1931 end if; 1932 end Nb_Dir_In_Obj_Search_Path; 1933 1934 ------------------------------- 1935 -- Nb_Dir_In_Src_Search_Path -- 1936 ------------------------------- 1937 1938 function Nb_Dir_In_Src_Search_Path return Natural is 1939 begin 1940 if Opt.Look_In_Primary_Dir then 1941 return Src_Search_Directories.Last - Primary_Directory + 1; 1942 else 1943 return Src_Search_Directories.Last - Primary_Directory; 1944 end if; 1945 end Nb_Dir_In_Src_Search_Path; 1946 1947 -------------------- 1948 -- Next_Main_File -- 1949 -------------------- 1950 1951 function Next_Main_File return File_Name_Type is 1952 File_Name : String_Ptr; 1953 Dir_Name : String_Ptr; 1954 Fptr : Natural; 1955 1956 begin 1957 pragma Assert (More_Files); 1958 1959 Current_File_Name_Index := Current_File_Name_Index + 1; 1960 1961 -- Get the file and directory name 1962 1963 File_Name := File_Names (Current_File_Name_Index); 1964 Fptr := File_Name'First; 1965 1966 for J in reverse File_Name'Range loop 1967 if File_Name (J) = Directory_Separator 1968 or else File_Name (J) = '/' 1969 then 1970 if J = File_Name'Last then 1971 Fail ("File name missing"); 1972 end if; 1973 1974 Fptr := J + 1; 1975 exit; 1976 end if; 1977 end loop; 1978 1979 -- Save name of directory in which main unit resides for use in 1980 -- locating other units 1981 1982 Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1)); 1983 1984 case Running_Program is 1985 when Compiler => 1986 Src_Search_Directories.Table (Primary_Directory) := Dir_Name; 1987 Look_In_Primary_Directory_For_Current_Main := True; 1988 1989 when Make => 1990 Src_Search_Directories.Table (Primary_Directory) := Dir_Name; 1991 1992 if Fptr > File_Name'First then 1993 Look_In_Primary_Directory_For_Current_Main := True; 1994 end if; 1995 1996 when Binder 1997 | Gnatls 1998 => 1999 Dir_Name := Normalize_Directory_Name (Dir_Name.all); 2000 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name; 2001 2002 when Unspecified => 2003 null; 2004 end case; 2005 2006 Name_Len := File_Name'Last - Fptr + 1; 2007 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last); 2008 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 2009 Current_Main := Name_Find; 2010 2011 -- In the gnatmake case, the main file may have not have the 2012 -- extension. Try ".adb" first then ".ads" 2013 2014 if Running_Program = Make then 2015 declare 2016 Orig_Main : constant File_Name_Type := Current_Main; 2017 2018 begin 2019 if Strip_Suffix (Orig_Main) = Orig_Main then 2020 Current_Main := 2021 Append_Suffix_To_File_Name (Orig_Main, ".adb"); 2022 2023 if Full_Source_Name (Current_Main) = No_File then 2024 Current_Main := 2025 Append_Suffix_To_File_Name (Orig_Main, ".ads"); 2026 2027 if Full_Source_Name (Current_Main) = No_File then 2028 Current_Main := Orig_Main; 2029 end if; 2030 end if; 2031 end if; 2032 end; 2033 end if; 2034 2035 return Current_Main; 2036 end Next_Main_File; 2037 2038 ------------------------------ 2039 -- Normalize_Directory_Name -- 2040 ------------------------------ 2041 2042 function Normalize_Directory_Name (Directory : String) return String_Ptr is 2043 2044 function Is_Quoted (Path : String) return Boolean; 2045 pragma Inline (Is_Quoted); 2046 -- Returns true if Path is quoted (either double or single quotes) 2047 2048 --------------- 2049 -- Is_Quoted -- 2050 --------------- 2051 2052 function Is_Quoted (Path : String) return Boolean is 2053 First : constant Character := Path (Path'First); 2054 Last : constant Character := Path (Path'Last); 2055 2056 begin 2057 if (First = ''' and then Last = ''') 2058 or else 2059 (First = '"' and then Last = '"') 2060 then 2061 return True; 2062 else 2063 return False; 2064 end if; 2065 end Is_Quoted; 2066 2067 Result : String_Ptr; 2068 2069 -- Start of processing for Normalize_Directory_Name 2070 2071 begin 2072 if Directory'Length = 0 then 2073 Result := new String'(Hostparm.Normalized_CWD); 2074 2075 elsif Is_Directory_Separator (Directory (Directory'Last)) then 2076 Result := new String'(Directory); 2077 2078 elsif Is_Quoted (Directory) then 2079 2080 -- This is a quoted string, it certainly means that the directory 2081 -- contains some spaces for example. We can safely remove the quotes 2082 -- here as the OS_Lib.Normalize_Arguments will be called before any 2083 -- spawn routines. This ensure that quotes will be added when needed. 2084 2085 Result := new String (1 .. Directory'Length - 1); 2086 Result (1 .. Directory'Length - 2) := 2087 Directory (Directory'First + 1 .. Directory'Last - 1); 2088 Result (Result'Last) := Directory_Separator; 2089 2090 else 2091 Result := new String (1 .. Directory'Length + 1); 2092 Result (1 .. Directory'Length) := Directory; 2093 Result (Directory'Length + 1) := Directory_Separator; 2094 end if; 2095 2096 return Result; 2097 end Normalize_Directory_Name; 2098 2099 --------------------- 2100 -- Number_Of_Files -- 2101 --------------------- 2102 2103 function Number_Of_Files return Nat is 2104 begin 2105 return Number_File_Names; 2106 end Number_Of_Files; 2107 2108 ------------------------------- 2109 -- Object_Dir_Default_Prefix -- 2110 ------------------------------- 2111 2112 function Object_Dir_Default_Prefix return String is 2113 Object_Dir : String_Access := 2114 String_Access (Update_Path (Object_Dir_Default_Name)); 2115 2116 begin 2117 if Object_Dir = null then 2118 return ""; 2119 2120 else 2121 declare 2122 Result : constant String := Object_Dir.all; 2123 begin 2124 Free (Object_Dir); 2125 return Result; 2126 end; 2127 end if; 2128 end Object_Dir_Default_Prefix; 2129 2130 ---------------------- 2131 -- Object_File_Name -- 2132 ---------------------- 2133 2134 function Object_File_Name (N : File_Name_Type) return File_Name_Type is 2135 begin 2136 if N = No_File then 2137 return No_File; 2138 end if; 2139 2140 Get_Name_String (N); 2141 Name_Len := Name_Len - ALI_Suffix'Length - 1; 2142 2143 for J in Target_Object_Suffix'Range loop 2144 Name_Len := Name_Len + 1; 2145 Name_Buffer (Name_Len) := Target_Object_Suffix (J); 2146 end loop; 2147 2148 return Name_Enter; 2149 end Object_File_Name; 2150 2151 ------------------------------- 2152 -- OS_Exit_Through_Exception -- 2153 ------------------------------- 2154 2155 procedure OS_Exit_Through_Exception (Status : Integer) is 2156 begin 2157 Current_Exit_Status := Status; 2158 raise Types.Terminate_Program; 2159 end OS_Exit_Through_Exception; 2160 2161 -------------------------- 2162 -- OS_Time_To_GNAT_Time -- 2163 -------------------------- 2164 2165 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is 2166 GNAT_Time : Time_Stamp_Type; 2167 2168 Y : Year_Type; 2169 Mo : Month_Type; 2170 D : Day_Type; 2171 H : Hour_Type; 2172 Mn : Minute_Type; 2173 S : Second_Type; 2174 2175 begin 2176 if T = Invalid_Time then 2177 return Empty_Time_Stamp; 2178 end if; 2179 2180 GM_Split (T, Y, Mo, D, H, Mn, S); 2181 Make_Time_Stamp 2182 (Year => Nat (Y), 2183 Month => Nat (Mo), 2184 Day => Nat (D), 2185 Hour => Nat (H), 2186 Minutes => Nat (Mn), 2187 Seconds => Nat (S), 2188 TS => GNAT_Time); 2189 2190 return GNAT_Time; 2191 end OS_Time_To_GNAT_Time; 2192 2193 ----------------- 2194 -- Prep_Suffix -- 2195 ----------------- 2196 2197 function Prep_Suffix return String is 2198 begin 2199 return ".prep"; 2200 end Prep_Suffix; 2201 2202 ------------------ 2203 -- Program_Name -- 2204 ------------------ 2205 2206 function Program_Name (Nam : String; Prog : String) return String_Access is 2207 End_Of_Prefix : Natural := 0; 2208 Start_Of_Prefix : Positive := 1; 2209 Start_Of_Suffix : Positive; 2210 2211 begin 2212 -- Get the name of the current program being executed 2213 2214 Find_Program_Name; 2215 2216 Start_Of_Suffix := Name_Len + 1; 2217 2218 -- Find the target prefix if any, for the cross compilation case. 2219 -- For instance in "powerpc-elf-gcc" the target prefix is 2220 -- "powerpc-elf-" 2221 -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1" 2222 2223 for J in reverse 1 .. Name_Len loop 2224 if Name_Buffer (J) = '/' 2225 or else Name_Buffer (J) = Directory_Separator 2226 or else Name_Buffer (J) = ':' 2227 then 2228 Start_Of_Prefix := J + 1; 2229 exit; 2230 end if; 2231 end loop; 2232 2233 -- Find End_Of_Prefix 2234 2235 for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop 2236 if Name_Buffer (J .. J + Prog'Length - 1) = Prog then 2237 End_Of_Prefix := J - 1; 2238 exit; 2239 end if; 2240 end loop; 2241 2242 if End_Of_Prefix > 1 then 2243 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1; 2244 end if; 2245 2246 -- Create the new program name 2247 2248 return new String' 2249 (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix) 2250 & Nam 2251 & Name_Buffer (Start_Of_Suffix .. Name_Len)); 2252 end Program_Name; 2253 2254 ------------------------------ 2255 -- Read_Default_Search_Dirs -- 2256 ------------------------------ 2257 2258 function Read_Default_Search_Dirs 2259 (Search_Dir_Prefix : String_Access; 2260 Search_File : String_Access; 2261 Search_Dir_Default_Name : String_Access) return String_Access 2262 is 2263 Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length; 2264 Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1); 2265 File_FD : File_Descriptor; 2266 S, S1 : String_Access; 2267 Len : Integer; 2268 Curr : Integer; 2269 Actual_Len : Integer; 2270 J1 : Integer; 2271 2272 Prev_Was_Separator : Boolean; 2273 Nb_Relative_Dir : Integer; 2274 2275 function Is_Relative (S : String; K : Positive) return Boolean; 2276 pragma Inline (Is_Relative); 2277 -- Returns True if a relative directory specification is found 2278 -- in S at position K, False otherwise. 2279 2280 ----------------- 2281 -- Is_Relative -- 2282 ----------------- 2283 2284 function Is_Relative (S : String; K : Positive) return Boolean is 2285 begin 2286 return not Is_Absolute_Path (S (K .. S'Last)); 2287 end Is_Relative; 2288 2289 -- Start of processing for Read_Default_Search_Dirs 2290 2291 begin 2292 -- Construct a C compatible character string buffer 2293 2294 Buffer (1 .. Search_Dir_Prefix.all'Length) 2295 := Search_Dir_Prefix.all; 2296 Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1) 2297 := Search_File.all; 2298 Buffer (Buffer'Last) := ASCII.NUL; 2299 2300 File_FD := Open_Read (Buffer'Address, Binary); 2301 if File_FD = Invalid_FD then 2302 return Search_Dir_Default_Name; 2303 end if; 2304 2305 Len := Integer (File_Length (File_FD)); 2306 2307 -- An extra character for a trailing Path_Separator is allocated 2308 2309 S := new String (1 .. Len + 1); 2310 S (Len + 1) := Path_Separator; 2311 2312 -- Read the file. Note that the loop is probably not necessary since the 2313 -- whole file is read at once but the loop is harmless and that way we 2314 -- are sure to accommodate systems where this is not the case. 2315 2316 Curr := 1; 2317 Actual_Len := Len; 2318 while Actual_Len /= 0 loop 2319 Actual_Len := Read (File_FD, S (Curr)'Address, Len); 2320 Curr := Curr + Actual_Len; 2321 end loop; 2322 2323 -- Process the file, dealing with path separators 2324 2325 Prev_Was_Separator := True; 2326 Nb_Relative_Dir := 0; 2327 for J in 1 .. Len loop 2328 2329 -- Treat any control character as a path separator. Note that we do 2330 -- not treat space as a path separator (we used to treat space as a 2331 -- path separator in an earlier version). That way space can appear 2332 -- as a legitimate character in a path name. 2333 2334 -- Why do we treat all control characters as path separators??? 2335 2336 if S (J) in ASCII.NUL .. ASCII.US then 2337 S (J) := Path_Separator; 2338 end if; 2339 2340 -- Test for explicit path separator (or control char as above) 2341 2342 if S (J) = Path_Separator then 2343 Prev_Was_Separator := True; 2344 2345 -- If not path separator, register use of relative directory 2346 2347 else 2348 if Prev_Was_Separator and then Is_Relative (S.all, J) then 2349 Nb_Relative_Dir := Nb_Relative_Dir + 1; 2350 end if; 2351 2352 Prev_Was_Separator := False; 2353 end if; 2354 end loop; 2355 2356 if Nb_Relative_Dir = 0 then 2357 return S; 2358 end if; 2359 2360 -- Add the Search_Dir_Prefix to all relative paths 2361 2362 S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len); 2363 J1 := 1; 2364 Prev_Was_Separator := True; 2365 for J in 1 .. Len + 1 loop 2366 if S (J) = Path_Separator then 2367 Prev_Was_Separator := True; 2368 2369 else 2370 if Prev_Was_Separator and then Is_Relative (S.all, J) then 2371 S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all; 2372 J1 := J1 + Prefix_Len; 2373 end if; 2374 2375 Prev_Was_Separator := False; 2376 end if; 2377 S1 (J1) := S (J); 2378 J1 := J1 + 1; 2379 end loop; 2380 2381 Free (S); 2382 return S1; 2383 end Read_Default_Search_Dirs; 2384 2385 ----------------------- 2386 -- Read_Library_Info -- 2387 ----------------------- 2388 2389 function Read_Library_Info 2390 (Lib_File : File_Name_Type; 2391 Fatal_Err : Boolean := False) return Text_Buffer_Ptr 2392 is 2393 File : File_Name_Type; 2394 Attr : aliased File_Attributes; 2395 begin 2396 Find_File (Lib_File, Library, File, Attr'Access); 2397 return Read_Library_Info_From_Full 2398 (Full_Lib_File => File, 2399 Lib_File_Attr => Attr'Access, 2400 Fatal_Err => Fatal_Err); 2401 end Read_Library_Info; 2402 2403 --------------------------------- 2404 -- Read_Library_Info_From_Full -- 2405 --------------------------------- 2406 2407 function Read_Library_Info_From_Full 2408 (Full_Lib_File : File_Name_Type; 2409 Lib_File_Attr : access File_Attributes; 2410 Fatal_Err : Boolean := False) return Text_Buffer_Ptr 2411 is 2412 Lib_FD : File_Descriptor; 2413 -- The file descriptor for the current library file. A negative value 2414 -- indicates failure to open the specified source file. 2415 2416 Len : Integer; 2417 -- Length of source file text (ALI). If it doesn't fit in an integer 2418 -- we're probably stuck anyway (>2 gigs of source seems a lot, and 2419 -- there are other places in the compiler that make this assumption). 2420 2421 Text : Text_Buffer_Ptr; 2422 -- Allocated text buffer 2423 2424 Status : Boolean; 2425 pragma Warnings (Off, Status); 2426 -- For the calls to Close 2427 2428 begin 2429 Current_Full_Lib_Name := Full_Lib_File; 2430 Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name); 2431 2432 if Current_Full_Lib_Name = No_File then 2433 if Fatal_Err then 2434 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); 2435 else 2436 Current_Full_Obj_Stamp := Empty_Time_Stamp; 2437 return null; 2438 end if; 2439 end if; 2440 2441 Get_Name_String (Current_Full_Lib_Name); 2442 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2443 2444 -- Open the library FD, note that we open in binary mode, because as 2445 -- documented in the spec, the caller is expected to handle either 2446 -- DOS or Unix mode files, and there is no point in wasting time on 2447 -- text translation when it is not required. 2448 2449 Lib_FD := Open_Read (Name_Buffer'Address, Binary); 2450 2451 if Lib_FD = Invalid_FD then 2452 if Fatal_Err then 2453 Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len)); 2454 else 2455 Current_Full_Obj_Stamp := Empty_Time_Stamp; 2456 return null; 2457 end if; 2458 end if; 2459 2460 -- Compute the length of the file (potentially also preparing other data 2461 -- like the timestamp and whether the file is read-only, for future use) 2462 2463 Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr)); 2464 2465 -- Check for object file consistency if requested 2466 2467 if Opt.Check_Object_Consistency then 2468 -- On most systems, this does not result in an extra system call 2469 2470 Current_Full_Lib_Stamp := 2471 OS_Time_To_GNAT_Time 2472 (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr)); 2473 2474 -- ??? One system call here 2475 2476 Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name); 2477 2478 if Current_Full_Obj_Stamp (1) = ' ' then 2479 2480 -- When the library is readonly always assume object is consistent 2481 -- The call to Is_Writable_File only results in a system call on 2482 -- some systems, but in most cases it has already been computed as 2483 -- part of the call to File_Length above. 2484 2485 Get_Name_String (Current_Full_Lib_Name); 2486 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2487 2488 if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then 2489 Current_Full_Obj_Stamp := Current_Full_Lib_Stamp; 2490 2491 elsif Fatal_Err then 2492 Get_Name_String (Current_Full_Obj_Name); 2493 Close (Lib_FD, Status); 2494 2495 -- No need to check the status, we fail anyway 2496 2497 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); 2498 2499 else 2500 Current_Full_Obj_Stamp := Empty_Time_Stamp; 2501 Close (Lib_FD, Status); 2502 2503 -- No need to check the status, we return null anyway 2504 2505 return null; 2506 end if; 2507 2508 elsif Current_Full_Obj_Stamp < Current_Full_Lib_Stamp then 2509 Close (Lib_FD, Status); 2510 2511 -- No need to check the status, we return null anyway 2512 2513 return null; 2514 end if; 2515 end if; 2516 2517 -- Read data from the file 2518 2519 declare 2520 Actual_Len : Integer := 0; 2521 2522 Lo : constant Text_Ptr := 0; 2523 -- Low bound for allocated text buffer 2524 2525 Hi : Text_Ptr := Text_Ptr (Len); 2526 -- High bound for allocated text buffer. Note length is Len + 1 2527 -- which allows for extra EOF character at the end of the buffer. 2528 2529 begin 2530 -- Allocate text buffer. Note extra character at end for EOF 2531 2532 Text := new Text_Buffer (Lo .. Hi); 2533 2534 -- Some systems have file types that require one read per line, 2535 -- so read until we get the Len bytes or until there are no more 2536 -- characters. 2537 2538 Hi := Lo; 2539 loop 2540 Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len); 2541 Hi := Hi + Text_Ptr (Actual_Len); 2542 exit when Actual_Len = Len or else Actual_Len <= 0; 2543 end loop; 2544 2545 Text (Hi) := EOF; 2546 end; 2547 2548 -- Read is complete, close file and we are done 2549 2550 Close (Lib_FD, Status); 2551 -- The status should never be False. But, if it is, what can we do? 2552 -- So, we don't test it. 2553 2554 return Text; 2555 2556 end Read_Library_Info_From_Full; 2557 2558 ---------------------- 2559 -- Read_Source_File -- 2560 ---------------------- 2561 2562 procedure Read_Source_File 2563 (N : File_Name_Type; 2564 Lo : Source_Ptr; 2565 Hi : out Source_Ptr; 2566 Src : out Source_Buffer_Ptr; 2567 FD : out File_Descriptor; 2568 T : File_Type := Source) 2569 is 2570 Len : Integer; 2571 -- Length of file, assume no more than 2 gigabytes of source 2572 2573 Actual_Len : Integer; 2574 2575 Status : Boolean; 2576 pragma Warnings (Off, Status); 2577 -- For the call to Close 2578 2579 begin 2580 Current_Full_Source_Name := Find_File (N, T, Full_Name => True); 2581 Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name); 2582 2583 if Current_Full_Source_Name = No_File then 2584 2585 -- If we were trying to access the main file and we could not find 2586 -- it, we have an error. 2587 2588 if N = Current_Main then 2589 Get_Name_String (N); 2590 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); 2591 end if; 2592 2593 FD := Null_FD; 2594 Src := null; 2595 Hi := No_Location; 2596 return; 2597 end if; 2598 2599 Get_Name_String (Current_Full_Source_Name); 2600 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2601 2602 -- Open the source FD, note that we open in binary mode, because as 2603 -- documented in the spec, the caller is expected to handle either 2604 -- DOS or Unix mode files, and there is no point in wasting time on 2605 -- text translation when it is not required. 2606 2607 FD := Open_Read (Name_Buffer'Address, Binary); 2608 2609 if FD = Invalid_FD then 2610 Src := null; 2611 Hi := No_Location; 2612 return; 2613 end if; 2614 2615 -- If it's a Source file, print out the file name, if requested, and if 2616 -- it's not part of the runtimes, store it in File_Name_Chars. We don't 2617 -- want to print non-Source files, like GNAT-TEMP-000001.TMP used to 2618 -- pass information from gprbuild to gcc. We don't want to save runtime 2619 -- file names, because we don't want users to send them in bug reports. 2620 2621 if T = Source then 2622 declare 2623 Name : String renames Name_Buffer (1 .. Name_Len); 2624 Inc : String renames Include_Dir_Default_Prefix.all; 2625 2626 Part_Of_Runtimes : constant Boolean := 2627 Inc /= "" 2628 and then Inc'Length < Name_Len 2629 and then Name_Buffer (1 .. Inc'Length) = Inc; 2630 2631 begin 2632 if Debug.Debug_Flag_Dot_N then 2633 Write_Line (Name); 2634 end if; 2635 2636 if not Part_Of_Runtimes then 2637 File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name)); 2638 File_Name_Chars.Append (ASCII.LF); 2639 end if; 2640 end; 2641 end if; 2642 2643 -- Prepare to read data from the file 2644 2645 Len := Integer (File_Length (FD)); 2646 2647 -- Set Hi so that length is one more than the physical length, 2648 -- allowing for the extra EOF character at the end of the buffer 2649 2650 Hi := Lo + Source_Ptr (Len); 2651 2652 -- Do the actual read operation 2653 2654 declare 2655 Var_Ptr : constant Source_Buffer_Ptr_Var := 2656 new Source_Buffer (Lo .. Hi); 2657 -- Allocate source buffer, allowing extra character at end for EOF 2658 begin 2659 -- Some systems have file types that require one read per line, 2660 -- so read until we get the Len bytes or until there are no more 2661 -- characters. 2662 2663 Hi := Lo; 2664 loop 2665 Actual_Len := Read (FD, Var_Ptr (Hi)'Address, Len); 2666 Hi := Hi + Source_Ptr (Actual_Len); 2667 exit when Actual_Len = Len or else Actual_Len <= 0; 2668 end loop; 2669 2670 Var_Ptr (Hi) := EOF; 2671 Src := Var_Ptr.all'Access; 2672 end; 2673 2674 -- Read is complete, get time stamp and close file and we are done 2675 2676 Close (FD, Status); 2677 2678 -- The status should never be False. But, if it is, what can we do? 2679 -- So, we don't test it. 2680 2681 -- ???We don't really need to return Hi anymore; We could get rid of 2682 -- it. We could also make this into a function. 2683 2684 pragma Assert (Hi = Src'Last); 2685 end Read_Source_File; 2686 2687 ------------------- 2688 -- Relocate_Path -- 2689 ------------------- 2690 2691 function Relocate_Path 2692 (Prefix : String; 2693 Path : String) return String_Ptr 2694 is 2695 S : String_Ptr; 2696 2697 procedure set_std_prefix (S : String; Len : Integer); 2698 pragma Import (C, set_std_prefix); 2699 2700 begin 2701 if Std_Prefix = null then 2702 Std_Prefix := Executable_Prefix; 2703 2704 if Std_Prefix.all /= "" then 2705 2706 -- Remove trailing directory separator when calling set_std_prefix 2707 2708 set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1); 2709 end if; 2710 end if; 2711 2712 if Path'Last >= Prefix'Last and then Path (Prefix'Range) = Prefix then 2713 if Std_Prefix.all /= "" then 2714 S := new String 2715 (1 .. Std_Prefix'Length + Path'Last - Prefix'Last); 2716 S (1 .. Std_Prefix'Length) := Std_Prefix.all; 2717 S (Std_Prefix'Length + 1 .. S'Last) := 2718 Path (Prefix'Last + 1 .. Path'Last); 2719 return S; 2720 end if; 2721 end if; 2722 2723 return new String'(Path); 2724 end Relocate_Path; 2725 2726 ----------------- 2727 -- Set_Program -- 2728 ----------------- 2729 2730 procedure Set_Program (P : Program_Type) is 2731 begin 2732 if Program_Set then 2733 Fail ("Set_Program called twice"); 2734 end if; 2735 2736 Program_Set := True; 2737 Running_Program := P; 2738 end Set_Program; 2739 2740 ---------------- 2741 -- Shared_Lib -- 2742 ---------------- 2743 2744 function Shared_Lib (Name : String) return String is 2745 Library : String (1 .. Name'Length + Library_Version'Length + 3); 2746 -- 3 = 2 for "-l" + 1 for "-" before lib version 2747 2748 begin 2749 Library (1 .. 2) := "-l"; 2750 Library (3 .. 2 + Name'Length) := Name; 2751 Library (3 + Name'Length) := '-'; 2752 Library (4 + Name'Length .. Library'Last) := Library_Version; 2753 return Library; 2754 end Shared_Lib; 2755 2756 ---------------------- 2757 -- Smart_File_Stamp -- 2758 ---------------------- 2759 2760 function Smart_File_Stamp 2761 (N : File_Name_Type; 2762 T : File_Type) return Time_Stamp_Type 2763 is 2764 File : File_Name_Type; 2765 Attr : aliased File_Attributes; 2766 2767 begin 2768 if not File_Cache_Enabled then 2769 Find_File (N, T, File, Attr'Access); 2770 else 2771 Smart_Find_File (N, T, File, Attr); 2772 end if; 2773 2774 if File = No_File then 2775 return Empty_Time_Stamp; 2776 else 2777 Get_Name_String (File); 2778 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2779 return 2780 OS_Time_To_GNAT_Time 2781 (File_Time_Stamp (Name_Buffer'Address, Attr'Access)); 2782 end if; 2783 end Smart_File_Stamp; 2784 2785 --------------------- 2786 -- Smart_Find_File -- 2787 --------------------- 2788 2789 function Smart_Find_File 2790 (N : File_Name_Type; 2791 T : File_Type) return File_Name_Type 2792 is 2793 File : File_Name_Type; 2794 Attr : File_Attributes; 2795 begin 2796 Smart_Find_File (N, T, File, Attr); 2797 return File; 2798 end Smart_Find_File; 2799 2800 --------------------- 2801 -- Smart_Find_File -- 2802 --------------------- 2803 2804 procedure Smart_Find_File 2805 (N : File_Name_Type; 2806 T : File_Type; 2807 Found : out File_Name_Type; 2808 Attr : out File_Attributes) 2809 is 2810 Info : File_Info_Cache; 2811 2812 begin 2813 if not File_Cache_Enabled then 2814 Find_File (N, T, Info.File, Info.Attr'Access); 2815 2816 else 2817 Info := File_Name_Hash_Table.Get (N); 2818 2819 if Info.File = No_File then 2820 Find_File (N, T, Info.File, Info.Attr'Access); 2821 File_Name_Hash_Table.Set (N, Info); 2822 end if; 2823 end if; 2824 2825 Found := Info.File; 2826 Attr := Info.Attr; 2827 end Smart_Find_File; 2828 2829 ---------------------- 2830 -- Source_File_Data -- 2831 ---------------------- 2832 2833 procedure Source_File_Data (Cache : Boolean) is 2834 begin 2835 File_Cache_Enabled := Cache; 2836 end Source_File_Data; 2837 2838 ----------------------- 2839 -- Source_File_Stamp -- 2840 ----------------------- 2841 2842 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is 2843 begin 2844 return Smart_File_Stamp (N, Source); 2845 end Source_File_Stamp; 2846 2847 --------------------- 2848 -- Strip_Directory -- 2849 --------------------- 2850 2851 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is 2852 begin 2853 Get_Name_String (Name); 2854 2855 for J in reverse 1 .. Name_Len - 1 loop 2856 2857 -- If we find the last directory separator 2858 2859 if Is_Directory_Separator (Name_Buffer (J)) then 2860 2861 -- Return part of Name that follows this last directory separator 2862 2863 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len); 2864 Name_Len := Name_Len - J; 2865 return Name_Find; 2866 end if; 2867 end loop; 2868 2869 -- There were no directory separator, just return Name 2870 2871 return Name; 2872 end Strip_Directory; 2873 2874 ------------------ 2875 -- Strip_Suffix -- 2876 ------------------ 2877 2878 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is 2879 begin 2880 Get_Name_String (Name); 2881 2882 for J in reverse 2 .. Name_Len loop 2883 2884 -- If we found the last '.', return part of Name that precedes it 2885 2886 if Name_Buffer (J) = '.' then 2887 Name_Len := J - 1; 2888 return Name_Enter; 2889 end if; 2890 end loop; 2891 2892 return Name; 2893 end Strip_Suffix; 2894 2895 --------------------------- 2896 -- To_Canonical_File_List -- 2897 --------------------------- 2898 2899 function To_Canonical_File_List 2900 (Wildcard_Host_File : String; 2901 Only_Dirs : Boolean) return String_Access_List_Access 2902 is 2903 function To_Canonical_File_List_Init 2904 (Host_File : Address; 2905 Only_Dirs : Integer) return Integer; 2906 pragma Import (C, To_Canonical_File_List_Init, 2907 "__gnat_to_canonical_file_list_init"); 2908 2909 function To_Canonical_File_List_Next return Address; 2910 pragma Import (C, To_Canonical_File_List_Next, 2911 "__gnat_to_canonical_file_list_next"); 2912 2913 procedure To_Canonical_File_List_Free; 2914 pragma Import (C, To_Canonical_File_List_Free, 2915 "__gnat_to_canonical_file_list_free"); 2916 2917 Num_Files : Integer; 2918 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1); 2919 2920 begin 2921 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) := 2922 Wildcard_Host_File; 2923 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL; 2924 2925 -- Do the expansion and say how many there are 2926 2927 Num_Files := To_Canonical_File_List_Init 2928 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs)); 2929 2930 declare 2931 Canonical_File_List : String_Access_List (1 .. Num_Files); 2932 Canonical_File_Addr : Address; 2933 Canonical_File_Len : CRTL.size_t; 2934 2935 begin 2936 -- Retrieve the expanded directory names and build the list 2937 2938 for J in 1 .. Num_Files loop 2939 Canonical_File_Addr := To_Canonical_File_List_Next; 2940 Canonical_File_Len := C_String_Length (Canonical_File_Addr); 2941 Canonical_File_List (J) := To_Path_String_Access 2942 (Canonical_File_Addr, Canonical_File_Len); 2943 end loop; 2944 2945 -- Free up the storage 2946 2947 To_Canonical_File_List_Free; 2948 2949 return new String_Access_List'(Canonical_File_List); 2950 end; 2951 end To_Canonical_File_List; 2952 2953 ---------------------- 2954 -- To_Host_Dir_Spec -- 2955 ---------------------- 2956 2957 function To_Host_Dir_Spec 2958 (Canonical_Dir : String; 2959 Prefix_Style : Boolean) return String_Access 2960 is 2961 function To_Host_Dir_Spec 2962 (Canonical_Dir : Address; 2963 Prefix_Flag : Integer) return Address; 2964 pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec"); 2965 2966 C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1); 2967 Host_Dir_Addr : Address; 2968 Host_Dir_Len : CRTL.size_t; 2969 2970 begin 2971 C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir; 2972 C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL; 2973 2974 if Prefix_Style then 2975 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1); 2976 else 2977 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0); 2978 end if; 2979 Host_Dir_Len := C_String_Length (Host_Dir_Addr); 2980 2981 if Host_Dir_Len = 0 then 2982 return null; 2983 else 2984 return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len); 2985 end if; 2986 end To_Host_Dir_Spec; 2987 2988 ----------------------- 2989 -- To_Host_File_Spec -- 2990 ----------------------- 2991 2992 function To_Host_File_Spec 2993 (Canonical_File : String) return String_Access 2994 is 2995 function To_Host_File_Spec (Canonical_File : Address) return Address; 2996 pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec"); 2997 2998 C_Canonical_File : String (1 .. Canonical_File'Length + 1); 2999 Host_File_Addr : Address; 3000 Host_File_Len : CRTL.size_t; 3001 3002 begin 3003 C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File; 3004 C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL; 3005 3006 Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address); 3007 Host_File_Len := C_String_Length (Host_File_Addr); 3008 3009 if Host_File_Len = 0 then 3010 return null; 3011 else 3012 return To_Path_String_Access 3013 (Host_File_Addr, Host_File_Len); 3014 end if; 3015 end To_Host_File_Spec; 3016 3017 --------------------------- 3018 -- To_Path_String_Access -- 3019 --------------------------- 3020 3021 function To_Path_String_Access 3022 (Path_Addr : Address; 3023 Path_Len : CRTL.size_t) return String_Access 3024 is 3025 subtype Path_String is String (1 .. Integer (Path_Len)); 3026 type Path_String_Access is access Path_String; 3027 3028 function Address_To_Access is new 3029 Unchecked_Conversion (Source => Address, 3030 Target => Path_String_Access); 3031 3032 Path_Access : constant Path_String_Access := 3033 Address_To_Access (Path_Addr); 3034 3035 Return_Val : String_Access; 3036 3037 begin 3038 Return_Val := new String (1 .. Integer (Path_Len)); 3039 3040 for J in 1 .. Integer (Path_Len) loop 3041 Return_Val (J) := Path_Access (J); 3042 end loop; 3043 3044 return Return_Val; 3045 end To_Path_String_Access; 3046 3047 ----------------- 3048 -- Update_Path -- 3049 ----------------- 3050 3051 function Update_Path (Path : String_Ptr) return String_Ptr is 3052 3053 function C_Update_Path (Path, Component : Address) return Address; 3054 pragma Import (C, C_Update_Path, "update_path"); 3055 3056 In_Length : constant Integer := Path'Length; 3057 In_String : String (1 .. In_Length + 1); 3058 Component_Name : aliased String := "GCC" & ASCII.NUL; 3059 Result_Ptr : Address; 3060 Result_Length : CRTL.size_t; 3061 Out_String : String_Ptr; 3062 3063 begin 3064 In_String (1 .. In_Length) := Path.all; 3065 In_String (In_Length + 1) := ASCII.NUL; 3066 Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address); 3067 Result_Length := CRTL.strlen (Result_Ptr); 3068 3069 Out_String := new String (1 .. Integer (Result_Length)); 3070 CRTL.strncpy (Out_String.all'Address, Result_Ptr, Result_Length); 3071 return Out_String; 3072 end Update_Path; 3073 3074 ---------------- 3075 -- Write_Info -- 3076 ---------------- 3077 3078 procedure Write_Info (Info : String) is 3079 begin 3080 Write_With_Check (Info'Address, Info'Length); 3081 Write_With_Check (EOL'Address, 1); 3082 end Write_Info; 3083 3084 ------------------------ 3085 -- Write_Program_Name -- 3086 ------------------------ 3087 3088 procedure Write_Program_Name is 3089 Save_Buffer : constant String (1 .. Name_Len) := 3090 Name_Buffer (1 .. Name_Len); 3091 3092 begin 3093 Find_Program_Name; 3094 3095 -- Convert the name to lower case so error messages are the same on 3096 -- all systems. 3097 3098 for J in 1 .. Name_Len loop 3099 if Name_Buffer (J) in 'A' .. 'Z' then 3100 Name_Buffer (J) := 3101 Character'Val (Character'Pos (Name_Buffer (J)) + 32); 3102 end if; 3103 end loop; 3104 3105 Write_Str (Name_Buffer (1 .. Name_Len)); 3106 3107 -- Restore Name_Buffer which was clobbered by the call to 3108 -- Find_Program_Name 3109 3110 Name_Len := Save_Buffer'Last; 3111 Name_Buffer (1 .. Name_Len) := Save_Buffer; 3112 end Write_Program_Name; 3113 3114 ---------------------- 3115 -- Write_With_Check -- 3116 ---------------------- 3117 3118 procedure Write_With_Check (A : Address; N : Integer) is 3119 Ignore : Boolean; 3120 begin 3121 if N = Write (Output_FD, A, N) then 3122 return; 3123 else 3124 Write_Str ("error: disk full writing "); 3125 Write_Name_Decoded (Output_File_Name); 3126 Write_Eol; 3127 Name_Len := Name_Len + 1; 3128 Name_Buffer (Name_Len) := ASCII.NUL; 3129 Delete_File (Name_Buffer'Address, Ignore); 3130 Exit_Program (E_Fatal); 3131 end if; 3132 end Write_With_Check; 3133 3134---------------------------- 3135-- Package Initialization -- 3136---------------------------- 3137 3138 procedure Reset_File_Attributes (Attr : System.Address); 3139 pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes"); 3140 3141begin 3142 Initialization : declare 3143 3144 function Get_Default_Identifier_Character_Set return Character; 3145 pragma Import (C, Get_Default_Identifier_Character_Set, 3146 "__gnat_get_default_identifier_character_set"); 3147 -- Function to determine the default identifier character set, 3148 -- which is system dependent. See Opt package spec for a list of 3149 -- the possible character codes and their interpretations. 3150 3151 function Get_Maximum_File_Name_Length return Int; 3152 pragma Import (C, Get_Maximum_File_Name_Length, 3153 "__gnat_get_maximum_file_name_length"); 3154 -- Function to get maximum file name length for system 3155 3156 Sizeof_File_Attributes : Integer; 3157 pragma Import (C, Sizeof_File_Attributes, 3158 "__gnat_size_of_file_attributes"); 3159 3160 begin 3161 pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size); 3162 3163 Reset_File_Attributes (Unknown_Attributes'Address); 3164 3165 Identifier_Character_Set := Get_Default_Identifier_Character_Set; 3166 Maximum_File_Name_Length := Get_Maximum_File_Name_Length; 3167 3168 -- Following should be removed by having above function return 3169 -- Integer'Last as indication of no maximum instead of -1 ??? 3170 3171 if Maximum_File_Name_Length = -1 then 3172 Maximum_File_Name_Length := Int'Last; 3173 end if; 3174 3175 Src_Search_Directories.Set_Last (Primary_Directory); 3176 Src_Search_Directories.Table (Primary_Directory) := new String'(""); 3177 3178 Lib_Search_Directories.Set_Last (Primary_Directory); 3179 Lib_Search_Directories.Table (Primary_Directory) := new String'(""); 3180 3181 Osint.Initialize; 3182 end Initialization; 3183 3184end Osint; 3185