Subversion Repositories openrisc_2011-10-31

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

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

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1998-2009, 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 Lib.Util; use Lib.Util;

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

with GNAT.Heap_Sort_G;

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

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

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

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

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

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

         Xrefs.Increment_Last;

         Indx := Xrefs.Last;

         Loc  := Original_Location (Sloc (E));

         Xrefs.Table (Indx).Ent := E;

         Xrefs.Table (Indx).Def := No_Location;

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

         Xrefs.Table (Indx).Typ := ' ';

         Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);

         Xrefs.Table (Indx).Lun := No_Unit;

         Set_Has_Xref_Entry (E);

         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;

      Ent       : Entity_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.

      if Is_Concurrent_Type (Base_T)

        and then Present (Corresponding_Record_Type (Base_T))

      then

         Prim_List := Primitive_Operations

                       (Corresponding_Record_Type (Base_T));

      else

         Prim_List := Primitive_Operations (Base_T);

      end if;

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

         Ent := Node (Prim);

         while Present (Alias (Ent)) loop

            Ent := Alias (Ent);

         end loop;

         Generate_Reference (Typ, Ent, '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

      Indx : Nat;

      Nod  : Node_Id;

      Ref  : Source_Ptr;

      Def  : Source_Ptr;

      Ent  : Entity_Id;

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

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

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

            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 do not generate warnings within the extended source

      --  unit of the entity in question, 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)

      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_05

        and then Warn_On_Ada_2005_Compatibility

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

      then

         Error_Msg_NE ("& is only defined in Ada 2005?", 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 = '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).

            elsif Is_Subprogram (E)

              and then E = Nearest_Dynamic_Scope (Current_Scope)

            then

               null;

            --  Any other occurrence counts as referencing the entity

            elsif OK_To_Set_Referenced then

               Set_Referenced (E);

               --  If variable, this is an OK reference after an assignment

               --  so we can clear the Last_Assignment indication.

               if Is_Assignable (E) then

                  Set_Last_Assignment (E, Empty);

               end if;

            end if;

         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 Is_On_LHS (N) then

               null;

            --  For entry formals, we want to place the warning message 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, except for default

         --  subprograms, for which we generate an implicit reference.

         and then

           (Instantiation_Location (Sloc (N)) = No_Location or else Typ = 'i')

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