From 15e4986cda84e26a3f9e676e0dc97dd31d0014ca Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Thu, 31 Jul 2008 14:46:35 +0200 Subject: [PATCH] sem_type.adb (Has_Compatible_Type): Complete support for synchronized types when... 2008-07-31 Javier Miranda * sem_type.adb (Has_Compatible_Type): Complete support for synchronized types when the candidate type is a synchronized type. * sem_res.adb (Resolve_Actuals): Reorganize code handling synchronized types, and complete management of synchronized types adding missing code to handle formal that is a synchronized type. * sem_ch4.adb (Try_Primitive_Operation): Avoid testing attributes that are not available and cause the compiler to blowup. Found compiling test with switch -gnatc * sem_ch6.adb (Check_Synchronized_Overriding): Remove local subprogram Has_Correct_Formal_Mode plus code cleanup. From-SVN: r138400 --- gcc/ada/sem_ch4.adb | 4 ++ gcc/ada/sem_ch6.adb | 130 ++++++++++++++++--------------------------- gcc/ada/sem_res.adb | 50 ++++++++++++++--- gcc/ada/sem_type.adb | 9 ++- 4 files changed, 100 insertions(+), 93 deletions(-) diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index e14fb436d6b..4994ac8d45e 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6414,6 +6414,10 @@ package body Sem_Ch4 is -- corresponding record (base) type. if Is_Concurrent_Type (Obj_Type) then + if not Present (Corresponding_Record_Type (Obj_Type)) then + return False; + end if; + Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); Elmt := First_Elmt (Primitive_Operations (Corr_Type)); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index b378be43fff..33cb73d9a56 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6599,12 +6599,6 @@ package body Sem_Ch6 is In_Scope : Boolean; Typ : Entity_Id; - function Has_Correct_Formal_Mode - (Tag_Typ : Entity_Id; - Subp : Entity_Id) return Boolean; - -- For an overridden subprogram Subp, check whether the mode of its - -- first parameter is correct depending on the kind of Tag_Typ. - function Matches_Prefixed_View_Profile (Prim_Params : List_Id; Iface_Params : List_Id) return Boolean; @@ -6613,39 +6607,6 @@ package body Sem_Ch6 is -- Iface_Params. Also determine if the type of first parameter of -- Iface_Params is an implemented interface. - ----------------------------- - -- Has_Correct_Formal_Mode -- - ----------------------------- - - function Has_Correct_Formal_Mode - (Tag_Typ : Entity_Id; - Subp : Entity_Id) return Boolean - is - Formal : constant Node_Id := First_Formal (Subp); - - begin - -- In order for an entry or a protected procedure to override, the - -- first parameter of the overridden routine must be of mode - -- "out", "in out" or access-to-variable. - - if (Ekind (Subp) = E_Entry - or else Ekind (Subp) = E_Procedure) - and then Is_Protected_Type (Tag_Typ) - and then Ekind (Formal) /= E_In_Out_Parameter - and then Ekind (Formal) /= E_Out_Parameter - and then Nkind (Parameter_Type (Parent (Formal))) /= - N_Access_Definition - then - return False; - end if; - - -- All other cases are OK since a task entry or routine does not - -- have a restriction on the mode of the first parameter of the - -- overridden interface routine. - - return True; - end Has_Correct_Formal_Mode; - ----------------------------------- -- Matches_Prefixed_View_Profile -- ----------------------------------- @@ -6723,15 +6684,15 @@ package body Sem_Ch6 is Iface_Id := Defining_Identifier (Iface_Param); Iface_Typ := Find_Parameter_Type (Iface_Param); - if Is_Access_Type (Iface_Typ) then - Iface_Typ := Directly_Designated_Type (Iface_Typ); - end if; - Prim_Id := Defining_Identifier (Prim_Param); Prim_Typ := Find_Parameter_Type (Prim_Param); - if Is_Access_Type (Prim_Typ) then - Prim_Typ := Directly_Designated_Type (Prim_Typ); + if Ekind (Iface_Typ) = E_Anonymous_Access_Type + and then Ekind (Prim_Typ) = E_Anonymous_Access_Type + and then Is_Concurrent_Type (Designated_Type (Prim_Typ)) + then + Iface_Typ := Designated_Type (Iface_Typ); + Prim_Typ := Designated_Type (Prim_Typ); end if; -- Case of multiple interface types inside a parameter profile @@ -6864,60 +6825,63 @@ package body Sem_Ch6 is while Present (Hom) loop Subp := Hom; - -- Entries can override abstract or null interface - -- procedures - - if Ekind (Def_Id) = E_Entry - and then Ekind (Subp) = E_Procedure - and then Nkind (Parent (Subp)) = N_Procedure_Specification - and then (Is_Abstract_Subprogram (Subp) - or else Null_Present (Parent (Subp))) + if Subp = Def_Id + or else not Is_Overloadable (Subp) + or else not Is_Primitive (Subp) + or else not Is_Dispatching_Operation (Subp) + or else not Is_Interface (Find_Dispatching_Type (Subp)) then - while Present (Alias (Subp)) loop - Subp := Alias (Subp); - end loop; - - if Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - then - Candidate := Subp; - - -- Absolute match - - if Has_Correct_Formal_Mode (Typ, Candidate) then - Overridden_Subp := Candidate; - return; - end if; - end if; + null; - -- Procedures can override abstract or null interface - -- procedures + -- Entries and procedures can override abstract or null + -- interface procedures - elsif Ekind (Def_Id) = E_Procedure + elsif (Ekind (Def_Id) = E_Procedure + or else Ekind (Def_Id) = E_Entry) and then Ekind (Subp) = E_Procedure - and then Nkind (Parent (Subp)) = N_Procedure_Specification - and then (Is_Abstract_Subprogram (Subp) - or else Null_Present (Parent (Subp))) and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), Parameter_Specifications (Parent (Subp))) then Candidate := Subp; - -- Absolute match + -- For an overridden subprogram Subp, check whether the mode + -- of its first parameter is correct depending on the kind + -- of synchronized type. - if Has_Correct_Formal_Mode (Typ, Candidate) then - Overridden_Subp := Candidate; - return; - end if; + declare + Formal : constant Node_Id := First_Formal (Candidate); + + begin + -- In order for an entry or a protected procedure to + -- override, the first parameter of the overridden + -- routine must be of mode "out", "in out" or + -- access-to-variable. + + if (Ekind (Candidate) = E_Entry + or else Ekind (Candidate) = E_Procedure) + and then Is_Protected_Type (Typ) + and then Ekind (Formal) /= E_In_Out_Parameter + and then Ekind (Formal) /= E_Out_Parameter + and then Nkind (Parameter_Type (Parent (Formal))) + /= N_Access_Definition + then + null; + + -- All other cases are OK since a task entry or routine + -- does not have a restriction on the mode of the first + -- parameter of the overridden interface routine. + + else + Overridden_Subp := Candidate; + return; + end if; + end; -- Functions can override abstract interface functions elsif Ekind (Def_Id) = E_Function and then Ekind (Subp) = E_Function - and then Nkind (Parent (Subp)) = N_Function_Specification - and then Is_Abstract_Subprogram (Subp) and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), Parameter_Specifications (Parent (Subp))) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index a6d42f73637..e0118685ea0 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3218,16 +3218,48 @@ package body Sem_Res is -- or because it is a generic actual, so use base type to -- locate concurrent type. - if Is_Concurrent_Type (Etype (A)) - and then Etype (F) = - Corresponding_Record_Type (Base_Type (Etype (A))) - then - Rewrite (A, - Unchecked_Convert_To - (Corresponding_Record_Type (Etype (A)), A)); - end if; + A_Typ := Base_Type (Etype (A)); + F_Typ := Base_Type (Etype (F)); + + declare + Full_A_Typ : Entity_Id; + + begin + if Present (Full_View (A_Typ)) then + Full_A_Typ := Base_Type (Full_View (A_Typ)); + else + Full_A_Typ := A_Typ; + end if; - Resolve (A, Etype (F)); + -- Tagged synchronized type (case 1): the actual is a + -- concurrent type + + if Is_Concurrent_Type (A_Typ) + and then Corresponding_Record_Type (A_Typ) = F_Typ + then + Rewrite (A, + Unchecked_Convert_To + (Corresponding_Record_Type (A_Typ), A)); + Resolve (A, Etype (F)); + + -- Tagged synchronized type (case 2): the formal is a + -- concurrent type + + elsif Ekind (Full_A_Typ) = E_Record_Type + and then Present + (Corresponding_Concurrent_Type (Full_A_Typ)) + and then Is_Concurrent_Type (F_Typ) + and then Present (Corresponding_Record_Type (F_Typ)) + and then Full_A_Typ = Corresponding_Record_Type (F_Typ) + then + Resolve (A, Corresponding_Record_Type (F_Typ)); + + -- Common case + + else + Resolve (A, Etype (F)); + end if; + end; end if; A_Typ := Etype (A); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 4a170d82ce3..aae54d1f67e 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2106,10 +2106,17 @@ package body Sem_Type is -- to check whether it is a proper descendant. or else - (Is_Concurrent_Type (Etype (N)) + (Is_Record_Type (Typ) + and then Is_Concurrent_Type (Etype (N)) and then Present (Corresponding_Record_Type (Etype (N))) and then Covers (Typ, Corresponding_Record_Type (Etype (N)))) + or else + (Is_Concurrent_Type (Typ) + and then Is_Record_Type (Etype (N)) + and then Present (Corresponding_Record_Type (Typ)) + and then Covers (Corresponding_Record_Type (Typ), Etype (N))) + or else (not Is_Tagged_Type (Typ) and then Ekind (Typ) /= E_Anonymous_Access_Type -- 2.30.2