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