From patchwork Fri Jun 18 09:07:07 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 56152 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 113761007D3 for ; Fri, 18 Jun 2010 19:06:57 +1000 (EST) Received: (qmail 17043 invoked by alias); 18 Jun 2010 09:06:55 -0000 Received: (qmail 17035 invoked by uid 22791); 18 Jun 2010 09:06:54 -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; Fri, 18 Jun 2010 09:06:50 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 92CC3CB0253; Fri, 18 Jun 2010 11:06:57 +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 u-3j6cxy9hkF; Fri, 18 Jun 2010 11:06:57 +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 7EF64CB01F8; Fri, 18 Jun 2010 11:06:57 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id AAF75D9B31; Fri, 18 Jun 2010 11:07:07 +0200 (CEST) Date: Fri, 18 Jun 2010 11:07:07 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Class-wide types of private extensions of constrained types Message-ID: <20100618090707.GA1015@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 The class-wide type of private extension is created when the partial view is analyzed. This class-wide type is shared with the full view. If the full view is a subtype, as is the case when the parent is a constrained discriminated subtype, the type of the private extension must be the base type of the full view, to prevent spurious semantic errors when the classwide equivalent type is constructed. This expansion involves dispatching calls to Size and to Deep_Adjust, and these are best expressed on the full view. x.adb must compile quietly: --- with P; use P; package X is function Create return access Child_1_3'Class; type Child_Acc is access all Child_1_3'Class; end X; --- package body X is function Create return access Child_1_3'Class is Res : Child_Acc := new Child_1_3; Res2 : Child_Acc := new Child_1_3'Class'(Res.all); begin return Res2; end Create; end X; --- package P is type Root_1 (V : Integer) is tagged record null; end record; type Child_1_3 is new Root_1 (1) with private; private type Child_1_3 is new Root_1 (1) with null record; end P; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-18 Ed Schonberg * exp_util.adb (Make_Subtype_From_Expr): If the unconstrained type is the class-wide type for a private extension, and the completion is a subtype, set the type of the class-wide type to the base type of the full view. Index: exp_util.adb =================================================================== --- exp_util.adb (revision 160962) +++ exp_util.adb (working copy) @@ -4052,6 +4052,20 @@ package body Exp_Util is -- additional intermediate type to handle the assignment). if Expander_Active and then Tagged_Type_Expansion then + + -- If this is the class_wide type of a completion that is + -- a record subtype, set the type of the class_wide type + -- to be the full base type, for use in the expanded code + -- for the equivalent type. Should this be done earlier when + -- the completion is analyzed ??? + + if Is_Private_Type (Etype (Unc_Typ)) + and then + Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype + then + Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ)))); + end if; + EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E); end if;