1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- O S I N T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, 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. In this case 1048 -- 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 -- Prep_Suffix -- 2195 ----------------- 2196 2197 function Prep_Suffix return String is 2198 begin 2199 if Hostparm.OpenVMS then 2200 return "_prep"; 2201 else 2202 return ".prep"; 2203 end if; 2204 end Prep_Suffix; 2205 2206 ------------------ 2207 -- Program_Name -- 2208 ------------------ 2209 2210 function Program_Name (Nam : String; Prog : String) return String_Access is 2211 End_Of_Prefix : Natural := 0; 2212 Start_Of_Prefix : Positive := 1; 2213 Start_Of_Suffix : Positive; 2214 2215 begin 2216 -- GNAAMP tool names require special treatment 2217 2218 if AAMP_On_Target then 2219 2220 -- The name "gcc" is mapped to "gnaamp" (the compiler driver) 2221 2222 if Nam = "gcc" then 2223 return new String'("gnaamp"); 2224 2225 -- Tool names starting with "gnat" are mapped by substituting the 2226 -- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp"). 2227 2228 elsif Nam'Length >= 4 2229 and then Nam (Nam'First .. Nam'First + 3) = "gnat" 2230 then 2231 return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last)); 2232 2233 -- No other mapping rules, so we continue and handle any other forms 2234 -- of tool names the same as on other targets. 2235 2236 else 2237 null; 2238 end if; 2239 end if; 2240 2241 -- Get the name of the current program being executed 2242 2243 Find_Program_Name; 2244 2245 Start_Of_Suffix := Name_Len + 1; 2246 2247 -- Find the target prefix if any, for the cross compilation case. 2248 -- For instance in "powerpc-elf-gcc" the target prefix is 2249 -- "powerpc-elf-" 2250 -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1" 2251 2252 for J in reverse 1 .. Name_Len loop 2253 if Name_Buffer (J) = '/' 2254 or else Name_Buffer (J) = Directory_Separator 2255 or else Name_Buffer (J) = ':' 2256 then 2257 Start_Of_Prefix := J + 1; 2258 exit; 2259 end if; 2260 end loop; 2261 2262 -- Find End_Of_Prefix 2263 2264 for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop 2265 if Name_Buffer (J .. J + Prog'Length - 1) = Prog then 2266 End_Of_Prefix := J - 1; 2267 exit; 2268 end if; 2269 end loop; 2270 2271 if End_Of_Prefix > 1 then 2272 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1; 2273 end if; 2274 2275 -- Create the new program name 2276 2277 return new String' 2278 (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix) 2279 & Nam 2280 & Name_Buffer (Start_Of_Suffix .. Name_Len)); 2281 end Program_Name; 2282 2283 ------------------------------ 2284 -- Read_Default_Search_Dirs -- 2285 ------------------------------ 2286 2287 function Read_Default_Search_Dirs 2288 (Search_Dir_Prefix : String_Access; 2289 Search_File : String_Access; 2290 Search_Dir_Default_Name : String_Access) return String_Access 2291 is 2292 Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length; 2293 Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1); 2294 File_FD : File_Descriptor; 2295 S, S1 : String_Access; 2296 Len : Integer; 2297 Curr : Integer; 2298 Actual_Len : Integer; 2299 J1 : Integer; 2300 2301 Prev_Was_Separator : Boolean; 2302 Nb_Relative_Dir : Integer; 2303 2304 function Is_Relative (S : String; K : Positive) return Boolean; 2305 pragma Inline (Is_Relative); 2306 -- Returns True if a relative directory specification is found 2307 -- in S at position K, False otherwise. 2308 2309 ----------------- 2310 -- Is_Relative -- 2311 ----------------- 2312 2313 function Is_Relative (S : String; K : Positive) return Boolean is 2314 begin 2315 return not Is_Absolute_Path (S (K .. S'Last)); 2316 end Is_Relative; 2317 2318 -- Start of processing for Read_Default_Search_Dirs 2319 2320 begin 2321 -- Construct a C compatible character string buffer 2322 2323 Buffer (1 .. Search_Dir_Prefix.all'Length) 2324 := Search_Dir_Prefix.all; 2325 Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1) 2326 := Search_File.all; 2327 Buffer (Buffer'Last) := ASCII.NUL; 2328 2329 File_FD := Open_Read (Buffer'Address, Binary); 2330 if File_FD = Invalid_FD then 2331 return Search_Dir_Default_Name; 2332 end if; 2333 2334 Len := Integer (File_Length (File_FD)); 2335 2336 -- An extra character for a trailing Path_Separator is allocated 2337 2338 S := new String (1 .. Len + 1); 2339 S (Len + 1) := Path_Separator; 2340 2341 -- Read the file. Note that the loop is not necessary since the 2342 -- whole file is read at once except on VMS. 2343 2344 Curr := 1; 2345 Actual_Len := Len; 2346 while Actual_Len /= 0 loop 2347 Actual_Len := Read (File_FD, S (Curr)'Address, Len); 2348 Curr := Curr + Actual_Len; 2349 end loop; 2350 2351 -- Process the file, dealing with path separators 2352 2353 Prev_Was_Separator := True; 2354 Nb_Relative_Dir := 0; 2355 for J in 1 .. Len loop 2356 2357 -- Treat any control character as a path separator. Note that we do 2358 -- not treat space as a path separator (we used to treat space as a 2359 -- path separator in an earlier version). That way space can appear 2360 -- as a legitimate character in a path name. 2361 2362 -- Why do we treat all control characters as path separators??? 2363 2364 if S (J) in ASCII.NUL .. ASCII.US then 2365 S (J) := Path_Separator; 2366 end if; 2367 2368 -- Test for explicit path separator (or control char as above) 2369 2370 if S (J) = Path_Separator then 2371 Prev_Was_Separator := True; 2372 2373 -- If not path separator, register use of relative directory 2374 2375 else 2376 if Prev_Was_Separator and then Is_Relative (S.all, J) then 2377 Nb_Relative_Dir := Nb_Relative_Dir + 1; 2378 end if; 2379 2380 Prev_Was_Separator := False; 2381 end if; 2382 end loop; 2383 2384 if Nb_Relative_Dir = 0 then 2385 return S; 2386 end if; 2387 2388 -- Add the Search_Dir_Prefix to all relative paths 2389 2390 S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len); 2391 J1 := 1; 2392 Prev_Was_Separator := True; 2393 for J in 1 .. Len + 1 loop 2394 if S (J) = Path_Separator then 2395 Prev_Was_Separator := True; 2396 2397 else 2398 if Prev_Was_Separator and then Is_Relative (S.all, J) then 2399 S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all; 2400 J1 := J1 + Prefix_Len; 2401 end if; 2402 2403 Prev_Was_Separator := False; 2404 end if; 2405 S1 (J1) := S (J); 2406 J1 := J1 + 1; 2407 end loop; 2408 2409 Free (S); 2410 return S1; 2411 end Read_Default_Search_Dirs; 2412 2413 ----------------------- 2414 -- Read_Library_Info -- 2415 ----------------------- 2416 2417 function Read_Library_Info 2418 (Lib_File : File_Name_Type; 2419 Fatal_Err : Boolean := False) return Text_Buffer_Ptr 2420 is 2421 File : File_Name_Type; 2422 Attr : aliased File_Attributes; 2423 begin 2424 Find_File (Lib_File, Library, File, Attr'Access); 2425 return Read_Library_Info_From_Full 2426 (Full_Lib_File => File, 2427 Lib_File_Attr => Attr'Access, 2428 Fatal_Err => Fatal_Err); 2429 end Read_Library_Info; 2430 2431 --------------------------------- 2432 -- Read_Library_Info_From_Full -- 2433 --------------------------------- 2434 2435 function Read_Library_Info_From_Full 2436 (Full_Lib_File : File_Name_Type; 2437 Lib_File_Attr : access File_Attributes; 2438 Fatal_Err : Boolean := False) return Text_Buffer_Ptr 2439 is 2440 Lib_FD : File_Descriptor; 2441 -- The file descriptor for the current library file. A negative value 2442 -- indicates failure to open the specified source file. 2443 2444 Len : Integer; 2445 -- Length of source file text (ALI). If it doesn't fit in an integer 2446 -- we're probably stuck anyway (>2 gigs of source seems a lot, and 2447 -- there are other places in the compiler that make this assumption). 2448 2449 Text : Text_Buffer_Ptr; 2450 -- Allocated text buffer 2451 2452 Status : Boolean; 2453 pragma Warnings (Off, Status); 2454 -- For the calls to Close 2455 2456 begin 2457 Current_Full_Lib_Name := Full_Lib_File; 2458 Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name); 2459 2460 if Current_Full_Lib_Name = No_File then 2461 if Fatal_Err then 2462 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); 2463 else 2464 Current_Full_Obj_Stamp := Empty_Time_Stamp; 2465 return null; 2466 end if; 2467 end if; 2468 2469 Get_Name_String (Current_Full_Lib_Name); 2470 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2471 2472 -- Open the library FD, note that we open in binary mode, because as 2473 -- documented in the spec, the caller is expected to handle either 2474 -- DOS or Unix mode files, and there is no point in wasting time on 2475 -- text translation when it is not required. 2476 2477 Lib_FD := Open_Read (Name_Buffer'Address, Binary); 2478 2479 if Lib_FD = Invalid_FD then 2480 if Fatal_Err then 2481 Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len)); 2482 else 2483 Current_Full_Obj_Stamp := Empty_Time_Stamp; 2484 return null; 2485 end if; 2486 end if; 2487 2488 -- Compute the length of the file (potentially also preparing other data 2489 -- like the timestamp and whether the file is read-only, for future use) 2490 2491 Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr)); 2492 2493 -- Check for object file consistency if requested 2494 2495 if Opt.Check_Object_Consistency then 2496 -- On most systems, this does not result in an extra system call 2497 2498 Current_Full_Lib_Stamp := 2499 OS_Time_To_GNAT_Time 2500 (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr)); 2501 2502 -- ??? One system call here 2503 2504 Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name); 2505 2506 if Current_Full_Obj_Stamp (1) = ' ' then 2507 2508 -- When the library is readonly always assume object is consistent 2509 -- The call to Is_Writable_File only results in a system call on 2510 -- some systems, but in most cases it has already been computed as 2511 -- part of the call to File_Length above. 2512 2513 Get_Name_String (Current_Full_Lib_Name); 2514 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2515 2516 if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then 2517 Current_Full_Obj_Stamp := Current_Full_Lib_Stamp; 2518 2519 elsif Fatal_Err then 2520 Get_Name_String (Current_Full_Obj_Name); 2521 Close (Lib_FD, Status); 2522 2523 -- No need to check the status, we fail anyway 2524 2525 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); 2526 2527 else 2528 Current_Full_Obj_Stamp := Empty_Time_Stamp; 2529 Close (Lib_FD, Status); 2530 2531 -- No need to check the status, we return null anyway 2532 2533 return null; 2534 end if; 2535 2536 elsif Current_Full_Obj_Stamp < Current_Full_Lib_Stamp then 2537 Close (Lib_FD, Status); 2538 2539 -- No need to check the status, we return null anyway 2540 2541 return null; 2542 end if; 2543 end if; 2544 2545 -- Read data from the file 2546 2547 declare 2548 Actual_Len : Integer := 0; 2549 2550 Lo : constant Text_Ptr := 0; 2551 -- Low bound for allocated text buffer 2552 2553 Hi : Text_Ptr := Text_Ptr (Len); 2554 -- High bound for allocated text buffer. Note length is Len + 1 2555 -- which allows for extra EOF character at the end of the buffer. 2556 2557 begin 2558 -- Allocate text buffer. Note extra character at end for EOF 2559 2560 Text := new Text_Buffer (Lo .. Hi); 2561 2562 -- Some systems (e.g. VMS) have file types that require one 2563 -- read per line, so read until we get the Len bytes or until 2564 -- there are no more characters. 2565 2566 Hi := Lo; 2567 loop 2568 Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len); 2569 Hi := Hi + Text_Ptr (Actual_Len); 2570 exit when Actual_Len = Len or else Actual_Len <= 0; 2571 end loop; 2572 2573 Text (Hi) := EOF; 2574 end; 2575 2576 -- Read is complete, close file and we are done 2577 2578 Close (Lib_FD, Status); 2579 -- The status should never be False. But, if it is, what can we do? 2580 -- So, we don't test it. 2581 2582 return Text; 2583 2584 end Read_Library_Info_From_Full; 2585 2586 ---------------------- 2587 -- Read_Source_File -- 2588 ---------------------- 2589 2590 procedure Read_Source_File 2591 (N : File_Name_Type; 2592 Lo : Source_Ptr; 2593 Hi : out Source_Ptr; 2594 Src : out Source_Buffer_Ptr; 2595 T : File_Type := Source) 2596 is 2597 Source_File_FD : File_Descriptor; 2598 -- The file descriptor for the current source file. A negative value 2599 -- indicates failure to open the specified source file. 2600 2601 Len : Integer; 2602 -- Length of file, assume no more than 2 gigabytes of source 2603 2604 Actual_Len : Integer; 2605 2606 Status : Boolean; 2607 pragma Warnings (Off, Status); 2608 -- For the call to Close 2609 2610 begin 2611 Current_Full_Source_Name := Find_File (N, T); 2612 Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name); 2613 2614 if Current_Full_Source_Name = No_File then 2615 2616 -- If we were trying to access the main file and we could not find 2617 -- it, we have an error. 2618 2619 if N = Current_Main then 2620 Get_Name_String (N); 2621 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); 2622 end if; 2623 2624 Src := null; 2625 Hi := No_Location; 2626 return; 2627 end if; 2628 2629 Get_Name_String (Current_Full_Source_Name); 2630 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2631 2632 -- Open the source FD, note that we open in binary mode, because as 2633 -- documented in the spec, the caller is expected to handle either 2634 -- DOS or Unix mode files, and there is no point in wasting time on 2635 -- text translation when it is not required. 2636 2637 Source_File_FD := Open_Read (Name_Buffer'Address, Binary); 2638 2639 if Source_File_FD = Invalid_FD then 2640 Src := null; 2641 Hi := No_Location; 2642 return; 2643 end if; 2644 2645 -- Print out the file name, if requested, and if it's not part of the 2646 -- runtimes, store it in File_Name_Chars. 2647 2648 declare 2649 Name : String renames Name_Buffer (1 .. Name_Len); 2650 Inc : String renames Include_Dir_Default_Prefix.all; 2651 2652 begin 2653 if Debug.Debug_Flag_Dot_N then 2654 Write_Line (Name); 2655 end if; 2656 2657 if Inc /= "" 2658 and then Inc'Length < Name_Len 2659 and then Name_Buffer (1 .. Inc'Length) = Inc 2660 then 2661 -- Part of runtimes, so ignore it 2662 2663 null; 2664 2665 else 2666 File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name)); 2667 File_Name_Chars.Append (ASCII.LF); 2668 end if; 2669 end; 2670 2671 -- Prepare to read data from the file 2672 2673 Len := Integer (File_Length (Source_File_FD)); 2674 2675 -- Set Hi so that length is one more than the physical length, 2676 -- allowing for the extra EOF character at the end of the buffer 2677 2678 Hi := Lo + Source_Ptr (Len); 2679 2680 -- Do the actual read operation 2681 2682 declare 2683 subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); 2684 -- Physical buffer allocated 2685 2686 type Actual_Source_Ptr is access Actual_Source_Buffer; 2687 -- This is the pointer type for the physical buffer allocated 2688 2689 Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer; 2690 -- And this is the actual physical buffer 2691 2692 begin 2693 -- Allocate source buffer, allowing extra character at end for EOF 2694 2695 -- Some systems (e.g. VMS) have file types that require one read per 2696 -- line, so read until we get the Len bytes or until there are no 2697 -- more characters. 2698 2699 Hi := Lo; 2700 loop 2701 Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len); 2702 Hi := Hi + Source_Ptr (Actual_Len); 2703 exit when Actual_Len = Len or else Actual_Len <= 0; 2704 end loop; 2705 2706 Actual_Ptr (Hi) := EOF; 2707 2708 -- Now we need to work out the proper virtual origin pointer to 2709 -- return. This is exactly Actual_Ptr (0)'Address, but we have to 2710 -- be careful to suppress checks to compute this address. 2711 2712 declare 2713 pragma Suppress (All_Checks); 2714 2715 pragma Warnings (Off); 2716 -- This use of unchecked conversion is aliasing safe 2717 2718 function To_Source_Buffer_Ptr is new 2719 Unchecked_Conversion (Address, Source_Buffer_Ptr); 2720 2721 pragma Warnings (On); 2722 2723 begin 2724 Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); 2725 end; 2726 end; 2727 2728 -- Read is complete, get time stamp and close file and we are done 2729 2730 Close (Source_File_FD, Status); 2731 2732 -- The status should never be False. But, if it is, what can we do? 2733 -- So, we don't test it. 2734 2735 end Read_Source_File; 2736 2737 ------------------- 2738 -- Relocate_Path -- 2739 ------------------- 2740 2741 function Relocate_Path 2742 (Prefix : String; 2743 Path : String) return String_Ptr 2744 is 2745 S : String_Ptr; 2746 2747 procedure set_std_prefix (S : String; Len : Integer); 2748 pragma Import (C, set_std_prefix); 2749 2750 begin 2751 if Std_Prefix = null then 2752 Std_Prefix := Executable_Prefix; 2753 2754 if Std_Prefix.all /= "" then 2755 2756 -- Remove trailing directory separator when calling set_std_prefix 2757 2758 set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1); 2759 end if; 2760 end if; 2761 2762 if Path (Prefix'Range) = Prefix then 2763 if Std_Prefix.all /= "" then 2764 S := new String 2765 (1 .. Std_Prefix'Length + Path'Last - Prefix'Last); 2766 S (1 .. Std_Prefix'Length) := Std_Prefix.all; 2767 S (Std_Prefix'Length + 1 .. S'Last) := 2768 Path (Prefix'Last + 1 .. Path'Last); 2769 return S; 2770 end if; 2771 end if; 2772 2773 return new String'(Path); 2774 end Relocate_Path; 2775 2776 ----------------- 2777 -- Set_Program -- 2778 ----------------- 2779 2780 procedure Set_Program (P : Program_Type) is 2781 begin 2782 if Program_Set then 2783 Fail ("Set_Program called twice"); 2784 end if; 2785 2786 Program_Set := True; 2787 Running_Program := P; 2788 end Set_Program; 2789 2790 ---------------- 2791 -- Shared_Lib -- 2792 ---------------- 2793 2794 function Shared_Lib (Name : String) return String is 2795 Library : String (1 .. Name'Length + Library_Version'Length + 3); 2796 -- 3 = 2 for "-l" + 1 for "-" before lib version 2797 2798 begin 2799 Library (1 .. 2) := "-l"; 2800 Library (3 .. 2 + Name'Length) := Name; 2801 Library (3 + Name'Length) := '-'; 2802 Library (4 + Name'Length .. Library'Last) := Library_Version; 2803 2804 if OpenVMS_On_Target then 2805 for K in Library'First + 2 .. Library'Last loop 2806 if Library (K) = '.' or else Library (K) = '-' then 2807 Library (K) := '_'; 2808 end if; 2809 end loop; 2810 end if; 2811 2812 return Library; 2813 end Shared_Lib; 2814 2815 ---------------------- 2816 -- Smart_File_Stamp -- 2817 ---------------------- 2818 2819 function Smart_File_Stamp 2820 (N : File_Name_Type; 2821 T : File_Type) return Time_Stamp_Type 2822 is 2823 File : File_Name_Type; 2824 Attr : aliased File_Attributes; 2825 2826 begin 2827 if not File_Cache_Enabled then 2828 Find_File (N, T, File, Attr'Access); 2829 else 2830 Smart_Find_File (N, T, File, Attr); 2831 end if; 2832 2833 if File = No_File then 2834 return Empty_Time_Stamp; 2835 else 2836 Get_Name_String (File); 2837 Name_Buffer (Name_Len + 1) := ASCII.NUL; 2838 return 2839 OS_Time_To_GNAT_Time 2840 (File_Time_Stamp (Name_Buffer'Address, Attr'Access)); 2841 end if; 2842 end Smart_File_Stamp; 2843 2844 --------------------- 2845 -- Smart_Find_File -- 2846 --------------------- 2847 2848 function Smart_Find_File 2849 (N : File_Name_Type; 2850 T : File_Type) return File_Name_Type 2851 is 2852 File : File_Name_Type; 2853 Attr : File_Attributes; 2854 begin 2855 Smart_Find_File (N, T, File, Attr); 2856 return File; 2857 end Smart_Find_File; 2858 2859 --------------------- 2860 -- Smart_Find_File -- 2861 --------------------- 2862 2863 procedure Smart_Find_File 2864 (N : File_Name_Type; 2865 T : File_Type; 2866 Found : out File_Name_Type; 2867 Attr : out File_Attributes) 2868 is 2869 Info : File_Info_Cache; 2870 2871 begin 2872 if not File_Cache_Enabled then 2873 Find_File (N, T, Info.File, Info.Attr'Access); 2874 2875 else 2876 Info := File_Name_Hash_Table.Get (N); 2877 2878 if Info.File = No_File then 2879 Find_File (N, T, Info.File, Info.Attr'Access); 2880 File_Name_Hash_Table.Set (N, Info); 2881 end if; 2882 end if; 2883 2884 Found := Info.File; 2885 Attr := Info.Attr; 2886 end Smart_Find_File; 2887 2888 ---------------------- 2889 -- Source_File_Data -- 2890 ---------------------- 2891 2892 procedure Source_File_Data (Cache : Boolean) is 2893 begin 2894 File_Cache_Enabled := Cache; 2895 end Source_File_Data; 2896 2897 ----------------------- 2898 -- Source_File_Stamp -- 2899 ----------------------- 2900 2901 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is 2902 begin 2903 return Smart_File_Stamp (N, Source); 2904 end Source_File_Stamp; 2905 2906 --------------------- 2907 -- Strip_Directory -- 2908 --------------------- 2909 2910 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is 2911 begin 2912 Get_Name_String (Name); 2913 2914 for J in reverse 1 .. Name_Len - 1 loop 2915 2916 -- If we find the last directory separator 2917 2918 if Is_Directory_Separator (Name_Buffer (J)) then 2919 2920 -- Return part of Name that follows this last directory separator 2921 2922 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len); 2923 Name_Len := Name_Len - J; 2924 return Name_Find; 2925 end if; 2926 end loop; 2927 2928 -- There were no directory separator, just return Name 2929 2930 return Name; 2931 end Strip_Directory; 2932 2933 ------------------ 2934 -- Strip_Suffix -- 2935 ------------------ 2936 2937 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is 2938 begin 2939 Get_Name_String (Name); 2940 2941 for J in reverse 2 .. Name_Len loop 2942 2943 -- If we found the last '.', return part of Name that precedes it 2944 2945 if Name_Buffer (J) = '.' then 2946 Name_Len := J - 1; 2947 return Name_Enter; 2948 end if; 2949 end loop; 2950 2951 return Name; 2952 end Strip_Suffix; 2953 2954 --------------------------- 2955 -- To_Canonical_Dir_Spec -- 2956 --------------------------- 2957 2958 function To_Canonical_Dir_Spec 2959 (Host_Dir : String; 2960 Prefix_Style : Boolean) return String_Access 2961 is 2962 function To_Canonical_Dir_Spec 2963 (Host_Dir : Address; 2964 Prefix_Flag : Integer) return Address; 2965 pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec"); 2966 2967 C_Host_Dir : String (1 .. Host_Dir'Length + 1); 2968 Canonical_Dir_Addr : Address; 2969 Canonical_Dir_Len : Integer; 2970 2971 begin 2972 C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir; 2973 C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL; 2974 2975 if Prefix_Style then 2976 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1); 2977 else 2978 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0); 2979 end if; 2980 2981 Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr); 2982 2983 if Canonical_Dir_Len = 0 then 2984 return null; 2985 else 2986 return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len); 2987 end if; 2988 2989 exception 2990 when others => 2991 Fail ("erroneous directory spec: " & Host_Dir); 2992 return null; 2993 end To_Canonical_Dir_Spec; 2994 2995 --------------------------- 2996 -- To_Canonical_File_List -- 2997 --------------------------- 2998 2999 function To_Canonical_File_List 3000 (Wildcard_Host_File : String; 3001 Only_Dirs : Boolean) return String_Access_List_Access 3002 is 3003 function To_Canonical_File_List_Init 3004 (Host_File : Address; 3005 Only_Dirs : Integer) return Integer; 3006 pragma Import (C, To_Canonical_File_List_Init, 3007 "__gnat_to_canonical_file_list_init"); 3008 3009 function To_Canonical_File_List_Next return Address; 3010 pragma Import (C, To_Canonical_File_List_Next, 3011 "__gnat_to_canonical_file_list_next"); 3012 3013 procedure To_Canonical_File_List_Free; 3014 pragma Import (C, To_Canonical_File_List_Free, 3015 "__gnat_to_canonical_file_list_free"); 3016 3017 Num_Files : Integer; 3018 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1); 3019 3020 begin 3021 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) := 3022 Wildcard_Host_File; 3023 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL; 3024 3025 -- Do the expansion and say how many there are 3026 3027 Num_Files := To_Canonical_File_List_Init 3028 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs)); 3029 3030 declare 3031 Canonical_File_List : String_Access_List (1 .. Num_Files); 3032 Canonical_File_Addr : Address; 3033 Canonical_File_Len : Integer; 3034 3035 begin 3036 -- Retrieve the expanded directory names and build the list 3037 3038 for J in 1 .. Num_Files loop 3039 Canonical_File_Addr := To_Canonical_File_List_Next; 3040 Canonical_File_Len := C_String_Length (Canonical_File_Addr); 3041 Canonical_File_List (J) := To_Path_String_Access 3042 (Canonical_File_Addr, Canonical_File_Len); 3043 end loop; 3044 3045 -- Free up the storage 3046 3047 To_Canonical_File_List_Free; 3048 3049 return new String_Access_List'(Canonical_File_List); 3050 end; 3051 end To_Canonical_File_List; 3052 3053 ---------------------------- 3054 -- To_Canonical_File_Spec -- 3055 ---------------------------- 3056 3057 function To_Canonical_File_Spec 3058 (Host_File : String) return String_Access 3059 is 3060 function To_Canonical_File_Spec (Host_File : Address) return Address; 3061 pragma Import 3062 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); 3063 3064 C_Host_File : String (1 .. Host_File'Length + 1); 3065 Canonical_File_Addr : Address; 3066 Canonical_File_Len : Integer; 3067 3068 begin 3069 C_Host_File (1 .. Host_File'Length) := Host_File; 3070 C_Host_File (C_Host_File'Last) := ASCII.NUL; 3071 3072 Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address); 3073 Canonical_File_Len := C_String_Length (Canonical_File_Addr); 3074 3075 if Canonical_File_Len = 0 then 3076 return null; 3077 else 3078 return To_Path_String_Access 3079 (Canonical_File_Addr, Canonical_File_Len); 3080 end if; 3081 3082 exception 3083 when others => 3084 Fail ("erroneous file spec: " & Host_File); 3085 return null; 3086 end To_Canonical_File_Spec; 3087 3088 ---------------------------- 3089 -- To_Canonical_Path_Spec -- 3090 ---------------------------- 3091 3092 function To_Canonical_Path_Spec 3093 (Host_Path : String) return String_Access 3094 is 3095 function To_Canonical_Path_Spec (Host_Path : Address) return Address; 3096 pragma Import 3097 (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec"); 3098 3099 C_Host_Path : String (1 .. Host_Path'Length + 1); 3100 Canonical_Path_Addr : Address; 3101 Canonical_Path_Len : Integer; 3102 3103 begin 3104 C_Host_Path (1 .. Host_Path'Length) := Host_Path; 3105 C_Host_Path (C_Host_Path'Last) := ASCII.NUL; 3106 3107 Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address); 3108 Canonical_Path_Len := C_String_Length (Canonical_Path_Addr); 3109 3110 -- Return a null string (vice a null) for zero length paths, for 3111 -- compatibility with getenv(). 3112 3113 return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len); 3114 3115 exception 3116 when others => 3117 Fail ("erroneous path spec: " & Host_Path); 3118 return null; 3119 end To_Canonical_Path_Spec; 3120 3121 ---------------------- 3122 -- To_Host_Dir_Spec -- 3123 ---------------------- 3124 3125 function To_Host_Dir_Spec 3126 (Canonical_Dir : String; 3127 Prefix_Style : Boolean) return String_Access 3128 is 3129 function To_Host_Dir_Spec 3130 (Canonical_Dir : Address; 3131 Prefix_Flag : Integer) return Address; 3132 pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec"); 3133 3134 C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1); 3135 Host_Dir_Addr : Address; 3136 Host_Dir_Len : Integer; 3137 3138 begin 3139 C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir; 3140 C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL; 3141 3142 if Prefix_Style then 3143 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1); 3144 else 3145 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0); 3146 end if; 3147 Host_Dir_Len := C_String_Length (Host_Dir_Addr); 3148 3149 if Host_Dir_Len = 0 then 3150 return null; 3151 else 3152 return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len); 3153 end if; 3154 end To_Host_Dir_Spec; 3155 3156 ----------------------- 3157 -- To_Host_File_Spec -- 3158 ----------------------- 3159 3160 function To_Host_File_Spec 3161 (Canonical_File : String) return String_Access 3162 is 3163 function To_Host_File_Spec (Canonical_File : Address) return Address; 3164 pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec"); 3165 3166 C_Canonical_File : String (1 .. Canonical_File'Length + 1); 3167 Host_File_Addr : Address; 3168 Host_File_Len : Integer; 3169 3170 begin 3171 C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File; 3172 C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL; 3173 3174 Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address); 3175 Host_File_Len := C_String_Length (Host_File_Addr); 3176 3177 if Host_File_Len = 0 then 3178 return null; 3179 else 3180 return To_Path_String_Access 3181 (Host_File_Addr, Host_File_Len); 3182 end if; 3183 end To_Host_File_Spec; 3184 3185 --------------------------- 3186 -- To_Path_String_Access -- 3187 --------------------------- 3188 3189 function To_Path_String_Access 3190 (Path_Addr : Address; 3191 Path_Len : Integer) return String_Access 3192 is 3193 subtype Path_String is String (1 .. Path_Len); 3194 type Path_String_Access is access Path_String; 3195 3196 function Address_To_Access is new 3197 Unchecked_Conversion (Source => Address, 3198 Target => Path_String_Access); 3199 3200 Path_Access : constant Path_String_Access := 3201 Address_To_Access (Path_Addr); 3202 3203 Return_Val : String_Access; 3204 3205 begin 3206 Return_Val := new String (1 .. Path_Len); 3207 3208 for J in 1 .. Path_Len loop 3209 Return_Val (J) := Path_Access (J); 3210 end loop; 3211 3212 return Return_Val; 3213 end To_Path_String_Access; 3214 3215 ----------------- 3216 -- Update_Path -- 3217 ----------------- 3218 3219 function Update_Path (Path : String_Ptr) return String_Ptr is 3220 3221 function C_Update_Path (Path, Component : Address) return Address; 3222 pragma Import (C, C_Update_Path, "update_path"); 3223 3224 function Strlen (Str : Address) return Integer; 3225 pragma Import (C, Strlen, "strlen"); 3226 3227 procedure Strncpy (X : Address; Y : Address; Length : Integer); 3228 pragma Import (C, Strncpy, "strncpy"); 3229 3230 In_Length : constant Integer := Path'Length; 3231 In_String : String (1 .. In_Length + 1); 3232 Component_Name : aliased String := "GCC" & ASCII.NUL; 3233 Result_Ptr : Address; 3234 Result_Length : Integer; 3235 Out_String : String_Ptr; 3236 3237 begin 3238 In_String (1 .. In_Length) := Path.all; 3239 In_String (In_Length + 1) := ASCII.NUL; 3240 Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address); 3241 Result_Length := Strlen (Result_Ptr); 3242 3243 Out_String := new String (1 .. Result_Length); 3244 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length); 3245 return Out_String; 3246 end Update_Path; 3247 3248 ---------------- 3249 -- Write_Info -- 3250 ---------------- 3251 3252 procedure Write_Info (Info : String) is 3253 begin 3254 Write_With_Check (Info'Address, Info'Length); 3255 Write_With_Check (EOL'Address, 1); 3256 end Write_Info; 3257 3258 ------------------------ 3259 -- Write_Program_Name -- 3260 ------------------------ 3261 3262 procedure Write_Program_Name is 3263 Save_Buffer : constant String (1 .. Name_Len) := 3264 Name_Buffer (1 .. Name_Len); 3265 3266 begin 3267 Find_Program_Name; 3268 3269 -- Convert the name to lower case so error messages are the same on 3270 -- all systems. 3271 3272 for J in 1 .. Name_Len loop 3273 if Name_Buffer (J) in 'A' .. 'Z' then 3274 Name_Buffer (J) := 3275 Character'Val (Character'Pos (Name_Buffer (J)) + 32); 3276 end if; 3277 end loop; 3278 3279 Write_Str (Name_Buffer (1 .. Name_Len)); 3280 3281 -- Restore Name_Buffer which was clobbered by the call to 3282 -- Find_Program_Name 3283 3284 Name_Len := Save_Buffer'Last; 3285 Name_Buffer (1 .. Name_Len) := Save_Buffer; 3286 end Write_Program_Name; 3287 3288 ---------------------- 3289 -- Write_With_Check -- 3290 ---------------------- 3291 3292 procedure Write_With_Check (A : Address; N : Integer) is 3293 Ignore : Boolean; 3294 pragma Warnings (Off, Ignore); 3295 3296 begin 3297 if N = Write (Output_FD, A, N) then 3298 return; 3299 3300 else 3301 Write_Str ("error: disk full writing "); 3302 Write_Name_Decoded (Output_File_Name); 3303 Write_Eol; 3304 Name_Len := Name_Len + 1; 3305 Name_Buffer (Name_Len) := ASCII.NUL; 3306 Delete_File (Name_Buffer'Address, Ignore); 3307 Exit_Program (E_Fatal); 3308 end if; 3309 end Write_With_Check; 3310 3311---------------------------- 3312-- Package Initialization -- 3313---------------------------- 3314 3315 procedure Reset_File_Attributes (Attr : System.Address); 3316 pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes"); 3317 3318begin 3319 Initialization : declare 3320 3321 function Get_Default_Identifier_Character_Set return Character; 3322 pragma Import (C, Get_Default_Identifier_Character_Set, 3323 "__gnat_get_default_identifier_character_set"); 3324 -- Function to determine the default identifier character set, 3325 -- which is system dependent. See Opt package spec for a list of 3326 -- the possible character codes and their interpretations. 3327 3328 function Get_Maximum_File_Name_Length return Int; 3329 pragma Import (C, Get_Maximum_File_Name_Length, 3330 "__gnat_get_maximum_file_name_length"); 3331 -- Function to get maximum file name length for system 3332 3333 Sizeof_File_Attributes : Integer; 3334 pragma Import (C, Sizeof_File_Attributes, 3335 "__gnat_size_of_file_attributes"); 3336 3337 begin 3338 pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size); 3339 3340 Reset_File_Attributes (Unknown_Attributes'Address); 3341 3342 Identifier_Character_Set := Get_Default_Identifier_Character_Set; 3343 Maximum_File_Name_Length := Get_Maximum_File_Name_Length; 3344 3345 -- Following should be removed by having above function return 3346 -- Integer'Last as indication of no maximum instead of -1 ??? 3347 3348 if Maximum_File_Name_Length = -1 then 3349 Maximum_File_Name_Length := Int'Last; 3350 end if; 3351 3352 Src_Search_Directories.Set_Last (Primary_Directory); 3353 Src_Search_Directories.Table (Primary_Directory) := new String'(""); 3354 3355 Lib_Search_Directories.Set_Last (Primary_Directory); 3356 Lib_Search_Directories.Table (Primary_Directory) := new String'(""); 3357 3358 Osint.Initialize; 3359 end Initialization; 3360 3361end Osint; 3362