From patchwork Tue Aug 30 13:50:37 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 112312 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id D835CB70C1 for ; Tue, 30 Aug 2011 23:51:04 +1000 (EST) Received: (qmail 15061 invoked by alias); 30 Aug 2011 13:50:58 -0000 Received: (qmail 15005 invoked by uid 22791); 30 Aug 2011 13:50:55 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 30 Aug 2011 13:50:38 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 8261D2BAF40; Tue, 30 Aug 2011 09:50:37 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id 3n405wqQSx3I; Tue, 30 Aug 2011 09:50:37 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 6CDA52BAE7E; Tue, 30 Aug 2011 09:50:37 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 6B8573FEE8; Tue, 30 Aug 2011 09:50:37 -0400 (EDT) Date: Tue, 30 Aug 2011 09:50:37 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Add support to detect conflicting overriding primitive Message-ID: <20110830135037.GA21977@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This patch incorporates support in the compiler to detect conflicts in declarations of primitives of concurrent tagged types (see full documentation in AI05-0090-1). In addition the patch also performs a minor code cleanup in order to factorize the code which reports an error on wrong formal of protected type entity. After this patch the following test must report an error. package Synch_Pkg is type Synch_Interface is synchronized interface; end Synch_Pkg; with Synch_Pkg; use Synch_Pkg; package Task_Pkg is task type Task_Type is new Synch_Interface with entry Other_Prim; end Task_Type; procedure Other_Prim (Tsk : in out Task_Type); -- Legal? (No.) end Task_Pkg; Command: gcc -c -gnat05 task_pkg.ads task_pkg.ads:8:14: "Other_Prim" conflicts with declaration at line 5 Tested on x86_64-pc-linux-gnu, committed on trunk 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. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 178305) +++ sem_ch3.adb (working copy) @@ -9162,9 +9162,6 @@ -- 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 @@ 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 Index: exp_ch9.adb =================================================================== --- exp_ch9.adb (revision 178304) +++ exp_ch9.adb (working copy) @@ -2263,14 +2263,42 @@ 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 Index: errout.adb =================================================================== --- errout.adb (revision 178293) +++ errout.adb (working copy) @@ -617,6 +617,23 @@ 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 -- ----------------- Index: errout.ads =================================================================== --- errout.ads (revision 178293) +++ errout.ads (working copy) @@ -801,6 +801,10 @@ -- 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 Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 178304) +++ sem_ch6.adb (working copy) @@ -4226,7 +4226,26 @@ 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 @@ -- 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 @@ 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;