gcc/ada/lib-xref.adb

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