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