sem_dist.ads, [...] (Is_RACW_Stub_Type_Operation): New subprogram.

2008-05-20  Thomas Quinot  <quinot@adacore.com>

	* sem_dist.ads, sem_dist.adb (Is_RACW_Stub_Type_Operation): New
	subprogram.

	* sem_type.adb
	(Add_One_Interp): Ignore any interpretation that is a primitive
	operation of an RACW stub type (these primitives are only executed
	through dispatching, never through static calls).
	(Collect_Interps): When only one interpretation has been found, set N's
	Entity and Etype to that interpretation, otherwise Entity and Etype may
	still refer to an interpretation that was ignored by Add_One_Interp,
	in which case would end up with being marked as not overloaded but with
	an Entity attribute not pointing to its (unique) correct interpretation.

From-SVN: r135642

diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb
index 50cf65aff58710d4273f4637053824fd013a4283..0be68edc9f389cb99aa0219301e785c0bb3dd7b1 100644 (file)
--- a/gcc/ada/sem_dist.adb
+++ b/gcc/ada/sem_dist.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, 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- --
@@ -35,6 +35,7 @@ with Namet;    use Namet;
 with Opt;      use Opt;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
+with Sem_Disp; use Sem_Disp;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
@@ -268,12 +269,33 @@ package body Sem_Dist is
       end if;
    end Is_All_Remote_Call;
 
+   ---------------------------------
+   -- Is_RACW_Stub_Type_Operation --
+   ---------------------------------
+
+   function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is
+      Dispatching_Type : Entity_Id;
+
+   begin
+      case Ekind (Op) is
+         when E_Function | E_Procedure =>
+            Dispatching_Type := Find_Dispatching_Type (Op);
+            return Present (Dispatching_Type)
+                     and then Is_RACW_Stub_Type (Dispatching_Type)
+                     and then not Is_Internal (Op);
+
+         when others =>
+            return False;
+      end case;
+   end Is_RACW_Stub_Type_Operation;
+
    ------------------------------------
    -- Package_Specification_Of_Scope --
    ------------------------------------
 
    function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
       N : Node_Id := Parent (E);
+
    begin
       while Nkind (N) /= N_Package_Specification loop
          N := Parent (N);

diff --git a/gcc/ada/sem_dist.ads b/gcc/ada/sem_dist.ads
index 9f9b95d3e69568b0218ecb4b84ee6b592a22b55c..38a164a418fc9dc5cca8dcae6e34f82501e38034 100644 (file)
--- a/gcc/ada/sem_dist.ads
+++ b/gcc/ada/sem_dist.ads
@@ -100,4 +100,7 @@ package Sem_Dist is
    function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id;
    --  Return the N_Package_Specification corresponding to a scope E
 
+   function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean;
+   --  True when Op is a primitive operation of an RACW stub type
+
 end Sem_Dist;

diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index b118c37034a35b7165d5c3580b32bcc3c0b744e7..c36125f52aad193660a0669e31f79edfada583d2 100644 (file)
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -39,6 +39,7 @@ 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;
@@ -403,10 +404,9 @@ package body Sem_Type is
             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).
+      --  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)
@@ -415,9 +415,9 @@ package body Sem_Type is
       then
          return;
 
-      --  An inherited interface operation that is implemented by some
-      --  derived type does not participate in overload resolution, only
-      --  the implementation operation does.
+      --  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)
@@ -438,6 +438,12 @@ package body Sem_Type is
          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.
@@ -681,9 +687,15 @@ package body Sem_Type is
 
       if All_Interp.Last = First_Interp + 1 then
 
-         --  The original interpretation is in fact not overloaded
+         --  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;