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