path: root/gcc/ada/lib-xref.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             L I B . X R E F                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1998-2004, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Csets;    use Csets;
with Elists;   use Elists;
with Errout;   use Errout;
with Lib.Util; use Lib.Util;
with Namet;    use Namet;
with Nlists;   use Nlists;
with Opt;      use Opt;
with Restrict; use Restrict;
with Rident;   use Rident;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Sinput;   use Sinput;
with Snames;   use Snames;
with Stringt;  use Stringt;
with Stand;    use Stand;
with Table;    use Table;
with Widechar; use Widechar;

with GNAT.Heap_Sort_A;

package body Lib.Xref is

   ------------------
   -- Declarations --
   ------------------

   --  The Xref table is used to record references. The Loc field is set
   --  to No_Location for a definition entry.

   subtype Xref_Entry_Number is Int;

   type Xref_Entry is record
      Ent : Entity_Id;
      --  Entity referenced (E parameter to Generate_Reference)

      Def : Source_Ptr;
      --  Original source location for entity being referenced. Note that
      --  these values are used only during the output process, they are
      --  not set when the entries are originally built. This is because
      --  private entities can be swapped when the initial call is made.

      Loc : Source_Ptr;
      --  Location of reference (Original_Location (Sloc field of N parameter
      --  to Generate_Reference). Set to No_Location for the case of a
      --  defining occurrence.

      Typ : Character;
      --  Reference type (Typ param to Generate_Reference)

      Eun : Unit_Number_Type;
      --  Unit number corresponding to Ent

      Lun : Unit_Number_Type;
      --  Unit number corresponding to Loc. Value is undefined and not
      --  referenced if Loc is set to No_Location.

   end record;

   package Xrefs is new Table.Table (
     Table_Component_Type => Xref_Entry,
     Table_Index_Type     => Xref_Entry_Number,
     Table_Low_Bound      => 1,
     Table_Initial        => Alloc.Xrefs_Initial,
     Table_Increment      => Alloc.Xrefs_Increment,
     Table_Name           => "Xrefs");

   -------------------------
   -- Generate_Definition --
   -------------------------

   procedure Generate_Definition (E : Entity_Id) is
      Loc  : Source_Ptr;
      Indx : Nat;

   begin
      pragma Assert (Nkind (E) in N_Entity);

      --  Note that we do not test Xref_Entity_Letters here. It is too
      --  early to do so, since we are often called before the entity
      --  is fully constructed, so that the Ekind is still E_Void.

      if Opt.Xref_Active

         --  Definition must come from source

         and then Comes_From_Source (E)

         --  And must have a reasonable source location that is not
         --  within an instance (all entities in instances are ignored)

         and then Sloc (E) > No_Location
         and then Instantiation_Location (Sloc (E)) = No_Location

         --  And must be a non-internal name from the main source unit

         and then In_Extended_Main_Source_Unit (E)
         and then not Is_Internal_Name (Chars (E))
      then
         Xrefs.Increment_Last;
         Indx := Xrefs.Last;
         Loc  := Original_Location (Sloc (E));

         Xrefs.Table (Indx).Ent := E;
         Xrefs.Table (Indx).Loc := No_Location;
         Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
         Xrefs.Table (Indx).Lun := No_Unit;
         Set_Has_Xref_Entry (E);
      end if;
   end Generate_Definition;

   ---------------------------------
   -- Generate_Operator_Reference --
   ---------------------------------

   procedure Generate_Operator_Reference
     (N : Node_Id;
      T : Entity_Id)
   is
   begin
      if not In_Extended_Main_Source_Unit (N) then
         return;
      end if;

      --  If the operator is not a Standard operator, then we generate
      --  a real reference to the user defined operator.

      if Sloc (Entity (N)) /= Standard_Location then
         Generate_Reference (Entity (N), N);

         --  A reference to an implicit inequality operator is a also a
         --  reference to the user-defined equality.

         if Nkind (N) = N_Op_Ne
           and then not Comes_From_Source (Entity (N))
           and then Present (Corresponding_Equality (Entity (N)))
         then
            Generate_Reference (Corresponding_Equality (Entity (N)), N);
         end if;

      --  For the case of Standard operators, we mark the result type
      --  as referenced. This ensures that in the case where we are
      --  using a derived operator, we mark an entity of the unit that
      --  implicitly defines this operator as used. Otherwise we may
      --  think that no entity of the unit is used. The actual entity
      --  marked as referenced is the first subtype, which is the user
      --  defined entity that is relevant.

      --  Note: we only do this for operators that come from source.
      --  The generated code sometimes reaches for entities that do
      --  not need to be explicitly visible (for example, when we
      --  expand the code for comparing two record types, the fields
      --  of the record may not be visible).

      elsif Comes_From_Source (N) then
         Set_Referenced (First_Subtype (T));
      end if;
   end Generate_Operator_Reference;

   ------------------------
   -- Generate_Reference --
   ------------------------

   procedure Generate_Reference
     (E       : Entity_Id;
      N       : Node_Id;
      Typ     : Character := 'r';
      Set_Ref : Boolean   := True;
      Force   : Boolean   := False)
   is
      Indx : Nat;
      Nod  : Node_Id;
      Ref  : Source_Ptr;
      Def  : Source_Ptr;
      Ent  : Entity_Id;

      function Is_On_LHS (Node : Node_Id) return Boolean;
      --  Used to check if a node is on the left hand side of an
      --  assignment. The following cases are handled:
      --
      --   Variable  Node is a direct descendant of an assignment
      --             statement.
      --
      --   Prefix    Of an indexed or selected component that is
      --             present in a subtree rooted by an assignment
      --             statement. There is no restriction of nesting
      --             of components, thus cases such as A.B(C).D are
      --             handled properly.

      ---------------
      -- Is_On_LHS --
      ---------------

      --  Couldn't we use Is_Lvalue or whatever it is called ???

      function Is_On_LHS (Node : Node_Id) return Boolean is
         N : Node_Id := Node;

      begin
         --  Only identifiers are considered, is this necessary???

         if Nkind (N) /= N_Identifier then
            return False;
         end if;

         --  Reach the assignment statement subtree root. In the
         --  case of a variable being a direct descendant of an
         --  assignment statement, the loop is skiped.

         while Nkind (Parent (N)) /= N_Assignment_Statement loop

            --  Check whether the parent is a component and the
            --  current node is its prefix.

            if (Nkind (Parent (N)) = N_Selected_Component
                  or else
                Nkind (Parent (N)) = N_Indexed_Component)
              and then Prefix (Parent (N)) = N
            then
               N := Parent (N);
            else
               return False;
            end if;
         end loop;

         --  Parent (N) is an assignment statement, check whether
         --  N is its name.

         return Name (Parent (N)) = N;
      end Is_On_LHS;

   --  Start of processing for Generate_Reference

   begin
      pragma Assert (Nkind (E) in N_Entity);

      if E = Standard_ASCII then
         Check_Restriction (No_Obsolescent_Features, N);
      end if;

      --  Never collect references if not in main source unit. However,
      --  we omit this test if Typ is 'e' or 'k', since these entries are
      --  really structural, and it is useful to have them in units
      --  that reference packages as well as units that define packages.
      --  We also omit the test for the case of 'p' since we want to
      --  include inherited primitive operations from other packages.

      if not In_Extended_Main_Source_Unit (N)
        and then Typ /= 'e'
        and then Typ /= 'p'
        and then Typ /= 'k'
      then
         return;
      end if;

      --  For reference type p, the entity must be in main source unit

      if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then
         return;
      end if;

      --  Unless the reference is forced, we ignore references where
      --  the reference itself does not come from Source.

      if not Force and then not Comes_From_Source (N) then
         return;
      end if;

      --  Deal with setting entity as referenced, unless suppressed.
      --  Note that we still do Set_Referenced on entities that do not
      --  come from source. This situation arises when we have a source
      --  reference to a derived operation, where the derived operation
      --  itself does not come from source, but we still want to mark it
      --  as referenced, since we really are referencing an entity in the
      --  corresponding package (this avoids incorrect complaints that the
      --  package contains no referenced entities).

      if Set_Ref then

         --  For a variable that appears on the left side of an
         --  assignment statement, we set the Referenced_As_LHS
         --  flag since this is indeed a left hand side.
         --  We also set the Referenced_As_LHS flag of a prefix
         --  of selected or indexed component.

         if Ekind (E) = E_Variable
           and then Is_On_LHS (N)
         then
            Set_Referenced_As_LHS (E);

         --  Check for a reference in a pragma that should not count as a
         --  making the variable referenced for warning purposes.

         elsif Is_Non_Significant_Pragma_Reference (N) then
            null;

         --  A reference in an attribute definition clause does not
         --  count as a reference except for the case of Address.
         --  The reason that 'Address is an exception is that it
         --  creates an alias through which the variable may be
         --  referenced.

         elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause
           and then Chars (Parent (N)) /= Name_Address
           and then N = Name (Parent (N))
         then
            null;

         --  Constant completion does not count as a reference

         elsif Typ = 'c'
           and then Ekind (E) = E_Constant
         then
            null;

         --  Record representation clause does not count as a reference

         elsif Nkind (N) = N_Identifier
           and then Nkind (Parent (N)) = N_Record_Representation_Clause
         then
            null;

         --  Discriminants do not need to produce a reference to record type

         elsif Typ = 'd'
           and then Nkind (Parent (N)) = N_Discriminant_Specification
         then
            null;

         --  Any other occurrence counts as referencing the entity

         else
            Set_Referenced (E);
         end if;

         --  Check for pragma Unreferenced given and reference is within
         --  this source unit (occasion for possible warning to be issued)

         if Has_Pragma_Unreferenced (E)
           and then In_Same_Extended_Unit (E, N)
         then
            --  A reference as a named parameter in a call does not count
            --  as a violation of pragma Unreferenced for this purpose.

            if Nkind (N) = N_Identifier
              and then Nkind (Parent (N)) = N_Parameter_Association
              and then Selector_Name (Parent (N)) = N
            then
               null;

            --  Neither does a reference to a variable on the left side
            --  of an assignment

            elsif Ekind (E) = E_Variable
              and then Nkind (Parent (N)) = N_Assignment_Statement
              and then Name (Parent (N)) = N
            then
               null;

            --  For entry formals, we want to place the warning on the
            --  corresponding entity in the accept statement. The current
            --  scope is the body of the accept, so we find the formal
            --  whose name matches that of the entry formal (there is no
            --  link between the two entities, and the one in the accept
            --  statement is only used for conformance checking).

            elsif Ekind (Scope (E)) = E_Entry then
               declare
                  BE : Entity_Id;

               begin
                  BE := First_Entity (Current_Scope);
                  while Present (BE) loop
                     if Chars (BE) = Chars (E) then
                        Error_Msg_NE
                          ("?pragma Unreferenced given for&", N, BE);
                        exit;
                     end if;

                     Next_Entity (BE);
                  end loop;
               end;

            --  Here we issue the warning, since this is a real reference

            else
               Error_Msg_NE ("?pragma Unreferenced given for&", N, E);
            end if;
         end if;

         --  If this is a subprogram instance, mark as well the internal
         --  subprogram in the wrapper package, which may be a visible
         --  compilation unit.

         if Is_Overloadable (E)
           and then Is_Generic_Instance (E)
           and then Present (Alias (E))
         then
            Set_Referenced (Alias (E));
         end if;
      end if;

      --  Generate reference if all conditions are met:

      if
         --  Cross referencing must be active

         Opt.Xref_Active

         --  The entity must be one for which we collect references

         and then Xref_Entity_Letters (Ekind (E)) /= ' '

         --  Both Sloc values must be set to something sensible

         and then Sloc (E) > No_Location
         and then Sloc (N) > No_Location

         --  We ignore references from within an instance

         and then Instantiation_Location (Sloc (N)) = No_Location

         --  Ignore dummy references

        and then Typ /= ' '
      then
         if Nkind (N) = N_Identifier
              or else
            Nkind (N) = N_Defining_Identifier
              or else
            Nkind (N) in N_Op
              or else
            Nkind (N) = N_Defining_Operator_Symbol
              or else
            Nkind (N) = N_Operator_Symbol
              or else
            (Nkind (N) = N_Character_Literal
              and then Sloc (Entity (N)) /= Standard_Location)
              or else
            Nkind (N) = N_Defining_Character_Literal
         then
            Nod := N;

         elsif Nkind (N) = N_Expanded_Name
                 or else
               Nkind (N) = N_Selected_Component
         then
            Nod := Selector_Name (N);

         else
            return;
         end if;

         --  Normal case of source entity comes from source

         if Comes_From_Source (E) then
            Ent := E;

         --  Entity does not come from source, but is a derived subprogram
         --  and the derived subprogram comes from source (after one or more
         --  derivations) in which case the reference is to parent subprogram.

         elsif Is_Overloadable (E)
           and then Present (Alias (E))
         then
            Ent := Alias (E);

            loop
               if Comes_From_Source (Ent) then
                  exit;
               elsif No (Alias (Ent)) then
                  return;
               else
                  Ent := Alias (Ent);
               end if;
            end loop;

         --  Record components of discriminated subtypes or derived types
         --  must be treated as references to the original component.

         elsif Ekind (E) = E_Component
           and then Comes_From_Source (Original_Record_Component (E))
         then
            Ent := Original_Record_Component (E);

         --  Ignore reference to any other entity that is not from source

         else
            return;
         end if;

         --  Record reference to entity

         Ref := Original_Location (Sloc (Nod));
         Def := Original_Location (Sloc (Ent));

         Xrefs.Increment_Last;
         Indx := Xrefs.Last;

         Xrefs.Table (Indx).Loc := Ref;

         --  Overriding operations are marked with 'P'.

         if Typ = 'p'
           and then Is_Subprogram (N)
           and then Is_Overriding_Operation (N)
         then
            Xrefs.Table (Indx).Typ := 'P';
         else
            Xrefs.Table (Indx).Typ := Typ;
         end if;

         Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
         Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
         Xrefs.Table (Indx).Ent := Ent;
         Set_Has_Xref_Entry (Ent);
      end if;
   end Generate_Reference;

   -----------------------------------
   -- Generate_Reference_To_Formals --
   -----------------------------------

   procedure Generate_Reference_To_Formals (E : Entity_Id) is
      Formal : Entity_Id;

   begin
      if Is_Generic_Subprogram (E) then
         Formal := First_Entity (E);

         while Present (Formal)
           and then not Is_Formal (Formal)
         loop
            Next_Entity (Formal);
         end loop;

      else
         Formal := First_Formal (E);
      end if;

      while Present (Formal) loop
         if Ekind (Formal) = E_In_Parameter then

            if Nkind (Parameter_Type (Parent (Formal)))
              = N_Access_Definition
            then
               Generate_Reference (E, Formal, '^', False);
            else
               Generate_Reference (E, Formal, '>', False);
            end if;

         elsif Ekind (Formal) = E_In_Out_Parameter then
            Generate_Reference (E, Formal, '=', False);

         else
            Generate_Reference (E, Formal, '<', False);
         end if;

         Next_Formal (Formal);
      end loop;
   end Generate_Reference_To_Formals;

   -------------------------------------------
   -- Generate_Reference_To_Generic_Formals --
   -------------------------------------------

   procedure Generate_Reference_To_Generic_Formals (E : Entity_Id) is
      Formal : Entity_Id;

   begin
      Formal := First_Entity (E);

      while Present (Formal) loop
         if Comes_From_Source (Formal) then
            Generate_Reference (E, Formal, 'z', False);
         end if;

         Next_Entity (Formal);
      end loop;
   end Generate_Reference_To_Generic_Formals;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      Xrefs.Init;
   end Initialize;

   -----------------------
   -- Output_References --
   -----------------------

   procedure Output_References is

      procedure Get_Type_Reference
        (Ent   : Entity_Id;
         Tref  : out Entity_Id;
         Left  : out Character;
         Right : out Character);
      --  Given an entity id Ent, determines whether a type reference is
      --  required. If so, Tref is set to the entity for the type reference
      --  and Left and Right are set to the left/right brackets to be
      --  output for the reference. If no type reference is required, then
      --  Tref is set to Empty, and Left/Right are set to space.

      procedure Output_Import_Export_Info (Ent : Entity_Id);
      --  Ouput language and external name information for an interfaced
      --  entity, using the format <language, external_name>,

      ------------------------
      -- Get_Type_Reference --
      ------------------------

      procedure Get_Type_Reference
        (Ent   : Entity_Id;
         Tref  : out Entity_Id;
         Left  : out Character;
         Right : out Character)
      is
         Sav : Entity_Id;

      begin
         --  See if we have a type reference

         Tref := Ent;
         Left := '{';
         Right := '}';

         loop
            Sav := Tref;

            --  Processing for types

            if Is_Type (Tref) then

               --  Case of base type

               if Base_Type (Tref) = Tref then

                  --  If derived, then get first subtype

                  if Tref /= Etype (Tref) then
                     Tref := First_Subtype (Etype (Tref));

                     --  Set brackets for derived type, but don't
                     --  override pointer case since the fact that
                     --  something is a pointer is more important

                     if Left /= '(' then
                        Left := '<';
                        Right := '>';
                     end if;

                  --  If non-derived ptr, get directly designated type.
                  --  If the type has a full view, all references are
                  --  on the partial view, that is seen first.

                  elsif Is_Access_Type (Tref) then
                     Tref := Directly_Designated_Type (Tref);
                     Left := '(';
                     Right := ')';

                  elsif Is_Private_Type (Tref)
                    and then Present (Full_View (Tref))
                    and then Is_Access_Type (Full_View (Tref))
                  then
                     Tref := Directly_Designated_Type (Full_View (Tref));
                     Left := '(';
                     Right := ')';

                  --  If non-derived array, get component type.
                  --  Skip component type for case of String
                  --  or Wide_String, saves worthwhile space.

                  elsif Is_Array_Type (Tref)
                    and then Tref /= Standard_String
                    and then Tref /= Standard_Wide_String
                  then
                     Tref := Component_Type (Tref);
                     Left := '(';
                     Right := ')';

                  --  For other non-derived base types, nothing

                  else
                     exit;
                  end if;

               --  For a subtype, go to ancestor subtype.

               else
                  Tref := Ancestor_Subtype (Tref);

                  --  If no ancestor subtype, go to base type

                  if No (Tref) then
                     Tref := Base_Type (Sav);
                  end if;
               end if;

            --  For objects, functions, enum literals,
            --  just get type from Etype field.

            elsif Is_Object (Tref)
              or else Ekind (Tref) = E_Enumeration_Literal
              or else Ekind (Tref) = E_Function
              or else Ekind (Tref) = E_Operator
            then
               Tref := Etype (Tref);

            --  For anything else, exit

            else
               exit;
            end if;

            --  Exit if no type reference, or we are stuck in
            --  some loop trying to find the type reference, or
            --  if the type is standard void type (the latter is
            --  an implementation artifact that should not show
            --  up in the generated cross-references).

            exit when No (Tref)
              or else Tref = Sav
              or else Tref = Standard_Void_Type;

            --  If we have a usable type reference, return, otherwise
            --  keep looking for something useful (we are looking for
            --  something that either comes from source or standard)

            if Sloc (Tref) = Standard_Location
              or else Comes_From_Source (Tref)
            then
               --  If the reference is a subtype created for a generic
               --  actual, go to actual directly, the inner subtype is
               --  not user visible.

               if Nkind (Parent (Tref)) = N_Subtype_Declaration
                 and then not Comes_From_Source (Parent (Tref))
                 and then
                  (Is_Wrapper_Package (Scope (Tref))
                     or else Is_Generic_Instance (Scope (Tref)))
               then
                  Tref := Base_Type (Tref);
               end if;

               return;
            end if;
         end loop;

         --  If we fall through the loop, no type reference

         Tref := Empty;
         Left := ' ';
         Right := ' ';
      end Get_Type_Reference;

      -------------------------------
      -- Output_Import_Export_Info --
      -------------------------------

      procedure Output_Import_Export_Info (Ent : Entity_Id) is
         Language_Name : Name_Id;
         Conv          : constant Convention_Id := Convention (Ent);
      begin
         if Conv  = Convention_C then
            Language_Name := Name_C;

         elsif Conv = Convention_CPP then
            Language_Name := Name_CPP;

         elsif Conv = Convention_Ada then
            Language_Name := Name_Ada;

         else
            --  These are the only languages that GPS knows about.

            return;
         end if;

         Write_Info_Char ('<');
         Get_Unqualified_Name_String (Language_Name);

         for J in 1 .. Name_Len loop
            Write_Info_Char (Name_Buffer (J));
         end loop;

         if Present (Interface_Name (Ent)) then
            Write_Info_Char (',');
            String_To_Name_Buffer (Strval (Interface_Name (Ent)));

            for J in 1 .. Name_Len loop
               Write_Info_Char (Name_Buffer (J));
            end loop;
         end if;

         Write_Info_Char ('>');
      end Output_Import_Export_Info;

   --  Start of processing for Output_References

   begin
      if not Opt.Xref_Active then
         return;
      end if;

      --  Before we go ahead and output the references we have a problem
      --  that needs dealing with. So far we have captured things that are
      --  definitely referenced by the main unit, or defined in the main
      --  unit. That's because we don't want to clutter up the ali file
      --  for this unit with definition lines for entities in other units
      --  that are not referenced.

      --  But there is a glitch. We may reference an entity in another unit,
      --  and it may have a type reference to an entity that is not directly
      --  referenced in the main unit, which may mean that there is no xref
      --  entry for this entity yet in the list of references.

      --  If we don't do something about this, we will end with an orphan
      --  type reference, i.e. it will point to an entity that does not
      --  appear within the generated references in the ali file. That is
      --  not good for tools using the xref information.

      --  To fix this, we go through the references adding definition
      --  entries for any unreferenced entities that can be referenced
      --  in a type reference. There is a recursion problem here, and
      --  that is dealt with by making sure that this traversal also
      --  traverses any entries that get added by the traversal.

      declare
         J    : Nat;
         Tref : Entity_Id;
         L, R : Character;
         Indx : Nat;
         Ent  : Entity_Id;
         Loc  : Source_Ptr;

      begin
         --  Note that this is not a for loop for a very good reason. The
         --  processing of items in the table can add new items to the
         --  table, and they must be processed as well

         J := 1;
         while J <= Xrefs.Last loop
            Ent := Xrefs.Table (J).Ent;
            Get_Type_Reference (Ent, Tref, L, R);

            if Present (Tref)
              and then not Has_Xref_Entry (Tref)
              and then Sloc (Tref) > No_Location
            then
               Xrefs.Increment_Last;
               Indx := Xrefs.Last;
               Loc  := Original_Location (Sloc (Tref));
               Xrefs.Table (Indx).Ent := Tref;
               Xrefs.Table (Indx).Loc := No_Location;
               Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
               Xrefs.Table (Indx).Lun := No_Unit;
               Set_Has_Xref_Entry (Tref);
            end if;

            --  Collect inherited primitive operations that may be
            --  declared in another unit and have no visible reference
            --  in the current one.

            if Is_Type (Ent)
              and then Is_Tagged_Type (Ent)
              and then Is_Derived_Type (Ent)
              and then Ent = Base_Type (Ent)
              and then In_Extended_Main_Source_Unit (Ent)
            then
               declare
                  Op_List : constant Elist_Id := Primitive_Operations (Ent);
                  Op      : Elmt_Id;
                  Prim    : Entity_Id;

                  function Parent_Op (E : Entity_Id) return Entity_Id;
                  --  Find original operation, which may be inherited
                  --  through several derivations.

                  function Parent_Op (E : Entity_Id) return Entity_Id is
                     Orig_Op : constant Entity_Id := Alias (E);
                  begin
                     if No (Orig_Op) then
                        return Empty;
                     elsif not Comes_From_Source (E)
                       and then not Has_Xref_Entry (Orig_Op)
                       and then Comes_From_Source (Orig_Op)
                     then
                        return Orig_Op;
                     else
                        return Parent_Op (Orig_Op);
                     end if;
                  end Parent_Op;

               begin
                  Op := First_Elmt (Op_List);
                  while Present (Op) loop
                     Prim := Parent_Op (Node (Op));

                     if Present (Prim) then
                        Xrefs.Increment_Last;
                        Indx := Xrefs.Last;
                        Loc  := Original_Location (Sloc (Prim));
                        Xrefs.Table (Indx).Ent := Prim;
                        Xrefs.Table (Indx).Loc := No_Location;
                        Xrefs.Table (Indx).Eun :=
                          Get_Source_Unit (Sloc (Prim));
                        Xrefs.Table (Indx).Lun := No_Unit;
                        Set_Has_Xref_Entry (Prim);
                     end if;

                     Next_Elmt (Op);
                  end loop;
               end;
            end if;

            J := J + 1;
         end loop;
      end;

      --  Now we have all the references, including those for any embedded
      --  type references, so we can sort them, and output them.

      Output_Refs : declare

         Nrefs : Nat := Xrefs.Last;
         --  Number of references in table. This value may get reset
         --  (reduced) when we eliminate duplicate reference entries.

         Rnums : array (0 .. Nrefs) of Nat;
         --  This array contains numbers of references in the Xrefs table.
         --  This list is sorted in output order. The extra 0'th entry is
         --  convenient for the call to sort. When we sort the table, we
         --  move the entries in Rnums around, but we do not move the
         --  original table entries.

         Curxu : Unit_Number_Type;
         --  Current xref unit

         Curru : Unit_Number_Type;
         --  Current reference unit for one entity

         Cursrc : Source_Buffer_Ptr;
         --  Current xref unit source text

         Curent : Entity_Id;
         --  Current entity

         Curnam : String (1 .. Name_Buffer'Length);
         Curlen : Natural;
         --  Simple name and length of current entity

         Curdef : Source_Ptr;
         --  Original source location for current entity

         Crloc : Source_Ptr;
         --  Current reference location

         Ctyp : Character;
         --  Entity type character

         Tref : Entity_Id;
         --  Type reference

         Rref : Node_Id;
         --  Renaming reference

         Trunit : Unit_Number_Type;
         --  Unit number for type reference

         function Lt (Op1, Op2 : Natural) return Boolean;
         --  Comparison function for Sort call

         function Name_Change (X : Entity_Id) return Boolean;
         --  Determines if entity X has a different simple name from Curent

         procedure Move (From : Natural; To : Natural);
         --  Move procedure for Sort call

         --------
         -- Lt --
         --------

         function Lt (Op1, Op2 : Natural) return Boolean is
            T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
            T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));

         begin
            --  First test. If entity is in different unit, sort by unit

            if T1.Eun /= T2.Eun then
               return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);

            --  Second test, within same unit, sort by entity Sloc

            elsif T1.Def /= T2.Def then
               return T1.Def < T2.Def;

            --  Third test, sort definitions ahead of references

            elsif T1.Loc = No_Location then
               return True;

            elsif T2.Loc = No_Location then
               return False;

            --  Fourth test, for same entity, sort by reference location unit

            elsif T1.Lun /= T2.Lun then
               return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);

            --  Fifth test order of location within referencing unit

            elsif T1.Loc /= T2.Loc then
               return T1.Loc < T2.Loc;

            --  Finally, for two locations at the same address, we prefer
            --  the one that does NOT have the type 'r' so that a modification
            --  or extension takes preference, when there are more than one
            --  reference at the same location.

            else
               return T2.Typ = 'r';
            end if;
         end Lt;

         ----------
         -- Move --
         ----------

         procedure Move (From : Natural; To : Natural) is
         begin
            Rnums (Nat (To)) := Rnums (Nat (From));
         end Move;

         -----------------
         -- Name_Change --
         -----------------

         function Name_Change (X : Entity_Id) return Boolean is
         begin
            Get_Unqualified_Name_String (Chars (X));

            if Name_Len /= Curlen then
               return True;

            else
               return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
            end if;
         end Name_Change;

      --  Start of processing for Output_Refs

      begin
         --  Capture the definition Sloc values. We delay doing this till now,
         --  since at the time the reference or definition is made, private
         --  types may be swapped, and the Sloc value may be incorrect. We
         --  also set up the pointer vector for the sort.

         for J in 1 .. Nrefs loop
            Rnums (J) := J;
            Xrefs.Table (J).Def :=
              Original_Location (Sloc (Xrefs.Table (J).Ent));
         end loop;

         --  Sort the references

         GNAT.Heap_Sort_A.Sort
           (Integer (Nrefs),
            Move'Unrestricted_Access,
            Lt'Unrestricted_Access);

         --  Eliminate duplicate entries

         declare
            NR : constant Nat := Nrefs;

         begin
            --  We need this test for NR because if we force ALI file
            --  generation in case of errors detected, it may be the case
            --  that Nrefs is 0, so we should not reset it here

            if NR >= 2 then
               Nrefs := 1;

               for J in 2 .. NR loop
                  if Xrefs.Table (Rnums (J)) /=
                     Xrefs.Table (Rnums (Nrefs))
                  then
                     Nrefs := Nrefs + 1;
                     Rnums (Nrefs) := Rnums (J);
                  end if;
               end loop;
            end if;
         end;

         --  Initialize loop through references

         Curxu  := No_Unit;
         Curent := Empty;
         Curdef := No_Location;
         Curru  := No_Unit;
         Crloc  := No_Location;

         --  Loop to output references

         for Refno in 1 .. Nrefs loop
            Output_One_Ref : declare
               P2  : Source_Ptr;
               WC  : Char_Code;
               Err : Boolean;
               Ent : Entity_Id;

               XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
               --  The current entry to be accessed

               P : Source_Ptr;
               --  Used to index into source buffer to get entity name

               Left  : Character;
               Right : Character;
               --  Used for {} or <> or () for type reference

               procedure Output_Instantiation_Refs (Loc : Source_Ptr);
               --  Recursive procedure to output instantiation references for
               --  the given source ptr in [file|line[...]] form. No output
               --  if the given location is not a generic template reference.

               -------------------------------
               -- Output_Instantiation_Refs --
               -------------------------------

               procedure Output_Instantiation_Refs (Loc : Source_Ptr) is
                  Iloc : constant Source_Ptr := Instantiation_Location (Loc);
                  Lun  : Unit_Number_Type;
                  Cu   : constant Unit_Number_Type := Curru;

               begin
                  --  Nothing to do if this is not an instantiation

                  if Iloc = No_Location then
                     return;
                  end if;

                  --  Output instantiation reference

                  Write_Info_Char ('[');
                  Lun := Get_Source_Unit (Iloc);

                  if Lun /= Curru then
                     Curru := Lun;
                     Write_Info_Nat (Dependency_Num (Curru));
                     Write_Info_Char ('|');
                  end if;

                  Write_Info_Nat (Int (Get_Logical_Line_Number (Iloc)));

                  --  Recursive call to get nested instantiations

                  Output_Instantiation_Refs (Iloc);

                  --  Output final ] after call to get proper nesting

                  Write_Info_Char (']');
                  Curru := Cu;
                  return;
               end Output_Instantiation_Refs;

            --  Start of processing for Output_One_Ref

            begin
               Ent := XE.Ent;
               Ctyp := Xref_Entity_Letters (Ekind (Ent));

               --  Skip reference if it is the only reference to an entity,
               --  and it is an end-line reference, and the entity is not in
               --  the current extended source. This prevents junk entries
               --  consisting only of packages with end lines, where no
               --  entity from the package is actually referenced.

               if XE.Typ = 'e'
                 and then Ent /= Curent
                 and then (Refno = Nrefs or else
                             Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent)
                 and then
                   not In_Extended_Main_Source_Unit (Ent)
               then
                  goto Continue;
               end if;

               --  For private type, get full view type

               if Ctyp = '+'
                 and then Present (Full_View (XE.Ent))
               then
                  Ent := Underlying_Type (Ent);

                  if Present (Ent) then
                     Ctyp := Xref_Entity_Letters (Ekind (Ent));
                  end if;
               end if;

               --  Special exception for Boolean

               if Ctyp = 'E' and then Is_Boolean_Type (Ent) then
                  Ctyp := 'B';
               end if;

               --  For variable reference, get corresponding type

               if Ctyp = '*' then
                  Ent := Etype (XE.Ent);
                  Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));

                  --  If variable is private type, get full view type

                  if Ctyp = '+'
                    and then Present (Full_View (Etype (XE.Ent)))
                  then
                     Ent := Underlying_Type (Etype (XE.Ent));

                     if Present (Ent) then
                        Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
                     end if;
                  end if;

                  --  Special handling for access parameter

                  declare
                     K : constant Entity_Kind := Ekind (Etype (XE.Ent));

                  begin
                     if (K = E_Anonymous_Access_Type
                           or else
                         K = E_Anonymous_Access_Subprogram_Type
                            or else K =
                         E_Anonymous_Access_Protected_Subprogram_Type)
                       and then Is_Formal (XE.Ent)
                     then
                        Ctyp := 'p';

                        --  Special handling for Boolean

                     elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
                        Ctyp := 'b';
                     end if;
                  end;
               end if;

               --  Special handling for abstract types and operations.

               if Is_Abstract (XE.Ent) then

                  if Ctyp = 'U' then
                     Ctyp := 'x';            --  abstract procedure

                  elsif Ctyp = 'V' then
                     Ctyp := 'y';            --  abstract function

                  elsif Ctyp = 'R' then
                     Ctyp := 'H';            --  abstract type
                  end if;
               end if;

               --  Only output reference if interesting type of entity,
               --  and suppress self references, except for bodies that
               --  act as specs. Also suppress definitions of body formals
               --  (we only treat these as references, and the references
               --  were separately recorded).

               if Ctyp = ' '
                 or else (XE.Loc = XE.Def
                            and then
                              (XE.Typ /= 'b'
                                or else not Is_Subprogram (XE.Ent)))
                 or else (Is_Formal (XE.Ent)
                            and then Present (Spec_Entity (XE.Ent)))
               then
                  null;

               else
                  --  Start new Xref section if new xref unit

                  if XE.Eun /= Curxu then
                     if Write_Info_Col > 1 then
                        Write_Info_EOL;
                     end if;

                     Curxu := XE.Eun;
                     Cursrc := Source_Text (Source_Index (Curxu));

                     Write_Info_Initiate ('X');
                     Write_Info_Char (' ');
                     Write_Info_Nat (Dependency_Num (XE.Eun));
                     Write_Info_Char (' ');
                     Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
                  end if;

                  --  Start new Entity line if new entity. Note that we
                  --  consider two entities the same if they have the same
                  --  name and source location. This causes entities in
                  --  instantiations to be treated as though they referred
                  --  to the template.

                  if No (Curent)
                    or else
                      (XE.Ent /= Curent
                         and then
                           (Name_Change (XE.Ent) or else XE.Def /= Curdef))
                  then
                     Curent := XE.Ent;
                     Curdef := XE.Def;

                     Get_Unqualified_Name_String (Chars (XE.Ent));
                     Curlen := Name_Len;
                     Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);

                     if Write_Info_Col > 1 then
                        Write_Info_EOL;
                     end if;

                     --  Write column number information

                     Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def)));
                     Write_Info_Char (Ctyp);
                     Write_Info_Nat (Int (Get_Column_Number (XE.Def)));

                     --  Write level information

                     Write_Level_Info : declare
                        function Is_Visible_Generic_Entity
                          (E : Entity_Id) return Boolean;
                        --  Check whether E is declared in the visible part
                        --  of a generic package. For source navigation
                        --  purposes, treat this as a visible entity.

                        function Is_Private_Record_Component
                          (E : Entity_Id) return Boolean;
                        --  Check whether E is a non-inherited component of a
                        --  private extension. Even if the enclosing record is
                        --  public, we want to treat the component as private
                        --  for navigation purposes.

                        ---------------------------------
                        -- Is_Private_Record_Component --
                        ---------------------------------

                        function Is_Private_Record_Component
                          (E : Entity_Id) return Boolean
                        is
                           S : constant Entity_Id := Scope (E);
                        begin
                           return
                             Ekind (E) = E_Component
                               and then Nkind (Declaration_Node (S)) =
                                 N_Private_Extension_Declaration
                               and then Original_Record_Component (E) = E;
                        end Is_Private_Record_Component;

                        -------------------------------
                        -- Is_Visible_Generic_Entity --
                        -------------------------------

                        function Is_Visible_Generic_Entity
                          (E : Entity_Id) return Boolean
                        is
                           Par : Node_Id;

                        begin
                           if Ekind (Scope (E)) /= E_Generic_Package then
                              return False;
                           end if;

                           Par := Parent (E);
                           while Present (Par) loop
                              if
                                Nkind (Par) = N_Generic_Package_Declaration
                              then
                                 --  Entity is a generic formal

                                 return False;

                              elsif
                                Nkind (Parent (Par)) = N_Package_Specification
                              then
                                 return
                                   Is_List_Member (Par)
                                     and then List_Containing (Par) =
                                       Visible_Declarations (Parent (Par));
                              else
                                 Par := Parent (Par);
                              end if;
                           end loop;

                           return False;
                        end Is_Visible_Generic_Entity;

                     --  Start of processing for Write_Level_Info

                     begin
                        if Is_Hidden (Curent)
                          or else Is_Private_Record_Component (Curent)
                        then
                           Write_Info_Char (' ');

                        elsif
                           Is_Public (Curent)
                             or else Is_Visible_Generic_Entity (Curent)
                        then
                           Write_Info_Char ('*');

                        else
                           Write_Info_Char (' ');
                        end if;
                     end Write_Level_Info;

                     --  Output entity name. We use the occurrence from the
                     --  actual source program at the definition point

                     P := Original_Location (Sloc (XE.Ent));

                     --  Entity is character literal

                     if Cursrc (P) = ''' then
                        Write_Info_Char (Cursrc (P));
                        Write_Info_Char (Cursrc (P + 1));
                        Write_Info_Char (Cursrc (P + 2));

                     --  Entity is operator symbol

                     elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
                        Write_Info_Char (Cursrc (P));

                        P2 := P;
                        loop
                           P2 := P2 + 1;
                           Write_Info_Char (Cursrc (P2));
                           exit when Cursrc (P2) = Cursrc (P);
                        end loop;

                     --  Entity is identifier

                     else
                        loop
                           if Is_Start_Of_Wide_Char (Cursrc, P) then
                              Scan_Wide (Cursrc, P, WC, Err);
                           elsif not Identifier_Char (Cursrc (P)) then
                              exit;
                           else
                              P := P + 1;
                           end if;
                        end loop;

                        for J in
                          Original_Location (Sloc (XE.Ent)) .. P - 1
                        loop
                           Write_Info_Char (Cursrc (J));
                        end loop;
                     end if;

                     --  See if we have a renaming reference

                     if Is_Object (XE.Ent)
                       and then Present (Renamed_Object (XE.Ent))
                     then
                        Rref := Renamed_Object (XE.Ent);

                     elsif Is_Overloadable (XE.Ent)
                       and then Nkind (Parent (Declaration_Node (XE.Ent))) =
                                            N_Subprogram_Renaming_Declaration
                     then
                        Rref := Name (Parent (Declaration_Node (XE.Ent)));

                     elsif Ekind (XE.Ent) = E_Package
                       and then Nkind (Declaration_Node (XE.Ent)) =
                                         N_Package_Renaming_Declaration
                     then
                        Rref := Name (Declaration_Node (XE.Ent));

                     else
                        Rref := Empty;
                     end if;

                     if Present (Rref) then
                        if Nkind (Rref) = N_Expanded_Name then
                           Rref := Selector_Name (Rref);
                        end if;

                        if Nkind (Rref) /= N_Identifier then
                           Rref := Empty;
                        end if;
                     end if;

                     --  Write out renaming reference if we have one

                     if Present (Rref) then
                        Write_Info_Char ('=');
                        Write_Info_Nat
                          (Int (Get_Logical_Line_Number (Sloc (Rref))));
                        Write_Info_Char (':');
                        Write_Info_Nat
                          (Int (Get_Column_Number (Sloc (Rref))));
                     end if;

                     --  Indicate that the entity is in the unit
                     --  of the current xref xection.

                     Curru := Curxu;

                     --  See if we have a type reference and if so output

                     Get_Type_Reference (XE.Ent, Tref, Left, Right);

                     if Present (Tref) then

                        --  Case of standard entity, output name

                        if Sloc (Tref) = Standard_Location then
                           Write_Info_Char (Left);
                           Write_Info_Name (Chars (Tref));
                           Write_Info_Char (Right);

                        --  Case of source entity, output location

                        else
                           Write_Info_Char (Left);
                           Trunit := Get_Source_Unit (Sloc (Tref));

                           if Trunit /= Curxu then
                              Write_Info_Nat (Dependency_Num (Trunit));
                              Write_Info_Char ('|');
                           end if;

                           Write_Info_Nat
                             (Int (Get_Logical_Line_Number (Sloc (Tref))));

                           declare
                              Ent  : Entity_Id := Tref;
                              Kind : constant Entity_Kind := Ekind (Ent);
                              Ctyp : Character := Xref_Entity_Letters (Kind);

                           begin
                              if Ctyp = '+'
                                and then Present (Full_View (Ent))
                              then
                                 Ent := Underlying_Type (Ent);

                                 if Present (Ent) then
                                    Ctyp := Xref_Entity_Letters (Ekind (Ent));
                                 end if;
                              end if;

                              Write_Info_Char (Ctyp);
                           end;

                           Write_Info_Nat
                             (Int (Get_Column_Number (Sloc (Tref))));

                           --  If the type comes from an instantiation,
                           --  add the corresponding info.

                           Output_Instantiation_Refs (Sloc (Tref));
                           Write_Info_Char (Right);
                        end if;
                     end if;

                     --  End of processing for entity output

                     Crloc := No_Location;
                  end if;

                  --  Output the reference

                  if XE.Loc /= No_Location
                     and then XE.Loc /= Crloc
                  then
                     Crloc := XE.Loc;

                     --  Start continuation if line full, else blank

                     if Write_Info_Col > 72 then
                        Write_Info_EOL;
                        Write_Info_Initiate ('.');
                     end if;

                     Write_Info_Char (' ');

                     --  Output file number if changed

                     if XE.Lun /= Curru then
                        Curru := XE.Lun;
                        Write_Info_Nat (Dependency_Num (Curru));
                        Write_Info_Char ('|');
                     end if;

                     Write_Info_Nat  (Int (Get_Logical_Line_Number (XE.Loc)));
                     Write_Info_Char (XE.Typ);

                     if Is_Overloadable (XE.Ent)
                       and then Is_Imported (XE.Ent)
                       and then XE.Typ = 'b'
                     then
                        Output_Import_Export_Info (XE.Ent);
                     end if;

                     Write_Info_Nat  (Int (Get_Column_Number (XE.Loc)));

                     Output_Instantiation_Refs (Sloc (XE.Ent));
                  end if;
               end if;
            end Output_One_Ref;

         <<Continue>>
            null;
         end loop;

         Write_Info_EOL;
      end Output_Refs;
   end Output_References;

end Lib.Xref;