gcc/ada/lib-xref.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             L I B . X R E F                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1998-2006, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Csets;    use Csets;
  29 with Elists;   use Elists;
  30 with Errout;   use Errout;
  31 with Lib.Util; use Lib.Util;
  32 with Namet;    use Namet;
  33 with Nlists;   use Nlists;
  34 with Opt;      use Opt;
  35 with Restrict; use Restrict;
  36 with Rident;   use Rident;
  37 with Sem;      use Sem;
  38 with Sem_Prag; use Sem_Prag;
  39 with Sem_Util; use Sem_Util;
  40 with Sinfo;    use Sinfo;
  41 with Sinput;   use Sinput;
  42 with Snames;   use Snames;
  43 with Stringt;  use Stringt;
  44 with Stand;    use Stand;
  45 with Table;    use Table;
  46 with Widechar; use Widechar;
  47
  48 with GNAT.Heap_Sort_A;
  49
  50 package body Lib.Xref is
  51
  52    ------------------
  53    -- Declarations --
  54    ------------------
  55
  56    --  The Xref table is used to record references. The Loc field is set
  57    --  to No_Location for a definition entry.
  58
  59    subtype Xref_Entry_Number is Int;
  60
  61    type Xref_Entry is record
  62       Ent : Entity_Id;
  63       --  Entity referenced (E parameter to Generate_Reference)
  64
  65       Def : Source_Ptr;
  66       --  Original source location for entity being referenced. Note that
  67       --  these values are used only during the output process, they are
  68       --  not set when the entries are originally built. This is because
  69       --  private entities can be swapped when the initial call is made.
  70
  71       Loc : Source_Ptr;
  72       --  Location of reference (Original_Location (Sloc field of N parameter
  73       --  to Generate_Reference). Set to No_Location for the case of a
  74       --  defining occurrence.
  75
  76       Typ : Character;
  77       --  Reference type (Typ param to Generate_Reference)
  78
  79       Eun : Unit_Number_Type;
  80       --  Unit number corresponding to Ent
  81
  82       Lun : Unit_Number_Type;
  83       --  Unit number corresponding to Loc. Value is undefined and not
  84       --  referenced if Loc is set to No_Location.
  85
  86    end record;
  87
  88    package Xrefs is new Table.Table (
  89      Table_Component_Type => Xref_Entry,
  90      Table_Index_Type     => Xref_Entry_Number,
  91      Table_Low_Bound      => 1,
  92      Table_Initial        => Alloc.Xrefs_Initial,
  93      Table_Increment      => Alloc.Xrefs_Increment,
  94      Table_Name           => "Xrefs");
  95
  96    -------------------------
  97    -- Generate_Definition --
  98    -------------------------
  99
 100    procedure Generate_Definition (E : Entity_Id) is
 101       Loc  : Source_Ptr;
 102       Indx : Nat;
 103
 104    begin
 105       pragma Assert (Nkind (E) in N_Entity);
 106
 107       --  Note that we do not test Xref_Entity_Letters here. It is too
 108       --  early to do so, since we are often called before the entity
 109       --  is fully constructed, so that the Ekind is still E_Void.
 110
 111       if Opt.Xref_Active
 112
 113          --  Definition must come from source
 114          --  We make an exception for subprogram child units that have no
 115          --  spec. For these we generate a subprogram declaration for library
 116          --  use, and the corresponding entity does not come from source.
 117          --  Nevertheless, all references will be attached to it and we have
 118          --  to treat is as coming from user code.
 119
 120          and then (Comes_From_Source (E) or else Is_Child_Unit (E))
 121
 122          --  And must have a reasonable source location that is not
 123          --  within an instance (all entities in instances are ignored)
 124
 125          and then Sloc (E) > No_Location
 126          and then Instantiation_Location (Sloc (E)) = No_Location
 127
 128          --  And must be a non-internal name from the main source unit
 129
 130          and then In_Extended_Main_Source_Unit (E)
 131          and then not Is_Internal_Name (Chars (E))
 132       then
 133          Xrefs.Increment_Last;
 134          Indx := Xrefs.Last;
 135          Loc  := Original_Location (Sloc (E));
 136
 137          Xrefs.Table (Indx).Ent := E;
 138          Xrefs.Table (Indx).Loc := No_Location;
 139          Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
 140          Xrefs.Table (Indx).Lun := No_Unit;
 141          Set_Has_Xref_Entry (E);
 142
 143          if In_Inlined_Body then
 144             Set_Referenced (E);
 145          end if;
 146       end if;
 147    end Generate_Definition;
 148
 149    ---------------------------------
 150    -- Generate_Operator_Reference --
 151    ---------------------------------
 152
 153    procedure Generate_Operator_Reference
 154      (N : Node_Id;
 155       T : Entity_Id)
 156    is
 157    begin
 158       if not In_Extended_Main_Source_Unit (N) then
 159          return;
 160       end if;
 161
 162       --  If the operator is not a Standard operator, then we generate
 163       --  a real reference to the user defined operator.
 164
 165       if Sloc (Entity (N)) /= Standard_Location then
 166          Generate_Reference (Entity (N), N);
 167
 168          --  A reference to an implicit inequality operator is a also a
 169          --  reference to the user-defined equality.
 170
 171          if Nkind (N) = N_Op_Ne
 172            and then not Comes_From_Source (Entity (N))
 173            and then Present (Corresponding_Equality (Entity (N)))
 174          then
 175             Generate_Reference (Corresponding_Equality (Entity (N)), N);
 176          end if;
 177
 178       --  For the case of Standard operators, we mark the result type
 179       --  as referenced. This ensures that in the case where we are
 180       --  using a derived operator, we mark an entity of the unit that
 181       --  implicitly defines this operator as used. Otherwise we may
 182       --  think that no entity of the unit is used. The actual entity
 183       --  marked as referenced is the first subtype, which is the user
 184       --  defined entity that is relevant.
 185
 186       --  Note: we only do this for operators that come from source.
 187       --  The generated code sometimes reaches for entities that do
 188       --  not need to be explicitly visible (for example, when we
 189       --  expand the code for comparing two record types, the fields
 190       --  of the record may not be visible).
 191
 192       elsif Comes_From_Source (N) then
 193          Set_Referenced (First_Subtype (T));
 194       end if;
 195    end Generate_Operator_Reference;
 196
 197    ------------------------
 198    -- Generate_Reference --
 199    ------------------------
 200
 201    procedure Generate_Reference
 202      (E       : Entity_Id;
 203       N       : Node_Id;
 204       Typ     : Character := 'r';
 205       Set_Ref : Boolean   := True;
 206       Force   : Boolean   := False)
 207    is
 208       Indx : Nat;
 209       Nod  : Node_Id;
 210       Ref  : Source_Ptr;
 211       Def  : Source_Ptr;
 212       Ent  : Entity_Id;
 213
 214       function Is_On_LHS (Node : Node_Id) return Boolean;
 215       --  Used to check if a node is on the left hand side of an
 216       --  assignment. The following cases are handled:
 217       --
 218       --   Variable  Node is a direct descendant of an assignment
 219       --             statement.
 220       --
 221       --   Prefix    Of an indexed or selected component that is
 222       --             present in a subtree rooted by an assignment
 223       --             statement. There is no restriction of nesting
 224       --             of components, thus cases such as A.B(C).D are
 225       --             handled properly.
 226
 227       ---------------
 228       -- Is_On_LHS --
 229       ---------------
 230
 231       --  Couldn't we use Is_Lvalue or whatever it is called ???
 232
 233       function Is_On_LHS (Node : Node_Id) return Boolean is
 234          N : Node_Id := Node;
 235
 236       begin
 237          --  Only identifiers are considered, is this necessary???
 238
 239          if Nkind (N) /= N_Identifier then
 240             return False;
 241          end if;
 242
 243          --  Reach the assignment statement subtree root. In the
 244          --  case of a variable being a direct descendant of an
 245          --  assignment statement, the loop is skiped.
 246
 247          while Nkind (Parent (N)) /= N_Assignment_Statement loop
 248
 249             --  Check whether the parent is a component and the
 250             --  current node is its prefix.
 251
 252             if (Nkind (Parent (N)) = N_Selected_Component
 253                   or else
 254                 Nkind (Parent (N)) = N_Indexed_Component)
 255               and then Prefix (Parent (N)) = N
 256             then
 257                N := Parent (N);
 258             else
 259                return False;
 260             end if;
 261          end loop;
 262
 263          --  Parent (N) is assignment statement, check whether N is its name
 264
 265          return Name (Parent (N)) = N;
 266       end Is_On_LHS;
 267
 268    --  Start of processing for Generate_Reference
 269
 270    begin
 271       pragma Assert (Nkind (E) in N_Entity);
 272
 273       --  Check for obsolescent reference to ASCII
 274
 275       if E = Standard_ASCII then
 276          Check_Restriction (No_Obsolescent_Features, N);
 277       end if;
 278
 279       --  Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only
 280       --  detect real explicit references (modifications and references).
 281
 282       if Is_Ada_2005 (E)
 283         and then Ada_Version < Ada_05
 284         and then Warn_On_Ada_2005_Compatibility
 285         and then (Typ = 'm' or else Typ = 'r')
 286       then
 287          Error_Msg_NE ("& is only defined in Ada 2005?", N, E);
 288       end if;
 289
 290       --  Never collect references if not in main source unit. However, we omit
 291       --  this test if Typ is 'e' or 'k', since these entries are structural,
 292       --  and it is useful to have them in units that reference packages as
 293       --  well as units that define packages. We also omit the test for the
 294       --  case of 'p' since we want to include inherited primitive operations
 295       --  from other packages.
 296
 297       if not In_Extended_Main_Source_Unit (N)
 298         and then Typ /= 'e'
 299         and then Typ /= 'p'
 300         and then Typ /= 'k'
 301       then
 302          return;
 303       end if;
 304
 305       --  For reference type p, the entity must be in main source unit
 306
 307       if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then
 308          return;
 309       end if;
 310
 311       --  Unless the reference is forced, we ignore references where
 312       --  the reference itself does not come from Source.
 313
 314       if not Force and then not Comes_From_Source (N) then
 315          return;
 316       end if;
 317
 318       --  Deal with setting entity as referenced, unless suppressed.
 319       --  Note that we still do Set_Referenced on entities that do not
 320       --  come from source. This situation arises when we have a source
 321       --  reference to a derived operation, where the derived operation
 322       --  itself does not come from source, but we still want to mark it
 323       --  as referenced, since we really are referencing an entity in the
 324       --  corresponding package (this avoids incorrect complaints that the
 325       --  package contains no referenced entities).
 326
 327       if Set_Ref then
 328
 329          --  For a variable that appears on the left side of an
 330          --  assignment statement, we set the Referenced_As_LHS
 331          --  flag since this is indeed a left hand side.
 332          --  We also set the Referenced_As_LHS flag of a prefix
 333          --  of selected or indexed component.
 334
 335          if Ekind (E) = E_Variable
 336            and then Is_On_LHS (N)
 337          then
 338             Set_Referenced_As_LHS (E);
 339
 340          --  Check for a reference in a pragma that should not count as a
 341          --  making the variable referenced for warning purposes.
 342
 343          elsif Is_Non_Significant_Pragma_Reference (N) then
 344             null;
 345
 346          --  A reference in an attribute definition clause does not
 347          --  count as a reference except for the case of Address.
 348          --  The reason that 'Address is an exception is that it
 349          --  creates an alias through which the variable may be
 350          --  referenced.
 351
 352          elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause
 353            and then Chars (Parent (N)) /= Name_Address
 354            and then N = Name (Parent (N))
 355          then
 356             null;
 357
 358          --  Constant completion does not count as a reference
 359
 360          elsif Typ = 'c'
 361            and then Ekind (E) = E_Constant
 362          then
 363             null;
 364
 365          --  Record representation clause does not count as a reference
 366
 367          elsif Nkind (N) = N_Identifier
 368            and then Nkind (Parent (N)) = N_Record_Representation_Clause
 369          then
 370             null;
 371
 372          --  Discriminants do not need to produce a reference to record type
 373
 374          elsif Typ = 'd'
 375            and then Nkind (Parent (N)) = N_Discriminant_Specification
 376          then
 377             null;
 378
 379          --  Any other occurrence counts as referencing the entity
 380
 381          else
 382             Set_Referenced (E);
 383          end if;
 384
 385          --  Check for pragma Unreferenced given and reference is within
 386          --  this source unit (occasion for possible warning to be issued)
 387
 388          if Has_Pragma_Unreferenced (E)
 389            and then In_Same_Extended_Unit (E, N)
 390          then
 391             --  A reference as a named parameter in a call does not count
 392             --  as a violation of pragma Unreferenced for this purpose.
 393
 394             if Nkind (N) = N_Identifier
 395               and then Nkind (Parent (N)) = N_Parameter_Association
 396               and then Selector_Name (Parent (N)) = N
 397             then
 398                null;
 399
 400             --  Neither does a reference to a variable on the left side
 401             --  of an assignment.
 402
 403             elsif Is_On_LHS (N) then
 404                null;
 405
 406             --  For entry formals, we want to place the warning on the
 407             --  corresponding entity in the accept statement. The current
 408             --  scope is the body of the accept, so we find the formal
 409             --  whose name matches that of the entry formal (there is no
 410             --  link between the two entities, and the one in the accept
 411             --  statement is only used for conformance checking).
 412
 413             elsif Ekind (Scope (E)) = E_Entry then
 414                declare
 415                   BE : Entity_Id;
 416
 417                begin
 418                   BE := First_Entity (Current_Scope);
 419                   while Present (BE) loop
 420                      if Chars (BE) = Chars (E) then
 421                         Error_Msg_NE
 422                           ("?pragma Unreferenced given for&", N, BE);
 423                         exit;
 424                      end if;
 425
 426                      Next_Entity (BE);
 427                   end loop;
 428                end;
 429
 430             --  Here we issue the warning, since this is a real reference
 431
 432             else
 433                Error_Msg_NE ("?pragma Unreferenced given for&", N, E);
 434             end if;
 435          end if;
 436
 437          --  If this is a subprogram instance, mark as well the internal
 438          --  subprogram in the wrapper package, which may be a visible
 439          --  compilation unit.
 440
 441          if Is_Overloadable (E)
 442            and then Is_Generic_Instance (E)
 443            and then Present (Alias (E))
 444          then
 445             Set_Referenced (Alias (E));
 446          end if;
 447       end if;
 448
 449       --  Generate reference if all conditions are met:
 450
 451       if
 452          --  Cross referencing must be active
 453
 454          Opt.Xref_Active
 455
 456          --  The entity must be one for which we collect references
 457
 458          and then Xref_Entity_Letters (Ekind (E)) /= ' '
 459
 460          --  Both Sloc values must be set to something sensible
 461
 462          and then Sloc (E) > No_Location
 463          and then Sloc (N) > No_Location
 464
 465          --  We ignore references from within an instance
 466
 467          and then Instantiation_Location (Sloc (N)) = No_Location
 468
 469          --  Ignore dummy references
 470
 471         and then Typ /= ' '
 472       then
 473          if Nkind (N) = N_Identifier
 474               or else
 475             Nkind (N) = N_Defining_Identifier
 476               or else
 477             Nkind (N) in N_Op
 478               or else
 479             Nkind (N) = N_Defining_Operator_Symbol
 480               or else
 481             Nkind (N) = N_Operator_Symbol
 482               or else
 483             (Nkind (N) = N_Character_Literal
 484               and then Sloc (Entity (N)) /= Standard_Location)
 485               or else
 486             Nkind (N) = N_Defining_Character_Literal
 487          then
 488             Nod := N;
 489
 490          elsif Nkind (N) = N_Expanded_Name
 491                  or else
 492                Nkind (N) = N_Selected_Component
 493          then
 494             Nod := Selector_Name (N);
 495
 496          else
 497             return;
 498          end if;
 499
 500          --  Normal case of source entity comes from source
 501
 502          if Comes_From_Source (E) then
 503             Ent := E;
 504
 505          --  Entity does not come from source, but is a derived subprogram
 506          --  and the derived subprogram comes from source (after one or more
 507          --  derivations) in which case the reference is to parent subprogram.
 508
 509          elsif Is_Overloadable (E)
 510            and then Present (Alias (E))
 511          then
 512             Ent := Alias (E);
 513
 514             loop
 515                if Comes_From_Source (Ent) then
 516                   exit;
 517                elsif No (Alias (Ent)) then
 518                   return;
 519                else
 520                   Ent := Alias (Ent);
 521                end if;
 522             end loop;
 523
 524          --  The internally created defining entity for a child subprogram
 525          --  that has no previous spec has valid references.
 526
 527          elsif Is_Overloadable (E)
 528            and then Is_Child_Unit (E)
 529          then
 530             Ent := E;
 531
 532          --  Record components of discriminated subtypes or derived types
 533          --  must be treated as references to the original component.
 534
 535          elsif Ekind (E) = E_Component
 536            and then Comes_From_Source (Original_Record_Component (E))
 537          then
 538             Ent := Original_Record_Component (E);
 539
 540          --  Ignore reference to any other entity that is not from source
 541
 542          else
 543             return;
 544          end if;
 545
 546          --  Record reference to entity
 547
 548          Ref := Original_Location (Sloc (Nod));
 549          Def := Original_Location (Sloc (Ent));
 550
 551          Xrefs.Increment_Last;
 552          Indx := Xrefs.Last;
 553
 554          Xrefs.Table (Indx).Loc := Ref;
 555
 556          --  Overriding operations are marked with 'P'
 557
 558          if Typ = 'p'
 559            and then Is_Subprogram (N)
 560            and then Is_Overriding_Operation (N)
 561          then
 562             Xrefs.Table (Indx).Typ := 'P';
 563          else
 564             Xrefs.Table (Indx).Typ := Typ;
 565          end if;
 566
 567          Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
 568          Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
 569          Xrefs.Table (Indx).Ent := Ent;
 570          Set_Has_Xref_Entry (Ent);
 571       end if;
 572    end Generate_Reference;
 573
 574    -----------------------------------
 575    -- Generate_Reference_To_Formals --
 576    -----------------------------------
 577
 578    procedure Generate_Reference_To_Formals (E : Entity_Id) is
 579       Formal : Entity_Id;
 580
 581    begin
 582       if Is_Generic_Subprogram (E) then
 583          Formal := First_Entity (E);
 584
 585          while Present (Formal)
 586            and then not Is_Formal (Formal)
 587          loop
 588             Next_Entity (Formal);
 589          end loop;
 590
 591       else
 592          Formal := First_Formal (E);
 593       end if;
 594
 595       while Present (Formal) loop
 596          if Ekind (Formal) = E_In_Parameter then
 597
 598             if Nkind (Parameter_Type (Parent (Formal)))
 599               = N_Access_Definition
 600             then
 601                Generate_Reference (E, Formal, '^', False);
 602             else
 603                Generate_Reference (E, Formal, '>', False);
 604             end if;
 605
 606          elsif Ekind (Formal) = E_In_Out_Parameter then
 607             Generate_Reference (E, Formal, '=', False);
 608
 609          else
 610             Generate_Reference (E, Formal, '<', False);
 611          end if;
 612
 613          Next_Formal (Formal);
 614       end loop;
 615    end Generate_Reference_To_Formals;
 616
 617    -------------------------------------------
 618    -- Generate_Reference_To_Generic_Formals --
 619    -------------------------------------------
 620
 621    procedure Generate_Reference_To_Generic_Formals (E : Entity_Id) is
 622       Formal : Entity_Id;
 623
 624    begin
 625       Formal := First_Entity (E);
 626
 627       while Present (Formal) loop
 628          if Comes_From_Source (Formal) then
 629             Generate_Reference (E, Formal, 'z', False);
 630          end if;
 631
 632          Next_Entity (Formal);
 633       end loop;
 634    end Generate_Reference_To_Generic_Formals;
 635
 636    ----------------
 637    -- Initialize --
 638    ----------------
 639
 640    procedure Initialize is
 641    begin
 642       Xrefs.Init;
 643    end Initialize;
 644
 645    -----------------------
 646    -- Output_References --
 647    -----------------------
 648
 649    procedure Output_References is
 650
 651       procedure Get_Type_Reference
 652         (Ent   : Entity_Id;
 653          Tref  : out Entity_Id;
 654          Left  : out Character;
 655          Right : out Character);
 656       --  Given an entity id Ent, determines whether a type reference is
 657       --  required. If so, Tref is set to the entity for the type reference
 658       --  and Left and Right are set to the left/right brackets to be
 659       --  output for the reference. If no type reference is required, then
 660       --  Tref is set to Empty, and Left/Right are set to space.
 661
 662       procedure Output_Import_Export_Info (Ent : Entity_Id);
 663       --  Ouput language and external name information for an interfaced
 664       --  entity, using the format <language, external_name>,
 665
 666       ------------------------
 667       -- Get_Type_Reference --
 668       ------------------------
 669
 670       procedure Get_Type_Reference
 671         (Ent   : Entity_Id;
 672          Tref  : out Entity_Id;
 673          Left  : out Character;
 674          Right : out Character)
 675       is
 676          Sav : Entity_Id;
 677
 678       begin
 679          --  See if we have a type reference
 680
 681          Tref := Ent;
 682          Left := '{';
 683          Right := '}';
 684
 685          loop
 686             Sav := Tref;
 687
 688             --  Processing for types
 689
 690             if Is_Type (Tref) then
 691
 692                --  Case of base type
 693
 694                if Base_Type (Tref) = Tref then
 695
 696                   --  If derived, then get first subtype
 697
 698                   if Tref /= Etype (Tref) then
 699                      Tref := First_Subtype (Etype (Tref));
 700
 701                      --  Set brackets for derived type, but don't
 702                      --  override pointer case since the fact that
 703                      --  something is a pointer is more important
 704
 705                      if Left /= '(' then
 706                         Left := '<';
 707                         Right := '>';
 708                      end if;
 709
 710                   --  If non-derived ptr, get directly designated type.
 711                   --  If the type has a full view, all references are
 712                   --  on the partial view, that is seen first.
 713
 714                   elsif Is_Access_Type (Tref) then
 715                      Tref := Directly_Designated_Type (Tref);
 716                      Left := '(';
 717                      Right := ')';
 718
 719                   elsif Is_Private_Type (Tref)
 720                     and then Present (Full_View (Tref))
 721                   then
 722                      if Is_Access_Type (Full_View (Tref)) then
 723                         Tref := Directly_Designated_Type (Full_View (Tref));
 724                         Left := '(';
 725                         Right := ')';
 726
 727                      --  If the full view is an array type, we also retrieve
 728                      --  the corresponding component type, because the ali
 729                      --  entry already indicates that this is an array.
 730
 731                      elsif Is_Array_Type (Full_View (Tref)) then
 732                         Tref := Component_Type (Full_View (Tref));
 733                         Left := '(';
 734                         Right := ')';
 735                      end if;
 736
 737                   --  If non-derived array, get component type.
 738                   --  Skip component type for case of String
 739                   --  or Wide_String, saves worthwhile space.
 740
 741                   elsif Is_Array_Type (Tref)
 742                     and then Tref /= Standard_String
 743                     and then Tref /= Standard_Wide_String
 744                   then
 745                      Tref := Component_Type (Tref);
 746                      Left := '(';
 747                      Right := ')';
 748
 749                   --  For other non-derived base types, nothing
 750
 751                   else
 752                      exit;
 753                   end if;
 754
 755                --  For a subtype, go to ancestor subtype
 756
 757                else
 758                   Tref := Ancestor_Subtype (Tref);
 759
 760                   --  If no ancestor subtype, go to base type
 761
 762                   if No (Tref) then
 763                      Tref := Base_Type (Sav);
 764                   end if;
 765                end if;
 766
 767             --  For objects, functions, enum literals,
 768             --  just get type from Etype field.
 769
 770             elsif Is_Object (Tref)
 771               or else Ekind (Tref) = E_Enumeration_Literal
 772               or else Ekind (Tref) = E_Function
 773               or else Ekind (Tref) = E_Operator
 774             then
 775                Tref := Etype (Tref);
 776
 777             --  For anything else, exit
 778
 779             else
 780                exit;
 781             end if;
 782
 783             --  Exit if no type reference, or we are stuck in
 784             --  some loop trying to find the type reference, or
 785             --  if the type is standard void type (the latter is
 786             --  an implementation artifact that should not show
 787             --  up in the generated cross-references).
 788
 789             exit when No (Tref)
 790               or else Tref = Sav
 791               or else Tref = Standard_Void_Type;
 792
 793             --  If we have a usable type reference, return, otherwise
 794             --  keep looking for something useful (we are looking for
 795             --  something that either comes from source or standard)
 796
 797             if Sloc (Tref) = Standard_Location
 798               or else Comes_From_Source (Tref)
 799             then
 800                --  If the reference is a subtype created for a generic
 801                --  actual, go to actual directly, the inner subtype is
 802                --  not user visible.
 803
 804                if Nkind (Parent (Tref)) = N_Subtype_Declaration
 805                  and then not Comes_From_Source (Parent (Tref))
 806                  and then
 807                   (Is_Wrapper_Package (Scope (Tref))
 808                      or else Is_Generic_Instance (Scope (Tref)))
 809                then
 810                   Tref := First_Subtype (Base_Type (Tref));
 811                end if;
 812
 813                return;
 814             end if;
 815          end loop;
 816
 817          --  If we fall through the loop, no type reference
 818
 819          Tref := Empty;
 820          Left := ' ';
 821          Right := ' ';
 822       end Get_Type_Reference;
 823
 824       -------------------------------
 825       -- Output_Import_Export_Info --
 826       -------------------------------
 827
 828       procedure Output_Import_Export_Info (Ent : Entity_Id) is
 829          Language_Name : Name_Id;
 830          Conv          : constant Convention_Id := Convention (Ent);
 831       begin
 832          if Conv  = Convention_C then
 833             Language_Name := Name_C;
 834
 835          elsif Conv = Convention_CPP then
 836             Language_Name := Name_CPP;
 837
 838          elsif Conv = Convention_Ada then
 839             Language_Name := Name_Ada;
 840
 841          else
 842             --  These are the only languages that GPS knows about
 843
 844             return;
 845          end if;
 846
 847          Write_Info_Char ('<');
 848          Get_Unqualified_Name_String (Language_Name);
 849
 850          for J in 1 .. Name_Len loop
 851             Write_Info_Char (Name_Buffer (J));
 852          end loop;
 853
 854          if Present (Interface_Name (Ent)) then
 855             Write_Info_Char (',');
 856             String_To_Name_Buffer (Strval (Interface_Name (Ent)));
 857
 858             for J in 1 .. Name_Len loop
 859                Write_Info_Char (Name_Buffer (J));
 860             end loop;
 861          end if;
 862
 863          Write_Info_Char ('>');
 864       end Output_Import_Export_Info;
 865
 866    --  Start of processing for Output_References
 867
 868    begin
 869       if not Opt.Xref_Active then
 870          return;
 871       end if;
 872
 873       --  Before we go ahead and output the references we have a problem
 874       --  that needs dealing with. So far we have captured things that are
 875       --  definitely referenced by the main unit, or defined in the main
 876       --  unit. That's because we don't want to clutter up the ali file
 877       --  for this unit with definition lines for entities in other units
 878       --  that are not referenced.
 879
 880       --  But there is a glitch. We may reference an entity in another unit,
 881       --  and it may have a type reference to an entity that is not directly
 882       --  referenced in the main unit, which may mean that there is no xref
 883       --  entry for this entity yet in the list of references.
 884
 885       --  If we don't do something about this, we will end with an orphan
 886       --  type reference, i.e. it will point to an entity that does not
 887       --  appear within the generated references in the ali file. That is
 888       --  not good for tools using the xref information.
 889
 890       --  To fix this, we go through the references adding definition
 891       --  entries for any unreferenced entities that can be referenced
 892       --  in a type reference. There is a recursion problem here, and
 893       --  that is dealt with by making sure that this traversal also
 894       --  traverses any entries that get added by the traversal.
 895
 896       declare
 897          J    : Nat;
 898          Tref : Entity_Id;
 899          L, R : Character;
 900          Indx : Nat;
 901          Ent  : Entity_Id;
 902          Loc  : Source_Ptr;
 903
 904       begin
 905          --  Note that this is not a for loop for a very good reason. The
 906          --  processing of items in the table can add new items to the
 907          --  table, and they must be processed as well
 908
 909          J := 1;
 910          while J <= Xrefs.Last loop
 911             Ent := Xrefs.Table (J).Ent;
 912             Get_Type_Reference (Ent, Tref, L, R);
 913
 914             if Present (Tref)
 915               and then not Has_Xref_Entry (Tref)
 916               and then Sloc (Tref) > No_Location
 917             then
 918                Xrefs.Increment_Last;
 919                Indx := Xrefs.Last;
 920                Loc  := Original_Location (Sloc (Tref));
 921                Xrefs.Table (Indx).Ent := Tref;
 922                Xrefs.Table (Indx).Loc := No_Location;
 923                Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
 924                Xrefs.Table (Indx).Lun := No_Unit;
 925                Set_Has_Xref_Entry (Tref);
 926             end if;
 927
 928             --  Collect inherited primitive operations that may be
 929             --  declared in another unit and have no visible reference
 930             --  in the current one.
 931
 932             if Is_Type (Ent)
 933               and then Is_Tagged_Type (Ent)
 934               and then Is_Derived_Type (Ent)
 935               and then Ent = Base_Type (Ent)
 936               and then In_Extended_Main_Source_Unit (Ent)
 937             then
 938                declare
 939                   Op_List : constant Elist_Id := Primitive_Operations (Ent);
 940                   Op      : Elmt_Id;
 941                   Prim    : Entity_Id;
 942
 943                   function Parent_Op (E : Entity_Id) return Entity_Id;
 944                   --  Find original operation, which may be inherited
 945                   --  through several derivations.
 946
 947                   function Parent_Op (E : Entity_Id) return Entity_Id is
 948                      Orig_Op : constant Entity_Id := Alias (E);
 949                   begin
 950                      if No (Orig_Op) then
 951                         return Empty;
 952                      elsif not Comes_From_Source (E)
 953                        and then not Has_Xref_Entry (Orig_Op)
 954                        and then Comes_From_Source (Orig_Op)
 955                      then
 956                         return Orig_Op;
 957                      else
 958                         return Parent_Op (Orig_Op);
 959                      end if;
 960                   end Parent_Op;
 961
 962                begin
 963                   Op := First_Elmt (Op_List);
 964                   while Present (Op) loop
 965                      Prim := Parent_Op (Node (Op));
 966
 967                      if Present (Prim) then
 968                         Xrefs.Increment_Last;
 969                         Indx := Xrefs.Last;
 970                         Loc  := Original_Location (Sloc (Prim));
 971                         Xrefs.Table (Indx).Ent := Prim;
 972                         Xrefs.Table (Indx).Loc := No_Location;
 973                         Xrefs.Table (Indx).Eun :=
 974                           Get_Source_Unit (Sloc (Prim));
 975                         Xrefs.Table (Indx).Lun := No_Unit;
 976                         Set_Has_Xref_Entry (Prim);
 977                      end if;
 978
 979                      Next_Elmt (Op);
 980                   end loop;
 981                end;
 982             end if;
 983
 984             J := J + 1;
 985          end loop;
 986       end;
 987
 988       --  Now we have all the references, including those for any embedded
 989       --  type references, so we can sort them, and output them.
 990
 991       Output_Refs : declare
 992
 993          Nrefs : Nat := Xrefs.Last;
 994          --  Number of references in table. This value may get reset
 995          --  (reduced) when we eliminate duplicate reference entries.
 996
 997          Rnums : array (0 .. Nrefs) of Nat;
 998          --  This array contains numbers of references in the Xrefs table.
 999          --  This list is sorted in output order. The extra 0'th entry is
1000          --  convenient for the call to sort. When we sort the table, we
1001          --  move the entries in Rnums around, but we do not move the
1002          --  original table entries.
1003
1004          Curxu : Unit_Number_Type;
1005          --  Current xref unit
1006
1007          Curru : Unit_Number_Type;
1008          --  Current reference unit for one entity
1009
1010          Cursrc : Source_Buffer_Ptr;
1011          --  Current xref unit source text
1012
1013          Curent : Entity_Id;
1014          --  Current entity
1015
1016          Curnam : String (1 .. Name_Buffer'Length);
1017          Curlen : Natural;
1018          --  Simple name and length of current entity
1019
1020          Curdef : Source_Ptr;
1021          --  Original source location for current entity
1022
1023          Crloc : Source_Ptr;
1024          --  Current reference location
1025
1026          Ctyp : Character;
1027          --  Entity type character
1028
1029          Tref : Entity_Id;
1030          --  Type reference
1031
1032          Rref : Node_Id;
1033          --  Renaming reference
1034
1035          Trunit : Unit_Number_Type;
1036          --  Unit number for type reference
1037
1038          function Lt (Op1, Op2 : Natural) return Boolean;
1039          --  Comparison function for Sort call
1040
1041          function Name_Change (X : Entity_Id) return Boolean;
1042          --  Determines if entity X has a different simple name from Curent
1043
1044          procedure Move (From : Natural; To : Natural);
1045          --  Move procedure for Sort call
1046
1047          --------
1048          -- Lt --
1049          --------
1050
1051          function Lt (Op1, Op2 : Natural) return Boolean is
1052             T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
1053             T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
1054
1055          begin
1056             --  First test. If entity is in different unit, sort by unit
1057
1058             if T1.Eun /= T2.Eun then
1059                return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
1060
1061             --  Second test, within same unit, sort by entity Sloc
1062
1063             elsif T1.Def /= T2.Def then
1064                return T1.Def < T2.Def;
1065
1066             --  Third test, sort definitions ahead of references
1067
1068             elsif T1.Loc = No_Location then
1069                return True;
1070
1071             elsif T2.Loc = No_Location then
1072                return False;
1073
1074             --  Fourth test, for same entity, sort by reference location unit
1075
1076             elsif T1.Lun /= T2.Lun then
1077                return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
1078
1079             --  Fifth test order of location within referencing unit
1080
1081             elsif T1.Loc /= T2.Loc then
1082                return T1.Loc < T2.Loc;
1083
1084             --  Finally, for two locations at the same address, we prefer
1085             --  the one that does NOT have the type 'r' so that a modification
1086             --  or extension takes preference, when there are more than one
1087             --  reference at the same location.
1088
1089             else
1090                return T2.Typ = 'r';
1091             end if;
1092          end Lt;
1093
1094          ----------
1095          -- Move --
1096          ----------
1097
1098          procedure Move (From : Natural; To : Natural) is
1099          begin
1100             Rnums (Nat (To)) := Rnums (Nat (From));
1101          end Move;
1102
1103          -----------------
1104          -- Name_Change --
1105          -----------------
1106
1107          function Name_Change (X : Entity_Id) return Boolean is
1108          begin
1109             Get_Unqualified_Name_String (Chars (X));
1110
1111             if Name_Len /= Curlen then
1112                return True;
1113
1114             else
1115                return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
1116             end if;
1117          end Name_Change;
1118
1119       --  Start of processing for Output_Refs
1120
1121       begin
1122          --  Capture the definition Sloc values. We delay doing this till now,
1123          --  since at the time the reference or definition is made, private
1124          --  types may be swapped, and the Sloc value may be incorrect. We
1125          --  also set up the pointer vector for the sort.
1126
1127          for J in 1 .. Nrefs loop
1128             Rnums (J) := J;
1129             Xrefs.Table (J).Def :=
1130               Original_Location (Sloc (Xrefs.Table (J).Ent));
1131          end loop;
1132
1133          --  Sort the references
1134
1135          GNAT.Heap_Sort_A.Sort
1136            (Integer (Nrefs),
1137             Move'Unrestricted_Access,
1138             Lt'Unrestricted_Access);
1139
1140          --  Eliminate duplicate entries
1141
1142          declare
1143             NR : constant Nat := Nrefs;
1144
1145          begin
1146             --  We need this test for NR because if we force ALI file
1147             --  generation in case of errors detected, it may be the case
1148             --  that Nrefs is 0, so we should not reset it here
1149
1150             if NR >= 2 then
1151                Nrefs := 1;
1152
1153                for J in 2 .. NR loop
1154                   if Xrefs.Table (Rnums (J)) /=
1155                      Xrefs.Table (Rnums (Nrefs))
1156                   then
1157                      Nrefs := Nrefs + 1;
1158                      Rnums (Nrefs) := Rnums (J);
1159                   end if;
1160                end loop;
1161             end if;
1162          end;
1163
1164          --  Initialize loop through references
1165
1166          Curxu  := No_Unit;
1167          Curent := Empty;
1168          Curdef := No_Location;
1169          Curru  := No_Unit;
1170          Crloc  := No_Location;
1171
1172          --  Loop to output references
1173
1174          for Refno in 1 .. Nrefs loop
1175             Output_One_Ref : declare
1176                P2  : Source_Ptr;
1177                WC  : Char_Code;
1178                Err : Boolean;
1179                Ent : Entity_Id;
1180
1181                XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
1182                --  The current entry to be accessed
1183
1184                P : Source_Ptr;
1185                --  Used to index into source buffer to get entity name
1186
1187                Left  : Character;
1188                Right : Character;
1189                --  Used for {} or <> or () for type reference
1190
1191                procedure Output_Instantiation_Refs (Loc : Source_Ptr);
1192                --  Recursive procedure to output instantiation references for
1193                --  the given source ptr in [file|line[...]] form. No output
1194                --  if the given location is not a generic template reference.
1195
1196                procedure Output_Overridden_Op (Old_E : Entity_Id);
1197                --  For a subprogram that is overriding, display information
1198                --  about the inherited operation that it overrides.
1199
1200                -------------------------------
1201                -- Output_Instantiation_Refs --
1202                -------------------------------
1203
1204                procedure Output_Instantiation_Refs (Loc : Source_Ptr) is
1205                   Iloc : constant Source_Ptr := Instantiation_Location (Loc);
1206                   Lun  : Unit_Number_Type;
1207                   Cu   : constant Unit_Number_Type := Curru;
1208
1209                begin
1210                   --  Nothing to do if this is not an instantiation
1211
1212                   if Iloc = No_Location then
1213                      return;
1214                   end if;
1215
1216                   --  Output instantiation reference
1217
1218                   Write_Info_Char ('[');
1219                   Lun := Get_Source_Unit (Iloc);
1220
1221                   if Lun /= Curru then
1222                      Curru := Lun;
1223                      Write_Info_Nat (Dependency_Num (Curru));
1224                      Write_Info_Char ('|');
1225                   end if;
1226
1227                   Write_Info_Nat (Int (Get_Logical_Line_Number (Iloc)));
1228
1229                   --  Recursive call to get nested instantiations
1230
1231                   Output_Instantiation_Refs (Iloc);
1232
1233                   --  Output final ] after call to get proper nesting
1234
1235                   Write_Info_Char (']');
1236                   Curru := Cu;
1237                   return;
1238                end Output_Instantiation_Refs;
1239
1240                --------------------------
1241                -- Output_Overridden_Op --
1242                --------------------------
1243
1244                procedure Output_Overridden_Op (Old_E : Entity_Id) is
1245                begin
1246                   if Present (Old_E)
1247                     and then Sloc (Old_E) /= Standard_Location
1248                   then
1249                      declare
1250                         Loc      : constant Source_Ptr := Sloc (Old_E);
1251                         Par_Unit : constant Unit_Number_Type :=
1252                                      Get_Source_Unit (Loc);
1253                      begin
1254                         Write_Info_Char ('<');
1255
1256                         if Par_Unit /= Curxu then
1257                            Write_Info_Nat (Dependency_Num (Par_Unit));
1258                            Write_Info_Char ('|');
1259                         end if;
1260
1261                         Write_Info_Nat (Int (Get_Logical_Line_Number (Loc)));
1262                         Write_Info_Char ('p');
1263                         Write_Info_Nat (Int (Get_Column_Number (Loc)));
1264                         Write_Info_Char ('>');
1265                      end;
1266                   end if;
1267                end Output_Overridden_Op;
1268
1269             --  Start of processing for Output_One_Ref
1270
1271             begin
1272                Ent := XE.Ent;
1273                Ctyp := Xref_Entity_Letters (Ekind (Ent));
1274
1275                --  Skip reference if it is the only reference to an entity,
1276                --  and it is an end-line reference, and the entity is not in
1277                --  the current extended source. This prevents junk entries
1278                --  consisting only of packages with end lines, where no
1279                --  entity from the package is actually referenced.
1280
1281                if XE.Typ = 'e'
1282                  and then Ent /= Curent
1283                  and then (Refno = Nrefs or else
1284                              Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent)
1285                  and then
1286                    not In_Extended_Main_Source_Unit (Ent)
1287                then
1288                   goto Continue;
1289                end if;
1290
1291                --  For private type, get full view type
1292
1293                if Ctyp = '+'
1294                  and then Present (Full_View (XE.Ent))
1295                then
1296                   Ent := Underlying_Type (Ent);
1297
1298                   if Present (Ent) then
1299                      Ctyp := Xref_Entity_Letters (Ekind (Ent));
1300                   end if;
1301                end if;
1302
1303                --  Special exception for Boolean
1304
1305                if Ctyp = 'E' and then Is_Boolean_Type (Ent) then
1306                   Ctyp := 'B';
1307                end if;
1308
1309                --  For variable reference, get corresponding type
1310
1311                if Ctyp = '*' then
1312                   Ent := Etype (XE.Ent);
1313                   Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1314
1315                   --  If variable is private type, get full view type
1316
1317                   if Ctyp = '+'
1318                     and then Present (Full_View (Etype (XE.Ent)))
1319                   then
1320                      Ent := Underlying_Type (Etype (XE.Ent));
1321
1322                      if Present (Ent) then
1323                         Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1324                      end if;
1325
1326                   elsif Is_Generic_Type (Ent) then
1327
1328                      --  If the type of the entity is a  generic private type
1329                      --  there is no usable full view, so retain the indication
1330                      --  that this is an object.
1331
1332                      Ctyp := '*';
1333                   end if;
1334
1335                   --  Special handling for access parameter
1336
1337                   declare
1338                      K : constant Entity_Kind := Ekind (Etype (XE.Ent));
1339
1340                   begin
1341                      if (K = E_Anonymous_Access_Type
1342                            or else
1343                          K = E_Anonymous_Access_Subprogram_Type
1344                             or else K =
1345                          E_Anonymous_Access_Protected_Subprogram_Type)
1346                        and then Is_Formal (XE.Ent)
1347                      then
1348                         Ctyp := 'p';
1349
1350                         --  Special handling for Boolean
1351
1352                      elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
1353                         Ctyp := 'b';
1354                      end if;
1355                   end;
1356                end if;
1357
1358                --  Special handling for abstract types and operations
1359
1360                if Is_Abstract (XE.Ent) then
1361
1362                   if Ctyp = 'U' then
1363                      Ctyp := 'x';            --  abstract procedure
1364
1365                   elsif Ctyp = 'V' then
1366                      Ctyp := 'y';            --  abstract function
1367
1368                   elsif Ctyp = 'R' then
1369                      Ctyp := 'H';            --  abstract type
1370                   end if;
1371                end if;
1372
1373                --  Only output reference if interesting type of entity,
1374                --  and suppress self references, except for bodies that
1375                --  act as specs. Also suppress definitions of body formals
1376                --  (we only treat these as references, and the references
1377                --  were separately recorded).
1378
1379                if Ctyp = ' '
1380                  or else (XE.Loc = XE.Def
1381                             and then
1382                               (XE.Typ /= 'b'
1383                                 or else not Is_Subprogram (XE.Ent)))
1384                  or else (Is_Formal (XE.Ent)
1385                             and then Present (Spec_Entity (XE.Ent)))
1386                then
1387                   null;
1388
1389                else
1390                   --  Start new Xref section if new xref unit
1391
1392                   if XE.Eun /= Curxu then
1393                      if Write_Info_Col > 1 then
1394                         Write_Info_EOL;
1395                      end if;
1396
1397                      Curxu := XE.Eun;
1398                      Cursrc := Source_Text (Source_Index (Curxu));
1399
1400                      Write_Info_Initiate ('X');
1401                      Write_Info_Char (' ');
1402                      Write_Info_Nat (Dependency_Num (XE.Eun));
1403                      Write_Info_Char (' ');
1404                      Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
1405                   end if;
1406
1407                   --  Start new Entity line if new entity. Note that we
1408                   --  consider two entities the same if they have the same
1409                   --  name and source location. This causes entities in
1410                   --  instantiations to be treated as though they referred
1411                   --  to the template.
1412
1413                   if No (Curent)
1414                     or else
1415                       (XE.Ent /= Curent
1416                          and then
1417                            (Name_Change (XE.Ent) or else XE.Def /= Curdef))
1418                   then
1419                      Curent := XE.Ent;
1420                      Curdef := XE.Def;
1421
1422                      Get_Unqualified_Name_String (Chars (XE.Ent));
1423                      Curlen := Name_Len;
1424                      Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
1425
1426                      if Write_Info_Col > 1 then
1427                         Write_Info_EOL;
1428                      end if;
1429
1430                      --  Write column number information
1431
1432                      Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def)));
1433                      Write_Info_Char (Ctyp);
1434                      Write_Info_Nat (Int (Get_Column_Number (XE.Def)));
1435
1436                      --  Write level information
1437
1438                      Write_Level_Info : declare
1439                         function Is_Visible_Generic_Entity
1440                           (E : Entity_Id) return Boolean;
1441                         --  Check whether E is declared in the visible part
1442                         --  of a generic package. For source navigation
1443                         --  purposes, treat this as a visible entity.
1444
1445                         function Is_Private_Record_Component
1446                           (E : Entity_Id) return Boolean;
1447                         --  Check whether E is a non-inherited component of a
1448                         --  private extension. Even if the enclosing record is
1449                         --  public, we want to treat the component as private
1450                         --  for navigation purposes.
1451
1452                         ---------------------------------
1453                         -- Is_Private_Record_Component --
1454                         ---------------------------------
1455
1456                         function Is_Private_Record_Component
1457                           (E : Entity_Id) return Boolean
1458                         is
1459                            S : constant Entity_Id := Scope (E);
1460                         begin
1461                            return
1462                              Ekind (E) = E_Component
1463                                and then Nkind (Declaration_Node (S)) =
1464                                  N_Private_Extension_Declaration
1465                                and then Original_Record_Component (E) = E;
1466                         end Is_Private_Record_Component;
1467
1468                         -------------------------------
1469                         -- Is_Visible_Generic_Entity --
1470                         -------------------------------
1471
1472                         function Is_Visible_Generic_Entity
1473                           (E : Entity_Id) return Boolean
1474                         is
1475                            Par : Node_Id;
1476
1477                         begin
1478                            if Ekind (Scope (E)) /= E_Generic_Package then
1479                               return False;
1480                            end if;
1481
1482                            Par := Parent (E);
1483                            while Present (Par) loop
1484                               if
1485                                 Nkind (Par) = N_Generic_Package_Declaration
1486                               then
1487                                  --  Entity is a generic formal
1488
1489                                  return False;
1490
1491                               elsif
1492                                 Nkind (Parent (Par)) = N_Package_Specification
1493                               then
1494                                  return
1495                                    Is_List_Member (Par)
1496                                      and then List_Containing (Par) =
1497                                        Visible_Declarations (Parent (Par));
1498                               else
1499                                  Par := Parent (Par);
1500                               end if;
1501                            end loop;
1502
1503                            return False;
1504                         end Is_Visible_Generic_Entity;
1505
1506                      --  Start of processing for Write_Level_Info
1507
1508                      begin
1509                         if Is_Hidden (Curent)
1510                           or else Is_Private_Record_Component (Curent)
1511                         then
1512                            Write_Info_Char (' ');
1513
1514                         elsif
1515                            Is_Public (Curent)
1516                              or else Is_Visible_Generic_Entity (Curent)
1517                         then
1518                            Write_Info_Char ('*');
1519
1520                         else
1521                            Write_Info_Char (' ');
1522                         end if;
1523                      end Write_Level_Info;
1524
1525                      --  Output entity name. We use the occurrence from the
1526                      --  actual source program at the definition point
1527
1528                      P := Original_Location (Sloc (XE.Ent));
1529
1530                      --  Entity is character literal
1531
1532                      if Cursrc (P) = ''' then
1533                         Write_Info_Char (Cursrc (P));
1534                         Write_Info_Char (Cursrc (P + 1));
1535                         Write_Info_Char (Cursrc (P + 2));
1536
1537                      --  Entity is operator symbol
1538
1539                      elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
1540                         Write_Info_Char (Cursrc (P));
1541
1542                         P2 := P;
1543                         loop
1544                            P2 := P2 + 1;
1545                            Write_Info_Char (Cursrc (P2));
1546                            exit when Cursrc (P2) = Cursrc (P);
1547                         end loop;
1548
1549                      --  Entity is identifier
1550
1551                      else
1552                         loop
1553                            if Is_Start_Of_Wide_Char (Cursrc, P) then
1554                               Scan_Wide (Cursrc, P, WC, Err);
1555                            elsif not Identifier_Char (Cursrc (P)) then
1556                               exit;
1557                            else
1558                               P := P + 1;
1559                            end if;
1560                         end loop;
1561
1562                         for J in
1563                           Original_Location (Sloc (XE.Ent)) .. P - 1
1564                         loop
1565                            Write_Info_Char (Cursrc (J));
1566                         end loop;
1567                      end if;
1568
1569                      --  See if we have a renaming reference
1570
1571                      if Is_Object (XE.Ent)
1572                        and then Present (Renamed_Object (XE.Ent))
1573                      then
1574                         Rref := Renamed_Object (XE.Ent);
1575
1576                      elsif Is_Overloadable (XE.Ent)
1577                        and then Nkind (Parent (Declaration_Node (XE.Ent))) =
1578                                             N_Subprogram_Renaming_Declaration
1579                      then
1580                         Rref := Name (Parent (Declaration_Node (XE.Ent)));
1581
1582                      elsif Ekind (XE.Ent) = E_Package
1583                        and then Nkind (Declaration_Node (XE.Ent)) =
1584                                          N_Package_Renaming_Declaration
1585                      then
1586                         Rref := Name (Declaration_Node (XE.Ent));
1587
1588                      else
1589                         Rref := Empty;
1590                      end if;
1591
1592                      if Present (Rref) then
1593                         if Nkind (Rref) = N_Expanded_Name then
1594                            Rref := Selector_Name (Rref);
1595                         end if;
1596
1597                         if Nkind (Rref) = N_Identifier
1598                           or else Nkind (Rref) = N_Operator_Symbol
1599                         then
1600                            null;
1601
1602                         --  For renamed array components, use the array name
1603                         --  for the renamed entity, which reflect the fact that
1604                         --  in general the whole array is aliased.
1605
1606                         elsif Nkind (Rref) = N_Indexed_Component then
1607                            if Nkind (Prefix (Rref)) = N_Identifier then
1608                               Rref := Prefix (Rref);
1609                            elsif Nkind (Prefix (Rref)) = N_Expanded_Name then
1610                               Rref := Selector_Name (Prefix (Rref));
1611                            else
1612                               Rref := Empty;
1613                            end if;
1614
1615                         else
1616                            Rref := Empty;
1617                         end if;
1618                      end if;
1619
1620                      --  Write out renaming reference if we have one
1621
1622                      if Present (Rref) then
1623                         Write_Info_Char ('=');
1624                         Write_Info_Nat
1625                           (Int (Get_Logical_Line_Number (Sloc (Rref))));
1626                         Write_Info_Char (':');
1627                         Write_Info_Nat
1628                           (Int (Get_Column_Number (Sloc (Rref))));
1629                      end if;
1630
1631                      --  Indicate that the entity is in the unit
1632                      --  of the current xref xection.
1633
1634                      Curru := Curxu;
1635
1636                      --  Write out information about generic parent,
1637                      --  if entity is an instance.
1638
1639                      if  Is_Generic_Instance (XE.Ent) then
1640                         declare
1641                            Gen_Par : constant Entity_Id :=
1642                              Generic_Parent
1643                                (Specification
1644                                   (Unit_Declaration_Node (XE.Ent)));
1645                            Loc : constant Source_Ptr := Sloc (Gen_Par);
1646                            Gen_U : constant Unit_Number_Type :=
1647                                      Get_Source_Unit (Loc);
1648                         begin
1649                            Write_Info_Char ('[');
1650                            if Curru /= Gen_U then
1651                               Write_Info_Nat (Dependency_Num (Gen_U));
1652                               Write_Info_Char ('|');
1653                            end if;
1654
1655                            Write_Info_Nat
1656                              (Int (Get_Logical_Line_Number (Loc)));
1657                            Write_Info_Char (']');
1658                         end;
1659                      end if;
1660
1661                      --  See if we have a type reference and if so output
1662
1663                      Get_Type_Reference (XE.Ent, Tref, Left, Right);
1664
1665                      if Present (Tref) then
1666
1667                         --  Case of standard entity, output name
1668
1669                         if Sloc (Tref) = Standard_Location then
1670                            Write_Info_Char (Left);
1671                            Write_Info_Name (Chars (Tref));
1672                            Write_Info_Char (Right);
1673
1674                         --  Case of source entity, output location
1675
1676                         else
1677                            Write_Info_Char (Left);
1678                            Trunit := Get_Source_Unit (Sloc (Tref));
1679
1680                            if Trunit /= Curxu then
1681                               Write_Info_Nat (Dependency_Num (Trunit));
1682                               Write_Info_Char ('|');
1683                            end if;
1684
1685                            Write_Info_Nat
1686                              (Int (Get_Logical_Line_Number (Sloc (Tref))));
1687
1688                            declare
1689                               Ent  : Entity_Id := Tref;
1690                               Kind : constant Entity_Kind := Ekind (Ent);
1691                               Ctyp : Character := Xref_Entity_Letters (Kind);
1692
1693                            begin
1694                               if Ctyp = '+'
1695                                 and then Present (Full_View (Ent))
1696                               then
1697                                  Ent := Underlying_Type (Ent);
1698
1699                                  if Present (Ent) then
1700                                     Ctyp := Xref_Entity_Letters (Ekind (Ent));
1701                                  end if;
1702                               end if;
1703
1704                               Write_Info_Char (Ctyp);
1705                            end;
1706
1707                            Write_Info_Nat
1708                              (Int (Get_Column_Number (Sloc (Tref))));
1709
1710                            --  If the type comes from an instantiation,
1711                            --  add the corresponding info.
1712
1713                            Output_Instantiation_Refs (Sloc (Tref));
1714                            Write_Info_Char (Right);
1715                         end if;
1716                      end if;
1717
1718                      --  If the entity is an overriding operation, write
1719                      --  info on operation that was overridden.
1720
1721                      if Is_Subprogram (XE.Ent)
1722                        and then Is_Overriding_Operation (XE.Ent)
1723                      then
1724                         Output_Overridden_Op (Overridden_Operation (XE.Ent));
1725                      end if;
1726
1727                      --  End of processing for entity output
1728
1729                      Crloc := No_Location;
1730                   end if;
1731
1732                   --  Output the reference
1733
1734                   if XE.Loc /= No_Location
1735                      and then XE.Loc /= Crloc
1736                   then
1737                      Crloc := XE.Loc;
1738
1739                      --  Start continuation if line full, else blank
1740
1741                      if Write_Info_Col > 72 then
1742                         Write_Info_EOL;
1743                         Write_Info_Initiate ('.');
1744                      end if;
1745
1746                      Write_Info_Char (' ');
1747
1748                      --  Output file number if changed
1749
1750                      if XE.Lun /= Curru then
1751                         Curru := XE.Lun;
1752                         Write_Info_Nat (Dependency_Num (Curru));
1753                         Write_Info_Char ('|');
1754                      end if;
1755
1756                      Write_Info_Nat  (Int (Get_Logical_Line_Number (XE.Loc)));
1757                      Write_Info_Char (XE.Typ);
1758
1759                      if Is_Overloadable (XE.Ent)
1760                        and then Is_Imported (XE.Ent)
1761                        and then XE.Typ = 'b'
1762                      then
1763                         Output_Import_Export_Info (XE.Ent);
1764                      end if;
1765
1766                      Write_Info_Nat  (Int (Get_Column_Number (XE.Loc)));
1767
1768                      Output_Instantiation_Refs (Sloc (XE.Ent));
1769                   end if;
1770                end if;
1771             end Output_One_Ref;
1772
1773          <<Continue>>
1774             null;
1775          end loop;
1776
1777          Write_Info_EOL;
1778       end Output_Refs;
1779    end Output_References;
1780
1781 end Lib.Xref;