gcc/ada/lib-xref.adb

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