From: Thomas Quinot Date: Tue, 20 May 2008 12:50:52 +0000 (+0200) Subject: sem_dist.ads, [...] (Is_RACW_Stub_Type_Operation): New subprogram. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=4b1c635450494b9aa044f355cb4fb87fcc0841eb;p=gcc.git sem_dist.ads, [...] (Is_RACW_Stub_Type_Operation): New subprogram. 2008-05-20 Thomas Quinot * 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 50cf65aff58..0be68edc9f3 100644 --- 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 9f9b95d3e69..38a164a418f 100644 --- 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 b118c37034a..c36125f52aa 100644 --- 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;