diff options
| -rw-r--r-- | gcc/ada/sem_type.adb | 80 |
1 files changed, 73 insertions, 7 deletions
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index eca91e59820..94c4c5c060e 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -913,7 +913,10 @@ package body Sem_Type is and then Designated_Type (T1) = Designated_Type (T2)) or else (T1 = Any_Access - and then Is_Access_Type (Underlying_Type (T2)))) + and then Is_Access_Type (Underlying_Type (T2))) + or else (T2 = Any_Composite + and then + Is_Composite_Type (Underlying_Type (T1)))) then return True; @@ -979,6 +982,13 @@ package body Sem_Type is -- Determine whether one of the candidates is an operation inherited by -- a type that is derived from an actual in an instantiation. + function In_Generic_Actual (Exp : Node_Id) return Boolean; + -- Determine whether the expression is part of a generic actual. At + -- the time the actual is resolved the scope is already that of the + -- instance, but conceptually the resolution of the actual takes place + -- in the enclosing context, and no special disambiguation rules should + -- be applied. + function Is_Actual_Subprogram (S : Entity_Id) return Boolean; -- Determine whether a subprogram is an actual in an enclosing instance. -- An overloading between such a subprogram and one declared outside the @@ -1009,6 +1019,34 @@ package body Sem_Type is -- pathology in the other direction with calls whose multiple overloaded -- actuals make them truly unresolvable. + ------------------------ + -- In_Generic_Actual -- + ------------------------ + + function In_Generic_Actual (Exp : Node_Id) return Boolean is + Par : constant Node_Id := Parent (Exp); + + begin + if No (Par) then + return False; + + elsif Nkind (Par) in N_Declaration then + if Nkind (Par) = N_Object_Declaration + or else Nkind (Par) = N_Object_Renaming_Declaration + then + return Present (Corresponding_Generic_Association (Par)); + else + return False; + end if; + + elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then + return False; + + else + return In_Generic_Actual (Parent (Par)); + end if; + end In_Generic_Actual; + --------------------------- -- Inherited_From_Actual -- --------------------------- @@ -1372,7 +1410,9 @@ package body Sem_Type is -- case the resolution was to the explicit declaration in the -- generic, and remains so in the instance. - elsif In_Instance then + elsif In_Instance + and then not In_Generic_Actual (N) + then if Nkind (N) = N_Function_Call or else Nkind (N) = N_Procedure_Call_Statement then @@ -1801,7 +1841,16 @@ package body Sem_Type is return True; end if; - E := Typ; + -- Handle private types + + if Present (Full_View (Typ)) + and then not Is_Concurrent_Type (Full_View (Typ)) + then + E := Full_View (Typ); + else + E := Typ; + end if; + loop if Present (Abstract_Interfaces (E)) and then Present (Abstract_Interfaces (E)) @@ -1819,7 +1868,12 @@ package body Sem_Type is end loop; end if; - exit when Etype (E) = E; + exit when Etype (E) = E + + -- Handle private types + + or else (Present (Full_View (Etype (E))) + and then Full_View (Etype (E)) = E); -- Check if the current type is a direct derivation of the -- interface @@ -1828,14 +1882,20 @@ package body Sem_Type is return True; end if; - -- Climb to the immediate ancestor + -- Climb to the immediate ancestor handling private types - E := Etype (E); + if Present (Full_View (Etype (E))) then + E := Full_View (Etype (E)); + else + E := Etype (E); + end if; end loop; return False; end Iface_Present_In_Ancestor; + -- Start of processing for Interface_Present_In_Ancestor + begin if Is_Access_Type (Typ) then Target_Typ := Etype (Directly_Designated_Type (Typ)); @@ -1879,6 +1939,12 @@ package body Sem_Type is if Ekind (Target_Typ) = E_Incomplete_Type then pragma Assert (Present (Non_Limited_View (Target_Typ))); Target_Typ := Non_Limited_View (Target_Typ); + + -- Protect the frontend against previously detected errors + + if Ekind (Target_Typ) = E_Incomplete_Type then + return False; + end if; end if; return Iface_Present_In_Ancestor (Target_Typ); |
