gcc/ada/xref_lib.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             X R E F _ L I B                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1998-2002 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Osint;
  28 with Output; use Output;
  29 with Types;  use Types;
  30
  31 with Unchecked_Deallocation;
  32
  33 with Ada.Strings.Fixed; use Ada.Strings.Fixed;
  34 with Ada.Text_IO;       use Ada.Text_IO;
  35
  36 with GNAT.Command_Line; use GNAT.Command_Line;
  37 with GNAT.IO_Aux;       use GNAT.IO_Aux;
  38
  39 package body Xref_Lib is
  40
  41    Type_Position : constant := 50;
  42    --  Column for label identifying type of entity
  43
  44    ---------------------
  45    -- Local Variables --
  46    ---------------------
  47
  48    Pipe : constant Character := '|';
  49    --  First character on xref lines in the .ali file
  50
  51    No_Xref_Information : exception;
  52    --  Exception raised when there is no cross-referencing information in
  53    --  the .ali files
  54
  55    procedure Parse_EOL
  56      (Source                 : access String;
  57       Ptr                    : in out Positive;
  58       Skip_Continuation_Line : Boolean := False);
  59    --  On return Source (Ptr) is the first character of the next line
  60    --  or EOF. Source.all must be terminated by EOF.
  61    --
  62    --  If Skip_Continuation_Line is True, this subprogram skips as many
  63    --  lines as required when the second or more lines starts with '.'
  64    --  (continuation lines in ALI files).
  65
  66    function Current_Xref_File (File : ALI_File) return File_Reference;
  67    --  Return the file matching the last 'X' line we found while parsing
  68    --  the ALI file.
  69
  70    function File_Name (File : ALI_File; Num : Positive) return File_Reference;
  71    --  Returns the dependency file name number Num
  72
  73    function Get_Full_Type (Decl : Declaration_Reference) return String;
  74    --  Returns the full type corresponding to a type letter as found in
  75    --  the .ali files.
  76
  77    procedure Open
  78      (Name         : in  String;
  79       File         : out ALI_File;
  80       Dependencies : in  Boolean := False);
  81    --  Open a new ALI file. If Dependencies is True, the insert every library
  82    --  file 'with'ed in the files database (used for gnatxref)
  83
  84    procedure Parse_Identifier_Info
  85      (Pattern       : Search_Pattern;
  86       File          : in out ALI_File;
  87       Local_Symbols : Boolean;
  88       Der_Info      : Boolean := False;
  89       Type_Tree     : Boolean := False;
  90       Wide_Search   : Boolean := True;
  91       Labels_As_Ref : Boolean := True);
  92    --  Output the file and the line where the identifier was referenced,
  93    --  If Local_Symbols is False then only the publicly visible symbols
  94    --  will be processed.
  95    --
  96    --  If Labels_As_Ref is true, then the references to the entities after
  97    --  the end statements ("end Foo") will be counted as actual references.
  98    --  The entity will never be reported as unreferenced by gnatxref -u
  99
 100    procedure Parse_Token
 101      (Source    : access String;
 102       Ptr       : in out Positive;
 103       Token_Ptr : out Positive);
 104    --  Skips any separators and stores the start of the token in Token_Ptr.
 105    --  Then stores the position of the next separator in Ptr. On return
 106    --  Source (Token_Ptr .. Ptr - 1) is the token. Separators are space
 107    --  and ASCII.HT. Parse_Token will never skip to the next line.
 108
 109    procedure Parse_Number
 110      (Source : access String;
 111       Ptr    : in out Positive;
 112       Number : out Natural);
 113    --  Skips any separators and parses Source upto the first character that
 114    --  is not a decimal digit. Returns value of parsed digits or 0 if none.
 115
 116    procedure Parse_X_Filename (File : in out ALI_File);
 117    --  Reads and processes "X..." lines in the ALI file
 118    --  and updates the File.X_File information.
 119
 120    procedure Skip_To_First_X_Line
 121      (File    : in out ALI_File;
 122       D_Lines : Boolean;
 123       W_Lines : Boolean);
 124    --  Skip the lines in the ALI file until the first cross-reference line
 125    --  (^X...) is found. Search is started from the beginning of the file.
 126    --  If not such line is found, No_Xref_Information is raised.
 127    --  If W_Lines is false, then the lines "^W" are not parsed.
 128    --  If D_Lines is false, then the lines "^D" are not parsed.
 129
 130    ----------------
 131    -- Add_Entity --
 132    ----------------
 133
 134    procedure Add_Entity
 135      (Pattern : in out Search_Pattern;
 136       Entity  : String;
 137       Glob    : Boolean := False)
 138    is
 139       File_Start  : Natural;
 140       Line_Start  : Natural;
 141       Col_Start   : Natural;
 142       Line_Num    : Natural := 0;
 143       Col_Num     : Natural := 0;
 144       File_Ref    : File_Reference := Empty_File;
 145       Has_Pattern : Boolean := False;
 146
 147    begin
 148       --  Find the end of the first item in Entity (pattern or file?)
 149       --  If there is no ':', we only have a pattern
 150
 151       File_Start := Index (Entity, ":");
 152
 153       --  If the regular expression is invalid, just consider it as a string
 154
 155       if File_Start = 0 then
 156          begin
 157             Pattern.Entity := Compile (Entity, Glob, False);
 158             Pattern.Initialized := True;
 159
 160          exception
 161             when Error_In_Regexp =>
 162
 163                --  The basic idea is to insert a \ before every character
 164
 165                declare
 166                   Tmp_Regexp : String (1 .. 2 * Entity'Length);
 167                   Index      : Positive := 1;
 168
 169                begin
 170                   for J in Entity'Range loop
 171                      Tmp_Regexp (Index) := '\';
 172                      Tmp_Regexp (Index + 1) := Entity (J);
 173                      Index := Index + 2;
 174                   end loop;
 175
 176                   Pattern.Entity := Compile (Tmp_Regexp, True, False);
 177                   Pattern.Initialized := True;
 178                end;
 179          end;
 180
 181          Set_Default_Match (True);
 182          return;
 183       end if;
 184
 185       --  If there is a dot in the pattern, then it is a file name
 186
 187       if (Glob and then
 188            Index (Entity (Entity'First .. File_Start - 1), ".") /= 0)
 189              or else
 190               (not Glob
 191                  and then Index (Entity (Entity'First .. File_Start - 1),
 192                                    "\.") /= 0)
 193       then
 194          Pattern.Entity      := Compile (".*", False);
 195          Pattern.Initialized := True;
 196          File_Start          := Entity'First;
 197
 198       else
 199          --  If the regular expression is invalid, just consider it as a string
 200
 201          begin
 202             Pattern.Entity :=
 203               Compile (Entity (Entity'First .. File_Start - 1), Glob, False);
 204             Pattern.Initialized := True;
 205
 206          exception
 207             when Error_In_Regexp =>
 208
 209                --  The basic idea is to insert a \ before every character
 210
 211                declare
 212                   Tmp_Regexp : String (1 .. 2 * (File_Start - Entity'First));
 213                   Index      : Positive := 1;
 214
 215                begin
 216                   for J in Entity'First .. File_Start - 1 loop
 217                      Tmp_Regexp (Index) := '\';
 218                      Tmp_Regexp (Index + 1) := Entity (J);
 219                      Index := Index + 2;
 220                   end loop;
 221
 222                   Pattern.Entity := Compile (Tmp_Regexp, True, False);
 223                   Pattern.Initialized := True;
 224                end;
 225          end;
 226
 227          File_Start  := File_Start + 1;
 228          Has_Pattern := True;
 229       end if;
 230
 231       --  Parse the file name
 232
 233       Line_Start := Index (Entity (File_Start .. Entity'Last), ":");
 234
 235       --  Check if it was a disk:\directory item (for NT and OS/2)
 236
 237       if File_Start = Line_Start - 1
 238         and then Line_Start < Entity'Last
 239         and then Entity (Line_Start + 1) = '\'
 240       then
 241          Line_Start := Index (Entity (Line_Start + 1 .. Entity'Last), ":");
 242       end if;
 243
 244       if Line_Start = 0 then
 245          Line_Start := Entity'Length + 1;
 246
 247       elsif Line_Start /= Entity'Last then
 248          Col_Start := Index (Entity (Line_Start + 1 .. Entity'Last), ":");
 249
 250          if Col_Start = 0 then
 251             Col_Start := Entity'Last + 1;
 252          end if;
 253
 254          if Col_Start > Line_Start + 1 then
 255             begin
 256                Line_Num := Natural'Value
 257                  (Entity (Line_Start + 1 .. Col_Start - 1));
 258
 259             exception
 260                when Constraint_Error =>
 261                   raise Invalid_Argument;
 262             end;
 263          end if;
 264
 265          if Col_Start < Entity'Last then
 266             begin
 267                Col_Num := Natural'Value (Entity
 268                                          (Col_Start + 1 .. Entity'Last));
 269
 270             exception
 271                when Constraint_Error => raise Invalid_Argument;
 272             end;
 273          end if;
 274       end if;
 275
 276       File_Ref :=
 277         Add_To_Xref_File
 278           (Entity (File_Start .. Line_Start - 1), Visited => True);
 279       Pattern.File_Ref := File_Ref;
 280       Add_Line (Pattern.File_Ref, Line_Num, Col_Num);
 281       File_Ref :=
 282         Add_To_Xref_File
 283           (ALI_File_Name (Entity (File_Start .. Line_Start - 1)),
 284            Visited      => False,
 285            Emit_Warning => True);
 286    end Add_Entity;
 287
 288    -------------------
 289    -- Add_Xref_File --
 290    -------------------
 291
 292    procedure Add_Xref_File (File : String) is
 293       File_Ref : File_Reference := Empty_File;
 294       Iterator : Expansion_Iterator;
 295
 296       procedure Add_Xref_File_Internal (File : String);
 297       --  Do the actual addition of the file
 298
 299       ----------------------------
 300       -- Add_Xref_File_Internal --
 301       ----------------------------
 302
 303       procedure Add_Xref_File_Internal (File : String) is
 304       begin
 305          --  Case where we have an ALI file, accept it even though this is
 306          --  not official usage, since the intention is obvious
 307
 308          if Tail (File, 4) = ".ali" then
 309             File_Ref := Add_To_Xref_File
 310               (File, Visited => False, Emit_Warning => True);
 311
 312          --  Normal non-ali file case
 313
 314          else
 315             File_Ref := Add_To_Xref_File (File, Visited => True);
 316
 317             File_Ref := Add_To_Xref_File
 318               (ALI_File_Name (File),
 319                Visited => False,
 320                Emit_Warning => True);
 321          end if;
 322       end Add_Xref_File_Internal;
 323
 324    --  Start of processing for Add_Xref_File
 325
 326    begin
 327       --  Check if we need to do the expansion
 328
 329       if Ada.Strings.Fixed.Index (File, "*") /= 0
 330         or else Ada.Strings.Fixed.Index (File, "?") /= 0
 331       then
 332          Start_Expansion (Iterator, File);
 333
 334          loop
 335             declare
 336                S : constant String := Expansion (Iterator);
 337
 338             begin
 339                exit when S'Length = 0;
 340                Add_Xref_File_Internal (S);
 341             end;
 342          end loop;
 343
 344       else
 345          Add_Xref_File_Internal (File);
 346       end if;
 347    end Add_Xref_File;
 348
 349    -----------------------
 350    -- Current_Xref_File --
 351    -----------------------
 352
 353    function Current_Xref_File (File : ALI_File) return File_Reference is
 354    begin
 355       return File.X_File;
 356    end Current_Xref_File;
 357
 358    --------------------------
 359    -- Default_Project_File --
 360    --------------------------
 361
 362    function Default_Project_File
 363      (Dir_Name : String)
 364       return     String
 365    is
 366       My_Dir  : Dir_Type;
 367       Dir_Ent : File_Name_String;
 368       Last    : Natural;
 369
 370    begin
 371       Open (My_Dir, Dir_Name);
 372
 373       loop
 374          Read (My_Dir, Dir_Ent, Last);
 375          exit when Last = 0;
 376
 377          if Tail (Dir_Ent (1 .. Last), 4) = ".adp" then
 378
 379             --  The first project file found is the good one.
 380
 381             Close (My_Dir);
 382             return Dir_Ent (1 .. Last);
 383          end if;
 384       end loop;
 385
 386       Close (My_Dir);
 387       return String'(1 .. 0 => ' ');
 388
 389    exception
 390       when Directory_Error => return String'(1 .. 0 => ' ');
 391    end Default_Project_File;
 392
 393    ---------------
 394    -- File_Name --
 395    ---------------
 396
 397    function File_Name
 398      (File : ALI_File;
 399       Num  : Positive)
 400       return File_Reference
 401    is
 402    begin
 403       return File.Dep.Table (Num);
 404    end File_Name;
 405
 406    --------------------
 407    -- Find_ALI_Files --
 408    --------------------
 409
 410    procedure Find_ALI_Files is
 411       My_Dir       : Rec_DIR;
 412       Dir_Ent      : File_Name_String;
 413       Last         : Natural;
 414       File_Ref     : File_Reference;
 415
 416       function Open_Next_Dir return Boolean;
 417       --  Tries to open the next object directory, and return False if
 418       --  the directory cannot be opened.
 419
 420       -------------------
 421       -- Open_Next_Dir --
 422       -------------------
 423
 424       function Open_Next_Dir return Boolean is
 425       begin
 426          --  Until we are able to open a new directory
 427
 428          loop
 429             declare
 430                Obj_Dir : constant String := Next_Obj_Dir;
 431
 432             begin
 433                --  Case of no more Obj_Dir lines
 434
 435                if Obj_Dir'Length = 0 then
 436                   return False;
 437                end if;
 438
 439                Open (My_Dir.Dir, Obj_Dir);
 440                exit;
 441
 442             exception
 443
 444                --  Could not open the directory
 445
 446                when Directory_Error => null;
 447             end;
 448          end loop;
 449
 450          return True;
 451       end Open_Next_Dir;
 452
 453    --  Start of processing for Find_ALI_Files
 454
 455    begin
 456       Reset_Obj_Dir;
 457
 458       if Open_Next_Dir then
 459          loop
 460             Read (My_Dir.Dir, Dir_Ent, Last);
 461
 462             if Last = 0 then
 463                Close (My_Dir.Dir);
 464
 465                if not Open_Next_Dir then
 466                   return;
 467                end if;
 468
 469             elsif Last > 4 and then Dir_Ent (Last - 3 .. Last) = ".ali" then
 470                File_Ref :=
 471                  Add_To_Xref_File (Dir_Ent (1 .. Last), Visited => False);
 472             end if;
 473          end loop;
 474       end if;
 475    end Find_ALI_Files;
 476
 477    -------------------
 478    -- Get_Full_Type --
 479    -------------------
 480
 481    function Get_Full_Type (Decl : Declaration_Reference) return String is
 482
 483       function Param_String return String;
 484       --  Return the string to display depending on whether Decl is a
 485       --  parameter or not
 486
 487       ------------------
 488       -- Param_String --
 489       ------------------
 490
 491       function Param_String return String is
 492       begin
 493          if Is_Parameter (Decl) then
 494             return "parameter ";
 495          else
 496             return "";
 497          end if;
 498       end Param_String;
 499
 500    --  Start of processing for Get_Full_Type
 501
 502    begin
 503       case Get_Type (Decl) is
 504          when 'A' => return "array type";
 505          when 'B' => return "boolean type";
 506          when 'C' => return "class-wide type";
 507          when 'D' => return "decimal type";
 508          when 'E' => return "enumeration type";
 509          when 'F' => return "float type";
 510          when 'I' => return "integer type";
 511          when 'M' => return "modular type";
 512          when 'O' => return "fixed type";
 513          when 'P' => return "access type";
 514          when 'R' => return "record type";
 515          when 'S' => return "string type";
 516          when 'T' => return "task type";
 517          when 'W' => return "protected type";
 518
 519          when 'a' => return "array type";
 520          when 'b' => return Param_String & "boolean object";
 521          when 'c' => return Param_String & "class-wide object";
 522          when 'd' => return Param_String & "decimal object";
 523          when 'e' => return Param_String & "enumeration object";
 524          when 'f' => return Param_String & "float object";
 525          when 'i' => return Param_String & "integer object";
 526          when 'm' => return Param_String & "modular object";
 527          when 'o' => return Param_String & "fixed object";
 528          when 'p' => return Param_String & "access object";
 529          when 'r' => return Param_String & "record object";
 530          when 's' => return Param_String & "string object";
 531          when 't' => return Param_String & "task object";
 532          when 'w' => return Param_String & "protected object";
 533          when 'x' => return Param_String & "abstract procedure";
 534          when 'y' => return Param_String & "abstract function";
 535
 536          when 'K' => return "package";
 537          when 'k' => return "generic package";
 538          when 'L' => return "statement label";
 539          when 'l' => return "loop label";
 540          when 'N' => return "named number";
 541          when 'n' => return "enumeration literal";
 542          when 'q' => return "block label";
 543          when 'U' => return "procedure";
 544          when 'u' => return "generic procedure";
 545          when 'V' => return "function";
 546          when 'v' => return "generic function";
 547          when 'X' => return "exception";
 548          when 'Y' => return "entry";
 549
 550          when '+' => return "private type";
 551
 552          --  The above should be the only possibilities, but for this kind
 553          --  of informational output, we don't want to bomb if we find
 554          --  something else, so just return three question marks when we
 555          --  have an unknown Abbrev value
 556
 557          when others =>
 558             return "??? (" & Get_Type (Decl) & ")";
 559       end case;
 560    end Get_Full_Type;
 561
 562    --------------------------
 563    -- Skip_To_First_X_Line --
 564    --------------------------
 565
 566    procedure Skip_To_First_X_Line
 567      (File    : in out ALI_File;
 568       D_Lines : Boolean;
 569       W_Lines : Boolean)
 570    is
 571       Ali              : String_Access renames File.Buffer;
 572       Token            : Positive;
 573       Ptr              : Positive := Ali'First;
 574       Num_Dependencies : Natural  := 0;
 575       File_Ref         : File_Reference;
 576       File_Start       : Positive;
 577       File_End         : Positive;
 578       Gnatchop_Offset  : Integer;
 579       Gnatchop_Name    : Positive;
 580
 581    begin
 582       --  Read all the lines possibly processing with-clauses and dependency
 583       --  information and exit on finding the first Xref line.
 584       --  A fall-through of the loop means that there is no xref information
 585       --  which is an error condition.
 586
 587       while Ali (Ptr) /= EOF loop
 588
 589          if D_Lines and then Ali (Ptr) = 'D' then
 590
 591             --  Found dependency information. Format looks like:
 592             --  D src-nam time-stmp checksum [subunit-name] [line:file-name]
 593
 594             --  Skip the D and parse the filenam
 595
 596             Ptr := Ptr + 1;
 597             Parse_Token (Ali, Ptr, Token);
 598             File_Start := Token;
 599             File_End := Ptr - 1;
 600
 601             Num_Dependencies := Num_Dependencies + 1;
 602             Set_Last (File.Dep, Num_Dependencies);
 603
 604             Parse_Token (Ali, Ptr, Token); --  Skip time-stamp
 605             Parse_Token (Ali, Ptr, Token); --  Skip checksum
 606             Parse_Token (Ali, Ptr, Token); --  Read next entity on the line
 607
 608             if not (Ali (Token) in '0' .. '9') then
 609                Parse_Token (Ali, Ptr, Token); --  Was a subunit name
 610             end if;
 611
 612             --  Did we have a gnatchop-ed file with a pragma Source_Reference ?
 613
 614             Gnatchop_Offset := 0;
 615
 616             if Ali (Token) in '0' .. '9' then
 617                Gnatchop_Name := Token;
 618                while Ali (Gnatchop_Name) /= ':' loop
 619                   Gnatchop_Name := Gnatchop_Name + 1;
 620                end loop;
 621
 622                Gnatchop_Offset :=
 623                  2 - Natural'Value (Ali (Token .. Gnatchop_Name - 1));
 624                Token := Gnatchop_Name + 1;
 625             end if;
 626
 627             File.Dep.Table (Num_Dependencies) := Add_To_Xref_File
 628               (Ali (File_Start .. File_End),
 629                Gnatchop_File => Ali (Token .. Ptr - 1),
 630                Gnatchop_Offset => Gnatchop_Offset);
 631
 632          elsif W_Lines and then Ali (Ptr) = 'W' then
 633
 634             --  Found with-clause information. Format looks like:
 635             --     "W debug%s               debug.adb               debug.ali"
 636
 637             --  Skip the W and parse the .ali filename (3rd token)
 638
 639             Parse_Token (Ali, Ptr, Token);
 640             Parse_Token (Ali, Ptr, Token);
 641             Parse_Token (Ali, Ptr, Token);
 642
 643             File_Ref := Add_To_Xref_File
 644               (Ali (Token .. Ptr - 1), Visited => False);
 645
 646          elsif Ali (Ptr) = 'X' then
 647
 648             --  Found a cross-referencing line - stop processing
 649
 650             File.Current_Line := Ptr;
 651             File.Xref_Line    := Ptr;
 652             return;
 653          end if;
 654
 655          Parse_EOL (Ali, Ptr);
 656       end loop;
 657
 658       raise No_Xref_Information;
 659    end Skip_To_First_X_Line;
 660
 661    ----------
 662    -- Open --
 663    ----------
 664
 665    procedure Open
 666      (Name         : String;
 667       File         : out ALI_File;
 668       Dependencies : Boolean := False)
 669    is
 670       Ali : String_Access renames File.Buffer;
 671
 672    begin
 673       if File.Buffer /= null then
 674          Free (File.Buffer);
 675       end if;
 676
 677       Init (File.Dep);
 678
 679       begin
 680          Read_File (Name, Ali);
 681
 682       exception
 683          when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error =>
 684             raise No_Xref_Information;
 685       end;
 686
 687       Skip_To_First_X_Line (File, D_Lines => True, W_Lines => Dependencies);
 688    end Open;
 689
 690    ---------------
 691    -- Parse_EOL --
 692    ---------------
 693
 694    procedure Parse_EOL
 695      (Source                 : access String;
 696       Ptr                    : in out Positive;
 697       Skip_Continuation_Line : Boolean := False)
 698    is
 699    begin
 700       loop
 701          --  Skip to end of line
 702
 703          while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
 704            and then Source (Ptr) /= EOF
 705          loop
 706             Ptr := Ptr + 1;
 707          end loop;
 708
 709          if Source (Ptr) /= EOF then
 710             Ptr := Ptr + 1;      -- skip CR or LF
 711          end if;
 712
 713          --  Skip past CR/LF or LF/CR combination
 714
 715          if (Source (Ptr) = ASCII.CR or else Source (Ptr) = ASCII.LF)
 716            and then Source (Ptr) /= Source (Ptr - 1)
 717          then
 718             Ptr := Ptr + 1;
 719          end if;
 720
 721          exit when not Skip_Continuation_Line or else Source (Ptr) /= '.';
 722       end loop;
 723    end Parse_EOL;
 724
 725    ---------------------------
 726    -- Parse_Identifier_Info --
 727    ---------------------------
 728
 729    procedure Parse_Identifier_Info
 730      (Pattern       : Search_Pattern;
 731       File          : in out ALI_File;
 732       Local_Symbols : Boolean;
 733       Der_Info      : Boolean := False;
 734       Type_Tree     : Boolean := False;
 735       Wide_Search   : Boolean := True;
 736       Labels_As_Ref : Boolean := True)
 737    is
 738       Ptr      : Positive renames File.Current_Line;
 739       Ali      : String_Access renames File.Buffer;
 740
 741       E_Line   : Natural;   --  Line number of current entity
 742       E_Col    : Natural;   --  Column number of current entity
 743       E_Type   : Character; --  Type of current entity
 744       E_Name   : Positive;  --  Pointer to begin of entity name
 745       E_Global : Boolean;   --  True iff entity is global
 746
 747       R_Line   : Natural;   --  Line number of current reference
 748       R_Col    : Natural;   --  Column number of current reference
 749       R_Type   : Character; --  Type of current reference
 750
 751       Decl_Ref : Declaration_Reference;
 752       File_Ref : File_Reference := Current_Xref_File (File);
 753
 754       function Get_Symbol_Name (Eun, Line, Col : Natural) return String;
 755       --  Returns the symbol name for the entity defined at the specified
 756       --  line and column in the dependent unit number Eun. For this we need
 757       --  to parse the ali file again because the parent entity is not in
 758       --  the declaration table if it did not match the search pattern.
 759
 760       ---------------------
 761       -- Get_Symbol_Name --
 762       ---------------------
 763
 764       function Get_Symbol_Name (Eun, Line, Col : Natural) return String is
 765          Ptr    : Positive := 1;
 766          E_Eun  : Positive;   --  Unit number of current entity
 767          E_Line : Natural;    --  Line number of current entity
 768          E_Col  : Natural;    --  Column number of current entity
 769          E_Name : Positive;   --  Pointer to begin of entity name
 770          E_Type : Character;  --  Type of current entity
 771
 772       begin
 773          --  Look for the X lines corresponding to unit Eun
 774
 775          loop
 776             if Ali (Ptr) = 'X' then
 777                Ptr := Ptr + 1;
 778                Parse_Number (Ali, Ptr, E_Eun);
 779                exit when E_Eun = Eun;
 780             end if;
 781
 782             Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
 783          end loop;
 784
 785          --  Here we are in the right Ali section, we now look for the entity
 786          --  declared at position (Line, Col).
 787
 788          loop
 789             Parse_Number (Ali, Ptr, E_Line);
 790             E_Type := Ali (Ptr);
 791             exit when Ali (Ptr) = EOF;
 792             Ptr := Ptr + 1;
 793             Parse_Number (Ali, Ptr, E_Col);
 794             exit when Ali (Ptr) = EOF;
 795             Ptr := Ptr + 1;
 796
 797             if Line = E_Line and then Col = E_Col then
 798                Parse_Token (Ali, Ptr, E_Name);
 799                return Ali (E_Name .. Ptr - 1);
 800             end if;
 801
 802             Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
 803             exit when Ali (Ptr) = EOF;
 804          end loop;
 805
 806          --  We were not able to find the symbol, this should not happend but
 807          --  since we don't want to stop here we return a string of three
 808          --  question marks as the symbol name.
 809
 810          return "???";
 811       end Get_Symbol_Name;
 812
 813    --  Start of processing for Parse_Identifier_Info
 814
 815    begin
 816       --  The identifier info looks like:
 817       --     "38U9*Debug 12|36r6 36r19"
 818
 819       --  Extract the line, column and entity name information
 820
 821       Parse_Number (Ali, Ptr, E_Line);
 822
 823       if Ali (Ptr) > ' ' then
 824          E_Type := Ali (Ptr);
 825          Ptr := Ptr + 1;
 826       end if;
 827
 828       --  Ignore some of the entities (labels,...)
 829
 830       case E_Type is
 831          when 'l' | 'L' | 'q' =>
 832             Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
 833             return;
 834
 835          when others =>
 836             null;
 837       end case;
 838
 839       Parse_Number (Ali, Ptr, E_Col);
 840
 841       E_Global := False;
 842       if Ali (Ptr) >= ' ' then
 843          E_Global := (Ali (Ptr) = '*');
 844          Ptr := Ptr + 1;
 845       end if;
 846
 847       Parse_Token (Ali, Ptr, E_Name);
 848
 849       --  Exit if the symbol does not match
 850       --  or if we have a local symbol and we do not want it
 851
 852       if (not Local_Symbols and not E_Global)
 853         or else (Pattern.Initialized
 854                   and then not Match (Ali (E_Name .. Ptr - 1), Pattern.Entity))
 855         or else (E_Name >= Ptr)
 856       then
 857          Decl_Ref := Add_Declaration
 858            (File.X_File, Ali (E_Name .. Ptr - 1), E_Line, E_Col, E_Type,
 859             Remove_Only => True);
 860          Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
 861          return;
 862       end if;
 863
 864       --  Insert the declaration in the table
 865
 866       Decl_Ref := Add_Declaration
 867         (File.X_File, Ali (E_Name .. Ptr - 1), E_Line, E_Col, E_Type);
 868
 869       if Ali (Ptr) = '<'
 870         or else Ali (Ptr) = '('
 871         or else Ali (Ptr) = '{'
 872       then
 873          --  Here we have a type derivation information. The format is
 874          --  <3|12I45> which means that the current entity is derived from the
 875          --  type defined in unit number 3, line 12 column 45. The pipe and
 876          --  unit number is optional. It is specified only if the parent type
 877          --  is not defined in the current unit.
 878
 879          --  We could also have something like
 880          --  16I9*I<integer>
 881          --  that indicates that I derives from the predefined type integer.
 882
 883          Ptr := Ptr + 1;
 884
 885          if Ali (Ptr) in '0' .. '9' then
 886             Parse_Derived_Info : declare
 887                P_Line   : Natural;          --  parent entity line
 888                P_Column : Natural;          --  parent entity column
 889                P_Type   : Character;        --  parent entity type
 890                P_Eun    : Positive;         --  parent entity file number
 891
 892             begin
 893                Parse_Number (Ali, Ptr, P_Line);
 894
 895                --  If we have a pipe then the first number was the unit number
 896
 897                if Ali (Ptr) = '|' then
 898                   P_Eun := P_Line;
 899                   Ptr := Ptr + 1;
 900
 901                   --  Now we have the line number
 902
 903                   Parse_Number (Ali, Ptr, P_Line);
 904
 905                else
 906                   --  We don't have a unit number specified, so we set P_Eun to
 907                   --  the current unit.
 908
 909                   for K in Dependencies_Tables.First .. Last (File.Dep) loop
 910                      P_Eun := K;
 911                      exit when File.Dep.Table (K) = File_Ref;
 912                   end loop;
 913                end if;
 914
 915                --  Then parse the type and column number
 916
 917                P_Type := Ali (Ptr);
 918                Ptr := Ptr + 1;
 919                Parse_Number (Ali, Ptr, P_Column);
 920
 921                --  Skip '>', or ')' or '>'
 922
 923                Ptr := Ptr + 1;
 924
 925                --  The derived info is needed only is the derived info mode is
 926                --  on or if we want to output the type hierarchy
 927
 928                if Der_Info or else Type_Tree then
 929                   declare
 930                      Symbol : constant String :=
 931                        Get_Symbol_Name (P_Eun, P_Line, P_Column);
 932
 933                   begin
 934                      if Symbol /= "???" then
 935                         Add_Parent
 936                           (Decl_Ref,
 937                            Symbol,
 938                            P_Line,
 939                            P_Column,
 940                            File.Dep.Table (P_Eun));
 941                      end if;
 942                   end;
 943                end if;
 944
 945                if Type_Tree
 946                  and then (Pattern.File_Ref = Empty_File
 947                              or else
 948                            Pattern.File_Ref = Current_Xref_File (File))
 949                then
 950                   Search_Parent_Tree : declare
 951                      Pattern         : Search_Pattern;  --  Parent type pattern
 952                      File_Pos_Backup : Positive;
 953
 954                   begin
 955                      Add_Entity
 956                        (Pattern,
 957                         Get_Symbol_Name (P_Eun, P_Line, P_Column)
 958                         & ':' & Get_Gnatchop_File (File.Dep.Table (P_Eun))
 959                         & ':' & Get_Line (Get_Parent (Decl_Ref))
 960                         & ':' & Get_Column (Get_Parent (Decl_Ref)),
 961                         False);
 962
 963                      --  No default match is needed to look for the parent type
 964                      --  since we are using the fully qualified symbol name:
 965                      --  symbol:file:line:column
 966
 967                      Set_Default_Match (False);
 968
 969                      --  The parent hierarchy is defined in the same unit as
 970                      --  the derived type. So we want to revisit the unit.
 971
 972                      File_Pos_Backup   := File.Current_Line;
 973
 974                      Skip_To_First_X_Line
 975                        (File, D_Lines => False, W_Lines => False);
 976
 977                      while File.Buffer (File.Current_Line) /= EOF loop
 978                         Parse_X_Filename (File);
 979                         Parse_Identifier_Info
 980                           (Pattern       => Pattern,
 981                            File          => File,
 982                            Local_Symbols => False,
 983                            Der_Info      => Der_Info,
 984                            Type_Tree     => True,
 985                            Wide_Search   => False,
 986                            Labels_As_Ref => Labels_As_Ref);
 987                      end loop;
 988
 989                      File.Current_Line := File_Pos_Backup;
 990                   end Search_Parent_Tree;
 991                end if;
 992             end Parse_Derived_Info;
 993
 994          else
 995             while Ali (Ptr) /= '>'
 996               and then Ali (Ptr) /= ')'
 997               and then Ali (Ptr) /= '}'
 998             loop
 999                Ptr := Ptr + 1;
1000             end loop;
1001             Ptr := Ptr + 1;
1002          end if;
1003
1004       elsif Ali (Ptr) = '=' then
1005          declare
1006             P_Line, P_Column : Natural;
1007
1008          begin
1009             Ptr := Ptr + 1;
1010             Parse_Number (Ali, Ptr, P_Line);
1011             Ptr := Ptr + 1;
1012             Parse_Number (Ali, Ptr, P_Column);
1013          end;
1014       end if;
1015
1016       --  To find the body, we will have to parse the file too
1017
1018       if Wide_Search then
1019          declare
1020             File_Ref     : File_Reference;
1021             File_Name    : constant String :=
1022                              Get_Gnatchop_File (File.X_File);
1023          begin
1024             File_Ref := Add_To_Xref_File (ALI_File_Name (File_Name), False);
1025          end;
1026       end if;
1027
1028       --  Parse references to this entity.
1029       --  Ptr points to next reference with leading blanks
1030
1031       loop
1032          --  Process references on current line
1033
1034          while Ali (Ptr) = ' ' or Ali (Ptr) = ASCII.HT loop
1035
1036             --  For every reference read the line, type and column,
1037             --  optionally preceded by a file number and a pipe symbol.
1038
1039             Parse_Number (Ali, Ptr, R_Line);
1040
1041             if Ali (Ptr) = Pipe then
1042                Ptr := Ptr + 1;
1043                File_Ref := File_Name (File, R_Line);
1044
1045                Parse_Number (Ali, Ptr, R_Line);
1046             end if;
1047
1048             if Ali (Ptr) > ' ' then
1049                R_Type := Ali (Ptr);
1050                Ptr := Ptr + 1;
1051             end if;
1052
1053             --  Imported entities might special indication as to their external
1054             --  name:
1055             --    5U14*Foo2 5>20 6b<c,myfoo2>22
1056
1057             if R_Type = 'b'
1058               and then Ali (Ptr) = '<'
1059             then
1060                while Ptr <= Ali'Last
1061                  and then Ali (Ptr) /= '>'
1062                loop
1063                   Ptr := Ptr + 1;
1064                end loop;
1065                Ptr := Ptr + 1;
1066             end if;
1067
1068             Parse_Number (Ali, Ptr, R_Col);
1069
1070             --  Insert the reference or body in the table
1071
1072             Add_Reference
1073               (Decl_Ref, File_Ref, R_Line, R_Col, R_Type, Labels_As_Ref);
1074
1075             --  Skip generic information, if any
1076
1077             if Ali (Ptr) = '[' then
1078                declare
1079                   Num_Nested : Integer := 1;
1080
1081                begin
1082                   Ptr := Ptr + 1;
1083                   while Num_Nested /= 0 loop
1084                      if Ali (Ptr) = ']' then
1085                         Num_Nested := Num_Nested - 1;
1086                      elsif Ali (Ptr) = '[' then
1087                         Num_Nested := Num_Nested + 1;
1088                      end if;
1089
1090                      Ptr := Ptr + 1;
1091                   end loop;
1092                end;
1093             end if;
1094
1095          end loop;
1096
1097          Parse_EOL (Ali, Ptr);
1098
1099          --   Loop until new line is no continuation line
1100
1101          exit when Ali (Ptr) /= '.';
1102          Ptr := Ptr + 1;
1103       end loop;
1104    end Parse_Identifier_Info;
1105
1106    ------------------
1107    -- Parse_Number --
1108    ------------------
1109
1110    procedure Parse_Number
1111      (Source : access String;
1112       Ptr    : in out Positive;
1113       Number : out Natural)
1114    is
1115    begin
1116       --  Skip separators
1117
1118       while Source (Ptr) = ' ' or else Source (Ptr) = ASCII.HT loop
1119          Ptr := Ptr + 1;
1120       end loop;
1121
1122       Number := 0;
1123       while Source (Ptr) in '0' .. '9' loop
1124          Number :=
1125            10 * Number + (Character'Pos (Source (Ptr)) - Character'Pos ('0'));
1126          Ptr := Ptr + 1;
1127       end loop;
1128    end Parse_Number;
1129
1130    -----------------
1131    -- Parse_Token --
1132    -----------------
1133
1134    procedure Parse_Token
1135      (Source    : access String;
1136       Ptr       : in out Positive;
1137       Token_Ptr : out Positive)
1138    is
1139       In_Quotes : Character := ASCII.NUL;
1140
1141    begin
1142       --  Skip separators
1143
1144       while Source (Ptr) = ' ' or else Source (Ptr) = ASCII.HT loop
1145          Ptr := Ptr + 1;
1146       end loop;
1147
1148       Token_Ptr := Ptr;
1149
1150       --  Find end-of-token
1151
1152       while (In_Quotes /= ASCII.NUL or else
1153                not (Source (Ptr) = ' '
1154                      or else Source (Ptr) = ASCII.HT
1155                      or else Source (Ptr) = '<'
1156                      or else Source (Ptr) = '{'
1157                      or else Source (Ptr) = '='
1158                      or else Source (Ptr) = '('))
1159         and then Source (Ptr) >= ' '
1160       loop
1161          --  Double-quotes are used for operators
1162          --  Simple-quotes are used for character constants, for instance when
1163          --  they are found in an enumeration type "type A is ('+', '-');"
1164
1165          case Source (Ptr) is
1166             when '"' | ''' =>
1167                if In_Quotes = Source (Ptr) then
1168                   In_Quotes := ASCII.NUL;
1169                elsif In_Quotes = ASCII.NUL then
1170                   In_Quotes := Source (Ptr);
1171                end if;
1172
1173             when others =>
1174                null;
1175          end case;
1176
1177          Ptr := Ptr + 1;
1178       end loop;
1179    end Parse_Token;
1180
1181    ----------------------
1182    -- Parse_X_Filename --
1183    ----------------------
1184
1185    procedure Parse_X_Filename (File : in out ALI_File) is
1186       Ali     : String_Access renames File.Buffer;
1187       Ptr     : Positive renames File.Current_Line;
1188       File_Nr : Natural;
1189
1190    begin
1191       while Ali (Ptr) = 'X' loop
1192
1193          --  The current line is the start of a new Xref file section,
1194          --  whose format looks like:
1195
1196          --     " X 1 debug.ads"
1197
1198          --  Skip the X and read the file number for the new X_File
1199
1200          Ptr := Ptr + 1;
1201          Parse_Number (Ali, Ptr, File_Nr);
1202
1203          if File_Nr > 0 then
1204             File.X_File := File.Dep.Table (File_Nr);
1205          end if;
1206
1207          Parse_EOL (Ali, Ptr);
1208       end loop;
1209    end Parse_X_Filename;
1210
1211    --------------------
1212    -- Print_Gnatfind --
1213    --------------------
1214
1215    procedure Print_Gnatfind
1216      (References     : Boolean;
1217       Full_Path_Name : Boolean)
1218    is
1219       Decls : constant Declaration_Array_Access := Get_Declarations;
1220       Decl  : Declaration_Reference;
1221       Arr   : Reference_Array_Access;
1222
1223       procedure Print_Ref
1224         (Ref : Reference;
1225          Msg : String := "      ");
1226       --  Print a reference, according to the extended tag of the output
1227
1228       ---------------
1229       -- Print_Ref --
1230       ---------------
1231
1232       procedure Print_Ref
1233         (Ref : Reference;
1234          Msg : String := "      ")
1235       is
1236          F : String_Access :=
1237                Osint.To_Host_File_Spec
1238                 (Get_Gnatchop_File (Ref, Full_Path_Name));
1239
1240          Buffer : constant String :=
1241                     F.all &
1242                     ":" & Get_Line (Ref)   &
1243                     ":" & Get_Column (Ref) &
1244                     ": ";
1245
1246          Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length;
1247
1248       begin
1249          Free (F);
1250          Num_Blanks := Integer'Max (0, Num_Blanks);
1251          Write_Line
1252            (Buffer
1253             & String'(1 .. Num_Blanks => ' ')
1254             & Msg & " " & Get_Symbol (Decl));
1255
1256          if Get_Source_Line (Ref)'Length /= 0 then
1257             Write_Line ("   " & Get_Source_Line (Ref));
1258          end if;
1259       end Print_Ref;
1260
1261    --  Start of processing for Print_Gnatfind
1262
1263    begin
1264       for D in Decls'Range loop
1265          Decl := Decls (D);
1266
1267          if Match (Decl) then
1268
1269             --  Output the declaration
1270
1271             declare
1272                Parent : constant Declaration_Reference := Get_Parent (Decl);
1273
1274                F : String_Access :=
1275                      Osint.To_Host_File_Spec
1276                       (Get_Gnatchop_File (Decl, Full_Path_Name));
1277
1278                Buffer : constant String :=
1279                           F.all &
1280                           ":" & Get_Line (Decl)   &
1281                           ":" & Get_Column (Decl) &
1282                           ": ";
1283
1284                Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length;
1285
1286             begin
1287                Free (F);
1288                Num_Blanks := Integer'Max (0, Num_Blanks);
1289                Write_Line
1290                  (Buffer & String'(1 .. Num_Blanks => ' ')
1291                   & "(spec) " & Get_Symbol (Decl));
1292
1293                if Parent /= Empty_Declaration then
1294                   F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent));
1295                   Write_Line
1296                     (Buffer & String'(1 .. Num_Blanks => ' ')
1297                      & "   derived from " & Get_Symbol (Parent)
1298                      & " ("
1299                      & F.all
1300                      & ':' & Get_Line (Parent)
1301                      & ':' & Get_Column (Parent) & ')');
1302                   Free (F);
1303                end if;
1304             end;
1305
1306             if Get_Source_Line (Decl)'Length /= 0 then
1307                Write_Line ("   " & Get_Source_Line (Decl));
1308             end if;
1309
1310             --  Output the body (sorted)
1311
1312             Arr := Get_References (Decl, Get_Bodies => True);
1313
1314             for R in Arr'Range loop
1315                Print_Ref (Arr (R), "(body)");
1316             end loop;
1317
1318             Free (Arr);
1319
1320             if References then
1321                Arr := Get_References
1322                  (Decl, Get_Writes => True, Get_Reads => True);
1323
1324                for R in Arr'Range loop
1325                   Print_Ref (Arr (R));
1326                end loop;
1327
1328                Free (Arr);
1329             end if;
1330          end if;
1331       end loop;
1332    end Print_Gnatfind;
1333
1334    ------------------
1335    -- Print_Unused --
1336    ------------------
1337
1338    procedure Print_Unused (Full_Path_Name : in Boolean) is
1339       Decls : constant Declaration_Array_Access := Get_Declarations;
1340       Decl  : Declaration_Reference;
1341       Arr   : Reference_Array_Access;
1342       F     : String_Access;
1343
1344    begin
1345       for D in Decls'Range loop
1346          Decl := Decls (D);
1347
1348          if References_Count
1349              (Decl, Get_Reads => True, Get_Writes => True) = 0
1350          then
1351             F := Osint.To_Host_File_Spec
1352               (Get_Gnatchop_File (Decl, Full_Path_Name));
1353             Write_Str (Get_Symbol (Decl)
1354                         & " ("
1355                         & Get_Full_Type (Decl)
1356                         & ") "
1357                         & F.all
1358                         & ':'
1359                         & Get_Line (Decl)
1360                         & ':'
1361                         & Get_Column (Decl));
1362             Free (F);
1363
1364             --  Print the body if any
1365
1366             Arr := Get_References (Decl, Get_Bodies => True);
1367
1368             for R in Arr'Range loop
1369                F := Osint.To_Host_File_Spec
1370                       (Get_Gnatchop_File (Arr (R), Full_Path_Name));
1371                Write_Str (' '
1372                            & F.all
1373                            & ':' & Get_Line (Arr (R))
1374                            & ':' & Get_Column (Arr (R)));
1375                Free (F);
1376             end loop;
1377
1378             Write_Eol;
1379             Free (Arr);
1380          end if;
1381       end loop;
1382    end Print_Unused;
1383
1384    --------------
1385    -- Print_Vi --
1386    --------------
1387
1388    procedure Print_Vi (Full_Path_Name : in Boolean) is
1389       Tab   : constant Character := ASCII.HT;
1390       Decls : constant Declaration_Array_Access :=
1391                 Get_Declarations (Sorted => False);
1392       Decl  : Declaration_Reference;
1393       Arr   : Reference_Array_Access;
1394       F     : String_Access;
1395
1396    begin
1397       for D in Decls'Range loop
1398          Decl := Decls (D);
1399
1400          F := Osint.To_Host_File_Spec (Get_File (Decl, Full_Path_Name));
1401          Write_Line (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Decl));
1402          Free (F);
1403
1404          --  Print the body if any
1405
1406          Arr := Get_References (Decl, Get_Bodies => True);
1407
1408          for R in Arr'Range loop
1409             F := Osint.To_Host_File_Spec (Get_File (Arr (R), Full_Path_Name));
1410             Write_Line
1411               (Get_Symbol (Decl) & Tab & F.all & Tab  & Get_Line (Arr (R)));
1412             Free (F);
1413          end loop;
1414
1415          Free (Arr);
1416
1417          --  Print the modifications
1418
1419          Arr := Get_References (Decl, Get_Writes => True, Get_Reads => True);
1420
1421          for R in Arr'Range loop
1422             F := Osint.To_Host_File_Spec (Get_File (Arr (R), Full_Path_Name));
1423             Write_Line
1424               (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Arr (R)));
1425             Free (F);
1426          end loop;
1427
1428          Free (Arr);
1429       end loop;
1430    end Print_Vi;
1431
1432    ----------------
1433    -- Print_Xref --
1434    ----------------
1435
1436    procedure Print_Xref (Full_Path_Name : in Boolean) is
1437       Decls : constant Declaration_Array_Access := Get_Declarations;
1438       Decl : Declaration_Reference;
1439
1440       Margin : constant := 10;
1441       --  Column where file names start
1442
1443       procedure New_Line80;
1444       --  Go to start of new line
1445
1446       procedure Print80 (S : in String);
1447       --  Print the text, respecting the 80 columns rule.
1448
1449       procedure Print_Ref (Line, Column : String);
1450       --  The beginning of the output is aligned on a column multiple of 9
1451
1452       procedure Print_List
1453         (Decl       : Declaration_Reference;
1454          Msg        : String;
1455          Get_Reads  : Boolean := False;
1456          Get_Writes : Boolean := False;
1457          Get_Bodies : Boolean := False);
1458       --  Print a list of references. If the list is not empty, Msg will
1459       --  be printed prior to the list.
1460
1461       ----------------
1462       -- New_Line80 --
1463       ----------------
1464
1465       procedure New_Line80 is
1466       begin
1467          Write_Eol;
1468          Write_Str (String'(1 .. Margin - 1 => ' '));
1469       end New_Line80;
1470
1471       -------------
1472       -- Print80 --
1473       -------------
1474
1475       procedure Print80 (S : in String) is
1476          Align : Natural := Margin - (Integer (Column) mod Margin);
1477
1478       begin
1479          if Align = Margin then
1480             Align := 0;
1481          end if;
1482
1483          Write_Str (String'(1 .. Align => ' ') & S);
1484       end Print80;
1485
1486       ---------------
1487       -- Print_Ref --
1488       ---------------
1489
1490       procedure Print_Ref (Line, Column : String) is
1491          Line_Align : constant Integer := 4 - Line'Length;
1492
1493          S : constant String := String'(1 .. Line_Align => ' ')
1494                                   & Line & ':' & Column;
1495
1496          Align : Natural := Margin - (Integer (Output.Column) mod Margin);
1497
1498       begin
1499          if Align = Margin then
1500             Align := 0;
1501          end if;
1502
1503          if Integer (Output.Column) + Align + S'Length > 79 then
1504             New_Line80;
1505             Align := 0;
1506          end if;
1507
1508          Write_Str (String'(1 .. Align => ' ') & S);
1509       end Print_Ref;
1510
1511       ----------------
1512       -- Print_List --
1513       ----------------
1514
1515       procedure Print_List
1516         (Decl       : Declaration_Reference;
1517          Msg        : String;
1518          Get_Reads  : Boolean := False;
1519          Get_Writes : Boolean := False;
1520          Get_Bodies : Boolean := False)
1521       is
1522          Arr : Reference_Array_Access :=
1523                  Get_References
1524                    (Decl,
1525                     Get_Writes => Get_Writes,
1526                     Get_Reads  => Get_Reads,
1527                     Get_Bodies => Get_Bodies);
1528          File : File_Reference := Empty_File;
1529          F    : String_Access;
1530
1531       begin
1532          if Arr'Length /= 0 then
1533             Write_Eol;
1534             Write_Str (Msg);
1535          end if;
1536
1537          for R in Arr'Range loop
1538             if Get_File_Ref (Arr (R)) /= File then
1539                if File /= Empty_File then
1540                   New_Line80;
1541                end if;
1542
1543                File := Get_File_Ref (Arr (R));
1544                F := Osint.To_Host_File_Spec
1545                  (Get_Gnatchop_File (Arr (R), Full_Path_Name));
1546                Write_Str (F.all & ' ');
1547                Free (F);
1548             end if;
1549
1550             Print_Ref (Get_Line (Arr (R)), Get_Column (Arr (R)));
1551          end loop;
1552
1553          Free (Arr);
1554       end Print_List;
1555
1556       F : String_Access;
1557
1558    --  Start of processing for Print_Xref
1559
1560    begin
1561       for D in Decls'Range loop
1562          Decl := Decls (D);
1563
1564          Write_Str (Get_Symbol (Decl));
1565
1566          while Column < Type_Position loop
1567             Write_Char (' ');
1568          end loop;
1569
1570          Write_Line (Get_Full_Type (Decl));
1571
1572          Write_Parent_Info : declare
1573             Parent : constant Declaration_Reference := Get_Parent (Decl);
1574
1575          begin
1576             if Parent /= Empty_Declaration then
1577                Write_Str ("  Ptype: ");
1578                F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent));
1579                Print80 (F.all);
1580                Free (F);
1581                Print_Ref (Get_Line (Parent), Get_Column (Parent));
1582                Print80 ("  " & Get_Symbol (Parent));
1583                Write_Eol;
1584             end if;
1585          end Write_Parent_Info;
1586
1587          Write_Str ("  Decl:  ");
1588          F := Osint.To_Host_File_Spec
1589                (Get_Gnatchop_File (Decl, Full_Path_Name));
1590          Print80 (F.all & ' ');
1591          Free (F);
1592          Print_Ref (Get_Line (Decl), Get_Column (Decl));
1593
1594          Print_List
1595            (Decl, "  Body:  ", Get_Bodies => True);
1596          Print_List
1597            (Decl, "  Modi:  ", Get_Writes => True);
1598          Print_List
1599            (Decl, "  Ref:   ", Get_Reads => True);
1600          Write_Eol;
1601       end loop;
1602    end Print_Xref;
1603
1604    ------------
1605    -- Search --
1606    ------------
1607
1608    procedure Search
1609      (Pattern       : Search_Pattern;
1610       Local_Symbols : Boolean;
1611       Wide_Search   : Boolean;
1612       Read_Only     : Boolean;
1613       Der_Info      : Boolean;
1614       Type_Tree     : Boolean)
1615    is
1616       type String_Access is access String;
1617       procedure Free is new Unchecked_Deallocation (String, String_Access);
1618
1619       ALIfile   : ALI_File;
1620       File_Ref  : File_Reference;
1621       Strip_Num : Natural := 0;
1622       Ali_Name  : String_Access;
1623
1624    begin
1625       --  If we want all the .ali files, then find them
1626
1627       if Wide_Search then
1628          Find_ALI_Files;
1629       end if;
1630
1631       loop
1632          --  Get the next unread ali file
1633
1634          File_Ref := Next_Unvisited_File;
1635
1636          exit when File_Ref = Empty_File;
1637
1638          --  Find the ALI file to use. Most of the time, it will be the unit
1639          --  name, with a different extension. However, when dealing with
1640          --  separates the ALI file is in fact the parent's ALI file (and this
1641          --  is recursive, in case the parent itself is a separate).
1642
1643          Strip_Num := 0;
1644          loop
1645             Free (Ali_Name);
1646             Ali_Name := new String'
1647               (Get_File (File_Ref, With_Dir => True, Strip => Strip_Num));
1648
1649             --  Stripped too many things...
1650
1651             if Ali_Name.all = "" then
1652                if Get_Emit_Warning (File_Ref) then
1653                   Set_Standard_Error;
1654                   Write_Line
1655                     ("warning : file " & Get_File (File_Ref, With_Dir => True)
1656                      & " not found");
1657                   Set_Standard_Output;
1658                end if;
1659                Free (Ali_Name);
1660                exit;
1661
1662             --  If not found, try the parent's ALI file (this is needed for
1663             --  separate units and subprograms).
1664
1665             --  Reset the cached directory first, in case the separate's
1666             --  ALI file is not in the same directory.
1667
1668             elsif not File_Exists (Ali_Name.all) then
1669                Strip_Num := Strip_Num + 1;
1670                Reset_Directory (File_Ref);
1671
1672             --  Else we finally found it
1673
1674             else
1675                exit;
1676             end if;
1677          end loop;
1678
1679          --  If we had to get the parent's ALI, insert it in the list as usual.
1680          --  This is to avoid parsing it twice in case it has already been
1681          --  parsed.
1682
1683          if Ali_Name /= null and then Strip_Num /= 0 then
1684             File_Ref := Add_To_Xref_File
1685               (File_Name => Ali_Name.all,
1686                Visited   => False);
1687
1688          --  Now that we have a file name, parse it to find any reference to
1689          --  the entity.
1690
1691          elsif Ali_Name /= null
1692            and then (Read_Only or else Is_Writable_File (Ali_Name.all))
1693          then
1694             begin
1695                Open (Ali_Name.all, ALIfile);
1696                while ALIfile.Buffer (ALIfile.Current_Line) /= EOF loop
1697                   Parse_X_Filename (ALIfile);
1698                   Parse_Identifier_Info
1699                     (Pattern, ALIfile, Local_Symbols,
1700                      Der_Info, Type_Tree, Wide_Search, Labels_As_Ref => True);
1701                end loop;
1702
1703             exception
1704                when No_Xref_Information   =>
1705                   if Get_Emit_Warning (File_Ref) then
1706                      Set_Standard_Error;
1707                      Write_Line
1708                        ("warning : No cross-referencing information in  "
1709                         & Ali_Name.all);
1710                      Set_Standard_Output;
1711                   end if;
1712             end;
1713          end if;
1714       end loop;
1715
1716       Free (Ali_Name);
1717    end Search;
1718
1719    -----------------
1720    -- Search_Xref --
1721    -----------------
1722
1723    procedure Search_Xref
1724      (Local_Symbols : Boolean;
1725       Read_Only     : Boolean;
1726       Der_Info      : Boolean)
1727    is
1728       ALIfile      : ALI_File;
1729       File_Ref     : File_Reference;
1730       Null_Pattern : Search_Pattern;
1731
1732    begin
1733       Null_Pattern.Initialized := False;
1734
1735       loop
1736          --  Find the next unvisited file
1737
1738          File_Ref := Next_Unvisited_File;
1739          exit when File_Ref = Empty_File;
1740
1741          --  Search the object directories for the .ali file
1742
1743          declare
1744             F : constant String := Get_File (File_Ref, With_Dir => True);
1745
1746          begin
1747             if Read_Only or else Is_Writable_File (F) then
1748                Open (F, ALIfile, True);
1749
1750                while ALIfile.Buffer (ALIfile.Current_Line) /= EOF loop
1751                   Parse_X_Filename (ALIfile);
1752                   Parse_Identifier_Info
1753                     (Null_Pattern, ALIfile, Local_Symbols, Der_Info,
1754                      Labels_As_Ref => False);
1755                end loop;
1756             end if;
1757
1758          exception
1759             when No_Xref_Information =>  null;
1760          end;
1761       end loop;
1762    end Search_Xref;
1763
1764 end Xref_Lib;