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