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