From patchwork Tue Jun 15 10:20:51 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1492096 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4G449f606fz9sTD for ; Tue, 15 Jun 2021 20:21:42 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 6B9E9398B173 for ; Tue, 15 Jun 2021 10:21:40 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from rock.gnat.com (rock.gnat.com [205.232.38.15]) by sourceware.org (Postfix) with ESMTPS id 239A2398B174 for ; Tue, 15 Jun 2021 10:20:52 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 239A2398B174 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 03D07117AD0; Tue, 15 Jun 2021 06:20:52 -0400 (EDT) X-Virus-Scanned: Debian amavisd-new at gnat.com Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id 5DcWlTDPr1wZ; Tue, 15 Jun 2021 06:20:51 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id E2D3E117985; Tue, 15 Jun 2021 06:20:51 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id E1CA31CA; Tue, 15 Jun 2021 06:20:51 -0400 (EDT) Date: Tue, 15 Jun 2021 06:20:51 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] Avoid inappropriate error messages regarding aggregates and variant parts Message-ID: <20210615102051.GA2546@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-9.5 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_DMARC_STATUS, SPAM_BODY, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: Steve Baird Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" An aggregate of a type that has a variant part has to satisfy certain rules about the discriminant value governing that variant part. If these rules are violated, then the front end typically emits a message associated with the discriminant value. However, this is not useful in the case where the discriminant value does not come from the aggregate. This can occur if we have a discriminated tagged type with a variant part, a type extension that declares a new discriminant (and supplies a value for the old discriminant), and (later) an aggregate of the extension type. This case was not being handled correctly in an Ada_2020-only case. One might reasonably wonder whether this decision to not generate an error message could lead to problems with incorrectly accepting some unit that ought to be rejected; the answer is quite the opposite - this error message suppression is needed for correctness in order to avoid rejecting units that ought to be accepted. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_util.adb (Gather_Components): Factor the test that was already being used to govern emitting a pre-Ada_2020 error message into an expression function, OK_Scope_For_Discrim_Value_Error_Messages. Call that new function in two places: the point where the same test was being performed previously, and in governing emission of a newer Ada_2020 error message. In both cases, the out-mode parameter Gather_Components.Report_Errors is set to True even if no error messages are generated within Gather_Components. * sem_util.ads: Correct a comment. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9990,6 +9990,18 @@ package body Sem_Util is Discrim_Value : Node_Id; Discrim_Value_Subtype : Node_Id; Discrim_Value_Status : Discriminant_Value_Status := Bad; + + function OK_Scope_For_Discrim_Value_Error_Messages return Boolean is + (Scope (Original_Record_Component + (Entity (First (Choices (Assoc))))) = Typ); + -- Used to avoid generating error messages having a source position + -- which refers to somewhere (e.g., a discriminant value in a derived + -- tagged type declaration) unrelated to the offending construct. This + -- is required for correctness - clients of Gather_Components such as + -- Sem_Ch3.Create_Constrained_Components depend on this function + -- returning True while processing semantically correct examples; + -- generating an error message in this case would be wrong. + begin Report_Errors := False; @@ -10178,9 +10190,7 @@ package body Sem_Util is -- every value of that subtype (and there must be at least one) -- selects the same variant. - if Scope (Original_Record_Component - ((Entity (First (Choices (Assoc)))))) = Typ - then + if OK_Scope_For_Discrim_Value_Error_Messages then if Ada_Version >= Ada_2020 then Error_Msg_FE ("value for discriminant & must be static or " & @@ -10299,10 +10309,12 @@ package body Sem_Util is (Subset => Discrim_Value_Subtype_Intervals, Of_Set => Variant_Intervals) then - Error_Msg_NE - ("no single variant is associated with all values of " & - "the subtype of discriminant value &", - Discrim_Value, Discrim); + if OK_Scope_For_Discrim_Value_Error_Messages then + Error_Msg_NE + ("no single variant is associated with all values of " & + "the subtype of discriminant value &", + Discrim_Value, Discrim); + end if; Report_Errors := True; return; end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1079,7 +1079,8 @@ package Sem_Util is -- to its tail. -- -- Report_Errors is set to True if the values of the discriminants are - -- non-static. + -- insufficiently static (see body for details of what that means). + -- -- Allow_Compile_Time if set to True, allows compile time known values in -- Governed_By expressions in addition to static expressions.