From patchwork Thu Oct 21 13:18:08 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 68605 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 F22F0B70EE for ; Fri, 22 Oct 2010 00:18:25 +1100 (EST) Received: (qmail 28078 invoked by alias); 21 Oct 2010 13:18:21 -0000 Received: (qmail 28058 invoked by uid 22791); 21 Oct 2010 13:18:18 -0000 X-SWARE-Spam-Status: No, hits=-1.5 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; Thu, 21 Oct 2010 13:18:12 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id B39CBCB0231; Thu, 21 Oct 2010 15:18:09 +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 5qcafbuGQ3Io; Thu, 21 Oct 2010 15:18:09 +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 8751CCB0212; Thu, 21 Oct 2010 15:18:09 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 63C2AD9BB5; Thu, 21 Oct 2010 15:18:09 +0200 (CEST) Date: Thu, 21 Oct 2010 15:18:08 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Thomas Quinot Subject: [Ada] Illegal tagged completion of private type with discriminant and default Message-ID: <20101021131808.GA13417@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 When an untagged private type declaration has a discriminant with default expression, its completion cannot be a tagged type declaration, because a tagged type can't have such a discriminant (3.7(9.1/2)). This change adds missing circuitry to detect this case and reject the compilation. The following compilation must fail with the indicated error: $ gcc -c bad_tagged_completion_disc_default.ads bad_tagged_completion_disc_defaults.ads:5:28: discriminants of tagged type cannot have defaults package Bad_Tagged_Completion_Disc_Defaults is type T (L : Integer) is tagged null record; type DT (L : Integer := 0) is private; private type DT (L : Integer := 0) is new T (L => L) with null record; end Bad_Tagged_Completion_Disc_Defaults; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-21 Thomas Quinot * sem_ch3.adb (Check_Or_Process_Discriminant): Reject illegal attempt to provide a tagged full view as the completion of an untagged partial view if the partial view has a discriminant with default. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 165766) +++ sem_ch3.adb (working copy) @@ -284,9 +284,11 @@ package body Sem_Ch3 is (N : Node_Id; T : Entity_Id; Prev : Entity_Id := Empty); - -- If T is the full declaration of an incomplete or private type, check the - -- conformance of the discriminants, otherwise process them. Prev is the - -- entity of the partial declaration, if any. + -- If N is the full declaration of the completion T of an incomplete or + -- private type, check its discriminants (which are already known to be + -- conformant with those of the partial view, see Find_Type_Name), + -- otherwise process them. Prev is the entity of the partial declaration, + -- if any. procedure Check_Real_Bound (Bound : Node_Id); -- Check given bound for being of real type and static. If not, post an @@ -9589,7 +9591,9 @@ package body Sem_Ch3 is -- If an incomplete or private type declaration was already given for the -- type, the discriminants may have already been processed if they were -- present on the incomplete declaration. In this case a full conformance - -- check is performed otherwise just process them. + -- check has been performed in Find_Type_Name, and we then recheck here + -- some properties that can't be checked on the partial view alone. + -- Otherwise we call Process_Discriminants. procedure Check_Or_Process_Discriminants (N : Node_Id; @@ -9599,19 +9603,46 @@ package body Sem_Ch3 is begin if Has_Discriminants (T) then - -- Make the discriminants visible to component declarations + -- Discriminants are already set on T if they were already present + -- on the partial view. Make them visible to component declarations. declare D : Entity_Id; - Prev : Entity_Id; + -- Discriminant on T (full view) referencing expression on partial + -- view. + + Prev_D : Entity_Id; + -- Entity of corresponding discriminant on partial view + New_D : Node_Id; + -- Discriminant specification for full view, expression is the + -- syntactic copy on full view (which has been checked for + -- conformance with partial view), only used here to post error + -- message. begin D := First_Discriminant (T); + New_D := First (Discriminant_Specifications (N)); + while Present (D) loop - Prev := Current_Entity (D); + Prev_D := Current_Entity (D); Set_Current_Entity (D); Set_Is_Immediately_Visible (D); - Set_Homonym (D, Prev); + Set_Homonym (D, Prev_D); + + -- Handle the case where there is an untagged partial view and + -- the full view is tagged: must disallow discriminants with + -- defaults. However suppress the error here if it was already + -- reported on the default expression of the partial view. + + if Is_Tagged_Type (T) + and then Present (Expression (Parent (D))) + and then not Error_Posted (Expression (Parent (D))) + then + Error_Msg_N + ("discriminants of tagged type " + & "cannot have defaults", + Expression (New_D)); + end if; -- Ada 2005 (AI-230): Access discriminant allowed in -- non-limited record types. @@ -9625,6 +9656,7 @@ package body Sem_Ch3 is end if; Next_Discriminant (D); + Next (New_D); end loop; end; @@ -16354,13 +16386,18 @@ package body Sem_Ch3 is ("discriminant defaults not allowed for formal type", Expression (Discr)); - -- Tagged types declarations cannot have defaulted discriminants, - -- but an untagged private type with defaulted discriminants can - -- have a tagged completion. - elsif Is_Tagged_Type (Current_Scope) - and then Comes_From_Source (N) + and then Comes_From_Source (N) then + -- Note: see also similar test in Check_Or_Process_ + -- Discriminants, to handle the (illegal) case of the + -- completion of an untagged view with discriminants + -- with defaults by a tagged full view. We skip the check if + -- Discr does not come from source to account for the case of + -- an untagged derived type providing defaults for a renamed + -- discriminant from a private nontagged ancestor with a tagged + -- full view (ACATS B460006). + Error_Msg_N ("discriminants of tagged type cannot have defaults", Expression (Discr));