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