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 Lib.Util; use Lib.Util;
  31 with Nlists;   use Nlists;
  32 with Opt;      use Opt;
  33 with Restrict; use Restrict;
  34 with Rident;   use Rident;
  35 with Sem;      use Sem;
  36 with Sem_Aux;  use Sem_Aux;
  37 with Sem_Prag; use Sem_Prag;
  38 with Sem_Util; use Sem_Util;
  39 with Sem_Warn; use Sem_Warn;
  40 with Sinfo;    use Sinfo;
  41 with Sinput;   use Sinput;
  42 with Snames;   use Snames;
  43 with Stringt;  use Stringt;
  44 with Stand;    use Stand;
  45 with Table;    use Table;
  46 with Widechar; use Widechar;
  47
  48 with GNAT.Heap_Sort_G;
  49
  50 package body Lib.Xref is
  51
  52    ------------------
  53    -- Declarations --
  54    ------------------
  55
  56    --  The Xref table is used to record references. The Loc field is set
  57    --  to No_Location for a definition entry.
  58
  59    subtype Xref_Entry_Number is Int;
  60
  61    type Xref_Entry is record
  62       Ent : Entity_Id;
  63       --  Entity referenced (E parameter to Generate_Reference)
  64
  65       Sub : Entity_Id;
  66       --  Entity of the closest enclosing subprogram or package
  67
  68       Def : Source_Ptr;
  69       --  Original source location for entity being referenced. Note that these
  70       --  values are used only during the output process, they are not set when
  71       --  the entries are originally built. This is because private entities
  72       --  can be swapped when the initial call is made.
  73
  74       Loc : Source_Ptr;
  75       --  Location of reference (Original_Location (Sloc field of N parameter
  76       --  to Generate_Reference). Set to No_Location for the case of a
  77       --  defining occurrence.
  78
  79       Slc : Source_Ptr;
  80       --  Original source location for entity Sub
  81
  82       Typ : Character;
  83       --  Reference type (Typ param to Generate_Reference)
  84
  85       Eun : Unit_Number_Type;
  86       --  Unit number corresponding to Ent
  87
  88       Sun : Unit_Number_Type;
  89       --  Unit number corresponding to Sub
  90
  91       Lun : Unit_Number_Type;
  92       --  Unit number corresponding to Loc. Value is undefined and not
  93       --  referenced if Loc is set to No_Location.
  94
  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    --  Local Subprograms --
 107    ------------------------
 108
 109    function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id;
 110    --  Return the closest enclosing subprogram of package
 111
 112    function Is_Local_Reference_Type (Typ : Character) return Boolean;
 113    --  Return whether Typ is a suitable reference type for a local reference
 114
 115    procedure Generate_Prim_Op_References (Typ : Entity_Id);
 116    --  For a tagged type, generate implicit references to its primitive
 117    --  operations, for source navigation. This is done right before emitting
 118    --  cross-reference information rather than at the freeze point of the type
 119    --  in order to handle late bodies that are primitive operations.
 120
 121    function Lt (T1, T2 : Xref_Entry) return Boolean;
 122    --  Order cross-references
 123
 124    procedure Write_Entity_Name (E : Entity_Id; Cursrc : Source_Buffer_Ptr);
 125    --  Output entity name for E. We use the occurrence from the actual
 126    --  source program at the definition point.
 127
 128    -------------------------------------
 129    -- Enclosing_Subprogram_Or_Package --
 130    -------------------------------------
 131
 132    function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id
 133    is
 134       Result : Entity_Id;
 135
 136    begin
 137       Result := N;
 138       loop
 139          exit when No (Result);
 140
 141          case Nkind (Result) is
 142             when N_Package_Specification =>
 143                Result := Defining_Unit_Name (Result);
 144                exit;
 145
 146             when N_Package_Body =>
 147                Result := Corresponding_Spec (Result);
 148                exit;
 149
 150             when N_Subprogram_Specification =>
 151                Result := Defining_Unit_Name (Result);
 152                exit;
 153
 154             when N_Subprogram_Declaration =>
 155                Result := Defining_Unit_Name (Specification (Result));
 156                exit;
 157
 158             when N_Subprogram_Body =>
 159                Result := Defining_Unit_Name (Specification (Result));
 160                exit;
 161
 162             when others =>
 163                Result := Parent (Result);
 164          end case;
 165       end loop;
 166
 167       if Nkind (Result) = N_Defining_Program_Unit_Name then
 168          Result := Defining_Identifier (Result);
 169       end if;
 170
 171       return Result;
 172    end Enclosing_Subprogram_Or_Package;
 173
 174    -------------------------
 175    -- Generate_Definition --
 176    -------------------------
 177
 178    procedure Generate_Definition (E : Entity_Id) is
 179       Loc  : Source_Ptr;
 180       Indx : Nat;
 181
 182    begin
 183       pragma Assert (Nkind (E) in N_Entity);
 184
 185       --  Note that we do not test Xref_Entity_Letters here. It is too early
 186       --  to do so, since we are often called before the entity is fully
 187       --  constructed, so that the Ekind is still E_Void.
 188
 189       if Opt.Xref_Active
 190
 191          --  Definition must come from source
 192
 193          --  We make an exception for subprogram child units that have no spec.
 194          --  For these we generate a subprogram declaration for library use,
 195          --  and the corresponding entity does not come from source.
 196          --  Nevertheless, all references will be attached to it and we have
 197          --  to treat is as coming from user code.
 198
 199          and then (Comes_From_Source (E) or else Is_Child_Unit (E))
 200
 201          --  And must have a reasonable source location that is not
 202          --  within an instance (all entities in instances are ignored)
 203
 204          and then Sloc (E) > No_Location
 205          and then Instantiation_Location (Sloc (E)) = No_Location
 206
 207          --  And must be a non-internal name from the main source unit
 208
 209          and then In_Extended_Main_Source_Unit (E)
 210          and then not Is_Internal_Name (Chars (E))
 211       then
 212          Xrefs.Increment_Last;
 213          Indx := Xrefs.Last;
 214          Loc  := Original_Location (Sloc (E));
 215
 216          Xrefs.Table (Indx).Ent := E;
 217
 218          if ALFA_Mode
 219            and then Nkind_In (Parent (E),
 220                               N_Object_Declaration,
 221                               N_Parameter_Specification)
 222          then
 223             --  In ALFA mode, define precise 'D' references for object
 224             --  definition.
 225
 226             declare
 227                Sub : constant Entity_Id := Enclosing_Subprogram_Or_Package (E);
 228                Slc : constant Source_Ptr := Original_Location (Sloc (Sub));
 229                Sun : constant Unit_Number_Type := Get_Source_Unit (Slc);
 230             begin
 231                Xrefs.Table (Indx).Typ := 'D';
 232                Xrefs.Table (Indx).Sub := Sub;
 233                Xrefs.Table (Indx).Def := Loc;
 234                Xrefs.Table (Indx).Loc := Loc;
 235                Xrefs.Table (Indx).Slc := Slc;
 236                Xrefs.Table (Indx).Lun := Get_Source_Unit (Loc);
 237                Xrefs.Table (Indx).Sun := Sun;
 238             end;
 239          else
 240             Xrefs.Table (Indx).Typ := ' ';
 241             Xrefs.Table (Indx).Sub := Empty;
 242             Xrefs.Table (Indx).Def := No_Location;
 243             Xrefs.Table (Indx).Loc := No_Location;
 244             Xrefs.Table (Indx).Slc := No_Location;
 245             Xrefs.Table (Indx).Lun := No_Unit;
 246             Xrefs.Table (Indx).Sun := No_Unit;
 247          end if;
 248
 249          Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
 250          Set_Has_Xref_Entry (E);
 251
 252          if In_Inlined_Body then
 253             Set_Referenced (E);
 254          end if;
 255       end if;
 256    end Generate_Definition;
 257
 258    ---------------------------------
 259    -- Generate_Operator_Reference --
 260    ---------------------------------
 261
 262    procedure Generate_Operator_Reference
 263      (N : Node_Id;
 264       T : Entity_Id)
 265    is
 266    begin
 267       if not In_Extended_Main_Source_Unit (N) then
 268          return;
 269       end if;
 270
 271       --  If the operator is not a Standard operator, then we generate a real
 272       --  reference to the user defined operator.
 273
 274       if Sloc (Entity (N)) /= Standard_Location then
 275          Generate_Reference (Entity (N), N);
 276
 277          --  A reference to an implicit inequality operator is also a reference
 278          --  to the user-defined equality.
 279
 280          if Nkind (N) = N_Op_Ne
 281            and then not Comes_From_Source (Entity (N))
 282            and then Present (Corresponding_Equality (Entity (N)))
 283          then
 284             Generate_Reference (Corresponding_Equality (Entity (N)), N);
 285          end if;
 286
 287       --  For the case of Standard operators, we mark the result type as
 288       --  referenced. This ensures that in the case where we are using a
 289       --  derived operator, we mark an entity of the unit that implicitly
 290       --  defines this operator as used. Otherwise we may think that no entity
 291       --  of the unit is used. The actual entity marked as referenced is the
 292       --  first subtype, which is the relevant user defined entity.
 293
 294       --  Note: we only do this for operators that come from source. The
 295       --  generated code sometimes reaches for entities that do not need to be
 296       --  explicitly visible (for example, when we expand the code for
 297       --  comparing two record objects, the fields of the record may not be
 298       --  visible).
 299
 300       elsif Comes_From_Source (N) then
 301          Set_Referenced (First_Subtype (T));
 302       end if;
 303    end Generate_Operator_Reference;
 304
 305    ---------------------------------
 306    -- Generate_Prim_Op_References --
 307    ---------------------------------
 308
 309    procedure Generate_Prim_Op_References (Typ : Entity_Id) is
 310       Base_T    : Entity_Id;
 311       Prim      : Elmt_Id;
 312       Prim_List : Elist_Id;
 313
 314    begin
 315       --  Handle subtypes of synchronized types
 316
 317       if Ekind (Typ) = E_Protected_Subtype
 318         or else Ekind (Typ) = E_Task_Subtype
 319       then
 320          Base_T := Etype (Typ);
 321       else
 322          Base_T := Typ;
 323       end if;
 324
 325       --  References to primitive operations are only relevant for tagged types
 326
 327       if not Is_Tagged_Type (Base_T)
 328         or else Is_Class_Wide_Type (Base_T)
 329       then
 330          return;
 331       end if;
 332
 333       --  Ada 2005 (AI-345): For synchronized types generate reference
 334       --  to the wrapper that allow us to dispatch calls through their
 335       --  implemented abstract interface types.
 336
 337       --  The check for Present here is to protect against previously
 338       --  reported critical errors.
 339
 340       Prim_List := Primitive_Operations (Base_T);
 341
 342       if No (Prim_List) then
 343          return;
 344       end if;
 345
 346       Prim := First_Elmt (Prim_List);
 347       while Present (Prim) loop
 348
 349          --  If the operation is derived, get the original for cross-reference
 350          --  reference purposes (it is the original for which we want the xref
 351          --  and for which the comes_from_source test must be performed).
 352
 353          Generate_Reference
 354            (Typ, Ultimate_Alias (Node (Prim)), 'p', Set_Ref => False);
 355          Next_Elmt (Prim);
 356       end loop;
 357    end Generate_Prim_Op_References;
 358
 359    ------------------------
 360    -- Generate_Reference --
 361    ------------------------
 362
 363    procedure Generate_Reference
 364      (E       : Entity_Id;
 365       N       : Node_Id;
 366       Typ     : Character := 'r';
 367       Set_Ref : Boolean   := True;
 368       Force   : Boolean   := False)
 369    is
 370       Indx : Nat;
 371       Nod  : Node_Id;
 372       Ref  : Source_Ptr;
 373       Def  : Source_Ptr;
 374       Slc  : Source_Ptr;
 375       Ent  : Entity_Id;
 376       Sub  : Entity_Id;
 377
 378       Call   : Node_Id;
 379       Formal : Entity_Id;
 380       --  Used for call to Find_Actual
 381
 382       Kind : Entity_Kind;
 383       --  If Formal is non-Empty, then its Ekind, otherwise E_Void
 384
 385       function Is_On_LHS (Node : Node_Id) return Boolean;
 386       --  Used to check if a node is on the left hand side of an assignment.
 387       --  The following cases are handled:
 388       --
 389       --   Variable    Node is a direct descendant of left hand side of an
 390       --               assignment statement.
 391       --
 392       --   Prefix      Of an indexed or selected component that is present in
 393       --               a subtree rooted by an assignment statement. There is
 394       --               no restriction of nesting of components, thus cases
 395       --               such as A.B (C).D are handled properly. However a prefix
 396       --               of a dereference (either implicit or explicit) is never
 397       --               considered as on a LHS.
 398       --
 399       --   Out param   Same as above cases, but OUT parameter
 400
 401       function OK_To_Set_Referenced return Boolean;
 402       --  Returns True if the Referenced flag can be set. There are a few
 403       --  exceptions where we do not want to set this flag, see body for
 404       --  details of these exceptional cases.
 405
 406       ---------------
 407       -- Is_On_LHS --
 408       ---------------
 409
 410       --  ??? There are several routines here and there that perform a similar
 411       --      (but subtly different) computation, which should be factored:
 412
 413       --      Sem_Util.May_Be_Lvalue
 414       --      Sem_Util.Known_To_Be_Assigned
 415       --      Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context
 416       --      Exp_Smem.Is_Out_Actual
 417
 418       function Is_On_LHS (Node : Node_Id) return Boolean is
 419          N : Node_Id;
 420          P : Node_Id;
 421          K : Node_Kind;
 422
 423       begin
 424          --  Only identifiers are considered, is this necessary???
 425
 426          if Nkind (Node) /= N_Identifier then
 427             return False;
 428          end if;
 429
 430          --  Immediate return if appeared as OUT parameter
 431
 432          if Kind = E_Out_Parameter then
 433             return True;
 434          end if;
 435
 436          --  Search for assignment statement subtree root
 437
 438          N := Node;
 439          loop
 440             P := Parent (N);
 441             K := Nkind (P);
 442
 443             if K = N_Assignment_Statement then
 444                return Name (P) = N;
 445
 446             --  Check whether the parent is a component and the current node is
 447             --  its prefix, but return False if the current node has an access
 448             --  type, as in that case the selected or indexed component is an
 449             --  implicit dereference, and the LHS is the designated object, not
 450             --  the access object.
 451
 452             --  ??? case of a slice assignment?
 453
 454             --  ??? Note that in some cases this is called too early
 455             --  (see comments in Sem_Ch8.Find_Direct_Name), at a point where
 456             --  the tree is not fully typed yet. In that case we may lack
 457             --  an Etype for N, and we must disable the check for an implicit
 458             --  dereference. If the dereference is on an LHS, this causes a
 459             --  false positive.
 460
 461             elsif (K = N_Selected_Component or else K = N_Indexed_Component)
 462               and then Prefix (P) = N
 463               and then not (Present (Etype (N))
 464                               and then
 465                             Is_Access_Type (Etype (N)))
 466             then
 467                N := P;
 468
 469             --  All other cases, definitely not on left side
 470
 471             else
 472                return False;
 473             end if;
 474          end loop;
 475       end Is_On_LHS;
 476
 477       ---------------------------
 478       -- OK_To_Set_Referenced --
 479       ---------------------------
 480
 481       function OK_To_Set_Referenced return Boolean is
 482          P : Node_Id;
 483
 484       begin
 485          --  A reference from a pragma Unreferenced or pragma Unmodified or
 486          --  pragma Warnings does not cause the Referenced flag to be set.
 487          --  This avoids silly warnings about things being referenced and
 488          --  not assigned when the only reference is from the pragma.
 489
 490          if Nkind (N) = N_Identifier then
 491             P := Parent (N);
 492
 493             if Nkind (P) = N_Pragma_Argument_Association then
 494                P := Parent (P);
 495
 496                if Nkind (P) = N_Pragma then
 497                   if Pragma_Name (P) = Name_Warnings
 498                        or else
 499                      Pragma_Name (P) = Name_Unmodified
 500                        or else
 501                      Pragma_Name (P) = Name_Unreferenced
 502                   then
 503                      return False;
 504                   end if;
 505                end if;
 506             end if;
 507          end if;
 508
 509          return True;
 510       end OK_To_Set_Referenced;
 511
 512    --  Start of processing for Generate_Reference
 513
 514    begin
 515       pragma Assert (Nkind (E) in N_Entity);
 516       Find_Actual (N, Formal, Call);
 517
 518       if Present (Formal) then
 519          Kind := Ekind (Formal);
 520       else
 521          Kind := E_Void;
 522       end if;
 523
 524       --  Check for obsolescent reference to package ASCII. GNAT treats this
 525       --  element of annex J specially since in practice, programs make a lot
 526       --  of use of this feature, so we don't include it in the set of features
 527       --  diagnosed when Warn_On_Obsolescent_Features mode is set. However we
 528       --  are required to note it as a violation of the RM defined restriction.
 529
 530       if E = Standard_ASCII then
 531          Check_Restriction (No_Obsolescent_Features, N);
 532       end if;
 533
 534       --  Check for reference to entity marked with Is_Obsolescent
 535
 536       --  Note that we always allow obsolescent references in the compiler
 537       --  itself and the run time, since we assume that we know what we are
 538       --  doing in such cases. For example the calls in Ada.Characters.Handling
 539       --  to its own obsolescent subprograms are just fine.
 540
 541       --  In any case we do not generate warnings within the extended source
 542       --  unit of the entity in question, since we assume the source unit
 543       --  itself knows what is going on (and for sure we do not want silly
 544       --  warnings, e.g. on the end line of an obsolescent procedure body).
 545
 546       if Is_Obsolescent (E)
 547         and then not GNAT_Mode
 548         and then not In_Extended_Main_Source_Unit (E)
 549       then
 550          Check_Restriction (No_Obsolescent_Features, N);
 551
 552          if Warn_On_Obsolescent_Feature then
 553             Output_Obsolescent_Entity_Warnings (N, E);
 554          end if;
 555       end if;
 556
 557       --  Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only
 558       --  detect real explicit references (modifications and references).
 559
 560       if Comes_From_Source (N)
 561         and then Is_Ada_2005_Only (E)
 562         and then Ada_Version < Ada_2005
 563         and then Warn_On_Ada_2005_Compatibility
 564         and then (Typ = 'm' or else Typ = 'r' or else Typ = 's')
 565       then
 566          Error_Msg_NE ("& is only defined in Ada 2005?", N, E);
 567       end if;
 568
 569       --  Warn if reference to Ada 2012 entity not in Ada 2012 mode. We only
 570       --  detect real explicit references (modifications and references).
 571
 572       if Comes_From_Source (N)
 573         and then Is_Ada_2012_Only (E)
 574         and then Ada_Version < Ada_2012
 575         and then Warn_On_Ada_2012_Compatibility
 576         and then (Typ = 'm' or else Typ = 'r')
 577       then
 578          Error_Msg_NE ("& is only defined in Ada 2012?", N, E);
 579       end if;
 580
 581       --  Never collect references if not in main source unit. However, we omit
 582       --  this test if Typ is 'e' or 'k', since these entries are structural,
 583       --  and it is useful to have them in units that reference packages as
 584       --  well as units that define packages. We also omit the test for the
 585       --  case of 'p' since we want to include inherited primitive operations
 586       --  from other packages.
 587
 588       --  We also omit this test is this is a body reference for a subprogram
 589       --  instantiation. In this case the reference is to the generic body,
 590       --  which clearly need not be in the main unit containing the instance.
 591       --  For the same reason we accept an implicit reference generated for
 592       --  a default in an instance.
 593
 594       if not In_Extended_Main_Source_Unit (N) then
 595          if Typ = 'e'
 596            or else Typ = 'I'
 597            or else Typ = 'p'
 598            or else Typ = 'i'
 599            or else Typ = 'k'
 600            or else (Typ = 'b' and then Is_Generic_Instance (E))
 601          then
 602             null;
 603          else
 604             return;
 605          end if;
 606       end if;
 607
 608       --  For reference type p, the entity must be in main source unit
 609
 610       if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then
 611          return;
 612       end if;
 613
 614       --  Unless the reference is forced, we ignore references where the
 615       --  reference itself does not come from source.
 616
 617       if not Force and then not Comes_From_Source (N) then
 618          return;
 619       end if;
 620
 621       --  Deal with setting entity as referenced, unless suppressed. Note that
 622       --  we still do Set_Referenced on entities that do not come from source.
 623       --  This situation arises when we have a source reference to a derived
 624       --  operation, where the derived operation itself does not come from
 625       --  source, but we still want to mark it as referenced, since we really
 626       --  are referencing an entity in the corresponding package (this avoids
 627       --  wrong complaints that the package contains no referenced entities).
 628
 629       if Set_Ref then
 630
 631          --  Assignable object appearing on left side of assignment or as
 632          --  an out parameter.
 633
 634          if Is_Assignable (E)
 635            and then Is_On_LHS (N)
 636            and then Ekind (E) /= E_In_Out_Parameter
 637          then
 638             --  For objects that are renamings, just set as simply referenced
 639             --  we do not try to do assignment type tracking in this case.
 640
 641             if Present (Renamed_Object (E)) then
 642                Set_Referenced (E);
 643
 644             --  Out parameter case
 645
 646             elsif Kind = E_Out_Parameter then
 647
 648                --  If warning mode for all out parameters is set, or this is
 649                --  the only warning parameter, then we want to mark this for
 650                --  later warning logic by setting Referenced_As_Out_Parameter
 651
 652                if Warn_On_Modified_As_Out_Parameter (Formal) then
 653                   Set_Referenced_As_Out_Parameter (E, True);
 654                   Set_Referenced_As_LHS (E, False);
 655
 656                --  For OUT parameter not covered by the above cases, we simply
 657                --  regard it as a normal reference (in this case we do not
 658                --  want any of the warning machinery for out parameters).
 659
 660                else
 661                   Set_Referenced (E);
 662                end if;
 663
 664             --  For the left hand of an assignment case, we do nothing here.
 665             --  The processing for Analyze_Assignment_Statement will set the
 666             --  Referenced_As_LHS flag.
 667
 668             else
 669                null;
 670             end if;
 671
 672          --  Check for a reference in a pragma that should not count as a
 673          --  making the variable referenced for warning purposes.
 674
 675          elsif Is_Non_Significant_Pragma_Reference (N) then
 676             null;
 677
 678          --  A reference in an attribute definition clause does not count as a
 679          --  reference except for the case of Address. The reason that 'Address
 680          --  is an exception is that it creates an alias through which the
 681          --  variable may be referenced.
 682
 683          elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause
 684            and then Chars (Parent (N)) /= Name_Address
 685            and then N = Name (Parent (N))
 686          then
 687             null;
 688
 689          --  Constant completion does not count as a reference
 690
 691          elsif Typ = 'c'
 692            and then Ekind (E) = E_Constant
 693          then
 694             null;
 695
 696          --  Record representation clause does not count as a reference
 697
 698          elsif Nkind (N) = N_Identifier
 699            and then Nkind (Parent (N)) = N_Record_Representation_Clause
 700          then
 701             null;
 702
 703          --  Discriminants do not need to produce a reference to record type
 704
 705          elsif Typ = 'd'
 706            and then Nkind (Parent (N)) = N_Discriminant_Specification
 707          then
 708             null;
 709
 710          --  All other cases
 711
 712          else
 713             --  Special processing for IN OUT parameters, where we have an
 714             --  implicit assignment to a simple variable.
 715
 716             if Kind = E_In_Out_Parameter
 717               and then Is_Assignable (E)
 718             then
 719                --  For sure this counts as a normal read reference
 720
 721                Set_Referenced (E);
 722                Set_Last_Assignment (E, Empty);
 723
 724                --  We count it as being referenced as an out parameter if the
 725                --  option is set to warn on all out parameters, except that we
 726                --  have a special exclusion for an intrinsic subprogram, which
 727                --  is most likely an instantiation of Unchecked_Deallocation
 728                --  which we do not want to consider as an assignment since it
 729                --  generates false positives. We also exclude the case of an
 730                --  IN OUT parameter if the name of the procedure is Free,
 731                --  since we suspect similar semantics.
 732
 733                if Warn_On_All_Unread_Out_Parameters
 734                  and then Is_Entity_Name (Name (Call))
 735                  and then not Is_Intrinsic_Subprogram (Entity (Name (Call)))
 736                  and then Chars (Name (Call)) /= Name_Free
 737                then
 738                   Set_Referenced_As_Out_Parameter (E, True);
 739                   Set_Referenced_As_LHS (E, False);
 740                end if;
 741
 742             --  Don't count a recursive reference within a subprogram as a
 743             --  reference (that allows detection of a recursive subprogram
 744             --  whose only references are recursive calls as unreferenced).
 745
 746             elsif Is_Subprogram (E)
 747               and then E = Nearest_Dynamic_Scope (Current_Scope)
 748             then
 749                null;
 750
 751             --  Any other occurrence counts as referencing the entity
 752
 753             elsif OK_To_Set_Referenced then
 754                Set_Referenced (E);
 755
 756                --  If variable, this is an OK reference after an assignment
 757                --  so we can clear the Last_Assignment indication.
 758
 759                if Is_Assignable (E) then
 760                   Set_Last_Assignment (E, Empty);
 761                end if;
 762             end if;
 763          end if;
 764
 765          --  Check for pragma Unreferenced given and reference is within
 766          --  this source unit (occasion for possible warning to be issued).
 767
 768          if Has_Unreferenced (E)
 769            and then In_Same_Extended_Unit (E, N)
 770          then
 771             --  A reference as a named parameter in a call does not count
 772             --  as a violation of pragma Unreferenced for this purpose...
 773
 774             if Nkind (N) = N_Identifier
 775               and then Nkind (Parent (N)) = N_Parameter_Association
 776               and then Selector_Name (Parent (N)) = N
 777             then
 778                null;
 779
 780             --  ... Neither does a reference to a variable on the left side
 781             --  of an assignment.
 782
 783             elsif Is_On_LHS (N) then
 784                null;
 785
 786             --  For entry formals, we want to place the warning message on the
 787             --  corresponding entity in the accept statement. The current scope
 788             --  is the body of the accept, so we find the formal whose name
 789             --  matches that of the entry formal (there is no link between the
 790             --  two entities, and the one in the accept statement is only used
 791             --  for conformance checking).
 792
 793             elsif Ekind (Scope (E)) = E_Entry then
 794                declare
 795                   BE : Entity_Id;
 796
 797                begin
 798                   BE := First_Entity (Current_Scope);
 799                   while Present (BE) loop
 800                      if Chars (BE) = Chars (E) then
 801                         Error_Msg_NE -- CODEFIX
 802                           ("?pragma Unreferenced given for&!", N, BE);
 803                         exit;
 804                      end if;
 805
 806                      Next_Entity (BE);
 807                   end loop;
 808                end;
 809
 810             --  Here we issue the warning, since this is a real reference
 811
 812             else
 813                Error_Msg_NE -- CODEFIX
 814                  ("?pragma Unreferenced given for&!", N, E);
 815             end if;
 816          end if;
 817
 818          --  If this is a subprogram instance, mark as well the internal
 819          --  subprogram in the wrapper package, which may be a visible
 820          --  compilation unit.
 821
 822          if Is_Overloadable (E)
 823            and then Is_Generic_Instance (E)
 824            and then Present (Alias (E))
 825          then
 826             Set_Referenced (Alias (E));
 827          end if;
 828       end if;
 829
 830       --  Generate reference if all conditions are met:
 831
 832       if
 833          --  Cross referencing must be active
 834
 835          Opt.Xref_Active
 836
 837          --  The entity must be one for which we collect references
 838
 839          and then Xref_Entity_Letters (Ekind (E)) /= ' '
 840
 841          --  Both Sloc values must be set to something sensible
 842
 843          and then Sloc (E) > No_Location
 844          and then Sloc (N) > No_Location
 845
 846          --  We ignore references from within an instance, except for default
 847          --  subprograms, for which we generate an implicit reference.
 848
 849          and then
 850            (Instantiation_Location (Sloc (N)) = No_Location or else Typ = 'i')
 851
 852          --  Ignore dummy references
 853
 854         and then Typ /= ' '
 855       then
 856          if Nkind (N) = N_Identifier
 857               or else
 858             Nkind (N) = N_Defining_Identifier
 859               or else
 860             Nkind (N) in N_Op
 861               or else
 862             Nkind (N) = N_Defining_Operator_Symbol
 863               or else
 864             Nkind (N) = N_Operator_Symbol
 865               or else
 866             (Nkind (N) = N_Character_Literal
 867               and then Sloc (Entity (N)) /= Standard_Location)
 868               or else
 869             Nkind (N) = N_Defining_Character_Literal
 870          then
 871             Nod := N;
 872
 873          elsif Nkind (N) = N_Expanded_Name
 874                  or else
 875                Nkind (N) = N_Selected_Component
 876          then
 877             Nod := Selector_Name (N);
 878
 879          else
 880             return;
 881          end if;
 882
 883          --  Normal case of source entity comes from source
 884
 885          if Comes_From_Source (E) then
 886             Ent := E;
 887
 888          --  Entity does not come from source, but is a derived subprogram and
 889          --  the derived subprogram comes from source (after one or more
 890          --  derivations) in which case the reference is to parent subprogram.
 891
 892          elsif Is_Overloadable (E)
 893            and then Present (Alias (E))
 894          then
 895             Ent := Alias (E);
 896             while not Comes_From_Source (Ent) loop
 897                if No (Alias (Ent)) then
 898                   return;
 899                end if;
 900
 901                Ent := Alias (Ent);
 902             end loop;
 903
 904          --  The internally created defining entity for a child subprogram
 905          --  that has no previous spec has valid references.
 906
 907          elsif Is_Overloadable (E)
 908            and then Is_Child_Unit (E)
 909          then
 910             Ent := E;
 911
 912          --  Record components of discriminated subtypes or derived types must
 913          --  be treated as references to the original component.
 914
 915          elsif Ekind (E) = E_Component
 916            and then Comes_From_Source (Original_Record_Component (E))
 917          then
 918             Ent := Original_Record_Component (E);
 919
 920          --  If this is an expanded reference to a discriminant, recover the
 921          --  original discriminant, which gets the reference.
 922
 923          elsif Ekind (E) = E_In_Parameter
 924            and then  Present (Discriminal_Link (E))
 925          then
 926             Ent := Discriminal_Link (E);
 927             Set_Referenced (Ent);
 928
 929          --  Ignore reference to any other entity that is not from source
 930
 931          else
 932             return;
 933          end if;
 934
 935          --  Record reference to entity
 936
 937          Sub := Enclosing_Subprogram_Or_Package (N);
 938
 939          Ref := Original_Location (Sloc (Nod));
 940          Def := Original_Location (Sloc (Ent));
 941          Slc := Original_Location (Sloc (Sub));
 942
 943          Xrefs.Increment_Last;
 944          Indx := Xrefs.Last;
 945
 946          Xrefs.Table (Indx).Loc := Ref;
 947          Xrefs.Table (Indx).Slc := Slc;
 948
 949          --  Overriding operations are marked with 'P'
 950
 951          if Typ = 'p'
 952            and then Is_Subprogram (N)
 953            and then Present (Overridden_Operation (N))
 954          then
 955             Xrefs.Table (Indx).Typ := 'P';
 956          else
 957             Xrefs.Table (Indx).Typ := Typ;
 958          end if;
 959
 960          Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
 961          Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
 962          Xrefs.Table (Indx).Sun := Get_Source_Unit (Slc);
 963          Xrefs.Table (Indx).Ent := Ent;
 964          Xrefs.Table (Indx).Sub := Sub;
 965          Set_Has_Xref_Entry (Ent);
 966       end if;
 967    end Generate_Reference;
 968
 969    -----------------------------------
 970    -- Generate_Reference_To_Formals --
 971    -----------------------------------
 972
 973    procedure Generate_Reference_To_Formals (E : Entity_Id) is
 974       Formal : Entity_Id;
 975
 976    begin
 977       if Is_Generic_Subprogram (E) then
 978          Formal := First_Entity (E);
 979
 980          while Present (Formal)
 981            and then not Is_Formal (Formal)
 982          loop
 983             Next_Entity (Formal);
 984          end loop;
 985
 986       else
 987          Formal := First_Formal (E);
 988       end if;
 989
 990       while Present (Formal) loop
 991          if Ekind (Formal) = E_In_Parameter then
 992
 993             if Nkind (Parameter_Type (Parent (Formal)))
 994               = N_Access_Definition
 995             then
 996                Generate_Reference (E, Formal, '^', False);
 997             else
 998                Generate_Reference (E, Formal, '>', False);
 999             end if;
1000
1001          elsif Ekind (Formal) = E_In_Out_Parameter then
1002             Generate_Reference (E, Formal, '=', False);
1003
1004          else
1005             Generate_Reference (E, Formal, '<', False);
1006          end if;
1007
1008          Next_Formal (Formal);
1009       end loop;
1010    end Generate_Reference_To_Formals;
1011
1012    -------------------------------------------
1013    -- Generate_Reference_To_Generic_Formals --
1014    -------------------------------------------
1015
1016    procedure Generate_Reference_To_Generic_Formals (E : Entity_Id) is
1017       Formal : Entity_Id;
1018
1019    begin
1020       Formal := First_Entity (E);
1021       while Present (Formal) loop
1022          if Comes_From_Source (Formal) then
1023             Generate_Reference (E, Formal, 'z', False);
1024          end if;
1025
1026          Next_Entity (Formal);
1027       end loop;
1028    end Generate_Reference_To_Generic_Formals;
1029
1030    ----------------
1031    -- Initialize --
1032    ----------------
1033
1034    procedure Initialize is
1035    begin
1036       Xrefs.Init;
1037    end Initialize;
1038
1039    -----------------------------
1040    -- Is_Local_Reference_Type --
1041    -----------------------------
1042
1043    function Is_Local_Reference_Type (Typ : Character) return Boolean is
1044    begin
1045       return Typ = 'r' or else Typ = 'm' or else Typ = 's'
1046         or else Typ = 'I' or else Typ = 'D';
1047    end Is_Local_Reference_Type;
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       if not Opt.Xref_Active then
1321          return;
1322       end if;
1323
1324       --  First we add references to the primitive operations of tagged
1325       --  types declared in the main unit.
1326
1327       Handle_Prim_Ops : declare
1328          Ent  : Entity_Id;
1329
1330       begin
1331          for J in 1 .. Xrefs.Last loop
1332             Ent := Xrefs.Table (J).Ent;
1333
1334             if Is_Type (Ent)
1335               and then Is_Tagged_Type (Ent)
1336               and then Is_Base_Type (Ent)
1337               and then In_Extended_Main_Source_Unit (Ent)
1338             then
1339                Generate_Prim_Op_References (Ent);
1340             end if;
1341          end loop;
1342       end Handle_Prim_Ops;
1343
1344       --  Before we go ahead and output the references we have a problem
1345       --  that needs dealing with. So far we have captured things that are
1346       --  definitely referenced by the main unit, or defined in the main
1347       --  unit. That's because we don't want to clutter up the ali file
1348       --  for this unit with definition lines for entities in other units
1349       --  that are not referenced.
1350
1351       --  But there is a glitch. We may reference an entity in another unit,
1352       --  and it may have a type reference to an entity that is not directly
1353       --  referenced in the main unit, which may mean that there is no xref
1354       --  entry for this entity yet in the list of references.
1355
1356       --  If we don't do something about this, we will end with an orphan type
1357       --  reference, i.e. it will point to an entity that does not appear
1358       --  within the generated references in the ali file. That is not good for
1359       --  tools using the xref information.
1360
1361       --  To fix this, we go through the references adding definition entries
1362       --  for any unreferenced entities that can be referenced in a type
1363       --  reference. There is a recursion problem here, and that is dealt with
1364       --  by making sure that this traversal also traverses any entries that
1365       --  get added by the traversal.
1366
1367       Handle_Orphan_Type_References : declare
1368          J    : Nat;
1369          Tref : Entity_Id;
1370          Indx : Nat;
1371          Ent  : Entity_Id;
1372          Loc  : Source_Ptr;
1373
1374          L, R : Character;
1375          pragma Warnings (Off, L);
1376          pragma Warnings (Off, R);
1377
1378          procedure New_Entry (E : Entity_Id);
1379          --  Make an additional entry into the Xref table for a type entity
1380          --  that is related to the current entity (parent, type ancestor,
1381          --  progenitor, etc.).
1382
1383          ----------------
1384          -- New_Entry --
1385          ----------------
1386
1387          procedure New_Entry (E : Entity_Id) is
1388          begin
1389             if Present (E)
1390               and then not Has_Xref_Entry (E)
1391               and then Sloc (E) > No_Location
1392             then
1393                Xrefs.Increment_Last;
1394                Indx := Xrefs.Last;
1395                Loc  := Original_Location (Sloc (E));
1396                Xrefs.Table (Indx).Ent := E;
1397                Xrefs.Table (Indx).Loc := No_Location;
1398                Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
1399                Xrefs.Table (Indx).Lun := No_Unit;
1400                Set_Has_Xref_Entry (E);
1401             end if;
1402          end New_Entry;
1403
1404       --  Start of processing for Handle_Orphan_Type_References
1405
1406       begin
1407          --  Note that this is not a for loop for a very good reason. The
1408          --  processing of items in the table can add new items to the table,
1409          --  and they must be processed as well.
1410
1411          J := 1;
1412          while J <= Xrefs.Last loop
1413             Ent := Xrefs.Table (J).Ent;
1414             Get_Type_Reference (Ent, Tref, L, R);
1415
1416             if Present (Tref)
1417               and then not Has_Xref_Entry (Tref)
1418               and then Sloc (Tref) > No_Location
1419             then
1420                New_Entry (Tref);
1421
1422                if Is_Record_Type (Ent)
1423                  and then Present (Interfaces (Ent))
1424                then
1425                   --  Add an entry for each one of the given interfaces
1426                   --  implemented by type Ent.
1427
1428                   declare
1429                      Elmt : Elmt_Id := First_Elmt (Interfaces (Ent));
1430                   begin
1431                      while Present (Elmt) loop
1432                         New_Entry (Node (Elmt));
1433                         Next_Elmt (Elmt);
1434                      end loop;
1435                   end;
1436                end if;
1437             end if;
1438
1439             --  Collect inherited primitive operations that may be declared in
1440             --  another unit and have no visible reference in the current one.
1441
1442             if Is_Type (Ent)
1443               and then Is_Tagged_Type (Ent)
1444               and then Is_Derived_Type (Ent)
1445               and then Is_Base_Type (Ent)
1446               and then In_Extended_Main_Source_Unit (Ent)
1447             then
1448                declare
1449                   Op_List : constant Elist_Id := Primitive_Operations (Ent);
1450                   Op      : Elmt_Id;
1451                   Prim    : Entity_Id;
1452
1453                   function Parent_Op (E : Entity_Id) return Entity_Id;
1454                   --  Find original operation, which may be inherited through
1455                   --  several derivations.
1456
1457                   function Parent_Op (E : Entity_Id) return Entity_Id is
1458                      Orig_Op : constant Entity_Id := Alias (E);
1459
1460                   begin
1461                      if No (Orig_Op) then
1462                         return Empty;
1463
1464                      elsif not Comes_From_Source (E)
1465                        and then not Has_Xref_Entry (Orig_Op)
1466                        and then Comes_From_Source (Orig_Op)
1467                      then
1468                         return Orig_Op;
1469                      else
1470                         return Parent_Op (Orig_Op);
1471                      end if;
1472                   end Parent_Op;
1473
1474                begin
1475                   Op := First_Elmt (Op_List);
1476                   while Present (Op) loop
1477                      Prim := Parent_Op (Node (Op));
1478
1479                      if Present (Prim) then
1480                         Xrefs.Increment_Last;
1481                         Indx := Xrefs.Last;
1482                         Loc  := Original_Location (Sloc (Prim));
1483                         Xrefs.Table (Indx).Ent := Prim;
1484                         Xrefs.Table (Indx).Loc := No_Location;
1485                         Xrefs.Table (Indx).Eun :=
1486                           Get_Source_Unit (Sloc (Prim));
1487                         Xrefs.Table (Indx).Lun := No_Unit;
1488                         Set_Has_Xref_Entry (Prim);
1489                      end if;
1490
1491                      Next_Elmt (Op);
1492                   end loop;
1493                end;
1494             end if;
1495
1496             J := J + 1;
1497          end loop;
1498       end Handle_Orphan_Type_References;
1499
1500       --  Now we have all the references, including those for any embedded
1501       --  type references, so we can sort them, and output them.
1502
1503       Output_Refs : declare
1504
1505          Nrefs : Nat := Xrefs.Last;
1506          --  Number of references in table. This value may get reset (reduced)
1507          --  when we eliminate duplicate reference entries.
1508
1509          Rnums : array (0 .. Nrefs) of Nat;
1510          --  This array contains numbers of references in the Xrefs table.
1511          --  This list is sorted in output order. The extra 0'th entry is
1512          --  convenient for the call to sort. When we sort the table, we
1513          --  move the entries in Rnums around, but we do not move the
1514          --  original table entries.
1515
1516          Curxu : Unit_Number_Type;
1517          --  Current xref unit
1518
1519          Curru : Unit_Number_Type;
1520          --  Current reference unit for one entity
1521
1522          Cursrc : Source_Buffer_Ptr;
1523          --  Current xref unit source text
1524
1525          Curent : Entity_Id;
1526          --  Current entity
1527
1528          Curnam : String (1 .. Name_Buffer'Length);
1529          Curlen : Natural;
1530          --  Simple name and length of current entity
1531
1532          Curdef : Source_Ptr;
1533          --  Original source location for current entity
1534
1535          Crloc : Source_Ptr;
1536          --  Current reference location
1537
1538          Ctyp : Character;
1539          --  Entity type character
1540
1541          Prevt : Character;
1542          --  reference kind of previous reference
1543
1544          Tref : Entity_Id;
1545          --  Type reference
1546
1547          Rref : Node_Id;
1548          --  Renaming reference
1549
1550          Trunit : Unit_Number_Type;
1551          --  Unit number for type reference
1552
1553          function Lt (Op1, Op2 : Natural) return Boolean;
1554          --  Comparison function for Sort call
1555
1556          function Name_Change (X : Entity_Id) return Boolean;
1557          --  Determines if entity X has a different simple name from Curent
1558
1559          procedure Move (From : Natural; To : Natural);
1560          --  Move procedure for Sort call
1561
1562          package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
1563
1564          --------
1565          -- Lt --
1566          --------
1567
1568          function Lt (Op1, Op2 : Natural) return Boolean is
1569             T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
1570             T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
1571
1572          begin
1573             return Lt (T1, T2);
1574          end Lt;
1575
1576          ----------
1577          -- Move --
1578          ----------
1579
1580          procedure Move (From : Natural; To : Natural) is
1581          begin
1582             Rnums (Nat (To)) := Rnums (Nat (From));
1583          end Move;
1584
1585          -----------------
1586          -- Name_Change --
1587          -----------------
1588
1589          --  Why a string comparison here??? Why not compare Name_Id values???
1590
1591          function Name_Change (X : Entity_Id) return Boolean is
1592          begin
1593             Get_Unqualified_Name_String (Chars (X));
1594
1595             if Name_Len /= Curlen then
1596                return True;
1597             else
1598                return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
1599             end if;
1600          end Name_Change;
1601
1602       --  Start of processing for Output_Refs
1603
1604       begin
1605          --  Capture the definition Sloc values. We delay doing this till now,
1606          --  since at the time the reference or definition is made, private
1607          --  types may be swapped, and the Sloc value may be incorrect. We
1608          --  also set up the pointer vector for the sort.
1609
1610          for J in 1 .. Nrefs loop
1611             Rnums (J) := J;
1612             Xrefs.Table (J).Def :=
1613               Original_Location (Sloc (Xrefs.Table (J).Ent));
1614          end loop;
1615
1616          --  Sort the references
1617
1618          Sorting.Sort (Integer (Nrefs));
1619
1620          --  Eliminate duplicate entries
1621
1622          declare
1623             NR : constant Nat := Nrefs;
1624
1625          begin
1626             --  We need this test for NR because if we force ALI file
1627             --  generation in case of errors detected, it may be the case
1628             --  that Nrefs is 0, so we should not reset it here
1629
1630             if NR >= 2 then
1631                Nrefs := 1;
1632
1633                for J in 2 .. NR loop
1634                   if Xrefs.Table (Rnums (J)) /=
1635                      Xrefs.Table (Rnums (Nrefs))
1636                   then
1637                      Nrefs := Nrefs + 1;
1638                      Rnums (Nrefs) := Rnums (J);
1639                   end if;
1640                end loop;
1641             end if;
1642          end;
1643
1644          --  Initialize loop through references
1645
1646          Curxu  := No_Unit;
1647          Curent := Empty;
1648          Curdef := No_Location;
1649          Curru  := No_Unit;
1650          Crloc  := No_Location;
1651          Prevt  := 'm';
1652
1653          --  Loop to output references
1654
1655          for Refno in 1 .. Nrefs loop
1656             Output_One_Ref : declare
1657                P2  : Source_Ptr;
1658                Ent : Entity_Id;
1659
1660                WC  : Char_Code;
1661                Err : Boolean;
1662                pragma Warnings (Off, WC);
1663                pragma Warnings (Off, Err);
1664
1665                XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
1666                --  The current entry to be accessed
1667
1668                P : Source_Ptr;
1669                --  Used to index into source buffer to get entity name
1670
1671                Left  : Character;
1672                Right : Character;
1673                --  Used for {} or <> or () for type reference
1674
1675                procedure Check_Type_Reference
1676                  (Ent            : Entity_Id;
1677                   List_Interface : Boolean);
1678                --  Find whether there is a meaningful type reference for
1679                --  Ent, and display it accordingly. If List_Interface is
1680                --  true, then Ent is a progenitor interface of the current
1681                --  type entity being listed. In that case list it as is,
1682                --  without looking for a type reference for it.
1683
1684                procedure Output_Instantiation_Refs (Loc : Source_Ptr);
1685                --  Recursive procedure to output instantiation references for
1686                --  the given source ptr in [file|line[...]] form. No output
1687                --  if the given location is not a generic template reference.
1688
1689                procedure Output_Overridden_Op (Old_E : Entity_Id);
1690                --  For a subprogram that is overriding, display information
1691                --  about the inherited operation that it overrides.
1692
1693                --------------------------
1694                -- Check_Type_Reference --
1695                --------------------------
1696
1697                procedure Check_Type_Reference
1698                  (Ent            : Entity_Id;
1699                   List_Interface : Boolean)
1700                is
1701                begin
1702                   if List_Interface then
1703
1704                      --  This is a progenitor interface of the type for which
1705                      --  xref information is being generated.
1706
1707                      Tref  := Ent;
1708                      Left  := '<';
1709                      Right := '>';
1710
1711                   else
1712                      Get_Type_Reference (Ent, Tref, Left, Right);
1713                   end if;
1714
1715                   if Present (Tref) then
1716
1717                      --  Case of standard entity, output name
1718
1719                      if Sloc (Tref) = Standard_Location then
1720                         Write_Info_Char (Left);
1721                         Write_Info_Name (Chars (Tref));
1722                         Write_Info_Char (Right);
1723
1724                      --  Case of source entity, output location
1725
1726                      else
1727                         Write_Info_Char (Left);
1728                         Trunit := Get_Source_Unit (Sloc (Tref));
1729
1730                         if Trunit /= Curxu then
1731                            Write_Info_Nat (Dependency_Num (Trunit));
1732                            Write_Info_Char ('|');
1733                         end if;
1734
1735                         Write_Info_Nat
1736                           (Int (Get_Logical_Line_Number (Sloc (Tref))));
1737
1738                         declare
1739                            Ent  : Entity_Id;
1740                            Ctyp : Character;
1741
1742                         begin
1743                            Ent := Tref;
1744                            Ctyp := Xref_Entity_Letters (Ekind (Ent));
1745
1746                            if Ctyp = '+'
1747                              and then Present (Full_View (Ent))
1748                            then
1749                               Ent := Underlying_Type (Ent);
1750
1751                               if Present (Ent) then
1752                                  Ctyp := Xref_Entity_Letters (Ekind (Ent));
1753                               end if;
1754                            end if;
1755
1756                            Write_Info_Char (Ctyp);
1757                         end;
1758
1759                         Write_Info_Nat
1760                           (Int (Get_Column_Number (Sloc (Tref))));
1761
1762                         --  If the type comes from an instantiation, add the
1763                         --  corresponding info.
1764
1765                         Output_Instantiation_Refs (Sloc (Tref));
1766                         Write_Info_Char (Right);
1767                      end if;
1768                   end if;
1769                end Check_Type_Reference;
1770
1771                -------------------------------
1772                -- Output_Instantiation_Refs --
1773                -------------------------------
1774
1775                procedure Output_Instantiation_Refs (Loc : Source_Ptr) is
1776                   Iloc : constant Source_Ptr := Instantiation_Location (Loc);
1777                   Lun  : Unit_Number_Type;
1778                   Cu   : constant Unit_Number_Type := Curru;
1779
1780                begin
1781                   --  Nothing to do if this is not an instantiation
1782
1783                   if Iloc = No_Location then
1784                      return;
1785                   end if;
1786
1787                   --  Output instantiation reference
1788
1789                   Write_Info_Char ('[');
1790                   Lun := Get_Source_Unit (Iloc);
1791
1792                   if Lun /= Curru then
1793                      Curru := Lun;
1794                      Write_Info_Nat (Dependency_Num (Curru));
1795                      Write_Info_Char ('|');
1796                   end if;
1797
1798                   Write_Info_Nat (Int (Get_Logical_Line_Number (Iloc)));
1799
1800                   --  Recursive call to get nested instantiations
1801
1802                   Output_Instantiation_Refs (Iloc);
1803
1804                   --  Output final ] after call to get proper nesting
1805
1806                   Write_Info_Char (']');
1807                   Curru := Cu;
1808                   return;
1809                end Output_Instantiation_Refs;
1810
1811                --------------------------
1812                -- Output_Overridden_Op --
1813                --------------------------
1814
1815                procedure Output_Overridden_Op (Old_E : Entity_Id) is
1816                   Op : Entity_Id;
1817
1818                begin
1819                   --  The overridden operation has an implicit declaration
1820                   --  at the point of derivation. What we want to display
1821                   --  is the original operation, which has the actual body
1822                   --  (or abstract declaration) that is being overridden.
1823                   --  The overridden operation is not always set, e.g. when
1824                   --  it is a predefined operator.
1825
1826                   if No (Old_E) then
1827                      return;
1828
1829                   --  Follow alias chain if one is present
1830
1831                   elsif Present (Alias (Old_E)) then
1832
1833                      --  The subprogram may have been implicitly inherited
1834                      --  through several levels of derivation, so find the
1835                      --  ultimate (source) ancestor.
1836
1837                      Op := Ultimate_Alias (Old_E);
1838
1839                   --  Normal case of no alias present
1840
1841                   else
1842                      Op := Old_E;
1843                   end if;
1844
1845                   if Present (Op)
1846                     and then Sloc (Op) /= Standard_Location
1847                   then
1848                      declare
1849                         Loc      : constant Source_Ptr := Sloc (Op);
1850                         Par_Unit : constant Unit_Number_Type :=
1851                                      Get_Source_Unit (Loc);
1852
1853                      begin
1854                         Write_Info_Char ('<');
1855
1856                         if Par_Unit /= Curxu then
1857                            Write_Info_Nat (Dependency_Num (Par_Unit));
1858                            Write_Info_Char ('|');
1859                         end if;
1860
1861                         Write_Info_Nat (Int (Get_Logical_Line_Number (Loc)));
1862                         Write_Info_Char ('p');
1863                         Write_Info_Nat (Int (Get_Column_Number (Loc)));
1864                         Write_Info_Char ('>');
1865                      end;
1866                   end if;
1867                end Output_Overridden_Op;
1868
1869             --  Start of processing for Output_One_Ref
1870
1871             begin
1872                Ent := XE.Ent;
1873                Ctyp := Xref_Entity_Letters (Ekind (Ent));
1874
1875                --  Skip reference if it is the only reference to an entity,
1876                --  and it is an END line reference, and the entity is not in
1877                --  the current extended source. This prevents junk entries
1878                --  consisting only of packages with END lines, where no
1879                --  entity from the package is actually referenced.
1880
1881                if XE.Typ = 'e'
1882                  and then Ent /= Curent
1883                  and then (Refno = Nrefs or else
1884                              Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent)
1885                  and then
1886                    not In_Extended_Main_Source_Unit (Ent)
1887                then
1888                   goto Continue;
1889                end if;
1890
1891                --  For private type, get full view type
1892
1893                if Ctyp = '+'
1894                  and then Present (Full_View (XE.Ent))
1895                then
1896                   Ent := Underlying_Type (Ent);
1897
1898                   if Present (Ent) then
1899                      Ctyp := Xref_Entity_Letters (Ekind (Ent));
1900                   end if;
1901                end if;
1902
1903                --  Special exception for Boolean
1904
1905                if Ctyp = 'E' and then Is_Boolean_Type (Ent) then
1906                   Ctyp := 'B';
1907                end if;
1908
1909                --  For variable reference, get corresponding type
1910
1911                if Ctyp = '*' then
1912                   Ent := Etype (XE.Ent);
1913                   Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1914
1915                   --  If variable is private type, get full view type
1916
1917                   if Ctyp = '+'
1918                     and then Present (Full_View (Etype (XE.Ent)))
1919                   then
1920                      Ent := Underlying_Type (Etype (XE.Ent));
1921
1922                      if Present (Ent) then
1923                         Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1924                      end if;
1925
1926                   elsif Is_Generic_Type (Ent) then
1927
1928                      --  If the type of the entity is a generic private type,
1929                      --  there is no usable full view, so retain the indication
1930                      --  that this is an object.
1931
1932                      Ctyp := '*';
1933                   end if;
1934
1935                   --  Special handling for access parameters and objects of
1936                   --  an anonymous access type.
1937
1938                   if Ekind_In (Etype (XE.Ent),
1939                                E_Anonymous_Access_Type,
1940                                E_Anonymous_Access_Subprogram_Type,
1941                                E_Anonymous_Access_Protected_Subprogram_Type)
1942                   then
1943                      if Is_Formal (XE.Ent)
1944                        or else Ekind_In (XE.Ent, E_Variable, E_Constant)
1945                      then
1946                         Ctyp := 'p';
1947                      end if;
1948
1949                      --  Special handling for Boolean
1950
1951                   elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
1952                      Ctyp := 'b';
1953                   end if;
1954                end if;
1955
1956                --  Special handling for abstract types and operations
1957
1958                if Is_Overloadable (XE.Ent)
1959                  and then Is_Abstract_Subprogram (XE.Ent)
1960                then
1961                   if Ctyp = 'U' then
1962                      Ctyp := 'x';            --  Abstract procedure
1963
1964                   elsif Ctyp = 'V' then
1965                      Ctyp := 'y';            --  Abstract function
1966                   end if;
1967
1968                elsif Is_Type (XE.Ent)
1969                  and then Is_Abstract_Type (XE.Ent)
1970                then
1971                   if Is_Interface (XE.Ent) then
1972                      Ctyp := 'h';
1973
1974                   elsif Ctyp = 'R' then
1975                      Ctyp := 'H';            --  Abstract type
1976                   end if;
1977                end if;
1978
1979                --  Only output reference if interesting type of entity
1980
1981                if Ctyp = ' '
1982
1983                --  Suppress references to object definitions, used for local
1984                --  references.
1985
1986                  or else XE.Typ = 'D'
1987                  or else XE.Typ = 'I'
1988
1989                --  Suppress self references, except for bodies that act as
1990                --  specs.
1991
1992                  or else (XE.Loc = XE.Def
1993                             and then
1994                               (XE.Typ /= 'b'
1995                                 or else not Is_Subprogram (XE.Ent)))
1996
1997                --  Also suppress definitions of body formals (we only
1998                --  treat these as references, and the references were
1999                --  separately recorded).
2000
2001                  or else (Is_Formal (XE.Ent)
2002                             and then Present (Spec_Entity (XE.Ent)))
2003                then
2004                   null;
2005
2006                else
2007                   --  Start new Xref section if new xref unit
2008
2009                   if XE.Eun /= Curxu then
2010                      if Write_Info_Col > 1 then
2011                         Write_Info_EOL;
2012                      end if;
2013
2014                      Curxu := XE.Eun;
2015                      Cursrc := Source_Text (Source_Index (Curxu));
2016
2017                      Write_Info_Initiate ('X');
2018                      Write_Info_Char (' ');
2019                      Write_Info_Nat (Dependency_Num (XE.Eun));
2020                      Write_Info_Char (' ');
2021                      Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
2022                   end if;
2023
2024                   --  Start new Entity line if new entity. Note that we
2025                   --  consider two entities the same if they have the same
2026                   --  name and source location. This causes entities in
2027                   --  instantiations to be treated as though they referred
2028                   --  to the template.
2029
2030                   if No (Curent)
2031                     or else
2032                       (XE.Ent /= Curent
2033                          and then
2034                            (Name_Change (XE.Ent) or else XE.Def /= Curdef))
2035                   then
2036                      Curent := XE.Ent;
2037                      Curdef := XE.Def;
2038
2039                      Get_Unqualified_Name_String (Chars (XE.Ent));
2040                      Curlen := Name_Len;
2041                      Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
2042
2043                      if Write_Info_Col > 1 then
2044                         Write_Info_EOL;
2045                      end if;
2046
2047                      --  Write column number information
2048
2049                      Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def)));
2050                      Write_Info_Char (Ctyp);
2051                      Write_Info_Nat (Int (Get_Column_Number (XE.Def)));
2052
2053                      --  Write level information
2054
2055                      Write_Level_Info : declare
2056                         function Is_Visible_Generic_Entity
2057                           (E : Entity_Id) return Boolean;
2058                         --  Check whether E is declared in the visible part
2059                         --  of a generic package. For source navigation
2060                         --  purposes, treat this as a visible entity.
2061
2062                         function Is_Private_Record_Component
2063                           (E : Entity_Id) return Boolean;
2064                         --  Check whether E is a non-inherited component of a
2065                         --  private extension. Even if the enclosing record is
2066                         --  public, we want to treat the component as private
2067                         --  for navigation purposes.
2068
2069                         ---------------------------------
2070                         -- Is_Private_Record_Component --
2071                         ---------------------------------
2072
2073                         function Is_Private_Record_Component
2074                           (E : Entity_Id) return Boolean
2075                         is
2076                            S : constant Entity_Id := Scope (E);
2077                         begin
2078                            return
2079                              Ekind (E) = E_Component
2080                                and then Nkind (Declaration_Node (S)) =
2081                                  N_Private_Extension_Declaration
2082                                and then Original_Record_Component (E) = E;
2083                         end Is_Private_Record_Component;
2084
2085                         -------------------------------
2086                         -- Is_Visible_Generic_Entity --
2087                         -------------------------------
2088
2089                         function Is_Visible_Generic_Entity
2090                           (E : Entity_Id) return Boolean
2091                         is
2092                            Par : Node_Id;
2093
2094                         begin
2095                            --  The Present check here is an error defense
2096
2097                            if Present (Scope (E))
2098                              and then Ekind (Scope (E)) /= E_Generic_Package
2099                            then
2100                               return False;
2101                            end if;
2102
2103                            Par := Parent (E);
2104                            while Present (Par) loop
2105                               if
2106                                 Nkind (Par) = N_Generic_Package_Declaration
2107                               then
2108                                  --  Entity is a generic formal
2109
2110                                  return False;
2111
2112                               elsif
2113                                 Nkind (Parent (Par)) = N_Package_Specification
2114                               then
2115                                  return
2116                                    Is_List_Member (Par)
2117                                      and then List_Containing (Par) =
2118                                        Visible_Declarations (Parent (Par));
2119                               else
2120                                  Par := Parent (Par);
2121                               end if;
2122                            end loop;
2123
2124                            return False;
2125                         end Is_Visible_Generic_Entity;
2126
2127                      --  Start of processing for Write_Level_Info
2128
2129                      begin
2130                         if Is_Hidden (Curent)
2131                           or else Is_Private_Record_Component (Curent)
2132                         then
2133                            Write_Info_Char (' ');
2134
2135                         elsif
2136                            Is_Public (Curent)
2137                              or else Is_Visible_Generic_Entity (Curent)
2138                         then
2139                            Write_Info_Char ('*');
2140
2141                         else
2142                            Write_Info_Char (' ');
2143                         end if;
2144                      end Write_Level_Info;
2145
2146                      --  Output entity name. We use the occurrence from the
2147                      --  actual source program at the definition point.
2148
2149                      P := Original_Location (Sloc (XE.Ent));
2150
2151                      --  Entity is character literal
2152
2153                      if Cursrc (P) = ''' then
2154                         Write_Info_Char (Cursrc (P));
2155                         Write_Info_Char (Cursrc (P + 1));
2156                         Write_Info_Char (Cursrc (P + 2));
2157
2158                      --  Entity is operator symbol
2159
2160                      elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
2161                         Write_Info_Char (Cursrc (P));
2162
2163                         P2 := P;
2164                         loop
2165                            P2 := P2 + 1;
2166                            Write_Info_Char (Cursrc (P2));
2167                            exit when Cursrc (P2) = Cursrc (P);
2168                         end loop;
2169
2170                      --  Entity is identifier
2171
2172                      else
2173                         loop
2174                            if Is_Start_Of_Wide_Char (Cursrc, P) then
2175                               Scan_Wide (Cursrc, P, WC, Err);
2176                            elsif not Identifier_Char (Cursrc (P)) then
2177                               exit;
2178                            else
2179                               P := P + 1;
2180                            end if;
2181                         end loop;
2182
2183                         --  Write out the identifier by copying the exact
2184                         --  source characters used in its declaration. Note
2185                         --  that this means wide characters will be in their
2186                         --  original encoded form.
2187
2188                         for J in
2189                           Original_Location (Sloc (XE.Ent)) .. P - 1
2190                         loop
2191                            Write_Info_Char (Cursrc (J));
2192                         end loop;
2193                      end if;
2194
2195                      --  See if we have a renaming reference
2196
2197                      if Is_Object (XE.Ent)
2198                        and then Present (Renamed_Object (XE.Ent))
2199                      then
2200                         Rref := Renamed_Object (XE.Ent);
2201
2202                      elsif Is_Overloadable (XE.Ent)
2203                        and then Nkind (Parent (Declaration_Node (XE.Ent))) =
2204                                             N_Subprogram_Renaming_Declaration
2205                      then
2206                         Rref := Name (Parent (Declaration_Node (XE.Ent)));
2207
2208                      elsif Ekind (XE.Ent) = E_Package
2209                        and then Nkind (Declaration_Node (XE.Ent)) =
2210                                          N_Package_Renaming_Declaration
2211                      then
2212                         Rref := Name (Declaration_Node (XE.Ent));
2213
2214                      else
2215                         Rref := Empty;
2216                      end if;
2217
2218                      if Present (Rref) then
2219                         if Nkind (Rref) = N_Expanded_Name then
2220                            Rref := Selector_Name (Rref);
2221                         end if;
2222
2223                         if Nkind (Rref) = N_Identifier
2224                           or else Nkind (Rref) = N_Operator_Symbol
2225                         then
2226                            null;
2227
2228                         --  For renamed array components, use the array name
2229                         --  for the renamed entity, which reflect the fact that
2230                         --  in general the whole array is aliased.
2231
2232                         elsif Nkind (Rref) = N_Indexed_Component then
2233                            if Nkind (Prefix (Rref)) = N_Identifier then
2234                               Rref := Prefix (Rref);
2235                            elsif Nkind (Prefix (Rref)) = N_Expanded_Name then
2236                               Rref := Selector_Name (Prefix (Rref));
2237                            else
2238                               Rref := Empty;
2239                            end if;
2240
2241                         else
2242                            Rref := Empty;
2243                         end if;
2244                      end if;
2245
2246                      --  Write out renaming reference if we have one
2247
2248                      if Present (Rref) then
2249                         Write_Info_Char ('=');
2250                         Write_Info_Nat
2251                           (Int (Get_Logical_Line_Number (Sloc (Rref))));
2252                         Write_Info_Char (':');
2253                         Write_Info_Nat
2254                           (Int (Get_Column_Number (Sloc (Rref))));
2255                      end if;
2256
2257                      --  Indicate that the entity is in the unit of the current
2258                      --  xref section.
2259
2260                      Curru := Curxu;
2261
2262                      --  Write out information about generic parent, if entity
2263                      --  is an instance.
2264
2265                      if  Is_Generic_Instance (XE.Ent) then
2266                         declare
2267                            Gen_Par : constant Entity_Id :=
2268                                        Generic_Parent
2269                                          (Specification
2270                                             (Unit_Declaration_Node (XE.Ent)));
2271                            Loc     : constant Source_Ptr := Sloc (Gen_Par);
2272                            Gen_U   : constant Unit_Number_Type :=
2273                                        Get_Source_Unit (Loc);
2274
2275                         begin
2276                            Write_Info_Char ('[');
2277
2278                            if Curru /= Gen_U then
2279                               Write_Info_Nat (Dependency_Num (Gen_U));
2280                               Write_Info_Char ('|');
2281                            end if;
2282
2283                            Write_Info_Nat
2284                              (Int (Get_Logical_Line_Number (Loc)));
2285                            Write_Info_Char (']');
2286                         end;
2287                      end if;
2288
2289                      --  See if we have a type reference and if so output
2290
2291                      Check_Type_Reference (XE.Ent, False);
2292
2293                      --  Additional information for types with progenitors
2294
2295                      if Is_Record_Type (XE.Ent)
2296                        and then Present (Interfaces (XE.Ent))
2297                      then
2298                         declare
2299                            Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent));
2300                         begin
2301                            while Present (Elmt) loop
2302                               Check_Type_Reference (Node (Elmt), True);
2303                               Next_Elmt (Elmt);
2304                            end loop;
2305                         end;
2306
2307                      --  For array types, list index types as well. (This is
2308                      --  not C, indexes have distinct types).
2309
2310                      elsif Is_Array_Type (XE.Ent) then
2311                         declare
2312                            Indx : Node_Id;
2313                         begin
2314                            Indx := First_Index (XE.Ent);
2315                            while Present (Indx) loop
2316                               Check_Type_Reference
2317                                 (First_Subtype (Etype (Indx)), True);
2318                               Next_Index (Indx);
2319                            end loop;
2320                         end;
2321                      end if;
2322
2323                      --  If the entity is an overriding operation, write info
2324                      --  on operation that was overridden.
2325
2326                      if Is_Subprogram (XE.Ent)
2327                        and then Present (Overridden_Operation (XE.Ent))
2328                      then
2329                         Output_Overridden_Op (Overridden_Operation (XE.Ent));
2330                      end if;
2331
2332                      --  End of processing for entity output
2333
2334                      Crloc := No_Location;
2335                   end if;
2336
2337                   --  Output the reference if it is not as the same location
2338                   --  as the previous one, or it is a read-reference that
2339                   --  indicates that the entity is an in-out actual in a call.
2340
2341                   if XE.Loc /= No_Location
2342                     and then
2343                       (XE.Loc /= Crloc
2344                         or else (Prevt = 'm' and then  XE.Typ = 'r'))
2345                   then
2346                      Crloc := XE.Loc;
2347                      Prevt := XE.Typ;
2348
2349                      --  Start continuation if line full, else blank
2350
2351                      if Write_Info_Col > 72 then
2352                         Write_Info_EOL;
2353                         Write_Info_Initiate ('.');
2354                      end if;
2355
2356                      Write_Info_Char (' ');
2357
2358                      --  Output file number if changed
2359
2360                      if XE.Lun /= Curru then
2361                         Curru := XE.Lun;
2362                         Write_Info_Nat (Dependency_Num (Curru));
2363                         Write_Info_Char ('|');
2364                      end if;
2365
2366                      Write_Info_Nat  (Int (Get_Logical_Line_Number (XE.Loc)));
2367                      Write_Info_Char (XE.Typ);
2368
2369                      if Is_Overloadable (XE.Ent)
2370                        and then Is_Imported (XE.Ent)
2371                        and then XE.Typ = 'b'
2372                      then
2373                         Output_Import_Export_Info (XE.Ent);
2374                      end if;
2375
2376                      Write_Info_Nat (Int (Get_Column_Number (XE.Loc)));
2377
2378                      Output_Instantiation_Refs (Sloc (XE.Ent));
2379                   end if;
2380                end if;
2381             end Output_One_Ref;
2382
2383          <<Continue>>
2384             null;
2385          end loop;
2386
2387          Write_Info_EOL;
2388       end Output_Refs;
2389    end Output_References;
2390
2391    -----------------------------
2392    -- Output_Local_References --
2393    -----------------------------
2394
2395    procedure Output_Local_References is
2396
2397       Nrefs : Nat := Xrefs.Last;
2398       --  Number of references in table. This value may get reset (reduced)
2399       --  when we eliminate duplicate reference entries as well as references
2400       --  not suitable for local cross-references.
2401
2402       Rnums : array (0 .. Nrefs) of Nat;
2403       --  This array contains numbers of references in the Xrefs table.
2404       --  This list is sorted in output order. The extra 0'th entry is
2405       --  convenient for the call to sort. When we sort the table, we
2406       --  move the entries in Rnums around, but we do not move the
2407       --  original table entries.
2408
2409       Curxu : Unit_Number_Type;
2410       --  Current xref unit
2411
2412       Curru : Unit_Number_Type;
2413       --  Current reference unit for one entity
2414
2415       Cursu : Unit_Number_Type;
2416       --  Current reference unit for one enclosing subprogram
2417
2418       Cursrc : Source_Buffer_Ptr;
2419       --  Current xref unit source text
2420
2421       Cursub : Entity_Id;
2422       --  Current enclosing subprogram
2423
2424       Curent : Entity_Id;
2425       --  Current entity
2426
2427       Curnam : String (1 .. Name_Buffer'Length);
2428       Curlen : Natural;
2429       --  Simple name and length of current entity
2430
2431       Curdef : Source_Ptr;
2432       --  Original source location for current entity
2433
2434       Crloc : Source_Ptr;
2435       --  Current reference location
2436
2437       Ctyp  : Character;
2438       --  Entity type character
2439
2440       Prevt : Character;
2441       --  Reference kind of previous reference
2442
2443       function Lt (Op1, Op2 : Natural) return Boolean;
2444       --  Comparison function for Sort call
2445
2446       function Name_Change (X : Entity_Id) return Boolean;
2447       --  Determines if entity X has a different simple name from Curent
2448
2449       procedure Move (From : Natural; To : Natural);
2450       --  Move procedure for Sort call
2451
2452       package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
2453
2454       --------
2455       -- Lt --
2456       --------
2457
2458       function Lt (Op1, Op2 : Natural) return Boolean is
2459          T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
2460          T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
2461
2462       begin
2463          if T1.Slc = No_Location then
2464             return True;
2465
2466          elsif T2.Slc = No_Location then
2467             return False;
2468
2469          elsif T1.Sun /= T2.Sun then
2470             return Dependency_Num (T1.Sun) < Dependency_Num (T2.Sun);
2471
2472          elsif T1.Slc /= T2.Slc then
2473             return T1.Slc < T2.Slc;
2474
2475          else
2476             return Lt (T1, T2);
2477          end if;
2478       end Lt;
2479
2480       ----------
2481       -- Move --
2482       ----------
2483
2484       procedure Move (From : Natural; To : Natural) is
2485       begin
2486          Rnums (Nat (To)) := Rnums (Nat (From));
2487       end Move;
2488
2489       -----------------
2490       -- Name_Change --
2491       -----------------
2492
2493       --  Why a string comparison here??? Why not compare Name_Id values???
2494
2495       function Name_Change (X : Entity_Id) return Boolean is
2496       begin
2497          Get_Unqualified_Name_String (Chars (X));
2498
2499          if Name_Len /= Curlen then
2500             return True;
2501          else
2502             return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
2503          end if;
2504       end Name_Change;
2505
2506       --  Start of processing for Output_Subprogram_References
2507    begin
2508
2509       --  Replace enclosing subprogram pointer by corresponding specification
2510       --  when appropriate. This could not be done before as the information
2511       --  was not always available when registering references.
2512
2513       for J in 1 .. Xrefs.Last loop
2514          if Present (Xrefs.Table (J).Sub) then
2515             declare
2516                N   : constant Node_Id :=
2517                        Parent (Parent (Xrefs.Table (J).Sub));
2518                Sub : Entity_Id;
2519                Slc : Source_Ptr;
2520                Sun : Unit_Number_Type;
2521             begin
2522                if Nkind (N) = N_Subprogram_Body
2523                  and then not Acts_As_Spec (N)
2524                then
2525                   Sub := Corresponding_Spec (N);
2526
2527                   if Nkind (Sub) = N_Defining_Program_Unit_Name then
2528                      Sub := Defining_Identifier (Sub);
2529                   end if;
2530
2531                   Slc := Original_Location (Sloc (Sub));
2532                   Sun := Get_Source_Unit (Slc);
2533
2534                   Xrefs.Table (J).Sub := Sub;
2535                   Xrefs.Table (J).Slc := Slc;
2536                   Xrefs.Table (J).Sun := Sun;
2537                end if;
2538             end;
2539          end if;
2540       end loop;
2541
2542       --  Set up the pointer vector for the sort
2543
2544       for J in 1 .. Nrefs loop
2545          Rnums (J) := J;
2546       end loop;
2547
2548       --  Sort the references
2549
2550       Sorting.Sort (Integer (Nrefs));
2551
2552       declare
2553          NR : Nat;
2554
2555       begin
2556          --  Eliminate duplicate entries
2557
2558          --  We need this test for NR because if we force ALI file
2559          --  generation in case of errors detected, it may be the case
2560          --  that Nrefs is 0, so we should not reset it here
2561
2562          if Nrefs >= 2 then
2563             NR    := Nrefs;
2564             Nrefs := 1;
2565
2566             for J in 2 .. NR loop
2567                if Xrefs.Table (Rnums (J)) /= Xrefs.Table (Rnums (Nrefs)) then
2568                   Nrefs         := Nrefs + 1;
2569                   Rnums (Nrefs) := Rnums (J);
2570                end if;
2571             end loop;
2572          end if;
2573
2574          --  Eliminate entries not appropriate for local references
2575
2576          NR    := Nrefs;
2577          Nrefs := 0;
2578
2579          for J in 1 .. NR loop
2580             if Lref_Entity_Status (Ekind (Xrefs.Table (Rnums (J)).Ent))
2581               and then Is_Local_Reference_Type (Xrefs.Table (Rnums (J)).Typ)
2582             then
2583                Nrefs         := Nrefs + 1;
2584                Rnums (Nrefs) := Rnums (J);
2585             end if;
2586          end loop;
2587       end;
2588
2589       --  Initialize loop through references
2590
2591       Curxu  := No_Unit;
2592       Cursub := Empty;
2593       Curent := Empty;
2594       Curdef := No_Location;
2595       Curru  := No_Unit;
2596       Cursu  := No_Unit;
2597       Crloc  := No_Location;
2598       Prevt  := 'm';
2599
2600       --  Loop to output references
2601
2602       for Refno in 1 .. Nrefs loop
2603          Output_One_Ref : declare
2604             Ent : Entity_Id;
2605             XE  : Xref_Entry renames Xrefs.Table (Rnums (Refno));
2606             --  The current entry to be accessed
2607
2608          begin
2609             Ent  := XE.Ent;
2610             Ctyp := Xref_Entity_Letters (Ekind (Ent));
2611
2612             --  Start new Unit section if subprogram in new unit
2613
2614             if XE.Sun /= Cursu then
2615                if Write_Info_Col > 1 then
2616                   Write_Info_EOL;
2617                end if;
2618
2619                Cursu := XE.Sun;
2620
2621                Write_Info_Initiate ('F');
2622                Write_Info_Char (' ');
2623                Write_Info_Nat (Dependency_Num (XE.Sun));
2624                Write_Info_Char (' ');
2625                Write_Info_Name (Reference_Name (Source_Index (XE.Sun)));
2626                Write_Info_EOL;
2627             end if;
2628
2629             --  Start new Subprogram section if new subprogram
2630
2631             if XE.Sub /= Cursub then
2632                if Write_Info_Col > 1 then
2633                   Write_Info_EOL;
2634                end if;
2635
2636                Cursub := XE.Sub;
2637                Cursrc := Source_Text (Source_Index (Cursu));
2638
2639                Write_Info_Initiate ('S');
2640                Write_Info_Char (' ');
2641                Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Slc)));
2642                Write_Info_Char (Xref_Entity_Letters (Ekind (XE.Sub)));
2643                Write_Info_Nat (Int (Get_Column_Number (XE.Slc)));
2644                Write_Info_Char (' ');
2645                Write_Entity_Name (XE.Sub, Cursrc);
2646
2647                --  Indicate that the entity is in the unit of the current
2648                --  local xref section.
2649
2650                Curru := Cursu;
2651
2652                --  End of processing for subprogram output
2653
2654                Curxu  := No_Unit;
2655                Curent := Empty;
2656             end if;
2657
2658             --  Start new Xref section if new xref unit
2659
2660             if XE.Eun /= Curxu then
2661                if Write_Info_Col > 1 then
2662                   Write_Info_EOL;
2663                end if;
2664
2665                Curxu  := XE.Eun;
2666                Cursrc := Source_Text (Source_Index (Curxu));
2667
2668                Write_Info_Initiate ('X');
2669                Write_Info_Char (' ');
2670                Write_Info_Nat (Dependency_Num (XE.Eun));
2671                Write_Info_Char (' ');
2672                Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
2673
2674                --  End of processing for Xref section output
2675
2676                Curru := Cursu;
2677             end if;
2678
2679             --  Start new Entity line if new entity. Note that we
2680             --  consider two entities the same if they have the same
2681             --  name and source location. This causes entities in
2682             --  instantiations to be treated as though they referred
2683             --  to the template.
2684
2685             if No (Curent)
2686               or else
2687                 (XE.Ent /= Curent
2688                  and then
2689                    (Name_Change (XE.Ent) or else XE.Def /= Curdef))
2690             then
2691                Curent := XE.Ent;
2692                Curdef := XE.Def;
2693
2694                Get_Unqualified_Name_String (Chars (XE.Ent));
2695                Curlen := Name_Len;
2696                Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
2697
2698                if Write_Info_Col > 1 then
2699                   Write_Info_EOL;
2700                end if;
2701
2702                --  Write line and column number information
2703
2704                Write_Info_Nat  (Int (Get_Logical_Line_Number (XE.Def)));
2705                Write_Info_Char (Ctyp);
2706                Write_Info_Nat  (Int (Get_Column_Number (XE.Def)));
2707                Write_Info_Char (' ');
2708
2709                --  Output entity name
2710
2711                Write_Entity_Name (XE.Ent, Cursrc);
2712
2713                --  End of processing for entity output
2714
2715                Crloc := No_Location;
2716             end if;
2717
2718             --  Output the reference if it is not as the same location
2719             --  as the previous one, or it is a read-reference that
2720             --  indicates that the entity is an in-out actual in a call.
2721
2722             if XE.Loc /= No_Location
2723               and then
2724                 (XE.Loc /= Crloc
2725                  or else (Prevt = 'm' and then XE.Typ = 'r'))
2726             then
2727                Crloc := XE.Loc;
2728                Prevt := XE.Typ;
2729
2730                --  Start continuation if line full, else blank
2731
2732                if Write_Info_Col > 72 then
2733                   Write_Info_EOL;
2734                   Write_Info_Initiate ('.');
2735                end if;
2736
2737                Write_Info_Char (' ');
2738
2739                --  Output file number if changed
2740
2741                if XE.Lun /= Curru then
2742                   Curru := XE.Lun;
2743                   Write_Info_Nat (Dependency_Num (Curru));
2744                   Write_Info_Char ('|');
2745                end if;
2746
2747                --  Write line and column number information
2748
2749                Write_Info_Nat  (Int (Get_Logical_Line_Number (XE.Loc)));
2750                Write_Info_Char (XE.Typ);
2751                Write_Info_Nat  (Int (Get_Column_Number (XE.Loc)));
2752             end if;
2753          end Output_One_Ref;
2754       end loop;
2755
2756       Write_Info_EOL;
2757    end Output_Local_References;
2758
2759    -----------------------
2760    -- Write_Entity_Name --
2761    -----------------------
2762
2763    procedure Write_Entity_Name (E : Entity_Id; Cursrc : Source_Buffer_Ptr) is
2764       P, P2 : Source_Ptr;
2765       --  Used to index into source buffer to get entity name
2766
2767       WC    : Char_Code;
2768       Err   : Boolean;
2769       pragma Warnings (Off, WC);
2770       pragma Warnings (Off, Err);
2771
2772    begin
2773       P := Original_Location (Sloc (E));
2774
2775       --  Entity is character literal
2776
2777       if Cursrc (P) = ''' then
2778          Write_Info_Char (Cursrc (P));
2779          Write_Info_Char (Cursrc (P + 1));
2780          Write_Info_Char (Cursrc (P + 2));
2781
2782          --  Entity is operator symbol
2783
2784       elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
2785          Write_Info_Char (Cursrc (P));
2786
2787          P2 := P;
2788          loop
2789             P2 := P2 + 1;
2790             Write_Info_Char (Cursrc (P2));
2791             exit when Cursrc (P2) = Cursrc (P);
2792          end loop;
2793
2794          --  Entity is identifier
2795
2796       else
2797          loop
2798             if Is_Start_Of_Wide_Char (Cursrc, P) then
2799                Scan_Wide (Cursrc, P, WC, Err);
2800             elsif not Identifier_Char (Cursrc (P)) then
2801                exit;
2802             else
2803                P := P + 1;
2804             end if;
2805          end loop;
2806
2807          --  Write out the identifier by copying the exact
2808          --  source characters used in its declaration. Note
2809          --  that this means wide characters will be in their
2810          --  original encoded form.
2811
2812          for J in
2813            Original_Location (Sloc (E)) .. P - 1
2814          loop
2815             Write_Info_Char (Cursrc (J));
2816          end loop;
2817       end if;
2818    end Write_Entity_Name;
2819
2820 end Lib.Xref;