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