Subversion Repositories openrisc_2011-10-31

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             S E M _ T Y P E                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-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 Alloc;

with Debug;    use Debug;

with Einfo;    use Einfo;

with Elists;   use Elists;

with Nlists;   use Nlists;

with Errout;   use Errout;

with Lib;      use Lib;

with Namet;    use Namet;

with Opt;      use Opt;

with Output;   use Output;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Ch6;  use Sem_Ch6;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Ch12; use Sem_Ch12;

with Sem_Disp; use Sem_Disp;

with Sem_Dist; use Sem_Dist;

with Sem_Util; use Sem_Util;

with Stand;    use Stand;

with Sinfo;    use Sinfo;

with Snames;   use Snames;

with Table;

with Uintp;    use Uintp;

package body Sem_Type is

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

   -- Data Structures --

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

   --  The following data structures establish a mapping between nodes and

   --  their interpretations. An overloaded node has an entry in Interp_Map,

   --  which in turn contains a pointer into the All_Interp array. The

   --  interpretations of a given node are contiguous in All_Interp. Each set

   --  of interpretations is terminated with the marker No_Interp. In order to

   --  speed up the retrieval of the interpretations of an overloaded node, the

   --  Interp_Map table is accessed by means of a simple hashing scheme, and

   --  the entries in Interp_Map are chained. The heads of clash lists are

   --  stored in array Headers.

   --              Headers        Interp_Map          All_Interp

   --                 _            +-----+             +--------+

   --                |_|           |_____|         --->|interp1 |

   --                |_|---------->|node |         |   |interp2 |

   --                |_|           |index|---------|   |nointerp|

   --                |_|           |next |             |        |

   --                              |-----|             |        |

   --                              +-----+             +--------+

   --  This scheme does not currently reclaim interpretations. In principle,

   --  after a unit is compiled, all overloadings have been resolved, and the

   --  candidate interpretations should be deleted. This should be easier

   --  now than with the previous scheme???

   package All_Interp is new Table.Table (

     Table_Component_Type => Interp,

     Table_Index_Type     => Int,

     Table_Low_Bound      => 0,

     Table_Initial        => Alloc.All_Interp_Initial,

     Table_Increment      => Alloc.All_Interp_Increment,

     Table_Name           => "All_Interp");

   type Interp_Ref is record

      Node  : Node_Id;

      Index : Interp_Index;

      Next  : Int;

   end record;

   Header_Size : constant Int := 2 ** 12;

   No_Entry    : constant Int := -1;

   Headers     : array (0 .. Header_Size) of Int := (others => No_Entry);

   package Interp_Map is new Table.Table (

     Table_Component_Type => Interp_Ref,

     Table_Index_Type     => Int,

     Table_Low_Bound      => 0,

     Table_Initial        => Alloc.Interp_Map_Initial,

     Table_Increment      => Alloc.Interp_Map_Increment,

     Table_Name           => "Interp_Map");

   function Hash (N : Node_Id) return Int;

   --  A trivial hashing function for nodes, used to insert an overloaded

   --  node into the Interp_Map table.

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

   -- Handling of Overload Resolution --

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

   --  Overload resolution uses two passes over the syntax tree of a complete

   --  context. In the first, bottom-up pass, the types of actuals in calls

   --  are used to resolve possibly overloaded subprogram and operator names.

   --  In the second top-down pass, the type of the context (for example the

   --  condition in a while statement) is used to resolve a possibly ambiguous

   --  call, and the unique subprogram name in turn imposes a specific context

   --  on each of its actuals.

   --  Most expressions are in fact unambiguous, and the bottom-up pass is

   --  sufficient  to resolve most everything. To simplify the common case,

   --  names and expressions carry a flag Is_Overloaded to indicate whether

   --  they have more than one interpretation. If the flag is off, then each

   --  name has already a unique meaning and type, and the bottom-up pass is

   --  sufficient (and much simpler).

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

   -- Operator Overloading --

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

   --  The visibility of operators is handled differently from that of other

   --  entities. We do not introduce explicit versions of primitive operators

   --  for each type definition. As a result, there is only one entity

   --  corresponding to predefined addition on all numeric types, etc. The

   --  back-end resolves predefined operators according to their type. The

   --  visibility of primitive operations then reduces to the visibility of the

   --  resulting type: (a + b) is a legal interpretation of some primitive

   --  operator + if the type of the result (which must also be the type of a

   --  and b) is directly visible (either immediately visible or use-visible).

   --  User-defined operators are treated like other functions, but the

   --  visibility of these user-defined operations must be special-cased

   --  to determine whether they hide or are hidden by predefined operators.

   --  The form P."+" (x, y) requires additional handling.

   --  Concatenation is treated more conventionally: for every one-dimensional

   --  array type we introduce a explicit concatenation operator. This is

   --  necessary to handle the case of (element & element => array) which

   --  cannot be handled conveniently if there is no explicit instance of

   --  resulting type of the operation.

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

   -- Local Subprograms --

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

   procedure All_Overloads;

   pragma Warnings (Off, All_Overloads);

   --  Debugging procedure: list full contents of Overloads table

   function Binary_Op_Interp_Has_Abstract_Op

     (N : Node_Id;

      E : Entity_Id) return Entity_Id;

   --  Given the node and entity of a binary operator, determine whether the

   --  actuals of E contain an abstract interpretation with regards to the

   --  types of their corresponding formals. Return the abstract operation or

   --  Empty.

   function Function_Interp_Has_Abstract_Op

     (N : Node_Id;

      E : Entity_Id) return Entity_Id;

   --  Given the node and entity of a function call, determine whether the

   --  actuals of E contain an abstract interpretation with regards to the

   --  types of their corresponding formals. Return the abstract operation or

   --  Empty.

   function Has_Abstract_Op

     (N   : Node_Id;

      Typ : Entity_Id) return Entity_Id;

   --  Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_

   --  Interp_Has_Abstract_Op. Determine whether an overloaded node has an

   --  abstract interpretation which yields type Typ.

   procedure New_Interps (N : Node_Id);

   --  Initialize collection of interpretations for the given node, which is

   --  either an overloaded entity, or an operation whose arguments have

   --  multiple interpretations. Interpretations can be added to only one

   --  node at a time.

   function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id;

   --  If Typ_1 and Typ_2 are compatible, return the one that is not universal

   --  or is not a "class" type (any_character, etc).

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

   -- Add_One_Interp --

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

   procedure Add_One_Interp

     (N         : Node_Id;

      E         : Entity_Id;

      T         : Entity_Id;

      Opnd_Type : Entity_Id := Empty)

   is

      Vis_Type : Entity_Id;

      procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);

      --  Add one interpretation to an overloaded node. Add a new entry if

      --  not hidden by previous one, and remove previous one if hidden by

      --  new one.

      function Is_Universal_Operation (Op : Entity_Id) return Boolean;

      --  True if the entity is a predefined operator and the operands have

      --  a universal Interpretation.

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

      -- Add_Entry --

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

      procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is

         Abstr_Op : Entity_Id := Empty;

         I        : Interp_Index;

         It       : Interp;

      --  Start of processing for Add_Entry

      begin

         --  Find out whether the new entry references interpretations that

         --  are abstract or disabled by abstract operators.

         if Ada_Version >= Ada_05 then

            if Nkind (N) in N_Binary_Op then

               Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name);

            elsif Nkind (N) = N_Function_Call then

               Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name);

            end if;

         end if;

         Get_First_Interp (N, I, It);

         while Present (It.Nam) loop

            --  A user-defined subprogram hides another declared at an outer

            --  level, or one that is use-visible. So return if previous

            --  definition hides new one (which is either in an outer

            --  scope, or use-visible). Note that for functions use-visible

            --  is the same as potentially use-visible. If new one hides

            --  previous one, replace entry in table of interpretations.

            --  If this is a universal operation, retain the operator in case

            --  preference rule applies.

            if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)

                 and then Ekind (Name) = Ekind (It.Nam))

                or else (Ekind (Name) = E_Operator

              and then Ekind (It.Nam) = E_Function))

              and then Is_Immediately_Visible (It.Nam)

              and then Type_Conformant (Name, It.Nam)

              and then Base_Type (It.Typ) = Base_Type (T)

            then

               if Is_Universal_Operation (Name) then

                  exit;

               --  If node is an operator symbol, we have no actuals with

               --  which to check hiding, and this is done in full in the

               --  caller (Analyze_Subprogram_Renaming) so we include the

               --  predefined operator in any case.

               elsif Nkind (N) = N_Operator_Symbol

                 or else (Nkind (N) = N_Expanded_Name

                            and then

                          Nkind (Selector_Name (N)) = N_Operator_Symbol)

               then

                  exit;

               elsif not In_Open_Scopes (Scope (Name))

                 or else Scope_Depth (Scope (Name)) <=

                         Scope_Depth (Scope (It.Nam))

               then

                  --  If ambiguity within instance, and entity is not an

                  --  implicit operation, save for later disambiguation.

                  if Scope (Name) = Scope (It.Nam)

                    and then not Is_Inherited_Operation (Name)

                    and then In_Instance

                  then

                     exit;

                  else

                     return;

                  end if;

               else

                  All_Interp.Table (I).Nam := Name;

                  return;

               end if;

            --  Avoid making duplicate entries in overloads

            elsif Name = It.Nam

              and then Base_Type (It.Typ) = Base_Type (T)

            then

               return;

            --  Otherwise keep going

            else

               Get_Next_Interp (I, It);

            end if;

         end loop;

         All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op);

         All_Interp.Append (No_Interp);

      end Add_Entry;

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

      -- Is_Universal_Operation --

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

      function Is_Universal_Operation (Op : Entity_Id) return Boolean is

         Arg : Node_Id;

      begin

         if Ekind (Op) /= E_Operator then

            return False;

         elsif Nkind (N) in N_Binary_Op then

            return Present (Universal_Interpretation (Left_Opnd (N)))

              and then Present (Universal_Interpretation (Right_Opnd (N)));

         elsif Nkind (N) in N_Unary_Op then

            return Present (Universal_Interpretation (Right_Opnd (N)));

         elsif Nkind (N) = N_Function_Call then

            Arg := First_Actual (N);

            while Present (Arg) loop

               if No (Universal_Interpretation (Arg)) then

                  return False;

               end if;

               Next_Actual (Arg);

            end loop;

            return True;

         else

            return False;

         end if;

      end Is_Universal_Operation;

   --  Start of processing for Add_One_Interp

   begin

      --  If the interpretation is a predefined operator, verify that the

      --  result type is visible, or that the entity has already been

      --  resolved (case of an instantiation node that refers to a predefined

      --  operation, or an internally generated operator node, or an operator

      --  given as an expanded name). If the operator is a comparison or

      --  equality, it is the type of the operand that matters to determine

      --  whether the operator is visible. In an instance, the check is not

      --  performed, given that the operator was visible in the generic.

      if Ekind (E) = E_Operator then

         if Present (Opnd_Type) then

            Vis_Type := Opnd_Type;

         else

            Vis_Type := Base_Type (T);

         end if;

         if In_Open_Scopes (Scope (Vis_Type))

           or else Is_Potentially_Use_Visible (Vis_Type)

           or else In_Use (Vis_Type)

           or else (In_Use (Scope (Vis_Type))

                      and then not Is_Hidden (Vis_Type))

           or else Nkind (N) = N_Expanded_Name

           or else (Nkind (N) in N_Op and then E = Entity (N))

           or else In_Instance

           or else Ekind (Vis_Type) = E_Anonymous_Access_Type

         then

            null;

         --  If the node is given in functional notation and the prefix

         --  is an expanded name, then the operator is visible if the

         --  prefix is the scope of the result type as well. If the

         --  operator is (implicitly) defined in an extension of system,

         --  it is know to be valid (see Defined_In_Scope, sem_ch4.adb).

         elsif Nkind (N) = N_Function_Call

           and then Nkind (Name (N)) = N_Expanded_Name

           and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))

                       or else Entity (Prefix (Name (N))) = Scope (Vis_Type)

                       or else Scope (Vis_Type) = System_Aux_Id)

         then

            null;

         --  Save type for subsequent error message, in case no other

         --  interpretation is found.

         else

            Candidate_Type := Vis_Type;

            return;

         end if;

      --  In an instance, an abstract non-dispatching operation cannot be a

      --  candidate interpretation, because it could not have been one in the

      --  generic (it may be a spurious overloading in the instance).

      elsif In_Instance

        and then Is_Overloadable (E)

        and then Is_Abstract_Subprogram (E)

        and then not Is_Dispatching_Operation (E)

      then

         return;

      --  An inherited interface operation that is implemented by some derived

      --  type does not participate in overload resolution, only the

      --  implementation operation does.

      elsif Is_Hidden (E)

        and then Is_Subprogram (E)

        and then Present (Interface_Alias (E))

      then

         --  Ada 2005 (AI-251): If this primitive operation corresponds with

         --  an immediate ancestor interface there is no need to add it to the

         --  list of interpretations. The corresponding aliased primitive is

         --  also in this list of primitive operations and will be used instead

         --  because otherwise we have a dummy ambiguity between the two

         --  subprograms which are in fact the same.

         if not Is_Ancestor

                  (Find_Dispatching_Type (Interface_Alias (E)),

                   Find_Dispatching_Type (E))

         then

            Add_One_Interp (N, Interface_Alias (E), T);

         end if;

         return;

      --  Calling stubs for an RACW operation never participate in resolution,

      --  they are executed only through dispatching calls.

      elsif Is_RACW_Stub_Type_Operation (E) then

         return;

      end if;

      --  If this is the first interpretation of N, N has type Any_Type.

      --  In that case place the new type on the node. If one interpretation

      --  already exists, indicate that the node is overloaded, and store

      --  both the previous and the new interpretation in All_Interp. If

      --  this is a later interpretation, just add it to the set.

      if Etype (N) = Any_Type then

         if Is_Type (E) then

            Set_Etype (N, T);

         else

            --  Record both the operator or subprogram name, and its type

            if Nkind (N) in N_Op or else Is_Entity_Name (N) then

               Set_Entity (N, E);

            end if;

            Set_Etype (N, T);

         end if;

      --  Either there is no current interpretation in the table for any

      --  node or the interpretation that is present is for a different

      --  node. In both cases add a new interpretation to the table.

      elsif Interp_Map.Last < 0

        or else

          (Interp_Map.Table (Interp_Map.Last).Node /= N

             and then not Is_Overloaded (N))

      then

         New_Interps (N);

         if (Nkind (N) in N_Op or else Is_Entity_Name (N))

           and then Present (Entity (N))

         then

            Add_Entry (Entity (N), Etype (N));

         elsif (Nkind (N) = N_Function_Call

                 or else Nkind (N) = N_Procedure_Call_Statement)

           and then (Nkind (Name (N)) = N_Operator_Symbol

                      or else Is_Entity_Name (Name (N)))

         then

            Add_Entry (Entity (Name (N)), Etype (N));

         --  If this is an indirect call there will be no name associated

         --  with the previous entry. To make diagnostics clearer, save

         --  Subprogram_Type of first interpretation, so that the error will

         --  point to the anonymous access to subprogram, not to the result

         --  type of the call itself.

         elsif (Nkind (N)) = N_Function_Call

           and then Nkind (Name (N)) = N_Explicit_Dereference

           and then Is_Overloaded (Name (N))

         then

            declare

               It : Interp;

               Itn : Interp_Index;

               pragma Warnings (Off, Itn);

            begin

               Get_First_Interp (Name (N), Itn, It);

               Add_Entry (It.Nam, Etype (N));

            end;

         else

            --  Overloaded prefix in indexed or selected component, or call

            --  whose name is an expression or another call.

            Add_Entry (Etype (N), Etype (N));

         end if;

         Add_Entry (E, T);

      else

         Add_Entry (E, T);

      end if;

   end Add_One_Interp;

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

   -- All_Overloads --

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

   procedure All_Overloads is

   begin

      for J in All_Interp.First .. All_Interp.Last loop

         if Present (All_Interp.Table (J).Nam) then

            Write_Entity_Info (All_Interp.Table (J). Nam, " ");

         else

            Write_Str ("No Interp");

            Write_Eol;

         end if;

         Write_Str ("=================");

         Write_Eol;

      end loop;

   end All_Overloads;

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

   -- Binary_Op_Interp_Has_Abstract_Op --

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

   function Binary_Op_Interp_Has_Abstract_Op

     (N : Node_Id;

      E : Entity_Id) return Entity_Id

   is

      Abstr_Op : Entity_Id;

      E_Left   : constant Node_Id := First_Formal (E);

      E_Right  : constant Node_Id := Next_Formal (E_Left);

   begin

      Abstr_Op := Has_Abstract_Op (Left_Opnd (N), Etype (E_Left));

      if Present (Abstr_Op) then

         return Abstr_Op;

      end if;

      return Has_Abstract_Op (Right_Opnd (N), Etype (E_Right));

   end Binary_Op_Interp_Has_Abstract_Op;

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

   -- Collect_Interps --

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

   procedure Collect_Interps (N : Node_Id) is

      Ent          : constant Entity_Id := Entity (N);

      H            : Entity_Id;

      First_Interp : Interp_Index;

   begin

      New_Interps (N);

      --  Unconditionally add the entity that was initially matched

      First_Interp := All_Interp.Last;

      Add_One_Interp (N, Ent, Etype (N));

      --  For expanded name, pick up all additional entities from the

      --  same scope, since these are obviously also visible. Note that

      --  these are not necessarily contiguous on the homonym chain.

      if Nkind (N) = N_Expanded_Name then

         H := Homonym (Ent);

         while Present (H) loop

            if Scope (H) = Scope (Entity (N)) then

               Add_One_Interp (N, H, Etype (H));

            end if;

            H := Homonym (H);

         end loop;

      --  Case of direct name

      else

         --  First, search the homonym chain for directly visible entities

         H := Current_Entity (Ent);

         while Present (H) loop

            exit when (not Is_Overloadable (H))

              and then Is_Immediately_Visible (H);

            if Is_Immediately_Visible (H)

              and then H /= Ent

            then

               --  Only add interpretation if not hidden by an inner

               --  immediately visible one.

               for J in First_Interp .. All_Interp.Last - 1 loop

                  --  Current homograph is not hidden. Add to overloads

                  if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then

                     exit;

                  --  Homograph is hidden, unless it is a predefined operator

                  elsif Type_Conformant (H, All_Interp.Table (J).Nam) then

                     --  A homograph in the same scope can occur within an

                     --  instantiation, the resulting ambiguity has to be

                     --  resolved later.

                     if Scope (H) = Scope (Ent)

                        and then In_Instance

                        and then not Is_Inherited_Operation (H)

                     then

                        All_Interp.Table (All_Interp.Last) :=

                          (H, Etype (H), Empty);

                        All_Interp.Append (No_Interp);

                        goto Next_Homograph;

                     elsif Scope (H) /= Standard_Standard then

                        goto Next_Homograph;

                     end if;

                  end if;

               end loop;

               --  On exit, we know that current homograph is not hidden

               Add_One_Interp (N, H, Etype (H));

               if Debug_Flag_E then

                  Write_Str ("Add overloaded interpretation ");

                  Write_Int (Int (H));

                  Write_Eol;

               end if;

            end if;

            <<Next_Homograph>>

               H := Homonym (H);

         end loop;

         --  Scan list of homographs for use-visible entities only

         H := Current_Entity (Ent);

         while Present (H) loop

            if Is_Potentially_Use_Visible (H)

              and then H /= Ent

              and then Is_Overloadable (H)

            then

               for J in First_Interp .. All_Interp.Last - 1 loop

                  if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then

                     exit;

                  elsif Type_Conformant (H, All_Interp.Table (J).Nam) then

                     goto Next_Use_Homograph;

                  end if;

               end loop;

               Add_One_Interp (N, H, Etype (H));

            end if;

            <<Next_Use_Homograph>>

               H := Homonym (H);

         end loop;

      end if;

      if All_Interp.Last = First_Interp + 1 then

         --  The final interpretation is in fact not overloaded. Note that the

         --  unique legal interpretation may or may not be the original one,

         --  so we need to update N's entity and etype now, because once N

         --  is marked as not overloaded it is also expected to carry the

         --  proper interpretation.

         Set_Is_Overloaded (N, False);

         Set_Entity (N, All_Interp.Table (First_Interp).Nam);

         Set_Etype  (N, All_Interp.Table (First_Interp).Typ);

      end if;

   end Collect_Interps;

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

   -- Covers --

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

   function Covers (T1, T2 : Entity_Id) return Boolean is

      BT1 : Entity_Id;

      BT2 : Entity_Id;

      function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean;

      --  In an instance the proper view may not always be correct for

      --  private types, but private and full view are compatible. This

      --  removes spurious errors from nested instantiations that involve,

      --  among other things, types derived from private types.

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

      -- Full_View_Covers --

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

      function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is

      begin

         return

           Is_Private_Type (Typ1)

             and then

              ((Present (Full_View (Typ1))

                    and then Covers (Full_View (Typ1), Typ2))

                 or else Base_Type (Typ1) = Typ2

                 or else Base_Type (Typ2) = Typ1);

      end Full_View_Covers;

   --  Start of processing for Covers

   begin

      --  If either operand missing, then this is an error, but ignore it (and

      --  pretend we have a cover) if errors already detected, since this may

      --  simply mean we have malformed trees or a semantic error upstream.

      if No (T1) or else No (T2) then

         if Total_Errors_Detected /= 0 then

            return True;

         else

            raise Program_Error;

         end if;

      else

         BT1 := Base_Type (T1);

         BT2 := Base_Type (T2);

         --  Handle underlying view of records with unknown discriminants

         --  using the original entity that motivated the construction of

         --  this underlying record view (see Build_Derived_Private_Type).

         if Is_Underlying_Record_View (BT1) then

            BT1 := Underlying_Record_View (BT1);

         end if;