gcc/ada/lib-xref-alfa.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                        L I B . X R E F . A L F A                         --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2011, 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 ALFA;        use ALFA;
  27 with Einfo;       use Einfo;
  28 with Put_ALFA;
  29 with GNAT.HTable;
  30
  31 separate (Lib.Xref)
  32 package body ALFA is
  33
  34    ---------------------
  35    -- Local Constants --
  36    ---------------------
  37
  38    --  Table of ALFA_Entities, True for each entity kind used in ALFA
  39
  40    ALFA_Entities : constant array (Entity_Kind) of Boolean :=
  41      (E_Void                                       => False,
  42       E_Variable                                   => True,
  43       E_Component                                  => False,
  44       E_Constant                                   => True,
  45       E_Discriminant                               => False,
  46
  47       E_Loop_Parameter                             => True,
  48       E_In_Parameter                               => True,
  49       E_Out_Parameter                              => True,
  50       E_In_Out_Parameter                           => True,
  51       E_Generic_In_Out_Parameter                   => False,
  52
  53       E_Generic_In_Parameter                       => False,
  54       E_Named_Integer                              => False,
  55       E_Named_Real                                 => False,
  56       E_Enumeration_Type                           => False,
  57       E_Enumeration_Subtype                        => False,
  58
  59       E_Signed_Integer_Type                        => False,
  60       E_Signed_Integer_Subtype                     => False,
  61       E_Modular_Integer_Type                       => False,
  62       E_Modular_Integer_Subtype                    => False,
  63       E_Ordinary_Fixed_Point_Type                  => False,
  64
  65       E_Ordinary_Fixed_Point_Subtype               => False,
  66       E_Decimal_Fixed_Point_Type                   => False,
  67       E_Decimal_Fixed_Point_Subtype                => False,
  68       E_Floating_Point_Type                        => False,
  69       E_Floating_Point_Subtype                     => False,
  70
  71       E_Access_Type                                => False,
  72       E_Access_Subtype                             => False,
  73       E_Access_Attribute_Type                      => False,
  74       E_Allocator_Type                             => False,
  75       E_General_Access_Type                        => False,
  76
  77       E_Access_Subprogram_Type                     => False,
  78       E_Access_Protected_Subprogram_Type           => False,
  79       E_Anonymous_Access_Subprogram_Type           => False,
  80       E_Anonymous_Access_Protected_Subprogram_Type => False,
  81       E_Anonymous_Access_Type                      => False,
  82
  83       E_Array_Type                                 => False,
  84       E_Array_Subtype                              => False,
  85       E_String_Type                                => False,
  86       E_String_Subtype                             => False,
  87       E_String_Literal_Subtype                     => False,
  88
  89       E_Class_Wide_Type                            => False,
  90       E_Class_Wide_Subtype                         => False,
  91       E_Record_Type                                => False,
  92       E_Record_Subtype                             => False,
  93       E_Record_Type_With_Private                   => False,
  94
  95       E_Record_Subtype_With_Private                => False,
  96       E_Private_Type                               => False,
  97       E_Private_Subtype                            => False,
  98       E_Limited_Private_Type                       => False,
  99       E_Limited_Private_Subtype                    => False,
 100
 101       E_Incomplete_Type                            => False,
 102       E_Incomplete_Subtype                         => False,
 103       E_Task_Type                                  => False,
 104       E_Task_Subtype                               => False,
 105       E_Protected_Type                             => False,
 106
 107       E_Protected_Subtype                          => False,
 108       E_Exception_Type                             => False,
 109       E_Subprogram_Type                            => False,
 110       E_Enumeration_Literal                        => False,
 111       E_Function                                   => True,
 112
 113       E_Operator                                   => True,
 114       E_Procedure                                  => True,
 115       E_Entry                                      => False,
 116       E_Entry_Family                               => False,
 117       E_Block                                      => False,
 118
 119       E_Entry_Index_Parameter                      => False,
 120       E_Exception                                  => False,
 121       E_Generic_Function                           => False,
 122       E_Generic_Package                            => False,
 123       E_Generic_Procedure                          => False,
 124
 125       E_Label                                      => False,
 126       E_Loop                                       => False,
 127       E_Return_Statement                           => False,
 128       E_Package                                    => False,
 129
 130       E_Package_Body                               => False,
 131       E_Protected_Object                           => False,
 132       E_Protected_Body                             => False,
 133       E_Task_Body                                  => False,
 134       E_Subprogram_Body                            => False);
 135
 136    --  True for each reference type used in ALFA
 137    ALFA_References : constant array (Character) of Boolean :=
 138      ('m' => True,
 139       'r' => True,
 140       's' => True,
 141       others => False);
 142
 143    type Entity_Hashed_Range is range 0 .. 255;
 144    --  Size of hash table headers
 145
 146    -----------------------
 147    -- Local Subprograms --
 148    -----------------------
 149
 150    procedure Add_ALFA_File (U : Unit_Number_Type; D : Nat);
 151    --  Add file U and all scopes in U to the tables ALFA_File_Table and
 152    --  ALFA_Scope_Table.
 153
 154    procedure Add_ALFA_Scope (N : Node_Id);
 155    --  Add scope N to the table ALFA_Scope_Table
 156
 157    procedure Add_ALFA_Xrefs;
 158    --  Filter table Xrefs to add all references used in ALFA to the table
 159    --  ALFA_Xref_Table.
 160
 161    procedure Detect_And_Add_ALFA_Scope (N : Node_Id);
 162    --  Call Add_ALFA_Scope on scopes
 163
 164    function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range;
 165    --  Hash function for hash table
 166
 167    procedure Traverse_Declarations_Or_Statements
 168      (L       : List_Id;
 169       Process : Node_Processing);
 170    procedure Traverse_Handled_Statement_Sequence
 171      (N       : Node_Id;
 172       Process : Node_Processing);
 173    procedure Traverse_Package_Body
 174      (N       : Node_Id;
 175       Process : Node_Processing);
 176    procedure Traverse_Package_Declaration
 177      (N       : Node_Id;
 178       Process : Node_Processing);
 179    procedure Traverse_Subprogram_Body
 180      (N       : Node_Id;
 181       Process : Node_Processing);
 182    --  Traverse the corresponding constructs, calling Process on all
 183    --  declarations.
 184
 185    -------------------
 186    -- Add_ALFA_File --
 187    -------------------
 188
 189    procedure Add_ALFA_File (U : Unit_Number_Type; D : Nat) is
 190       From : Scope_Index;
 191
 192       S : constant Source_File_Index := Source_Index (U);
 193
 194    begin
 195       --  Source file could be inexistant as a result of an error, if option
 196       --  gnatQ is used.
 197
 198       if S = No_Source_File then
 199          return;
 200       end if;
 201
 202       From := ALFA_Scope_Table.Last + 1;
 203
 204       Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_ALFA_Scope'Access);
 205
 206       --  Update scope numbers
 207
 208       declare
 209          Count : Nat;
 210
 211       begin
 212          Count := 1;
 213          for S in From .. ALFA_Scope_Table.Last loop
 214             declare
 215                E : Entity_Id renames ALFA_Scope_Table.Table (S).Scope_Entity;
 216
 217             begin
 218                if Lib.Get_Source_Unit (E) = U then
 219                   ALFA_Scope_Table.Table (S).Scope_Num := Count;
 220                   ALFA_Scope_Table.Table (S).File_Num  := D;
 221                   Count                                := Count + 1;
 222
 223                else
 224                   --  Mark for removal a scope S which is not located in unit
 225                   --  U, for example for scope inside generics that get
 226                   --  instantiated.
 227
 228                   ALFA_Scope_Table.Table (S).Scope_Num := 0;
 229                end if;
 230             end;
 231          end loop;
 232       end;
 233
 234       declare
 235          Snew : Scope_Index;
 236
 237       begin
 238          Snew := From;
 239          for S in From .. ALFA_Scope_Table.Last loop
 240             --  Remove those scopes previously marked for removal
 241
 242             if ALFA_Scope_Table.Table (S).Scope_Num /= 0 then
 243                ALFA_Scope_Table.Table (Snew) := ALFA_Scope_Table.Table (S);
 244                Snew := Snew + 1;
 245             end if;
 246          end loop;
 247
 248          ALFA_Scope_Table.Set_Last (Snew - 1);
 249       end;
 250
 251       --  Make entry for new file in file table
 252
 253       Get_Name_String (Reference_Name (S));
 254
 255       ALFA_File_Table.Append (
 256         (File_Name  => new String'(Name_Buffer (1 .. Name_Len)),
 257          File_Num   => D,
 258          From_Scope => From,
 259          To_Scope   => ALFA_Scope_Table.Last));
 260    end Add_ALFA_File;
 261
 262    --------------------
 263    -- Add_ALFA_Scope --
 264    --------------------
 265
 266    procedure Add_ALFA_Scope (N : Node_Id) is
 267       E   : constant Entity_Id  := Defining_Entity (N);
 268       Loc : constant Source_Ptr := Sloc (E);
 269       Typ : Character;
 270
 271    begin
 272       --  Ignore scopes without a proper location
 273
 274       if Sloc (N) = No_Location then
 275          return;
 276       end if;
 277
 278       case Ekind (E) is
 279          when E_Function =>
 280             Typ := 'V';
 281
 282          when E_Procedure =>
 283             Typ := 'U';
 284
 285          when E_Subprogram_Body =>
 286             declare
 287                Spec : Node_Id;
 288
 289             begin
 290                Spec := Parent (E);
 291
 292                if Nkind (Spec) = N_Defining_Program_Unit_Name then
 293                   Spec := Parent (Spec);
 294                end if;
 295
 296                if Nkind (Spec) = N_Function_Specification then
 297                   Typ := 'V';
 298                else
 299                   pragma Assert
 300                     (Nkind (Spec) = N_Procedure_Specification);
 301                   Typ := 'U';
 302                end if;
 303             end;
 304
 305          when E_Package | E_Package_Body =>
 306             Typ := 'K';
 307
 308          when E_Void =>
 309             --  Compilation of prj-attr.adb with -gnatn creates a node with
 310             --  entity E_Void for the package defined at a-charac.ads16:13
 311
 312             --  ??? TBD
 313
 314             return;
 315
 316          when others =>
 317             raise Program_Error;
 318       end case;
 319
 320       --  File_Num and Scope_Num are filled later. From_Xref and To_Xref are
 321       --  filled even later, but are initialized to represent an empty range.
 322
 323       ALFA_Scope_Table.Append (
 324         (Scope_Name     => new String'(Unique_Name (E)),
 325          File_Num       => 0,
 326          Scope_Num      => 0,
 327          Spec_File_Num  => 0,
 328          Spec_Scope_Num => 0,
 329          Line           => Nat (Get_Logical_Line_Number (Loc)),
 330          Stype          => Typ,
 331          Col            => Nat (Get_Column_Number (Loc)),
 332          From_Xref      => 1,
 333          To_Xref        => 0,
 334          Scope_Entity   => E));
 335    end Add_ALFA_Scope;
 336
 337    --------------------
 338    -- Add_ALFA_Xrefs --
 339    --------------------
 340
 341    procedure Add_ALFA_Xrefs is
 342       Cur_Scope_Idx   : Scope_Index;
 343       From_Xref_Idx   : Xref_Index;
 344       Cur_Entity      : Entity_Id;
 345       Cur_Entity_Name : String_Ptr;
 346
 347       package Scopes is
 348          No_Scope : constant Nat := 0;
 349          function Get_Scope_Num (N : Entity_Id) return Nat;
 350          procedure Set_Scope_Num (N : Entity_Id; Num : Nat);
 351       end Scopes;
 352
 353       ------------
 354       -- Scopes --
 355       ------------
 356
 357       package body Scopes is
 358          type Scope is record
 359             Num    : Nat;
 360             Entity : Entity_Id;
 361          end record;
 362
 363          package Scopes is new GNAT.HTable.Simple_HTable
 364            (Header_Num => Entity_Hashed_Range,
 365             Element    => Scope,
 366             No_Element => (Num => No_Scope, Entity => Empty),
 367             Key        => Entity_Id,
 368             Hash       => Entity_Hash,
 369             Equal      => "=");
 370
 371          -------------------
 372          -- Get_Scope_Num --
 373          -------------------
 374
 375          function Get_Scope_Num (N : Entity_Id) return Nat is
 376          begin
 377             return Scopes.Get (N).Num;
 378          end Get_Scope_Num;
 379
 380          -------------------
 381          -- Set_Scope_Num --
 382          -------------------
 383
 384          procedure Set_Scope_Num (N : Entity_Id; Num : Nat) is
 385          begin
 386             Scopes.Set (K => N, E => Scope'(Num => Num, Entity => N));
 387          end Set_Scope_Num;
 388       end Scopes;
 389
 390       use Scopes;
 391
 392       Nrefs : Nat := Xrefs.Last;
 393       --  Number of references in table. This value may get reset (reduced)
 394       --  when we eliminate duplicate reference entries as well as references
 395       --  not suitable for local cross-references.
 396
 397       Rnums : array (0 .. Nrefs) of Nat;
 398       --  This array contains numbers of references in the Xrefs table. This
 399       --  list is sorted in output order. The extra 0'th entry is convenient
 400       --  for the call to sort. When we sort the table, we move the entries in
 401       --  Rnums around, but we do not move the original table entries.
 402
 403       function Lt (Op1, Op2 : Natural) return Boolean;
 404       --  Comparison function for Sort call
 405
 406       procedure Move (From : Natural; To : Natural);
 407       --  Move procedure for Sort call
 408
 409       package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
 410
 411       --------
 412       -- Lt --
 413       --------
 414
 415       function Lt (Op1, Op2 : Natural) return Boolean is
 416          T1 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op1)));
 417          T2 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op2)));
 418
 419       begin
 420          --  First test: if entity is in different unit, sort by unit. Note:
 421          --  that we use Ent_Scope_File rather than Eun, as Eun may refer to
 422          --  the file where the generic scope is defined, which may differ from
 423          --  the file where the enclosing scope is defined. It is the latter
 424          --  which matters for a correct order here.
 425
 426          if T1.Ent_Scope_File /= T2.Ent_Scope_File then
 427             return Dependency_Num (T1.Ent_Scope_File) <
 428               Dependency_Num (T2.Ent_Scope_File);
 429
 430          --  Second test: within same unit, sort by location of the scope of
 431          --  the entity definition.
 432
 433          elsif Get_Scope_Num (T1.Ent_Scope) /=
 434            Get_Scope_Num (T2.Ent_Scope)
 435          then
 436             return Get_Scope_Num (T1.Ent_Scope) < Get_Scope_Num (T2.Ent_Scope);
 437
 438          --  Third test: within same unit and scope, sort by location of
 439          --  entity definition.
 440
 441          elsif T1.Def /= T2.Def then
 442             return T1.Def < T2.Def;
 443
 444          --  Fourth test: if reference is in same unit as entity definition,
 445          --  sort first.
 446
 447          elsif T1.Lun /= T2.Lun and then T1.Ent_Scope_File = T1.Lun then
 448             return True;
 449          elsif T1.Lun /= T2.Lun and then T2.Ent_Scope_File = T2.Lun then
 450             return False;
 451
 452          --  Fifth test: if reference is in same unit and same scope as entity
 453          --  definition, sort first.
 454
 455          elsif T1.Ent_Scope_File = T1.Lun
 456            and then T1.Ref_Scope /= T2.Ref_Scope
 457            and then T1.Ent_Scope = T1.Ref_Scope
 458          then
 459             return True;
 460          elsif T1.Ent_Scope_File = T1.Lun
 461            and then T1.Ref_Scope /= T2.Ref_Scope
 462            and then T2.Ent_Scope = T2.Ref_Scope
 463          then
 464             return False;
 465
 466          --  Sixth test: for same entity, sort by reference location unit
 467
 468          elsif T1.Lun /= T2.Lun then
 469             return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
 470
 471          --  Seventh test: for same entity, sort by reference location scope
 472
 473          elsif Get_Scope_Num (T1.Ref_Scope) /=
 474            Get_Scope_Num (T2.Ref_Scope)
 475          then
 476             return Get_Scope_Num (T1.Ref_Scope) < Get_Scope_Num (T2.Ref_Scope);
 477
 478          --  Eighth test: order of location within referencing unit
 479
 480          elsif T1.Loc /= T2.Loc then
 481             return T1.Loc < T2.Loc;
 482
 483          --  Finally, for two locations at the same address prefer the one that
 484          --  does NOT have the type 'r', so that a modification or extension
 485          --  takes preference, when there are more than one reference at the
 486          --  same location. As a result, in the case of entities that are
 487          --  in-out actuals, the read reference follows the modify reference.
 488
 489          else
 490             return T2.Typ = 'r';
 491          end if;
 492       end Lt;
 493
 494       ----------
 495       -- Move --
 496       ----------
 497
 498       procedure Move (From : Natural; To : Natural) is
 499       begin
 500          Rnums (Nat (To)) := Rnums (Nat (From));
 501       end Move;
 502
 503       --  Start of processing for Add_ALFA_Xrefs
 504    begin
 505
 506       for J in ALFA_Scope_Table.First .. ALFA_Scope_Table.Last loop
 507          Set_Scope_Num (N   => ALFA_Scope_Table.Table (J).Scope_Entity,
 508                         Num => ALFA_Scope_Table.Table (J).Scope_Num);
 509       end loop;
 510
 511       --  Set up the pointer vector for the sort
 512
 513       for J in 1 .. Nrefs loop
 514          Rnums (J) := J;
 515       end loop;
 516
 517       --  Eliminate entries not appropriate for ALFA. Done prior to sorting
 518       --  cross-references, as it discards useless references which do not have
 519       --  a proper format for the comparison function (like no location).
 520
 521       Eliminate_Before_Sort : declare
 522          NR : Nat;
 523
 524          function Is_ALFA_Scope (E : Entity_Id) return Boolean;
 525          --  Return whether the entity or reference scope is adequate
 526
 527          function Is_Global_Constant (E : Entity_Id) return Boolean;
 528          --  Return True if E is a global constant for which we should ignore
 529          --  reads in ALFA.
 530
 531          -------------------
 532          -- Is_ALFA_Scope --
 533          -------------------
 534
 535          function Is_ALFA_Scope (E : Entity_Id) return Boolean is
 536          begin
 537             return Present (E)
 538               and then not Is_Generic_Unit (E)
 539               and then Renamed_Entity (E) = Empty
 540               and then Get_Scope_Num (E) /= No_Scope;
 541          end Is_ALFA_Scope;
 542
 543          ------------------------
 544          -- Is_Global_Constant --
 545          ------------------------
 546
 547          function Is_Global_Constant (E : Entity_Id) return Boolean is
 548          begin
 549             return Ekind (E) = E_Constant
 550               and then Ekind_In (Scope (E), E_Package, E_Package_Body);
 551          end Is_Global_Constant;
 552
 553       --  Start of processing for Eliminate_Before_Sort
 554
 555       begin
 556          NR    := Nrefs;
 557          Nrefs := 0;
 558
 559          for J in 1 .. NR loop
 560             if ALFA_Entities (Ekind (Xrefs.Table (Rnums (J)).Ent))
 561               and then ALFA_References (Xrefs.Table (Rnums (J)).Typ)
 562               and then Is_ALFA_Scope (Xrefs.Table (Rnums (J)).Ent_Scope)
 563               and then Is_ALFA_Scope (Xrefs.Table (Rnums (J)).Ref_Scope)
 564               and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Ent)
 565             then
 566                Nrefs         := Nrefs + 1;
 567                Rnums (Nrefs) := Rnums (J);
 568             end if;
 569          end loop;
 570       end Eliminate_Before_Sort;
 571
 572       --  Sort the references
 573
 574       Sorting.Sort (Integer (Nrefs));
 575
 576       Eliminate_After_Sort : declare
 577          NR : Nat;
 578
 579          Crloc : Source_Ptr;
 580          --  Current reference location
 581
 582          Prevt : Character;
 583          --  reference kind of previous reference
 584
 585       begin
 586          --  Eliminate duplicate entries
 587
 588          --  We need this test for NR because if we force ALI file generation
 589          --  in case of errors detected, it may be the case that Nrefs is 0, so
 590          --  we should not reset it here
 591
 592          if Nrefs >= 2 then
 593             NR    := Nrefs;
 594             Nrefs := 1;
 595
 596             for J in 2 .. NR loop
 597                if Xrefs.Table (Rnums (J)) /=
 598                  Xrefs.Table (Rnums (Nrefs))
 599                then
 600                   Nrefs := Nrefs + 1;
 601                   Rnums (Nrefs) := Rnums (J);
 602                end if;
 603             end loop;
 604          end if;
 605
 606          --  Eliminate the reference if it is at the same location as the
 607          --  previous one, unless it is a read-reference indicating that the
 608          --  entity is an in-out actual in a call.
 609
 610          NR    := Nrefs;
 611          Nrefs := 0;
 612          Crloc := No_Location;
 613          Prevt := 'm';
 614
 615          for J in 1 .. NR loop
 616             if Xrefs.Table (Rnums (J)).Loc /= Crloc
 617               or else (Prevt = 'm'
 618                         and then Xrefs.Table (Rnums (J)).Typ = 'r')
 619             then
 620                Crloc         := Xrefs.Table (Rnums (J)).Loc;
 621                Prevt         := Xrefs.Table (Rnums (J)).Typ;
 622                Nrefs         := Nrefs + 1;
 623                Rnums (Nrefs) := Rnums (J);
 624             end if;
 625          end loop;
 626       end Eliminate_After_Sort;
 627
 628       --  Initialize loop
 629
 630       Cur_Scope_Idx  := 1;
 631       From_Xref_Idx  := 1;
 632       Cur_Entity     := Empty;
 633
 634       if ALFA_Scope_Table.Last = 0 then
 635          return;
 636       end if;
 637
 638       --  Loop to output references
 639
 640       for Refno in 1 .. Nrefs loop
 641          Add_One_Xref : declare
 642
 643             -----------------------
 644             -- Local Subprograms --
 645             -----------------------
 646
 647             function Cur_Scope return Node_Id;
 648             --  Return scope entity which corresponds to index Cur_Scope_Idx in
 649             --  table ALFA_Scope_Table.
 650
 651             function Get_Entity_Type (E : Entity_Id) return Character;
 652             --  Return a character representing the type of entity
 653
 654             function Is_Future_Scope_Entity (E : Entity_Id) return Boolean;
 655             --  Check whether entity E is in ALFA_Scope_Table at index
 656             --  Cur_Scope_Idx or higher.
 657
 658             function Is_Past_Scope_Entity (E : Entity_Id) return Boolean;
 659             --  Check whether entity E is in ALFA_Scope_Table at index strictly
 660             --  lower than Cur_Scope_Idx.
 661
 662             ---------------
 663             -- Cur_Scope --
 664             ---------------
 665
 666             function Cur_Scope return Node_Id is
 667             begin
 668                return ALFA_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity;
 669             end Cur_Scope;
 670
 671             ---------------------
 672             -- Get_Entity_Type --
 673             ---------------------
 674
 675             function Get_Entity_Type (E : Entity_Id) return Character is
 676                C : Character;
 677             begin
 678                case Ekind (E) is
 679                   when E_Out_Parameter    => C := '<';
 680                   when E_In_Out_Parameter => C := '=';
 681                   when E_In_Parameter     => C := '>';
 682                   when others             => C := '*';
 683                end case;
 684                return C;
 685             end Get_Entity_Type;
 686
 687             ----------------------------
 688             -- Is_Future_Scope_Entity --
 689             ----------------------------
 690
 691             function Is_Future_Scope_Entity (E : Entity_Id) return Boolean is
 692             begin
 693                for J in Cur_Scope_Idx .. ALFA_Scope_Table.Last loop
 694                   if E = ALFA_Scope_Table.Table (J).Scope_Entity then
 695                      return True;
 696                   end if;
 697                end loop;
 698
 699                --  If this assertion fails, this means that the scope which we
 700                --  are looking for has been treated already, which reveals a
 701                --  problem in the order of cross-references.
 702
 703                pragma Assert (not Is_Past_Scope_Entity (E));
 704
 705                return False;
 706             end Is_Future_Scope_Entity;
 707
 708             --------------------------
 709             -- Is_Past_Scope_Entity --
 710             --------------------------
 711
 712             function Is_Past_Scope_Entity (E : Entity_Id) return Boolean is
 713             begin
 714                for J in ALFA_Scope_Table.First .. Cur_Scope_Idx - 1 loop
 715                   if E = ALFA_Scope_Table.Table (J).Scope_Entity then
 716                      return True;
 717                   end if;
 718                end loop;
 719
 720                return False;
 721             end Is_Past_Scope_Entity;
 722
 723             ---------------------
 724             -- Local Variables --
 725             ---------------------
 726
 727             XE  : Xref_Entry renames Xrefs.Table (Rnums (Refno));
 728
 729          begin
 730             --  If this assertion fails, the scope which we are looking for is
 731             --  not in ALFA scope table, which reveals either a problem in the
 732             --  construction of the scope table, or an erroneous scope for the
 733             --  current cross-reference.
 734
 735             pragma Assert (Is_Future_Scope_Entity (XE.Ent_Scope));
 736
 737             --  Update the range of cross references to which the current scope
 738             --  refers to. This may be the empty range only for the first scope
 739             --  considered.
 740
 741             if XE.Ent_Scope /= Cur_Scope then
 742                ALFA_Scope_Table.Table (Cur_Scope_Idx).From_Xref :=
 743                  From_Xref_Idx;
 744                ALFA_Scope_Table.Table (Cur_Scope_Idx).To_Xref :=
 745                  ALFA_Xref_Table.Last;
 746                From_Xref_Idx := ALFA_Xref_Table.Last + 1;
 747             end if;
 748
 749             while XE.Ent_Scope /= Cur_Scope loop
 750                Cur_Scope_Idx := Cur_Scope_Idx + 1;
 751                pragma Assert (Cur_Scope_Idx <= ALFA_Scope_Table.Last);
 752             end loop;
 753
 754             if XE.Ent /= Cur_Entity then
 755                Cur_Entity_Name :=
 756                  new String'(Unique_Name (XE.Ent));
 757             end if;
 758
 759             ALFA_Xref_Table.Append (
 760               (Entity_Name => Cur_Entity_Name,
 761                Entity_Line => Int (Get_Logical_Line_Number (XE.Def)),
 762                Etype       => Get_Entity_Type (XE.Ent),
 763                Entity_Col  => Int (Get_Column_Number (XE.Def)),
 764                File_Num    => Dependency_Num (XE.Lun),
 765                Scope_Num   => Get_Scope_Num (XE.Ref_Scope),
 766                Line        => Int (Get_Logical_Line_Number (XE.Loc)),
 767                Rtype       => XE.Typ,
 768                Col         => Int (Get_Column_Number (XE.Loc))));
 769          end Add_One_Xref;
 770       end loop;
 771
 772       --  Update the range of cross references to which the scope refers to
 773
 774       ALFA_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx;
 775       ALFA_Scope_Table.Table (Cur_Scope_Idx).To_Xref   := ALFA_Xref_Table.Last;
 776    end Add_ALFA_Xrefs;
 777
 778    ------------------
 779    -- Collect_ALFA --
 780    ------------------
 781
 782    procedure Collect_ALFA (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat) is
 783    begin
 784       --  Cross-references should have been computed first
 785
 786       pragma Assert (Xrefs.Last /= 0);
 787
 788       Initialize_ALFA_Tables;
 789
 790       --  Generate file and scope ALFA information
 791
 792       for D in 1 .. Num_Sdep loop
 793
 794          --  Ignore file for System
 795
 796          if Units.Table (Sdep_Table (D)).Source_Index /=
 797            System_Source_File_Index
 798          then
 799             Add_ALFA_File (U => Sdep_Table (D), D => D);
 800          end if;
 801       end loop;
 802
 803       --  Fill in the spec information when relevant
 804
 805       declare
 806          package Entity_Hash_Table is new
 807            GNAT.HTable.Simple_HTable
 808              (Header_Num => Entity_Hashed_Range,
 809               Element    => Scope_Index,
 810               No_Element => 0,
 811               Key        => Entity_Id,
 812               Hash       => Entity_Hash,
 813               Equal      => "=");
 814
 815       begin
 816          --  Fill in the hash-table
 817
 818          for S in ALFA_Scope_Table.First .. ALFA_Scope_Table.Last loop
 819             declare
 820                Srec : ALFA_Scope_Record renames ALFA_Scope_Table.Table (S);
 821             begin
 822                Entity_Hash_Table.Set (Srec.Scope_Entity, S);
 823             end;
 824          end loop;
 825
 826          --  Use the hash-table to locate spec entities
 827
 828          for S in ALFA_Scope_Table.First .. ALFA_Scope_Table.Last loop
 829             declare
 830                Srec : ALFA_Scope_Record renames ALFA_Scope_Table.Table (S);
 831
 832                Body_Entity : Entity_Id;
 833                Spec_Entity : Entity_Id;
 834                Spec_Scope  : Scope_Index;
 835
 836             begin
 837                if Ekind (Srec.Scope_Entity) = E_Subprogram_Body then
 838                   Body_Entity := Parent (Parent (Srec.Scope_Entity));
 839                elsif Ekind (Srec.Scope_Entity) = E_Package_Body then
 840                   Body_Entity := Parent (Srec.Scope_Entity);
 841                else
 842                   Body_Entity := Empty;
 843                end if;
 844
 845                if Present (Body_Entity) then
 846                   if Nkind (Body_Entity) = N_Defining_Program_Unit_Name then
 847                      Body_Entity := Parent (Body_Entity);
 848                   end if;
 849
 850                   Spec_Entity := Corresponding_Spec (Body_Entity);
 851                   Spec_Scope := Entity_Hash_Table.Get (Spec_Entity);
 852
 853                   --  Spec of generic may be missing
 854
 855                   if Spec_Scope /= 0 then
 856                      Srec.Spec_File_Num :=
 857                        ALFA_Scope_Table.Table (Spec_Scope).File_Num;
 858                      Srec.Spec_Scope_Num :=
 859                        ALFA_Scope_Table.Table (Spec_Scope).Scope_Num;
 860                   end if;
 861                end if;
 862             end;
 863          end loop;
 864       end;
 865
 866       --  Generate cross reference ALFA information
 867
 868       Add_ALFA_Xrefs;
 869    end Collect_ALFA;
 870
 871    -------------------------------
 872    -- Detect_And_Add_ALFA_Scope --
 873    -------------------------------
 874
 875    procedure Detect_And_Add_ALFA_Scope (N : Node_Id) is
 876    begin
 877       if Nkind_In (N, N_Subprogram_Declaration,
 878                       N_Subprogram_Body,
 879                       N_Package_Declaration,
 880                       N_Package_Body)
 881       then
 882          Add_ALFA_Scope (N);
 883       end if;
 884    end Detect_And_Add_ALFA_Scope;
 885
 886    -----------------
 887    -- Entity_Hash --
 888    -----------------
 889
 890    function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range is
 891    begin
 892       return
 893         Entity_Hashed_Range (E mod (Entity_Id (Entity_Hashed_Range'Last) + 1));
 894    end Entity_Hash;
 895
 896    ------------------------------------
 897    -- Traverse_All_Compilation_Units --
 898    ------------------------------------
 899
 900    procedure Traverse_All_Compilation_Units (Process : Node_Processing) is
 901    begin
 902       for U in Units.First .. Last_Unit loop
 903          Traverse_Compilation_Unit (Cunit (U), Process);
 904       end loop;
 905    end Traverse_All_Compilation_Units;
 906
 907    -------------------------------
 908    -- Traverse_Compilation_Unit --
 909    -------------------------------
 910
 911    procedure Traverse_Compilation_Unit
 912      (CU      : Node_Id;
 913       Process : Node_Processing)
 914    is
 915       Lu : Node_Id;
 916
 917    begin
 918       --  Get Unit (checking case of subunit)
 919
 920       Lu := Unit (CU);
 921
 922       if Nkind (Lu) = N_Subunit then
 923          Lu := Proper_Body (Lu);
 924       end if;
 925
 926       --  Call Process on all declarations
 927
 928       if Nkind (Lu) in N_Declaration
 929         or else Nkind (Lu) in N_Later_Decl_Item
 930       then
 931          Process (Lu);
 932       end if;
 933
 934       --  Traverse the unit
 935
 936       if Nkind (Lu) = N_Subprogram_Body then
 937          Traverse_Subprogram_Body (Lu, Process);
 938
 939       elsif Nkind (Lu) = N_Subprogram_Declaration then
 940          null;
 941
 942       elsif Nkind (Lu) = N_Package_Declaration then
 943          Traverse_Package_Declaration (Lu, Process);
 944
 945       elsif Nkind (Lu) = N_Package_Body then
 946          Traverse_Package_Body (Lu, Process);
 947
 948       --  ??? TBD
 949
 950       elsif Nkind (Lu) = N_Generic_Package_Declaration then
 951          null;
 952
 953       --  ??? TBD
 954
 955       elsif Nkind (Lu) in N_Generic_Instantiation then
 956          null;
 957
 958       --  All other cases of compilation units (e.g. renamings), are not
 959       --  declarations.
 960
 961       else
 962          null;
 963       end if;
 964    end Traverse_Compilation_Unit;
 965
 966    -----------------------------------------
 967    -- Traverse_Declarations_Or_Statements --
 968    -----------------------------------------
 969
 970    procedure Traverse_Declarations_Or_Statements
 971      (L       : List_Id;
 972       Process : Node_Processing)
 973    is
 974       N : Node_Id;
 975
 976    begin
 977       --  Loop through statements or declarations
 978
 979       N := First (L);
 980       while Present (N) loop
 981          --  Call Process on all declarations
 982
 983          if Nkind (N) in N_Declaration
 984               or else
 985             Nkind (N) in N_Later_Decl_Item
 986          then
 987             Process (N);
 988          end if;
 989
 990          case Nkind (N) is
 991
 992             --  Package declaration
 993
 994             when N_Package_Declaration =>
 995                Traverse_Package_Declaration (N, Process);
 996
 997             --  Generic package declaration ??? TBD
 998
 999             when N_Generic_Package_Declaration =>
1000                null;
1001
1002             --  Package body
1003
1004             when N_Package_Body =>
1005                if Ekind (Defining_Entity (N)) /= E_Generic_Package then
1006                   Traverse_Package_Body (N, Process);
1007                end if;
1008
1009             --  Subprogram declaration
1010
1011             when N_Subprogram_Declaration =>
1012                null;
1013
1014             --  Generic subprogram declaration ??? TBD
1015
1016             when N_Generic_Subprogram_Declaration =>
1017                null;
1018
1019             --  Subprogram body
1020
1021             when N_Subprogram_Body =>
1022                if not Is_Generic_Subprogram (Defining_Entity (N)) then
1023                   Traverse_Subprogram_Body (N, Process);
1024                end if;
1025
1026             --  Block statement
1027
1028             when N_Block_Statement =>
1029                Traverse_Declarations_Or_Statements (Declarations (N), Process);
1030                Traverse_Handled_Statement_Sequence
1031                  (Handled_Statement_Sequence (N), Process);
1032
1033             when N_If_Statement =>
1034
1035                --  Traverse the statements in the THEN part
1036
1037                Traverse_Declarations_Or_Statements
1038                  (Then_Statements (N), Process);
1039
1040                --  Loop through ELSIF parts if present
1041
1042                if Present (Elsif_Parts (N)) then
1043                   declare
1044                      Elif : Node_Id := First (Elsif_Parts (N));
1045
1046                   begin
1047                      while Present (Elif) loop
1048                         Traverse_Declarations_Or_Statements
1049                           (Then_Statements (Elif), Process);
1050                         Next (Elif);
1051                      end loop;
1052                   end;
1053                end if;
1054
1055                --  Finally traverse the ELSE statements if present
1056
1057                Traverse_Declarations_Or_Statements
1058                  (Else_Statements (N), Process);
1059
1060             --  Case statement
1061
1062             when N_Case_Statement =>
1063
1064                --  Process case branches
1065
1066                declare
1067                   Alt : Node_Id;
1068                begin
1069                   Alt := First (Alternatives (N));
1070                   while Present (Alt) loop
1071                      Traverse_Declarations_Or_Statements
1072                        (Statements (Alt), Process);
1073                      Next (Alt);
1074                   end loop;
1075                end;
1076
1077             --  Extended return statement
1078
1079             when N_Extended_Return_Statement =>
1080                Traverse_Handled_Statement_Sequence
1081                  (Handled_Statement_Sequence (N), Process);
1082
1083             --  Loop
1084
1085             when N_Loop_Statement =>
1086                Traverse_Declarations_Or_Statements (Statements (N), Process);
1087
1088             when others =>
1089                null;
1090          end case;
1091
1092          Next (N);
1093       end loop;
1094    end Traverse_Declarations_Or_Statements;
1095
1096    -----------------------------------------
1097    -- Traverse_Handled_Statement_Sequence --
1098    -----------------------------------------
1099
1100    procedure Traverse_Handled_Statement_Sequence
1101      (N       : Node_Id;
1102       Process : Node_Processing)
1103    is
1104       Handler : Node_Id;
1105
1106    begin
1107       if Present (N) then
1108          Traverse_Declarations_Or_Statements (Statements (N), Process);
1109
1110          if Present (Exception_Handlers (N)) then
1111             Handler := First (Exception_Handlers (N));
1112             while Present (Handler) loop
1113                Traverse_Declarations_Or_Statements
1114                  (Statements (Handler), Process);
1115                Next (Handler);
1116             end loop;
1117          end if;
1118       end if;
1119    end Traverse_Handled_Statement_Sequence;
1120
1121    ---------------------------
1122    -- Traverse_Package_Body --
1123    ---------------------------
1124
1125    procedure Traverse_Package_Body
1126      (N       : Node_Id;
1127       Process : Node_Processing) is
1128    begin
1129       Traverse_Declarations_Or_Statements (Declarations (N), Process);
1130       Traverse_Handled_Statement_Sequence
1131         (Handled_Statement_Sequence (N), Process);
1132    end Traverse_Package_Body;
1133
1134    ----------------------------------
1135    -- Traverse_Package_Declaration --
1136    ----------------------------------
1137
1138    procedure Traverse_Package_Declaration
1139      (N       : Node_Id;
1140       Process : Node_Processing)
1141    is
1142       Spec : constant Node_Id := Specification (N);
1143    begin
1144       Traverse_Declarations_Or_Statements
1145         (Visible_Declarations (Spec), Process);
1146       Traverse_Declarations_Or_Statements
1147         (Private_Declarations (Spec), Process);
1148    end Traverse_Package_Declaration;
1149
1150    ------------------------------
1151    -- Traverse_Subprogram_Body --
1152    ------------------------------
1153
1154    procedure Traverse_Subprogram_Body
1155      (N       : Node_Id;
1156       Process : Node_Processing) is
1157    begin
1158       Traverse_Declarations_Or_Statements (Declarations (N), Process);
1159       Traverse_Handled_Statement_Sequence
1160         (Handled_Statement_Sequence (N), Process);
1161    end Traverse_Subprogram_Body;
1162
1163 end ALFA;