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