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