From patchwork Thu Jul 11 19:55:58 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1959508 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; unprotected) header.d=orange.fr header.i=@orange.fr header.a=rsa-sha256 header.s=t20230301 header.b=pB4epenz; 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 4WKlqJ0tq2z1xpd for ; Fri, 12 Jul 2024 05:56:42 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id AAF943875470 for ; Thu, 11 Jul 2024 19:56:40 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (msa-217.smtpout.orange.fr [193.252.23.217]) by sourceware.org (Postfix) with ESMTPS id 9C694385DDE6; Thu, 11 Jul 2024 19:56:05 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 9C694385DDE6 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=orange.fr Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=orange.fr ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 9C694385DDE6 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=193.252.23.217 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1720727769; cv=none; b=MJRCWbZim9oSDfUhyTksGZFsr+4m0GvJogHyYio7m4t7t/YXg3Y10Nu8AWZqTqWX1lOmv/OjLERvh6aeOrmROQRziIjdFJ4jRZc3qHAUzUs1E/bIa4sJUyW0jCdIoPLjo6HLAbTyYTPVb7ZpRKp8P26jtRuOuTRNA+87pFRFIwQ= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1720727769; c=relaxed/simple; bh=Oj+bvvHN9mSs3fYpxeEmxW9IbNFwVT1GW3OB/2O0XsY=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=UAVSRHhVnygfZKs2gR8V6yXgaa5ZP1HfoTjlMSaX6Pd5AaNii0Hd2NxoqWlIRYR6yz0GMWdhsgZWto17DjIsLslvw+tgvxwcLfmjX34AIAGtGrKtAN6xzMxlYeviW7CzaIYEOoQcrP0MQl8aTGIUiBnrv/vPFMGIyf3riyrOkQk= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id RztWsTDBmqvisRztbs7aKf; Thu, 11 Jul 2024 21:56:04 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1720727764; bh=/ruphmXLPkDCLJdVyFZLAciuRVdO1AkAfbLPTLpClnU=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=pB4epenzqXmCvVRZHHY09lco3xkxXkcGfG/amOX+VOvjsSLLI1mLgcwegtD1ufK0t HZwik2jK3jKtFbgM3RIbd/z4ntKapMPX367+HsK7QdmYC9hw8NnTupG69sjnEymdF9 R5D8GURo8ddELSzwojzREGrl3bcdUsDBljVRDurkWN92RYj+xRxY5UJ7a25e0mpwHU 939FLYLjetQ0TVtX8TVb0LvucluQT8klmKYNxK4AjWfvBbtLFSpN2PBfUXfBUHUBW7 khhOV59d9RWwF1TX+D//N7/OXOiLwR2VqObRrPs3BOxnT9qsGUZ/+23FVx73XrEo+y yNlr08KYqx04w== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Thu, 11 Jul 2024 21:56:04 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH] fortran: Factor the evaluation of MINLOCK/MAXLOC's BACK argument Date: Thu, 11 Jul 2024 21:55:58 +0200 Message-ID: <20240711195558.93923-1-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 MIME-Version: 1.0 X-Spam-Status: No, score=-10.9 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, 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: Mikael Morin Hello, I discovered this while testing the inline MINLOC/MAXLOC (aka PR90608) patches. Regression tested on x86_64-linux. OK for master? -- 8< -- Move the evaluation of the BACK argument out of the loop in the inline code generated for MINLOC or MAXLOC. For that, add a new (scalar) element associated with BACK to the scalarization loop chain, evaluate the argument with the context of that element, and let the scalarizer do its job. The problem was not only a missed optimisation, but also a wrong code one in the cases where the expression associated with BACK is not free of side-effects, making multiple evaluations observable. The new tests check the evaluation count of the BACK argument, and try to cover all the variations (with/out NANs, constant or unknown shape, absent or scalar or array MASK) supported by the inline implementation of the functions. Care has been taken to not check the case of a constant .FALSE. MASK, for which the evaluation of BACK can be elided. gcc/fortran/ChangeLog: * trans-intrinsic.cc (gfc_conv_intrinsic_minmaxloc): Create a new scalar scalarization chain element if BACK is present. Add it to the loop. Set the scalarization chain before evaluating the argument. gcc/testsuite/ChangeLog: * gfortran.dg/maxloc_5.f90: New test. * gfortran.dg/minloc_5.f90: New test. --- gcc/fortran/trans-intrinsic.cc | 10 + gcc/testsuite/gfortran.dg/maxloc_5.f90 | 257 +++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/minloc_5.f90 | 257 +++++++++++++++++++++++++ 3 files changed, 524 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/maxloc_5.f90 create mode 100644 gcc/testsuite/gfortran.dg/minloc_5.f90 diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 5ea10e84060..cadbd177452 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5325,6 +5325,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_actual_arglist *actual; gfc_ss *arrayss; gfc_ss *maskss; + gfc_ss *backss; gfc_se arrayse; gfc_se maskse; gfc_expr *arrayexpr; @@ -5390,6 +5391,11 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) && maskexpr->symtree->n.sym->attr.dummy && maskexpr->symtree->n.sym->attr.optional; backexpr = actual->next->next->expr; + if (backexpr) + backss = gfc_get_scalar_ss (gfc_ss_terminator, backexpr); + else + backss = nullptr; + nonempty = NULL; if (maskexpr && maskexpr->rank != 0) { @@ -5449,6 +5455,9 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (maskss) gfc_add_ss_to_loop (&loop, maskss); + if (backss) + gfc_add_ss_to_loop (&loop, backss); + gfc_add_ss_to_loop (&loop, arrayss); /* Initialize the loop. */ @@ -5535,6 +5544,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_add_block_to_block (&block, &arrayse.pre); gfc_init_se (&backse, NULL); + backse.ss = backss; gfc_conv_expr_val (&backse, backexpr); gfc_add_block_to_block (&block, &backse.pre); diff --git a/gcc/testsuite/gfortran.dg/maxloc_5.f90 b/gcc/testsuite/gfortran.dg/maxloc_5.f90 new file mode 100644 index 00000000000..5d722450c8f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/maxloc_5.f90 @@ -0,0 +1,257 @@ +! { dg-do run } +! +! Check that the evaluation of MAXLOC's BACK argument is made only once +! before the scalarisation loops. + +program p + implicit none + integer, parameter :: data10(*) = (/ 7, 4, 7, 6, 6, 4, 6, 3, 9, 8 /) + logical, parameter :: mask10(*) = (/ .false., .true., .false., & + .false., .true., .true., & + .true. , .true., .false., & + .false. /) + integer :: calls_count = 0 + call check_int_const_shape + call check_int_const_shape_scalar_mask + call check_int_const_shape_array_mask + call check_int_const_shape_optional_mask_present + call check_int_const_shape_optional_mask_absent + call check_int_const_shape_empty + call check_int_alloc + call check_int_alloc_scalar_mask + call check_int_alloc_array_mask + call check_int_alloc_empty + call check_real_const_shape + call check_real_const_shape_scalar_mask + call check_real_const_shape_array_mask + call check_real_const_shape_optional_mask_present + call check_real_const_shape_optional_mask_absent + call check_real_const_shape_empty + call check_real_alloc + call check_real_alloc_scalar_mask + call check_real_alloc_array_mask + call check_real_alloc_empty +contains + function get_scalar_false() + logical :: get_scalar_false + calls_count = calls_count + 1 + get_scalar_false = .false. + end function + subroutine check_int_const_shape() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 11 + end subroutine + subroutine check_int_const_shape_scalar_mask() + integer :: a(10) + integer :: r + a = data10 + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 18 + end subroutine + subroutine check_int_const_shape_array_mask() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + m = mask10 + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 32 + end subroutine + subroutine call_maxloc_int(r, a, m, b) + integer :: a(:) + logical, optional :: m(:) + logical, optional :: b + integer :: r + r = maxloc(a, dim = 1, mask = m, back = b) + end subroutine + subroutine check_int_const_shape_optional_mask_present() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + m = mask10 + calls_count = 0 + call call_maxloc_int(r, a, m, get_scalar_false()) + if (calls_count /= 1) stop 39 + end subroutine + subroutine check_int_const_shape_optional_mask_absent() + integer :: a(10) + integer :: r + a = data10 + calls_count = 0 + call call_maxloc_int(r, a, b = get_scalar_false()) + if (calls_count /= 1) stop 46 + end subroutine + subroutine check_int_const_shape_empty() + integer :: a(0) + logical :: m(0) + integer :: r + a = (/ integer:: /) + m = (/ logical:: /) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 53 + end subroutine + subroutine check_int_alloc() + integer, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = data10 + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 60 + end subroutine + subroutine check_int_alloc_scalar_mask() + integer, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = data10 + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 67 + end subroutine + subroutine check_int_alloc_array_mask() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(10), m(10)) + a(:) = data10 + m(:) = mask10 + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 81 + end subroutine + subroutine check_int_alloc_empty() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(0), m(0)) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 88 + end subroutine + subroutine check_real_const_shape() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 95 + end subroutine + subroutine check_real_const_shape_scalar_mask() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 102 + end subroutine + subroutine check_real_const_shape_array_mask() + real :: a(10) + logical :: m(10) + integer :: r + a = (/ real:: data10 /) + m = mask10 + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 116 + end subroutine + subroutine call_maxloc_real(r, a, m, b) + real :: a(:) + logical, optional :: m(:) + logical, optional :: b + integer :: r + r = maxloc(a, dim = 1, mask = m, back = b) + end subroutine + subroutine check_real_const_shape_optional_mask_present() + real :: a(10) + logical :: m(10) + integer :: r + a = (/ real:: data10 /) + m = mask10 + calls_count = 0 + call call_maxloc_real(r, a, m, b = get_scalar_false()) + if (calls_count /= 1) stop 123 + end subroutine + subroutine check_real_const_shape_optional_mask_absent() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + call call_maxloc_real(r, a, b = get_scalar_false()) + if (calls_count /= 1) stop 130 + end subroutine + subroutine check_real_const_shape_empty() + real :: a(0) + logical :: m(0) + integer :: r + a = (/ real:: /) + m = (/ logical:: /) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 137 + end subroutine + subroutine check_real_alloc() + real, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = (/ real:: data10 /) + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 144 + end subroutine + subroutine check_real_alloc_scalar_mask() + real, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = (/ real:: data10 /) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 151 + end subroutine + subroutine check_real_alloc_array_mask() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(10), m(10)) + a(:) = (/ real:: data10 /) + m(:) = mask10 + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 165 + end subroutine + subroutine check_real_alloc_empty() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(0), m(0)) + a(:) = (/ real:: /) + m(:) = (/ logical :: /) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 172 + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/minloc_5.f90 b/gcc/testsuite/gfortran.dg/minloc_5.f90 new file mode 100644 index 00000000000..cb2cd008344 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minloc_5.f90 @@ -0,0 +1,257 @@ +! { dg-do run } +! +! Check that the evaluation of MINLOC's BACK argument is made only once +! before the scalarisation loops. + +program p + implicit none + integer, parameter :: data10(*) = (/ 2, 5, 2, 3, 3, 5, 3, 6, 0, 1 /) + logical, parameter :: mask10(*) = (/ .false., .true., .false., & + .false., .true., .true., & + .true. , .true., .false., & + .false. /) + integer :: calls_count = 0 + call check_int_const_shape + call check_int_const_shape_scalar_mask + call check_int_const_shape_array_mask + call check_int_const_shape_optional_mask_present + call check_int_const_shape_optional_mask_absent + call check_int_const_shape_empty + call check_int_alloc + call check_int_alloc_scalar_mask + call check_int_alloc_array_mask + call check_int_alloc_empty + call check_real_const_shape + call check_real_const_shape_scalar_mask + call check_real_const_shape_array_mask + call check_real_const_shape_optional_mask_present + call check_real_const_shape_optional_mask_absent + call check_real_const_shape_empty + call check_real_alloc + call check_real_alloc_scalar_mask + call check_real_alloc_array_mask + call check_real_alloc_empty +contains + function get_scalar_false() + logical :: get_scalar_false + calls_count = calls_count + 1 + get_scalar_false = .false. + end function + subroutine check_int_const_shape() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 11 + end subroutine + subroutine check_int_const_shape_scalar_mask() + integer :: a(10) + integer :: r + a = data10 + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 18 + end subroutine + subroutine check_int_const_shape_array_mask() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + m = mask10 + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 32 + end subroutine + subroutine call_minloc_int(r, a, m, b) + integer :: a(:) + logical, optional :: m(:) + logical, optional :: b + integer :: r + r = minloc(a, dim = 1, mask = m, back = b) + end subroutine + subroutine check_int_const_shape_optional_mask_present() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + m = mask10 + calls_count = 0 + call call_minloc_int(r, a, m, get_scalar_false()) + if (calls_count /= 1) stop 39 + end subroutine + subroutine check_int_const_shape_optional_mask_absent() + integer :: a(10) + integer :: r + a = data10 + calls_count = 0 + call call_minloc_int(r, a, b = get_scalar_false()) + if (calls_count /= 1) stop 46 + end subroutine + subroutine check_int_const_shape_empty() + integer :: a(0) + logical :: m(0) + integer :: r + a = (/ integer:: /) + m = (/ logical:: /) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 53 + end subroutine + subroutine check_int_alloc() + integer, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = data10 + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 60 + end subroutine + subroutine check_int_alloc_scalar_mask() + integer, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = data10 + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 67 + end subroutine + subroutine check_int_alloc_array_mask() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(10), m(10)) + a(:) = data10 + m(:) = mask10 + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 81 + end subroutine + subroutine check_int_alloc_empty() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(0), m(0)) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 88 + end subroutine + subroutine check_real_const_shape() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 95 + end subroutine + subroutine check_real_const_shape_scalar_mask() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 102 + end subroutine + subroutine check_real_const_shape_array_mask() + real :: a(10) + logical :: m(10) + integer :: r + a = (/ real:: data10 /) + m = mask10 + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 116 + end subroutine + subroutine call_minloc_real(r, a, m, b) + real :: a(:) + logical, optional :: m(:) + logical, optional :: b + integer :: r + r = minloc(a, dim = 1, mask = m, back = b) + end subroutine + subroutine check_real_const_shape_optional_mask_present() + real :: a(10) + logical :: m(10) + integer :: r + a = (/ real:: data10 /) + m = mask10 + calls_count = 0 + call call_minloc_real(r, a, m, b = get_scalar_false()) + if (calls_count /= 1) stop 123 + end subroutine + subroutine check_real_const_shape_optional_mask_absent() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + call call_minloc_real(r, a, b = get_scalar_false()) + if (calls_count /= 1) stop 130 + end subroutine + subroutine check_real_const_shape_empty() + real :: a(0) + logical :: m(0) + integer :: r + a = (/ real:: /) + m = (/ logical:: /) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 137 + end subroutine + subroutine check_real_alloc() + real, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = (/ real:: data10 /) + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 144 + end subroutine + subroutine check_real_alloc_scalar_mask() + real, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = (/ real:: data10 /) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 151 + end subroutine + subroutine check_real_alloc_array_mask() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(10), m(10)) + a(:) = (/ real:: data10 /) + m(:) = mask10 + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 165 + end subroutine + subroutine check_real_alloc_empty() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(0), m(0)) + a(:) = (/ real:: /) + m(:) = (/ logical :: /) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 172 + end subroutine +end program p