1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T L S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, 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 26pragma Ada_2012; 27 28with ALI; use ALI; 29with ALI.Util; use ALI.Util; 30with Binderr; use Binderr; 31with Butil; use Butil; 32with Csets; 33with Fname; use Fname; 34with Gnatvsn; use Gnatvsn; 35with Make_Util; use Make_Util; 36with Namet; use Namet; 37with Opt; use Opt; 38with Osint; use Osint; 39with Osint.L; use Osint.L; 40with Output; use Output; 41with Rident; use Rident; 42with Sdefault; 43with Snames; 44with Stringt; 45with Switch; use Switch; 46with Types; use Types; 47 48with GNAT.Case_Util; use GNAT.Case_Util; 49with GNAT.Command_Line; use GNAT.Command_Line; 50with GNAT.Directory_Operations; use GNAT.Directory_Operations; 51with GNAT.OS_Lib; use GNAT.OS_Lib; 52 53procedure Gnatls is 54 pragma Ident (Gnat_Static_Version_String); 55 56 -- NOTE : The following string may be used by other tools, such as 57 -- GNAT Studio. So it can only be modified if these other uses are checked 58 -- and coordinated. 59 60 Project_Search_Path : constant String := "Project Search Path:"; 61 -- Label displayed in verbose mode before the directories in the project 62 -- search path. Do not modify without checking NOTE above. 63 64 Prj_Path : String_Access; 65 66 Max_Column : constant := 80; 67 68 No_Obj : aliased String := "<no_obj>"; 69 70 No_Runtime : Boolean := False; 71 -- Set to True if there is no default runtime and --RTS= is not specified 72 73 type File_Status is ( 74 OK, -- matching timestamp 75 Checksum_OK, -- only matching checksum 76 Not_Found, -- file not found on source PATH 77 Not_Same, -- neither checksum nor timestamp matching 78 Not_First_On_PATH); -- matching file hidden by Not_Same file on path 79 80 type Dir_Data; 81 type Dir_Ref is access Dir_Data; 82 83 type Dir_Data is record 84 Value : String_Access; 85 Next : Dir_Ref; 86 end record; 87 -- Simply linked list of dirs 88 89 First_Source_Dir : Dir_Ref; 90 Last_Source_Dir : Dir_Ref; 91 -- The list of source directories from the command line. 92 -- These directories are added using Osint.Add_Src_Search_Dir 93 -- after those of the GNAT Project File, if any. 94 95 First_Lib_Dir : Dir_Ref; 96 Last_Lib_Dir : Dir_Ref; 97 -- The list of object directories from the command line. 98 -- These directories are added using Osint.Add_Lib_Search_Dir 99 -- after those of the GNAT Project File, if any. 100 101 Main_File : File_Name_Type; 102 Ali_File : File_Name_Type; 103 Text : Text_Buffer_Ptr; 104 Next_Arg : Positive; 105 106 Too_Long : Boolean := False; 107 -- When True, lines are too long for multi-column output and each 108 -- item of information is on a different line. 109 110 Selective_Output : Boolean := False; 111 Print_Usage : Boolean := False; 112 Print_Unit : Boolean := True; 113 Print_Source : Boolean := True; 114 Print_Object : Boolean := True; 115 -- Flags controlling the form of the output 116 117 Also_Predef : Boolean := False; -- -a 118 Dependable : Boolean := False; -- -d 119 License : Boolean := False; -- -l 120 Very_Verbose_Mode : Boolean := False; -- -V 121 -- Command line flags 122 123 Unit_Start : Integer; 124 Unit_End : Integer; 125 Source_Start : Integer; 126 Source_End : Integer; 127 Object_Start : Integer; 128 Object_End : Integer; 129 -- Various column starts and ends 130 131 Spaces : constant String (1 .. Max_Column) := (others => ' '); 132 133 RTS_Specified : String_Access := null; 134 -- Used to detect multiple use of --RTS= switch 135 136 Exit_Status : Exit_Code_Type := E_Success; 137 -- Reset to E_Fatal if bad error found 138 139 ----------------------- 140 -- Local Subprograms -- 141 ----------------------- 142 143 procedure Add_Lib_Dir (Dir : String); 144 -- Add an object directory in the list First_Lib_Dir-Last_Lib_Dir 145 146 procedure Add_Source_Dir (Dir : String); 147 -- Add a source directory in the list First_Source_Dir-Last_Source_Dir 148 149 procedure Find_General_Layout; 150 -- Determine the structure of the output (multi columns or not, etc) 151 152 procedure Find_Status 153 (FS : in out File_Name_Type; 154 Stamp : Time_Stamp_Type; 155 Checksum : Word; 156 Status : out File_Status); 157 -- Determine the file status (Status) of the file represented by FS with 158 -- the expected Stamp and checksum given as argument. FS will be updated 159 -- to the full file name if available. 160 161 function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id; 162 -- Give the Sdep entry corresponding to the unit U in ali record A 163 164 procedure Output_Object (O : File_Name_Type); 165 -- Print out the name of the object when requested 166 167 procedure Output_Source (Sdep_I : Sdep_Id); 168 -- Print out the name and status of the source corresponding to this 169 -- sdep entry. 170 171 procedure Output_Status (FS : File_Status; Verbose : Boolean); 172 -- Print out FS either in a coded form if verbose is false or in an 173 -- expanded form otherwise. 174 175 procedure Output_Unit (ALI : ALI_Id; U_Id : Unit_Id); 176 -- Print out information on the unit when requested 177 178 procedure Reset_Print; 179 -- Reset Print flags properly when selective output is chosen 180 181 procedure Scan_Ls_Arg (Argv : String); 182 -- Scan and process user specific arguments (Argv is a single argument) 183 184 procedure Search_RTS (Name : String); 185 -- Find include and objects path for the RTS name. 186 187 procedure Usage; 188 -- Print usage message 189 190 procedure Output_License_Information; 191 pragma No_Return (Output_License_Information); 192 -- Output license statement, and if not found, output reference to COPYING 193 194 function Image (Restriction : Restriction_Id) return String; 195 -- Returns the capitalized image of Restriction 196 197 function Normalize (Path : String) return String; 198 -- Returns a normalized path name. On Windows, the directory separators are 199 -- set to '\' in Normalize_Pathname. 200 201 ------------------------------------------ 202 -- GNATDIST specific output subprograms -- 203 ------------------------------------------ 204 205 package GNATDIST is 206 207 -- Any modification to this subunit requires synchronization with the 208 -- GNATDIST sources. 209 210 procedure Output_ALI (A : ALI_Id); 211 -- Comment required saying what this routine does ??? 212 213 procedure Output_No_ALI (Afile : File_Name_Type); 214 -- Comments required saying what this routine does ??? 215 216 end GNATDIST; 217 218 ------------------------------ 219 -- Support for project path -- 220 ------------------------------ 221 222 package Prj_Env is 223 224 procedure Initialize_Default_Project_Path 225 (Self : in out String_Access; 226 Target_Name : String; 227 Runtime_Name : String := ""); 228 -- Initialize Self. It will then contain the default project path on 229 -- the given target and runtime (including directories specified by the 230 -- environment variables GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH and 231 -- ADA_PROJECT_PATH). If one of the directory or Target_Name is "-", 232 -- then the path contains only those directories specified by the 233 -- environment variables (except "-"). This does nothing if Self has 234 -- already been initialized. 235 236 procedure Add_Directories 237 (Self : in out String_Access; 238 Path : String; 239 Prepend : Boolean := False); 240 -- Add one or more directories to the path. Directories added with this 241 -- procedure are added in order after the current directory and before 242 -- the path given by the environment variable GPR_PROJECT_PATH. A value 243 -- of "-" will remove the default project directory from the project 244 -- path. 245 -- 246 -- Calls to this subprogram must be performed before the first call to 247 -- Find_Project below, or PATH will be added at the end of the search 248 -- path. 249 250 function Get_Runtime_Path 251 (Self : String_Access; 252 Path : String) return String_Access; 253 -- Compute the full path for the project-based runtime name. 254 -- Path is simply searched on the project path. 255 256 end Prj_Env; 257 258 ----------------- 259 -- Add_Lib_Dir -- 260 ----------------- 261 262 procedure Add_Lib_Dir (Dir : String) is 263 begin 264 if First_Lib_Dir = null then 265 First_Lib_Dir := 266 new Dir_Data' 267 (Value => new String'(Dir), 268 Next => null); 269 Last_Lib_Dir := First_Lib_Dir; 270 271 else 272 Last_Lib_Dir.Next := 273 new Dir_Data' 274 (Value => new String'(Dir), 275 Next => null); 276 Last_Lib_Dir := Last_Lib_Dir.Next; 277 end if; 278 end Add_Lib_Dir; 279 280 -------------------- 281 -- Add_Source_Dir -- 282 -------------------- 283 284 procedure Add_Source_Dir (Dir : String) is 285 begin 286 if First_Source_Dir = null then 287 First_Source_Dir := 288 new Dir_Data' 289 (Value => new String'(Dir), 290 Next => null); 291 Last_Source_Dir := First_Source_Dir; 292 293 else 294 Last_Source_Dir.Next := 295 new Dir_Data' 296 (Value => new String'(Dir), 297 Next => null); 298 Last_Source_Dir := Last_Source_Dir.Next; 299 end if; 300 end Add_Source_Dir; 301 302 ------------------------------ 303 -- Corresponding_Sdep_Entry -- 304 ------------------------------ 305 306 function Corresponding_Sdep_Entry 307 (A : ALI_Id; 308 U : Unit_Id) return Sdep_Id 309 is 310 begin 311 for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop 312 if Sdep.Table (D).Sfile = Units.Table (U).Sfile then 313 return D; 314 end if; 315 end loop; 316 317 Error_Msg_Unit_1 := Units.Table (U).Uname; 318 Error_Msg_File_1 := ALIs.Table (A).Afile; 319 Write_Eol; 320 Error_Msg ("wrong ALI format, can't find dependency line for $ in {"); 321 Exit_Program (E_Fatal); 322 return No_Sdep_Id; 323 end Corresponding_Sdep_Entry; 324 325 ------------------------- 326 -- Find_General_Layout -- 327 ------------------------- 328 329 procedure Find_General_Layout is 330 Max_Unit_Length : Integer := 11; 331 Max_Src_Length : Integer := 11; 332 Max_Obj_Length : Integer := 11; 333 334 Len : Integer; 335 FS : File_Name_Type; 336 337 begin 338 -- Compute maximum of each column 339 340 for Id in ALIs.First .. ALIs.Last loop 341 Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname); 342 if Also_Predef or else not Is_Internal_Unit then 343 344 if Print_Unit then 345 Len := Name_Len - 1; 346 Max_Unit_Length := Integer'Max (Max_Unit_Length, Len); 347 end if; 348 349 if Print_Source then 350 FS := Full_Source_Name (ALIs.Table (Id).Sfile); 351 352 if FS = No_File then 353 Get_Name_String (ALIs.Table (Id).Sfile); 354 Name_Len := Name_Len + 13; 355 else 356 Get_Name_String (FS); 357 end if; 358 359 Max_Src_Length := Integer'Max (Max_Src_Length, Name_Len + 1); 360 end if; 361 362 if Print_Object then 363 if ALIs.Table (Id).No_Object then 364 Max_Obj_Length := 365 Integer'Max (Max_Obj_Length, No_Obj'Length); 366 else 367 Get_Name_String (ALIs.Table (Id).Ofile_Full_Name); 368 Max_Obj_Length := Integer'Max (Max_Obj_Length, Name_Len + 1); 369 end if; 370 end if; 371 end if; 372 end loop; 373 374 -- Verify is output is not wider than maximum number of columns 375 376 Too_Long := 377 Verbose_Mode 378 or else 379 (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column; 380 381 -- Set start and end of columns 382 383 Object_Start := 1; 384 Object_End := Object_Start - 1; 385 386 if Print_Object then 387 Object_End := Object_Start + Max_Obj_Length; 388 end if; 389 390 Unit_Start := Object_End + 1; 391 Unit_End := Unit_Start - 1; 392 393 if Print_Unit then 394 Unit_End := Unit_Start + Max_Unit_Length; 395 end if; 396 397 Source_Start := Unit_End + 1; 398 399 if Source_Start > Spaces'Last then 400 Source_Start := Spaces'Last; 401 end if; 402 403 Source_End := Source_Start - 1; 404 405 if Print_Source then 406 Source_End := Source_Start + Max_Src_Length; 407 end if; 408 end Find_General_Layout; 409 410 ----------------- 411 -- Find_Status -- 412 ----------------- 413 414 procedure Find_Status 415 (FS : in out File_Name_Type; 416 Stamp : Time_Stamp_Type; 417 Checksum : Word; 418 Status : out File_Status) 419 is 420 Tmp1 : File_Name_Type; 421 Tmp2 : File_Name_Type; 422 423 begin 424 Tmp1 := Full_Source_Name (FS); 425 426 if Tmp1 = No_File then 427 Status := Not_Found; 428 429 elsif File_Stamp (Tmp1) = Stamp then 430 FS := Tmp1; 431 Status := OK; 432 433 elsif Checksums_Match (Get_File_Checksum (FS), Checksum) then 434 FS := Tmp1; 435 Status := Checksum_OK; 436 437 else 438 Tmp2 := Matching_Full_Source_Name (FS, Stamp); 439 440 if Tmp2 = No_File then 441 Status := Not_Same; 442 FS := Tmp1; 443 444 else 445 Status := Not_First_On_PATH; 446 FS := Tmp2; 447 end if; 448 end if; 449 end Find_Status; 450 451 -------------- 452 -- GNATDIST -- 453 -------------- 454 455 package body GNATDIST is 456 457 N_Flags : Natural; 458 N_Indents : Natural := 0; 459 460 type Token_Type is 461 (T_No_ALI, 462 T_ALI, 463 T_Unit, 464 T_With, 465 T_Source, 466 T_Afile, 467 T_Ofile, 468 T_Sfile, 469 T_Name, 470 T_Main, 471 T_Kind, 472 T_Flags, 473 T_Preelaborated, 474 T_Pure, 475 T_Has_RACW, 476 T_Remote_Types, 477 T_Shared_Passive, 478 T_RCI, 479 T_Predefined, 480 T_Internal, 481 T_Is_Generic, 482 T_Procedure, 483 T_Function, 484 T_Package, 485 T_Subprogram, 486 T_Spec, 487 T_Body); 488 489 Image : constant array (Token_Type) of String_Access := 490 (T_No_ALI => new String'("No_ALI"), 491 T_ALI => new String'("ALI"), 492 T_Unit => new String'("Unit"), 493 T_With => new String'("With"), 494 T_Source => new String'("Source"), 495 T_Afile => new String'("Afile"), 496 T_Ofile => new String'("Ofile"), 497 T_Sfile => new String'("Sfile"), 498 T_Name => new String'("Name"), 499 T_Main => new String'("Main"), 500 T_Kind => new String'("Kind"), 501 T_Flags => new String'("Flags"), 502 T_Preelaborated => new String'("Preelaborated"), 503 T_Pure => new String'("Pure"), 504 T_Has_RACW => new String'("Has_RACW"), 505 T_Remote_Types => new String'("Remote_Types"), 506 T_Shared_Passive => new String'("Shared_Passive"), 507 T_RCI => new String'("RCI"), 508 T_Predefined => new String'("Predefined"), 509 T_Internal => new String'("Internal"), 510 T_Is_Generic => new String'("Is_Generic"), 511 T_Procedure => new String'("procedure"), 512 T_Function => new String'("function"), 513 T_Package => new String'("package"), 514 T_Subprogram => new String'("subprogram"), 515 T_Spec => new String'("spec"), 516 T_Body => new String'("body")); 517 518 procedure Output_Name (N : Name_Id); 519 -- Remove any encoding info (%b and %s) and output N 520 521 procedure Output_Afile (A : File_Name_Type); 522 procedure Output_Ofile (O : File_Name_Type); 523 procedure Output_Sfile (S : File_Name_Type); 524 -- Output various names. Check that the name is different from no name. 525 -- Otherwise, skip the output. 526 527 procedure Output_Token (T : Token_Type); 528 -- Output token using specific format. That is several indentations and: 529 -- 530 -- T_No_ALI .. T_With : <token> & " =>" & NL 531 -- T_Source .. T_Kind : <token> & " => " 532 -- T_Flags : <token> & " =>" 533 -- T_Preelab .. T_Body : " " & <token> 534 535 procedure Output_Sdep (S : Sdep_Id); 536 procedure Output_Unit (U : Unit_Id); 537 procedure Output_With (W : With_Id); 538 -- Output this entry as a global section (like ALIs) 539 540 ------------------ 541 -- Output_Afile -- 542 ------------------ 543 544 procedure Output_Afile (A : File_Name_Type) is 545 begin 546 if A /= No_File then 547 Output_Token (T_Afile); 548 Write_Name (A); 549 Write_Eol; 550 end if; 551 end Output_Afile; 552 553 ---------------- 554 -- Output_ALI -- 555 ---------------- 556 557 procedure Output_ALI (A : ALI_Id) is 558 begin 559 Output_Token (T_ALI); 560 N_Indents := N_Indents + 1; 561 562 Output_Afile (ALIs.Table (A).Afile); 563 Output_Ofile (ALIs.Table (A).Ofile_Full_Name); 564 Output_Sfile (ALIs.Table (A).Sfile); 565 566 -- Output Main 567 568 if ALIs.Table (A).Main_Program /= None then 569 Output_Token (T_Main); 570 571 if ALIs.Table (A).Main_Program = Proc then 572 Output_Token (T_Procedure); 573 else 574 Output_Token (T_Function); 575 end if; 576 577 Write_Eol; 578 end if; 579 580 -- Output Units 581 582 for U in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop 583 Output_Unit (U); 584 end loop; 585 586 -- Output Sdeps 587 588 for S in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop 589 Output_Sdep (S); 590 end loop; 591 592 N_Indents := N_Indents - 1; 593 end Output_ALI; 594 595 ------------------- 596 -- Output_No_ALI -- 597 ------------------- 598 599 procedure Output_No_ALI (Afile : File_Name_Type) is 600 begin 601 Output_Token (T_No_ALI); 602 N_Indents := N_Indents + 1; 603 Output_Afile (Afile); 604 N_Indents := N_Indents - 1; 605 end Output_No_ALI; 606 607 ----------------- 608 -- Output_Name -- 609 ----------------- 610 611 procedure Output_Name (N : Name_Id) is 612 begin 613 -- Remove any encoding info (%s or %b) 614 615 Get_Name_String (N); 616 617 if Name_Len > 2 618 and then Name_Buffer (Name_Len - 1) = '%' 619 then 620 Name_Len := Name_Len - 2; 621 end if; 622 623 Output_Token (T_Name); 624 Write_Str (Name_Buffer (1 .. Name_Len)); 625 Write_Eol; 626 end Output_Name; 627 628 ------------------ 629 -- Output_Ofile -- 630 ------------------ 631 632 procedure Output_Ofile (O : File_Name_Type) is 633 begin 634 if O /= No_File then 635 Output_Token (T_Ofile); 636 Write_Name (O); 637 Write_Eol; 638 end if; 639 end Output_Ofile; 640 641 ----------------- 642 -- Output_Sdep -- 643 ----------------- 644 645 procedure Output_Sdep (S : Sdep_Id) is 646 begin 647 Output_Token (T_Source); 648 Write_Name (Sdep.Table (S).Sfile); 649 Write_Eol; 650 end Output_Sdep; 651 652 ------------------ 653 -- Output_Sfile -- 654 ------------------ 655 656 procedure Output_Sfile (S : File_Name_Type) is 657 FS : File_Name_Type := S; 658 659 begin 660 if FS /= No_File then 661 662 -- We want to output the full source name 663 664 FS := Full_Source_Name (FS); 665 666 -- There is no full source name. This occurs for instance when a 667 -- withed unit has a spec file but no body file. This situation is 668 -- not a problem for GNATDIST since the unit may be located on a 669 -- partition we do not want to build. However, we need to locate 670 -- the spec file and to find its full source name. Replace the 671 -- body file name with the spec file name used to compile the 672 -- current unit when possible. 673 674 if FS = No_File then 675 Get_Name_String (S); 676 677 if Name_Len > 4 678 and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" 679 then 680 Name_Buffer (Name_Len) := 's'; 681 FS := Full_Source_Name (Name_Find); 682 end if; 683 end if; 684 end if; 685 686 if FS /= No_File then 687 Output_Token (T_Sfile); 688 Write_Name (FS); 689 Write_Eol; 690 end if; 691 end Output_Sfile; 692 693 ------------------ 694 -- Output_Token -- 695 ------------------ 696 697 procedure Output_Token (T : Token_Type) is 698 begin 699 case T is 700 when T_No_ALI .. T_Flags => 701 for J in 1 .. N_Indents loop 702 Write_Str (" "); 703 end loop; 704 705 Write_Str (Image (T).all); 706 707 for J in Image (T)'Length .. 12 loop 708 Write_Char (' '); 709 end loop; 710 711 Write_Str ("=>"); 712 713 if T in T_No_ALI .. T_With then 714 Write_Eol; 715 elsif T in T_Source .. T_Name then 716 Write_Char (' '); 717 end if; 718 719 when T_Preelaborated .. T_Body => 720 if T in T_Preelaborated .. T_Is_Generic then 721 if N_Flags = 0 then 722 Output_Token (T_Flags); 723 end if; 724 725 N_Flags := N_Flags + 1; 726 end if; 727 728 Write_Char (' '); 729 Write_Str (Image (T).all); 730 end case; 731 end Output_Token; 732 733 ----------------- 734 -- Output_Unit -- 735 ----------------- 736 737 procedure Output_Unit (U : Unit_Id) is 738 begin 739 Output_Token (T_Unit); 740 N_Indents := N_Indents + 1; 741 742 -- Output Name 743 744 Output_Name (Name_Id (Units.Table (U).Uname)); 745 746 -- Output Kind 747 748 Output_Token (T_Kind); 749 750 if Units.Table (U).Unit_Kind = 'p' then 751 Output_Token (T_Package); 752 else 753 Output_Token (T_Subprogram); 754 end if; 755 756 if Name_Buffer (Name_Len) = 's' then 757 Output_Token (T_Spec); 758 else 759 Output_Token (T_Body); 760 end if; 761 762 Write_Eol; 763 764 -- Output source file name 765 766 Output_Sfile (Units.Table (U).Sfile); 767 768 -- Output Flags 769 770 N_Flags := 0; 771 772 if Units.Table (U).Preelab then 773 Output_Token (T_Preelaborated); 774 end if; 775 776 if Units.Table (U).Pure then 777 Output_Token (T_Pure); 778 end if; 779 780 if Units.Table (U).Has_RACW then 781 Output_Token (T_Has_RACW); 782 end if; 783 784 if Units.Table (U).Remote_Types then 785 Output_Token (T_Remote_Types); 786 end if; 787 788 if Units.Table (U).Shared_Passive then 789 Output_Token (T_Shared_Passive); 790 end if; 791 792 if Units.Table (U).RCI then 793 Output_Token (T_RCI); 794 end if; 795 796 if Units.Table (U).Predefined then 797 Output_Token (T_Predefined); 798 end if; 799 800 if Units.Table (U).Internal then 801 Output_Token (T_Internal); 802 end if; 803 804 if Units.Table (U).Is_Generic then 805 Output_Token (T_Is_Generic); 806 end if; 807 808 if N_Flags > 0 then 809 Write_Eol; 810 end if; 811 812 -- Output Withs 813 814 for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop 815 Output_With (W); 816 end loop; 817 818 N_Indents := N_Indents - 1; 819 end Output_Unit; 820 821 ----------------- 822 -- Output_With -- 823 ----------------- 824 825 procedure Output_With (W : With_Id) is 826 begin 827 Output_Token (T_With); 828 N_Indents := N_Indents + 1; 829 830 Output_Name (Name_Id (Withs.Table (W).Uname)); 831 832 -- Output Kind 833 834 Output_Token (T_Kind); 835 836 if Name_Buffer (Name_Len) = 's' then 837 Output_Token (T_Spec); 838 else 839 Output_Token (T_Body); 840 end if; 841 842 Write_Eol; 843 844 Output_Afile (Withs.Table (W).Afile); 845 Output_Sfile (Withs.Table (W).Sfile); 846 847 N_Indents := N_Indents - 1; 848 end Output_With; 849 850 end GNATDIST; 851 852 ----------- 853 -- Image -- 854 ----------- 855 856 function Image (Restriction : Restriction_Id) return String is 857 Result : String := Restriction'Img; 858 Skip : Boolean := True; 859 860 begin 861 for J in Result'Range loop 862 if Skip then 863 Skip := False; 864 Result (J) := To_Upper (Result (J)); 865 866 elsif Result (J) = '_' then 867 Skip := True; 868 869 else 870 Result (J) := To_Lower (Result (J)); 871 end if; 872 end loop; 873 874 return Result; 875 end Image; 876 877 --------------- 878 -- Normalize -- 879 --------------- 880 881 function Normalize (Path : String) return String is 882 begin 883 return Normalize_Pathname (Path); 884 end Normalize; 885 886 -------------------------------- 887 -- Output_License_Information -- 888 -------------------------------- 889 890 procedure Output_License_Information is 891 begin 892 case Build_Type is 893 when others => 894 Write_Str ("Please refer to file COPYING in your distribution" 895 & " for license terms."); 896 Write_Eol; 897 end case; 898 899 Exit_Program (E_Success); 900 end Output_License_Information; 901 902 ------------------- 903 -- Output_Object -- 904 ------------------- 905 906 procedure Output_Object (O : File_Name_Type) is 907 Object_Name : String_Access; 908 909 begin 910 if Print_Object then 911 if O /= No_File then 912 Get_Name_String (O); 913 Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len)); 914 else 915 Object_Name := No_Obj'Unchecked_Access; 916 end if; 917 918 Write_Str (Object_Name.all); 919 920 if Print_Source or else Print_Unit then 921 if Too_Long then 922 Write_Eol; 923 Write_Str (" "); 924 else 925 Write_Str (Spaces 926 (Object_Start + Object_Name'Length .. Object_End)); 927 end if; 928 end if; 929 end if; 930 end Output_Object; 931 932 ------------------- 933 -- Output_Source -- 934 ------------------- 935 936 procedure Output_Source (Sdep_I : Sdep_Id) is 937 Stamp : Time_Stamp_Type; 938 Checksum : Word; 939 FS : File_Name_Type; 940 Status : File_Status; 941 Object_Name : String_Access; 942 943 begin 944 if Sdep_I = No_Sdep_Id then 945 return; 946 end if; 947 948 Stamp := Sdep.Table (Sdep_I).Stamp; 949 Checksum := Sdep.Table (Sdep_I).Checksum; 950 FS := Sdep.Table (Sdep_I).Sfile; 951 952 if Print_Source then 953 Find_Status (FS, Stamp, Checksum, Status); 954 Get_Name_String (FS); 955 956 Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len)); 957 958 if Verbose_Mode then 959 Write_Str (" Source => "); 960 Write_Str (Object_Name.all); 961 962 if not Too_Long then 963 Write_Str 964 (Spaces (Source_Start + Object_Name'Length .. Source_End)); 965 end if; 966 967 Output_Status (Status, Verbose => True); 968 Write_Eol; 969 Write_Str (" "); 970 971 else 972 if not Selective_Output then 973 Output_Status (Status, Verbose => False); 974 end if; 975 976 Write_Str (Object_Name.all); 977 end if; 978 end if; 979 end Output_Source; 980 981 ------------------- 982 -- Output_Status -- 983 ------------------- 984 985 procedure Output_Status (FS : File_Status; Verbose : Boolean) is 986 begin 987 if Verbose then 988 case FS is 989 when OK => 990 Write_Str (" unchanged"); 991 992 when Checksum_OK => 993 Write_Str (" slightly modified"); 994 995 when Not_Found => 996 Write_Str (" file not found"); 997 998 when Not_Same => 999 Write_Str (" modified"); 1000 1001 when Not_First_On_PATH => 1002 Write_Str (" unchanged version not first on PATH"); 1003 end case; 1004 1005 else 1006 case FS is 1007 when OK => 1008 Write_Str (" OK "); 1009 1010 when Checksum_OK => 1011 Write_Str (" MOK "); 1012 1013 when Not_Found => 1014 Write_Str (" ??? "); 1015 1016 when Not_Same => 1017 Write_Str (" DIF "); 1018 1019 when Not_First_On_PATH => 1020 Write_Str (" HID "); 1021 end case; 1022 end if; 1023 end Output_Status; 1024 1025 ----------------- 1026 -- Output_Unit -- 1027 ----------------- 1028 1029 procedure Output_Unit (ALI : ALI_Id; U_Id : Unit_Id) is 1030 Kind : Character; 1031 U : Unit_Record renames Units.Table (U_Id); 1032 1033 begin 1034 if Print_Unit then 1035 Get_Name_String (U.Uname); 1036 Kind := Name_Buffer (Name_Len); 1037 Name_Len := Name_Len - 2; 1038 1039 if not Verbose_Mode then 1040 Write_Str (Name_Buffer (1 .. Name_Len)); 1041 1042 else 1043 Write_Str ("Unit => "); 1044 Write_Eol; 1045 Write_Str (" Name => "); 1046 Write_Str (Name_Buffer (1 .. Name_Len)); 1047 Write_Eol; 1048 Write_Str (" Kind => "); 1049 1050 if Units.Table (U_Id).Unit_Kind = 'p' then 1051 Write_Str ("package "); 1052 else 1053 Write_Str ("subprogram "); 1054 end if; 1055 1056 if Kind = 's' then 1057 Write_Str ("spec"); 1058 else 1059 Write_Str ("body"); 1060 end if; 1061 end if; 1062 1063 if Verbose_Mode then 1064 if U.Preelab or else 1065 U.No_Elab or else 1066 U.Pure or else 1067 U.Dynamic_Elab or else 1068 U.Has_RACW or else 1069 U.Remote_Types or else 1070 U.Shared_Passive or else 1071 U.RCI or else 1072 U.Predefined or else 1073 U.Internal or else 1074 U.Is_Generic or else 1075 U.Init_Scalars or else 1076 U.SAL_Interface or else 1077 U.Body_Needed_For_SAL or else 1078 U.Elaborate_Body 1079 then 1080 Write_Eol; 1081 Write_Str (" Flags =>"); 1082 1083 if U.Preelab then 1084 Write_Str (" Preelaborable"); 1085 end if; 1086 1087 if U.No_Elab then 1088 Write_Str (" No_Elab_Code"); 1089 end if; 1090 1091 if U.Pure then 1092 Write_Str (" Pure"); 1093 end if; 1094 1095 if U.Dynamic_Elab then 1096 Write_Str (" Dynamic_Elab"); 1097 end if; 1098 1099 if U.Has_RACW then 1100 Write_Str (" Has_RACW"); 1101 end if; 1102 1103 if U.Remote_Types then 1104 Write_Str (" Remote_Types"); 1105 end if; 1106 1107 if U.Shared_Passive then 1108 Write_Str (" Shared_Passive"); 1109 end if; 1110 1111 if U.RCI then 1112 Write_Str (" RCI"); 1113 end if; 1114 1115 if U.Predefined then 1116 Write_Str (" Predefined"); 1117 end if; 1118 1119 if U.Internal then 1120 Write_Str (" Internal"); 1121 end if; 1122 1123 if U.Is_Generic then 1124 Write_Str (" Is_Generic"); 1125 end if; 1126 1127 if U.Init_Scalars then 1128 Write_Str (" Init_Scalars"); 1129 end if; 1130 1131 if U.SAL_Interface then 1132 Write_Str (" SAL_Interface"); 1133 end if; 1134 1135 if U.Body_Needed_For_SAL then 1136 Write_Str (" Body_Needed_For_SAL"); 1137 end if; 1138 1139 if U.Elaborate_Body then 1140 Write_Str (" Elaborate Body"); 1141 end if; 1142 1143 if U.Remote_Types then 1144 Write_Str (" Remote_Types"); 1145 end if; 1146 1147 if U.Shared_Passive then 1148 Write_Str (" Shared_Passive"); 1149 end if; 1150 1151 if U.Predefined then 1152 Write_Str (" Predefined"); 1153 end if; 1154 end if; 1155 1156 declare 1157 Restrictions : constant Restrictions_Info := 1158 ALIs.Table (ALI).Restrictions; 1159 1160 begin 1161 -- If the source was compiled with pragmas Restrictions, 1162 -- Display these restrictions. 1163 1164 if Restrictions.Set /= (All_Restrictions => False) then 1165 Write_Eol; 1166 Write_Str (" pragma Restrictions =>"); 1167 1168 -- For boolean restrictions, just display the name of the 1169 -- restriction; for valued restrictions, also display the 1170 -- restriction value. 1171 1172 for Restriction in All_Restrictions loop 1173 if Restrictions.Set (Restriction) then 1174 Write_Eol; 1175 Write_Str (" "); 1176 Write_Str (Image (Restriction)); 1177 1178 if Restriction in All_Parameter_Restrictions then 1179 Write_Str (" =>"); 1180 Write_Str (Restrictions.Value (Restriction)'Img); 1181 end if; 1182 end if; 1183 end loop; 1184 end if; 1185 1186 -- If the unit violates some Restrictions, display the list of 1187 -- these restrictions. 1188 1189 if Restrictions.Violated /= (All_Restrictions => False) then 1190 Write_Eol; 1191 Write_Str (" Restrictions violated =>"); 1192 1193 -- For boolean restrictions, just display the name of the 1194 -- restriction. For valued restrictions, also display the 1195 -- restriction value. 1196 1197 for Restriction in All_Restrictions loop 1198 if Restrictions.Violated (Restriction) then 1199 Write_Eol; 1200 Write_Str (" "); 1201 Write_Str (Image (Restriction)); 1202 1203 if Restriction in All_Parameter_Restrictions then 1204 if Restrictions.Count (Restriction) > 0 then 1205 Write_Str (" =>"); 1206 1207 if Restrictions.Unknown (Restriction) then 1208 Write_Str (" at least"); 1209 end if; 1210 1211 Write_Str (Restrictions.Count (Restriction)'Img); 1212 end if; 1213 end if; 1214 end if; 1215 end loop; 1216 end if; 1217 end; 1218 end if; 1219 1220 if Print_Source then 1221 if Too_Long then 1222 Write_Eol; 1223 Write_Str (" "); 1224 else 1225 Write_Str (Spaces (Unit_Start + Name_Len + 1 .. Unit_End)); 1226 end if; 1227 end if; 1228 end if; 1229 end Output_Unit; 1230 1231 package body Prj_Env is 1232 1233 Uninitialized_Prefix : constant String := '#' & Path_Separator; 1234 -- Prefix to indicate that the project path has not been initialized 1235 -- yet. Must be two characters long. 1236 1237 --------------------- 1238 -- Add_Directories -- 1239 --------------------- 1240 1241 procedure Add_Directories 1242 (Self : in out String_Access; 1243 Path : String; 1244 Prepend : Boolean := False) 1245 is 1246 Tmp : String_Access; 1247 1248 begin 1249 if Self = null then 1250 Self := new String'(Uninitialized_Prefix & Path); 1251 else 1252 Tmp := Self; 1253 if Prepend then 1254 Self := new String'(Path & Path_Separator & Tmp.all); 1255 else 1256 Self := new String'(Tmp.all & Path_Separator & Path); 1257 end if; 1258 Free (Tmp); 1259 end if; 1260 end Add_Directories; 1261 1262 ------------------------------------- 1263 -- Initialize_Default_Project_Path -- 1264 ------------------------------------- 1265 1266 procedure Initialize_Default_Project_Path 1267 (Self : in out String_Access; 1268 Target_Name : String; 1269 Runtime_Name : String := "") 1270 is 1271 Add_Default_Dir : Boolean := Target_Name /= "-"; 1272 First : Positive; 1273 Last : Positive; 1274 1275 Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; 1276 Gpr_Project_Path : constant String := "GPR_PROJECT_PATH"; 1277 Gpr_Project_Path_File : constant String := "GPR_PROJECT_PATH_FILE"; 1278 -- Names of alternate env. variables that contain path name(s) of 1279 -- directories where project files may reside. They are taken into 1280 -- account in this order: GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH, 1281 -- ADA_PROJECT_PATH. 1282 1283 Gpr_Prj_Path_File : String_Access; 1284 Gpr_Prj_Path : String_Access; 1285 Ada_Prj_Path : String_Access; 1286 -- The path name(s) of directories where project files may reside. 1287 -- May be empty. 1288 1289 Prefix : String_Ptr; 1290 Runtime : String_Ptr; 1291 1292 procedure Add_Target (Suffix : String); 1293 -- Add :<prefix>/<target>/Suffix to the project path 1294 1295 FD : File_Descriptor; 1296 Len : Integer; 1297 1298 ---------------- 1299 -- Add_Target -- 1300 ---------------- 1301 1302 procedure Add_Target (Suffix : String) is 1303 Extra_Sep : constant String := 1304 (if Target_Name (Target_Name'Last) = '/' then 1305 "" 1306 else 1307 (1 => Directory_Separator)); 1308 -- Note: Target_Name has a trailing / when it comes from Sdefault 1309 1310 begin 1311 Add_Str_To_Name_Buffer 1312 (Path_Separator & Prefix.all & Target_Name & Extra_Sep & Suffix); 1313 end Add_Target; 1314 1315 -- Start of processing for Initialize_Default_Project_Path 1316 1317 begin 1318 if Self /= null 1319 and then (Self'Length = 0 1320 or else Self (Self'First) /= '#') 1321 then 1322 return; 1323 end if; 1324 1325 -- The current directory is always first in the search path. Since 1326 -- the Project_Path currently starts with '#:' as a sign that it is 1327 -- not initialized, we simply replace '#' with '.' 1328 1329 if Self = null then 1330 Self := new String'('.' & Path_Separator); 1331 else 1332 Self (Self'First) := '.'; 1333 end if; 1334 1335 -- Then the reset of the project path (if any) currently contains the 1336 -- directories added through Add_Search_Project_Directory 1337 1338 -- If environment variables are defined and not empty, add their 1339 -- content 1340 1341 Gpr_Prj_Path_File := Getenv (Gpr_Project_Path_File); 1342 Gpr_Prj_Path := Getenv (Gpr_Project_Path); 1343 Ada_Prj_Path := Getenv (Ada_Project_Path); 1344 1345 if Gpr_Prj_Path_File.all /= "" then 1346 FD := Open_Read (Gpr_Prj_Path_File.all, GNAT.OS_Lib.Text); 1347 1348 if FD = Invalid_FD then 1349 Osint.Fail 1350 ("warning: could not read project path file """ 1351 & Gpr_Prj_Path_File.all & """"); 1352 end if; 1353 1354 Len := Integer (File_Length (FD)); 1355 1356 declare 1357 Buffer : String (1 .. Len); 1358 Index : Positive := 1; 1359 Last : Positive; 1360 Tmp : String_Access; 1361 1362 begin 1363 -- Read the file 1364 1365 Len := Read (FD, Buffer (1)'Address, Len); 1366 Close (FD); 1367 1368 -- Scan the file line by line 1369 1370 while Index < Buffer'Last loop 1371 1372 -- Find the end of line 1373 1374 Last := Index; 1375 while Last <= Buffer'Last 1376 and then Buffer (Last) /= ASCII.LF 1377 and then Buffer (Last) /= ASCII.CR 1378 loop 1379 Last := Last + 1; 1380 end loop; 1381 1382 -- Ignore empty lines 1383 1384 if Last > Index then 1385 Tmp := Self; 1386 Self := 1387 new String' 1388 (Tmp.all & Path_Separator & 1389 Buffer (Index .. Last - 1)); 1390 Free (Tmp); 1391 end if; 1392 1393 -- Find the beginning of the next line 1394 1395 Index := Last; 1396 while Buffer (Index) = ASCII.CR or else 1397 Buffer (Index) = ASCII.LF 1398 loop 1399 Index := Index + 1; 1400 end loop; 1401 end loop; 1402 end; 1403 1404 end if; 1405 1406 if Gpr_Prj_Path.all /= "" then 1407 Add_Directories (Self, Gpr_Prj_Path.all); 1408 end if; 1409 1410 Free (Gpr_Prj_Path); 1411 1412 if Ada_Prj_Path.all /= "" then 1413 Add_Directories (Self, Ada_Prj_Path.all); 1414 end if; 1415 1416 Free (Ada_Prj_Path); 1417 1418 -- Copy to Name_Buffer, since we will need to manipulate the path 1419 1420 Name_Len := Self'Length; 1421 Name_Buffer (1 .. Name_Len) := Self.all; 1422 1423 -- Scan the directory path to see if "-" is one of the directories. 1424 -- Remove each occurrence of "-" and set Add_Default_Dir to False. 1425 -- Also resolve relative paths and symbolic links. 1426 1427 First := 3; 1428 loop 1429 while First <= Name_Len 1430 and then (Name_Buffer (First) = Path_Separator) 1431 loop 1432 First := First + 1; 1433 end loop; 1434 1435 exit when First > Name_Len; 1436 1437 Last := First; 1438 1439 while Last < Name_Len 1440 and then Name_Buffer (Last + 1) /= Path_Separator 1441 loop 1442 Last := Last + 1; 1443 end loop; 1444 1445 -- If the directory is "-", set Add_Default_Dir to False and 1446 -- remove from path. 1447 1448 if Name_Buffer (First .. Last) = "-" then 1449 Add_Default_Dir := False; 1450 1451 for J in Last + 1 .. Name_Len loop 1452 Name_Buffer (J - 2) := Name_Buffer (J); 1453 end loop; 1454 1455 Name_Len := Name_Len - 2; 1456 1457 -- After removing the '-', go back one character to get the 1458 -- next directory correctly. 1459 1460 Last := Last - 1; 1461 1462 else 1463 declare 1464 New_Dir : constant String := 1465 Normalize_Pathname 1466 (Name_Buffer (First .. Last), 1467 Resolve_Links => Opt.Follow_Links_For_Dirs); 1468 New_Len : Positive; 1469 New_Last : Positive; 1470 1471 begin 1472 -- If the absolute path was resolved and is different from 1473 -- the original, replace original with the resolved path. 1474 1475 if New_Dir /= Name_Buffer (First .. Last) 1476 and then New_Dir'Length /= 0 1477 then 1478 New_Len := Name_Len + New_Dir'Length - (Last - First + 1); 1479 New_Last := First + New_Dir'Length - 1; 1480 Name_Buffer (New_Last + 1 .. New_Len) := 1481 Name_Buffer (Last + 1 .. Name_Len); 1482 Name_Buffer (First .. New_Last) := New_Dir; 1483 Name_Len := New_Len; 1484 Last := New_Last; 1485 end if; 1486 end; 1487 end if; 1488 1489 First := Last + 1; 1490 end loop; 1491 1492 Free (Self); 1493 1494 -- Set the initial value of Current_Project_Path 1495 1496 if Add_Default_Dir then 1497 if Sdefault.Search_Dir_Prefix = null then 1498 1499 -- gprbuild case 1500 1501 Prefix := new String'(Executable_Prefix_Path); 1502 1503 else 1504 Prefix := new String'(Sdefault.Search_Dir_Prefix.all 1505 & ".." & Dir_Separator 1506 & ".." & Dir_Separator 1507 & ".." & Dir_Separator 1508 & ".." & Dir_Separator); 1509 end if; 1510 1511 if Prefix.all /= "" then 1512 if Target_Name /= "" then 1513 1514 if Runtime_Name /= "" then 1515 if Base_Name (Runtime_Name) = Runtime_Name then 1516 1517 -- $prefix/$target/$runtime/lib/gnat 1518 1519 Add_Target 1520 (Runtime_Name & Directory_Separator & 1521 "lib" & Directory_Separator & "gnat"); 1522 1523 -- $prefix/$target/$runtime/share/gpr 1524 1525 Add_Target 1526 (Runtime_Name & Directory_Separator & 1527 "share" & Directory_Separator & "gpr"); 1528 1529 else 1530 Runtime := 1531 new String'(Normalize_Pathname (Runtime_Name)); 1532 1533 -- $runtime_dir/lib/gnat 1534 1535 Add_Str_To_Name_Buffer 1536 (Path_Separator & Runtime.all & Directory_Separator & 1537 "lib" & Directory_Separator & "gnat"); 1538 1539 -- $runtime_dir/share/gpr 1540 1541 Add_Str_To_Name_Buffer 1542 (Path_Separator & Runtime.all & Directory_Separator & 1543 "share" & Directory_Separator & "gpr"); 1544 end if; 1545 end if; 1546 1547 -- $prefix/$target/lib/gnat 1548 1549 Add_Target 1550 ("lib" & Directory_Separator & "gnat"); 1551 1552 -- $prefix/$target/share/gpr 1553 1554 Add_Target 1555 ("share" & Directory_Separator & "gpr"); 1556 end if; 1557 1558 -- $prefix/share/gpr 1559 1560 Add_Str_To_Name_Buffer 1561 (Path_Separator & Prefix.all & "share" 1562 & Directory_Separator & "gpr"); 1563 1564 -- $prefix/lib/gnat 1565 1566 Add_Str_To_Name_Buffer 1567 (Path_Separator & Prefix.all & "lib" 1568 & Directory_Separator & "gnat"); 1569 end if; 1570 1571 Free (Prefix); 1572 end if; 1573 1574 Self := new String'(Name_Buffer (1 .. Name_Len)); 1575 end Initialize_Default_Project_Path; 1576 1577 ----------------------- 1578 -- Get_Runtime_Path -- 1579 ----------------------- 1580 1581 function Get_Runtime_Path 1582 (Self : String_Access; 1583 Path : String) return String_Access 1584 is 1585 First : Natural; 1586 Last : Natural; 1587 1588 begin 1589 1590 if Is_Absolute_Path (Path) then 1591 if Is_Directory (Path) then 1592 return new String'(Path); 1593 else 1594 return null; 1595 end if; 1596 1597 else 1598 -- Because we do not want to resolve symbolic links, we cannot 1599 -- use Locate_Regular_File. Instead we try each possible path 1600 -- successively. 1601 1602 First := Self'First; 1603 while First <= Self'Last loop 1604 while First <= Self'Last 1605 and then Self (First) = Path_Separator 1606 loop 1607 First := First + 1; 1608 end loop; 1609 1610 exit when First > Self'Last; 1611 1612 Last := First; 1613 while Last < Self'Last 1614 and then Self (Last + 1) /= Path_Separator 1615 loop 1616 Last := Last + 1; 1617 end loop; 1618 1619 Name_Len := 0; 1620 1621 if not Is_Absolute_Path (Self (First .. Last)) then 1622 Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call 1623 Add_Char_To_Name_Buffer (Directory_Separator); 1624 end if; 1625 1626 Add_Str_To_Name_Buffer (Self (First .. Last)); 1627 Add_Char_To_Name_Buffer (Directory_Separator); 1628 Add_Str_To_Name_Buffer (Path); 1629 1630 if Is_Directory (Name_Buffer (1 .. Name_Len)) then 1631 return new String'(Name_Buffer (1 .. Name_Len)); 1632 end if; 1633 1634 First := Last + 1; 1635 end loop; 1636 end if; 1637 1638 return null; 1639 end Get_Runtime_Path; 1640 1641 end Prj_Env; 1642 1643 ----------------- 1644 -- Reset_Print -- 1645 ----------------- 1646 1647 procedure Reset_Print is 1648 begin 1649 if not Selective_Output then 1650 Selective_Output := True; 1651 Print_Source := False; 1652 Print_Object := False; 1653 Print_Unit := False; 1654 end if; 1655 end Reset_Print; 1656 1657 ---------------- 1658 -- Search_RTS -- 1659 ---------------- 1660 1661 procedure Search_RTS (Name : String) is 1662 Src_Path : String_Ptr; 1663 Lib_Path : String_Ptr; 1664 -- Paths for source and include subdirs 1665 1666 Rts_Full_Path : String_Access; 1667 -- Full path for RTS project 1668 1669 begin 1670 -- Try to find the RTS 1671 1672 Src_Path := Get_RTS_Search_Dir (Name, Include); 1673 Lib_Path := Get_RTS_Search_Dir (Name, Objects); 1674 1675 -- For non-project RTS, both the include and the objects directories 1676 -- must be present. 1677 1678 if Src_Path /= null and then Lib_Path /= null then 1679 Add_Search_Dirs (Src_Path, Include); 1680 Add_Search_Dirs (Lib_Path, Objects); 1681 Prj_Env.Initialize_Default_Project_Path 1682 (Prj_Path, 1683 Target_Name => Sdefault.Target_Name.all, 1684 Runtime_Name => Name); 1685 return; 1686 end if; 1687 1688 if Lib_Path /= null then 1689 Osint.Fail ("RTS path not valid: missing adainclude directory"); 1690 elsif Src_Path /= null then 1691 Osint.Fail ("RTS path not valid: missing adalib directory"); 1692 end if; 1693 1694 -- Try to find the RTS on the project path. First setup the project path 1695 1696 Prj_Env.Initialize_Default_Project_Path 1697 (Prj_Path, 1698 Target_Name => Sdefault.Target_Name.all, 1699 Runtime_Name => Name); 1700 1701 Rts_Full_Path := Prj_Env.Get_Runtime_Path (Prj_Path, Name); 1702 1703 if Rts_Full_Path /= null then 1704 1705 -- Directory name was found on the project path. Look for the 1706 -- include subdirectory(s). 1707 1708 Src_Path := Get_RTS_Search_Dir (Rts_Full_Path.all, Include); 1709 1710 if Src_Path /= null then 1711 Add_Search_Dirs (Src_Path, Include); 1712 1713 -- Add the lib subdirectory if it exists 1714 1715 Lib_Path := Get_RTS_Search_Dir (Rts_Full_Path.all, Objects); 1716 1717 if Lib_Path /= null then 1718 Add_Search_Dirs (Lib_Path, Objects); 1719 end if; 1720 1721 return; 1722 end if; 1723 end if; 1724 1725 Osint.Fail 1726 ("RTS path not valid: missing adainclude and adalib directories"); 1727 end Search_RTS; 1728 1729 ------------------- 1730 -- Scan_Ls_Arg -- 1731 ------------------- 1732 1733 procedure Scan_Ls_Arg (Argv : String) is 1734 FD : File_Descriptor; 1735 Len : Integer; 1736 OK : Boolean; 1737 1738 begin 1739 pragma Assert (Argv'First = 1); 1740 1741 if Argv'Length = 0 then 1742 return; 1743 end if; 1744 1745 OK := True; 1746 if Argv (1) = '-' then 1747 if Argv'Length = 1 then 1748 Fail ("switch character cannot be followed by a blank"); 1749 1750 -- Processing for -I- 1751 1752 elsif Argv (2 .. Argv'Last) = "I-" then 1753 Opt.Look_In_Primary_Dir := False; 1754 1755 -- Forbid -?- or -??- where ? is any character 1756 1757 elsif (Argv'Length = 3 and then Argv (3) = '-') 1758 or else (Argv'Length = 4 and then Argv (4) = '-') 1759 then 1760 Fail ("Trailing ""-"" at the end of " & Argv & " forbidden."); 1761 1762 -- Processing for -Idir 1763 1764 elsif Argv (2) = 'I' then 1765 Add_Source_Dir (Argv (3 .. Argv'Last)); 1766 Add_Lib_Dir (Argv (3 .. Argv'Last)); 1767 1768 -- Processing for -aIdir (to gcc this is like a -I switch) 1769 1770 elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then 1771 Add_Source_Dir (Argv (4 .. Argv'Last)); 1772 1773 -- Processing for -aOdir 1774 1775 elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aO" then 1776 Add_Lib_Dir (Argv (4 .. Argv'Last)); 1777 1778 -- Processing for -aLdir (to gnatbind this is like a -aO switch) 1779 1780 elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then 1781 Add_Lib_Dir (Argv (4 .. Argv'Last)); 1782 1783 -- Processing for -aP<dir> 1784 1785 elsif Argv'Length > 3 and then Argv (1 .. 3) = "-aP" then 1786 Prj_Env.Add_Directories (Prj_Path, Argv (4 .. Argv'Last)); 1787 1788 -- Processing for -nostdinc 1789 1790 elsif Argv (2 .. Argv'Last) = "nostdinc" then 1791 Opt.No_Stdinc := True; 1792 1793 -- Processing for one character switches 1794 1795 elsif Argv'Length = 2 then 1796 case Argv (2) is 1797 when 'a' => Also_Predef := True; 1798 when 'h' => Print_Usage := True; 1799 when 'u' => Reset_Print; Print_Unit := True; 1800 when 's' => Reset_Print; Print_Source := True; 1801 when 'o' => Reset_Print; Print_Object := True; 1802 when 'v' => Verbose_Mode := True; 1803 when 'd' => Dependable := True; 1804 when 'l' => License := True; 1805 when 'V' => Very_Verbose_Mode := True; 1806 1807 when others => OK := False; 1808 end case; 1809 1810 -- Processing for -files=file 1811 1812 elsif Argv'Length > 7 and then Argv (1 .. 7) = "-files=" then 1813 FD := Open_Read (Argv (8 .. Argv'Last), GNAT.OS_Lib.Text); 1814 1815 if FD = Invalid_FD then 1816 Osint.Fail ("could not find text file """ & 1817 Argv (8 .. Argv'Last) & '"'); 1818 end if; 1819 1820 Len := Integer (File_Length (FD)); 1821 1822 declare 1823 Buffer : String (1 .. Len + 1); 1824 Index : Positive := 1; 1825 Last : Positive; 1826 1827 begin 1828 -- Read the file 1829 1830 Len := Read (FD, Buffer (1)'Address, Len); 1831 Buffer (Buffer'Last) := ASCII.NUL; 1832 Close (FD); 1833 1834 -- Scan the file line by line 1835 1836 while Index < Buffer'Last loop 1837 1838 -- Find the end of line 1839 1840 Last := Index; 1841 while Last <= Buffer'Last 1842 and then Buffer (Last) /= ASCII.LF 1843 and then Buffer (Last) /= ASCII.CR 1844 loop 1845 Last := Last + 1; 1846 end loop; 1847 1848 -- Ignore empty lines 1849 1850 if Last > Index then 1851 Add_File (Buffer (Index .. Last - 1)); 1852 end if; 1853 1854 -- Find the beginning of the next line 1855 1856 Index := Last; 1857 while Buffer (Index) = ASCII.CR or else 1858 Buffer (Index) = ASCII.LF 1859 loop 1860 Index := Index + 1; 1861 end loop; 1862 end loop; 1863 end; 1864 1865 -- Processing for --RTS=path 1866 1867 elsif Argv'Length >= 5 and then Argv (1 .. 5) = "--RTS" then 1868 if Argv'Length <= 6 or else Argv (6) /= '='then 1869 Osint.Fail ("missing path for --RTS"); 1870 1871 else 1872 -- Check that it is the first time we see this switch or, if 1873 -- it is not the first time, the same path is specified. 1874 1875 if RTS_Specified = null then 1876 RTS_Specified := new String'(Argv (7 .. Argv'Last)); 1877 1878 elsif RTS_Specified.all /= Argv (7 .. Argv'Last) then 1879 Osint.Fail ("--RTS cannot be specified multiple times"); 1880 end if; 1881 1882 -- Valid --RTS switch 1883 1884 Opt.No_Stdinc := True; 1885 Opt.RTS_Switch := True; 1886 end if; 1887 1888 else 1889 OK := False; 1890 end if; 1891 1892 -- If not a switch, it must be a file name 1893 1894 else 1895 Add_File (Argv); 1896 end if; 1897 1898 if not OK then 1899 Write_Str ("warning: unknown switch """); 1900 Write_Str (Argv); 1901 Write_Line (""""); 1902 end if; 1903 1904 end Scan_Ls_Arg; 1905 1906 ----------- 1907 -- Usage -- 1908 ----------- 1909 1910 procedure Usage is 1911 begin 1912 -- Usage line 1913 1914 Write_Str ("Usage: "); 1915 Osint.Write_Program_Name; 1916 Write_Str (" switches [list of object files]"); 1917 Write_Eol; 1918 Write_Eol; 1919 1920 -- GNATLS switches 1921 1922 Write_Str ("switches:"); 1923 Write_Eol; 1924 1925 Display_Usage_Version_And_Help; 1926 1927 -- Line for -a 1928 1929 Write_Str (" -a also output relevant predefined units"); 1930 Write_Eol; 1931 1932 -- Line for -u 1933 1934 Write_Str (" -u output only relevant unit names"); 1935 Write_Eol; 1936 1937 -- Line for -h 1938 1939 Write_Str (" -h output this help message"); 1940 Write_Eol; 1941 1942 -- Line for -s 1943 1944 Write_Str (" -s output only relevant source names"); 1945 Write_Eol; 1946 1947 -- Line for -o 1948 1949 Write_Str (" -o output only relevant object names"); 1950 Write_Eol; 1951 1952 -- Line for -d 1953 1954 Write_Str (" -d output sources on which specified units " & 1955 "depend"); 1956 Write_Eol; 1957 1958 -- Line for -l 1959 1960 Write_Str (" -l output license information"); 1961 Write_Eol; 1962 1963 -- Line for -v 1964 1965 Write_Str (" -v verbose output, full path and unit " & 1966 "information"); 1967 Write_Eol; 1968 Write_Eol; 1969 1970 -- Line for -files= 1971 1972 Write_Str (" -files=fil files are listed in text file 'fil'"); 1973 Write_Eol; 1974 1975 -- Line for -aI switch 1976 1977 Write_Str (" -aIdir specify source files search path"); 1978 Write_Eol; 1979 1980 -- Line for -aO switch 1981 1982 Write_Str (" -aOdir specify object files search path"); 1983 Write_Eol; 1984 1985 -- Line for -aP switch 1986 1987 Write_Str (" -aPdir specify project search path"); 1988 Write_Eol; 1989 1990 -- Line for -I switch 1991 1992 Write_Str (" -Idir like -aIdir -aOdir"); 1993 Write_Eol; 1994 1995 -- Line for -I- switch 1996 1997 Write_Str (" -I- do not look for sources & object files"); 1998 Write_Str (" in the default directory"); 1999 Write_Eol; 2000 2001 -- Line for -nostdinc 2002 2003 Write_Str (" -nostdinc do not look for source files"); 2004 Write_Str (" in the system default directory"); 2005 Write_Eol; 2006 2007 -- Line for --RTS 2008 2009 Write_Str (" --RTS=dir specify the default source and object search" 2010 & " path"); 2011 Write_Eol; 2012 2013 -- File Status explanation 2014 2015 Write_Eol; 2016 Write_Str (" file status can be:"); 2017 Write_Eol; 2018 2019 for ST in File_Status loop 2020 Write_Str (" "); 2021 Output_Status (ST, Verbose => False); 2022 Write_Str (" ==> "); 2023 Output_Status (ST, Verbose => True); 2024 Write_Eol; 2025 end loop; 2026 end Usage; 2027 2028 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); 2029 2030-- Start of processing for Gnatls 2031 2032begin 2033 -- Initialize standard packages 2034 2035 Csets.Initialize; 2036 Snames.Initialize; 2037 Stringt.Initialize; 2038 2039 -- First check for --version or --help 2040 2041 Check_Version_And_Help ("GNATLS", "1992"); 2042 2043 -- Loop to scan out arguments 2044 2045 Next_Arg := 1; 2046 Scan_Args : while Next_Arg < Arg_Count loop 2047 declare 2048 Next_Argv : String (1 .. Len_Arg (Next_Arg)); 2049 begin 2050 Fill_Arg (Next_Argv'Address, Next_Arg); 2051 Scan_Ls_Arg (Next_Argv); 2052 end; 2053 2054 Next_Arg := Next_Arg + 1; 2055 end loop Scan_Args; 2056 2057 -- If -l (output license information) is given, it must be the only switch 2058 2059 if License then 2060 if Arg_Count = 2 then 2061 Output_License_Information; 2062 Exit_Program (E_Success); 2063 2064 else 2065 Set_Standard_Error; 2066 Write_Str ("Can't use -l with another switch"); 2067 Write_Eol; 2068 Try_Help; 2069 Exit_Program (E_Fatal); 2070 end if; 2071 end if; 2072 2073 -- Handle --RTS switch 2074 2075 if RTS_Specified /= null then 2076 Search_RTS (RTS_Specified.all); 2077 end if; 2078 2079 -- Add the source and object directories specified on the command line, if 2080 -- any, to the searched directories. 2081 2082 while First_Source_Dir /= null loop 2083 Add_Src_Search_Dir (First_Source_Dir.Value.all); 2084 First_Source_Dir := First_Source_Dir.Next; 2085 end loop; 2086 2087 while First_Lib_Dir /= null loop 2088 Add_Lib_Search_Dir (First_Lib_Dir.Value.all); 2089 First_Lib_Dir := First_Lib_Dir.Next; 2090 end loop; 2091 2092 -- Finally, add the default directories 2093 2094 Osint.Add_Default_Search_Dirs; 2095 2096 -- If --RTS= is not specified, check if there is a default runtime 2097 2098 if RTS_Specified = null then 2099 declare 2100 FD : File_Descriptor; 2101 Text : Source_Buffer_Ptr; 2102 Hi : Source_Ptr; 2103 2104 begin 2105 Name_Buffer (1 .. 10) := "system.ads"; 2106 Name_Len := 10; 2107 2108 Read_Source_File (Name_Find, 0, Hi, Text, FD); 2109 2110 if Null_Source_Buffer_Ptr (Text) then 2111 No_Runtime := True; 2112 end if; 2113 end; 2114 end if; 2115 2116 if Verbose_Mode then 2117 Write_Eol; 2118 Display_Version ("GNATLS", "1997"); 2119 Write_Eol; 2120 2121 if No_Runtime then 2122 Write_Str 2123 ("Default runtime not available. Use --RTS= with a valid runtime"); 2124 Write_Eol; 2125 Write_Eol; 2126 Exit_Status := E_Warnings; 2127 end if; 2128 2129 Write_Str ("Source Search Path:"); 2130 Write_Eol; 2131 2132 for J in 1 .. Nb_Dir_In_Src_Search_Path loop 2133 Write_Str (" "); 2134 2135 if Dir_In_Src_Search_Path (J)'Length = 0 then 2136 Write_Str ("<Current_Directory>"); 2137 Write_Eol; 2138 2139 elsif not No_Runtime then 2140 Write_Str 2141 (Normalize 2142 (To_Host_Dir_Spec 2143 (Dir_In_Src_Search_Path (J).all, True).all)); 2144 Write_Eol; 2145 end if; 2146 end loop; 2147 2148 Write_Eol; 2149 Write_Eol; 2150 Write_Str ("Object Search Path:"); 2151 Write_Eol; 2152 2153 for J in 1 .. Nb_Dir_In_Obj_Search_Path loop 2154 Write_Str (" "); 2155 2156 if Dir_In_Obj_Search_Path (J)'Length = 0 then 2157 Write_Str ("<Current_Directory>"); 2158 Write_Eol; 2159 2160 elsif not No_Runtime then 2161 Write_Str 2162 (Normalize 2163 (To_Host_Dir_Spec 2164 (Dir_In_Obj_Search_Path (J).all, True).all)); 2165 Write_Eol; 2166 end if; 2167 end loop; 2168 2169 Write_Eol; 2170 Write_Eol; 2171 Write_Str (Project_Search_Path); 2172 Write_Eol; 2173 Write_Str (" <Current_Directory>"); 2174 Write_Eol; 2175 2176 Prj_Env.Initialize_Default_Project_Path 2177 (Prj_Path, Target_Name => Sdefault.Target_Name.all); 2178 2179 declare 2180 First : Natural; 2181 Last : Natural; 2182 2183 begin 2184 2185 if Prj_Path.all /= "" then 2186 First := Prj_Path'First; 2187 loop 2188 while First <= Prj_Path'Last 2189 and then (Prj_Path (First) = Path_Separator) 2190 loop 2191 First := First + 1; 2192 end loop; 2193 2194 exit when First > Prj_Path'Last; 2195 2196 Last := First; 2197 while Last < Prj_Path'Last 2198 and then Prj_Path (Last + 1) /= Path_Separator 2199 loop 2200 Last := Last + 1; 2201 end loop; 2202 2203 if First /= Last or else Prj_Path (First) /= '.' then 2204 2205 -- If the directory is ".", skip it as it is the current 2206 -- directory and it is already the first directory in the 2207 -- project path. 2208 2209 Write_Str (" "); 2210 Write_Str 2211 (Normalize 2212 (To_Host_Dir_Spec 2213 (Prj_Path (First .. Last), True).all)); 2214 Write_Eol; 2215 end if; 2216 2217 First := Last + 1; 2218 end loop; 2219 end if; 2220 end; 2221 2222 Write_Eol; 2223 end if; 2224 2225 -- Output usage information when requested 2226 2227 if Print_Usage then 2228 Usage; 2229 end if; 2230 2231 if not More_Lib_Files then 2232 if not Print_Usage and then not Verbose_Mode then 2233 if Arg_Count = 1 then 2234 Usage; 2235 else 2236 Try_Help; 2237 Exit_Status := E_Fatal; 2238 end if; 2239 end if; 2240 2241 Exit_Program (Exit_Status); 2242 end if; 2243 2244 Initialize_ALI; 2245 Initialize_ALI_Source; 2246 2247 -- Print out all libraries for which no ALI files can be located 2248 2249 while More_Lib_Files loop 2250 Main_File := Next_Main_Lib_File; 2251 Ali_File := Full_Lib_File_Name (Lib_File_Name (Main_File)); 2252 2253 if Ali_File = No_File then 2254 if Very_Verbose_Mode then 2255 GNATDIST.Output_No_ALI (Lib_File_Name (Main_File)); 2256 2257 else 2258 Set_Standard_Error; 2259 Write_Str ("Can't find library info for "); 2260 Get_Name_String (Main_File); 2261 Write_Char ('"'); -- " 2262 Write_Str (Name_Buffer (1 .. Name_Len)); 2263 Write_Char ('"'); -- " 2264 Write_Eol; 2265 Exit_Status := E_Fatal; 2266 end if; 2267 2268 else 2269 Ali_File := Strip_Directory (Ali_File); 2270 2271 if Get_Name_Table_Int (Ali_File) = 0 then 2272 Text := Read_Library_Info (Ali_File, True); 2273 2274 declare 2275 Discard : ALI_Id; 2276 begin 2277 Discard := 2278 Scan_ALI 2279 (Ali_File, 2280 Text, 2281 Ignore_ED => False, 2282 Err => False, 2283 Ignore_Errors => True); 2284 end; 2285 2286 Free (Text); 2287 end if; 2288 end if; 2289 end loop; 2290 2291 -- Reset default output file descriptor, if needed 2292 2293 Set_Standard_Output; 2294 2295 if Very_Verbose_Mode then 2296 for A in ALIs.First .. ALIs.Last loop 2297 GNATDIST.Output_ALI (A); 2298 end loop; 2299 2300 return; 2301 end if; 2302 2303 Find_General_Layout; 2304 2305 for Id in ALIs.First .. ALIs.Last loop 2306 declare 2307 Last_U : Unit_Id; 2308 2309 begin 2310 Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname); 2311 2312 if Also_Predef or else not Is_Internal_Unit then 2313 if ALIs.Table (Id).No_Object then 2314 Output_Object (No_File); 2315 else 2316 Output_Object (ALIs.Table (Id).Ofile_Full_Name); 2317 end if; 2318 2319 -- In verbose mode print all main units in the ALI file, otherwise 2320 -- just print the first one to ease columnwise printout 2321 2322 if Verbose_Mode then 2323 Last_U := ALIs.Table (Id).Last_Unit; 2324 else 2325 Last_U := ALIs.Table (Id).First_Unit; 2326 end if; 2327 2328 for U in ALIs.Table (Id).First_Unit .. Last_U loop 2329 if U /= ALIs.Table (Id).First_Unit 2330 and then Selective_Output 2331 and then Print_Unit 2332 then 2333 Write_Eol; 2334 end if; 2335 2336 Output_Unit (Id, U); 2337 2338 -- Output source now, unless if it will be done as part of 2339 -- outputing dependencies. 2340 2341 if not (Dependable and then Print_Source) then 2342 Output_Source (Corresponding_Sdep_Entry (Id, U)); 2343 end if; 2344 end loop; 2345 2346 -- Print out list of units on which this unit depends (D lines) 2347 2348 if Dependable and then Print_Source then 2349 if Verbose_Mode then 2350 Write_Str ("depends upon"); 2351 Write_Eol; 2352 Write_Str (" "); 2353 else 2354 Write_Eol; 2355 end if; 2356 2357 for D in 2358 ALIs.Table (Id).First_Sdep .. ALIs.Table (Id).Last_Sdep 2359 loop 2360 if Also_Predef 2361 or else not Is_Internal_File_Name (Sdep.Table (D).Sfile) 2362 then 2363 if Verbose_Mode then 2364 Write_Str (" "); 2365 Output_Source (D); 2366 2367 elsif Too_Long then 2368 Write_Str (" "); 2369 Output_Source (D); 2370 Write_Eol; 2371 2372 else 2373 Write_Str (Spaces (1 .. Source_Start - 2)); 2374 Output_Source (D); 2375 Write_Eol; 2376 end if; 2377 end if; 2378 end loop; 2379 end if; 2380 2381 Write_Eol; 2382 end if; 2383 end; 2384 end loop; 2385 2386 -- All done. Set proper exit status 2387 2388 Namet.Finalize; 2389 Exit_Program (Exit_Status); 2390end Gnatls; 2391