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