From patchwork Thu Aug 1 15:17:23 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1967861 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=kPuc+aP0; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.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 ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4WZY8248g5z1ybV for ; Fri, 2 Aug 2024 01:40:34 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id C040F3865C24 for ; Thu, 1 Aug 2024 15:40:32 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x436.google.com (mail-wr1-x436.google.com [IPv6:2a00:1450:4864:20::436]) by sourceware.org (Postfix) with ESMTPS id 628BF3861009 for ; Thu, 1 Aug 2024 15:18:23 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 628BF3861009 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 628BF3861009 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::436 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1722525508; cv=none; b=dOjHcLGTpchMxbUjJlW8w+sQL7cuItKbgRZK2RC2p+BxxPnrk7e1OpxWUQgdzPsfyu5jzaxrcSaI1vSn+SL87fE9KgH4sTM25mm7ya3RuoTCJXlD09+VIhvp/nndWXsyQtz9EhrrcZ7Iv9ScZuD3XXC5+2uAd3oifMOQkK+ORNM= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1722525508; c=relaxed/simple; bh=BJyBfDUTwuJ/A1cmbBjW+DDfpVtYHb3xGvsOcyatgyw=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=X8VdLjjn13YgR72gHZpecGFfpwFd6NHahNuWyoZBTqmTuJSs3yYr+bvobi98qKPL+lIrT5CqB7MTgXg4th+Ho9ltOKyUcW51PR8+0nbT8nIOPl6QbWCe5VT37XLJapWBD8LppM5nfCLPZJSSvKk733RRTI3i6QXN/NvSxum6yB4= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x436.google.com with SMTP id ffacd0b85a97d-3687fb526b9so3455660f8f.0 for ; Thu, 01 Aug 2024 08:18:23 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1722525502; x=1723130302; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=GnM7NwMPpnDctHukdId8mkA4adCr1jbUGR5ZxehyZI0=; b=kPuc+aP00C9cMklCHM9a7pasK+7XheyJjEw/V1fapvUxH4IQZlgZ/8KMi9HSTskeBi GNURKU160NKOaxjG1ondtamMnEmWgIFDDJ4mXlRI299OAni9DCM7BEhCBGNQ41+/MahV GmpkYZR+XNrwlrLns7SvMHjoFGCLvWHsy/OD0O+WMksett55WGnyKiPJce3VhRf5y2BW sqX8DJckkvrcYlAEP+RBskFDN5hRlrA1Cridpir8AZgp86Q9jBfzP17jwIevX9225TxW xehBZnsvSSgvmvyN2lItlWIn4BkYO7UPDw/kOYy9k+zPT5uh4Ho6lIgh9fcWBp3GZHRO Vykg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1722525502; x=1723130302; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=GnM7NwMPpnDctHukdId8mkA4adCr1jbUGR5ZxehyZI0=; b=o+iiZkqS52OFhMqtydFTmAv9gaBrpms2SfMSrxlwzm9+twNcPqq4zl0brJ1lCJkOIV Ms1P7BokkMNVKPvyf5cXMs3FKSP1tmM9xdSbajXNhgb3Omb9hK0O2c/p+hruYZTfR0vy oxOEf28/a3Js3uV+lRj4Sc3MNmIGU4DqffPUIDcbGaqkkfaA1IZBN1gJ72OdBfrELYhg jCe65qhtfXgtg5ogLZpcVHLZgu08QHlXUPPMrti2ZlrnwTIzp88PBhUt9OQLNUlXm2H/ I138tf9ri8OlmXf789hEaKs3R3cLN/azVGvQS05QJVyP+3G6lW+uDskXhVc7i8mZPT4l 5SaQ== X-Gm-Message-State: AOJu0YzktStkmjRG9DRoMSnmhwdx10QsC29/6BXH/dsBov6ej3IATAdB rGMwo1Kq0bHSWCBqNYxqxWbvinehf7/eh5HnyZlZZkisjFXDV+sTQuJHHJRel7Ys/Pw2p1lRd3j zLg== X-Google-Smtp-Source: AGHT+IGq/89rJEteW5NcxzHcjPAEh1fTXjcEdDFyDl4yRJEU2RSjH45UAVji69sFcRZXCY1lZSAigQ== X-Received: by 2002:adf:b195:0:b0:368:5b78:c92e with SMTP id ffacd0b85a97d-36bbc0e468dmr118648f8f.24.1722525501975; Thu, 01 Aug 2024 08:18:21 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:b6aa:4751:9ea1:da1e]) by smtp.gmail.com with ESMTPSA id ffacd0b85a97d-36b36857fdesm20065995f8f.75.2024.08.01.08.18.21 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 01 Aug 2024 08:18:21 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [COMMITTED 15/30] ada: Check default value aspects before resolving their expressions Date: Thu, 1 Aug 2024 17:17:23 +0200 Message-ID: <20240801151738.400796-15-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240801151738.400796-1-poulhies@adacore.com> References: <20240801151738.400796-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Piotr Trojanek Check expressions of aspects Default_Value and Default_Component_Value for references to the annotated types just before resolving these expressions. This patch fixes both an asymmetry in processing of those aspects and adds a missing check in GNATprove on aspect Default_Component_Value. gcc/ada/ * sem_ch13.adb (Check_Aspect_Too_Late): Move routine to top-level. (Resolve_Aspect_Expressions): Check aspects Default_Value and Default_Component_Value before resolving their expressions. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch13.adb | 229 ++++++++++++++++++++++--------------------- 1 file changed, 117 insertions(+), 112 deletions(-) diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 3784f831410..b903381e5de 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -160,6 +160,14 @@ package body Sem_Ch13 is -- Performs the processing of an aspect at the freeze point. ASN is the -- N_Aspect_Specification node for the aspect. + procedure Check_Aspect_Too_Late (N : Node_Id); + -- This procedure is similar to Rep_Item_Too_Late for representation + -- aspects that apply to type and that do not have a corresponding pragma. + -- + -- Used to check in particular that the expression associated with aspect + -- node N for the given type (entity) of the aspect does not appear too + -- late according to the rules in RM 13.1(9) and 13.1(10). + procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id); -- Called if both Storage_Pool and Storage_Size attribute definition -- clauses (SP and SS) are present for entity Ent. Issue error message. @@ -967,14 +975,6 @@ package body Sem_Ch13 is -- This routine analyzes an Aspect_Default_[Component_]Value denoted by -- the aspect specification node ASN. - procedure Check_Aspect_Too_Late (N : Node_Id); - -- This procedure is similar to Rep_Item_Too_Late for representation - -- aspects that apply to type and that do not have a corresponding - -- pragma. - -- Used to check in particular that the expression associated with - -- aspect node N for the given type (entity) of the aspect does not - -- appear too late according to the rules in RM 13.1(9) and 13.1(10). - procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id); -- Given an aspect specification node ASN whose expression is an -- optional Boolean, this routines creates the corresponding pragma @@ -1000,110 +1000,6 @@ package body Sem_Ch13 is Check_Aspect_Too_Late (ASN); end Analyze_Aspect_Default_Value; - --------------------------- - -- Check_Aspect_Too_Late -- - --------------------------- - - procedure Check_Aspect_Too_Late (N : Node_Id) is - Typ : constant Entity_Id := Entity (N); - Expr : constant Node_Id := Expression (N); - - function Find_Type_Reference - (Typ : Entity_Id; Expr : Node_Id) return Boolean; - -- Return True if a reference to type Typ is found in the expression - -- Expr. - - ------------------------- - -- Find_Type_Reference -- - ------------------------- - - function Find_Type_Reference - (Typ : Entity_Id; Expr : Node_Id) return Boolean - is - function Find_Type (N : Node_Id) return Traverse_Result; - -- Set Found to True if N refers to Typ - - --------------- - -- Find_Type -- - --------------- - - function Find_Type (N : Node_Id) return Traverse_Result is - begin - if N = Typ - or else (Nkind (N) in N_Identifier | N_Expanded_Name - and then Present (Entity (N)) - and then Entity (N) = Typ) - then - return Abandon; - else - return OK; - end if; - end Find_Type; - - function Search_Type_Reference is new Traverse_Func (Find_Type); - - begin - return Search_Type_Reference (Expr) = Abandon; - end Find_Type_Reference; - - Parent_Type : Entity_Id; - - Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; - Save_Must_Not_Freeze : constant Boolean := Must_Not_Freeze (Expr); - - begin - -- Ensure Expr is analyzed so that e.g. all types are properly - -- resolved for Find_Type_Reference. We preanalyze this expression - -- (to avoid expansion), handle it as a spec expression (like default - -- expression), disable freezing and skip resolution (to not fold - -- type self-references, e.g. T'Last). - - In_Spec_Expression := True; - Set_Must_Not_Freeze (Expr); - - Preanalyze (Expr); - - Set_Must_Not_Freeze (Expr, Save_Must_Not_Freeze); - In_Spec_Expression := Save_In_Spec_Expression; - - -- A self-referential aspect is illegal if it forces freezing the - -- entity before the corresponding aspect has been analyzed. - - if Find_Type_Reference (Typ, Expr) then - Error_Msg_NE - ("aspect specification causes premature freezing of&", N, Typ); - end if; - - -- For representation aspects, check for case of untagged derived - -- type whose parent either has primitive operations (pre Ada 2022), - -- or is a by-reference type (RM 13.1(10)). - -- Strictly speaking the check also applies to Ada 2012 but it is - -- really too constraining for existing code already, so relax it. - -- ??? Confirming aspects should be allowed here. - - if Is_Representation_Aspect (Get_Aspect_Id (N)) - and then Is_Derived_Type (Typ) - and then not Is_Tagged_Type (Typ) - then - Parent_Type := Etype (Base_Type (Typ)); - - if Ada_Version <= Ada_2012 - and then Has_Primitive_Operations (Parent_Type) - then - Error_Msg_N - ("|representation aspect not permitted before Ada 2022: " & - "use -gnat2022!", N); - Error_Msg_NE - ("\parent type & has primitive operations!", N, Parent_Type); - - elsif Is_By_Reference_Type (Parent_Type) then - No_Type_Rep_Item (N); - Error_Msg_NE - ("\parent type & is a by-reference type!", N, Parent_Type); - end if; - end if; - end Check_Aspect_Too_Late; - ------------------------------------- -- Make_Pragma_From_Boolean_Aspect -- ------------------------------------- @@ -11637,6 +11533,110 @@ package body Sem_Ch13 is end if; end Check_Aspect_At_Freeze_Point; + --------------------------- + -- Check_Aspect_Too_Late -- + --------------------------- + + procedure Check_Aspect_Too_Late (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Expr : constant Node_Id := Expression (N); + + function Find_Type_Reference + (Typ : Entity_Id; Expr : Node_Id) return Boolean; + -- Return True if a reference to type Typ is found in the expression + -- Expr. + + ------------------------- + -- Find_Type_Reference -- + ------------------------- + + function Find_Type_Reference + (Typ : Entity_Id; Expr : Node_Id) return Boolean + is + function Find_Type (N : Node_Id) return Traverse_Result; + -- Set Found to True if N refers to Typ + + --------------- + -- Find_Type -- + --------------- + + function Find_Type (N : Node_Id) return Traverse_Result is + begin + if N = Typ + or else (Nkind (N) in N_Identifier | N_Expanded_Name + and then Present (Entity (N)) + and then Entity (N) = Typ) + then + return Abandon; + else + return OK; + end if; + end Find_Type; + + function Search_Type_Reference is new Traverse_Func (Find_Type); + + begin + return Search_Type_Reference (Expr) = Abandon; + end Find_Type_Reference; + + Parent_Type : Entity_Id; + + Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; + Save_Must_Not_Freeze : constant Boolean := Must_Not_Freeze (Expr); + + begin + -- Ensure Expr is analyzed so that e.g. all types are properly + -- resolved for Find_Type_Reference. We preanalyze this expression + -- (to avoid expansion), handle it as a spec expression (like default + -- expression), disable freezing and skip resolution (to not fold + -- type self-references, e.g. T'Last). + + In_Spec_Expression := True; + Set_Must_Not_Freeze (Expr); + + Preanalyze (Expr); + + Set_Must_Not_Freeze (Expr, Save_Must_Not_Freeze); + In_Spec_Expression := Save_In_Spec_Expression; + + -- A self-referential aspect is illegal if it forces freezing the + -- entity before the corresponding aspect has been analyzed. + + if Find_Type_Reference (Typ, Expr) then + Error_Msg_NE + ("aspect specification causes premature freezing of&", N, Typ); + end if; + + -- For representation aspects, check for case of untagged derived + -- type whose parent either has primitive operations (pre Ada 2022), + -- or is a by-reference type (RM 13.1(10)). + -- Strictly speaking the check also applies to Ada 2012 but it is + -- really too constraining for existing code already, so relax it. + -- ??? Confirming aspects should be allowed here. + + if Is_Representation_Aspect (Get_Aspect_Id (N)) + and then Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + Parent_Type := Etype (Base_Type (Typ)); + + if Ada_Version <= Ada_2012 + and then Has_Primitive_Operations (Parent_Type) + then + Error_Msg_N + ("|representation aspect not permitted before Ada 2022: " & + "use -gnat2022!", N); + Error_Msg_NE + ("\parent type & has primitive operations!", N, Parent_Type); + + elsif Is_By_Reference_Type (Parent_Type) then + No_Type_Rep_Item (N); + Error_Msg_NE + ("\parent type & is a by-reference type!", N, Parent_Type); + end if; + end if; + end Check_Aspect_Too_Late; + ----------------------------------- -- Check_Constant_Address_Clause -- ----------------------------------- @@ -16064,8 +16064,13 @@ package body Sem_Ch13 is -- before the actual freeze point. when Aspect_Default_Value => + Check_Aspect_Too_Late (ASN); Preanalyze_Spec_Expression (Expr, E); + when Aspect_Default_Component_Value => + Check_Aspect_Too_Late (ASN); + Preanalyze_Spec_Expression (Expr, Component_Type (E)); + when Aspect_CPU | Aspect_Interrupt_Priority | Aspect_Priority