From patchwork Mon Aug 29 12:53:58 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 112040 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 9FE81B6F90 for ; Mon, 29 Aug 2011 22:54:26 +1000 (EST) Received: (qmail 13280 invoked by alias); 29 Aug 2011 12:54:21 -0000 Received: (qmail 13097 invoked by uid 22791); 29 Aug 2011 12:54:19 -0000 X-SWARE-Spam-Status: No, hits=-1.1 required=5.0 tests=AWL,BAYES_05 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; Mon, 29 Aug 2011 12:53:59 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 59F0A2BAB09; Mon, 29 Aug 2011 08:53:58 -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 mhFXzlsepmL6; Mon, 29 Aug 2011 08:53:58 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 479CB2BAACD; Mon, 29 Aug 2011 08:53:58 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 463F692A55; Mon, 29 Aug 2011 08:53:58 -0400 (EDT) Date: Mon, 29 Aug 2011 08:53:58 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Inheriting non-conformant homographs Message-ID: <20110829125358.GA28418@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 In Ada 2012 it is possible to inherit non-conformant homographs, but they can't be called or overridden. The following test now compiles silently. package Pack1 is type Int1 is interface; procedure Op (X : in Int1) is null; end Pack1; package Pack2 is type Int2 is interface; procedure Op (Y : in out Int2) is null; end Pack2; with Pack1; with Pack2; package Pack3 is type Typ3 is new Pack1.Int1 and Pack2.Int2 with record F1 : Integer; end record; end Pack3; Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-29 Javier Miranda * exp_ch6.ads, exp_ch6.adb (Is_Null_Procedure): Move the spec of this function to the package spec. * sem_ch6.adb (Find_Corresponding_Spec, New_Overloaded_Entity): For internally generated bodies of null procedures locate the internally generated spec enforcing mode conformance. (Is_Interface_Conformant): Ensure that the controlling formal of the primitives match. Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 178183) +++ exp_ch6.adb (working copy) @@ -223,10 +223,6 @@ -- reference to the object itself, and the call becomes a call to the -- corresponding protected subprogram. - function Is_Null_Procedure (Subp : Entity_Id) return Boolean; - -- Predicate to recognize stubbed procedures and null procedures, which - -- can be inlined unconditionally in all cases. - procedure Expand_Simple_Function_Return (N : Node_Id); -- Expand simple return from function. In the case where we are returning -- from a function body this is called by Expand_N_Simple_Return_Statement. Index: exp_ch6.ads =================================================================== --- exp_ch6.ads (revision 178183) +++ exp_ch6.ads (working copy) @@ -119,6 +119,10 @@ -- that requires handling as a build-in-place call or is a qualified -- expression applied to such a call; otherwise returns False. + function Is_Null_Procedure (Subp : Entity_Id) return Boolean; + -- Predicate to recognize stubbed procedures and null procedures, which + -- can be inlined unconditionally in all cases. + procedure Make_Build_In_Place_Call_In_Allocator (Allocator : Node_Id; Function_Call : Node_Id); Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 178211) +++ sem_ch6.adb (working copy) @@ -6362,7 +6362,19 @@ end if; end if; - if not Has_Completion (E) then + -- Ada 2012 (AI05-0165): For internally generated bodies of + -- null procedures locate the internally generated spec. We + -- enforce mode conformance since a tagged type may inherit + -- from interfaces several null primitives which differ only + -- in the mode of the formals. + + if not (Comes_From_Source (E)) + and then Is_Null_Procedure (E) + and then not Mode_Conformant (Designator, E) + then + null; + + elsif not Has_Completion (E) then if Nkind (N) /= N_Subprogram_Body_Stub then Set_Corresponding_Spec (N, E); end if; @@ -7037,6 +7049,30 @@ Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim); Typ : constant Entity_Id := Find_Dispatching_Type (Prim); + function Controlling_Formal (Prim : Entity_Id) return Entity_Id; + -- Return the controlling formal of Prim + + function Controlling_Formal (Prim : Entity_Id) return Entity_Id is + E : Entity_Id := First_Entity (Prim); + begin + while Present (E) loop + if Is_Formal (E) and then Is_Controlling_Formal (E) then + return E; + end if; + + Next_Entity (E); + end loop; + + return Empty; + end Controlling_Formal; + + -- Local variables + + Iface_Ctrl_F : constant Entity_Id := Controlling_Formal (Iface_Prim); + Prim_Ctrl_F : constant Entity_Id := Controlling_Formal (Prim); + + -- Start of processing for Is_Interface_Conformant + begin pragma Assert (Is_Subprogram (Iface_Prim) and then Is_Subprogram (Prim) @@ -7060,9 +7096,18 @@ then return False; - -- Case of a procedure, or a function that does not have a controlling - -- result (I or access I). + -- The mode of the controlling formals must match + elsif Present (Iface_Ctrl_F) + and then Present (Prim_Ctrl_F) + and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F) + then + return False; + + -- Case of a procedure, or a function whose result type matches the + -- result type of the interface primitive, or a function that has no + -- controlling result (I or access I). + elsif Ekind (Iface_Prim) = E_Procedure or else Etype (Prim) = Etype (Iface_Prim) or else not Has_Controlling_Result (Prim) @@ -8254,6 +8299,18 @@ if Scope (E) /= Current_Scope then null; + -- Ada 2012 (AI05-0165): For internally generated bodies of + -- null procedures locate the internally generated spec. We + -- enforce mode conformance since a tagged type may inherit + -- from interfaces several null primitives which differ only + -- in the mode of the formals. + + elsif not Comes_From_Source (S) + and then Is_Null_Procedure (S) + and then not Mode_Conformant (E, S) + then + null; + -- Check if we have type conformance elsif Type_Conformant (E, S) then