gcc/ada/gnatls.adb

   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-2009, 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
  26 with ALI;         use ALI;
  27 with ALI.Util;    use ALI.Util;
  28 with Binderr;     use Binderr;
  29 with Butil;       use Butil;
  30 with Csets;       use Csets;
  31 with Fname;       use Fname;
  32 with Gnatvsn;     use Gnatvsn;
  33 with GNAT.OS_Lib; use GNAT.OS_Lib;
  34 with Namet;       use Namet;
  35 with Opt;         use Opt;
  36 with Osint;       use Osint;
  37 with Osint.L;     use Osint.L;
  38 with Output;      use Output;
  39 with Rident;      use Rident;
  40 with Sdefault;
  41 with Snames;
  42 with Switch;      use Switch;
  43 with Types;       use Types;
  44
  45 with GNAT.Case_Util; use GNAT.Case_Util;
  46
  47 procedure Gnatls is
  48    pragma Ident (Gnat_Static_Version_String);
  49
  50    Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
  51    Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
  52    --  Names of the env. variables that contains path name(s) of directories
  53    --  where project files may reside. If GPR_PROJECT_PATH is defined, its
  54    --  value is used, otherwise ADA_PROJECT_PATH is used, if defined.
  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    No_Project_Default_Dir : constant String := "-";
  64
  65    Max_Column : constant := 80;
  66
  67    No_Obj : aliased String := "<no_obj>";
  68
  69    type File_Status is (
  70      OK,                  --  matching timestamp
  71      Checksum_OK,         --  only matching checksum
  72      Not_Found,           --  file not found on source PATH
  73      Not_Same,            --  neither checksum nor timestamp matching
  74      Not_First_On_PATH);  --  matching file hidden by Not_Same file on path
  75
  76    type Dir_Data;
  77    type Dir_Ref is access Dir_Data;
  78
  79    type Dir_Data is record
  80       Value : String_Access;
  81       Next  : Dir_Ref;
  82    end record;
  83    --  ??? comment needed
  84
  85    First_Source_Dir : Dir_Ref;
  86    Last_Source_Dir  : Dir_Ref;
  87    --  The list of source directories from the command line.
  88    --  These directories are added using Osint.Add_Src_Search_Dir
  89    --  after those of the GNAT Project File, if any.
  90
  91    First_Lib_Dir : Dir_Ref;
  92    Last_Lib_Dir  : Dir_Ref;
  93    --  The list of object directories from the command line.
  94    --  These directories are added using Osint.Add_Lib_Search_Dir
  95    --  after those of the GNAT Project File, if any.
  96
  97    Main_File : File_Name_Type;
  98    Ali_File  : File_Name_Type;
  99    Text      : Text_Buffer_Ptr;
 100    Next_Arg  : Positive;
 101
 102    Too_Long : Boolean := False;
 103    --  When True, lines are too long for multi-column output and each
 104    --  item of information is on a different line.
 105
 106    Selective_Output : Boolean := False;
 107    Print_Usage      : Boolean := False;
 108    Print_Unit       : Boolean := True;
 109    Print_Source     : Boolean := True;
 110    Print_Object     : Boolean := True;
 111    --  Flags controlling the form of the output
 112
 113    Also_Predef       : Boolean := False;  --  -a
 114    Dependable        : Boolean := False;  --  -d
 115    License           : Boolean := False;  --  -l
 116    Very_Verbose_Mode : Boolean := False;  --  -V
 117    --  Command line flags
 118
 119    Unit_Start   : Integer;
 120    Unit_End     : Integer;
 121    Source_Start : Integer;
 122    Source_End   : Integer;
 123    Object_Start : Integer;
 124    Object_End   : Integer;
 125    --  Various column starts and ends
 126
 127    Spaces : constant String (1 .. Max_Column) := (others => ' ');
 128
 129    RTS_Specified : String_Access := null;
 130    --  Used to detect multiple use of --RTS= switch
 131
 132    -----------------------
 133    -- Local Subprograms --
 134    -----------------------
 135
 136    procedure Add_Lib_Dir (Dir : String);
 137    --  Add an object directory in the list First_Lib_Dir-Last_Lib_Dir
 138
 139    procedure Add_Source_Dir (Dir : String);
 140    --  Add a source directory in the list First_Source_Dir-Last_Source_Dir
 141
 142    procedure Find_General_Layout;
 143    --  Determine the structure of the output (multi columns or not, etc)
 144
 145    procedure Find_Status
 146      (FS       : in out File_Name_Type;
 147       Stamp    : Time_Stamp_Type;
 148       Checksum : Word;
 149       Status   : out File_Status);
 150    --  Determine the file status (Status) of the file represented by FS
 151    --  with the expected Stamp and checksum given as argument. FS will be
 152    --  updated to the full file name if available.
 153
 154    function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id;
 155    --  Give the Sdep entry corresponding to the unit U in ali record A
 156
 157    procedure Output_Object (O : File_Name_Type);
 158    --  Print out the name of the object when requested
 159
 160    procedure Output_Source (Sdep_I : Sdep_Id);
 161    --  Print out the name and status of the source corresponding to this
 162    --  sdep entry.
 163
 164    procedure Output_Status (FS : File_Status; Verbose : Boolean);
 165    --  Print out FS either in a coded form if verbose is false or in an
 166    --  expanded form otherwise.
 167
 168    procedure Output_Unit (ALI : ALI_Id; U_Id : Unit_Id);
 169    --  Print out information on the unit when requested
 170
 171    procedure Reset_Print;
 172    --  Reset Print flags properly when selective output is chosen
 173
 174    procedure Scan_Ls_Arg (Argv : String);
 175    --  Scan and process lser specific arguments. Argv is a single argument
 176
 177    procedure Usage;
 178    --  Print usage message
 179
 180    procedure Output_License_Information;
 181    --  Output license statement, and if not found, output reference to
 182    --  COPYING.
 183
 184    function Image (Restriction : Restriction_Id) return String;
 185    --  Returns the capitalized image of Restriction
 186
 187    ------------------------------------------
 188    -- GNATDIST specific output subprograms --
 189    ------------------------------------------
 190
 191    package GNATDIST is
 192
 193       --  Any modification to this subunit requires synchronization with the
 194       --  GNATDIST sources.
 195
 196       procedure Output_ALI (A : ALI_Id);
 197       --  Comment required saying what this routine does ???
 198
 199       procedure Output_No_ALI (Afile : File_Name_Type);
 200       --  Comments required saying what this routine does ???
 201
 202    end GNATDIST;
 203
 204    -----------------
 205    -- Add_Lib_Dir --
 206    -----------------
 207
 208    procedure Add_Lib_Dir (Dir : String) is
 209    begin
 210       if First_Lib_Dir = null then
 211          First_Lib_Dir :=
 212            new Dir_Data'
 213              (Value => new String'(Dir),
 214               Next  => null);
 215          Last_Lib_Dir := First_Lib_Dir;
 216
 217       else
 218          Last_Lib_Dir.Next :=
 219            new Dir_Data'
 220              (Value => new String'(Dir),
 221               Next  => null);
 222          Last_Lib_Dir := Last_Lib_Dir.Next;
 223       end if;
 224    end Add_Lib_Dir;
 225
 226    -- -----------------
 227    -- Add_Source_Dir --
 228    --------------------
 229
 230    procedure Add_Source_Dir (Dir : String) is
 231    begin
 232       if First_Source_Dir = null then
 233          First_Source_Dir :=
 234            new Dir_Data'
 235              (Value => new String'(Dir),
 236               Next  => null);
 237          Last_Source_Dir := First_Source_Dir;
 238
 239       else
 240          Last_Source_Dir.Next :=
 241            new Dir_Data'
 242              (Value => new String'(Dir),
 243               Next  => null);
 244          Last_Source_Dir := Last_Source_Dir.Next;
 245       end if;
 246    end Add_Source_Dir;
 247
 248    ------------------------------
 249    -- Corresponding_Sdep_Entry --
 250    ------------------------------
 251
 252    function Corresponding_Sdep_Entry
 253      (A : ALI_Id;
 254       U : Unit_Id) return Sdep_Id
 255    is
 256    begin
 257       for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop
 258          if Sdep.Table (D).Sfile = Units.Table (U).Sfile then
 259             return D;
 260          end if;
 261       end loop;
 262
 263       Error_Msg_Unit_1 := Units.Table (U).Uname;
 264       Error_Msg_File_1 := ALIs.Table (A).Afile;
 265       Write_Eol;
 266       Error_Msg ("wrong ALI format, can't find dependency line for $ in {");
 267       Exit_Program (E_Fatal);
 268       return No_Sdep_Id;
 269    end Corresponding_Sdep_Entry;
 270
 271    -------------------------
 272    -- Find_General_Layout --
 273    -------------------------
 274
 275    procedure Find_General_Layout is
 276       Max_Unit_Length : Integer := 11;
 277       Max_Src_Length  : Integer := 11;
 278       Max_Obj_Length  : Integer := 11;
 279
 280       Len : Integer;
 281       FS  : File_Name_Type;
 282
 283    begin
 284       --  Compute maximum of each column
 285
 286       for Id in ALIs.First .. ALIs.Last loop
 287          Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname);
 288          if Also_Predef or else not Is_Internal_Unit then
 289
 290             if Print_Unit then
 291                Len := Name_Len - 1;
 292                Max_Unit_Length := Integer'Max (Max_Unit_Length, Len);
 293             end if;
 294
 295             if Print_Source then
 296                FS := Full_Source_Name (ALIs.Table (Id).Sfile);
 297
 298                if FS = No_File then
 299                   Get_Name_String (ALIs.Table (Id).Sfile);
 300                   Name_Len := Name_Len + 13;
 301                else
 302                   Get_Name_String (FS);
 303                end if;
 304
 305                Max_Src_Length := Integer'Max (Max_Src_Length, Name_Len + 1);
 306             end if;
 307
 308             if Print_Object then
 309                if ALIs.Table (Id).No_Object then
 310                   Max_Obj_Length :=
 311                     Integer'Max (Max_Obj_Length, No_Obj'Length);
 312                else
 313                   Get_Name_String (ALIs.Table (Id).Ofile_Full_Name);
 314                   Max_Obj_Length := Integer'Max (Max_Obj_Length, Name_Len + 1);
 315                end if;
 316             end if;
 317          end if;
 318       end loop;
 319
 320       --  Verify is output is not wider than maximum number of columns
 321
 322       Too_Long :=
 323         Verbose_Mode
 324           or else
 325             (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column;
 326
 327       --  Set start and end of columns
 328
 329       Object_Start := 1;
 330       Object_End   := Object_Start - 1;
 331
 332       if Print_Object then
 333          Object_End   := Object_Start + Max_Obj_Length;
 334       end if;
 335
 336       Unit_Start := Object_End + 1;
 337       Unit_End   := Unit_Start - 1;
 338
 339       if Print_Unit then
 340          Unit_End   := Unit_Start + Max_Unit_Length;
 341       end if;
 342
 343       Source_Start := Unit_End + 1;
 344
 345       if Source_Start > Spaces'Last then
 346          Source_Start := Spaces'Last;
 347       end if;
 348
 349       Source_End := Source_Start - 1;
 350
 351       if Print_Source then
 352          Source_End := Source_Start + Max_Src_Length;
 353       end if;
 354    end Find_General_Layout;
 355
 356    -----------------
 357    -- Find_Status --
 358    -----------------
 359
 360    procedure Find_Status
 361      (FS       : in out File_Name_Type;
 362       Stamp    : Time_Stamp_Type;
 363       Checksum : Word;
 364       Status   : out File_Status)
 365    is
 366       Tmp1 : File_Name_Type;
 367       Tmp2 : File_Name_Type;
 368
 369    begin
 370       Tmp1 := Full_Source_Name (FS);
 371
 372       if Tmp1 = No_File then
 373          Status := Not_Found;
 374
 375       elsif File_Stamp (Tmp1) = Stamp then
 376          FS     := Tmp1;
 377          Status := OK;
 378
 379       elsif Checksums_Match (Get_File_Checksum (FS), Checksum) then
 380          FS := Tmp1;
 381          Status := Checksum_OK;
 382
 383       else
 384          Tmp2 := Matching_Full_Source_Name (FS, Stamp);
 385
 386          if Tmp2 = No_File then
 387             Status := Not_Same;
 388             FS     := Tmp1;
 389
 390          else
 391             Status := Not_First_On_PATH;
 392             FS := Tmp2;
 393          end if;
 394       end if;
 395    end Find_Status;
 396
 397    --------------
 398    -- GNATDIST --
 399    --------------
 400
 401    package body GNATDIST is
 402
 403       N_Flags   : Natural;
 404       N_Indents : Natural := 0;
 405
 406       type Token_Type is
 407         (T_No_ALI,
 408          T_ALI,
 409          T_Unit,
 410          T_With,
 411          T_Source,
 412          T_Afile,
 413          T_Ofile,
 414          T_Sfile,
 415          T_Name,
 416          T_Main,
 417          T_Kind,
 418          T_Flags,
 419          T_Preelaborated,
 420          T_Pure,
 421          T_Has_RACW,
 422          T_Remote_Types,
 423          T_Shared_Passive,
 424          T_RCI,
 425          T_Predefined,
 426          T_Internal,
 427          T_Is_Generic,
 428          T_Procedure,
 429          T_Function,
 430          T_Package,
 431          T_Subprogram,
 432          T_Spec,
 433          T_Body);
 434
 435       Image : constant array (Token_Type) of String_Access :=
 436                 (T_No_ALI         => new String'("No_ALI"),
 437                  T_ALI            => new String'("ALI"),
 438                  T_Unit           => new String'("Unit"),
 439                  T_With           => new String'("With"),
 440                  T_Source         => new String'("Source"),
 441                  T_Afile          => new String'("Afile"),
 442                  T_Ofile          => new String'("Ofile"),
 443                  T_Sfile          => new String'("Sfile"),
 444                  T_Name           => new String'("Name"),
 445                  T_Main           => new String'("Main"),
 446                  T_Kind           => new String'("Kind"),
 447                  T_Flags          => new String'("Flags"),
 448                  T_Preelaborated  => new String'("Preelaborated"),
 449                  T_Pure           => new String'("Pure"),
 450                  T_Has_RACW       => new String'("Has_RACW"),
 451                  T_Remote_Types   => new String'("Remote_Types"),
 452                  T_Shared_Passive => new String'("Shared_Passive"),
 453                  T_RCI            => new String'("RCI"),
 454                  T_Predefined     => new String'("Predefined"),
 455                  T_Internal       => new String'("Internal"),
 456                  T_Is_Generic     => new String'("Is_Generic"),
 457                  T_Procedure      => new String'("procedure"),
 458                  T_Function       => new String'("function"),
 459                  T_Package        => new String'("package"),
 460                  T_Subprogram     => new String'("subprogram"),
 461                  T_Spec           => new String'("spec"),
 462                  T_Body           => new String'("body"));
 463
 464       procedure Output_Name  (N : Name_Id);
 465       --  Remove any encoding info (%b and %s) and output N
 466
 467       procedure Output_Afile (A : File_Name_Type);
 468       procedure Output_Ofile (O : File_Name_Type);
 469       procedure Output_Sfile (S : File_Name_Type);
 470       --  Output various names. Check that the name is different from no name.
 471       --  Otherwise, skip the output.
 472
 473       procedure Output_Token (T : Token_Type);
 474       --  Output token using specific format. That is several indentations and:
 475       --
 476       --  T_No_ALI  .. T_With : <token> & " =>" & NL
 477       --  T_Source  .. T_Kind : <token> & " => "
 478       --  T_Flags             : <token> & " =>"
 479       --  T_Preelab .. T_Body : " " & <token>
 480
 481       procedure Output_Sdep  (S : Sdep_Id);
 482       procedure Output_Unit  (U : Unit_Id);
 483       procedure Output_With  (W : With_Id);
 484       --  Output this entry as a global section (like ALIs)
 485
 486       ------------------
 487       -- Output_Afile --
 488       ------------------
 489
 490       procedure Output_Afile (A : File_Name_Type) is
 491       begin
 492          if A /= No_File then
 493             Output_Token (T_Afile);
 494             Write_Name (A);
 495             Write_Eol;
 496          end if;
 497       end Output_Afile;
 498
 499       ----------------
 500       -- Output_ALI --
 501       ----------------
 502
 503       procedure Output_ALI (A : ALI_Id) is
 504       begin
 505          Output_Token (T_ALI);
 506          N_Indents := N_Indents + 1;
 507
 508          Output_Afile (ALIs.Table (A).Afile);
 509          Output_Ofile (ALIs.Table (A).Ofile_Full_Name);
 510          Output_Sfile (ALIs.Table (A).Sfile);
 511
 512          --  Output Main
 513
 514          if ALIs.Table (A).Main_Program /= None then
 515             Output_Token (T_Main);
 516
 517             if ALIs.Table (A).Main_Program = Proc then
 518                Output_Token (T_Procedure);
 519             else
 520                Output_Token (T_Function);
 521             end if;
 522
 523             Write_Eol;
 524          end if;
 525
 526          --  Output Units
 527
 528          for U in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop
 529             Output_Unit (U);
 530          end loop;
 531
 532          --  Output Sdeps
 533
 534          for S in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop
 535             Output_Sdep (S);
 536          end loop;
 537
 538          N_Indents := N_Indents - 1;
 539       end Output_ALI;
 540
 541       -------------------
 542       -- Output_No_ALI --
 543       -------------------
 544
 545       procedure Output_No_ALI (Afile : File_Name_Type) is
 546       begin
 547          Output_Token (T_No_ALI);
 548          N_Indents := N_Indents + 1;
 549          Output_Afile (Afile);
 550          N_Indents := N_Indents - 1;
 551       end Output_No_ALI;
 552
 553       -----------------
 554       -- Output_Name --
 555       -----------------
 556
 557       procedure Output_Name (N : Name_Id) is
 558       begin
 559          --  Remove any encoding info (%s or %b)
 560
 561          Get_Name_String (N);
 562
 563          if Name_Len > 2
 564            and then Name_Buffer (Name_Len - 1) = '%'
 565          then
 566             Name_Len := Name_Len - 2;
 567          end if;
 568
 569          Output_Token (T_Name);
 570          Write_Str (Name_Buffer (1 .. Name_Len));
 571          Write_Eol;
 572       end Output_Name;
 573
 574       ------------------
 575       -- Output_Ofile --
 576       ------------------
 577
 578       procedure Output_Ofile (O : File_Name_Type) is
 579       begin
 580          if O /= No_File then
 581             Output_Token (T_Ofile);
 582             Write_Name (O);
 583             Write_Eol;
 584          end if;
 585       end Output_Ofile;
 586
 587       -----------------
 588       -- Output_Sdep --
 589       -----------------
 590
 591       procedure Output_Sdep (S : Sdep_Id) is
 592       begin
 593          Output_Token (T_Source);
 594          Write_Name (Sdep.Table (S).Sfile);
 595          Write_Eol;
 596       end Output_Sdep;
 597
 598       ------------------
 599       -- Output_Sfile --
 600       ------------------
 601
 602       procedure Output_Sfile (S : File_Name_Type) is
 603          FS : File_Name_Type := S;
 604
 605       begin
 606          if FS /= No_File then
 607
 608             --  We want to output the full source name
 609
 610             FS := Full_Source_Name (FS);
 611
 612             --  There is no full source name. This occurs for instance when a
 613             --  withed unit has a spec file but no body file. This situation is
 614             --  not a problem for GNATDIST since the unit may be located on a
 615             --  partition we do not want to build. However, we need to locate
 616             --  the spec file and to find its full source name. Replace the
 617             --  body file name with the spec file name used to compile the
 618             --  current unit when possible.
 619
 620             if FS = No_File then
 621                Get_Name_String (S);
 622
 623                if Name_Len > 4
 624                  and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb"
 625                then
 626                   Name_Buffer (Name_Len) := 's';
 627                   FS := Full_Source_Name (Name_Find);
 628                end if;
 629             end if;
 630          end if;
 631
 632          if FS /= No_File then
 633             Output_Token (T_Sfile);
 634             Write_Name (FS);
 635             Write_Eol;
 636          end if;
 637       end Output_Sfile;
 638
 639       ------------------
 640       -- Output_Token --
 641       ------------------
 642
 643       procedure Output_Token (T : Token_Type) is
 644       begin
 645          if T in T_No_ALI .. T_Flags then
 646             for J in 1 .. N_Indents loop
 647                Write_Str ("   ");
 648             end loop;
 649
 650             Write_Str (Image (T).all);
 651
 652             for J in Image (T)'Length .. 12 loop
 653                Write_Char (' ');
 654             end loop;
 655
 656             Write_Str ("=>");
 657
 658             if T in T_No_ALI .. T_With then
 659                Write_Eol;
 660             elsif T in T_Source .. T_Name then
 661                Write_Char (' ');
 662             end if;
 663
 664          elsif T in T_Preelaborated .. T_Body then
 665             if T in T_Preelaborated .. T_Is_Generic then
 666                if N_Flags = 0 then
 667                   Output_Token (T_Flags);
 668                end if;
 669
 670                N_Flags := N_Flags + 1;
 671             end if;
 672
 673             Write_Char (' ');
 674             Write_Str  (Image (T).all);
 675
 676          else
 677             Write_Str  (Image (T).all);
 678          end if;
 679       end Output_Token;
 680
 681       -----------------
 682       -- Output_Unit --
 683       -----------------
 684
 685       procedure Output_Unit (U : Unit_Id) is
 686       begin
 687          Output_Token (T_Unit);
 688          N_Indents := N_Indents + 1;
 689
 690          --  Output Name
 691
 692          Output_Name (Name_Id (Units.Table (U).Uname));
 693
 694          --  Output Kind
 695
 696          Output_Token (T_Kind);
 697
 698          if Units.Table (U).Unit_Kind = 'p' then
 699             Output_Token (T_Package);
 700          else
 701             Output_Token (T_Subprogram);
 702          end if;
 703
 704          if Name_Buffer (Name_Len) = 's' then
 705             Output_Token (T_Spec);
 706          else
 707             Output_Token (T_Body);
 708          end if;
 709
 710          Write_Eol;
 711
 712          --  Output source file name
 713
 714          Output_Sfile (Units.Table (U).Sfile);
 715
 716          --  Output Flags
 717
 718          N_Flags := 0;
 719
 720          if Units.Table (U).Preelab then
 721             Output_Token (T_Preelaborated);
 722          end if;
 723
 724          if Units.Table (U).Pure then
 725             Output_Token (T_Pure);
 726          end if;
 727
 728          if Units.Table (U).Has_RACW then
 729             Output_Token (T_Has_RACW);
 730          end if;
 731
 732          if Units.Table (U).Remote_Types then
 733             Output_Token (T_Remote_Types);
 734          end if;
 735
 736          if Units.Table (U).Shared_Passive then
 737             Output_Token (T_Shared_Passive);
 738          end if;
 739
 740          if Units.Table (U).RCI then
 741             Output_Token (T_RCI);
 742          end if;
 743
 744          if Units.Table (U).Predefined then
 745             Output_Token (T_Predefined);
 746          end if;
 747
 748          if Units.Table (U).Internal then
 749             Output_Token (T_Internal);
 750          end if;
 751
 752          if Units.Table (U).Is_Generic then
 753             Output_Token (T_Is_Generic);
 754          end if;
 755
 756          if N_Flags > 0 then
 757             Write_Eol;
 758          end if;
 759
 760          --  Output Withs
 761
 762          for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
 763             Output_With (W);
 764          end loop;
 765
 766          N_Indents := N_Indents - 1;
 767       end Output_Unit;
 768
 769       -----------------
 770       -- Output_With --
 771       -----------------
 772
 773       procedure Output_With (W : With_Id) is
 774       begin
 775          Output_Token (T_With);
 776          N_Indents := N_Indents + 1;
 777
 778          Output_Name (Name_Id (Withs.Table (W).Uname));
 779
 780          --  Output Kind
 781
 782          Output_Token (T_Kind);
 783
 784          if Name_Buffer (Name_Len) = 's' then
 785             Output_Token (T_Spec);
 786          else
 787             Output_Token (T_Body);
 788          end if;
 789
 790          Write_Eol;
 791
 792          Output_Afile (Withs.Table (W).Afile);
 793          Output_Sfile (Withs.Table (W).Sfile);
 794
 795          N_Indents := N_Indents - 1;
 796       end Output_With;
 797
 798    end GNATDIST;
 799
 800    -----------
 801    -- Image --
 802    -----------
 803
 804    function Image (Restriction : Restriction_Id) return String is
 805       Result : String := Restriction'Img;
 806       Skip   : Boolean := True;
 807
 808    begin
 809       for J in Result'Range loop
 810          if Skip then
 811             Skip := False;
 812             Result (J) := To_Upper (Result (J));
 813
 814          elsif Result (J) = '_' then
 815             Skip := True;
 816
 817          else
 818             Result (J) := To_Lower (Result (J));
 819          end if;
 820       end loop;
 821
 822       return Result;
 823    end Image;
 824
 825    --------------------------------
 826    -- Output_License_Information --
 827    --------------------------------
 828
 829    procedure Output_License_Information is
 830       Params_File_Name : constant String := "gnatlic.adl";
 831       --  Name of license file
 832
 833       Lo   : constant Source_Ptr := 1;
 834       Hi   : Source_Ptr;
 835       Text : Source_Buffer_Ptr;
 836
 837    begin
 838       Name_Len := 0;
 839       Add_Str_To_Name_Buffer (Params_File_Name);
 840       Read_Source_File (Name_Find, Lo, Hi, Text);
 841
 842       if Text /= null then
 843
 844          --  Omit last character (end-of-file marker) in output
 845
 846          Write_Str (String (Text (Lo .. Hi - 1)));
 847          Write_Eol;
 848
 849          --  The following condition is determined at compile time: disable
 850          --  "condition is always true/false" warning.
 851
 852          pragma Warnings (Off);
 853       elsif Build_Type /= GPL and then Build_Type /= FSF then
 854          pragma Warnings (On);
 855
 856          Write_Str ("License file missing, please contact AdaCore.");
 857          Write_Eol;
 858
 859       else
 860          Write_Str ("Please refer to file COPYING in your distribution"
 861                   & " for license terms.");
 862          Write_Eol;
 863
 864       end if;
 865
 866       Exit_Program (E_Success);
 867    end Output_License_Information;
 868
 869    -------------------
 870    -- Output_Object --
 871    -------------------
 872
 873    procedure Output_Object (O : File_Name_Type) is
 874       Object_Name : String_Access;
 875
 876    begin
 877       if Print_Object then
 878          if O /= No_File then
 879             Get_Name_String (O);
 880             Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len));
 881          else
 882             Object_Name := No_Obj'Unchecked_Access;
 883          end if;
 884
 885          Write_Str (Object_Name.all);
 886
 887          if Print_Source or else Print_Unit then
 888             if Too_Long then
 889                Write_Eol;
 890                Write_Str ("   ");
 891             else
 892                Write_Str (Spaces
 893                 (Object_Start + Object_Name'Length .. Object_End));
 894             end if;
 895          end if;
 896       end if;
 897    end Output_Object;
 898
 899    -------------------
 900    -- Output_Source --
 901    -------------------
 902
 903    procedure Output_Source (Sdep_I : Sdep_Id) is
 904       Stamp       : Time_Stamp_Type;
 905       Checksum    : Word;
 906       FS          : File_Name_Type;
 907       Status      : File_Status;
 908       Object_Name : String_Access;
 909
 910    begin
 911       if Sdep_I = No_Sdep_Id then
 912          return;
 913       end if;
 914
 915       Stamp    := Sdep.Table (Sdep_I).Stamp;
 916       Checksum := Sdep.Table (Sdep_I).Checksum;
 917       FS       := Sdep.Table (Sdep_I).Sfile;
 918
 919       if Print_Source then
 920          Find_Status (FS, Stamp, Checksum, Status);
 921          Get_Name_String (FS);
 922
 923          Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len));
 924
 925          if Verbose_Mode then
 926             Write_Str ("  Source => ");
 927             Write_Str (Object_Name.all);
 928
 929             if not Too_Long then
 930                Write_Str
 931                  (Spaces (Source_Start + Object_Name'Length .. Source_End));
 932             end if;
 933
 934             Output_Status (Status, Verbose => True);
 935             Write_Eol;
 936             Write_Str ("   ");
 937
 938          else
 939             if not Selective_Output then
 940                Output_Status (Status, Verbose => False);
 941             end if;
 942
 943             Write_Str (Object_Name.all);
 944          end if;
 945       end if;
 946    end Output_Source;
 947
 948    -------------------
 949    -- Output_Status --
 950    -------------------
 951
 952    procedure Output_Status (FS : File_Status; Verbose : Boolean) is
 953    begin
 954       if Verbose then
 955          case FS is
 956             when OK =>
 957                Write_Str (" unchanged");
 958
 959             when Checksum_OK =>
 960                Write_Str (" slightly modified");
 961
 962             when Not_Found =>
 963                Write_Str (" file not found");
 964
 965             when Not_Same =>
 966                Write_Str (" modified");
 967
 968             when Not_First_On_PATH =>
 969                Write_Str (" unchanged version not first on PATH");
 970          end case;
 971
 972       else
 973          case FS is
 974             when OK =>
 975                Write_Str ("  OK ");
 976
 977             when Checksum_OK =>
 978                Write_Str (" MOK ");
 979
 980             when Not_Found =>
 981                Write_Str (" ??? ");
 982
 983             when Not_Same =>
 984                Write_Str (" DIF ");
 985
 986             when Not_First_On_PATH =>
 987                Write_Str (" HID ");
 988          end case;
 989       end if;
 990    end Output_Status;
 991
 992    -----------------
 993    -- Output_Unit --
 994    -----------------
 995
 996    procedure Output_Unit (ALI : ALI_Id; U_Id : Unit_Id) is
 997       Kind : Character;
 998       U    : Unit_Record renames Units.Table (U_Id);
 999
1000    begin
1001       if Print_Unit then
1002          Get_Name_String (U.Uname);
1003          Kind := Name_Buffer (Name_Len);
1004          Name_Len := Name_Len - 2;
1005
1006          if not Verbose_Mode then
1007             Write_Str (Name_Buffer (1 .. Name_Len));
1008
1009          else
1010             Write_Str ("Unit => ");
1011             Write_Eol;
1012             Write_Str ("     Name   => ");
1013             Write_Str (Name_Buffer (1 .. Name_Len));
1014             Write_Eol;
1015             Write_Str ("     Kind   => ");
1016
1017             if Units.Table (U_Id).Unit_Kind = 'p' then
1018                Write_Str ("package ");
1019             else
1020                Write_Str ("subprogram ");
1021             end if;
1022
1023             if Kind = 's' then
1024                Write_Str ("spec");
1025             else
1026                Write_Str ("body");
1027             end if;
1028          end if;
1029
1030          if Verbose_Mode then
1031             if U.Preelab             or else
1032                U.No_Elab             or else
1033                U.Pure                or else
1034                U.Dynamic_Elab        or else
1035                U.Has_RACW            or else
1036                U.Remote_Types        or else
1037                U.Shared_Passive      or else
1038                U.RCI                 or else
1039                U.Predefined          or else
1040                U.Internal            or else
1041                U.Is_Generic          or else
1042                U.Init_Scalars        or else
1043                U.SAL_Interface       or else
1044                U.Body_Needed_For_SAL or else
1045                U.Elaborate_Body
1046             then
1047                Write_Eol;
1048                Write_Str ("     Flags  =>");
1049
1050                if U.Preelab then
1051                   Write_Str (" Preelaborable");
1052                end if;
1053
1054                if U.No_Elab then
1055                   Write_Str (" No_Elab_Code");
1056                end if;
1057
1058                if U.Pure then
1059                   Write_Str (" Pure");
1060                end if;
1061
1062                if U.Dynamic_Elab then
1063                   Write_Str (" Dynamic_Elab");
1064                end if;
1065
1066                if U.Has_RACW then
1067                   Write_Str (" Has_RACW");
1068                end if;
1069
1070                if U.Remote_Types then
1071                   Write_Str (" Remote_Types");
1072                end if;
1073
1074                if U.Shared_Passive then
1075                   Write_Str (" Shared_Passive");
1076                end if;
1077
1078                if U.RCI then
1079                   Write_Str (" RCI");
1080                end if;
1081
1082                if U.Predefined then
1083                   Write_Str (" Predefined");
1084                end if;
1085
1086                if U.Internal then
1087                   Write_Str (" Internal");
1088                end if;
1089
1090                if U.Is_Generic then
1091                   Write_Str (" Is_Generic");
1092                end if;
1093
1094                if U.Init_Scalars then
1095                   Write_Str (" Init_Scalars");
1096                end if;
1097
1098                if U.SAL_Interface then
1099                   Write_Str (" SAL_Interface");
1100                end if;
1101
1102                if U.Body_Needed_For_SAL then
1103                   Write_Str (" Body_Needed_For_SAL");
1104                end if;
1105
1106                if U.Elaborate_Body then
1107                   Write_Str (" Elaborate Body");
1108                end if;
1109
1110                if U.Remote_Types then
1111                   Write_Str (" Remote_Types");
1112                end if;
1113
1114                if U.Shared_Passive then
1115                   Write_Str (" Shared_Passive");
1116                end if;
1117
1118                if U.Predefined then
1119                   Write_Str (" Predefined");
1120                end if;
1121             end if;
1122
1123             declare
1124                Restrictions : constant Restrictions_Info :=
1125                                 ALIs.Table (ALI).Restrictions;
1126
1127             begin
1128                --  If the source was compiled with pragmas Restrictions,
1129                --  Display these restrictions.
1130
1131                if Restrictions.Set /= (All_Restrictions => False) then
1132                   Write_Eol;
1133                   Write_Str ("     pragma Restrictions  =>");
1134
1135                   --  For boolean restrictions, just display the name of the
1136                   --  restriction; for valued restrictions, also display the
1137                   --  restriction value.
1138
1139                   for Restriction in All_Restrictions loop
1140                      if Restrictions.Set (Restriction) then
1141                         Write_Eol;
1142                         Write_Str ("       ");
1143                         Write_Str (Image (Restriction));
1144
1145                         if Restriction in All_Parameter_Restrictions then
1146                            Write_Str (" =>");
1147                            Write_Str (Restrictions.Value (Restriction)'Img);
1148                         end if;
1149                      end if;
1150                   end loop;
1151                end if;
1152
1153                --  If the unit violates some Restrictions, display the list of
1154                --  these restrictions.
1155
1156                if Restrictions.Violated /= (All_Restrictions => False) then
1157                   Write_Eol;
1158                   Write_Str ("     Restrictions violated =>");
1159
1160                   --  For boolean restrictions, just display the name of the
1161                   --  restriction. For valued restrictions, also display the
1162                   --  restriction value.
1163
1164                   for Restriction in All_Restrictions loop
1165                      if Restrictions.Violated (Restriction) then
1166                         Write_Eol;
1167                         Write_Str ("       ");
1168                         Write_Str (Image (Restriction));
1169
1170                         if Restriction in All_Parameter_Restrictions then
1171                            if Restrictions.Count (Restriction) > 0 then
1172                               Write_Str (" =>");
1173
1174                               if Restrictions.Unknown (Restriction) then
1175                                  Write_Str (" at least");
1176                               end if;
1177
1178                               Write_Str (Restrictions.Count (Restriction)'Img);
1179                            end if;
1180                         end if;
1181                      end if;
1182                   end loop;
1183                end if;
1184             end;
1185          end if;
1186
1187          if Print_Source then
1188             if Too_Long then
1189                Write_Eol;
1190                Write_Str ("   ");
1191             else
1192                Write_Str (Spaces (Unit_Start + Name_Len + 1 .. Unit_End));
1193             end if;
1194          end if;
1195       end if;
1196    end Output_Unit;
1197
1198    -----------------
1199    -- Reset_Print --
1200    -----------------
1201
1202    procedure Reset_Print is
1203    begin
1204       if not Selective_Output then
1205          Selective_Output := True;
1206          Print_Source := False;
1207          Print_Object := False;
1208          Print_Unit   := False;
1209       end if;
1210    end Reset_Print;
1211
1212    -------------------
1213    -- Scan_Ls_Arg --
1214    -------------------
1215
1216    procedure Scan_Ls_Arg (Argv : String) is
1217       FD  : File_Descriptor;
1218       Len : Integer;
1219
1220    begin
1221       pragma Assert (Argv'First = 1);
1222
1223       if Argv'Length = 0 then
1224          return;
1225       end if;
1226
1227       if Argv (1) = '-' then
1228          if Argv'Length = 1 then
1229             Fail ("switch character cannot be followed by a blank");
1230
1231          --  Processing for -I-
1232
1233          elsif Argv (2 .. Argv'Last) = "I-" then
1234             Opt.Look_In_Primary_Dir := False;
1235
1236          --  Forbid -?- or -??- where ? is any character
1237
1238          elsif (Argv'Length = 3 and then Argv (3) = '-')
1239            or else (Argv'Length = 4 and then Argv (4) = '-')
1240          then
1241             Fail ("Trailing ""-"" at the end of " & Argv & " forbidden.");
1242
1243          --  Processing for -Idir
1244
1245          elsif Argv (2) = 'I' then
1246             Add_Source_Dir (Argv (3 .. Argv'Last));
1247             Add_Lib_Dir (Argv (3 .. Argv'Last));
1248
1249          --  Processing for -aIdir (to gcc this is like a -I switch)
1250
1251          elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then
1252             Add_Source_Dir (Argv (4 .. Argv'Last));
1253
1254          --  Processing for -aOdir
1255
1256          elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aO" then
1257             Add_Lib_Dir (Argv (4 .. Argv'Last));
1258
1259          --  Processing for -aLdir (to gnatbind this is like a -aO switch)
1260
1261          elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then
1262             Add_Lib_Dir (Argv (4 .. Argv'Last));
1263
1264          --  Processing for -nostdinc
1265
1266          elsif Argv (2 .. Argv'Last) = "nostdinc" then
1267             Opt.No_Stdinc := True;
1268
1269          --  Processing for one character switches
1270
1271          elsif Argv'Length = 2 then
1272             case Argv (2) is
1273                when 'a' => Also_Predef               := True;
1274                when 'h' => Print_Usage               := True;
1275                when 'u' => Reset_Print; Print_Unit   := True;
1276                when 's' => Reset_Print; Print_Source := True;
1277                when 'o' => Reset_Print; Print_Object := True;
1278                when 'v' => Verbose_Mode              := True;
1279                when 'd' => Dependable                := True;
1280                when 'l' => License                   := True;
1281                when 'V' => Very_Verbose_Mode         := True;
1282
1283                when others => null;
1284             end case;
1285
1286          --  Processing for -files=file
1287
1288          elsif Argv'Length > 7 and then Argv (1 .. 7) = "-files=" then
1289             FD := Open_Read (Argv (8 .. Argv'Last), GNAT.OS_Lib.Text);
1290
1291             if FD = Invalid_FD then
1292                Osint.Fail ("could not find text file """ &
1293                            Argv (8 .. Argv'Last) & '"');
1294             end if;
1295
1296             Len := Integer (File_Length (FD));
1297
1298             declare
1299                Buffer : String (1 .. Len + 1);
1300                Index  : Positive := 1;
1301                Last   : Positive;
1302
1303             begin
1304                --  Read the file
1305
1306                Len := Read (FD, Buffer (1)'Address, Len);
1307                Buffer (Buffer'Last) := ASCII.NUL;
1308                Close (FD);
1309
1310                --  Scan the file line by line
1311
1312                while Index < Buffer'Last loop
1313
1314                   --  Find the end of line
1315
1316                   Last := Index;
1317                   while Last <= Buffer'Last
1318                     and then Buffer (Last) /= ASCII.LF
1319                     and then Buffer (Last) /= ASCII.CR
1320                   loop
1321                      Last := Last + 1;
1322                   end loop;
1323
1324                   --  Ignore empty lines
1325
1326                   if Last > Index then
1327                      Add_File (Buffer (Index .. Last - 1));
1328                   end if;
1329
1330                   --  Find the beginning of the next line
1331
1332                   Index := Last;
1333                   while Buffer (Index) = ASCII.CR or else
1334                         Buffer (Index) = ASCII.LF
1335                   loop
1336                      Index := Index + 1;
1337                   end loop;
1338                end loop;
1339             end;
1340
1341          --  Processing for --RTS=path
1342
1343          elsif Argv'Length >= 5 and then Argv (1 .. 5) = "--RTS" then
1344             if Argv'Length <= 6 or else Argv (6) /= '='then
1345                Osint.Fail ("missing path for --RTS");
1346
1347             else
1348                --  Check that it is the first time we see this switch or, if
1349                --  it is not the first time, the same path is specified.
1350
1351                if RTS_Specified = null then
1352                   RTS_Specified := new String'(Argv (7 .. Argv'Last));
1353
1354                elsif RTS_Specified.all /= Argv (7 .. Argv'Last) then
1355                   Osint.Fail ("--RTS cannot be specified multiple times");
1356                end if;
1357
1358                --  Valid --RTS switch
1359
1360                Opt.No_Stdinc := True;
1361                Opt.RTS_Switch := True;
1362
1363                declare
1364                   Src_Path_Name : constant String_Ptr :=
1365                                     String_Ptr
1366                                       (Get_RTS_Search_Dir
1367                                         (Argv (7 .. Argv'Last), Include));
1368                   Lib_Path_Name : constant String_Ptr :=
1369                                     String_Ptr
1370                                       (Get_RTS_Search_Dir
1371                                         (Argv (7 .. Argv'Last), Objects));
1372
1373                begin
1374                   if Src_Path_Name /= null
1375                     and then Lib_Path_Name /= null
1376                   then
1377                      Add_Search_Dirs (Src_Path_Name, Include);
1378                      Add_Search_Dirs (Lib_Path_Name, Objects);
1379
1380                   elsif Src_Path_Name = null
1381                     and then Lib_Path_Name = null
1382                   then
1383                      Osint.Fail ("RTS path not valid: missing " &
1384                                  "adainclude and adalib directories");
1385
1386                   elsif Src_Path_Name = null then
1387                      Osint.Fail ("RTS path not valid: missing " &
1388                                  "adainclude directory");
1389
1390                   elsif Lib_Path_Name = null then
1391                      Osint.Fail ("RTS path not valid: missing " &
1392                                  "adalib directory");
1393                   end if;
1394                end;
1395             end if;
1396          end if;
1397
1398       --  If not a switch, it must be a file name
1399
1400       else
1401          Add_File (Argv);
1402       end if;
1403    end Scan_Ls_Arg;
1404
1405    -----------
1406    -- Usage --
1407    -----------
1408
1409    procedure Usage is
1410    begin
1411       --  Usage line
1412
1413       Write_Str ("Usage: ");
1414       Osint.Write_Program_Name;
1415       Write_Str ("  switches  [list of object files]");
1416       Write_Eol;
1417       Write_Eol;
1418
1419       --  GNATLS switches
1420
1421       Write_Str ("switches:");
1422       Write_Eol;
1423
1424       --  Line for -a
1425
1426       Write_Str ("  -a         also output relevant predefined units");
1427       Write_Eol;
1428
1429       --  Line for -u
1430
1431       Write_Str ("  -u         output only relevant unit names");
1432       Write_Eol;
1433
1434       --  Line for -h
1435
1436       Write_Str ("  -h         output this help message");
1437       Write_Eol;
1438
1439       --  Line for -s
1440
1441       Write_Str ("  -s         output only relevant source names");
1442       Write_Eol;
1443
1444       --  Line for -o
1445
1446       Write_Str ("  -o         output only relevant object names");
1447       Write_Eol;
1448
1449       --  Line for -d
1450
1451       Write_Str ("  -d         output sources on which specified units " &
1452                                "depend");
1453       Write_Eol;
1454
1455       --  Line for -l
1456
1457       Write_Str ("  -l         output license information");
1458       Write_Eol;
1459
1460       --  Line for -v
1461
1462       Write_Str ("  -v         verbose output, full path and unit " &
1463                                "information");
1464       Write_Eol;
1465       Write_Eol;
1466
1467       --  Line for -files=
1468
1469       Write_Str ("  -files=fil files are listed in text file 'fil'");
1470       Write_Eol;
1471
1472       --  Line for -aI switch
1473
1474       Write_Str ("  -aIdir     specify source files search path");
1475       Write_Eol;
1476
1477       --  Line for -aO switch
1478
1479       Write_Str ("  -aOdir     specify object files search path");
1480       Write_Eol;
1481
1482       --  Line for -I switch
1483
1484       Write_Str ("  -Idir      like -aIdir -aOdir");
1485       Write_Eol;
1486
1487       --  Line for -I- switch
1488
1489       Write_Str ("  -I-        do not look for sources & object files");
1490       Write_Str (" in the default directory");
1491       Write_Eol;
1492
1493       --  Line for -nostdinc
1494
1495       Write_Str ("  -nostdinc  do not look for source files");
1496       Write_Str (" in the system default directory");
1497       Write_Eol;
1498
1499       --  Line for --RTS
1500
1501       Write_Str ("  --RTS=dir  specify the default source and object search"
1502                  & " path");
1503       Write_Eol;
1504
1505       --  File Status explanation
1506
1507       Write_Eol;
1508       Write_Str (" file status can be:");
1509       Write_Eol;
1510
1511       for ST in File_Status loop
1512          Write_Str ("   ");
1513          Output_Status (ST, Verbose => False);
1514          Write_Str (" ==> ");
1515          Output_Status (ST, Verbose => True);
1516          Write_Eol;
1517       end loop;
1518    end Usage;
1519
1520    procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
1521
1522 --  Start of processing for Gnatls
1523
1524 begin
1525    --  Initialize standard packages
1526
1527    Namet.Initialize;
1528    Csets.Initialize;
1529    Snames.Initialize;
1530
1531    --  First check for --version or --help
1532
1533    Check_Version_And_Help ("GNATLS", "1997");
1534
1535    --  Loop to scan out arguments
1536
1537    Next_Arg := 1;
1538    Scan_Args : while Next_Arg < Arg_Count loop
1539       declare
1540          Next_Argv : String (1 .. Len_Arg (Next_Arg));
1541       begin
1542          Fill_Arg (Next_Argv'Address, Next_Arg);
1543          Scan_Ls_Arg (Next_Argv);
1544       end;
1545
1546       Next_Arg := Next_Arg + 1;
1547    end loop Scan_Args;
1548
1549    --  If -l (output license information) is given, it must be the only switch
1550
1551    if License and then Arg_Count /= 2 then
1552       Write_Str ("Can't use -l with another switch");
1553       Write_Eol;
1554       Usage;
1555       Exit_Program (E_Fatal);
1556    end if;
1557
1558    --  Add the source and object directories specified on the command line, if
1559    --  any, to the searched directories.
1560
1561    while First_Source_Dir /= null loop
1562       Add_Src_Search_Dir (First_Source_Dir.Value.all);
1563       First_Source_Dir := First_Source_Dir.Next;
1564    end loop;
1565
1566    while First_Lib_Dir /= null loop
1567       Add_Lib_Search_Dir (First_Lib_Dir.Value.all);
1568       First_Lib_Dir := First_Lib_Dir.Next;
1569    end loop;
1570
1571    --  Finally, add the default directories and obtain target parameters
1572
1573    Osint.Add_Default_Search_Dirs;
1574
1575    if Verbose_Mode then
1576       Write_Eol;
1577       Display_Version ("GNATLS", "1997");
1578       Write_Eol;
1579       Write_Str ("Source Search Path:");
1580       Write_Eol;
1581
1582       for J in 1 .. Nb_Dir_In_Src_Search_Path loop
1583          Write_Str ("   ");
1584
1585          if Dir_In_Src_Search_Path (J)'Length = 0 then
1586             Write_Str ("<Current_Directory>");
1587          else
1588             Write_Str (To_Host_Dir_Spec
1589               (Dir_In_Src_Search_Path (J).all, True).all);
1590          end if;
1591
1592          Write_Eol;
1593       end loop;
1594
1595       Write_Eol;
1596       Write_Eol;
1597       Write_Str ("Object Search Path:");
1598       Write_Eol;
1599
1600       for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
1601          Write_Str ("   ");
1602
1603          if Dir_In_Obj_Search_Path (J)'Length = 0 then
1604             Write_Str ("<Current_Directory>");
1605          else
1606             Write_Str (To_Host_Dir_Spec
1607               (Dir_In_Obj_Search_Path (J).all, True).all);
1608          end if;
1609
1610          Write_Eol;
1611       end loop;
1612
1613       Write_Eol;
1614       Write_Eol;
1615       Write_Str (Project_Search_Path);
1616       Write_Eol;
1617       Write_Str ("   <Current_Directory>");
1618       Write_Eol;
1619
1620       declare
1621          Project_Path : String_Access := Getenv (Gpr_Project_Path);
1622
1623          Lib : constant String :=
1624                  Directory_Separator & "lib" & Directory_Separator;
1625
1626          First : Natural;
1627          Last  : Natural;
1628
1629          Add_Default_Dir : Boolean := True;
1630
1631       begin
1632          --  If there is a project path, display each directory in the path
1633
1634          if Project_Path.all = "" then
1635             Project_Path := Getenv (Ada_Project_Path);
1636          end if;
1637
1638          if Project_Path.all /= "" then
1639             First := Project_Path'First;
1640             loop
1641                while First <= Project_Path'Last
1642                  and then (Project_Path (First) = Path_Separator)
1643                loop
1644                   First := First + 1;
1645                end loop;
1646
1647                exit when First > Project_Path'Last;
1648
1649                Last := First;
1650                while Last < Project_Path'Last
1651                  and then Project_Path (Last + 1) /= Path_Separator
1652                loop
1653                   Last := Last + 1;
1654                end loop;
1655
1656                --  If the directory is No_Default_Project_Dir, set
1657                --  Add_Default_Dir to False.
1658
1659                if Project_Path (First .. Last) = No_Project_Default_Dir then
1660                   Add_Default_Dir := False;
1661
1662                elsif First /= Last or else Project_Path (First) /= '.' then
1663
1664                   --  If the directory is ".", skip it as it is the current
1665                   --  directory and it is already the first directory in the
1666                   --  project path.
1667
1668                   Write_Str ("   ");
1669                   Write_Str
1670                     (To_Host_Dir_Spec
1671                        (Project_Path (First .. Last), True).all);
1672                   Write_Eol;
1673                end if;
1674
1675                First := Last + 1;
1676             end loop;
1677          end if;
1678
1679          --  Add the default dir, except if "-" was one of the "directories"
1680          --  specified in ADA_PROJECT_DIR.
1681
1682          if Add_Default_Dir then
1683             Name_Len := 0;
1684             Add_Str_To_Name_Buffer (Sdefault.Search_Dir_Prefix.all);
1685
1686             --  On Windows, make sure that all directory separators are '\'
1687
1688             if Directory_Separator /= '/' then
1689                for J in 1 .. Name_Len loop
1690                   if Name_Buffer (J) = '/' then
1691                      Name_Buffer (J) := Directory_Separator;
1692                   end if;
1693                end loop;
1694             end if;
1695
1696             --  Find the sequence "/lib/"
1697
1698             while Name_Len >= Lib'Length
1699               and then Name_Buffer (Name_Len - 4 .. Name_Len) /= Lib
1700             loop
1701                Name_Len := Name_Len - 1;
1702             end loop;
1703
1704             --  If the sequence "/lib"/ was found, display the default
1705             --  directory <prefix>/lib/gnat/.
1706
1707             if Name_Len >= 5 then
1708                Name_Buffer (Name_Len + 1 .. Name_Len + 4) := "gnat";
1709                Name_Buffer (Name_Len + 5) := Directory_Separator;
1710                Name_Len := Name_Len + 5;
1711                Write_Str ("   ");
1712                Write_Line
1713                  (To_Host_Dir_Spec (Name_Buffer (1 .. Name_Len), True).all);
1714             end if;
1715          end if;
1716       end;
1717
1718       Write_Eol;
1719    end if;
1720
1721    --  Output usage information when requested
1722
1723    if Print_Usage then
1724       Usage;
1725    end if;
1726
1727    --  Output license information when requested
1728
1729    if License then
1730       Output_License_Information;
1731       Exit_Program (E_Success);
1732    end if;
1733
1734    if not More_Lib_Files then
1735       if not Print_Usage and then not Verbose_Mode then
1736          Usage;
1737       end if;
1738
1739       Exit_Program (E_Fatal);
1740    end if;
1741
1742    Initialize_ALI;
1743    Initialize_ALI_Source;
1744
1745    --  Print out all library for which no ALI files can be located
1746
1747    while More_Lib_Files loop
1748       Main_File := Next_Main_Lib_File;
1749       Ali_File  := Full_Lib_File_Name (Lib_File_Name (Main_File));
1750
1751       if Ali_File = No_File then
1752          if Very_Verbose_Mode then
1753             GNATDIST.Output_No_ALI (Lib_File_Name (Main_File));
1754
1755          else
1756             Write_Str ("Can't find library info for ");
1757             Get_Name_String (Main_File);
1758             Write_Char ('"'); -- "
1759             Write_Str (Name_Buffer (1 .. Name_Len));
1760             Write_Char ('"'); -- "
1761             Write_Eol;
1762          end if;
1763
1764       else
1765          Ali_File := Strip_Directory (Ali_File);
1766
1767          if Get_Name_Table_Info (Ali_File) = 0 then
1768             Text := Read_Library_Info (Ali_File, True);
1769
1770             declare
1771                Discard : ALI_Id;
1772                pragma Unreferenced (Discard);
1773             begin
1774                Discard :=
1775                  Scan_ALI
1776                    (Ali_File,
1777                     Text,
1778                     Ignore_ED     => False,
1779                     Err           => False,
1780                     Ignore_Errors => True);
1781             end;
1782
1783             Free (Text);
1784          end if;
1785       end if;
1786    end loop;
1787
1788    if Very_Verbose_Mode then
1789       for A in ALIs.First .. ALIs.Last loop
1790          GNATDIST.Output_ALI (A);
1791       end loop;
1792
1793       return;
1794    end if;
1795
1796    Find_General_Layout;
1797
1798    for Id in ALIs.First .. ALIs.Last loop
1799       declare
1800          Last_U : Unit_Id;
1801
1802       begin
1803          Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname);
1804
1805          if Also_Predef or else not Is_Internal_Unit then
1806             if ALIs.Table (Id).No_Object then
1807                Output_Object (No_File);
1808             else
1809                Output_Object (ALIs.Table (Id).Ofile_Full_Name);
1810             end if;
1811
1812             --  In verbose mode print all main units in the ALI file, otherwise
1813             --  just print the first one to ease columnwise printout
1814
1815             if Verbose_Mode then
1816                Last_U := ALIs.Table (Id).Last_Unit;
1817             else
1818                Last_U := ALIs.Table (Id).First_Unit;
1819             end if;
1820
1821             for U in ALIs.Table (Id).First_Unit .. Last_U loop
1822                if U /= ALIs.Table (Id).First_Unit
1823                  and then Selective_Output
1824                  and then Print_Unit
1825                then
1826                   Write_Eol;
1827                end if;
1828
1829                Output_Unit (Id, U);
1830
1831                --  Output source now, unless if it will be done as part of
1832                --  outputing dependencies.
1833
1834                if not (Dependable and then Print_Source) then
1835                   Output_Source (Corresponding_Sdep_Entry (Id, U));
1836                end if;
1837             end loop;
1838
1839             --  Print out list of units on which this unit depends (D lines)
1840
1841             if Dependable and then Print_Source then
1842                if Verbose_Mode then
1843                   Write_Str ("depends upon");
1844                   Write_Eol;
1845                   Write_Str ("   ");
1846                else
1847                   Write_Eol;
1848                end if;
1849
1850                for D in
1851                  ALIs.Table (Id).First_Sdep .. ALIs.Table (Id).Last_Sdep
1852                loop
1853                   if Also_Predef
1854                     or else not Is_Internal_File_Name (Sdep.Table (D).Sfile)
1855                   then
1856                      if Verbose_Mode then
1857                         Write_Str ("   ");
1858                         Output_Source (D);
1859
1860                      elsif Too_Long then
1861                         Write_Str ("   ");
1862                         Output_Source (D);
1863                         Write_Eol;
1864
1865                      else
1866                         Write_Str (Spaces (1 .. Source_Start - 2));
1867                         Output_Source (D);
1868                         Write_Eol;
1869                      end if;
1870                   end if;
1871                end loop;
1872             end if;
1873
1874             Write_Eol;
1875          end if;
1876       end;
1877    end loop;
1878
1879    --  All done. Set proper exit status
1880
1881    Namet.Finalize;
1882    Exit_Program (E_Success);
1883 end Gnatls;