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