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