gcc/ada/lib-xref.adb

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