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