Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             L I B . X R E F                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1998-2011, 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 3,  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 COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- 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 Nlists;   use Nlists;

with Opt;      use Opt;

with Restrict; use Restrict;

with Rident;   use Rident;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Prag; use Sem_Prag;

with Sem_Util; use Sem_Util;

with Sem_Warn; use Sem_Warn;

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 GNAT.Heap_Sort_G;

with GNAT.HTable;

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_Key is record

      --  These are the components of Xref_Entry that participate in hash

      --  lookups.

      Ent : Entity_Id;

      --  Entity referenced (E parameter to Generate_Reference)

      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.

      --  The following components are only used for Alfa cross-references

      Ref_Scope : Entity_Id;

      --  Entity of the closest subprogram or package enclosing the reference

      Ent_Scope : Entity_Id;

      --  Entity of the closest subprogram or package enclosing the definition,

      --  which should be located in the same file as the definition itself.

   end record;

   type Xref_Entry is record

      Key : Xref_Key;

      Ent_Scope_File : Unit_Number_Type;

      --  File for entity Ent_Scope

      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.

      HTable_Next : Xref_Entry_Number;

      --  For use only by Static_HTable

   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");

   --------------

   -- Xref_Set --

   --------------

   --  We keep a set of xref entries, in order to avoid inserting duplicate

   --  entries into the above Xrefs table. An entry is in Xref_Set if and only

   --  if it is in Xrefs.

   Num_Buckets : constant := 2**16;

   subtype Header_Num is Integer range 0 .. Num_Buckets - 1;

   type Null_Type is null record;

   pragma Unreferenced (Null_Type);

   function Hash (F : Xref_Entry_Number) return Header_Num;

   function Equal (F1, F2 : Xref_Entry_Number) return Boolean;

   procedure HT_Set_Next (E : Xref_Entry_Number; Next : Xref_Entry_Number);

   function  HT_Next (E : Xref_Entry_Number) return Xref_Entry_Number;

   function Get_Key (E : Xref_Entry_Number) return Xref_Entry_Number;

   pragma Inline (Hash, Equal, HT_Set_Next, HT_Next, Get_Key);

   package Xref_Set is new GNAT.HTable.Static_HTable (

     Header_Num,

     Element    => Xref_Entry,

     Elmt_Ptr   => Xref_Entry_Number,

     Null_Ptr   => 0,

     Set_Next   => HT_Set_Next,

     Next       => HT_Next,

     Key        => Xref_Entry_Number,

     Get_Key    => Get_Key,

     Hash       => Hash,

     Equal      => Equal);

   ----------------------

   -- Alfa Information --

   ----------------------

   package body Alfa is separate;

   ------------------------

   --  Local Subprograms --

   ------------------------

   procedure Generate_Prim_Op_References (Typ : Entity_Id);

   --  For a tagged type, generate implicit references to its primitive

   --  operations, for source navigation. This is done right before emitting

   --  cross-reference information rather than at the freeze point of the type

   --  in order to handle late bodies that are primitive operations.

   function Lt (T1, T2 : Xref_Entry) return Boolean;

   --  Order cross-references

   procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type);

   --  Add an entry to the tables of Xref_Entries, avoiding duplicates

   ---------------

   -- Add_Entry --

   ---------------

   procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type) is

   begin

      Xrefs.Increment_Last; -- tentative

      Xrefs.Table (Xrefs.Last).Key := Key;

      --  Set the entry in Xref_Set, and if newly set, keep the above

      --  tentative increment.

      if Xref_Set.Set_If_Not_Present (Xrefs.Last) then

         Xrefs.Table (Xrefs.Last).Ent_Scope_File := Ent_Scope_File;

         --  Leave Def and HTable_Next uninitialized

         Set_Has_Xref_Entry (Key.Ent);

      --  It was already in Xref_Set, so throw away the tentatively-added

      --  entry

      else

         Xrefs.Decrement_Last;

      end if;

   end Add_Entry;

   -----------

   -- Equal --

   -----------

   function Equal (F1, F2 : Xref_Entry_Number) return Boolean is

      Result : constant Boolean :=

                 Xrefs.Table (F1).Key = Xrefs.Table (F2).Key;

   begin

      return Result;

   end Equal;

   -------------------------

   -- Generate_Definition --

   -------------------------

   procedure Generate_Definition (E : Entity_Id) is

   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

         --  We make an exception for subprogram child units that have no spec.

         --  For these we generate a subprogram declaration for library use,

         --  and the corresponding entity does not come from source.

         --  Nevertheless, all references will be attached to it and we have

         --  to treat is as coming from user code.

         and then (Comes_From_Source (E) or else Is_Child_Unit (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

         Add_Entry

           ((Ent => E,

             Loc => No_Location,

             Typ => ' ',

             Eun => Get_Source_Unit (Original_Location (Sloc (E))),

             Lun => No_Unit,

             Ref_Scope => Empty,

             Ent_Scope => Empty),

            Ent_Scope_File => No_Unit);

         if In_Inlined_Body then

            Set_Referenced (E);

         end if;

      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 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 relevant user defined entity.

      --  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 objects, 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_Prim_Op_References --

   ---------------------------------

   procedure Generate_Prim_Op_References (Typ : Entity_Id) is

      Base_T    : Entity_Id;

      Prim      : Elmt_Id;

      Prim_List : Elist_Id;

   begin

      --  Handle subtypes of synchronized types

      if Ekind (Typ) = E_Protected_Subtype

        or else Ekind (Typ) = E_Task_Subtype

      then

         Base_T := Etype (Typ);

      else

         Base_T := Typ;

      end if;

      --  References to primitive operations are only relevant for tagged types

      if not Is_Tagged_Type (Base_T)

        or else Is_Class_Wide_Type (Base_T)

      then

         return;

      end if;

      --  Ada 2005 (AI-345): For synchronized types generate reference to the

      --  wrapper that allow us to dispatch calls through their implemented

      --  abstract interface types.

      --  The check for Present here is to protect against previously reported

      --  critical errors.

      Prim_List := Primitive_Operations (Base_T);

      if No (Prim_List) then

         return;

      end if;

      Prim := First_Elmt (Prim_List);

      while Present (Prim) loop

         --  If the operation is derived, get the original for cross-reference

         --  reference purposes (it is the original for which we want the xref

         --  and for which the comes_from_source test must be performed).

         Generate_Reference

           (Typ, Ultimate_Alias (Node (Prim)), 'p', Set_Ref => False);

         Next_Elmt (Prim);

      end loop;

   end Generate_Prim_Op_References;

   ------------------------

   -- Generate_Reference --

   ------------------------

   procedure Generate_Reference

     (E       : Entity_Id;

      N       : Node_Id;

      Typ     : Character := 'r';

      Set_Ref : Boolean   := True;

      Force   : Boolean   := False)

   is

      Nod : Node_Id;

      Ref : Source_Ptr;

      Def : Source_Ptr;

      Ent : Entity_Id;

      Actual_Typ : Character := Typ;

      Ref_Scope      : Entity_Id;

      Ent_Scope      : Entity_Id;

      Ent_Scope_File : Unit_Number_Type;

      Call   : Node_Id;

      Formal : Entity_Id;

      --  Used for call to Find_Actual

      Kind : Entity_Kind;

      --  If Formal is non-Empty, then its Ekind, otherwise E_Void

      function Get_Through_Renamings (E : Entity_Id) return Entity_Id;

      --  Get the enclosing entity through renamings, which may come from

      --  source or from the translation of generic instantiations.

      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 left hand side 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. However a prefix

      --               of a dereference (either implicit or explicit) is never

      --               considered as on a LHS.

      --

      --   Out param   Same as above cases, but OUT parameter

      function OK_To_Set_Referenced return Boolean;

      --  Returns True if the Referenced flag can be set. There are a few

      --  exceptions where we do not want to set this flag, see body for

      --  details of these exceptional cases.

      ---------------------------

      -- Get_Through_Renamings --

      ---------------------------

      function Get_Through_Renamings (E : Entity_Id) return Entity_Id is

         Result : Entity_Id := E;

      begin

         while Present (Result)

           and then Is_Object (Result)

           and then Present (Renamed_Object (Result))

         loop

            Result := Get_Enclosing_Object (Renamed_Object (Result));

         end loop;

         return Result;

      end Get_Through_Renamings;

      ---------------

      -- Is_On_LHS --

      ---------------

      --  ??? There are several routines here and there that perform a similar

      --      (but subtly different) computation, which should be factored:

      --      Sem_Util.May_Be_Lvalue

      --      Sem_Util.Known_To_Be_Assigned

      --      Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context

      --      Exp_Smem.Is_Out_Actual

      function Is_On_LHS (Node : Node_Id) return Boolean is

         N : Node_Id;

         P : Node_Id;

         K : Node_Kind;

      begin

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

         if Nkind (Node) /= N_Identifier then

            return False;

         end if;

         --  Immediate return if appeared as OUT parameter

         if Kind = E_Out_Parameter then

            return True;

         end if;

         --  Search for assignment statement subtree root

         N := Node;

         loop

            P := Parent (N);

            K := Nkind (P);

            if K = N_Assignment_Statement then

               return Name (P) = N;

            --  Check whether the parent is a component and the current node is

            --  its prefix, but return False if the current node has an access

            --  type, as in that case the selected or indexed component is an

            --  implicit dereference, and the LHS is the designated object, not

            --  the access object.

            --  ??? case of a slice assignment?

            --  ??? Note that in some cases this is called too early

            --  (see comments in Sem_Ch8.Find_Direct_Name), at a point where

            --  the tree is not fully typed yet. In that case we may lack

            --  an Etype for N, and we must disable the check for an implicit

            --  dereference. If the dereference is on an LHS, this causes a

            --  false positive.

            elsif (K = N_Selected_Component or else K = N_Indexed_Component)

              and then Prefix (P) = N

              and then not (Present (Etype (N))

                              and then

                            Is_Access_Type (Etype (N)))

            then

               N := P;

            --  All other cases, definitely not on left side

            else

               return False;

            end if;

         end loop;

      end Is_On_LHS;

      ---------------------------

      -- OK_To_Set_Referenced --

      ---------------------------

      function OK_To_Set_Referenced return Boolean is

         P : Node_Id;

      begin

         --  A reference from a pragma Unreferenced or pragma Unmodified or

         --  pragma Warnings does not cause the Referenced flag to be set.

         --  This avoids silly warnings about things being referenced and

         --  not assigned when the only reference is from the pragma.

         if Nkind (N) = N_Identifier then

            P := Parent (N);

            if Nkind (P) = N_Pragma_Argument_Association then

               P := Parent (P);

               if Nkind (P) = N_Pragma then

                  if Pragma_Name (P) = Name_Warnings

                       or else

                     Pragma_Name (P) = Name_Unmodified

                       or else

                     Pragma_Name (P) = Name_Unreferenced

                  then

                     return False;

                  end if;

               end if;

            --  A reference to a formal in a named parameter association does

            --  not make the formal referenced. Formals that are unused in the

            --  subprogram body are properly flagged as such, even if calls

            --  elsewhere use named notation.

            elsif Nkind (P) = N_Parameter_Association

              and then N = Selector_Name (P)

            then

               return False;

            end if;

         end if;

         return True;

      end OK_To_Set_Referenced;

   --  Start of processing for Generate_Reference

   begin

      pragma Assert (Nkind (E) in N_Entity);

      Find_Actual (N, Formal, Call);

      if Present (Formal) then

         Kind := Ekind (Formal);

      else

         Kind := E_Void;

      end if;

      --  Check for obsolescent reference to package ASCII. GNAT treats this

      --  element of annex J specially since in practice, programs make a lot

      --  of use of this feature, so we don't include it in the set of features

      --  diagnosed when Warn_On_Obsolescent_Features mode is set. However we

      --  are required to note it as a violation of the RM defined restriction.

      if E = Standard_ASCII then

         Check_Restriction (No_Obsolescent_Features, N);

      end if;

      --  Check for reference to entity marked with Is_Obsolescent

      --  Note that we always allow obsolescent references in the compiler

      --  itself and the run time, since we assume that we know what we are

      --  doing in such cases. For example the calls in Ada.Characters.Handling

      --  to its own obsolescent subprograms are just fine.

      --  In any case we only generate warnings if we are in the extended main

      --  source unit, and the entity itself is not in the extended main source

      --  unit, since we assume the source unit itself knows what is going on

      --  (and for sure we do not want silly warnings, e.g. on the end line of

      --  an obsolescent procedure body).

      if Is_Obsolescent (E)

        and then not GNAT_Mode

        and then not In_Extended_Main_Source_Unit (E)

        and then In_Extended_Main_Source_Unit (N)

      then

         Check_Restriction (No_Obsolescent_Features, N);

         if Warn_On_Obsolescent_Feature then

            Output_Obsolescent_Entity_Warnings (N, E);

         end if;

      end if;

      --  Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only

      --  detect real explicit references (modifications and references).

      if Comes_From_Source (N)

        and then Is_Ada_2005_Only (E)

        and then Ada_Version < Ada_2005

        and then Warn_On_Ada_2005_Compatibility

        and then (Typ = 'm' or else Typ = 'r' or else Typ = 's')

      then

         Error_Msg_NE ("& is only defined in Ada 2005?", N, E);

      end if;

      --  Warn if reference to Ada 2012 entity not in Ada 2012 mode. We only

      --  detect real explicit references (modifications and references).

      if Comes_From_Source (N)

        and then Is_Ada_2012_Only (E)

        and then Ada_Version < Ada_2012

        and then Warn_On_Ada_2012_Compatibility

        and then (Typ = 'm' or else Typ = 'r')

      then

         Error_Msg_NE ("& is only defined in Ada 2012?", N, E);

      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 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.

      --  We also omit this test is this is a body reference for a subprogram

      --  instantiation. In this case the reference is to the generic body,

      --  which clearly need not be in the main unit containing the instance.

      --  For the same reason we accept an implicit reference generated for

      --  a default in an instance.

      if not In_Extended_Main_Source_Unit (N) then

         if Typ = 'e'

           or else Typ = 'I'

           or else Typ = 'p'

           or else Typ = 'i'

           or else Typ = 'k'

           or else (Typ = 'b' and then Is_Generic_Instance (E))

         then

            null;

         else

            return;

         end if;

      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

      --  wrong complaints that the package contains no referenced entities).

      if Set_Ref then

         --  Assignable object appearing on left side of assignment or as

         --  an out parameter.

         if Is_Assignable (E)

           and then Is_On_LHS (N)

           and then Ekind (E) /= E_In_Out_Parameter

         then

            --  For objects that are renamings, just set as simply referenced

            --  we do not try to do assignment type tracking in this case.

            if Present (Renamed_Object (E)) then

               Set_Referenced (E);

            --  Out parameter case

            elsif Kind = E_Out_Parameter then

               --  If warning mode for all out parameters is set, or this is

               --  the only warning parameter, then we want to mark this for

               --  later warning logic by setting Referenced_As_Out_Parameter

               if Warn_On_Modified_As_Out_Parameter (Formal) then

                  Set_Referenced_As_Out_Parameter (E, True);

                  Set_Referenced_As_LHS (E, False);

               --  For OUT parameter not covered by the above cases, we simply

               --  regard it as a normal reference (in this case we do not

               --  want any of the warning machinery for out parameters).

               else

                  Set_Referenced (E);

               end if;

            --  For the left hand of an assignment case, we do nothing here.

            --  The processing for Analyze_Assignment_Statement will set the

            --  Referenced_As_LHS flag.

            else

               null;

            end if;

         --  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;

         --  All other cases

         else

            --  Special processing for IN OUT parameters, where we have an

            --  implicit assignment to a simple variable.

            if Kind = E_In_Out_Parameter

              and then Is_Assignable (E)

            then

               --  For sure this counts as a normal read reference

               Set_Referenced (E);

               Set_Last_Assignment (E, Empty);

               --  We count it as being referenced as an out parameter if the

               --  option is set to warn on all out parameters, except that we

               --  have a special exclusion for an intrinsic subprogram, which

               --  is most likely an instantiation of Unchecked_Deallocation

               --  which we do not want to consider as an assignment since it

               --  generates false positives. We also exclude the case of an

               --  IN OUT parameter if the name of the procedure is Free,

               --  since we suspect similar semantics.

               if Warn_On_All_Unread_Out_Parameters

                 and then Is_Entity_Name (Name (Call))

                 and then not Is_Intrinsic_Subprogram (Entity (Name (Call)))

                 and then Chars (Name (Call)) /= Name_Free

               then

                  Set_Referenced_As_Out_Parameter (E, True);

                  Set_Referenced_As_LHS (E, False);

               end if;

            --  Don't count a recursive reference within a subprogram as a

            --  reference (that allows detection of a recursive subprogram

            --  whose only references are recursive calls as unreferenced).