diff options
| -rw-r--r-- | gcc/ada/sem_dist.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/sem_dist.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 28 |
3 files changed, 46 insertions, 9 deletions
diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index 50cf65a..0be68ed 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 9f9b95d..38a164a 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 b118c37..c36125f 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; |