From dd54644b315aa181b563ee78ee5f48ec908632c2 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Tue, 30 Aug 2011 13:50:19 +0000 Subject: [PATCH] sem_ch3.adb (Check_Abstract_Overriding): Code cleanup... 2011-08-30 Javier Miranda * sem_ch3.adb (Check_Abstract_Overriding): Code cleanup: replace code which emits an error by a call to a new routine which report the error. * exp_ch9.adb (Build_Wrapper_Spec): Build the wrapper even if the entity does not cover an existing interface. * errout.ads, errout.adb (Error_Msg_PT): New routine. Used to factorize code. * sem_ch6.adb (Check_Conformance): Add specific error for wrappers of protected procedures or entries whose mode is not conformant. (Check_Synchronized_Overriding): Code cleanup: replace code which emits an error by a call to a new routine which report the error. From-SVN: r178306 --- gcc/ada/ChangeLog | 13 +++++++++++++ gcc/ada/errout.adb | 17 +++++++++++++++++ gcc/ada/errout.ads | 4 ++++ gcc/ada/exp_ch9.adb | 36 ++++++++++++++++++++++++++++++++---- gcc/ada/sem_ch3.adb | 10 +--------- gcc/ada/sem_ch6.adb | 29 ++++++++++++++++++++++------- 6 files changed, 89 insertions(+), 20 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 45904350732..91367c8d9e2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2011-08-30 Javier Miranda + + * sem_ch3.adb (Check_Abstract_Overriding): Code cleanup: replace code + which emits an error by a call to a new routine which report the error. + * exp_ch9.adb (Build_Wrapper_Spec): Build the wrapper even if the + entity does not cover an existing interface. + * errout.ads, errout.adb (Error_Msg_PT): New routine. Used to factorize + code. + * sem_ch6.adb (Check_Conformance): Add specific error for wrappers of + protected procedures or entries whose mode is not conformant. + (Check_Synchronized_Overriding): Code cleanup: replace code which emits + an error by a call to a new routine which report the error. + 2011-08-30 Robert Dewar * gnat_rm.texi: Minor change. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 39d73027840..ac880eca235 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -617,6 +617,23 @@ package body Errout is Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1; end Error_Msg_CRT; + ------------------ + -- Error_Msg_PT -- + ------------------ + + procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id) is + begin + -- Error message below needs rewording (remember comma in -gnatj + -- mode) ??? + + Error_Msg_NE + ("first formal of & must be of mode `OUT`, `IN OUT` or " & + "access-to-variable", Typ, Subp); + Error_Msg_N + ("\in order to be overridden by protected procedure or entry " & + "(RM 9.4(11.9/2))", Typ); + end Error_Msg_PT; + ----------------- -- Error_Msg_F -- ----------------- diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index ef3dcc47c29..7005cc11092 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -801,6 +801,10 @@ package Errout is -- run-time mode or no run-time mode (as appropriate). In the former case, -- the name of the library is output if available. + procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id); + -- Posts an error on the protected type declaration Typ indicating wrong + -- mode of the first formal of protected type primitive Subp. + procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg; -- Debugging routine to dump an error message diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 2e11a278995..b30254df350 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -2263,14 +2263,42 @@ package body Exp_Ch9 is end loop Search; end if; - -- If the subprogram to be wrapped is not overriding anything or is not - -- a primitive declared between two views, do not produce anything. This - -- avoids spurious errors involving overriding. + -- Ada 2012 (AI05-0090-1): If no interface primitive is covered by + -- this subprogram and this is not a primitive declared between two + -- views then force the generation of a wrapper. As an optimization, + -- previous versions of the frontend avoid generating the wrapper; + -- however, the wrapper facilitates locating and reporting an error + -- when a duplicate declaration is found later. See example in + -- AI05-0090-1. if No (First_Param) and then not Is_Private_Primitive_Subprogram (Subp_Id) then - return Empty; + if Is_Task_Type + (Corresponding_Concurrent_Type (Obj_Typ)) + then + First_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Name_uO), + In_Present => True, + Out_Present => False, + Parameter_Type => New_Reference_To (Obj_Typ, Loc)); + + -- For entries and procedures of protected types the mode of + -- the controlling argument must be in-out. + + else + First_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Name_uO), + In_Present => True, + Out_Present => (Ekind (Subp_Id) /= E_Function), + Parameter_Type => New_Reference_To (Obj_Typ, Loc)); + end if; end if; declare diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9ecfb72f74a..67aff229e29 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9162,9 +9162,6 @@ package body Sem_Ch3 is -- The controlling formal of Subp must be of mode "out", -- "in out" or an access-to-variable to be overridden. - -- Error message below needs rewording (remember comma - -- in -gnatj mode) ??? - if Ekind (First_Formal (Subp)) = E_In_Parameter and then Ekind (Subp) /= E_Function then @@ -9172,12 +9169,7 @@ package body Sem_Ch3 is and then Is_Protected_Type (Corresponding_Concurrent_Type (T)) then - Error_Msg_NE - ("first formal of & must be of mode `OUT`, " & - "`IN OUT` or access-to-variable", T, Subp); - Error_Msg_N - ("\in order to be overridden by protected procedure " - & "or entry (RM 9.4(11.9/2))", T); + Error_Msg_PT (T, Subp); end if; -- Some other kind of overriding failure diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 07c625d17a1..174a7dfd009 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4226,7 +4226,26 @@ package body Sem_Ch6 is if Ctype >= Mode_Conformant then if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then - Conformance_Error ("\mode of & does not match!", New_Formal); + if not Ekind_In (New_Id, E_Function, E_Procedure) + or else not Is_Primitive_Wrapper (New_Id) + then + Conformance_Error ("\mode of & does not match!", New_Formal); + else + declare + T : constant Entity_Id := + Find_Dispatching_Type (New_Id); + begin + if Is_Protected_Type + (Corresponding_Concurrent_Type (T)) + then + Error_Msg_PT (T, New_Id); + else + Conformance_Error + ("\mode of & does not match!", New_Formal); + end if; + end; + end if; + return; -- Part of mode conformance for access types is having the same @@ -7971,6 +7990,7 @@ package body Sem_Ch6 is -- to retrieve the corresponding concurrent type. elsif Is_Concurrent_Record_Type (Typ) + and then not Is_Class_Wide_Type (Typ) and then Present (Corresponding_Concurrent_Type (Typ)) then Typ := Corresponding_Concurrent_Type (Typ); @@ -8102,12 +8122,7 @@ package body Sem_Ch6 is or else Is_Synchronized_Interface (Iface_Typ) or else Is_Task_Interface (Iface_Typ)) then - Error_Msg_NE - ("first formal of & must be of mode `OUT`, `IN OUT`" - & " or access-to-variable", Typ, Candidate); - Error_Msg_N - ("\in order to be overridden by protected procedure or " - & "entry (RM 9.4(11.9/2))", Typ); + Error_Msg_PT (Parent (Typ), Candidate); end if; end if; -- 2.30.2