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