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-2012, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Types;    use Types;
  27 with Osint;
  28 with Hostparm;
  29
  30 with Ada.Unchecked_Conversion;
  31 with Ada.Unchecked_Deallocation;
  32 with Ada.Strings.Fixed;
  33 with Ada.Strings;
  34 with Ada.Text_IO;
  35 with Ada.Characters.Handling;   use Ada.Characters.Handling;
  36 with Ada.Strings.Unbounded;     use Ada.Strings.Unbounded;
  37
  38 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  39 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  40 with GNAT.HTable;               use GNAT.HTable;
  41 with GNAT.Heap_Sort_G;
  42
  43 package body Xr_Tabls is
  44
  45    type HTable_Headers is range 1 .. 10000;
  46
  47    procedure Set_Next (E : File_Reference; Next : File_Reference);
  48    function  Next (E : File_Reference) return File_Reference;
  49    function  Get_Key (E : File_Reference) return Cst_String_Access;
  50    function  Hash (F : Cst_String_Access) return HTable_Headers;
  51    function  Equal (F1, F2 : Cst_String_Access) return Boolean;
  52    --  The five subprograms above are used to instantiate the static
  53    --  htable to store the files that should be processed.
  54
  55    package File_HTable is new GNAT.HTable.Static_HTable
  56      (Header_Num => HTable_Headers,
  57       Element    => File_Record,
  58       Elmt_Ptr   => File_Reference,
  59       Null_Ptr   => null,
  60       Set_Next   => Set_Next,
  61       Next       => Next,
  62       Key        => Cst_String_Access,
  63       Get_Key    => Get_Key,
  64       Hash       => Hash,
  65       Equal      => Equal);
  66    --  A hash table to store all the files referenced in the
  67    --  application.  The keys in this htable are the name of the files
  68    --  themselves, therefore it is assumed that the source path
  69    --  doesn't contain twice the same source or ALI file name
  70
  71    type Unvisited_Files_Record;
  72    type Unvisited_Files_Access is access Unvisited_Files_Record;
  73    type Unvisited_Files_Record is record
  74       File : File_Reference;
  75       Next : Unvisited_Files_Access;
  76    end record;
  77    --  A special list, in addition to File_HTable, that only stores
  78    --  the files that haven't been visited so far. Note that the File
  79    --  list points to some data in File_HTable, and thus should never be freed.
  80
  81    function Next (E : Declaration_Reference) return Declaration_Reference;
  82    procedure Set_Next (E, Next : Declaration_Reference);
  83    function  Get_Key (E : Declaration_Reference) return Cst_String_Access;
  84    --  The subprograms above are used to instantiate the static
  85    --  htable to store the entities that have been found in the application
  86
  87    package Entities_HTable is new GNAT.HTable.Static_HTable
  88      (Header_Num => HTable_Headers,
  89       Element    => Declaration_Record,
  90       Elmt_Ptr   => Declaration_Reference,
  91       Null_Ptr   => null,
  92       Set_Next   => Set_Next,
  93       Next       => Next,
  94       Key        => Cst_String_Access,
  95       Get_Key    => Get_Key,
  96       Hash       => Hash,
  97       Equal      => Equal);
  98    --  A hash table to store all the entities defined in the
  99    --  application. For each entity, we store a list of its reference
 100    --  locations as well.
 101    --  The keys in this htable should be created with Key_From_Ref,
 102    --  and are the file, line and column of the declaration, which are
 103    --  unique for every entity.
 104
 105    Entities_Count : Natural := 0;
 106    --  Number of entities in Entities_HTable. This is used in the end
 107    --  when sorting the table.
 108
 109    Longest_File_Name_In_Table : Natural := 0;
 110    Unvisited_Files            : Unvisited_Files_Access := null;
 111    Directories                : Project_File_Ptr;
 112    Default_Match              : Boolean := False;
 113    --  The above need commenting ???
 114
 115    function Parse_Gnatls_Src return String;
 116    --  Return the standard source directories (taking into account the
 117    --  ADA_INCLUDE_PATH environment variable, if Osint.Add_Default_Search_Dirs
 118    --  was called first).
 119
 120    function Parse_Gnatls_Obj return String;
 121    --  Return the standard object directories (taking into account the
 122    --  ADA_OBJECTS_PATH environment variable).
 123
 124    function Key_From_Ref
 125      (File_Ref  : File_Reference;
 126       Line      : Natural;
 127       Column    : Natural)
 128       return      String;
 129    --  Return a key for the symbol declared at File_Ref, Line,
 130    --  Column. This key should be used for lookup in Entity_HTable
 131
 132    function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean;
 133    --  Compare two declarations (the comparison is case-insensitive)
 134
 135    function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean;
 136    --  Compare two references
 137
 138    procedure Store_References
 139      (Decl            : Declaration_Reference;
 140       Get_Writes      : Boolean := False;
 141       Get_Reads       : Boolean := False;
 142       Get_Bodies      : Boolean := False;
 143       Get_Declaration : Boolean := False;
 144       Arr             : in out Reference_Array;
 145       Index           : in out Natural);
 146    --  Store in Arr, starting at Index, all the references to Decl. The Get_*
 147    --  parameters can be used to indicate which references should be stored.
 148    --  Constraint_Error will be raised if Arr is not big enough.
 149
 150    procedure Sort (Arr : in out Reference_Array);
 151    --  Sort an array of references (Arr'First must be 1)
 152
 153    --------------
 154    -- Set_Next --
 155    --------------
 156
 157    procedure Set_Next (E : File_Reference; Next : File_Reference) is
 158    begin
 159       E.Next := Next;
 160    end Set_Next;
 161
 162    procedure Set_Next
 163      (E : Declaration_Reference; Next : Declaration_Reference) is
 164    begin
 165       E.Next := Next;
 166    end Set_Next;
 167
 168    -------------
 169    -- Get_Key --
 170    -------------
 171
 172    function Get_Key (E : File_Reference) return Cst_String_Access is
 173    begin
 174       return E.File;
 175    end Get_Key;
 176
 177    function Get_Key (E : Declaration_Reference) return Cst_String_Access is
 178    begin
 179       return E.Key;
 180    end Get_Key;
 181
 182    ----------
 183    -- Hash --
 184    ----------
 185
 186    function Hash (F : Cst_String_Access) return HTable_Headers is
 187       function H is new GNAT.HTable.Hash (HTable_Headers);
 188
 189    begin
 190       return H (F.all);
 191    end Hash;
 192
 193    -----------
 194    -- Equal --
 195    -----------
 196
 197    function Equal (F1, F2 : Cst_String_Access) return Boolean is
 198    begin
 199       return F1.all = F2.all;
 200    end Equal;
 201
 202    ------------------
 203    -- Key_From_Ref --
 204    ------------------
 205
 206    function Key_From_Ref
 207      (File_Ref : File_Reference;
 208       Line     : Natural;
 209       Column   : Natural)
 210       return     String
 211    is
 212    begin
 213       return File_Ref.File.all & Natural'Image (Line) & Natural'Image (Column);
 214    end Key_From_Ref;
 215
 216    ---------------------
 217    -- Add_Declaration --
 218    ---------------------
 219
 220    function Add_Declaration
 221      (File_Ref     : File_Reference;
 222       Symbol       : String;
 223       Line         : Natural;
 224       Column       : Natural;
 225       Decl_Type    : Character;
 226       Is_Parameter : Boolean := False;
 227       Remove_Only  : Boolean := False;
 228       Symbol_Match : Boolean := True)
 229       return         Declaration_Reference
 230    is
 231       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 232         (Declaration_Record, Declaration_Reference);
 233
 234       Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
 235
 236       New_Decl : Declaration_Reference :=
 237                    Entities_HTable.Get (Key'Unchecked_Access);
 238
 239       Is_Param : Boolean := Is_Parameter;
 240
 241    begin
 242       --  Insert the Declaration in the table. There might already be a
 243       --  declaration in the table if the entity is a parameter, so we
 244       --  need to check that first.
 245
 246       if New_Decl /= null and then New_Decl.Symbol_Length = 0 then
 247          Is_Param := Is_Parameter or else New_Decl.Is_Parameter;
 248          Entities_HTable.Remove (Key'Unrestricted_Access);
 249          Entities_Count := Entities_Count - 1;
 250          Free (New_Decl.Key);
 251          Unchecked_Free (New_Decl);
 252          New_Decl := null;
 253       end if;
 254
 255       --  The declaration might also already be there for parent types. In
 256       --  this case, we should keep the entry, since some other entries are
 257       --  pointing to it.
 258
 259       if New_Decl = null
 260         and then not Remove_Only
 261       then
 262          New_Decl :=
 263            new Declaration_Record'
 264              (Symbol_Length => Symbol'Length,
 265               Symbol        => Symbol,
 266               Key           => new String'(Key),
 267               Decl          => new Reference_Record'
 268                                      (File          => File_Ref,
 269                                       Line          => Line,
 270                                       Column        => Column,
 271                                       Source_Line   => null,
 272                                       Next          => null),
 273               Is_Parameter  => Is_Param,
 274               Decl_Type     => Decl_Type,
 275               Body_Ref      => null,
 276               Ref_Ref       => null,
 277               Modif_Ref     => null,
 278               Match         => Symbol_Match
 279                                  and then
 280                                    (Default_Match
 281                                      or else Match (File_Ref, Line, Column)),
 282               Par_Symbol    => null,
 283               Next          => null);
 284
 285          Entities_HTable.Set (New_Decl);
 286          Entities_Count := Entities_Count + 1;
 287
 288          if New_Decl.Match then
 289             Longest_File_Name_In_Table :=
 290               Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
 291          end if;
 292
 293       elsif New_Decl /= null
 294         and then not New_Decl.Match
 295       then
 296          New_Decl.Match := Default_Match
 297            or else Match (File_Ref, Line, Column);
 298          New_Decl.Is_Parameter := New_Decl.Is_Parameter or Is_Param;
 299
 300       elsif New_Decl /= null then
 301          New_Decl.Is_Parameter := New_Decl.Is_Parameter or Is_Param;
 302       end if;
 303
 304       return New_Decl;
 305    end Add_Declaration;
 306
 307    ----------------------
 308    -- Add_To_Xref_File --
 309    ----------------------
 310
 311    function Add_To_Xref_File
 312      (File_Name       : String;
 313       Visited         : Boolean := True;
 314       Emit_Warning    : Boolean := False;
 315       Gnatchop_File   : String  := "";
 316       Gnatchop_Offset : Integer := 0) return File_Reference
 317    is
 318       Base    : aliased constant String := Base_Name (File_Name);
 319       Dir     : constant String := Dir_Name (File_Name);
 320       Dir_Acc : GNAT.OS_Lib.String_Access   := null;
 321       Ref     : File_Reference;
 322
 323    begin
 324       --  Do we have a directory name as well?
 325
 326       if File_Name /= Base then
 327          Dir_Acc := new String'(Dir);
 328       end if;
 329
 330       Ref := File_HTable.Get (Base'Unchecked_Access);
 331       if Ref = null then
 332          Ref := new File_Record'
 333            (File            => new String'(Base),
 334             Dir             => Dir_Acc,
 335             Lines           => null,
 336             Visited         => Visited,
 337             Emit_Warning    => Emit_Warning,
 338             Gnatchop_File   => new String'(Gnatchop_File),
 339             Gnatchop_Offset => Gnatchop_Offset,
 340             Next            => null);
 341          File_HTable.Set (Ref);
 342
 343          if not Visited then
 344
 345             --  Keep a separate list for faster access
 346
 347             Set_Unvisited (Ref);
 348          end if;
 349       end if;
 350       return Ref;
 351    end Add_To_Xref_File;
 352
 353    --------------
 354    -- Add_Line --
 355    --------------
 356
 357    procedure Add_Line
 358      (File   : File_Reference;
 359       Line   : Natural;
 360       Column : Natural)
 361    is
 362    begin
 363       File.Lines := new Ref_In_File'(Line   => Line,
 364                                      Column => Column,
 365                                      Next   => File.Lines);
 366    end Add_Line;
 367
 368    ----------------
 369    -- Add_Parent --
 370    ----------------
 371
 372    procedure Add_Parent
 373      (Declaration : in out Declaration_Reference;
 374       Symbol      : String;
 375       Line        : Natural;
 376       Column      : Natural;
 377       File_Ref    : File_Reference)
 378    is
 379    begin
 380       Declaration.Par_Symbol :=
 381         Add_Declaration
 382           (File_Ref, Symbol, Line, Column,
 383            Decl_Type    => ' ',
 384            Symbol_Match => False);
 385    end Add_Parent;
 386
 387    -------------------
 388    -- Add_Reference --
 389    -------------------
 390
 391    procedure Add_Reference
 392      (Declaration   : Declaration_Reference;
 393       File_Ref      : File_Reference;
 394       Line          : Natural;
 395       Column        : Natural;
 396       Ref_Type      : Character;
 397       Labels_As_Ref : Boolean)
 398    is
 399       New_Ref : Reference;
 400       New_Decl : Declaration_Reference;
 401       pragma Unreferenced (New_Decl);
 402
 403    begin
 404       case Ref_Type is
 405          when 'b' | 'c' | 'H' | 'm' | 'o' | 'r' | 'R' |
 406               's' | 'i' | ' ' | 'x' =>
 407             null;
 408
 409          when 'l' | 'w' =>
 410             if not Labels_As_Ref then
 411                return;
 412             end if;
 413
 414          when '=' | '<' | '>' | '^' =>
 415
 416             --  Create dummy declaration in table to report it as a parameter
 417
 418             --  In a given ALI file, the declaration of the subprogram comes
 419             --  before the declaration of the parameter. However, it is
 420             --  possible that another ALI file has been parsed that also
 421             --  references the parameter (for instance a named parameter in
 422             --  a call), so we need to check whether there already exists a
 423             --  declaration for the parameter.
 424
 425             New_Decl :=
 426               Add_Declaration
 427                 (File_Ref     => File_Ref,
 428                  Symbol       => "",
 429                  Line         => Line,
 430                  Column       => Column,
 431                  Decl_Type    => ' ',
 432                  Is_Parameter => True);
 433
 434          when 'e' | 'z' | 't' | 'p' | 'P' | 'k' | 'd' =>
 435             return;
 436
 437          when others    =>
 438             Ada.Text_IO.Put_Line ("Unknown reference type: " & Ref_Type);
 439             return;
 440       end case;
 441
 442       New_Ref := new Reference_Record'
 443         (File        => File_Ref,
 444          Line        => Line,
 445          Column      => Column,
 446          Source_Line => null,
 447          Next        => null);
 448
 449       --  We can insert the reference into the list directly, since all the
 450       --  references will appear only once in the ALI file corresponding to the
 451       --  file where they are referenced. This saves a lot of time compared to
 452       --  checking the list to check if it exists.
 453
 454       case Ref_Type is
 455          when 'b' | 'c' =>
 456             New_Ref.Next          := Declaration.Body_Ref;
 457             Declaration.Body_Ref  := New_Ref;
 458
 459          when 'r' | 'R' | 's' | 'H' | 'i' | 'l' | 'o' | ' ' | 'x' | 'w' =>
 460             New_Ref.Next          := Declaration.Ref_Ref;
 461             Declaration.Ref_Ref   := New_Ref;
 462
 463          when 'm' =>
 464             New_Ref.Next          := Declaration.Modif_Ref;
 465             Declaration.Modif_Ref := New_Ref;
 466
 467          when others =>
 468             null;
 469       end case;
 470
 471       if not Declaration.Match then
 472          Declaration.Match := Match (File_Ref, Line, Column);
 473       end if;
 474
 475       if Declaration.Match then
 476          Longest_File_Name_In_Table :=
 477            Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
 478       end if;
 479    end Add_Reference;
 480
 481    -------------------
 482    -- ALI_File_Name --
 483    -------------------
 484
 485    function ALI_File_Name (Ada_File_Name : String) return String is
 486
 487       --  ??? Should ideally be based on the naming scheme defined in
 488       --  project files.
 489
 490       Index : constant Natural :=
 491                 Ada.Strings.Fixed.Index
 492                   (Ada_File_Name, ".", Going => Ada.Strings.Backward);
 493
 494    begin
 495       if Index /= 0 then
 496          return Ada_File_Name (Ada_File_Name'First .. Index)
 497            & Osint.ALI_Suffix.all;
 498       else
 499          return Ada_File_Name & "." & Osint.ALI_Suffix.all;
 500       end if;
 501    end ALI_File_Name;
 502
 503    ------------------
 504    -- Is_Less_Than --
 505    ------------------
 506
 507    function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean is
 508    begin
 509       if Ref1 = null then
 510          return False;
 511       elsif Ref2 = null then
 512          return True;
 513       end if;
 514
 515       if Ref1.File.File.all < Ref2.File.File.all then
 516          return True;
 517
 518       elsif Ref1.File.File.all = Ref2.File.File.all then
 519          return (Ref1.Line < Ref2.Line
 520                  or else (Ref1.Line = Ref2.Line
 521                           and then Ref1.Column < Ref2.Column));
 522       end if;
 523
 524       return False;
 525    end Is_Less_Than;
 526
 527    ------------------
 528    -- Is_Less_Than --
 529    ------------------
 530
 531    function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean
 532    is
 533       --  We cannot store the data case-insensitive in the table,
 534       --  since we wouldn't be able to find the right casing for the
 535       --  display later on.
 536
 537       S1 : constant String := To_Lower (Decl1.Symbol);
 538       S2 : constant String := To_Lower (Decl2.Symbol);
 539
 540    begin
 541       if S1 < S2 then
 542          return True;
 543       elsif S1 > S2 then
 544          return False;
 545       end if;
 546
 547       return Decl1.Key.all < Decl2.Key.all;
 548    end Is_Less_Than;
 549
 550    -------------------------
 551    -- Create_Project_File --
 552    -------------------------
 553
 554    procedure Create_Project_File (Name : String) is
 555       Obj_Dir     : Unbounded_String := Null_Unbounded_String;
 556       Src_Dir     : Unbounded_String := Null_Unbounded_String;
 557       Build_Dir   : GNAT.OS_Lib.String_Access := new String'("");
 558
 559       F           : File_Descriptor;
 560       Len         : Positive;
 561       File_Name   : aliased String := Name & ASCII.NUL;
 562
 563    begin
 564       --  Read the size of the file
 565
 566       F := Open_Read (File_Name'Address, Text);
 567
 568       --  Project file not found
 569
 570       if F /= Invalid_FD then
 571          Len := Positive (File_Length (F));
 572
 573          declare
 574             Buffer : String (1 .. Len);
 575             Index  : Positive := Buffer'First;
 576             Last   : Positive;
 577
 578          begin
 579             Len := Read (F, Buffer'Address, Len);
 580             Close (F);
 581
 582             --  First, look for Build_Dir, since all the source and object
 583             --  path are relative to it.
 584
 585             while Index <= Buffer'Last loop
 586
 587                --  Find the end of line
 588
 589                Last := Index;
 590                while Last <= Buffer'Last
 591                  and then Buffer (Last) /= ASCII.LF
 592                  and then Buffer (Last) /= ASCII.CR
 593                loop
 594                   Last := Last + 1;
 595                end loop;
 596
 597                if Index <= Buffer'Last - 9
 598                  and then Buffer (Index .. Index + 9) = "build_dir="
 599                then
 600                   Index := Index + 10;
 601                   while Index <= Last
 602                     and then (Buffer (Index) = ' '
 603                               or else Buffer (Index) = ASCII.HT)
 604                   loop
 605                      Index := Index + 1;
 606                   end loop;
 607
 608                   Free (Build_Dir);
 609                   Build_Dir := new String'(Buffer (Index .. Last - 1));
 610                end if;
 611
 612                Index := Last + 1;
 613
 614                --  In case we had a ASCII.CR/ASCII.LF end of line, skip the
 615                --  remaining symbol
 616
 617                if Index <= Buffer'Last
 618                  and then Buffer (Index) = ASCII.LF
 619                then
 620                   Index := Index + 1;
 621                end if;
 622             end loop;
 623
 624             --  Now parse the source and object paths
 625
 626             Index := Buffer'First;
 627             while Index <= Buffer'Last loop
 628
 629                --  Find the end of line
 630
 631                Last := Index;
 632                while Last <= Buffer'Last
 633                  and then Buffer (Last) /= ASCII.LF
 634                  and then Buffer (Last) /= ASCII.CR
 635                loop
 636                   Last := Last + 1;
 637                end loop;
 638
 639                if Index <= Buffer'Last - 7
 640                  and then Buffer (Index .. Index + 7) = "src_dir="
 641                then
 642                   Append (Src_Dir, Normalize_Pathname
 643                           (Name      => Ada.Strings.Fixed.Trim
 644                            (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
 645                            Directory => Build_Dir.all) & Path_Separator);
 646
 647                elsif Index <= Buffer'Last - 7
 648                  and then Buffer (Index .. Index + 7) = "obj_dir="
 649                then
 650                   Append (Obj_Dir, Normalize_Pathname
 651                           (Name      => Ada.Strings.Fixed.Trim
 652                            (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
 653                            Directory => Build_Dir.all) & Path_Separator);
 654                end if;
 655
 656                --  In case we had a ASCII.CR/ASCII.LF end of line, skip the
 657                --  remaining symbol
 658                Index := Last + 1;
 659
 660                if Index <= Buffer'Last
 661                  and then Buffer (Index) = ASCII.LF
 662                then
 663                   Index := Index + 1;
 664                end if;
 665             end loop;
 666          end;
 667       end if;
 668
 669       Osint.Add_Default_Search_Dirs;
 670
 671       declare
 672          Src : constant String := Parse_Gnatls_Src;
 673          Obj : constant String := Parse_Gnatls_Obj;
 674
 675       begin
 676          Directories := new Project_File'
 677            (Src_Dir_Length     => Length (Src_Dir) + Src'Length,
 678             Obj_Dir_Length     => Length (Obj_Dir) + Obj'Length,
 679             Src_Dir            => To_String (Src_Dir) & Src,
 680             Obj_Dir            => To_String (Obj_Dir) & Obj,
 681             Src_Dir_Index      => 1,
 682             Obj_Dir_Index      => 1,
 683             Last_Obj_Dir_Start => 0);
 684       end;
 685
 686       Free (Build_Dir);
 687    end Create_Project_File;
 688
 689    ---------------------
 690    -- Current_Obj_Dir --
 691    ---------------------
 692
 693    function Current_Obj_Dir return String is
 694    begin
 695       return Directories.Obj_Dir
 696         (Directories.Last_Obj_Dir_Start .. Directories.Obj_Dir_Index - 2);
 697    end Current_Obj_Dir;
 698
 699    ----------------
 700    -- Get_Column --
 701    ----------------
 702
 703    function Get_Column (Decl : Declaration_Reference) return String is
 704    begin
 705       return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Column),
 706                                      Ada.Strings.Left);
 707    end Get_Column;
 708
 709    function Get_Column (Ref : Reference) return String is
 710    begin
 711       return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Column),
 712                                      Ada.Strings.Left);
 713    end Get_Column;
 714
 715    ---------------------
 716    -- Get_Declaration --
 717    ---------------------
 718
 719    function Get_Declaration
 720      (File_Ref : File_Reference;
 721       Line     : Natural;
 722       Column   : Natural)
 723       return     Declaration_Reference
 724    is
 725       Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
 726
 727    begin
 728       return Entities_HTable.Get (Key'Unchecked_Access);
 729    end Get_Declaration;
 730
 731    ----------------------
 732    -- Get_Emit_Warning --
 733    ----------------------
 734
 735    function Get_Emit_Warning (File : File_Reference) return Boolean is
 736    begin
 737       return File.Emit_Warning;
 738    end Get_Emit_Warning;
 739
 740    --------------
 741    -- Get_File --
 742    --------------
 743
 744    function Get_File
 745      (Decl     : Declaration_Reference;
 746       With_Dir : Boolean := False) return String
 747    is
 748    begin
 749       return Get_File (Decl.Decl.File, With_Dir);
 750    end Get_File;
 751
 752    function Get_File
 753      (Ref      : Reference;
 754       With_Dir : Boolean := False) return String
 755    is
 756    begin
 757       return Get_File (Ref.File, With_Dir);
 758    end Get_File;
 759
 760    function Get_File
 761      (File     : File_Reference;
 762       With_Dir : Boolean := False;
 763       Strip    : Natural    := 0) return String
 764    is
 765       Tmp : GNAT.OS_Lib.String_Access;
 766
 767       function Internal_Strip (Full_Name : String) return String;
 768       --  Internal function to process the Strip parameter
 769
 770       --------------------
 771       -- Internal_Strip --
 772       --------------------
 773
 774       function Internal_Strip (Full_Name : String) return String is
 775          Unit_End        : Natural;
 776          Extension_Start : Natural;
 777          S               : Natural;
 778
 779       begin
 780          if Strip = 0 then
 781             return Full_Name;
 782          end if;
 783
 784          --  Isolate the file extension
 785
 786          Extension_Start := Full_Name'Last;
 787          while Extension_Start >= Full_Name'First
 788            and then Full_Name (Extension_Start) /= '.'
 789          loop
 790             Extension_Start := Extension_Start - 1;
 791          end loop;
 792
 793          --  Strip the right number of subunit_names
 794
 795          S := Strip;
 796          Unit_End := Extension_Start - 1;
 797          while Unit_End >= Full_Name'First
 798            and then S > 0
 799          loop
 800             if Full_Name (Unit_End) = '-' then
 801                S := S - 1;
 802             end if;
 803
 804             Unit_End := Unit_End - 1;
 805          end loop;
 806
 807          if Unit_End < Full_Name'First then
 808             return "";
 809          else
 810             return Full_Name (Full_Name'First .. Unit_End)
 811               & Full_Name (Extension_Start .. Full_Name'Last);
 812          end if;
 813       end Internal_Strip;
 814
 815    --  Start of processing for Get_File;
 816
 817    begin
 818       --  If we do not want the full path name
 819
 820       if not With_Dir then
 821          return Internal_Strip (File.File.all);
 822       end if;
 823
 824       if File.Dir = null then
 825          if Ada.Strings.Fixed.Tail (File.File.all, 3) =
 826                                                Osint.ALI_Suffix.all
 827          then
 828             Tmp := Locate_Regular_File
 829                      (Internal_Strip (File.File.all), Directories.Obj_Dir);
 830          else
 831             Tmp := Locate_Regular_File
 832                      (File.File.all, Directories.Src_Dir);
 833          end if;
 834
 835          if Tmp = null then
 836             File.Dir := new String'("");
 837          else
 838             File.Dir := new String'(Dir_Name (Tmp.all));
 839             Free (Tmp);
 840          end if;
 841       end if;
 842
 843       return Internal_Strip (File.Dir.all & File.File.all);
 844    end Get_File;
 845
 846    ------------------
 847    -- Get_File_Ref --
 848    ------------------
 849
 850    function Get_File_Ref (Ref : Reference) return File_Reference is
 851    begin
 852       return Ref.File;
 853    end Get_File_Ref;
 854
 855    -----------------------
 856    -- Get_Gnatchop_File --
 857    -----------------------
 858
 859    function Get_Gnatchop_File
 860      (File     : File_Reference;
 861       With_Dir : Boolean := False)
 862       return     String
 863    is
 864    begin
 865       if File.Gnatchop_File.all = "" then
 866          return Get_File (File, With_Dir);
 867       else
 868          return File.Gnatchop_File.all;
 869       end if;
 870    end Get_Gnatchop_File;
 871
 872    function Get_Gnatchop_File
 873      (Ref      : Reference;
 874       With_Dir : Boolean := False)
 875       return     String
 876    is
 877    begin
 878       return Get_Gnatchop_File (Ref.File, With_Dir);
 879    end Get_Gnatchop_File;
 880
 881    function Get_Gnatchop_File
 882      (Decl     : Declaration_Reference;
 883       With_Dir : Boolean := False)
 884       return     String
 885    is
 886    begin
 887       return Get_Gnatchop_File (Decl.Decl.File, With_Dir);
 888    end Get_Gnatchop_File;
 889
 890    --------------
 891    -- Get_Line --
 892    --------------
 893
 894    function Get_Line (Decl : Declaration_Reference) return String is
 895    begin
 896       return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Line),
 897                                      Ada.Strings.Left);
 898    end Get_Line;
 899
 900    function Get_Line (Ref : Reference) return String is
 901    begin
 902       return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Line),
 903                                      Ada.Strings.Left);
 904    end Get_Line;
 905
 906    ----------------
 907    -- Get_Parent --
 908    ----------------
 909
 910    function Get_Parent
 911      (Decl : Declaration_Reference)
 912       return Declaration_Reference
 913    is
 914    begin
 915       return Decl.Par_Symbol;
 916    end Get_Parent;
 917
 918    ---------------------
 919    -- Get_Source_Line --
 920    ---------------------
 921
 922    function Get_Source_Line (Ref : Reference) return String is
 923    begin
 924       if Ref.Source_Line /= null then
 925          return Ref.Source_Line.all;
 926       else
 927          return "";
 928       end if;
 929    end Get_Source_Line;
 930
 931    function Get_Source_Line (Decl : Declaration_Reference) return String is
 932    begin
 933       if Decl.Decl.Source_Line /= null then
 934          return Decl.Decl.Source_Line.all;
 935       else
 936          return "";
 937       end if;
 938    end Get_Source_Line;
 939
 940    ----------------
 941    -- Get_Symbol --
 942    ----------------
 943
 944    function Get_Symbol (Decl : Declaration_Reference) return String is
 945    begin
 946       return Decl.Symbol;
 947    end Get_Symbol;
 948
 949    --------------
 950    -- Get_Type --
 951    --------------
 952
 953    function Get_Type (Decl : Declaration_Reference) return Character is
 954    begin
 955       return Decl.Decl_Type;
 956    end Get_Type;
 957
 958    ----------
 959    -- Sort --
 960    ----------
 961
 962    procedure Sort (Arr : in out Reference_Array) is
 963       Tmp : Reference;
 964
 965       function Lt (Op1, Op2 : Natural) return Boolean;
 966       procedure Move (From, To : Natural);
 967       --  See GNAT.Heap_Sort_G
 968
 969       --------
 970       -- Lt --
 971       --------
 972
 973       function Lt (Op1, Op2 : Natural) return Boolean is
 974       begin
 975          if Op1 = 0 then
 976             return Is_Less_Than (Tmp, Arr (Op2));
 977          elsif Op2 = 0 then
 978             return Is_Less_Than (Arr (Op1), Tmp);
 979          else
 980             return Is_Less_Than (Arr (Op1), Arr (Op2));
 981          end if;
 982       end Lt;
 983
 984       ----------
 985       -- Move --
 986       ----------
 987
 988       procedure Move (From, To : Natural) is
 989       begin
 990          if To = 0 then
 991             Tmp := Arr (From);
 992          elsif From = 0 then
 993             Arr (To) := Tmp;
 994          else
 995             Arr (To) := Arr (From);
 996          end if;
 997       end Move;
 998
 999       package Ref_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1000
1001    --  Start of processing for Sort
1002
1003    begin
1004       Ref_Sort.Sort (Arr'Last);
1005    end Sort;
1006
1007    -----------------------
1008    -- Grep_Source_Files --
1009    -----------------------
1010
1011    procedure Grep_Source_Files is
1012       Length       : Natural := 0;
1013       Decl         : Declaration_Reference := Entities_HTable.Get_First;
1014       Arr          : Reference_Array_Access;
1015       Index        : Natural;
1016       End_Index    : Natural;
1017       Current_File : File_Reference;
1018       Current_Line : Cst_String_Access;
1019       Buffer       : GNAT.OS_Lib.String_Access;
1020       Ref          : Reference;
1021       Line         : Natural;
1022
1023    begin
1024       --  Create a temporary array, where all references will be
1025       --  sorted by files. This way, we only have to read the source
1026       --  files once.
1027
1028       while Decl /= null loop
1029
1030          --  Add 1 for the declaration itself
1031
1032          Length := Length + References_Count (Decl, True, True, True) + 1;
1033          Decl := Entities_HTable.Get_Next;
1034       end loop;
1035
1036       Arr := new Reference_Array (1 .. Length);
1037       Index := Arr'First;
1038
1039       Decl := Entities_HTable.Get_First;
1040       while Decl /= null loop
1041          Store_References (Decl, True, True, True, True, Arr.all, Index);
1042          Decl := Entities_HTable.Get_Next;
1043       end loop;
1044
1045       Sort (Arr.all);
1046
1047       --  Now traverse the whole array and find the appropriate source
1048       --  lines.
1049
1050       for R in Arr'Range loop
1051          Ref := Arr (R);
1052
1053          if Ref.File /= Current_File then
1054             Free (Buffer);
1055             begin
1056                Read_File (Get_File (Ref.File, With_Dir => True), Buffer);
1057                End_Index := Buffer'First - 1;
1058                Line := 0;
1059             exception
1060                when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error =>
1061                   Line := Natural'Last;
1062             end;
1063             Current_File := Ref.File;
1064          end if;
1065
1066          if Ref.Line > Line then
1067
1068             --  Do not free Current_Line, it is referenced by the last
1069             --  Ref we processed.
1070
1071             loop
1072                Index := End_Index + 1;
1073
1074                loop
1075                   End_Index := End_Index + 1;
1076                   exit when End_Index > Buffer'Last
1077                     or else Buffer (End_Index) = ASCII.LF;
1078                end loop;
1079
1080                --  Skip spaces at beginning of line
1081
1082                while Index < End_Index and then
1083                  (Buffer (Index) = ' ' or else Buffer (Index) = ASCII.HT)
1084                loop
1085                   Index := Index + 1;
1086                end loop;
1087
1088                Line := Line + 1;
1089                exit when Ref.Line = Line;
1090             end loop;
1091
1092             Current_Line := new String'(Buffer (Index .. End_Index - 1));
1093          end if;
1094
1095          Ref.Source_Line := Current_Line;
1096       end loop;
1097
1098       Free (Buffer);
1099       Free (Arr);
1100    end Grep_Source_Files;
1101
1102    ---------------
1103    -- Read_File --
1104    ---------------
1105
1106    procedure Read_File
1107      (File_Name : String;
1108       Contents  : out GNAT.OS_Lib.String_Access)
1109    is
1110       Name_0 : constant String := File_Name & ASCII.NUL;
1111       FD     : constant File_Descriptor := Open_Read (Name_0'Address, Binary);
1112       Length : Natural;
1113
1114    begin
1115       if FD = Invalid_FD then
1116          raise Ada.Text_IO.Name_Error;
1117       end if;
1118
1119       --  Include room for EOF char
1120
1121       Length := Natural (File_Length (FD));
1122
1123       declare
1124          Buffer    : String (1 .. Length + 1);
1125          This_Read : Integer;
1126          Read_Ptr  : Natural := 1;
1127
1128       begin
1129          loop
1130             This_Read := Read (FD,
1131                                A => Buffer (Read_Ptr)'Address,
1132                                N => Length + 1 - Read_Ptr);
1133             Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
1134             exit when This_Read <= 0;
1135          end loop;
1136
1137          Buffer (Read_Ptr) := EOF;
1138          Contents := new String'(Buffer (1 .. Read_Ptr));
1139
1140          --  Things are not simple on VMS due to the plethora of file types
1141          --  and organizations. It seems clear that there shouldn't be more
1142          --  bytes read than are contained in the file though.
1143
1144          if (Hostparm.OpenVMS and then Read_Ptr > Length + 1)
1145            or else (not Hostparm.OpenVMS and then Read_Ptr /= Length + 1)
1146          then
1147             raise Ada.Text_IO.End_Error;
1148          end if;
1149
1150          Close (FD);
1151       end;
1152    end Read_File;
1153
1154    -----------------------
1155    -- Longest_File_Name --
1156    -----------------------
1157
1158    function Longest_File_Name return Natural is
1159    begin
1160       return Longest_File_Name_In_Table;
1161    end Longest_File_Name;
1162
1163    -----------
1164    -- Match --
1165    -----------
1166
1167    function Match
1168      (File   : File_Reference;
1169       Line   : Natural;
1170       Column : Natural)
1171       return   Boolean
1172    is
1173       Ref : Ref_In_File_Ptr := File.Lines;
1174
1175    begin
1176       while Ref /= null loop
1177          if (Ref.Line = 0 or else Ref.Line = Line)
1178            and then (Ref.Column = 0 or else Ref.Column = Column)
1179          then
1180             return True;
1181          end if;
1182
1183          Ref := Ref.Next;
1184       end loop;
1185
1186       return False;
1187    end Match;
1188
1189    -----------
1190    -- Match --
1191    -----------
1192
1193    function Match (Decl : Declaration_Reference) return Boolean is
1194    begin
1195       return Decl.Match;
1196    end Match;
1197
1198    ----------
1199    -- Next --
1200    ----------
1201
1202    function Next (E : File_Reference) return File_Reference is
1203    begin
1204       return E.Next;
1205    end Next;
1206
1207    function Next (E : Declaration_Reference) return Declaration_Reference is
1208    begin
1209       return E.Next;
1210    end Next;
1211
1212    ------------------
1213    -- Next_Obj_Dir --
1214    ------------------
1215
1216    function Next_Obj_Dir return String is
1217       First : constant Integer := Directories.Obj_Dir_Index;
1218       Last  : Integer;
1219
1220    begin
1221       Last := Directories.Obj_Dir_Index;
1222
1223       if Last > Directories.Obj_Dir_Length then
1224          return String'(1 .. 0 => ' ');
1225       end if;
1226
1227       while Directories.Obj_Dir (Last) /= Path_Separator loop
1228          Last := Last + 1;
1229       end loop;
1230
1231       Directories.Obj_Dir_Index := Last + 1;
1232       Directories.Last_Obj_Dir_Start := First;
1233       return Directories.Obj_Dir (First .. Last - 1);
1234    end Next_Obj_Dir;
1235
1236    -------------------------
1237    -- Next_Unvisited_File --
1238    -------------------------
1239
1240    function Next_Unvisited_File return File_Reference is
1241       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1242         (Unvisited_Files_Record, Unvisited_Files_Access);
1243
1244       Ref : File_Reference;
1245       Tmp : Unvisited_Files_Access;
1246
1247    begin
1248       if Unvisited_Files = null then
1249          return Empty_File;
1250       else
1251          Tmp := Unvisited_Files;
1252          Ref := Unvisited_Files.File;
1253          Unvisited_Files := Unvisited_Files.Next;
1254          Unchecked_Free (Tmp);
1255          return Ref;
1256       end if;
1257    end Next_Unvisited_File;
1258
1259    ----------------------
1260    -- Parse_Gnatls_Src --
1261    ----------------------
1262
1263    function Parse_Gnatls_Src return String is
1264       Length : Natural;
1265
1266    begin
1267       Length := 0;
1268       for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
1269          if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
1270             Length := Length + 2;
1271          else
1272             Length := Length + Osint.Dir_In_Src_Search_Path (J)'Length + 1;
1273          end if;
1274       end loop;
1275
1276       declare
1277          Result : String (1 .. Length);
1278          L      : Natural;
1279
1280       begin
1281          L := Result'First;
1282          for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
1283             if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
1284                Result (L .. L + 1) := "." & Path_Separator;
1285                L := L + 2;
1286
1287             else
1288                Result (L .. L + Osint.Dir_In_Src_Search_Path (J)'Length - 1) :=
1289                  Osint.Dir_In_Src_Search_Path (J).all;
1290                L := L + Osint.Dir_In_Src_Search_Path (J)'Length;
1291                Result (L) := Path_Separator;
1292                L := L + 1;
1293             end if;
1294          end loop;
1295
1296          return Result;
1297       end;
1298    end Parse_Gnatls_Src;
1299
1300    ----------------------
1301    -- Parse_Gnatls_Obj --
1302    ----------------------
1303
1304    function Parse_Gnatls_Obj return String is
1305       Length : Natural;
1306
1307    begin
1308       Length := 0;
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             Length := Length + 2;
1312          else
1313             Length := Length + Osint.Dir_In_Obj_Search_Path (J)'Length + 1;
1314          end if;
1315       end loop;
1316
1317       declare
1318          Result : String (1 .. Length);
1319          L      : Natural;
1320
1321       begin
1322          L := Result'First;
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                Result (L .. L + 1) := "." & Path_Separator;
1326                L := L + 2;
1327             else
1328                Result (L .. L + Osint.Dir_In_Obj_Search_Path (J)'Length - 1) :=
1329                  Osint.Dir_In_Obj_Search_Path (J).all;
1330                L := L + Osint.Dir_In_Obj_Search_Path (J)'Length;
1331                Result (L) := Path_Separator;
1332                L := L + 1;
1333             end if;
1334          end loop;
1335
1336          return Result;
1337       end;
1338    end Parse_Gnatls_Obj;
1339
1340    -------------------
1341    -- Reset_Obj_Dir --
1342    -------------------
1343
1344    procedure Reset_Obj_Dir is
1345    begin
1346       Directories.Obj_Dir_Index := 1;
1347    end Reset_Obj_Dir;
1348
1349    -----------------------
1350    -- Set_Default_Match --
1351    -----------------------
1352
1353    procedure Set_Default_Match (Value : Boolean) is
1354    begin
1355       Default_Match := Value;
1356    end Set_Default_Match;
1357
1358    ----------
1359    -- Free --
1360    ----------
1361
1362    procedure Free (Str : in out Cst_String_Access) is
1363       function Convert is new Ada.Unchecked_Conversion
1364         (Cst_String_Access, GNAT.OS_Lib.String_Access);
1365
1366       S : GNAT.OS_Lib.String_Access := Convert (Str);
1367
1368    begin
1369       Free (S);
1370       Str := null;
1371    end Free;
1372
1373    ---------------------
1374    -- Reset_Directory --
1375    ---------------------
1376
1377    procedure Reset_Directory (File : File_Reference) is
1378    begin
1379       Free (File.Dir);
1380    end Reset_Directory;
1381
1382    -------------------
1383    -- Set_Unvisited --
1384    -------------------
1385
1386    procedure Set_Unvisited (File_Ref : File_Reference) is
1387       F : constant String := Get_File (File_Ref, With_Dir => False);
1388
1389    begin
1390       File_Ref.Visited := False;
1391
1392       --  ??? Do not add a source file to the list. This is true at
1393       --  least for gnatxref, and probably for gnatfind as well
1394
1395       if F'Length > 4
1396         and then F (F'Last - 3 .. F'Last) = "." & Osint.ALI_Suffix.all
1397       then
1398          Unvisited_Files := new Unvisited_Files_Record'
1399            (File => File_Ref,
1400             Next => Unvisited_Files);
1401       end if;
1402    end Set_Unvisited;
1403
1404    ----------------------
1405    -- Get_Declarations --
1406    ----------------------
1407
1408    function Get_Declarations
1409      (Sorted : Boolean := True)
1410       return   Declaration_Array_Access
1411    is
1412       Arr   : constant Declaration_Array_Access :=
1413                 new Declaration_Array (1 .. Entities_Count);
1414       Decl  : Declaration_Reference := Entities_HTable.Get_First;
1415       Index : Natural               := Arr'First;
1416       Tmp   : Declaration_Reference;
1417
1418       procedure Move (From : Natural; To : Natural);
1419       function Lt (Op1, Op2 : Natural) return Boolean;
1420       --  See GNAT.Heap_Sort_G
1421
1422       --------
1423       -- Lt --
1424       --------
1425
1426       function Lt (Op1, Op2 : Natural) return Boolean is
1427       begin
1428          if Op1 = 0 then
1429             return Is_Less_Than (Tmp, Arr (Op2));
1430          elsif Op2 = 0 then
1431             return Is_Less_Than (Arr (Op1), Tmp);
1432          else
1433             return Is_Less_Than (Arr (Op1), Arr (Op2));
1434          end if;
1435       end Lt;
1436
1437       ----------
1438       -- Move --
1439       ----------
1440
1441       procedure Move (From : Natural; To : Natural) is
1442       begin
1443          if To = 0 then
1444             Tmp := Arr (From);
1445          elsif From = 0 then
1446             Arr (To) := Tmp;
1447          else
1448             Arr (To) := Arr (From);
1449          end if;
1450       end Move;
1451
1452       package Decl_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1453
1454    --  Start of processing for Get_Declarations
1455
1456    begin
1457       while Decl /= null loop
1458          Arr (Index) := Decl;
1459          Index := Index + 1;
1460          Decl := Entities_HTable.Get_Next;
1461       end loop;
1462
1463       if Sorted and then Arr'Length /= 0 then
1464          Decl_Sort.Sort (Entities_Count);
1465       end if;
1466
1467       return Arr;
1468    end Get_Declarations;
1469
1470    ----------------------
1471    -- References_Count --
1472    ----------------------
1473
1474    function References_Count
1475      (Decl       : Declaration_Reference;
1476       Get_Reads  : Boolean := False;
1477       Get_Writes : Boolean := False;
1478       Get_Bodies : Boolean := False)
1479       return       Natural
1480    is
1481       function List_Length (E : Reference) return Natural;
1482       --  Return the number of references in E
1483
1484       -----------------
1485       -- List_Length --
1486       -----------------
1487
1488       function List_Length (E : Reference) return Natural is
1489          L  : Natural := 0;
1490          E1 : Reference := E;
1491
1492       begin
1493          while E1 /= null loop
1494             L := L + 1;
1495             E1 := E1.Next;
1496          end loop;
1497
1498          return L;
1499       end List_Length;
1500
1501       Length : Natural := 0;
1502
1503    --  Start of processing for References_Count
1504
1505    begin
1506       if Get_Reads then
1507          Length := List_Length (Decl.Ref_Ref);
1508       end if;
1509
1510       if Get_Writes then
1511          Length := Length + List_Length (Decl.Modif_Ref);
1512       end if;
1513
1514       if Get_Bodies then
1515          Length := Length + List_Length (Decl.Body_Ref);
1516       end if;
1517
1518       return Length;
1519    end References_Count;
1520
1521    ----------------------
1522    -- Store_References --
1523    ----------------------
1524
1525    procedure Store_References
1526      (Decl            : Declaration_Reference;
1527       Get_Writes      : Boolean := False;
1528       Get_Reads       : Boolean := False;
1529       Get_Bodies      : Boolean := False;
1530       Get_Declaration : Boolean := False;
1531       Arr             : in out Reference_Array;
1532       Index           : in out Natural)
1533    is
1534       procedure Add (List : Reference);
1535       --  Add all the references in List to Arr
1536
1537       ---------
1538       -- Add --
1539       ---------
1540
1541       procedure Add (List : Reference) is
1542          E : Reference := List;
1543       begin
1544          while E /= null loop
1545             Arr (Index) := E;
1546             Index := Index + 1;
1547             E := E.Next;
1548          end loop;
1549       end Add;
1550
1551    --  Start of processing for Store_References
1552
1553    begin
1554       if Get_Declaration then
1555          Add (Decl.Decl);
1556       end if;
1557
1558       if Get_Reads then
1559          Add (Decl.Ref_Ref);
1560       end if;
1561
1562       if Get_Writes then
1563          Add (Decl.Modif_Ref);
1564       end if;
1565
1566       if Get_Bodies then
1567          Add (Decl.Body_Ref);
1568       end if;
1569    end Store_References;
1570
1571    --------------------
1572    -- Get_References --
1573    --------------------
1574
1575    function Get_References
1576      (Decl : Declaration_Reference;
1577       Get_Reads  : Boolean := False;
1578       Get_Writes : Boolean := False;
1579       Get_Bodies : Boolean := False)
1580       return       Reference_Array_Access
1581    is
1582       Length : constant Natural :=
1583                  References_Count (Decl, Get_Reads, Get_Writes, Get_Bodies);
1584
1585       Arr : constant Reference_Array_Access :=
1586               new Reference_Array (1 .. Length);
1587
1588       Index : Natural := Arr'First;
1589
1590    begin
1591       Store_References
1592         (Decl            => Decl,
1593          Get_Writes      => Get_Writes,
1594          Get_Reads       => Get_Reads,
1595          Get_Bodies      => Get_Bodies,
1596          Get_Declaration => False,
1597          Arr             => Arr.all,
1598          Index           => Index);
1599
1600       if Arr'Length /= 0 then
1601          Sort (Arr.all);
1602       end if;
1603
1604       return Arr;
1605    end Get_References;
1606
1607    ----------
1608    -- Free --
1609    ----------
1610
1611    procedure Free (Arr : in out Reference_Array_Access) is
1612       procedure Internal is new Ada.Unchecked_Deallocation
1613         (Reference_Array, Reference_Array_Access);
1614    begin
1615       Internal (Arr);
1616    end Free;
1617
1618    ------------------
1619    -- Is_Parameter --
1620    ------------------
1621
1622    function Is_Parameter (Decl : Declaration_Reference) return Boolean is
1623    begin
1624       return Decl.Is_Parameter;
1625    end Is_Parameter;
1626
1627 end Xr_Tabls;