From patchwork Tue Oct 5 09:38:16 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 66778 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 F1F16B70D4 for ; Tue, 5 Oct 2010 20:38:26 +1100 (EST) Received: (qmail 4978 invoked by alias); 5 Oct 2010 09:38:25 -0000 Received: (qmail 4969 invoked by uid 22791); 5 Oct 2010 09:38:24 -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) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 05 Oct 2010 09:38:18 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 9C2E3CB01EC; Tue, 5 Oct 2010 11:38:16 +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 H6K2KAWuXO3V; Tue, 5 Oct 2010 11:38:16 +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 7995ACB01DF; Tue, 5 Oct 2010 11:38:16 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 5C379D9BB5; Tue, 5 Oct 2010 11:38:16 +0200 (CEST) Date: Tue, 5 Oct 2010 11:38:16 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Inheritance of private null interface primitive Message-ID: <20101005093816.GA6029@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 A derived type does not inherit a private operation from a parent type, but can dispatch to it. That is, its dispatch table includes a full copy of the dispatch table of the parent, even if some of its entries can never be named. After this patch the following test compiles and executes silently. package R is type I1 is interface; procedure Oper (Obj : I1'Class); private procedure Proc (Obj : I1) is null; end R; package body R is procedure Oper (Obj : I1'Class) is begin Obj.Proc; -- Dispatching end Oper; end; with R; package P1 is type Root is tagged private; private type Root is tagged null record; end; with P1; with R; package Q1 is type Child is new P1.Root and R.I1 with null record; end Q1; with P1, Q1, R; procedure Main1 is X : Q1.Child; begin R.Oper (X); end Main1; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-05 Javier Miranda * sem_ch3.adb (Add_Internal_Interface_Entities): Code reorganization: move code that searches in the list of primitives of a tagged type for the entity that will be overridden by user-defined routines. * sem_disp.adb (Find_Primitive_Covering_Interface): Move here code previously located in routine Add_Internal_Interface_Entities. * sem_disp.ads (Find_Primitive_Covering_Interface): Update documentation * sem_ch6.adb (New_Overloaded_Entity): Add missing check on availability of attribute Alias. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 164906) +++ sem_ch3.adb (working copy) @@ -1567,41 +1567,9 @@ package body Sem_Ch3 is if Is_Null_Interface_Primitive (Iface_Prim) then goto Continue; - -- if the tagged type is defined at library level then we - -- invoke Check_Abstract_Overriding to report the error - -- and thus avoid generating the dispatch tables. - - elsif Is_Library_Level_Tagged_Type (Tagged_Type) then - Check_Abstract_Overriding (Tagged_Type); - pragma Assert (Serious_Errors_Detected > 0); - return; - - -- For tagged types defined in nested scopes it is still - -- possible to cover this interface primitive by means of - -- late overriding (see Override_Dispatching_Operation). - - -- Search in the list of primitives of the type for the - -- entity that will be overridden in such case to reference - -- it in the internal entity that we build here. If the - -- primitive is not overridden then the error will be - -- reported later as part of the analysis of entities - -- defined in the enclosing scope. - else - declare - El : Elmt_Id; - - begin - El := First_Elmt (Primitive_Operations (Tagged_Type)); - while Present (El) - and then Alias (Node (El)) /= Iface_Prim - loop - Next_Elmt (El); - end loop; - - pragma Assert (Present (El)); - Prim := Node (El); - end; + pragma Assert (False); + raise Program_Error; end if; end if; Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 164933) +++ sem_ch6.adb (working copy) @@ -7625,6 +7625,7 @@ package body Sem_Ch6 is if Ada_Version >= Ada_05 and then Present (Derived_Type) + and then Present (Alias (S)) and then Is_Dispatching_Operation (Alias (S)) and then Present (Find_Dispatching_Type (Alias (S))) and then Is_Interface (Find_Dispatching_Type (Alias (S))) Index: sem_disp.adb =================================================================== --- sem_disp.adb (revision 164939) +++ sem_disp.adb (working copy) @@ -1651,7 +1651,8 @@ package body Sem_Disp is (Tagged_Type : Entity_Id; Iface_Prim : Entity_Id) return Entity_Id is - E : Entity_Id; + E : Entity_Id; + El : Elmt_Id; begin pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim)) @@ -1660,6 +1661,8 @@ package body Sem_Disp is Is_Interface (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); + -- Search in the homonym chain + E := Current_Entity (Iface_Prim); while Present (E) loop if Is_Subprogram (E) @@ -1672,6 +1675,23 @@ package body Sem_Disp is E := Homonym (E); end loop; + -- Search in the list of primitives of the type + + El := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (El) loop + E := Node (El); + + if No (Interface_Alias (E)) + and then Alias (E) = Iface_Prim + then + return Node (El); + end if; + + Next_Elmt (El); + end loop; + + -- Not found + return Empty; end Find_Primitive_Covering_Interface; Index: sem_disp.ads =================================================================== --- sem_disp.ads (revision 164906) +++ sem_disp.ads (working copy) @@ -82,10 +82,12 @@ package Sem_Disp is function Find_Primitive_Covering_Interface (Tagged_Type : Entity_Id; Iface_Prim : Entity_Id) return Entity_Id; - -- Search in the homonym chain for the primitive of Tagged_Type that - -- covers Iface_Prim. The homonym chain traversal is required to catch - -- primitives associated with the partial view of private types when - -- processing the corresponding full view. + -- Search in the homonym chain for the primitive of Tagged_Type that covers + -- Iface_Prim. The homonym chain traversal is required to catch primitives + -- associated with the partial view of private types when processing the + -- corresponding full view. If the entity is not found then search for it + -- in the list of primitives of Tagged_Type. This latter search is needed + -- when the interface primitive is covered by a private subprogram. function Is_Dynamically_Tagged (N : Node_Id) return Boolean; -- Used to determine whether a call is dispatching, i.e. if is an