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