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