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-2019, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  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         : in 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         : in 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          pragma Assert (Source (Ptr) /= EOF);
 727
 728          --  Skip to end of line
 729
 730          while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
 731            and then Source (Ptr) /= EOF
 732          loop
 733             Ptr := Ptr + 1;
 734          end loop;
 735
 736          --  Skip CR or LF if not at end of file
 737
 738          if Source (Ptr) /= EOF then
 739             Ptr := Ptr + 1;
 740          end if;
 741
 742          --  Skip past CR/LF
 743
 744          if Source (Ptr - 1) = ASCII.CR and then Source (Ptr) = ASCII.LF 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       --  If the symbol is not found, we return "???".
 787
 788       procedure Skip_To_Matching_Closing_Bracket;
 789       --  When Ptr points to an opening square bracket, moves it to the
 790       --  character following the matching closing bracket
 791
 792       ---------------------
 793       -- Get_Symbol_Name --
 794       ---------------------
 795
 796       function Get_Symbol_Name (Eun, Line, Col : Natural) return String is
 797          Ptr    : Positive := 1;
 798          E_Eun  : Positive;   --  Unit number of current entity
 799          E_Line : Natural;    --  Line number of current entity
 800          E_Col  : Natural;    --  Column number of current entity
 801          E_Name : Positive;   --  Pointer to begin of entity name
 802
 803       begin
 804          --  Look for the X lines corresponding to unit Eun
 805
 806          loop
 807             if Ali (Ptr) = EOF then
 808                return "???";
 809             end if;
 810
 811             if Ali (Ptr) = 'X' then
 812                Ptr := Ptr + 1;
 813                Parse_Number (Ali, Ptr, E_Eun);
 814                exit when E_Eun = Eun;
 815             end if;
 816
 817             Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
 818          end loop;
 819
 820          --  Here we are in the right Ali section, we now look for the entity
 821          --  declared at position (Line, Col).
 822
 823          loop
 824             Parse_Number (Ali, Ptr, E_Line);
 825             exit when Ali (Ptr) = EOF;
 826             Ptr := Ptr + 1;
 827             Parse_Number (Ali, Ptr, E_Col);
 828             exit when Ali (Ptr) = EOF;
 829             Ptr := Ptr + 1;
 830
 831             if Line = E_Line and then Col = E_Col then
 832                Parse_Token (Ali, Ptr, E_Name);
 833                return Ali (E_Name .. Ptr - 1);
 834             end if;
 835
 836             Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
 837             exit when Ali (Ptr) = EOF;
 838          end loop;
 839
 840          return "???";
 841       end Get_Symbol_Name;
 842
 843       --------------------------------------
 844       -- Skip_To_Matching_Closing_Bracket --
 845       --------------------------------------
 846
 847       procedure Skip_To_Matching_Closing_Bracket is
 848          Num_Brackets : Natural;
 849
 850       begin
 851          Num_Brackets := 1;
 852          while Num_Brackets /= 0 loop
 853             Ptr := Ptr + 1;
 854             if Ali (Ptr) = '[' then
 855                Num_Brackets := Num_Brackets + 1;
 856             elsif Ali (Ptr) = ']' then
 857                Num_Brackets := Num_Brackets - 1;
 858             end if;
 859          end loop;
 860
 861          Ptr := Ptr + 1;
 862       end Skip_To_Matching_Closing_Bracket;
 863
 864       Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
 865
 866    --  Start of processing for Parse_Identifier_Info
 867
 868    begin
 869       --  The identifier info looks like:
 870       --     "38U9*Debug 12|36r6 36r19"
 871
 872       --  Extract the line, column and entity name information
 873
 874       Parse_Number (Ali, Ptr, E_Line);
 875
 876       if Ali (Ptr) > ' ' then
 877          E_Type := Ali (Ptr);
 878          Ptr := Ptr + 1;
 879       end if;
 880
 881       --  Ignore some of the entities (labels,...)
 882
 883       case E_Type is
 884          when 'l' | 'L' | 'q' =>
 885             Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
 886             return;
 887
 888          when others =>
 889             null;
 890       end case;
 891
 892       Parse_Number (Ali, Ptr, E_Col);
 893
 894       E_Global := False;
 895       if Ali (Ptr) >= ' ' then
 896          E_Global := (Ali (Ptr) = '*');
 897          Ptr := Ptr + 1;
 898       end if;
 899
 900       Parse_Token (Ali, Ptr, E_Name);
 901
 902       --  Exit if the symbol does not match or if we have a local symbol and we
 903       --  do not want it or if the file is unknown.
 904
 905       if File.X_File = Empty_File then
 906          return;
 907       end if;
 908
 909       if (not Local_Symbols and not E_Global)
 910         or else (Pattern.Initialized
 911                   and then not Match (Ali (E_Name .. Ptr - 1), Pattern.Entity))
 912         or else (E_Name >= Ptr)
 913       then
 914          Decl_Ref := Add_Declaration
 915            (File.X_File, Ali (E_Name .. Ptr - 1), E_Line, E_Col, E_Type,
 916             Remove_Only => True);
 917          Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
 918          return;
 919       end if;
 920
 921       --  Insert the declaration in the table
 922
 923       Decl_Ref := Add_Declaration
 924         (File.X_File, Ali (E_Name .. Ptr - 1), E_Line, E_Col, E_Type);
 925
 926       if Ali (Ptr) = '[' then
 927          Skip_To_Matching_Closing_Bracket;
 928       end if;
 929
 930       --  Skip any renaming indication
 931
 932       if Ali (Ptr) = '=' then
 933          declare
 934             P_Line, P_Column : Natural;
 935             pragma Warnings (Off, P_Line);
 936             pragma Warnings (Off, P_Column);
 937          begin
 938             Ptr := Ptr + 1;
 939             Parse_Number (Ali, Ptr, P_Line);
 940             Ptr := Ptr + 1;
 941             Parse_Number (Ali, Ptr, P_Column);
 942          end;
 943       end if;
 944
 945       while Ptr <= Ali'Last
 946          and then (Ali (Ptr) = '<'
 947                    or else Ali (Ptr) = '('
 948                    or else Ali (Ptr) = '{')
 949       loop
 950          --  Here we have a type derivation information. The format is
 951          --  <3|12I45> which means that the current entity is derived from the
 952          --  type defined in unit number 3, line 12 column 45. The pipe and
 953          --  unit number is optional. It is specified only if the parent type
 954          --  is not defined in the current unit.
 955
 956          --  We also have the format for generic instantiations, as in
 957          --  7a5*Uid(3|5I8[4|2]) 2|4r74
 958
 959          --  We could also have something like
 960          --  16I9*I<integer>
 961          --  that indicates that I derives from the predefined type integer.
 962
 963          Ptr := Ptr + 1;
 964
 965          if Ali (Ptr) in '0' .. '9' then
 966             Parse_Derived_Info : declare
 967                P_Line   : Natural;          --  parent entity line
 968                P_Column : Natural;          --  parent entity column
 969                P_Eun    : Positive;         --  parent entity file number
 970
 971             begin
 972                Parse_Number (Ali, Ptr, P_Line);
 973
 974                --  If we have a pipe then the first number was the unit number
 975
 976                if Ali (Ptr) = '|' then
 977                   P_Eun := P_Line;
 978                   Ptr := Ptr + 1;
 979
 980                   --  Now we have the line number
 981
 982                   Parse_Number (Ali, Ptr, P_Line);
 983
 984                else
 985                   --  We don't have a unit number specified, so we set P_Eun to
 986                   --  the current unit.
 987
 988                   for K in Table'Range loop
 989                      P_Eun := K;
 990                      exit when Table (K) = File_Ref;
 991                   end loop;
 992                end if;
 993
 994                --  Then parse the type and column number
 995
 996                Ptr := Ptr + 1;
 997                Parse_Number (Ali, Ptr, P_Column);
 998
 999                --  Skip the information for generics instantiations
1000
1001                if Ali (Ptr) = '[' then
1002                   Skip_To_Matching_Closing_Bracket;
1003                end if;
1004
1005                --  Skip '>', or ')' or '>'
1006
1007                Ptr := Ptr + 1;
1008
1009                --  The derived info is needed only is the derived info mode is
1010                --  on or if we want to output the type hierarchy
1011
1012                if Der_Info or else Type_Tree then
1013                   declare
1014                      Symbol : constant String :=
1015                                 Get_Symbol_Name (P_Eun, P_Line, P_Column);
1016                   begin
1017                      if Symbol /= "???" then
1018                         Add_Parent
1019                           (Decl_Ref,
1020                            Symbol,
1021                            P_Line,
1022                            P_Column,
1023                            Table (P_Eun));
1024                      end if;
1025                   end;
1026                end if;
1027
1028                if Type_Tree
1029                  and then (Pattern.File_Ref = Empty_File
1030                              or else
1031                            Pattern.File_Ref = Current_Xref_File (File))
1032                then
1033                   Search_Parent_Tree : declare
1034                      Pattern         : Search_Pattern;  --  Parent type pattern
1035                      File_Pos_Backup : Positive;
1036
1037                   begin
1038                      Add_Entity
1039                        (Pattern,
1040                         Get_Symbol_Name (P_Eun, P_Line, P_Column)
1041                         & ':' & Get_Gnatchop_File (Table (P_Eun))
1042                         & ':' & Get_Line (Get_Parent (Decl_Ref))
1043                         & ':' & Get_Column (Get_Parent (Decl_Ref)),
1044                         False);
1045
1046                      --  No default match is needed to look for the parent type
1047                      --  since we are using the fully qualified symbol name:
1048                      --  symbol:file:line:column
1049
1050                      Set_Default_Match (False);
1051
1052                      --  The parent hierarchy is defined in the same unit as
1053                      --  the derived type. So we want to revisit the unit.
1054
1055                      File_Pos_Backup   := File.Current_Line;
1056
1057                      Skip_To_First_X_Line
1058                        (File, D_Lines => False, W_Lines => False);
1059
1060                      while File.Buffer (File.Current_Line) /= EOF loop
1061                         Parse_X_Filename (File);
1062                         Parse_Identifier_Info
1063                           (Pattern       => Pattern,
1064                            File          => File,
1065                            Local_Symbols => False,
1066                            Der_Info      => Der_Info,
1067                            Type_Tree     => True,
1068                            Wide_Search   => False,
1069                            Labels_As_Ref => Labels_As_Ref);
1070                      end loop;
1071
1072                      File.Current_Line := File_Pos_Backup;
1073                   end Search_Parent_Tree;
1074                end if;
1075             end Parse_Derived_Info;
1076
1077          else
1078             while Ali (Ptr) /= '>'
1079               and then Ali (Ptr) /= ')'
1080               and then Ali (Ptr) /= '}'
1081             loop
1082                Ptr := Ptr + 1;
1083             end loop;
1084             Ptr := Ptr + 1;
1085          end if;
1086       end loop;
1087
1088       --  To find the body, we will have to parse the file too
1089
1090       if Wide_Search then
1091          declare
1092             File_Name : constant String := Get_Gnatchop_File (File.X_File);
1093             Ignored : File_Reference;
1094          begin
1095             Ignored := Add_To_Xref_File (ALI_File_Name (File_Name), False);
1096          end;
1097       end if;
1098
1099       --  Parse references to this entity.
1100       --  Ptr points to next reference with leading blanks
1101
1102       loop
1103          --  Process references on current line
1104
1105          while Ali (Ptr) = ' ' or else Ali (Ptr) = ASCII.HT loop
1106
1107             --  For every reference read the line, type and column,
1108             --  optionally preceded by a file number and a pipe symbol.
1109
1110             Parse_Number (Ali, Ptr, R_Line);
1111
1112             if Ali (Ptr) = Pipe then
1113                Ptr := Ptr + 1;
1114                File_Ref := File_Name (File, R_Line);
1115
1116                Parse_Number (Ali, Ptr, R_Line);
1117             end if;
1118
1119             if Ali (Ptr) > ' ' then
1120                R_Type := Ali (Ptr);
1121                Ptr := Ptr + 1;
1122             end if;
1123
1124             --  Imported entities may have an indication specifying information
1125             --  about the corresponding external name:
1126             --    5U14*Foo2 5>20 6b<c,myfoo2>22   # Imported entity
1127             --    5U14*Foo2 5>20 6i<c,myfoo2>22   # Exported entity
1128
1129             if (R_Type = 'b' or else R_Type = 'i')
1130               and then Ali (Ptr) = '<'
1131             then
1132                while Ptr <= Ali'Last
1133                  and then Ali (Ptr) /= '>'
1134                loop
1135                   Ptr := Ptr + 1;
1136                end loop;
1137                Ptr := Ptr + 1;
1138             end if;
1139
1140             Parse_Number (Ali, Ptr, R_Col);
1141
1142             --  Insert the reference or body in the table
1143
1144             Add_Reference
1145               (Decl_Ref, File_Ref, R_Line, R_Col, R_Type, Labels_As_Ref);
1146
1147             --  Skip generic information, if any
1148
1149             if Ali (Ptr) = '[' then
1150                declare
1151                   Num_Nested : Integer := 1;
1152
1153                begin
1154                   Ptr := Ptr + 1;
1155                   while Num_Nested /= 0 loop
1156                      if Ali (Ptr) = ']' then
1157                         Num_Nested := Num_Nested - 1;
1158                      elsif Ali (Ptr) = '[' then
1159                         Num_Nested := Num_Nested + 1;
1160                      end if;
1161
1162                      Ptr := Ptr + 1;
1163                   end loop;
1164                end;
1165             end if;
1166
1167          end loop;
1168
1169          Parse_EOL (Ali, Ptr);
1170
1171          --   Loop until new line is no continuation line
1172
1173          exit when Ali (Ptr) /= '.';
1174          Ptr := Ptr + 1;
1175       end loop;
1176    end Parse_Identifier_Info;
1177
1178    ------------------
1179    -- Parse_Number --
1180    ------------------
1181
1182    procedure Parse_Number
1183      (Source : not null access String;
1184       Ptr    : in out Positive;
1185       Number : out Natural)
1186    is
1187    begin
1188       --  Skip separators
1189
1190       while Source (Ptr) = ' ' or else Source (Ptr) = ASCII.HT loop
1191          Ptr := Ptr + 1;
1192       end loop;
1193
1194       Number := 0;
1195       while Source (Ptr) in '0' .. '9' loop
1196          Number :=
1197            10 * Number + (Character'Pos (Source (Ptr)) - Character'Pos ('0'));
1198          Ptr := Ptr + 1;
1199       end loop;
1200    end Parse_Number;
1201
1202    -----------------
1203    -- Parse_Token --
1204    -----------------
1205
1206    procedure Parse_Token
1207      (Source    : not null access String;
1208       Ptr       : in out Positive;
1209       Token_Ptr : out Positive)
1210    is
1211       In_Quotes : Character := ASCII.NUL;
1212
1213    begin
1214       --  Skip separators
1215
1216       while Source (Ptr) = ' ' or else Source (Ptr) = ASCII.HT loop
1217          Ptr := Ptr + 1;
1218       end loop;
1219
1220       Token_Ptr := Ptr;
1221
1222       --  Find end-of-token
1223
1224       while (In_Quotes /= ASCII.NUL or else
1225                not (Source (Ptr) = ' '
1226                      or else Source (Ptr) = ASCII.HT
1227                      or else Source (Ptr) = '<'
1228                      or else Source (Ptr) = '{'
1229                      or else Source (Ptr) = '['
1230                      or else Source (Ptr) = '='
1231                      or else Source (Ptr) = '('))
1232         and then Source (Ptr) >= ' '
1233       loop
1234          --  Double-quotes are used for operators
1235          --  Simple-quotes are used for character constants, for instance when
1236          --  they are found in an enumeration type "type A is ('+', '-');"
1237
1238          case Source (Ptr) is
1239             when '"' | ''' =>
1240                if In_Quotes = Source (Ptr) then
1241                   In_Quotes := ASCII.NUL;
1242                elsif In_Quotes = ASCII.NUL then
1243                   In_Quotes := Source (Ptr);
1244                end if;
1245
1246             when others =>
1247                null;
1248          end case;
1249
1250          Ptr := Ptr + 1;
1251       end loop;
1252    end Parse_Token;
1253
1254    ----------------------
1255    -- Parse_X_Filename --
1256    ----------------------
1257
1258    procedure Parse_X_Filename (File : in out ALI_File) is
1259       Ali     : String_Access renames File.Buffer;
1260       Ptr     : Positive renames File.Current_Line;
1261       File_Nr : Natural;
1262
1263       Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
1264
1265    begin
1266       while Ali (Ptr) = 'X' loop
1267
1268          --  The current line is the start of a new Xref file section,
1269          --  whose format looks like:
1270
1271          --     " X 1 debug.ads"
1272
1273          --  Skip the X and read the file number for the new X_File
1274
1275          Ptr := Ptr + 1;
1276          Parse_Number (Ali, Ptr, File_Nr);
1277
1278          --  If the referenced file is unknown, we simply ignore it
1279
1280          if File_Nr in Table'Range then
1281             File.X_File := Table (File_Nr);
1282          else
1283             File.X_File := Empty_File;
1284          end if;
1285
1286          Parse_EOL (Ali, Ptr);
1287       end loop;
1288    end Parse_X_Filename;
1289
1290    --------------------
1291    -- Print_Gnatfind --
1292    --------------------
1293
1294    procedure Print_Gnatfind
1295      (References     : Boolean;
1296       Full_Path_Name : Boolean)
1297    is
1298       Decls : constant Declaration_Array_Access := Get_Declarations;
1299       Decl  : Declaration_Reference;
1300       Arr   : Reference_Array_Access;
1301
1302       procedure Print_Ref
1303         (Ref : Reference;
1304          Msg : String := "      ");
1305       --  Print a reference, according to the extended tag of the output
1306
1307       ---------------
1308       -- Print_Ref --
1309       ---------------
1310
1311       procedure Print_Ref
1312         (Ref : Reference;
1313          Msg : String := "      ")
1314       is
1315          F : String_Access :=
1316                Osint.To_Host_File_Spec
1317                 (Get_Gnatchop_File (Ref, Full_Path_Name));
1318
1319          Buffer : constant String :=
1320                     F.all &
1321                     ":" & Get_Line (Ref)   &
1322                     ":" & Get_Column (Ref) &
1323                     ": ";
1324
1325          Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length;
1326
1327       begin
1328          Free (F);
1329          Num_Blanks := Integer'Max (0, Num_Blanks);
1330          Write_Line
1331            (Buffer
1332             & String'(1 .. Num_Blanks => ' ')
1333             & Msg & " " & Get_Symbol (Decl));
1334
1335          if Get_Source_Line (Ref)'Length /= 0 then
1336             Write_Line ("   " & Get_Source_Line (Ref));
1337          end if;
1338       end Print_Ref;
1339
1340    --  Start of processing for Print_Gnatfind
1341
1342    begin
1343       for D in Decls'Range loop
1344          Decl := Decls (D);
1345
1346          if Match (Decl) then
1347
1348             --  Output the declaration
1349
1350             declare
1351                Parent : constant Declaration_Reference := Get_Parent (Decl);
1352
1353                F : String_Access :=
1354                      Osint.To_Host_File_Spec
1355                       (Get_Gnatchop_File (Decl, Full_Path_Name));
1356
1357                Buffer : constant String :=
1358                           F.all &
1359                           ":" & Get_Line (Decl)   &
1360                           ":" & Get_Column (Decl) &
1361                           ": ";
1362
1363                Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length;
1364
1365             begin
1366                Free (F);
1367                Num_Blanks := Integer'Max (0, Num_Blanks);
1368                Write_Line
1369                  (Buffer & String'(1 .. Num_Blanks => ' ')
1370                   & "(spec) " & Get_Symbol (Decl));
1371
1372                if Parent /= Empty_Declaration then
1373                   F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent));
1374                   Write_Line
1375                     (Buffer & String'(1 .. Num_Blanks => ' ')
1376                      & "   derived from " & Get_Symbol (Parent)
1377                      & " ("
1378                      & F.all
1379                      & ':' & Get_Line (Parent)
1380                      & ':' & Get_Column (Parent) & ')');
1381                   Free (F);
1382                end if;
1383             end;
1384
1385             if Get_Source_Line (Decl)'Length /= 0 then
1386                Write_Line ("   " & Get_Source_Line (Decl));
1387             end if;
1388
1389             --  Output the body (sorted)
1390
1391             Arr := Get_References (Decl, Get_Bodies => True);
1392
1393             for R in Arr'Range loop
1394                Print_Ref (Arr (R), "(body)");
1395             end loop;
1396
1397             Free (Arr);
1398
1399             if References then
1400                Arr := Get_References
1401                  (Decl, Get_Writes => True, Get_Reads => True);
1402
1403                for R in Arr'Range loop
1404                   Print_Ref (Arr (R));
1405                end loop;
1406
1407                Free (Arr);
1408             end if;
1409          end if;
1410       end loop;
1411    end Print_Gnatfind;
1412
1413    ------------------
1414    -- Print_Unused --
1415    ------------------
1416
1417    procedure Print_Unused (Full_Path_Name : Boolean) is
1418       Decls : constant Declaration_Array_Access := Get_Declarations;
1419       Decl  : Declaration_Reference;
1420       Arr   : Reference_Array_Access;
1421       F     : String_Access;
1422
1423    begin
1424       for D in Decls'Range loop
1425          Decl := Decls (D);
1426
1427          if References_Count
1428              (Decl, Get_Reads => True, Get_Writes => True) = 0
1429          then
1430             F := Osint.To_Host_File_Spec
1431               (Get_Gnatchop_File (Decl, Full_Path_Name));
1432             Write_Str (Get_Symbol (Decl)
1433                         & " ("
1434                         & Get_Full_Type (Decl)
1435                         & ") "
1436                         & F.all
1437                         & ':'
1438                         & Get_Line (Decl)
1439                         & ':'
1440                         & Get_Column (Decl));
1441             Free (F);
1442
1443             --  Print the body if any
1444
1445             Arr := Get_References (Decl, Get_Bodies => True);
1446
1447             for R in Arr'Range loop
1448                F := Osint.To_Host_File_Spec
1449                       (Get_Gnatchop_File (Arr (R), Full_Path_Name));
1450                Write_Str (' '
1451                            & F.all
1452                            & ':' & Get_Line (Arr (R))
1453                            & ':' & Get_Column (Arr (R)));
1454                Free (F);
1455             end loop;
1456
1457             Write_Eol;
1458             Free (Arr);
1459          end if;
1460       end loop;
1461    end Print_Unused;
1462
1463    --------------
1464    -- Print_Vi --
1465    --------------
1466
1467    procedure Print_Vi (Full_Path_Name : Boolean) is
1468       Tab   : constant Character := ASCII.HT;
1469       Decls : constant Declaration_Array_Access :=
1470                 Get_Declarations (Sorted => False);
1471       Decl  : Declaration_Reference;
1472       Arr   : Reference_Array_Access;
1473       F     : String_Access;
1474
1475    begin
1476       for D in Decls'Range loop
1477          Decl := Decls (D);
1478
1479          F := Osint.To_Host_File_Spec (Get_File (Decl, Full_Path_Name));
1480          Write_Line (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Decl));
1481          Free (F);
1482
1483          --  Print the body if any
1484
1485          Arr := Get_References (Decl, Get_Bodies => True);
1486
1487          for R in Arr'Range loop
1488             F := Osint.To_Host_File_Spec (Get_File (Arr (R), Full_Path_Name));
1489             Write_Line
1490               (Get_Symbol (Decl) & Tab & F.all & Tab  & Get_Line (Arr (R)));
1491             Free (F);
1492          end loop;
1493
1494          Free (Arr);
1495
1496          --  Print the modifications
1497
1498          Arr := Get_References (Decl, Get_Writes => True, Get_Reads => True);
1499
1500          for R in Arr'Range loop
1501             F := Osint.To_Host_File_Spec (Get_File (Arr (R), Full_Path_Name));
1502             Write_Line
1503               (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Arr (R)));
1504             Free (F);
1505          end loop;
1506
1507          Free (Arr);
1508       end loop;
1509    end Print_Vi;
1510
1511    ----------------
1512    -- Print_Xref --
1513    ----------------
1514
1515    procedure Print_Xref (Full_Path_Name : Boolean) is
1516       Decls : constant Declaration_Array_Access := Get_Declarations;
1517       Decl : Declaration_Reference;
1518
1519       Margin : constant := 10;
1520       --  Column where file names start
1521
1522       procedure New_Line80;
1523       --  Go to start of new line
1524
1525       procedure Print80 (S : String);
1526       --  Print the text, respecting the 80 columns rule
1527
1528       procedure Print_Ref (Line, Column : String);
1529       --  The beginning of the output is aligned on a column multiple of 9
1530
1531       procedure Print_List
1532         (Decl       : Declaration_Reference;
1533          Msg        : String;
1534          Get_Reads  : Boolean := False;
1535          Get_Writes : Boolean := False;
1536          Get_Bodies : Boolean := False);
1537       --  Print a list of references. If the list is not empty, Msg will
1538       --  be printed prior to the list.
1539
1540       ----------------
1541       -- New_Line80 --
1542       ----------------
1543
1544       procedure New_Line80 is
1545       begin
1546          Write_Eol;
1547          Write_Str (String'(1 .. Margin - 1 => ' '));
1548       end New_Line80;
1549
1550       -------------
1551       -- Print80 --
1552       -------------
1553
1554       procedure Print80 (S : String) is
1555          Align : Natural := Margin - (Integer (Column) mod Margin);
1556
1557       begin
1558          if Align = Margin then
1559             Align := 0;
1560          end if;
1561
1562          Write_Str (String'(1 .. Align => ' ') & S);
1563       end Print80;
1564
1565       ---------------
1566       -- Print_Ref --
1567       ---------------
1568
1569       procedure Print_Ref (Line, Column : String) is
1570          Line_Align : constant Integer := 4 - Line'Length;
1571
1572          S : constant String := String'(1 .. Line_Align => ' ')
1573                                   & Line & ':' & Column;
1574
1575          Align : Natural := Margin - (Integer (Output.Column) mod Margin);
1576
1577       begin
1578          if Align = Margin then
1579             Align := 0;
1580          end if;
1581
1582          if Integer (Output.Column) + Align + S'Length > 79 then
1583             New_Line80;
1584             Align := 0;
1585          end if;
1586
1587          Write_Str (String'(1 .. Align => ' ') & S);
1588       end Print_Ref;
1589
1590       ----------------
1591       -- Print_List --
1592       ----------------
1593
1594       procedure Print_List
1595         (Decl       : Declaration_Reference;
1596          Msg        : String;
1597          Get_Reads  : Boolean := False;
1598          Get_Writes : Boolean := False;
1599          Get_Bodies : Boolean := False)
1600       is
1601          Arr : Reference_Array_Access :=
1602                  Get_References
1603                    (Decl,
1604                     Get_Writes => Get_Writes,
1605                     Get_Reads  => Get_Reads,
1606                     Get_Bodies => Get_Bodies);
1607          File : File_Reference := Empty_File;
1608          F    : String_Access;
1609
1610       begin
1611          if Arr'Length /= 0 then
1612             Write_Eol;
1613             Write_Str (Msg);
1614          end if;
1615
1616          for R in Arr'Range loop
1617             if Get_File_Ref (Arr (R)) /= File then
1618                if File /= Empty_File then
1619                   New_Line80;
1620                end if;
1621
1622                File := Get_File_Ref (Arr (R));
1623                F := Osint.To_Host_File_Spec
1624                  (Get_Gnatchop_File (Arr (R), Full_Path_Name));
1625
1626                if F = null then
1627                   Write_Str ("<unknown> ");
1628                else
1629                   Write_Str (F.all & ' ');
1630                   Free (F);
1631                end if;
1632             end if;
1633
1634             Print_Ref (Get_Line (Arr (R)), Get_Column (Arr (R)));
1635          end loop;
1636
1637          Free (Arr);
1638       end Print_List;
1639
1640       F : String_Access;
1641
1642    --  Start of processing for Print_Xref
1643
1644    begin
1645       for D in Decls'Range loop
1646          Decl := Decls (D);
1647
1648          Write_Str (Get_Symbol (Decl));
1649
1650          --  Put the declaration type in column Type_Position, but if the
1651          --  declaration name is too long, put at least one space between its
1652          --  name and its type.
1653
1654          while Column < Type_Position - 1 loop
1655             Write_Char (' ');
1656          end loop;
1657
1658          Write_Char (' ');
1659
1660          Write_Line (Get_Full_Type (Decl));
1661
1662          Write_Parent_Info : declare
1663             Parent : constant Declaration_Reference := Get_Parent (Decl);
1664
1665          begin
1666             if Parent /= Empty_Declaration then
1667                Write_Str ("  Ptype: ");
1668                F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent));
1669                Print80 (F.all);
1670                Free (F);
1671                Print_Ref (Get_Line (Parent), Get_Column (Parent));
1672                Print80 ("  " & Get_Symbol (Parent));
1673                Write_Eol;
1674             end if;
1675          end Write_Parent_Info;
1676
1677          Write_Str ("  Decl:  ");
1678          F := Osint.To_Host_File_Spec
1679                (Get_Gnatchop_File (Decl, Full_Path_Name));
1680
1681          if F = null then
1682             Print80 ("<unknown> ");
1683          else
1684             Print80 (F.all & ' ');
1685             Free (F);
1686          end if;
1687
1688          Print_Ref (Get_Line (Decl), Get_Column (Decl));
1689
1690          Print_List
1691            (Decl, "  Body:  ", Get_Bodies => True);
1692          Print_List
1693            (Decl, "  Modi:  ", Get_Writes => True);
1694          Print_List
1695            (Decl, "  Ref:   ", Get_Reads => True);
1696          Write_Eol;
1697       end loop;
1698    end Print_Xref;
1699
1700    ------------
1701    -- Search --
1702    ------------
1703
1704    procedure Search
1705      (Pattern       : Search_Pattern;
1706       Local_Symbols : Boolean;
1707       Wide_Search   : Boolean;
1708       Read_Only     : Boolean;
1709       Der_Info      : Boolean;
1710       Type_Tree     : Boolean)
1711    is
1712       type String_Access is access String;
1713       procedure Free is new Unchecked_Deallocation (String, String_Access);
1714
1715       ALIfile   : ALI_File;
1716       File_Ref  : File_Reference;
1717       Strip_Num : Natural := 0;
1718       Ali_Name  : String_Access;
1719
1720    begin
1721       --  If we want all the .ali files, then find them
1722
1723       if Wide_Search then
1724          Find_ALI_Files;
1725       end if;
1726
1727       loop
1728          --  Get the next unread ali file
1729
1730          File_Ref := Next_Unvisited_File;
1731
1732          exit when File_Ref = Empty_File;
1733
1734          --  Find the ALI file to use. Most of the time, it will be the unit
1735          --  name, with a different extension. However, when dealing with
1736          --  separates the ALI file is in fact the parent's ALI file (and this
1737          --  is recursive, in case the parent itself is a separate).
1738
1739          Strip_Num := 0;
1740          loop
1741             Free (Ali_Name);
1742             Ali_Name := new String'
1743               (Get_File (File_Ref, With_Dir => True, Strip => Strip_Num));
1744
1745             --  Stripped too many things...
1746
1747             if Ali_Name.all = "" then
1748                if Get_Emit_Warning (File_Ref) then
1749                   Set_Standard_Error;
1750                   Write_Line
1751                     ("warning : file " & Get_File (File_Ref, With_Dir => True)
1752                      & " not found");
1753                   Set_Standard_Output;
1754                end if;
1755                Free (Ali_Name);
1756                exit;
1757
1758             --  If not found, try the parent's ALI file (this is needed for
1759             --  separate units and subprograms).
1760
1761             --  Reset the cached directory first, in case the separate's
1762             --  ALI file is not in the same directory.
1763
1764             elsif not File_Exists (Ali_Name.all) then
1765                Strip_Num := Strip_Num + 1;
1766                Reset_Directory (File_Ref);
1767
1768             --  Else we finally found it
1769
1770             else
1771                exit;
1772             end if;
1773          end loop;
1774
1775          --  If we had to get the parent's ALI, insert it in the list as usual.
1776          --  This is to avoid parsing it twice in case it has already been
1777          --  parsed.
1778
1779          if Ali_Name /= null and then Strip_Num /= 0 then
1780             File_Ref := Add_To_Xref_File
1781               (File_Name => Ali_Name.all,
1782                Visited   => False);
1783
1784          --  Now that we have a file name, parse it to find any reference to
1785          --  the entity.
1786
1787          elsif Ali_Name /= null
1788            and then (Read_Only or else Is_Writable_File (Ali_Name.all))
1789          then
1790             begin
1791                Open (Ali_Name.all, ALIfile);
1792
1793                --  The cross-reference section in the ALI file may be followed
1794                --  by other sections, which can be identified by the starting
1795                --  character of every line, which should neither be 'X' nor a
1796                --  figure in '1' .. '9'.
1797
1798                --  The loop tests below also take into account the end-of-file
1799                --  possibility.
1800
1801                while ALIfile.Buffer (ALIfile.Current_Line) = 'X' loop
1802                   Parse_X_Filename (ALIfile);
1803
1804                   while ALIfile.Buffer (ALIfile.Current_Line) in '1' .. '9'
1805                   loop
1806                      Parse_Identifier_Info
1807                        (Pattern, ALIfile, Local_Symbols, Der_Info, Type_Tree,
1808                         Wide_Search, Labels_As_Ref => True);
1809                   end loop;
1810                end loop;
1811
1812             exception
1813                when No_Xref_Information   =>
1814                   if Get_Emit_Warning (File_Ref) then
1815                      Set_Standard_Error;
1816                      Write_Line
1817                        ("warning : No cross-referencing information in  "
1818                         & Ali_Name.all);
1819                      Set_Standard_Output;
1820                   end if;
1821             end;
1822          end if;
1823       end loop;
1824
1825       Free (Ali_Name);
1826    end Search;
1827
1828    -----------------
1829    -- Search_Xref --
1830    -----------------
1831
1832    procedure Search_Xref
1833      (Local_Symbols : Boolean;
1834       Read_Only     : Boolean;
1835       Der_Info      : Boolean)
1836    is
1837       ALIfile      : ALI_File;
1838       File_Ref     : File_Reference;
1839       Null_Pattern : Search_Pattern;
1840
1841    begin
1842       Null_Pattern.Initialized := False;
1843
1844       loop
1845          --  Find the next unvisited file
1846
1847          File_Ref := Next_Unvisited_File;
1848          exit when File_Ref = Empty_File;
1849
1850          --  Search the object directories for the .ali file
1851
1852          declare
1853             F : constant String := Get_File (File_Ref, With_Dir => True);
1854
1855          begin
1856             if Read_Only or else Is_Writable_File (F) then
1857                Open (F, ALIfile, True);
1858
1859                --  The cross-reference section in the ALI file may be followed
1860                --  by other sections, which can be identified by the starting
1861                --  character of every line, which should neither be 'X' nor a
1862                --  figure in '1' .. '9'.
1863
1864                --  The loop tests below also take into account the end-of-file
1865                --  possibility.
1866
1867                while ALIfile.Buffer (ALIfile.Current_Line) = 'X' loop
1868                   Parse_X_Filename (ALIfile);
1869
1870                   while ALIfile.Buffer (ALIfile.Current_Line) in '1' .. '9'
1871                   loop
1872                      Parse_Identifier_Info
1873                        (Null_Pattern, ALIfile, Local_Symbols, Der_Info,
1874                         Labels_As_Ref => False);
1875                   end loop;
1876                end loop;
1877             end if;
1878
1879          exception
1880             when No_Xref_Information => null;
1881          end;
1882       end loop;
1883    end Search_Xref;
1884
1885 end Xref_Lib;