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