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