From patchwork Tue Oct 26 12:45:58 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 69242 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 C1A76B6EEE for ; Tue, 26 Oct 2010 23:46:18 +1100 (EST) Received: (qmail 7127 invoked by alias); 26 Oct 2010 12:46:16 -0000 Received: (qmail 6979 invoked by uid 22791); 26 Oct 2010 12:46:14 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (194.98.77.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 26 Oct 2010 12:46:01 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id EAFCECB02F2; Tue, 26 Oct 2010 14:45:58 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id zPxwcLNsfipE; Tue, 26 Oct 2010 14:45:58 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id D837CCB0240; Tue, 26 Oct 2010 14:45:58 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id B7B6DD9BB4; Tue, 26 Oct 2010 14:45:58 +0200 (CEST) Date: Tue, 26 Oct 2010 14:45:58 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] AI05-0197: Dispatching with multiple inherited operations Message-ID: <20101026124558.GA11605@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes 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 AI resolves a conflict between an inherited null interface primitive and an inherited private primitive. In such case the inherited private primitive is the dispatching primitive. For further details read http://www.ada-auth.org/cgi-bin/cvsweb.cgi/ai05s/ai05-0197-1.txt After this patch the following test compiles and executes fine. package Pack1 is type Int1 is interface; procedure Op1 (X : Int1) is null; end Pack1; package Pack2 is type T2 is tagged null record; private procedure Op1 (X : T2); end Pack2; with Pack1, Pack2; package Pack2.Pack3 is type T3 is new Pack2.T2 and Pack1.Int1 with null record; end Pack2.Pack3; with Text_IO; use Text_IO; package body Pack2 is procedure Op1 (X : T2) is begin Put_Line ("OK"); end; end Pack2; with Pack2.Pack3; procedure Do_Test is X : Pack2.Pack3.T3; begin Pack2.Pack3.Op1 (X); end; Output: OK Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-26 Javier Miranda * sem_ch3.adb (Add_Internal_Interface_Entities): Handle primitives inherited from the parent that cover interface primitives. (Derive_Progenitor_Subprograms): Handle primitives inherited from the parent that cover interface primitives. * sem_disp.adb (Find_Primitive_Covering_Interface): When searching in the list of primitives of the type extend the test to include inherited private primitives. * sem_ch6.ads (Is_Interface_Conformant): Add missing documentation. * sem_ch7.adb (Declare_Inherited_Private_Subprograms): Add missing barrier to the loop searching for explicit overriding primitives. * sem_ch4.adb (Analyze_Indexed_Component_Form): Add missing barrier before accessing attribute Entity. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 165946) +++ sem_ch3.adb (working copy) @@ -1572,6 +1572,26 @@ package body Sem_Ch3 is pragma Assert (Present (Prim)); + -- Ada 2012 (AI05-0197): If the name of the covering primitive + -- differs from the name of the interface primitive then it is + -- a private primitive inherited from a parent type. In such + -- case, given that Tagged_Type covers the interface, the + -- inherited private primitive becomes visible. For such + -- purpose we add a new entity that renames the inherited + -- private primitive. + + if Chars (Prim) /= Chars (Iface_Prim) then + pragma Assert (Has_Suffix (Prim, 'P')); + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Prim, + Derived_Type => Tagged_Type, + Parent_Type => Iface); + Set_Alias (New_Subp, Prim); + Set_Is_Abstract_Subprogram (New_Subp, + Is_Abstract_Subprogram (Prim)); + end if; + Derive_Subprogram (New_Subp => New_Subp, Parent_Subp => Iface_Prim, @@ -12416,6 +12436,22 @@ package body Sem_Ch3 is Derive_Subprogram (New_Subp, Iface_Subp, Tagged_Type, Iface); + -- Ada 2012 (AI05-0197): If the covering primitive's name + -- differs from the name of the interface primitive then it + -- is a private primitive inherited from a parent type. In + -- such case, given that Tagged_Type covers the interface, + -- the inherited private primitive becomes visible. For such + -- purpose we add a new entity that renames the inherited + -- private primitive. + + elsif Chars (E) /= Chars (Iface_Subp) then + pragma Assert (Has_Suffix (E, 'P')); + Derive_Subprogram + (New_Subp, Iface_Subp, Tagged_Type, Iface); + Set_Alias (New_Subp, E); + Set_Is_Abstract_Subprogram (New_Subp, + Is_Abstract_Subprogram (E)); + -- Propagate to the full view interface entities associated -- with the partial view Index: sem_ch7.adb =================================================================== --- sem_ch7.adb (revision 165946) +++ sem_ch7.adb (working copy) @@ -1527,8 +1527,15 @@ package body Sem_Ch7 is Op_Elmt_2 := Next_Elmt (Op_Elmt); while Present (Op_Elmt_2) loop + + -- Skip entities with attribute Interface_Alias since + -- they are not overriding primitives (these entities + -- link an interface primitive with their covering + -- primitive) + if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) + and then No (Interface_Alias (Node (Op_Elmt_2))) then -- The private inherited operation has been -- overridden by an explicit subprogram: replace Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 165944) +++ sem_ch4.adb (working copy) @@ -2155,7 +2155,9 @@ package body Sem_Ch4 is P_T := Base_Type (Etype (P)); - if Is_Entity_Name (P) then + if Is_Entity_Name (P) + and then Present (Entity (P)) + then U_N := Entity (P); if Is_Type (U_N) then Index: sem_ch6.ads =================================================================== --- sem_ch6.ads (revision 165935) +++ sem_ch6.ads (working copy) @@ -186,9 +186,10 @@ package Sem_Ch6 is (Tagged_Type : Entity_Id; Iface_Prim : Entity_Id; Prim : Entity_Id) return Boolean; - -- Returns true if both primitives have a matching name, they are type - -- conformant, and Prim is defined in the scope of Tagged_Type. Special - -- management is done for functions returning interfaces. + -- Returns true if both primitives have a matching name (including support + -- for names of inherited private primitives --which have suffix 'P'), they + -- are type conformant, and Prim is defined in the scope of Tagged_Type. + -- Special management is done for functions returning interfaces. procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id); -- E is the entity for a subprogram or generic subprogram spec. This call Index: sem_disp.adb =================================================================== --- sem_disp.adb (revision 165945) +++ sem_disp.adb (working copy) @@ -1817,6 +1817,13 @@ package body Sem_Disp is end if; end if; + -- Check if E covers the interface primitive (includes case in + -- which E is an inherited private primitive) + + if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then + return E; + end if; + -- Use the internal entity that links the interface primitive with -- the covering primitive to locate the entity