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-2018, 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 -- Output license statement, and if not found, output reference to COPYING 191 192 function Image (Restriction : Restriction_Id) return String; 193 -- Returns the capitalized image of Restriction 194 195 function Normalize (Path : String) return String; 196 -- Returns a normalized path name. On Windows, the directory separators are 197 -- set to '\' in Normalize_Pathname. 198 199 ------------------------------------------ 200 -- GNATDIST specific output subprograms -- 201 ------------------------------------------ 202 203 package GNATDIST is 204 205 -- Any modification to this subunit requires synchronization with the 206 -- GNATDIST sources. 207 208 procedure Output_ALI (A : ALI_Id); 209 -- Comment required saying what this routine does ??? 210 211 procedure Output_No_ALI (Afile : File_Name_Type); 212 -- Comments required saying what this routine does ??? 213 214 end GNATDIST; 215 216 ------------------------------ 217 -- Support for project path -- 218 ------------------------------ 219 220 package Prj_Env is 221 222 procedure Initialize_Default_Project_Path 223 (Self : in out String_Access; 224 Target_Name : String; 225 Runtime_Name : String := ""); 226 -- Initialize Self. It will then contain the default project path on 227 -- the given target and runtime (including directories specified by the 228 -- environment variables GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH and 229 -- ADA_PROJECT_PATH). If one of the directory or Target_Name is "-", 230 -- then the path contains only those directories specified by the 231 -- environment variables (except "-"). This does nothing if Self has 232 -- already been initialized. 233 234 procedure Add_Directories 235 (Self : in out String_Access; 236 Path : String; 237 Prepend : Boolean := False); 238 -- Add one or more directories to the path. Directories added with this 239 -- procedure are added in order after the current directory and before 240 -- the path given by the environment variable GPR_PROJECT_PATH. A value 241 -- of "-" will remove the default project directory from the project 242 -- path. 243 -- 244 -- Calls to this subprogram must be performed before the first call to 245 -- Find_Project below, or PATH will be added at the end of the search 246 -- path. 247 248 function Get_Runtime_Path 249 (Self : String_Access; 250 Path : String) return String_Access; 251 -- Compute the full path for the project-based runtime name. 252 -- Path is simply searched on the project path. 253 254 end Prj_Env; 255 256 ----------------- 257 -- Add_Lib_Dir -- 258 ----------------- 259 260 procedure Add_Lib_Dir (Dir : String) is 261 begin 262 if First_Lib_Dir = null then 263 First_Lib_Dir := 264 new Dir_Data' 265 (Value => new String'(Dir), 266 Next => null); 267 Last_Lib_Dir := First_Lib_Dir; 268 269 else 270 Last_Lib_Dir.Next := 271 new Dir_Data' 272 (Value => new String'(Dir), 273 Next => null); 274 Last_Lib_Dir := Last_Lib_Dir.Next; 275 end if; 276 end Add_Lib_Dir; 277 278 -------------------- 279 -- Add_Source_Dir -- 280 -------------------- 281 282 procedure Add_Source_Dir (Dir : String) is 283 begin 284 if First_Source_Dir = null then 285 First_Source_Dir := 286 new Dir_Data' 287 (Value => new String'(Dir), 288 Next => null); 289 Last_Source_Dir := First_Source_Dir; 290 291 else 292 Last_Source_Dir.Next := 293 new Dir_Data' 294 (Value => new String'(Dir), 295 Next => null); 296 Last_Source_Dir := Last_Source_Dir.Next; 297 end if; 298 end Add_Source_Dir; 299 300 ------------------------------ 301 -- Corresponding_Sdep_Entry -- 302 ------------------------------ 303 304 function Corresponding_Sdep_Entry 305 (A : ALI_Id; 306 U : Unit_Id) return Sdep_Id 307 is 308 begin 309 for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop 310 if Sdep.Table (D).Sfile = Units.Table (U).Sfile then 311 return D; 312 end if; 313 end loop; 314 315 Error_Msg_Unit_1 := Units.Table (U).Uname; 316 Error_Msg_File_1 := ALIs.Table (A).Afile; 317 Write_Eol; 318 Error_Msg ("wrong ALI format, can't find dependency line for $ in {"); 319 Exit_Program (E_Fatal); 320 return No_Sdep_Id; 321 end Corresponding_Sdep_Entry; 322 323 ------------------------- 324 -- Find_General_Layout -- 325 ------------------------- 326 327 procedure Find_General_Layout is 328 Max_Unit_Length : Integer := 11; 329 Max_Src_Length : Integer := 11; 330 Max_Obj_Length : Integer := 11; 331 332 Len : Integer; 333 FS : File_Name_Type; 334 335 begin 336 -- Compute maximum of each column 337 338 for Id in ALIs.First .. ALIs.Last loop 339 Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname); 340 if Also_Predef or else not Is_Internal_Unit then 341 342 if Print_Unit then 343 Len := Name_Len - 1; 344 Max_Unit_Length := Integer'Max (Max_Unit_Length, Len); 345 end if; 346 347 if Print_Source then 348 FS := Full_Source_Name (ALIs.Table (Id).Sfile); 349 350 if FS = No_File then 351 Get_Name_String (ALIs.Table (Id).Sfile); 352 Name_Len := Name_Len + 13; 353 else 354 Get_Name_String (FS); 355 end if; 356 357 Max_Src_Length := Integer'Max (Max_Src_Length, Name_Len + 1); 358 end if; 359 360 if Print_Object then 361 if ALIs.Table (Id).No_Object then 362 Max_Obj_Length := 363 Integer'Max (Max_Obj_Length, No_Obj'Length); 364 else 365 Get_Name_String (ALIs.Table (Id).Ofile_Full_Name); 366 Max_Obj_Length := Integer'Max (Max_Obj_Length, Name_Len + 1); 367 end if; 368 end if; 369 end if; 370 end loop; 371 372 -- Verify is output is not wider than maximum number of columns 373 374 Too_Long := 375 Verbose_Mode 376 or else 377 (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column; 378 379 -- Set start and end of columns 380 381 Object_Start := 1; 382 Object_End := Object_Start - 1; 383 384 if Print_Object then 385 Object_End := Object_Start + Max_Obj_Length; 386 end if; 387 388 Unit_Start := Object_End + 1; 389 Unit_End := Unit_Start - 1; 390 391 if Print_Unit then 392 Unit_End := Unit_Start + Max_Unit_Length; 393 end if; 394 395 Source_Start := Unit_End + 1; 396 397 if Source_Start > Spaces'Last then 398 Source_Start := Spaces'Last; 399 end if; 400 401 Source_End := Source_Start - 1; 402 403 if Print_Source then 404 Source_End := Source_Start + Max_Src_Length; 405 end if; 406 end Find_General_Layout; 407 408 ----------------- 409 -- Find_Status -- 410 ----------------- 411 412 procedure Find_Status 413 (FS : in out File_Name_Type; 414 Stamp : Time_Stamp_Type; 415 Checksum : Word; 416 Status : out File_Status) 417 is 418 Tmp1 : File_Name_Type; 419 Tmp2 : File_Name_Type; 420 421 begin 422 Tmp1 := Full_Source_Name (FS); 423 424 if Tmp1 = No_File then 425 Status := Not_Found; 426 427 elsif File_Stamp (Tmp1) = Stamp then 428 FS := Tmp1; 429 Status := OK; 430 431 elsif Checksums_Match (Get_File_Checksum (FS), Checksum) then 432 FS := Tmp1; 433 Status := Checksum_OK; 434 435 else 436 Tmp2 := Matching_Full_Source_Name (FS, Stamp); 437 438 if Tmp2 = No_File then 439 Status := Not_Same; 440 FS := Tmp1; 441 442 else 443 Status := Not_First_On_PATH; 444 FS := Tmp2; 445 end if; 446 end if; 447 end Find_Status; 448 449 -------------- 450 -- GNATDIST -- 451 -------------- 452 453 package body GNATDIST is 454 455 N_Flags : Natural; 456 N_Indents : Natural := 0; 457 458 type Token_Type is 459 (T_No_ALI, 460 T_ALI, 461 T_Unit, 462 T_With, 463 T_Source, 464 T_Afile, 465 T_Ofile, 466 T_Sfile, 467 T_Name, 468 T_Main, 469 T_Kind, 470 T_Flags, 471 T_Preelaborated, 472 T_Pure, 473 T_Has_RACW, 474 T_Remote_Types, 475 T_Shared_Passive, 476 T_RCI, 477 T_Predefined, 478 T_Internal, 479 T_Is_Generic, 480 T_Procedure, 481 T_Function, 482 T_Package, 483 T_Subprogram, 484 T_Spec, 485 T_Body); 486 487 Image : constant array (Token_Type) of String_Access := 488 (T_No_ALI => new String'("No_ALI"), 489 T_ALI => new String'("ALI"), 490 T_Unit => new String'("Unit"), 491 T_With => new String'("With"), 492 T_Source => new String'("Source"), 493 T_Afile => new String'("Afile"), 494 T_Ofile => new String'("Ofile"), 495 T_Sfile => new String'("Sfile"), 496 T_Name => new String'("Name"), 497 T_Main => new String'("Main"), 498 T_Kind => new String'("Kind"), 499 T_Flags => new String'("Flags"), 500 T_Preelaborated => new String'("Preelaborated"), 501 T_Pure => new String'("Pure"), 502 T_Has_RACW => new String'("Has_RACW"), 503 T_Remote_Types => new String'("Remote_Types"), 504 T_Shared_Passive => new String'("Shared_Passive"), 505 T_RCI => new String'("RCI"), 506 T_Predefined => new String'("Predefined"), 507 T_Internal => new String'("Internal"), 508 T_Is_Generic => new String'("Is_Generic"), 509 T_Procedure => new String'("procedure"), 510 T_Function => new String'("function"), 511 T_Package => new String'("package"), 512 T_Subprogram => new String'("subprogram"), 513 T_Spec => new String'("spec"), 514 T_Body => new String'("body")); 515 516 procedure Output_Name (N : Name_Id); 517 -- Remove any encoding info (%b and %s) and output N 518 519 procedure Output_Afile (A : File_Name_Type); 520 procedure Output_Ofile (O : File_Name_Type); 521 procedure Output_Sfile (S : File_Name_Type); 522 -- Output various names. Check that the name is different from no name. 523 -- Otherwise, skip the output. 524 525 procedure Output_Token (T : Token_Type); 526 -- Output token using specific format. That is several indentations and: 527 -- 528 -- T_No_ALI .. T_With : <token> & " =>" & NL 529 -- T_Source .. T_Kind : <token> & " => " 530 -- T_Flags : <token> & " =>" 531 -- T_Preelab .. T_Body : " " & <token> 532 533 procedure Output_Sdep (S : Sdep_Id); 534 procedure Output_Unit (U : Unit_Id); 535 procedure Output_With (W : With_Id); 536 -- Output this entry as a global section (like ALIs) 537 538 ------------------ 539 -- Output_Afile -- 540 ------------------ 541 542 procedure Output_Afile (A : File_Name_Type) is 543 begin 544 if A /= No_File then 545 Output_Token (T_Afile); 546 Write_Name (A); 547 Write_Eol; 548 end if; 549 end Output_Afile; 550 551 ---------------- 552 -- Output_ALI -- 553 ---------------- 554 555 procedure Output_ALI (A : ALI_Id) is 556 begin 557 Output_Token (T_ALI); 558 N_Indents := N_Indents + 1; 559 560 Output_Afile (ALIs.Table (A).Afile); 561 Output_Ofile (ALIs.Table (A).Ofile_Full_Name); 562 Output_Sfile (ALIs.Table (A).Sfile); 563 564 -- Output Main 565 566 if ALIs.Table (A).Main_Program /= None then 567 Output_Token (T_Main); 568 569 if ALIs.Table (A).Main_Program = Proc then 570 Output_Token (T_Procedure); 571 else 572 Output_Token (T_Function); 573 end if; 574 575 Write_Eol; 576 end if; 577 578 -- Output Units 579 580 for U in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop 581 Output_Unit (U); 582 end loop; 583 584 -- Output Sdeps 585 586 for S in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop 587 Output_Sdep (S); 588 end loop; 589 590 N_Indents := N_Indents - 1; 591 end Output_ALI; 592 593 ------------------- 594 -- Output_No_ALI -- 595 ------------------- 596 597 procedure Output_No_ALI (Afile : File_Name_Type) is 598 begin 599 Output_Token (T_No_ALI); 600 N_Indents := N_Indents + 1; 601 Output_Afile (Afile); 602 N_Indents := N_Indents - 1; 603 end Output_No_ALI; 604 605 ----------------- 606 -- Output_Name -- 607 ----------------- 608 609 procedure Output_Name (N : Name_Id) is 610 begin 611 -- Remove any encoding info (%s or %b) 612 613 Get_Name_String (N); 614 615 if Name_Len > 2 616 and then Name_Buffer (Name_Len - 1) = '%' 617 then 618 Name_Len := Name_Len - 2; 619 end if; 620 621 Output_Token (T_Name); 622 Write_Str (Name_Buffer (1 .. Name_Len)); 623 Write_Eol; 624 end Output_Name; 625 626 ------------------ 627 -- Output_Ofile -- 628 ------------------ 629 630 procedure Output_Ofile (O : File_Name_Type) is 631 begin 632 if O /= No_File then 633 Output_Token (T_Ofile); 634 Write_Name (O); 635 Write_Eol; 636 end if; 637 end Output_Ofile; 638 639 ----------------- 640 -- Output_Sdep -- 641 ----------------- 642 643 procedure Output_Sdep (S : Sdep_Id) is 644 begin 645 Output_Token (T_Source); 646 Write_Name (Sdep.Table (S).Sfile); 647 Write_Eol; 648 end Output_Sdep; 649 650 ------------------ 651 -- Output_Sfile -- 652 ------------------ 653 654 procedure Output_Sfile (S : File_Name_Type) is 655 FS : File_Name_Type := S; 656 657 begin 658 if FS /= No_File then 659 660 -- We want to output the full source name 661 662 FS := Full_Source_Name (FS); 663 664 -- There is no full source name. This occurs for instance when a 665 -- withed unit has a spec file but no body file. This situation is 666 -- not a problem for GNATDIST since the unit may be located on a 667 -- partition we do not want to build. However, we need to locate 668 -- the spec file and to find its full source name. Replace the 669 -- body file name with the spec file name used to compile the 670 -- current unit when possible. 671 672 if FS = No_File then 673 Get_Name_String (S); 674 675 if Name_Len > 4 676 and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" 677 then 678 Name_Buffer (Name_Len) := 's'; 679 FS := Full_Source_Name (Name_Find); 680 end if; 681 end if; 682 end if; 683 684 if FS /= No_File then 685 Output_Token (T_Sfile); 686 Write_Name (FS); 687 Write_Eol; 688 end if; 689 end Output_Sfile; 690 691 ------------------ 692 -- Output_Token -- 693 ------------------ 694 695 procedure Output_Token (T : Token_Type) is 696 begin 697 if T in T_No_ALI .. T_Flags then 698 for J in 1 .. N_Indents loop 699 Write_Str (" "); 700 end loop; 701 702 Write_Str (Image (T).all); 703 704 for J in Image (T)'Length .. 12 loop 705 Write_Char (' '); 706 end loop; 707 708 Write_Str ("=>"); 709 710 if T in T_No_ALI .. T_With then 711 Write_Eol; 712 elsif T in T_Source .. T_Name then 713 Write_Char (' '); 714 end if; 715 716 elsif T in T_Preelaborated .. T_Body then 717 if T in T_Preelaborated .. T_Is_Generic then 718 if N_Flags = 0 then 719 Output_Token (T_Flags); 720 end if; 721 722 N_Flags := N_Flags + 1; 723 end if; 724 725 Write_Char (' '); 726 Write_Str (Image (T).all); 727 728 else 729 Write_Str (Image (T).all); 730 end if; 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