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 (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 := First_Elmt (Interfaces (Ent));
1160                   begin
1161                      while Present (Elmt) loop
1162                         New_Entry (Node (Elmt));
1163                         Next_Elmt (Elmt);
1164                      end loop;
1165                   end;
1166                end if;
1167             end if;
1168
1169             --  Collect inherited primitive operations that may be declared in
1170             --  another unit and have no visible reference in the current one.
1171
1172             if Is_Type (Ent)
1173               and then Is_Tagged_Type (Ent)
1174               and then Is_Derived_Type (Ent)
1175               and then Ent = Base_Type (Ent)
1176               and then In_Extended_Main_Source_Unit (Ent)
1177             then
1178                declare
1179                   Op_List : constant Elist_Id := Primitive_Operations (Ent);
1180                   Op      : Elmt_Id;
1181                   Prim    : Entity_Id;
1182
1183                   function Parent_Op (E : Entity_Id) return Entity_Id;
1184                   --  Find original operation, which may be inherited through
1185                   --  several derivations.
1186
1187                   function Parent_Op (E : Entity_Id) return Entity_Id is
1188                      Orig_Op : constant Entity_Id := Alias (E);
1189                   begin
1190                      if No (Orig_Op) then
1191                         return Empty;
1192                      elsif not Comes_From_Source (E)
1193                        and then not Has_Xref_Entry (Orig_Op)
1194                        and then Comes_From_Source (Orig_Op)
1195                      then
1196                         return Orig_Op;
1197                      else
1198                         return Parent_Op (Orig_Op);
1199                      end if;
1200                   end Parent_Op;
1201
1202                begin
1203                   Op := First_Elmt (Op_List);
1204                   while Present (Op) loop
1205                      Prim := Parent_Op (Node (Op));
1206
1207                      if Present (Prim) then
1208                         Xrefs.Increment_Last;
1209                         Indx := Xrefs.Last;
1210                         Loc  := Original_Location (Sloc (Prim));
1211                         Xrefs.Table (Indx).Ent := Prim;
1212                         Xrefs.Table (Indx).Loc := No_Location;
1213                         Xrefs.Table (Indx).Eun :=
1214                           Get_Source_Unit (Sloc (Prim));
1215                         Xrefs.Table (Indx).Lun := No_Unit;
1216                         Set_Has_Xref_Entry (Prim);
1217                      end if;
1218
1219                      Next_Elmt (Op);
1220                   end loop;
1221                end;
1222             end if;
1223
1224             J := J + 1;
1225          end loop;
1226       end Handle_Orphan_Type_References;
1227
1228       --  Now we have all the references, including those for any embedded
1229       --  type references, so we can sort them, and output them.
1230
1231       Output_Refs : declare
1232
1233          Nrefs : Nat := Xrefs.Last;
1234          --  Number of references in table. This value may get reset (reduced)
1235          --  when we eliminate duplicate reference entries.
1236
1237          Rnums : array (0 .. Nrefs) of Nat;
1238          --  This array contains numbers of references in the Xrefs table.
1239          --  This list is sorted in output order. The extra 0'th entry is
1240          --  convenient for the call to sort. When we sort the table, we
1241          --  move the entries in Rnums around, but we do not move the
1242          --  original table entries.
1243
1244          Curxu : Unit_Number_Type;
1245          --  Current xref unit
1246
1247          Curru : Unit_Number_Type;
1248          --  Current reference unit for one entity
1249
1250          Cursrc : Source_Buffer_Ptr;
1251          --  Current xref unit source text
1252
1253          Curent : Entity_Id;
1254          --  Current entity
1255
1256          Curnam : String (1 .. Name_Buffer'Length);
1257          Curlen : Natural;
1258          --  Simple name and length of current entity
1259
1260          Curdef : Source_Ptr;
1261          --  Original source location for current entity
1262
1263          Crloc : Source_Ptr;
1264          --  Current reference location
1265
1266          Ctyp : Character;
1267          --  Entity type character
1268
1269          Tref : Entity_Id;
1270          --  Type reference
1271
1272          Rref : Node_Id;
1273          --  Renaming reference
1274
1275          Trunit : Unit_Number_Type;
1276          --  Unit number for type reference
1277
1278          function Lt (Op1, Op2 : Natural) return Boolean;
1279          --  Comparison function for Sort call
1280
1281          function Name_Change (X : Entity_Id) return Boolean;
1282          --  Determines if entity X has a different simple name from Curent
1283
1284          procedure Move (From : Natural; To : Natural);
1285          --  Move procedure for Sort call
1286
1287          package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
1288
1289          --------
1290          -- Lt --
1291          --------
1292
1293          function Lt (Op1, Op2 : Natural) return Boolean is
1294             T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
1295             T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
1296
1297          begin
1298             --  First test: if entity is in different unit, sort by unit
1299
1300             if T1.Eun /= T2.Eun then
1301                return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
1302
1303             --  Second test: within same unit, sort by entity Sloc
1304
1305             elsif T1.Def /= T2.Def then
1306                return T1.Def < T2.Def;
1307
1308             --  Third test: sort definitions ahead of references
1309
1310             elsif T1.Loc = No_Location then
1311                return True;
1312
1313             elsif T2.Loc = No_Location then
1314                return False;
1315
1316             --  Fourth test: for same entity, sort by reference location unit
1317
1318             elsif T1.Lun /= T2.Lun then
1319                return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
1320
1321             --  Fifth test: order of location within referencing unit
1322
1323             elsif T1.Loc /= T2.Loc then
1324                return T1.Loc < T2.Loc;
1325
1326             --  Finally, for two locations at the same address, we prefer
1327             --  the one that does NOT have the type 'r' so that a modification
1328             --  or extension takes preference, when there are more than one
1329             --  reference at the same location.
1330
1331             else
1332                return T2.Typ = 'r';
1333             end if;
1334          end Lt;
1335
1336          ----------
1337          -- Move --
1338          ----------
1339
1340          procedure Move (From : Natural; To : Natural) is
1341          begin
1342             Rnums (Nat (To)) := Rnums (Nat (From));
1343          end Move;
1344
1345          -----------------
1346          -- Name_Change --
1347          -----------------
1348
1349          --  Why a string comparison here??? Why not compare Name_Id values???
1350
1351          function Name_Change (X : Entity_Id) return Boolean is
1352          begin
1353             Get_Unqualified_Name_String (Chars (X));
1354
1355             if Name_Len /= Curlen then
1356                return True;
1357
1358             else
1359                return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
1360             end if;
1361          end Name_Change;
1362
1363       --  Start of processing for Output_Refs
1364
1365       begin
1366          --  Capture the definition Sloc values. We delay doing this till now,
1367          --  since at the time the reference or definition is made, private
1368          --  types may be swapped, and the Sloc value may be incorrect. We
1369          --  also set up the pointer vector for the sort.
1370
1371          for J in 1 .. Nrefs loop
1372             Rnums (J) := J;
1373             Xrefs.Table (J).Def :=
1374               Original_Location (Sloc (Xrefs.Table (J).Ent));
1375          end loop;
1376
1377          --  Sort the references
1378
1379          Sorting.Sort (Integer (Nrefs));
1380
1381          --  Eliminate duplicate entries
1382
1383          declare
1384             NR : constant Nat := Nrefs;
1385
1386          begin
1387             --  We need this test for NR because if we force ALI file
1388             --  generation in case of errors detected, it may be the case
1389             --  that Nrefs is 0, so we should not reset it here
1390
1391             if NR >= 2 then
1392                Nrefs := 1;
1393
1394                for J in 2 .. NR loop
1395                   if Xrefs.Table (Rnums (J)) /=
1396                      Xrefs.Table (Rnums (Nrefs))
1397                   then
1398                      Nrefs := Nrefs + 1;
1399                      Rnums (Nrefs) := Rnums (J);
1400                   end if;
1401                end loop;
1402             end if;
1403          end;
1404
1405          --  Initialize loop through references
1406
1407          Curxu  := No_Unit;
1408          Curent := Empty;
1409          Curdef := No_Location;
1410          Curru  := No_Unit;
1411          Crloc  := No_Location;
1412
1413          --  Loop to output references
1414
1415          for Refno in 1 .. Nrefs loop
1416             Output_One_Ref : declare
1417                P2  : Source_Ptr;
1418                Ent : Entity_Id;
1419
1420                WC  : Char_Code;
1421                Err : Boolean;
1422                pragma Warnings (Off, WC);
1423                pragma Warnings (Off, Err);
1424
1425                XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
1426                --  The current entry to be accessed
1427
1428                P : Source_Ptr;
1429                --  Used to index into source buffer to get entity name
1430
1431                Left  : Character;
1432                Right : Character;
1433                --  Used for {} or <> or () for type reference
1434
1435                procedure Check_Type_Reference
1436                  (Ent : Entity_Id;
1437                   List_Interface : Boolean);
1438                --  Find whether there is a meaningful type reference for
1439                --  Ent, and display it accordingly. If List_Interface is
1440                --  true, then Ent is a progenitor interface of the current
1441                --  type entity being listed. In that case list it as is,
1442                --  without looking for a type reference for it.
1443
1444                procedure Output_Instantiation_Refs (Loc : Source_Ptr);
1445                --  Recursive procedure to output instantiation references for
1446                --  the given source ptr in [file|line[...]] form. No output
1447                --  if the given location is not a generic template reference.
1448
1449                procedure Output_Overridden_Op (Old_E : Entity_Id);
1450                --  For a subprogram that is overriding, display information
1451                --  about the inherited operation that it overrides.
1452
1453                --------------------------
1454                -- Check_Type_Reference --
1455                --------------------------
1456
1457                procedure Check_Type_Reference
1458                  (Ent : Entity_Id;
1459                   List_Interface : Boolean)
1460                is
1461                begin
1462                   if List_Interface then
1463
1464                      --  This is a progenitor interface of the type for which
1465                      --  xref information is being generated.
1466
1467                      Tref  := Ent;
1468                      Left  := '<';
1469                      Right := '>';
1470
1471                   else
1472                      Get_Type_Reference (Ent, Tref, Left, Right);
1473                   end if;
1474
1475                   if Present (Tref) then
1476
1477                      --  Case of standard entity, output name
1478
1479                      if Sloc (Tref) = Standard_Location then
1480                         Write_Info_Char (Left);
1481                         Write_Info_Name (Chars (Tref));
1482                         Write_Info_Char (Right);
1483
1484                      --  Case of source entity, output location
1485
1486                      else
1487                         Write_Info_Char (Left);
1488                         Trunit := Get_Source_Unit (Sloc (Tref));
1489
1490                         if Trunit /= Curxu then
1491                            Write_Info_Nat (Dependency_Num (Trunit));
1492                            Write_Info_Char ('|');
1493                         end if;
1494
1495                         Write_Info_Nat
1496                           (Int (Get_Logical_Line_Number (Sloc (Tref))));
1497
1498                         declare
1499                            Ent  : Entity_Id;
1500                            Ctyp : Character;
1501
1502                         begin
1503                            Ent := Tref;
1504                            Ctyp := Xref_Entity_Letters (Ekind (Ent));
1505
1506                            if Ctyp = '+'
1507                              and then Present (Full_View (Ent))
1508                            then
1509                               Ent := Underlying_Type (Ent);
1510
1511                               if Present (Ent) then
1512                                  Ctyp := Xref_Entity_Letters (Ekind (Ent));
1513                               end if;
1514                            end if;
1515
1516                            Write_Info_Char (Ctyp);
1517                         end;
1518
1519                         Write_Info_Nat
1520                           (Int (Get_Column_Number (Sloc (Tref))));
1521
1522                         --  If the type comes from an instantiation, add the
1523                         --  corresponding info.
1524
1525                         Output_Instantiation_Refs (Sloc (Tref));
1526                         Write_Info_Char (Right);
1527                      end if;
1528                   end if;
1529                end Check_Type_Reference;
1530
1531                -------------------------------
1532                -- Output_Instantiation_Refs --
1533                -------------------------------
1534
1535                procedure Output_Instantiation_Refs (Loc : Source_Ptr) is
1536                   Iloc : constant Source_Ptr := Instantiation_Location (Loc);
1537                   Lun  : Unit_Number_Type;
1538                   Cu   : constant Unit_Number_Type := Curru;
1539
1540                begin
1541                   --  Nothing to do if this is not an instantiation
1542
1543                   if Iloc = No_Location then
1544                      return;
1545                   end if;
1546
1547                   --  Output instantiation reference
1548
1549                   Write_Info_Char ('[');
1550                   Lun := Get_Source_Unit (Iloc);
1551
1552                   if Lun /= Curru then
1553                      Curru := Lun;
1554                      Write_Info_Nat (Dependency_Num (Curru));
1555                      Write_Info_Char ('|');
1556                   end if;
1557
1558                   Write_Info_Nat (Int (Get_Logical_Line_Number (Iloc)));
1559
1560                   --  Recursive call to get nested instantiations
1561
1562                   Output_Instantiation_Refs (Iloc);
1563
1564                   --  Output final ] after call to get proper nesting
1565
1566                   Write_Info_Char (']');
1567                   Curru := Cu;
1568                   return;
1569                end Output_Instantiation_Refs;
1570
1571                --------------------------
1572                -- Output_Overridden_Op --
1573                --------------------------
1574
1575                procedure Output_Overridden_Op (Old_E : Entity_Id) is
1576                   Op : Entity_Id;
1577
1578                begin
1579                   --  The overridden operation has an implicit declaration
1580                   --  at the point of derivation. What we want to display
1581                   --  is the original operation, which has the actual body
1582                   --  (or abstract declaration) that is being overridden.
1583                   --  The overridden operation is not always set, e.g. when
1584                   --  it is a predefined operator.
1585
1586                   if No (Old_E) then
1587                      return;
1588
1589                   elsif Present (Alias (Old_E)) then
1590                      Op := Alias (Old_E);
1591
1592                   else
1593                      Op := Old_E;
1594                   end if;
1595
1596                   if Present (Op)
1597                     and then Sloc (Op) /= Standard_Location
1598                   then
1599                      declare
1600                         Loc      : constant Source_Ptr := Sloc (Op);
1601                         Par_Unit : constant Unit_Number_Type :=
1602                                      Get_Source_Unit (Loc);
1603
1604                      begin
1605                         Write_Info_Char ('<');
1606
1607                         if Par_Unit /= Curxu then
1608                            Write_Info_Nat (Dependency_Num (Par_Unit));
1609                            Write_Info_Char ('|');
1610                         end if;
1611
1612                         Write_Info_Nat (Int (Get_Logical_Line_Number (Loc)));
1613                         Write_Info_Char ('p');
1614                         Write_Info_Nat (Int (Get_Column_Number (Loc)));
1615                         Write_Info_Char ('>');
1616                      end;
1617                   end if;
1618                end Output_Overridden_Op;
1619
1620             --  Start of processing for Output_One_Ref
1621
1622             begin
1623                Ent := XE.Ent;
1624                Ctyp := Xref_Entity_Letters (Ekind (Ent));
1625
1626                --  Skip reference if it is the only reference to an entity,
1627                --  and it is an END line reference, and the entity is not in
1628                --  the current extended source. This prevents junk entries
1629                --  consisting only of packages with END lines, where no
1630                --  entity from the package is actually referenced.
1631
1632                if XE.Typ = 'e'
1633                  and then Ent /= Curent
1634                  and then (Refno = Nrefs or else
1635                              Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent)
1636                  and then
1637                    not In_Extended_Main_Source_Unit (Ent)
1638                then
1639                   goto Continue;
1640                end if;
1641
1642                --  For private type, get full view type
1643
1644                if Ctyp = '+'
1645                  and then Present (Full_View (XE.Ent))
1646                then
1647                   Ent := Underlying_Type (Ent);
1648
1649                   if Present (Ent) then
1650                      Ctyp := Xref_Entity_Letters (Ekind (Ent));
1651                   end if;
1652                end if;
1653
1654                --  Special exception for Boolean
1655
1656                if Ctyp = 'E' and then Is_Boolean_Type (Ent) then
1657                   Ctyp := 'B';
1658                end if;
1659
1660                --  For variable reference, get corresponding type
1661
1662                if Ctyp = '*' then
1663                   Ent := Etype (XE.Ent);
1664                   Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1665
1666                   --  If variable is private type, get full view type
1667
1668                   if Ctyp = '+'
1669                     and then Present (Full_View (Etype (XE.Ent)))
1670                   then
1671                      Ent := Underlying_Type (Etype (XE.Ent));
1672
1673                      if Present (Ent) then
1674                         Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1675                      end if;
1676
1677                   elsif Is_Generic_Type (Ent) then
1678
1679                      --  If the type of the entity is a generic private type,
1680                      --  there is no usable full view, so retain the indication
1681                      --  that this is an object.
1682
1683                      Ctyp := '*';
1684                   end if;
1685
1686                   --  Special handling for access parameter
1687
1688                   declare
1689                      K : constant Entity_Kind := Ekind (Etype (XE.Ent));
1690
1691                   begin
1692                      if (K = E_Anonymous_Access_Type
1693                            or else
1694                          K = E_Anonymous_Access_Subprogram_Type
1695                             or else K =
1696                          E_Anonymous_Access_Protected_Subprogram_Type)
1697                        and then Is_Formal (XE.Ent)
1698                      then
1699                         Ctyp := 'p';
1700
1701                         --  Special handling for Boolean
1702
1703                      elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
1704                         Ctyp := 'b';
1705                      end if;
1706                   end;
1707                end if;
1708
1709                --  Special handling for abstract types and operations
1710
1711                if Is_Overloadable (XE.Ent)
1712                  and then Is_Abstract_Subprogram (XE.Ent)
1713                then
1714                   if Ctyp = 'U' then
1715                      Ctyp := 'x';            --  Abstract procedure
1716
1717                   elsif Ctyp = 'V' then
1718                      Ctyp := 'y';            --  Abstract function
1719                   end if;
1720
1721                elsif Is_Type (XE.Ent)
1722                  and then Is_Abstract_Type (XE.Ent)
1723                then
1724                   if Is_Interface (XE.Ent) then
1725                      Ctyp := 'h';
1726
1727                   elsif Ctyp = 'R' then
1728                      Ctyp := 'H';            --  Abstract type
1729                   end if;
1730                end if;
1731
1732                --  Only output reference if interesting type of entity, and
1733                --  suppress self references, except for bodies that act as
1734                --  specs. Also suppress definitions of body formals (we only
1735                --  treat these as references, and the references were
1736                --  separately recorded).
1737
1738                if Ctyp = ' '
1739                  or else (XE.Loc = XE.Def
1740                             and then
1741                               (XE.Typ /= 'b'
1742                                 or else not Is_Subprogram (XE.Ent)))
1743                  or else (Is_Formal (XE.Ent)
1744                             and then Present (Spec_Entity (XE.Ent)))
1745                then
1746                   null;
1747
1748                else
1749                   --  Start new Xref section if new xref unit
1750
1751                   if XE.Eun /= Curxu then
1752                      if Write_Info_Col > 1 then
1753                         Write_Info_EOL;
1754                      end if;
1755
1756                      Curxu := XE.Eun;
1757                      Cursrc := Source_Text (Source_Index (Curxu));
1758
1759                      Write_Info_Initiate ('X');
1760                      Write_Info_Char (' ');
1761                      Write_Info_Nat (Dependency_Num (XE.Eun));
1762                      Write_Info_Char (' ');
1763                      Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
1764                   end if;
1765
1766                   --  Start new Entity line if new entity. Note that we
1767                   --  consider two entities the same if they have the same
1768                   --  name and source location. This causes entities in
1769                   --  instantiations to be treated as though they referred
1770                   --  to the template.
1771
1772                   if No (Curent)
1773                     or else
1774                       (XE.Ent /= Curent
1775                          and then
1776                            (Name_Change (XE.Ent) or else XE.Def /= Curdef))
1777                   then
1778                      Curent := XE.Ent;
1779                      Curdef := XE.Def;
1780
1781                      Get_Unqualified_Name_String (Chars (XE.Ent));
1782                      Curlen := Name_Len;
1783                      Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
1784
1785                      if Write_Info_Col > 1 then
1786                         Write_Info_EOL;
1787                      end if;
1788
1789                      --  Write column number information
1790
1791                      Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def)));
1792                      Write_Info_Char (Ctyp);
1793                      Write_Info_Nat (Int (Get_Column_Number (XE.Def)));
1794
1795                      --  Write level information
1796
1797                      Write_Level_Info : declare
1798                         function Is_Visible_Generic_Entity
1799                           (E : Entity_Id) return Boolean;
1800                         --  Check whether E is declared in the visible part
1801                         --  of a generic package. For source navigation
1802                         --  purposes, treat this as a visible entity.
1803
1804                         function Is_Private_Record_Component
1805                           (E : Entity_Id) return Boolean;
1806                         --  Check whether E is a non-inherited component of a
1807                         --  private extension. Even if the enclosing record is
1808                         --  public, we want to treat the component as private
1809                         --  for navigation purposes.
1810
1811                         ---------------------------------
1812                         -- Is_Private_Record_Component --
1813                         ---------------------------------
1814
1815                         function Is_Private_Record_Component
1816                           (E : Entity_Id) return Boolean
1817                         is
1818                            S : constant Entity_Id := Scope (E);
1819                         begin
1820                            return
1821                              Ekind (E) = E_Component
1822                                and then Nkind (Declaration_Node (S)) =
1823                                  N_Private_Extension_Declaration
1824                                and then Original_Record_Component (E) = E;
1825                         end Is_Private_Record_Component;
1826
1827                         -------------------------------
1828                         -- Is_Visible_Generic_Entity --
1829                         -------------------------------
1830
1831                         function Is_Visible_Generic_Entity
1832                           (E : Entity_Id) return Boolean
1833                         is
1834                            Par : Node_Id;
1835
1836                         begin
1837                            --  The Present check here is an error defense
1838
1839                            if Present (Scope (E))
1840                              and then Ekind (Scope (E)) /= E_Generic_Package
1841                            then
1842                               return False;
1843                            end if;
1844
1845                            Par := Parent (E);
1846                            while Present (Par) loop
1847                               if
1848                                 Nkind (Par) = N_Generic_Package_Declaration
1849                               then
1850                                  --  Entity is a generic formal
1851
1852                                  return False;
1853
1854                               elsif
1855                                 Nkind (Parent (Par)) = N_Package_Specification
1856                               then
1857                                  return
1858                                    Is_List_Member (Par)
1859                                      and then List_Containing (Par) =
1860                                        Visible_Declarations (Parent (Par));
1861                               else
1862                                  Par := Parent (Par);
1863                               end if;
1864                            end loop;
1865
1866                            return False;
1867                         end Is_Visible_Generic_Entity;
1868
1869                      --  Start of processing for Write_Level_Info
1870
1871                      begin
1872                         if Is_Hidden (Curent)
1873                           or else Is_Private_Record_Component (Curent)
1874                         then
1875                            Write_Info_Char (' ');
1876
1877                         elsif
1878                            Is_Public (Curent)
1879                              or else Is_Visible_Generic_Entity (Curent)
1880                         then
1881                            Write_Info_Char ('*');
1882
1883                         else
1884                            Write_Info_Char (' ');
1885                         end if;
1886                      end Write_Level_Info;
1887
1888                      --  Output entity name. We use the occurrence from the
1889                      --  actual source program at the definition point.
1890
1891                      P := Original_Location (Sloc (XE.Ent));
1892
1893                      --  Entity is character literal
1894
1895                      if Cursrc (P) = ''' then
1896                         Write_Info_Char (Cursrc (P));
1897                         Write_Info_Char (Cursrc (P + 1));
1898                         Write_Info_Char (Cursrc (P + 2));
1899
1900                      --  Entity is operator symbol
1901
1902                      elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
1903                         Write_Info_Char (Cursrc (P));
1904
1905                         P2 := P;
1906                         loop
1907                            P2 := P2 + 1;
1908                            Write_Info_Char (Cursrc (P2));
1909                            exit when Cursrc (P2) = Cursrc (P);
1910                         end loop;
1911
1912                      --  Entity is identifier
1913
1914                      else
1915                         loop
1916                            if Is_Start_Of_Wide_Char (Cursrc, P) then
1917                               Scan_Wide (Cursrc, P, WC, Err);
1918                            elsif not Identifier_Char (Cursrc (P)) then
1919                               exit;
1920                            else
1921                               P := P + 1;
1922                            end if;
1923                         end loop;
1924
1925                         --  Write out the identifier by copying the exact
1926                         --  source characters used in its declaration. Note
1927                         --  that this means wide characters will be in their
1928                         --  original encoded form.
1929
1930                         for J in
1931                           Original_Location (Sloc (XE.Ent)) .. P - 1
1932                         loop
1933                            Write_Info_Char (Cursrc (J));
1934                         end loop;
1935                      end if;
1936
1937                      --  See if we have a renaming reference
1938
1939                      if Is_Object (XE.Ent)
1940                        and then Present (Renamed_Object (XE.Ent))
1941                      then
1942                         Rref := Renamed_Object (XE.Ent);
1943
1944                      elsif Is_Overloadable (XE.Ent)
1945                        and then Nkind (Parent (Declaration_Node (XE.Ent))) =
1946                                             N_Subprogram_Renaming_Declaration
1947                      then
1948                         Rref := Name (Parent (Declaration_Node (XE.Ent)));
1949
1950                      elsif Ekind (XE.Ent) = E_Package
1951                        and then Nkind (Declaration_Node (XE.Ent)) =
1952                                          N_Package_Renaming_Declaration
1953                      then
1954                         Rref := Name (Declaration_Node (XE.Ent));
1955
1956                      else
1957                         Rref := Empty;
1958                      end if;
1959
1960                      if Present (Rref) then
1961                         if Nkind (Rref) = N_Expanded_Name then
1962                            Rref := Selector_Name (Rref);
1963                         end if;
1964
1965                         if Nkind (Rref) = N_Identifier
1966                           or else Nkind (Rref) = N_Operator_Symbol
1967                         then
1968                            null;
1969
1970                         --  For renamed array components, use the array name
1971                         --  for the renamed entity, which reflect the fact that
1972                         --  in general the whole array is aliased.
1973
1974                         elsif Nkind (Rref) = N_Indexed_Component then
1975                            if Nkind (Prefix (Rref)) = N_Identifier then
1976                               Rref := Prefix (Rref);
1977                            elsif Nkind (Prefix (Rref)) = N_Expanded_Name then
1978                               Rref := Selector_Name (Prefix (Rref));
1979                            else
1980                               Rref := Empty;
1981                            end if;
1982
1983                         else
1984                            Rref := Empty;
1985                         end if;
1986                      end if;
1987
1988                      --  Write out renaming reference if we have one
1989
1990                      if Present (Rref) then
1991                         Write_Info_Char ('=');
1992                         Write_Info_Nat
1993                           (Int (Get_Logical_Line_Number (Sloc (Rref))));
1994                         Write_Info_Char (':');
1995                         Write_Info_Nat
1996                           (Int (Get_Column_Number (Sloc (Rref))));
1997                      end if;
1998
1999                      --  Indicate that the entity is in the unit of the current
2000                      --  xref section.
2001
2002                      Curru := Curxu;
2003
2004                      --  Write out information about generic parent, if entity
2005                      --  is an instance.
2006
2007                      if  Is_Generic_Instance (XE.Ent) then
2008                         declare
2009                            Gen_Par : constant Entity_Id :=
2010                                        Generic_Parent
2011                                          (Specification
2012                                             (Unit_Declaration_Node (XE.Ent)));
2013                            Loc     : constant Source_Ptr := Sloc (Gen_Par);
2014                            Gen_U   : constant Unit_Number_Type :=
2015                                        Get_Source_Unit (Loc);
2016
2017                         begin
2018                            Write_Info_Char ('[');
2019                            if Curru /= Gen_U then
2020                               Write_Info_Nat (Dependency_Num (Gen_U));
2021                               Write_Info_Char ('|');
2022                            end if;
2023
2024                            Write_Info_Nat
2025                              (Int (Get_Logical_Line_Number (Loc)));
2026                            Write_Info_Char (']');
2027                         end;
2028                      end if;
2029
2030                      --  See if we have a type reference and if so output
2031
2032                      Check_Type_Reference (XE.Ent, False);
2033
2034                      --  Additional information for types with progenitors
2035
2036                      if Is_Record_Type (XE.Ent)
2037                        and then Present (Interfaces (XE.Ent))
2038                      then
2039                         declare
2040                            Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent));
2041                         begin
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;