From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wr1-x42c.google.com (mail-wr1-x42c.google.com [IPv6:2a00:1450:4864:20::42c]) by sourceware.org (Postfix) with ESMTPS id 1A5233858419 for ; Thu, 29 Sep 2022 09:11:11 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 1A5233858419 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-wr1-x42c.google.com with SMTP id r6so1138301wru.8 for ; Thu, 29 Sep 2022 02:11:11 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date; bh=VerHT4pZ2yaS2f7nsJm8wtuS0uXcOXd6FmlADiVQk9o=; b=MMMrldifavym0KBpQqFU7mnOqxR5xowAaHXGezuTv2+7QJwp/PeZC3XfjA44Elr8cO J3YglJdBbtvVo5kDZROd49m0yR+uwFCwPTQqwBwKvEDK7SBYQrK9308ng5SDE+MDexv/ shTpmZP8va9/U7kyz0A4gXmfRj76j+ZCmoXRXkNZ8MLLCpWIAecXwy8ZQB28C6wqsrCy j7joFwrh+KUgtM/OK9NcdNydtfF+KJQo57Olr4bcbKmBZUdk/RNiYDAmXsUuXmmznQDU /o5yH69zckKYGskDk0oCWisc8kp85pKNWMJd7ogYQZnaJBFYHA0qBBX4PNTbuO0+9UZj kIlQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date; bh=VerHT4pZ2yaS2f7nsJm8wtuS0uXcOXd6FmlADiVQk9o=; b=ODtKhTsZohWK1XOyEGGHGGo9GZRPba8EcNQaT46yju+D9PI0vlgoLEM/ha65cNpGoz ybs7bY7yOp3ANXFOYNDpBZkPLbGDpx+fn9Q74Wok0b1mTcq8/BlRcgfDYDnR4h4z6Cbp ygqOd1wXxW9XSUmLzz27uqqkS1xjm3BYHs85rzN//W0J7Z4/lDLkz0qBA1w0rRzl6j/6 9VXvLyIS5snRxkC5yPBF067sRG3DdSF7dB+LnVIZg4egwZ/mTpjoUdxlNGCELO+0ttQ+ Fh6vTisONzLCHbhIQYoaEboaZdYQpy4Z+msQguCglAkNv6j8v6xoSOLfiZDEmSRQhtvq jyEg== X-Gm-Message-State: ACrzQf39P+IFIvD+SEUkquV3zMiI3V/QVAK/N4PzBMYEG2GHQ26cVkjd 5FEU6TjDWpifJ+g3JcRf1+rVYmpenKRvEQ== X-Google-Smtp-Source: AMsMyM4YiSg9T+Gna8vbU3uEwIVfE0g94RcNYKrb+7GSSZr0mcSTqgqKcEQZRkG/mdsGd52wof11DQ== X-Received: by 2002:adf:ce03:0:b0:22c:cccf:cbd7 with SMTP id p3-20020adfce03000000b0022ccccfcbd7mr1379766wrn.424.1664442669888; Thu, 29 Sep 2022 02:11:09 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id u7-20020adfdd47000000b00228655a5c8fsm6395008wrm.28.2022.09.29.02.11.09 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 29 Sep 2022 02:11:09 -0700 (PDT) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITED] ada: Further tweak new expansion of contracts Date: Thu, 29 Sep 2022 11:11:06 +0200 Message-Id: <20220929091106.359762-1-poulhies@adacore.com> X-Mailer: git-send-email 2.25.1 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-13.1 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,GIT_PATCH_0,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 List-Id: From: Eric Botcazou The original extended return statement is mandatory for functions whose result type is limited in Ada 2005 and later. gcc/ada/ * contracts.adb (Build_Subprogram_Contract_Wrapper): Put back the extended return statement if the result type is built-in-place. * sem_attr.adb (Analyze_Attribute_Old_Result): Also expect an extended return statement. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/contracts.adb | 46 ++++++++++++++++++++++++++++++++++++++++--- gcc/ada/sem_attr.adb | 8 +++++--- 2 files changed, 48 insertions(+), 6 deletions(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index dd573d374c6..a300d739eff 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -30,6 +30,7 @@ with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; +with Exp_Ch6; use Exp_Ch6; with Exp_Prag; use Exp_Prag; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -1609,7 +1610,7 @@ package body Contracts is -- preserving the result for the purpose of evaluating postconditions, -- contracts, type invariants, etc. - -- In the case of a function, generate: + -- In the case of a regular function, generate: -- -- function Original_Func (X : in out Integer) return Typ is -- @@ -1641,7 +1642,27 @@ package body Contracts is -- Note that an extended return statement does not yield the same result -- because the copy of the return object is not elided by GNAT for now. - -- Or, in the case of a procedure: + -- Or else, in the case of a BIP function, generate: + + -- function Original_Func (X : in out Integer) return Typ is + -- + -- + -- + -- function _Wrapped_Statements return Typ is + -- + -- begin + -- + -- end; + -- + -- begin + -- return + -- Result_Obj : constant Typ := _Wrapped_Statements + -- do + -- + -- end return; + -- end; + + -- Or else, in the case of a procedure, generate: -- -- procedure Original_Proc (X : in out Integer) is -- @@ -1657,7 +1678,6 @@ package body Contracts is -- _Wrapped_Statements; -- -- end; - -- -- Create Identifier @@ -1716,6 +1736,26 @@ package body Contracts is Set_Statements (Handled_Statement_Sequence (Body_Decl), Stmts); + -- Generate the post-execution statements and the extended return + -- when the subprogram being wrapped is a BIP function. + + elsif Is_Build_In_Place_Result_Type (Ret_Type) then + Set_Statements (Handled_Statement_Sequence (Body_Decl), New_List ( + Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Ret_Type, Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Wrapper_Id, Loc)))), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)))); + -- Declare a renaming of the result of the call to the wrapper and -- append a return of the result of the call when the subprogram is -- a function, after manually removing the side effects. Note that diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 0c88be71b94..d27d956a1e7 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1454,10 +1454,12 @@ package body Sem_Attr is Subp_Decl := Find_Related_Declaration_Or_Body (Prag); end if; - -- 'Old objects appear in block statements as part of the expansion - -- of contract wrappers. + -- 'Old objects appear in block and extended return statements as + -- part of the expansion of contract wrappers. - if Nkind (Subp_Decl) = N_Block_Statement then + if Nkind (Subp_Decl) in N_Block_Statement + | N_Extended_Return_Statement + then Subp_Decl := Parent (Parent (Subp_Decl)); end if; -- 2.25.1