From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2071) id AB5103852769; Fri, 1 Dec 2023 21:21:38 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org AB5103852769 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1701465698; bh=c8nGxQhxAb7rnIEild02EFtvi5ZDdNn/Q5F7V3ueBUk=; h=From:To:Subject:Date:From; b=VijgBj/lzDy6YQMQCtOqfiR3XTOudLBxOGYF22rRLo3sdRQaccxjSA+5sufGqkUsS eBQ9ZiEuAKKKrJ8iFTLaXHD1ENM7Nwevpxp7y0cAj8zbUete59sVDh0j0YEHAIV/+i hIPKVo5HAS0Pg2Rq81AtMI3wmdg4UK3rLLCcJl4I= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Harald Anlauf To: gcc-cvs@gcc.gnu.org Subject: [gcc r14-6066] Fortran: copy-out for possibly missing OPTIONAL CLASS arguments [PR112772] X-Act-Checkin: gcc X-Git-Author: Harald Anlauf X-Git-Refname: refs/heads/master X-Git-Oldrev: 37e6c9bd99575752b7122c5d76aa2cf021deb93c X-Git-Newrev: 7317275497e10c4a0fb3fbaa6ca87f3463ac124d Message-Id: <20231201212138.AB5103852769@sourceware.org> Date: Fri, 1 Dec 2023 21:21:38 +0000 (GMT) List-Id: https://gcc.gnu.org/g:7317275497e10c4a0fb3fbaa6ca87f3463ac124d commit r14-6066-g7317275497e10c4a0fb3fbaa6ca87f3463ac124d Author: Harald Anlauf Date: Thu Nov 30 21:53:21 2023 +0100 Fortran: copy-out for possibly missing OPTIONAL CLASS arguments [PR112772] gcc/fortran/ChangeLog: PR fortran/112772 * trans-expr.cc (gfc_conv_class_to_class): Make copy-out conditional on the presence of an OPTIONAL CLASS argument passed to an OPTIONAL CLASS dummy. gcc/testsuite/ChangeLog: PR fortran/112772 * gfortran.dg/missing_optional_dummy_7.f90: New test. Diff: --- gcc/fortran/trans-expr.cc | 9 +++ .../gfortran.dg/missing_optional_dummy_7.f90 | 64 ++++++++++++++++++++++ 2 files changed, 73 insertions(+) diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index bfe9996ced6..6a47af39c57 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1365,6 +1365,15 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tmp = build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, tmp2); gfc_add_expr_to_block (&parmse->pre, tmp); + + if (!elemental && full_array && copyback) + { + tmp2 = build_empty_stmt (input_location); + tmp = gfc_finish_block (&parmse->post); + tmp = build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, tmp2); + gfc_add_expr_to_block (&parmse->post, tmp); + } } else gfc_add_block_to_block (&parmse->pre, &block); diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_7.f90 b/gcc/testsuite/gfortran.dg/missing_optional_dummy_7.f90 new file mode 100644 index 00000000000..ad9ecd8f2b6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_7.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! PR fortran/112772 - test absent OPTIONAL, ALLOCATABLE/POINTER class dummies + +program main + implicit none + type t + end type t + call test_c_a () + call test_u_a () + call test_c_p () + call test_u_p () +contains + ! class, allocatable + subroutine test_c_a (msg1) + class(t), optional, allocatable :: msg1(:) + if (present (msg1)) stop 1 + call assert_c_a () + call assert_c_a (msg1) + end + + subroutine assert_c_a (msg2) + class(t), optional, allocatable :: msg2(:) + if (present (msg2)) stop 2 + end + + ! unlimited polymorphic, allocatable + subroutine test_u_a (msg1) + class(*), optional, allocatable :: msg1(:) + if (present (msg1)) stop 3 + call assert_u_a () + call assert_u_a (msg1) + end + + subroutine assert_u_a (msg2) + class(*), optional, allocatable :: msg2(:) + if (present (msg2)) stop 4 + end + + ! class, pointer + subroutine test_c_p (msg1) + class(t), optional, pointer :: msg1(:) + if (present (msg1)) stop 5 + call assert_c_p () + call assert_c_p (msg1) + end + + subroutine assert_c_p (msg2) + class(t), optional, pointer :: msg2(:) + if (present (msg2)) stop 6 + end + + ! unlimited polymorphic, pointer + subroutine test_u_p (msg1) + class(*), optional, pointer :: msg1(:) + if (present (msg1)) stop 7 + call assert_u_p () + call assert_u_p (msg1) + end + + subroutine assert_u_p (msg2) + class(*), optional, pointer :: msg2(:) + if (present (msg2)) stop 8 + end +end