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