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