From patchwork Thu Jun 17 15:24:22 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 56059 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 B2F2CB7D83 for ; Fri, 18 Jun 2010 01:24:15 +1000 (EST) Received: (qmail 27396 invoked by alias); 17 Jun 2010 15:24:13 -0000 Received: (qmail 27378 invoked by uid 22791); 17 Jun 2010 15:24:11 -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; Thu, 17 Jun 2010 15:24:06 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 51784CB01EA; Thu, 17 Jun 2010 17:24:12 +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 NuSy4SJ37yak; Thu, 17 Jun 2010 17:24:12 +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 3F095CB01DB; Thu, 17 Jun 2010 17:24:12 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 4BC96D9AB0; Thu, 17 Jun 2010 17:24:22 +0200 (CEST) Date: Thu, 17 Jun 2010 17:24:22 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Extension aggregate with ancestor that is a constrained private extension Message-ID: <20100617152422.GA14120@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 patch fixes the handling of extension aggregates when the parent type is a private extension that constrains a discriminant of the parent. The following must compile quietly: with P; use P; package X is type Base_I is interface; type Interface_And_Child is new Child_1_3 and Base_I with null record; function Copy_No_Clone (Object : Interface_And_Child) return access Interface_And_Child; type Interface_And_Child_Acc is access all Interface_And_Child'Class; end X; --- package body X is function Copy_No_Clone (Object : Interface_And_Child) return access Interface_And_Child is Res : Interface_And_Child_Acc := new Interface_And_Child'(Child_1_3 with others => <>); begin return Res; end Copy_No_Clone; end X; --- package P is type Root_1 (V : Integer) is tagged null 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-17 Ed Schonberg * sem_aggr.adb (Valid_Ancestor_Type): handle properly the case of a constrained discriminated parent that is a private type. (Analyze_Record_Aggregate): when collecting inherited discriminants, handle properly an ancestor type that is a constrained private type. Index: sem_aggr.adb =================================================================== --- sem_aggr.adb (revision 160919) +++ sem_aggr.adb (working copy) @@ -2288,6 +2288,18 @@ package body Sem_Aggr is then A_Type := Etype (Imm_Type); return True; + + -- The parent type may be a private extension. The aggregate is + -- legal if the type of the aggregate is an extension of it that + -- is not a private extension. + + elsif Is_Private_Type (A_Type) + and then not Is_Private_Type (Imm_Type) + and then Present (Full_View (A_Type)) + and then Base_Type (Full_View (A_Type)) = Etype (Imm_Type) + then + return True; + else Imm_Type := Etype (Base_Type (Imm_Type)); end if; @@ -2502,11 +2514,9 @@ package body Sem_Aggr is From : List_Id; Consider_Others_Choice : Boolean := False) return Node_Id; - -- Given a record component stored in parameter Compon, the following - -- function returns its value as it appears in the list From, which is - -- a list of N_Component_Association nodes. - -- What is this referring to??? There is no "following function" in - -- sight??? + -- Given a record component stored in parameter Compon, this function + -- returns its value as it appears in the list From, which is a list + -- of N_Component_Association nodes. -- -- If no component association has a choice for the searched component, -- the value provided by the others choice is returned, if there is one, @@ -3241,12 +3251,11 @@ package body Sem_Aggr is Dnode := Declaration_Node (Base_Type (Root_Typ)); - -- If we don't get a full declaration, then we have some - -- error which will get signalled later so skip this part. - -- Otherwise, gather components of root that apply to the - -- aggregate type. We use the base type in case there is an - -- applicable stored constraint that renames the discriminants - -- of the root. + -- If we don't get a full declaration, then we have some error + -- which will get signalled later so skip this part. Otherwise + -- gather components of root that apply to the aggregate type. + -- We use the base type in case there is an applicable stored + -- constraint that renames the discriminants of the root. if Nkind (Dnode) = N_Full_Type_Declaration then Record_Def := Type_Definition (Dnode); @@ -3281,6 +3290,15 @@ package body Sem_Aggr is Ancestor_Part (N), Parent_Typ); return; end if; + + -- The current view of ancestor part may be a private type, + -- while the context type is always non-private. + + elsif Is_Private_Type (Root_Typ) + and then Present (Full_View (Root_Typ)) + and then Nkind (N) = N_Extension_Aggregate + then + exit when Base_Type (Full_View (Root_Typ)) = Parent_Typ; end if; end loop;