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 --                                                                          --
  10 --          Copyright (C) 1998-2002, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Csets;    use Csets;
  30 with Errout;   use Errout;
  31 with Lib.Util; use Lib.Util;
  32 with Namet;    use Namet;
  33 with Opt;      use Opt;
  34 with Sinfo;    use Sinfo;
  35 with Sinput;   use Sinput;
  36 with Stand;    use Stand;
  37 with Table;    use Table;
  38 with Widechar; use Widechar;
  39
  40 with GNAT.Heap_Sort_A;
  41
  42 package body Lib.Xref is
  43
  44    ------------------
  45    -- Declarations --
  46    ------------------
  47
  48    --  The Xref table is used to record references. The Loc field is set
  49    --  to No_Location for a definition entry.
  50
  51    subtype Xref_Entry_Number is Int;
  52
  53    type Xref_Entry is record
  54       Ent : Entity_Id;
  55       --  Entity referenced (E parameter to Generate_Reference)
  56
  57       Def : Source_Ptr;
  58       --  Original source location for entity being referenced. Note that
  59       --  these values are used only during the output process, they are
  60       --  not set when the entries are originally built. This is because
  61       --  private entities can be swapped when the initial call is made.
  62
  63       Loc : Source_Ptr;
  64       --  Location of reference (Original_Location (Sloc field of N parameter
  65       --  to Generate_Reference). Set to No_Location for the case of a
  66       --  defining occurrence.
  67
  68       Typ : Character;
  69       --  Reference type (Typ param to Generate_Reference)
  70
  71       Eun : Unit_Number_Type;
  72       --  Unit number corresponding to Ent
  73
  74       Lun : Unit_Number_Type;
  75       --  Unit number corresponding to Loc. Value is undefined and not
  76       --  referenced if Loc is set to No_Location.
  77
  78    end record;
  79
  80    package Xrefs is new Table.Table (
  81      Table_Component_Type => Xref_Entry,
  82      Table_Index_Type     => Xref_Entry_Number,
  83      Table_Low_Bound      => 1,
  84      Table_Initial        => Alloc.Xrefs_Initial,
  85      Table_Increment      => Alloc.Xrefs_Increment,
  86      Table_Name           => "Xrefs");
  87
  88    -------------------------
  89    -- Generate_Definition --
  90    -------------------------
  91
  92    procedure Generate_Definition (E : Entity_Id) is
  93       Loc  : Source_Ptr;
  94       Indx : Nat;
  95
  96    begin
  97       pragma Assert (Nkind (E) in N_Entity);
  98
  99       --  Note that we do not test Xref_Entity_Letters here. It is too
 100       --  early to do so, since we are often called before the entity
 101       --  is fully constructed, so that the Ekind is still E_Void.
 102
 103       if Opt.Xref_Active
 104
 105          --  Definition must come from source
 106
 107          and then Comes_From_Source (E)
 108
 109          --  And must have a reasonable source location that is not
 110          --  within an instance (all entities in instances are ignored)
 111
 112          and then Sloc (E) > No_Location
 113          and then Instantiation_Location (Sloc (E)) = No_Location
 114
 115          --  And must be a non-internal name from the main source unit
 116
 117          and then In_Extended_Main_Source_Unit (E)
 118          and then not Is_Internal_Name (Chars (E))
 119       then
 120          Xrefs.Increment_Last;
 121          Indx := Xrefs.Last;
 122          Loc  := Original_Location (Sloc (E));
 123
 124          Xrefs.Table (Indx).Ent := E;
 125          Xrefs.Table (Indx).Loc := No_Location;
 126          Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
 127          Xrefs.Table (Indx).Lun := No_Unit;
 128       end if;
 129    end Generate_Definition;
 130
 131    ---------------------------------
 132    -- Generate_Operator_Reference --
 133    ---------------------------------
 134
 135    procedure Generate_Operator_Reference (N : Node_Id) is
 136    begin
 137       if not In_Extended_Main_Source_Unit (N) then
 138          return;
 139       end if;
 140
 141       --  If the operator is not a Standard operator, then we generate
 142       --  a real reference to the user defined operator.
 143
 144       if Sloc (Entity (N)) /= Standard_Location then
 145          Generate_Reference (Entity (N), N);
 146
 147          --  A reference to an implicit inequality operator is a also a
 148          --  reference to the user-defined equality.
 149
 150          if Nkind (N) = N_Op_Ne
 151            and then not Comes_From_Source (Entity (N))
 152            and then Present (Corresponding_Equality (Entity (N)))
 153          then
 154             Generate_Reference (Corresponding_Equality (Entity (N)), N);
 155          end if;
 156
 157       --  For the case of Standard operators, we mark the result type
 158       --  as referenced. This ensures that in the case where we are
 159       --  using a derived operator, we mark an entity of the unit that
 160       --  implicitly defines this operator as used. Otherwise we may
 161       --  think that no entity of the unit is used. The actual entity
 162       --  marked as referenced is the first subtype, which is the user
 163       --  defined entity that is relevant.
 164
 165       else
 166          if Nkind (N) = N_Op_Eq
 167            or else Nkind (N) = N_Op_Ne
 168            or else Nkind (N) = N_Op_Le
 169            or else Nkind (N) = N_Op_Lt
 170            or else Nkind (N) = N_Op_Ge
 171            or else Nkind (N) = N_Op_Gt
 172          then
 173             Set_Referenced (First_Subtype (Etype (Right_Opnd (N))));
 174          else
 175             Set_Referenced (First_Subtype (Etype (N)));
 176          end if;
 177       end if;
 178    end Generate_Operator_Reference;
 179
 180    ------------------------
 181    -- Generate_Reference --
 182    ------------------------
 183
 184    procedure Generate_Reference
 185      (E       : Entity_Id;
 186       N       : Node_Id;
 187       Typ     : Character := 'r';
 188       Set_Ref : Boolean   := True;
 189       Force   : Boolean   := False)
 190    is
 191       Indx : Nat;
 192       Nod  : Node_Id;
 193       Ref  : Source_Ptr;
 194       Def  : Source_Ptr;
 195       Ent  : Entity_Id;
 196
 197    begin
 198       pragma Assert (Nkind (E) in N_Entity);
 199
 200       --  Never collect references if not in main source unit. However,
 201       --  we omit this test if Typ is 'e', since these entries are
 202       --  really structural, and it is useful to have them in units
 203       --  that reference packages as well as units that define packages.
 204       --  We also omit the test for the case of 'p' since we want to
 205       --  include inherited primitive operations from other packages.
 206
 207       if not In_Extended_Main_Source_Unit (N)
 208         and then Typ /= 'e'
 209         and then Typ /= 'p'
 210       then
 211          return;
 212       end if;
 213
 214       --  For reference type p, then entity must be in main source unit
 215
 216       if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then
 217          return;
 218       end if;
 219
 220       --  Unless the reference is forced, we ignore references where
 221       --  the reference itself does not come from Source.
 222
 223       if not Force and then not Comes_From_Source (N) then
 224          return;
 225       end if;
 226
 227       --  Deal with setting entity as referenced, unless suppressed.
 228       --  Note that we still do Set_Referenced on entities that do not
 229       --  come from source. This situation arises when we have a source
 230       --  reference to a derived operation, where the derived operation
 231       --  itself does not come from source, but we still want to mark it
 232       --  as referenced, since we really are referencing an entity in the
 233       --  corresponding package (this avoids incorrect complaints that the
 234       --  package contains no referenced entities).
 235
 236       if Set_Ref then
 237          Set_Referenced (E);
 238
 239          --  Check for pragma unreferenced given
 240
 241          if Has_Pragma_Unreferenced (E) then
 242
 243             --  A reference as a named parameter in a call does not count
 244             --  as a violation of pragma Unreferenced for this purpose.
 245
 246             if Nkind (N) = N_Identifier
 247               and then Nkind (Parent (N)) = N_Parameter_Association
 248               and then Selector_Name (Parent (N)) = N
 249             then
 250                null;
 251
 252             --  Here we issue the warning, since this is a real reference
 253
 254             else
 255                Error_Msg_NE ("?pragma Unreferenced given for&", N, E);
 256             end if;
 257          end if;
 258
 259          --  If this is a subprogram instance, mark as well the internal
 260          --  subprogram in the wrapper package, which may be a visible
 261          --  compilation unit.
 262
 263          if Is_Overloadable (E)
 264            and then Is_Generic_Instance (E)
 265            and then Present (Alias (E))
 266          then
 267             Set_Referenced (Alias (E));
 268          end if;
 269       end if;
 270
 271       --  Generate reference if all conditions are met:
 272
 273       if
 274          --  Cross referencing must be active
 275
 276          Opt.Xref_Active
 277
 278          --  The entity must be one for which we collect references
 279
 280          and then Xref_Entity_Letters (Ekind (E)) /= ' '
 281
 282          --  Both Sloc values must be set to something sensible
 283
 284          and then Sloc (E) > No_Location
 285          and then Sloc (N) > No_Location
 286
 287          --  We ignore references from within an instance
 288
 289          and then Instantiation_Location (Sloc (N)) = No_Location
 290
 291          --  Ignore dummy references
 292
 293         and then Typ /= ' '
 294       then
 295          if Nkind (N) = N_Identifier
 296               or else
 297             Nkind (N) = N_Defining_Identifier
 298               or else
 299             Nkind (N) in N_Op
 300               or else
 301             Nkind (N) = N_Defining_Operator_Symbol
 302               or else
 303             (Nkind (N) = N_Character_Literal
 304               and then Sloc (Entity (N)) /= Standard_Location)
 305               or else
 306             Nkind (N) = N_Defining_Character_Literal
 307          then
 308             Nod := N;
 309
 310          elsif Nkind (N) = N_Expanded_Name
 311                  or else
 312                Nkind (N) = N_Selected_Component
 313          then
 314             Nod := Selector_Name (N);
 315
 316          else
 317             return;
 318          end if;
 319
 320          --  Normal case of source entity comes from source
 321
 322          if Comes_From_Source (E) then
 323             Ent := E;
 324
 325          --  Entity does not come from source, but is a derived subprogram
 326          --  and the derived subprogram comes from source, in which case
 327          --  the reference is to this parent subprogram.
 328
 329          elsif Is_Overloadable (E)
 330            and then Present (Alias (E))
 331            and then Comes_From_Source (Alias (E))
 332          then
 333             Ent := Alias (E);
 334
 335          --  Ignore reference to any other source that is not from source
 336
 337          else
 338             return;
 339          end if;
 340
 341          --  Record reference to entity
 342
 343          Ref := Original_Location (Sloc (Nod));
 344          Def := Original_Location (Sloc (Ent));
 345
 346          Xrefs.Increment_Last;
 347          Indx := Xrefs.Last;
 348
 349          Xrefs.Table (Indx).Loc := Ref;
 350          Xrefs.Table (Indx).Typ := Typ;
 351          Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
 352          Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
 353          Xrefs.Table (Indx).Ent := Ent;
 354       end if;
 355    end Generate_Reference;
 356
 357    -----------------------
 358    -- Output_References --
 359    -----------------------
 360
 361    procedure Output_References is
 362       Nrefs : constant Nat := Xrefs.Last;
 363
 364       Rnums : array (0 .. Nrefs) of Nat;
 365       --  This array contains numbers of references in the Xrefs table. This
 366       --  list is sorted in output order. The extra 0'th entry is convenient
 367       --  for the call to sort. When we sort the table, we move these entries
 368       --  around, but we do not move the original table entries.
 369
 370       function Lt (Op1, Op2 : Natural) return Boolean;
 371       --  Comparison function for Sort call
 372
 373       procedure Move (From : Natural; To : Natural);
 374       --  Move procedure for Sort call
 375
 376       function Lt (Op1, Op2 : Natural) return Boolean is
 377          T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
 378          T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
 379
 380       begin
 381          --  First test. If entity is in different unit, sort by unit
 382
 383          if T1.Eun /= T2.Eun then
 384             return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
 385
 386          --  Second test, within same unit, sort by entity Sloc
 387
 388          elsif T1.Def /= T2.Def then
 389             return T1.Def < T2.Def;
 390
 391          --  Third test, sort definitions ahead of references
 392
 393          elsif T1.Loc = No_Location then
 394             return True;
 395
 396          elsif T2.Loc = No_Location then
 397             return False;
 398
 399          --  Fourth test, for same entity, sort by reference location unit
 400
 401          elsif T1.Lun /= T2.Lun then
 402             return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
 403
 404          --  Fifth test order of location within referencing unit
 405
 406          elsif T1.Loc /= T2.Loc then
 407             return T1.Loc < T2.Loc;
 408
 409          --  Finally, for two locations at the same address, we prefer
 410          --  the one that does NOT have the type 'r' so that a modification
 411          --  or extension takes preference, when there are more than one
 412          --  reference at the same location.
 413
 414          else
 415             return T2.Typ = 'r';
 416          end if;
 417       end Lt;
 418
 419       procedure Move (From : Natural; To : Natural) is
 420       begin
 421          Rnums (Nat (To)) := Rnums (Nat (From));
 422       end Move;
 423
 424    --  Start of processing for Output_References
 425
 426    begin
 427       if not Opt.Xref_Active then
 428          return;
 429       end if;
 430
 431       --  Capture the definition Sloc values. We delay doing this till now,
 432       --  since at the time the reference or definition is made, private
 433       --  types may be swapped, and the Sloc value may be incorrect. We
 434       --  also set up the pointer vector for the sort.
 435
 436       for J in 1 .. Nrefs loop
 437          Rnums (J) := J;
 438          Xrefs.Table (J).Def :=
 439            Original_Location (Sloc (Xrefs.Table (J).Ent));
 440       end loop;
 441
 442       --  Sort the references
 443
 444       GNAT.Heap_Sort_A.Sort
 445         (Integer (Nrefs),
 446          Move'Unrestricted_Access,
 447          Lt'Unrestricted_Access);
 448
 449       --  Now output the references
 450
 451       Output_Refs : declare
 452
 453          Curxu : Unit_Number_Type;
 454          --  Current xref unit
 455
 456          Curru : Unit_Number_Type;
 457          --  Current reference unit for one entity
 458
 459          Cursrc : Source_Buffer_Ptr;
 460          --  Current xref unit source text
 461
 462          Curent : Entity_Id;
 463          --  Current entity
 464
 465          Curnam : String (1 .. Name_Buffer'Length);
 466          Curlen : Natural;
 467          --  Simple name and length of current entity
 468
 469          Curdef : Source_Ptr;
 470          --  Original source location for current entity
 471
 472          Crloc : Source_Ptr;
 473          --  Current reference location
 474
 475          Ctyp : Character;
 476          --  Entity type character
 477
 478          Tref : Entity_Id;
 479          --  Type reference
 480
 481          Rref : Node_Id;
 482          --  Renaming reference
 483
 484          Trunit : Unit_Number_Type;
 485          --  Unit number for type reference
 486
 487          function Name_Change (X : Entity_Id) return Boolean;
 488          --  Determines if entity X has a different simple name from Curent
 489
 490          -----------------
 491          -- Name_Change --
 492          -----------------
 493
 494          function Name_Change (X : Entity_Id) return Boolean is
 495          begin
 496             Get_Unqualified_Name_String (Chars (X));
 497
 498             if Name_Len /= Curlen then
 499                return True;
 500
 501             else
 502                return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
 503             end if;
 504          end Name_Change;
 505
 506       --  Start of processing for Output_Refs
 507
 508       begin
 509          Curxu  := No_Unit;
 510          Curent := Empty;
 511          Curdef := No_Location;
 512          Curru  := No_Unit;
 513          Crloc  := No_Location;
 514
 515          for Refno in 1 .. Nrefs loop
 516
 517             Output_One_Ref : declare
 518
 519                XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
 520                --  The current entry to be accessed
 521
 522                P : Source_Ptr;
 523                --  Used to index into source buffer to get entity name
 524
 525                P2  : Source_Ptr;
 526                WC  : Char_Code;
 527                Err : Boolean;
 528                Ent : Entity_Id;
 529                Sav : Entity_Id;
 530
 531                Left  : Character;
 532                Right : Character;
 533                --  Used for {} or <> for type reference
 534
 535                procedure Output_Instantiation_Refs (Loc : Source_Ptr);
 536                --  Recursive procedure to output instantiation references for
 537                --  the given source ptr in [file|line[...]] form. No output
 538                --  if the given location is not a generic template reference.
 539
 540                -------------------------------
 541                -- Output_Instantiation_Refs --
 542                -------------------------------
 543
 544                procedure Output_Instantiation_Refs (Loc : Source_Ptr) is
 545                   Iloc : constant Source_Ptr := Instantiation_Location (Loc);
 546                   Lun  : Unit_Number_Type;
 547
 548                begin
 549                   --  Nothing to do if this is not an instantiation
 550
 551                   if Iloc = No_Location then
 552                      return;
 553                   end if;
 554
 555                   --  Output instantiation reference
 556
 557                   Write_Info_Char ('[');
 558                   Lun := Get_Source_Unit (Iloc);
 559
 560                   if Lun /= Curru then
 561                      Curru := XE.Lun;
 562                      Write_Info_Nat (Dependency_Num (Curru));
 563                      Write_Info_Char ('|');
 564                   end if;
 565
 566                   Write_Info_Nat (Int (Get_Logical_Line_Number (Iloc)));
 567
 568                   --  Recursive call to get nested instantiations
 569
 570                   Output_Instantiation_Refs (Iloc);
 571
 572                   --  Output final ] after call to get proper nesting
 573
 574                   Write_Info_Char (']');
 575                   return;
 576                end Output_Instantiation_Refs;
 577
 578             --  Start of processing for Output_One_Ref
 579
 580             begin
 581                Ent := XE.Ent;
 582                Ctyp := Xref_Entity_Letters (Ekind (Ent));
 583
 584                --  Skip reference if it is the only reference to an entity,
 585                --  and it is an end-line reference, and the entity is not in
 586                --  the current extended source. This prevents junk entries
 587                --  consisting only of packages with end lines, where no
 588                --  entity from the package is actually referenced.
 589
 590                if XE.Typ = 'e'
 591                  and then Ent /= Curent
 592                  and then (Refno = Nrefs or else
 593                              Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent)
 594                  and then
 595                    not In_Extended_Main_Source_Unit (Ent)
 596                then
 597                   goto Continue;
 598                end if;
 599
 600                --  For private type, get full view type
 601
 602                if Ctyp = '+'
 603                  and then Present (Full_View (XE.Ent))
 604                then
 605                   Ent := Underlying_Type (Ent);
 606
 607                   if Present (Ent) then
 608                      Ctyp := Xref_Entity_Letters (Ekind (Ent));
 609                   end if;
 610                end if;
 611
 612                --  Special exception for Boolean
 613
 614                if Ctyp = 'E' and then Is_Boolean_Type (Ent) then
 615                   Ctyp := 'B';
 616                end if;
 617
 618                --  For variable reference, get corresponding type
 619
 620                if Ctyp = '*' then
 621                   Ent := Etype (XE.Ent);
 622                   Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
 623
 624                   --  If variable is private type, get full view type
 625
 626                   if Ctyp = '+'
 627                     and then Present (Full_View (Etype (XE.Ent)))
 628                   then
 629                      Ent := Underlying_Type (Etype (XE.Ent));
 630
 631                      if Present (Ent) then
 632                         Ctyp := Xref_Entity_Letters (Ekind (Ent));
 633                      end if;
 634                   end if;
 635
 636                   --  Special handling for access parameter
 637
 638                   if Ekind (Etype (XE.Ent)) = E_Anonymous_Access_Type
 639                     and then Is_Formal (XE.Ent)
 640                   then
 641                      Ctyp := 'p';
 642
 643                   --  Special handling for Boolean
 644
 645                   elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
 646                      Ctyp := 'b';
 647                   end if;
 648                end if;
 649
 650                --  Only output reference if interesting type of entity,
 651                --  and suppress self references. Also suppress definitions
 652                --  of body formals (we only treat these as references, and
 653                --  the references were separately recorded).
 654
 655                if Ctyp /= ' '
 656                  and then XE.Loc /= XE.Def
 657                  and then (not Is_Formal (XE.Ent)
 658                             or else No (Spec_Entity (XE.Ent)))
 659                then
 660                   --  Start new Xref section if new xref unit
 661
 662                   if XE.Eun /= Curxu then
 663
 664                      if Write_Info_Col > 1 then
 665                         Write_Info_EOL;
 666                      end if;
 667
 668                      Curxu := XE.Eun;
 669                      Cursrc := Source_Text (Source_Index (Curxu));
 670
 671                      Write_Info_Initiate ('X');
 672                      Write_Info_Char (' ');
 673                      Write_Info_Nat (Dependency_Num (XE.Eun));
 674                      Write_Info_Char (' ');
 675                      Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
 676                   end if;
 677
 678                   --  Start new Entity line if new entity. Note that we
 679                   --  consider two entities the same if they have the same
 680                   --  name and source location. This causes entities in
 681                   --  instantiations to be treated as though they referred
 682                   --  to the template.
 683
 684                   if No (Curent)
 685                     or else
 686                       (XE.Ent /= Curent
 687                          and then
 688                            (Name_Change (XE.Ent) or else XE.Def /= Curdef))
 689                   then
 690                      Curent := XE.Ent;
 691                      Curdef := XE.Def;
 692
 693                      Get_Unqualified_Name_String (Chars (XE.Ent));
 694                      Curlen := Name_Len;
 695                      Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
 696
 697                      if Write_Info_Col > 1 then
 698                         Write_Info_EOL;
 699                      end if;
 700
 701                      --  Write column number information
 702
 703                      Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def)));
 704                      Write_Info_Char (Ctyp);
 705                      Write_Info_Nat (Int (Get_Column_Number (XE.Def)));
 706
 707                      --  Write level information
 708
 709                      if Is_Public (Curent) and then not Is_Hidden (Curent) then
 710                         Write_Info_Char ('*');
 711                      else
 712                         Write_Info_Char (' ');
 713                      end if;
 714
 715                      --  Output entity name. We use the occurrence from the
 716                      --  actual source program at the definition point
 717
 718                      P := Original_Location (Sloc (XE.Ent));
 719
 720                      --  Entity is character literal
 721
 722                      if Cursrc (P) = ''' then
 723                         Write_Info_Char (Cursrc (P));
 724                         Write_Info_Char (Cursrc (P + 1));
 725                         Write_Info_Char (Cursrc (P + 2));
 726
 727                      --  Entity is operator symbol
 728
 729                      elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
 730                         Write_Info_Char (Cursrc (P));
 731
 732                         P2 := P;
 733                         loop
 734                            P2 := P2 + 1;
 735                            Write_Info_Char (Cursrc (P2));
 736                            exit when Cursrc (P2) = Cursrc (P);
 737                         end loop;
 738
 739                      --  Entity is identifier
 740
 741                      else
 742                         loop
 743                            if Is_Start_Of_Wide_Char (Cursrc, P) then
 744                               Scan_Wide (Cursrc, P, WC, Err);
 745                            elsif not Identifier_Char (Cursrc (P)) then
 746                               exit;
 747                            else
 748                               P := P + 1;
 749                            end if;
 750                         end loop;
 751
 752                         for J in
 753                           Original_Location (Sloc (XE.Ent)) .. P - 1
 754                         loop
 755                            Write_Info_Char (Cursrc (J));
 756                         end loop;
 757                      end if;
 758
 759                      --  See if we have a renaming reference
 760
 761                      if Is_Object (XE.Ent)
 762                        and then Present (Renamed_Object (XE.Ent))
 763                      then
 764                         Rref := Renamed_Object (XE.Ent);
 765
 766                      elsif Is_Overloadable (XE.Ent)
 767                        and then Nkind (Parent (Declaration_Node (XE.Ent))) =
 768                                             N_Subprogram_Renaming_Declaration
 769                      then
 770                         Rref := Name (Parent (Declaration_Node (XE.Ent)));
 771
 772                      elsif Ekind (XE.Ent) = E_Package
 773                        and then Nkind (Declaration_Node (XE.Ent)) =
 774                                          N_Package_Renaming_Declaration
 775                      then
 776                         Rref := Name (Declaration_Node (XE.Ent));
 777
 778                      else
 779                         Rref := Empty;
 780                      end if;
 781
 782                      if Present (Rref) then
 783                         if Nkind (Rref) = N_Expanded_Name then
 784                            Rref := Selector_Name (Rref);
 785                         end if;
 786
 787                         if Nkind (Rref) /= N_Identifier then
 788                            Rref := Empty;
 789                         end if;
 790                      end if;
 791
 792                      --  Write out renaming reference if we have one
 793
 794                      if Present (Rref) then
 795                         Write_Info_Char ('=');
 796                         Write_Info_Nat
 797                           (Int (Get_Logical_Line_Number (Sloc (Rref))));
 798                         Write_Info_Char (':');
 799                         Write_Info_Nat
 800                           (Int (Get_Column_Number (Sloc (Rref))));
 801                      end if;
 802
 803                      --  See if we have a type reference
 804
 805                      Tref := XE.Ent;
 806                      Left := '{';
 807                      Right := '}';
 808
 809                      loop
 810                         Sav := Tref;
 811
 812                         --  Processing for types
 813
 814                         if Is_Type (Tref) then
 815
 816                            --  Case of base type
 817
 818                            if Base_Type (Tref) = Tref then
 819
 820                               --  If derived, then get first subtype
 821
 822                               if Tref /= Etype (Tref) then
 823                                  Tref := First_Subtype (Etype (Tref));
 824
 825                                  --  Set brackets for derived type, but don't
 826                                  --  override pointer case since the fact that
 827                                  --  something is a pointer is more important
 828
 829                                  if Left /= '(' then
 830                                     Left := '<';
 831                                     Right := '>';
 832                                  end if;
 833
 834                               --  If non-derived ptr, get designated type
 835
 836                               elsif Is_Access_Type (Tref) then
 837                                  Tref := Designated_Type (Tref);
 838                                  Left := '(';
 839                                  Right := ')';
 840
 841                               --  For other non-derived base types, nothing
 842
 843                               else
 844                                  exit;
 845                               end if;
 846
 847                            --  For a subtype, go to ancestor subtype
 848
 849                            else
 850                               Tref := Ancestor_Subtype (Tref);
 851
 852                               --  If no ancestor subtype, go to base type
 853
 854                               if No (Tref) then
 855                                  Tref := Base_Type (Sav);
 856                               end if;
 857                            end if;
 858
 859                         --  For objects, functions, enum literals,
 860                         --  just get type from Etype field.
 861
 862                         elsif Is_Object (Tref)
 863                           or else Ekind (Tref) = E_Enumeration_Literal
 864                           or else Ekind (Tref) = E_Function
 865                           or else Ekind (Tref) = E_Operator
 866                         then
 867                            Tref := Etype (Tref);
 868
 869                         --  For anything else, exit
 870
 871                         else
 872                            exit;
 873                         end if;
 874
 875                         --  Exit if no type reference, or we are stuck in
 876                         --  some loop trying to find the type reference, or
 877                         --  if the type is standard void type (the latter is
 878                         --  an implementation artifact that should not show
 879                         --  up in the generated cross-references).
 880
 881                         exit when No (Tref)
 882                           or else Tref = Sav
 883                           or else Tref = Standard_Void_Type;
 884
 885                         --  Here we have a type reference to output
 886
 887                         --  Case of standard entity, output name
 888
 889                         if Sloc (Tref) = Standard_Location then
 890                            Write_Info_Char (Left);
 891                            Write_Info_Name (Chars (Tref));
 892                            Write_Info_Char (Right);
 893                            exit;
 894
 895                         --  Case of source entity, output location
 896
 897                         elsif Comes_From_Source (Tref) then
 898
 899                            --  Do not output type reference if referenced
 900                            --  entity is not in the main unit and is itself
 901                            --  not referenced, since otherwise the reference
 902                            --  will dangle.
 903
 904                            exit when not Referenced (Tref)
 905                              and then not In_Extended_Main_Source_Unit (Tref);
 906
 907                            --  Output the reference
 908
 909                            Write_Info_Char (Left);
 910                            Trunit := Get_Source_Unit (Sloc (Tref));
 911
 912                            if Trunit /= Curxu then
 913                               Write_Info_Nat (Dependency_Num (Trunit));
 914                               Write_Info_Char ('|');
 915                            end if;
 916
 917                            Write_Info_Nat
 918                              (Int (Get_Logical_Line_Number (Sloc (Tref))));
 919
 920                            declare
 921                               Ent  : Entity_Id := Tref;
 922                               Kind : constant Entity_Kind := Ekind (Ent);
 923                               Ctyp : Character := Xref_Entity_Letters (Kind);
 924
 925                            begin
 926                               if Ctyp = '+'
 927                                 and then Present (Full_View (Ent))
 928                               then
 929                                  Ent := Underlying_Type (Ent);
 930
 931                                  if Present (Ent) then
 932                                     Ctyp := Xref_Entity_Letters (Ekind (Ent));
 933                                  end if;
 934                               end if;
 935
 936                               Write_Info_Char (Ctyp);
 937                            end;
 938
 939                            Write_Info_Nat
 940                              (Int (Get_Column_Number (Sloc (Tref))));
 941                            Write_Info_Char (Right);
 942                            exit;
 943
 944                         --  If non-standard, non-source entity, keep looking
 945
 946                         else
 947                            null;
 948                         end if;
 949                      end loop;
 950
 951                      --  End of processing for entity output
 952
 953                      Curru := Curxu;
 954                      Crloc := No_Location;
 955                   end if;
 956
 957                   --  Output the reference
 958
 959                   if XE.Loc /= No_Location
 960                      and then XE.Loc /= Crloc
 961                   then
 962                      Crloc := XE.Loc;
 963
 964                      --  Start continuation if line full, else blank
 965
 966                      if Write_Info_Col > 72 then
 967                         Write_Info_EOL;
 968                         Write_Info_Initiate ('.');
 969                      end if;
 970
 971                      Write_Info_Char (' ');
 972
 973                      --  Output file number if changed
 974
 975                      if XE.Lun /= Curru then
 976                         Curru := XE.Lun;
 977                         Write_Info_Nat (Dependency_Num (Curru));
 978                         Write_Info_Char ('|');
 979                      end if;
 980
 981                      Write_Info_Nat  (Int (Get_Logical_Line_Number (XE.Loc)));
 982                      Write_Info_Char (XE.Typ);
 983                      Write_Info_Nat  (Int (Get_Column_Number (XE.Loc)));
 984
 985                      Output_Instantiation_Refs (Sloc (XE.Ent));
 986                   end if;
 987                end if;
 988             end Output_One_Ref;
 989
 990          <<Continue>>
 991             null;
 992          end loop;
 993
 994          Write_Info_EOL;
 995       end Output_Refs;
 996    end Output_References;
 997
 998 end Lib.Xref;