gcc/ada/xr_tabls.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             X R  _ T A B L S                             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.36 $
  10 --                                                                          --
  11 --          Copyright (C) 1998-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Ada.IO_Exceptions;
  29 with Ada.Strings.Fixed;
  30 with Ada.Strings;
  31 with Ada.Text_IO;
  32 with Hostparm;
  33 with GNAT.IO_Aux;
  34 with Unchecked_Deallocation;
  35 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  36 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  37 with Osint;
  38
  39 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
  40
  41 package body Xr_Tabls is
  42
  43    subtype Line_String      is String (1 .. Hostparm.Max_Line_Length);
  44    subtype File_Name_String is String (1 .. Hostparm.Max_Name_Length);
  45
  46    function Base_File_Name (File : String) return String;
  47    --  Return the base file name for File (ie not including the directory)
  48
  49    function Dir_Name (File : String; Base : String := "") return String;
  50    --  Return the directory name of File, or "" if there is no directory part
  51    --  in File.
  52    --  This includes the last separator at the end, and always return an
  53    --  absolute path name (directories are relative to Base, or the current
  54    --  directory if Base is "")
  55
  56    Dir_Sep       : Character renames GNAT.OS_Lib.Directory_Separator;
  57
  58    Files         : File_Table;
  59    Entities      : Entity_Table;
  60    Directories   : Project_File_Ptr;
  61    Default_Match : Boolean := False;
  62
  63    ---------------------
  64    -- Add_Declaration --
  65    ---------------------
  66
  67    function Add_Declaration
  68      (File_Ref  : File_Reference;
  69       Symbol    : String;
  70       Line      : Natural;
  71       Column    : Natural;
  72       Decl_Type : Character)
  73       return      Declaration_Reference
  74    is
  75       The_Entities : Declaration_Reference := Entities.Table;
  76       New_Decl     : Declaration_Reference;
  77       Result       : Compare_Result;
  78       Prev         : Declaration_Reference := null;
  79
  80    begin
  81       --  Check if the identifier already exists in the table
  82
  83       while The_Entities /= null loop
  84          Result := Compare (The_Entities, File_Ref, Line, Column, Symbol);
  85          exit when Result = GreaterThan;
  86
  87          if Result = Equal then
  88             return The_Entities;
  89          end if;
  90
  91          Prev := The_Entities;
  92          The_Entities  := The_Entities.Next;
  93       end loop;
  94
  95       --  Insert the Declaration in the table
  96
  97       New_Decl := new Declaration_Record'
  98         (Symbol_Length => Symbol'Length,
  99          Symbol        => Symbol,
 100          Decl          => (File          => File_Ref,
 101                            Line          => Line,
 102                            Column        => Column,
 103                            Source_Line   => Null_Unbounded_String,
 104                            Next          => null),
 105          Decl_Type     => Decl_Type,
 106          Body_Ref      => null,
 107          Ref_Ref       => null,
 108          Modif_Ref     => null,
 109          Match         => Default_Match or else Match (File_Ref, Line, Column),
 110          Par_Symbol    => null,
 111          Next          => null);
 112
 113       if Prev = null then
 114          New_Decl.Next := Entities.Table;
 115          Entities.Table := New_Decl;
 116       else
 117          New_Decl.Next := Prev.Next;
 118          Prev.Next := New_Decl;
 119       end if;
 120
 121       if New_Decl.Match then
 122          Files.Longest_Name := Natural'Max (File_Ref.File'Length,
 123                                             Files.Longest_Name);
 124       end if;
 125
 126       return New_Decl;
 127    end Add_Declaration;
 128
 129    --------------
 130    -- Add_File --
 131    --------------
 132
 133    procedure Add_File
 134      (File_Name    : String;
 135       File_Existed : out Boolean;
 136       Ref          : out File_Reference;
 137       Visited      : Boolean := True;
 138       Emit_Warning : Boolean := False;
 139       Gnatchop_File : String := "";
 140       Gnatchop_Offset : Integer := 0)
 141    is
 142       The_Files : File_Reference := Files.Table;
 143       Base      : constant String := Base_File_Name (File_Name);
 144       Dir       : constant String := Xr_Tabls.Dir_Name (File_Name);
 145       Dir_Acc   : String_Access := null;
 146
 147    begin
 148       --  Do we have a directory name as well ?
 149       if Dir /= "" then
 150          Dir_Acc := new String' (Dir);
 151       end if;
 152
 153       --  Check if the file already exists in the table
 154
 155       while The_Files /= null loop
 156
 157          if The_Files.File = File_Name then
 158             File_Existed      := True;
 159             Ref               := The_Files;
 160             return;
 161          end if;
 162
 163          The_Files := The_Files.Next;
 164       end loop;
 165
 166       Ref := new File_Record'
 167         (File_Length     => Base'Length,
 168          File            => Base,
 169          Dir             => Dir_Acc,
 170          Lines           => null,
 171          Visited         => Visited,
 172          Emit_Warning    => Emit_Warning,
 173          Gnatchop_File   => new String' (Gnatchop_File),
 174          Gnatchop_Offset => Gnatchop_Offset,
 175          Next            => Files.Table);
 176       Files.Table := Ref;
 177       File_Existed := False;
 178    end Add_File;
 179
 180    --------------
 181    -- Add_Line --
 182    --------------
 183
 184    procedure Add_Line
 185      (File   : File_Reference;
 186       Line   : Natural;
 187       Column : Natural)
 188    is
 189    begin
 190       File.Lines := new Ref_In_File'(Line   => Line,
 191                                      Column => Column,
 192                                      Next   => File.Lines);
 193    end Add_Line;
 194
 195    ----------------
 196    -- Add_Parent --
 197    ----------------
 198
 199    procedure Add_Parent
 200      (Declaration : in out Declaration_Reference;
 201       Symbol      : String;
 202       Line        : Natural;
 203       Column      : Natural;
 204       File_Ref    : File_Reference)
 205    is
 206    begin
 207       Declaration.Par_Symbol := new Declaration_Record'
 208         (Symbol_Length => Symbol'Length,
 209          Symbol        => Symbol,
 210          Decl          => (File         => File_Ref,
 211                            Line         => Line,
 212                            Column       => Column,
 213                            Source_Line  => Null_Unbounded_String,
 214                            Next         => null),
 215          Decl_Type     => ' ',
 216          Body_Ref      => null,
 217          Ref_Ref       => null,
 218          Modif_Ref     => null,
 219          Match         => False,
 220          Par_Symbol    => null,
 221          Next          => null);
 222    end Add_Parent;
 223
 224    -------------------
 225    -- Add_Reference --
 226    -------------------
 227
 228    procedure Add_Reference
 229      (Declaration : Declaration_Reference;
 230       File_Ref    : File_Reference;
 231       Line        : Natural;
 232       Column      : Natural;
 233       Ref_Type    : Character)
 234    is
 235       procedure Free is new Unchecked_Deallocation
 236         (Reference_Record, Reference);
 237
 238       Ref     : Reference;
 239       Prev    : Reference := null;
 240       Result  : Compare_Result;
 241       New_Ref : Reference := new Reference_Record'
 242         (File   => File_Ref,
 243          Line   => Line,
 244          Column => Column,
 245          Source_Line => Null_Unbounded_String,
 246          Next   => null);
 247
 248    begin
 249       case Ref_Type is
 250          when 'b' | 'c' => Ref := Declaration.Body_Ref;
 251          when 'r' | 'i' => Ref := Declaration.Ref_Ref;
 252          when 'm'       => Ref := Declaration.Modif_Ref;
 253          when others => return;
 254       end case;
 255
 256       --  Check if the reference already exists
 257
 258       while Ref /= null loop
 259          Result := Compare (New_Ref, Ref);
 260          exit when Result = LessThan;
 261
 262          if Result = Equal then
 263             Free (New_Ref);
 264             return;
 265          end if;
 266
 267          Prev := Ref;
 268          Ref  := Ref.Next;
 269       end loop;
 270
 271       --  Insert it in the list
 272
 273       if Prev /= null then
 274          New_Ref.Next := Prev.Next;
 275          Prev.Next := New_Ref;
 276
 277       else
 278          case Ref_Type is
 279             when 'b' | 'c' =>
 280                New_Ref.Next := Declaration.Body_Ref;
 281                Declaration.Body_Ref := New_Ref;
 282             when 'r' | 'i' =>
 283                New_Ref.Next := Declaration.Ref_Ref;
 284                Declaration.Ref_Ref := New_Ref;
 285             when 'm' =>
 286                New_Ref.Next := Declaration.Modif_Ref;
 287                Declaration.Modif_Ref := New_Ref;
 288             when others => null;
 289          end case;
 290       end if;
 291
 292       if not Declaration.Match then
 293          Declaration.Match := Match (File_Ref, Line, Column);
 294       end if;
 295
 296       if Declaration.Match then
 297          Files.Longest_Name := Natural'Max (File_Ref.File'Length,
 298                                             Files.Longest_Name);
 299       end if;
 300    end Add_Reference;
 301
 302    -------------------
 303    -- ALI_File_Name --
 304    -------------------
 305
 306    function ALI_File_Name (Ada_File_Name : String) return String is
 307       Index : Natural := Ada.Strings.Fixed.Index
 308                           (Ada_File_Name, ".", Going => Ada.Strings.Backward);
 309
 310    begin
 311       if Index /= 0 then
 312          return Ada_File_Name (Ada_File_Name'First .. Index)
 313            & "ali";
 314       else
 315          return Ada_File_Name & ".ali";
 316       end if;
 317    end ALI_File_Name;
 318
 319    --------------------
 320    -- Base_File_Name --
 321    --------------------
 322
 323    function Base_File_Name (File : String) return String is
 324    begin
 325       for J in reverse File'Range loop
 326          if File (J) = '/' or else File (J) = Dir_Sep then
 327             return File (J + 1 .. File'Last);
 328          end if;
 329       end loop;
 330       return File;
 331    end Base_File_Name;
 332
 333    -------------
 334    -- Compare --
 335    -------------
 336
 337    function Compare
 338      (Ref1 : Reference;
 339       Ref2 : Reference)
 340       return Compare_Result
 341    is
 342    begin
 343       if Ref1 = null then
 344          return GreaterThan;
 345       elsif Ref2 = null then
 346          return LessThan;
 347       end if;
 348
 349       if Ref1.File.File < Ref2.File.File then
 350          return LessThan;
 351
 352       elsif Ref1.File.File = Ref2.File.File then
 353          if Ref1.Line < Ref2.Line then
 354             return LessThan;
 355
 356          elsif Ref1.Line = Ref2.Line then
 357             if Ref1.Column < Ref2.Column then
 358                return LessThan;
 359             elsif Ref1.Column = Ref2.Column then
 360                return Equal;
 361             else
 362                return GreaterThan;
 363             end if;
 364
 365          else
 366             return GreaterThan;
 367          end if;
 368
 369       else
 370          return GreaterThan;
 371       end if;
 372    end Compare;
 373
 374    -------------
 375    -- Compare --
 376    -------------
 377
 378    function Compare
 379      (Decl1 : Declaration_Reference;
 380       File2 : File_Reference;
 381       Line2 : Integer;
 382       Col2  : Integer;
 383       Symb2 : String)
 384       return  Compare_Result
 385    is
 386    begin
 387       if Decl1 = null then
 388          return GreaterThan;
 389       end if;
 390
 391       if Decl1.Symbol < Symb2 then
 392          return LessThan;
 393       elsif Decl1.Symbol > Symb2 then
 394          return GreaterThan;
 395       end if;
 396
 397       if Decl1.Decl.File.File < Get_File (File2) then
 398          return LessThan;
 399
 400       elsif Decl1.Decl.File.File = Get_File (File2) then
 401          if Decl1.Decl.Line < Line2 then
 402             return LessThan;
 403
 404          elsif Decl1.Decl.Line = Line2 then
 405             if Decl1.Decl.Column < Col2 then
 406                return LessThan;
 407
 408             elsif Decl1.Decl.Column = Col2 then
 409                return Equal;
 410
 411             else
 412                return GreaterThan;
 413             end if;
 414
 415          else
 416             return GreaterThan;
 417          end if;
 418
 419       else
 420          return GreaterThan;
 421       end if;
 422    end Compare;
 423
 424    -------------------------
 425    -- Create_Project_File --
 426    -------------------------
 427
 428    procedure Create_Project_File
 429      (Name           : String)
 430    is
 431       use Ada.Strings.Unbounded;
 432
 433       Obj_Dir     : Unbounded_String := Null_Unbounded_String;
 434       Src_Dir     : Unbounded_String := Null_Unbounded_String;
 435       Build_Dir   : Unbounded_String;
 436
 437       Gnatls_Src_Cache : Unbounded_String;
 438       Gnatls_Obj_Cache : Unbounded_String;
 439
 440       F           : File_Descriptor;
 441       Len         : Positive;
 442       File_Name   : aliased String := Name & ASCII.NUL;
 443
 444    begin
 445
 446       --  Read the size of the file
 447       F := Open_Read (File_Name'Address, Text);
 448
 449       --  Project file not found
 450       if F /= Invalid_FD then
 451          Len := Positive (File_Length (F));
 452
 453          declare
 454             Buffer : String (1 .. Len);
 455             Index  : Positive := Buffer'First;
 456             Last   : Positive;
 457          begin
 458             Len := Read (F, Buffer'Address, Len);
 459             Close (F);
 460
 461             --  First, look for Build_Dir, since all the source and object
 462             --  path are relative to it.
 463
 464             while Index <= Buffer'Last loop
 465
 466                --  find the end of line
 467
 468                Last := Index;
 469                while Last <= Buffer'Last
 470                  and then Buffer (Last) /= ASCII.LF
 471                  and then Buffer (Last) /= ASCII.CR
 472                loop
 473                   Last := Last + 1;
 474                end loop;
 475
 476                if Index <= Buffer'Last - 9
 477                  and then Buffer (Index .. Index + 9) = "build_dir="
 478                then
 479                   Index := Index + 10;
 480                   while Index <= Last
 481                     and then (Buffer (Index) = ' '
 482                               or else Buffer (Index) = ASCII.HT)
 483                   loop
 484                      Index := Index + 1;
 485                   end loop;
 486
 487                   Build_Dir :=
 488                     To_Unbounded_String (Buffer (Index .. Last - 1));
 489                   if Buffer (Last - 1) /= Dir_Sep then
 490                      Append (Build_Dir, Dir_Sep);
 491                   end if;
 492                end if;
 493
 494                Index := Last + 1;
 495
 496                --  In case we had a ASCII.CR/ASCII.LF end of line, skip the
 497                --  remaining symbol
 498
 499                if Index <= Buffer'Last
 500                  and then Buffer (Index) = ASCII.LF
 501                then
 502                   Index := Index + 1;
 503                end if;
 504             end loop;
 505
 506             --  Now parse the source and object paths
 507
 508             Index := Buffer'First;
 509             while Index <= Buffer'Last loop
 510
 511                --  find the end of line
 512
 513                Last := Index;
 514                while Last <= Buffer'Last
 515                  and then Buffer (Last) /= ASCII.LF
 516                  and then Buffer (Last) /= ASCII.CR
 517                loop
 518                   Last := Last + 1;
 519                end loop;
 520
 521                if Index <= Buffer'Last - 7
 522                  and then Buffer (Index .. Index + 7) = "src_dir="
 523                then
 524                   declare
 525                      S : String := Ada.Strings.Fixed.Trim
 526                        (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both);
 527                   begin
 528                      --  A relative directory ?
 529                      if S (S'First) /= Dir_Sep then
 530                         Append (Src_Dir, Build_Dir);
 531                      end if;
 532
 533                      if S (S'Last) = Dir_Sep then
 534                         Append (Src_Dir, S & " ");
 535                      else
 536                         Append (Src_Dir, S & Dir_Sep & " ");
 537                      end if;
 538                   end;
 539
 540                elsif Index <= Buffer'Last - 7
 541                  and then Buffer (Index .. Index + 7) = "obj_dir="
 542                then
 543                   declare
 544                      S : String := Ada.Strings.Fixed.Trim
 545                        (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both);
 546                   begin
 547                      --  A relative directory ?
 548                      if S (S'First) /= Dir_Sep then
 549                         Append (Obj_Dir, Build_Dir);
 550                      end if;
 551
 552                      if S (S'Last) = Dir_Sep then
 553                         Append (Obj_Dir, S & " ");
 554                      else
 555                         Append (Obj_Dir, S & Dir_Sep & " ");
 556                      end if;
 557                   end;
 558                end if;
 559
 560                --  In case we had a ASCII.CR/ASCII.LF end of line, skip the
 561                --  remaining symbol
 562                Index := Last + 1;
 563
 564                if Index <= Buffer'Last
 565                  and then Buffer (Index) = ASCII.LF
 566                then
 567                   Index := Index + 1;
 568                end if;
 569             end loop;
 570          end;
 571       end if;
 572
 573       Parse_Gnatls (Gnatls_Src_Cache, Gnatls_Obj_Cache);
 574
 575       Directories := new Project_File'
 576         (Src_Dir_Length     => Length (Src_Dir) + Length (Gnatls_Src_Cache),
 577          Obj_Dir_Length     => Length (Obj_Dir) + Length (Gnatls_Obj_Cache),
 578          Src_Dir            => To_String (Src_Dir & Gnatls_Src_Cache),
 579          Obj_Dir            => To_String (Obj_Dir & Gnatls_Obj_Cache),
 580          Src_Dir_Index      => 1,
 581          Obj_Dir_Index      => 1,
 582          Last_Obj_Dir_Start => 0);
 583    end Create_Project_File;
 584
 585    ---------------------
 586    -- Current_Obj_Dir --
 587    ---------------------
 588
 589    function Current_Obj_Dir return String is
 590    begin
 591       return Directories.Obj_Dir (Directories.Last_Obj_Dir_Start
 592                                   .. Directories.Obj_Dir_Index - 2);
 593    end Current_Obj_Dir;
 594
 595    --------------
 596    -- Dir_Name --
 597    --------------
 598
 599    function Dir_Name (File : String; Base : String := "") return String is
 600    begin
 601       for J in reverse File'Range loop
 602          if File (J) = '/' or else File (J) = Dir_Sep then
 603
 604             --  Is this an absolute directory ?
 605             if File (File'First) = '/'
 606               or else File (File'First) = Dir_Sep
 607             then
 608                return File (File'First .. J);
 609
 610             --  Else do we know the base directory ?
 611             elsif Base /= "" then
 612                return Base & File (File'First .. J);
 613
 614             else
 615                declare
 616                   Max_Path : Integer;
 617                   pragma Import (C, Max_Path, "max_path_len");
 618
 619                   Base2 : Dir_Name_Str (1 .. Max_Path);
 620                   Last  : Natural;
 621                begin
 622                   Get_Current_Dir (Base2, Last);
 623                   return Base2 (Base2'First .. Last) & File (File'First .. J);
 624                end;
 625             end if;
 626          end if;
 627       end loop;
 628       return "";
 629    end Dir_Name;
 630
 631    -------------------
 632    -- Find_ALI_File --
 633    -------------------
 634
 635    function Find_ALI_File (Short_Name  : String) return String is
 636       use type Ada.Strings.Unbounded.String_Access;
 637       Old_Obj_Dir : constant Integer := Directories.Obj_Dir_Index;
 638
 639    begin
 640       Reset_Obj_Dir;
 641
 642       loop
 643          declare
 644             Obj_Dir : String := Next_Obj_Dir;
 645          begin
 646             exit when Obj_Dir'Length = 0;
 647             if GNAT.IO_Aux.File_Exists (Obj_Dir & Short_Name) then
 648                Directories.Obj_Dir_Index := Old_Obj_Dir;
 649                return Obj_Dir;
 650             end if;
 651          end;
 652       end loop;
 653
 654       --  Finally look in the standard directories
 655
 656       Directories.Obj_Dir_Index := Old_Obj_Dir;
 657       return "";
 658    end Find_ALI_File;
 659
 660    ----------------------
 661    -- Find_Source_File --
 662    ----------------------
 663
 664    function Find_Source_File (Short_Name  : String) return String is
 665       use type Ada.Strings.Unbounded.String_Access;
 666
 667    begin
 668       Reset_Src_Dir;
 669       loop
 670          declare
 671             Src_Dir : String := Next_Src_Dir;
 672          begin
 673             exit when Src_Dir'Length = 0;
 674
 675             if GNAT.IO_Aux.File_Exists (Src_Dir & Short_Name) then
 676                return Src_Dir;
 677             end if;
 678          end;
 679       end loop;
 680
 681       --  Finally look in the standard directories
 682
 683       return "";
 684    end Find_Source_File;
 685
 686    ----------------
 687    -- First_Body --
 688    ----------------
 689
 690    function First_Body (Decl : Declaration_Reference) return Reference is
 691    begin
 692       return Decl.Body_Ref;
 693    end First_Body;
 694
 695    -----------------------
 696    -- First_Declaration --
 697    -----------------------
 698
 699    function First_Declaration return Declaration_Reference is
 700    begin
 701       return Entities.Table;
 702    end First_Declaration;
 703
 704    -----------------
 705    -- First_Modif --
 706    -----------------
 707
 708    function First_Modif (Decl : Declaration_Reference) return Reference is
 709    begin
 710       return Decl.Modif_Ref;
 711    end First_Modif;
 712
 713    ---------------------
 714    -- First_Reference --
 715    ---------------------
 716
 717    function First_Reference (Decl : Declaration_Reference) return Reference is
 718    begin
 719       return Decl.Ref_Ref;
 720    end First_Reference;
 721
 722    ----------------
 723    -- Get_Column --
 724    ----------------
 725
 726    function Get_Column (Decl : Declaration_Reference) return String is
 727    begin
 728       return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Column),
 729                                      Ada.Strings.Left);
 730    end Get_Column;
 731
 732    function Get_Column (Ref : Reference) return String is
 733    begin
 734       return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Column),
 735                                      Ada.Strings.Left);
 736    end Get_Column;
 737
 738    ---------------------
 739    -- Get_Declaration --
 740    ---------------------
 741
 742    function Get_Declaration
 743      (File_Ref : File_Reference;
 744       Line     : Natural;
 745       Column   : Natural)
 746       return     Declaration_Reference
 747    is
 748       The_Entities : Declaration_Reference := Entities.Table;
 749    begin
 750       while The_Entities /= null loop
 751          if The_Entities.Decl.Line = Line
 752            and then The_Entities.Decl.Column = Column
 753            and then The_Entities.Decl.File = File_Ref
 754          then
 755             return The_Entities;
 756          else
 757             The_Entities := The_Entities.Next;
 758          end if;
 759       end loop;
 760
 761       return Empty_Declaration;
 762    end Get_Declaration;
 763
 764    ----------------------
 765    -- Get_Emit_Warning --
 766    ----------------------
 767
 768    function Get_Emit_Warning (File : File_Reference) return Boolean is
 769    begin
 770       return File.Emit_Warning;
 771    end Get_Emit_Warning;
 772
 773    --------------
 774    -- Get_File --
 775    --------------
 776
 777    function Get_File
 778      (Decl     : Declaration_Reference;
 779       With_Dir : Boolean := False)
 780       return     String
 781    is
 782    begin
 783       return Get_File (Decl.Decl.File, With_Dir);
 784    end Get_File;
 785
 786    function Get_File
 787      (Ref      : Reference;
 788       With_Dir : Boolean := False)
 789       return     String
 790    is
 791    begin
 792       return Get_File (Ref.File, With_Dir);
 793    end Get_File;
 794
 795    function Get_File
 796      (File     : File_Reference;
 797       With_Dir : in Boolean := False;
 798       Strip    : Natural := 0)
 799       return     String
 800    is
 801       function Internal_Strip (Full_Name : String) return String;
 802       --  Internal function to process the Strip parameter
 803
 804       --------------------
 805       -- Internal_Strip --
 806       --------------------
 807
 808       function Internal_Strip (Full_Name : String) return String is
 809          Unit_End, Extension_Start : Natural;
 810          S : Natural := Strip;
 811       begin
 812          if Strip = 0 then
 813             return Full_Name;
 814          end if;
 815
 816          --  Isolate the file extension
 817
 818          Extension_Start := Full_Name'Last;
 819          while Extension_Start >= Full_Name'First
 820            and then Full_Name (Extension_Start) /= '.'
 821          loop
 822             Extension_Start := Extension_Start - 1;
 823          end loop;
 824
 825          --  Strip the right number of subunit_names
 826
 827          Unit_End := Extension_Start - 1;
 828          while Unit_End >= Full_Name'First
 829            and then S > 0
 830          loop
 831             if Full_Name (Unit_End) = '-' then
 832                S := S - 1;
 833             end if;
 834             Unit_End := Unit_End - 1;
 835          end loop;
 836
 837          if Unit_End < Full_Name'First then
 838             return "";
 839          else
 840             return Full_Name (Full_Name'First .. Unit_End)
 841               & Full_Name (Extension_Start .. Full_Name'Last);
 842          end if;
 843       end Internal_Strip;
 844
 845    begin
 846       --  If we do not want the full path name
 847
 848       if not With_Dir then
 849          return Internal_Strip (File.File);
 850       end if;
 851
 852       if File.Dir = null then
 853
 854          if Ada.Strings.Fixed.Tail (File.File, 3) = "ali" then
 855             File.Dir := new String'(Find_ALI_File (File.File));
 856          else
 857             File.Dir := new String'(Find_Source_File (File.File));
 858          end if;
 859       end if;
 860
 861       return Internal_Strip (File.Dir.all & File.File);
 862    end Get_File;
 863
 864    ------------------
 865    -- Get_File_Ref --
 866    ------------------
 867
 868    function Get_File_Ref (Ref : Reference) return File_Reference is
 869    begin
 870       return Ref.File;
 871    end Get_File_Ref;
 872
 873    -----------------------
 874    -- Get_Gnatchop_File --
 875    -----------------------
 876
 877    function Get_Gnatchop_File
 878      (File : File_Reference; With_Dir : Boolean := False) return String is
 879    begin
 880       if File.Gnatchop_File.all = "" then
 881          return Get_File (File, With_Dir);
 882       else
 883          return File.Gnatchop_File.all;
 884       end if;
 885    end Get_Gnatchop_File;
 886
 887    -----------------------
 888    -- Get_Gnatchop_File --
 889    -----------------------
 890
 891    function Get_Gnatchop_File
 892      (Ref : Reference; With_Dir : Boolean := False) return String is
 893    begin
 894       return Get_Gnatchop_File (Ref.File, With_Dir);
 895    end Get_Gnatchop_File;
 896
 897    -----------------------
 898    -- Get_Gnatchop_File --
 899    -----------------------
 900
 901    function Get_Gnatchop_File
 902      (Decl : Declaration_Reference; With_Dir : Boolean := False) return String
 903    is
 904    begin
 905       return Get_Gnatchop_File (Decl.Decl.File, With_Dir);
 906    end Get_Gnatchop_File;
 907
 908    --------------
 909    -- Get_Line --
 910    --------------
 911
 912    function Get_Line (Decl : Declaration_Reference) return String is
 913    begin
 914       return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Line),
 915                                      Ada.Strings.Left);
 916    end Get_Line;
 917
 918    function Get_Line (Ref : Reference) return String is
 919    begin
 920       return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Line),
 921                                      Ada.Strings.Left);
 922    end Get_Line;
 923
 924    ----------------
 925    -- Get_Parent --
 926    ----------------
 927
 928    function Get_Parent
 929      (Decl : Declaration_Reference)
 930      return Declaration_Reference is
 931    begin
 932       return Decl.Par_Symbol;
 933    end Get_Parent;
 934
 935    ---------------------
 936    -- Get_Source_Line --
 937    ---------------------
 938
 939    function Get_Source_Line (Ref : Reference) return String is
 940    begin
 941       return To_String (Ref.Source_Line);
 942    end Get_Source_Line;
 943
 944    function Get_Source_Line (Decl : Declaration_Reference) return String is
 945    begin
 946       return To_String (Decl.Decl.Source_Line);
 947    end Get_Source_Line;
 948
 949    ----------------
 950    -- Get_Symbol --
 951    ----------------
 952
 953    function Get_Symbol (Decl : Declaration_Reference) return String is
 954    begin
 955       return Decl.Symbol;
 956    end Get_Symbol;
 957
 958    --------------
 959    -- Get_Type --
 960    --------------
 961
 962    function Get_Type (Decl : Declaration_Reference) return Character is
 963    begin
 964       return Decl.Decl_Type;
 965    end Get_Type;
 966
 967    -----------------------
 968    -- Grep_Source_Files --
 969    -----------------------
 970
 971    procedure Grep_Source_Files is
 972       Decl : Declaration_Reference := First_Declaration;
 973
 974       type Simple_Ref;
 975       type Simple_Ref_Access is access Simple_Ref;
 976       type Simple_Ref is
 977          record
 978             Ref  : Reference;
 979             Next : Simple_Ref_Access;
 980          end record;
 981       List : Simple_Ref_Access := null;
 982       --  This structure is used to speed up the parsing of Ada sources:
 983       --  Every reference found by parsing the .ali files is inserted in this
 984       --  list, sorted by filename and line numbers.
 985       --  This allows use not to parse a same ada file multiple times
 986
 987       procedure Free is new Unchecked_Deallocation
 988         (Simple_Ref, Simple_Ref_Access);
 989       --  Clear an element of the list
 990
 991       procedure Grep_List;
 992       --  For each reference in the list, parse the file and find the
 993       --  source line
 994
 995       procedure Insert_In_Order (Ref  : Reference);
 996       --  Insert a new reference in the list, ordered by line numbers
 997
 998       procedure Insert_List_Ref (First_Ref : Reference);
 999       --  Process a list of references
1000
1001       ---------------
1002       -- Grep_List --
1003       ---------------
1004
1005       procedure Grep_List is
1006          Line         : String (1 .. 1024);
1007          Last         : Natural;
1008          File         : Ada.Text_IO.File_Type;
1009          Line_Number  : Natural;
1010          Pos          : Natural;
1011          Save_List    : Simple_Ref_Access := List;
1012          Current_File : File_Reference;
1013
1014       begin
1015          while List /= null loop
1016
1017             --  Makes sure we can find and read the file
1018
1019             Current_File := List.Ref.File;
1020             Line_Number  := 0;
1021
1022             begin
1023                Ada.Text_IO.Open (File,
1024                                  Ada.Text_IO.In_File,
1025                                  Get_File (List.Ref, True));
1026
1027                --  Read the file and find every relevant lines
1028
1029                while List /= null
1030                  and then List.Ref.File = Current_File
1031                  and then not Ada.Text_IO.End_Of_File (File)
1032                loop
1033                   Ada.Text_IO.Get_Line (File, Line, Last);
1034                   Line_Number := Line_Number + 1;
1035
1036                   while List /= null
1037                     and then Line_Number = List.Ref.Line
1038                   loop
1039
1040                      --  Skip the leading blanks on the line
1041
1042                      Pos := 1;
1043                      while Line (Pos) = ' '
1044                        or else Line (Pos) = ASCII.HT
1045                      loop
1046                         Pos := Pos + 1;
1047                      end loop;
1048
1049                      List.Ref.Source_Line :=
1050                        To_Unbounded_String (Line (Pos .. Last));
1051
1052                      --  Find the next element in the list
1053
1054                      List := List.Next;
1055                   end loop;
1056
1057                end loop;
1058
1059                Ada.Text_IO.Close (File);
1060
1061                --  If the Current_File was not found, just skip it
1062
1063             exception
1064                when Ada.IO_Exceptions.Name_Error =>
1065                   null;
1066             end;
1067
1068             --  If the line or the file were not found
1069
1070             while List /= null
1071               and then List.Ref.File = Current_File
1072             loop
1073                List := List.Next;
1074             end loop;
1075
1076          end loop;
1077
1078          --  Clear the list
1079
1080          while Save_List /= null loop
1081             List      := Save_List;
1082             Save_List := Save_List.Next;
1083             Free (List);
1084          end loop;
1085       end Grep_List;
1086
1087       ---------------------
1088       -- Insert_In_Order --
1089       ---------------------
1090
1091       procedure Insert_In_Order (Ref : Reference) is
1092          Iter : Simple_Ref_Access := List;
1093          Prev : Simple_Ref_Access := null;
1094
1095       begin
1096          while Iter /= null loop
1097
1098             --  If we have found the file, sort by lines
1099
1100             if Iter.Ref.File = Ref.File then
1101
1102                while Iter /= null
1103                  and then Iter.Ref.File = Ref.File
1104                loop
1105                   if Iter.Ref.Line > Ref.Line then
1106
1107                      if Iter = List then
1108                         List := new Simple_Ref'(Ref, List);
1109                      else
1110                         Prev.Next := new Simple_Ref'(Ref, Iter);
1111                      end if;
1112                      return;
1113                   end if;
1114
1115                   Prev := Iter;
1116                   Iter := Iter.Next;
1117                end loop;
1118
1119                if Iter = List then
1120                   List := new Simple_Ref'(Ref, List);
1121                else
1122                   Prev.Next := new Simple_Ref'(Ref, Iter);
1123                end if;
1124                return;
1125             end if;
1126
1127             Prev := Iter;
1128             Iter := Iter.Next;
1129          end loop;
1130
1131          --  The file was not already in the list, insert it
1132
1133          List := new Simple_Ref'(Ref, List);
1134       end Insert_In_Order;
1135
1136       ---------------------
1137       -- Insert_List_Ref --
1138       ---------------------
1139
1140       procedure Insert_List_Ref (First_Ref : Reference) is
1141          Ref : Reference := First_Ref;
1142
1143       begin
1144          while Ref /= Empty_Reference loop
1145             Insert_In_Order (Ref);
1146             Ref := Next (Ref);
1147          end loop;
1148       end Insert_List_Ref;
1149
1150    --  Start of processing for Grep_Source_Files
1151
1152    begin
1153       while Decl /= Empty_Declaration loop
1154          Insert_In_Order (Decl.Decl'Access);
1155          Insert_List_Ref (First_Body (Decl));
1156          Insert_List_Ref (First_Reference (Decl));
1157          Insert_List_Ref (First_Modif (Decl));
1158          Decl := Next (Decl);
1159       end loop;
1160
1161       Grep_List;
1162    end Grep_Source_Files;
1163
1164    -----------------------
1165    -- Longest_File_Name --
1166    -----------------------
1167
1168    function Longest_File_Name return Natural is
1169    begin
1170       return Files.Longest_Name;
1171    end Longest_File_Name;
1172
1173    -----------
1174    -- Match --
1175    -----------
1176
1177    function Match
1178      (File   : File_Reference;
1179       Line   : Natural;
1180       Column : Natural)
1181       return   Boolean
1182    is
1183       Ref : Ref_In_File_Ptr := File.Lines;
1184
1185    begin
1186       while Ref /= null loop
1187          if (Ref.Line = 0 or else Ref.Line = Line)
1188            and then (Ref.Column = 0 or else Ref.Column = Column)
1189          then
1190             return True;
1191          end if;
1192
1193          Ref := Ref.Next;
1194       end loop;
1195
1196       return False;
1197    end Match;
1198
1199    -----------
1200    -- Match --
1201    -----------
1202
1203    function Match (Decl : Declaration_Reference) return Boolean is
1204    begin
1205       return Decl.Match;
1206    end Match;
1207
1208    ----------
1209    -- Next --
1210    ----------
1211
1212    function Next (Decl : Declaration_Reference) return Declaration_Reference is
1213    begin
1214       return Decl.Next;
1215    end Next;
1216
1217    ----------
1218    -- Next --
1219    ----------
1220
1221    function Next (Ref : Reference) return Reference is
1222    begin
1223       return Ref.Next;
1224    end Next;
1225
1226    ------------------
1227    -- Next_Obj_Dir --
1228    ------------------
1229
1230    function Next_Obj_Dir return String is
1231       First : Integer := Directories.Obj_Dir_Index;
1232       Last  : Integer := Directories.Obj_Dir_Index;
1233
1234    begin
1235       if Last > Directories.Obj_Dir_Length then
1236          return String'(1 .. 0 => ' ');
1237       end if;
1238
1239       while Directories.Obj_Dir (Last) /= ' ' loop
1240          Last := Last + 1;
1241       end loop;
1242
1243       Directories.Obj_Dir_Index := Last + 1;
1244       Directories.Last_Obj_Dir_Start := First;
1245       return Directories.Obj_Dir (First .. Last - 1);
1246    end Next_Obj_Dir;
1247
1248    ------------------
1249    -- Next_Src_Dir --
1250    ------------------
1251
1252    function Next_Src_Dir return String is
1253       First : Integer := Directories.Src_Dir_Index;
1254       Last  : Integer := Directories.Src_Dir_Index;
1255
1256    begin
1257       if Last > Directories.Src_Dir_Length then
1258          return String'(1 .. 0 => ' ');
1259       end if;
1260
1261       while Directories.Src_Dir (Last) /= ' ' loop
1262          Last := Last + 1;
1263       end loop;
1264
1265       Directories.Src_Dir_Index := Last + 1;
1266       return Directories.Src_Dir (First .. Last - 1);
1267    end Next_Src_Dir;
1268
1269    -------------------------
1270    -- Next_Unvisited_File --
1271    -------------------------
1272
1273    function Next_Unvisited_File return File_Reference is
1274       The_Files : File_Reference := Files.Table;
1275
1276    begin
1277       while The_Files /= null loop
1278          if not The_Files.Visited then
1279             The_Files.Visited := True;
1280             return The_Files;
1281          end if;
1282
1283          The_Files := The_Files.Next;
1284       end loop;
1285
1286       return Empty_File;
1287    end Next_Unvisited_File;
1288
1289    ------------------
1290    -- Parse_Gnatls --
1291    ------------------
1292
1293    procedure Parse_Gnatls
1294      (Gnatls_Src_Cache : out Ada.Strings.Unbounded.Unbounded_String;
1295       Gnatls_Obj_Cache : out Ada.Strings.Unbounded.Unbounded_String)
1296    is
1297    begin
1298       Osint.Add_Default_Search_Dirs;
1299
1300       for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
1301          if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
1302             Ada.Strings.Unbounded.Append (Gnatls_Src_Cache, "./" & ' ');
1303          else
1304             Ada.Strings.Unbounded.Append
1305               (Gnatls_Src_Cache, Osint.Dir_In_Src_Search_Path (J).all & ' ');
1306          end if;
1307       end loop;
1308
1309       for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
1310          if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
1311             Ada.Strings.Unbounded.Append (Gnatls_Obj_Cache, "./" & ' ');
1312          else
1313             Ada.Strings.Unbounded.Append
1314               (Gnatls_Obj_Cache, Osint.Dir_In_Obj_Search_Path (J).all & ' ');
1315          end if;
1316       end loop;
1317    end Parse_Gnatls;
1318
1319    -------------------
1320    -- Reset_Obj_Dir --
1321    -------------------
1322
1323    procedure Reset_Obj_Dir is
1324    begin
1325       Directories.Obj_Dir_Index := 1;
1326    end Reset_Obj_Dir;
1327
1328    -------------------
1329    -- Reset_Src_Dir --
1330    -------------------
1331
1332    procedure Reset_Src_Dir is
1333    begin
1334       Directories.Src_Dir_Index := 1;
1335    end Reset_Src_Dir;
1336
1337    -----------------------
1338    -- Set_Default_Match --
1339    -----------------------
1340
1341    procedure Set_Default_Match (Value : Boolean) is
1342    begin
1343       Default_Match := Value;
1344    end Set_Default_Match;
1345
1346    -------------------
1347    -- Set_Directory --
1348    -------------------
1349
1350    procedure Set_Directory
1351      (File : in File_Reference;
1352       Dir  : in String)
1353    is
1354    begin
1355       File.Dir := new String'(Dir);
1356    end Set_Directory;
1357
1358    -------------------
1359    -- Set_Unvisited --
1360    -------------------
1361
1362    procedure Set_Unvisited (File_Ref : in File_Reference) is
1363       The_Files : File_Reference := Files.Table;
1364
1365    begin
1366       while The_Files /= null loop
1367          if The_Files = File_Ref then
1368             The_Files.Visited := False;
1369             return;
1370          end if;
1371
1372          The_Files := The_Files.Next;
1373       end loop;
1374    end Set_Unvisited;
1375
1376 end Xr_Tabls;