From patchwork Wed Jun 16 15:48:06 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 55900 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 34862B7D85 for ; Thu, 17 Jun 2010 01:48:14 +1000 (EST) Received: (qmail 11200 invoked by alias); 16 Jun 2010 15:48:07 -0000 Received: (qmail 11084 invoked by uid 22791); 16 Jun 2010 15:48:05 -0000 X-SWARE-Spam-Status: No, hits=-0.9 required=5.0 tests=AWL, BAYES_40, 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; Wed, 16 Jun 2010 15:47:53 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 3422ACB0246; Wed, 16 Jun 2010 17:47: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 dFiax5gMPAm6; Wed, 16 Jun 2010 17:47: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 1A3C9CB01E2; Wed, 16 Jun 2010 17:47:57 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id D3319D9B31; Wed, 16 Jun 2010 17:48:06 +0200 (CEST) Date: Wed, 16 Jun 2010 17:48:06 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Class_wide type of a private subtype Message-ID: <20100616154806.GA24661@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 There is a separate class_wide type for each subtype of a discriminated type. When the parent type is a private type, the completion of the subtype (which is created at the time the full view of the parent is analyzed) must have the same class_wide type. Prior to this patch the completion inherited the class_wide type of the parent type. The following must compile quietly: --- package P is type Kinds is (A, C); type T (K : Kinds) is abstract tagged limited private; subtype TA is T (A); procedure B (S : not null access TA'Class); private type T (K : Kinds) is abstract tagged limited null record; end P; --- package body P is procedure B (S : not null access TA'Class) is begin null; end B; end P; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-16 Ed Schonberg * sem_ch3.adb (Complete_Private_Subtype): Inherit class_wide type from base type only if it was not previously created for the partial view. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 160834) +++ sem_ch3.adb (working copy) @@ -9584,7 +9584,14 @@ package body Sem_Ch3 is if Is_Tagged_Type (Full_Base) then Set_Is_Tagged_Type (Full); Set_Primitive_Operations (Full, Primitive_Operations (Full_Base)); - Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); + + -- Inherit class_wide type of full_base in case the partial view was + -- not tagged. Otherwise it has already been created when the private + -- subtype was analyzed. + + if No (Class_Wide_Type (Full)) then + Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); + end if; -- If this is a subtype of a protected or task type, constrain its -- corresponding record, unless this is a subtype without constraints,