libfortran: Fix up _gfortran_s{max,min}loc2_{4,8,16}_s{1,4} [PR120191]

I've tried to write a testcase for the BT_CHARACTER maxloc/minloc with named
or unnamed arguments and indeed the just posted patch fixed the arguments
in there in multiple cases to match what the library expects.
But the testcase still fails, due to library problems.

One dealt with in this patch are _gfortran_s{max,min}loc2_{4,8,16}_s{1,4}
functions.  Those are trivial wrappers around
_gfortrani_{max,min}loc2_{4,8,16}_s{1,4} which should call those functions
if the scalar mask is true and just return 0 otherwise.
The two bugs I see there is that the back, len arguments are swapped,
which means that it always acts as back=.true. and for len will use
character length of 1 or 0 instead of the desired one.
The _gfortrani_{max,min}loc2_{4,8,16}_s{1,4} functions have prototypes like
GFC_INTEGER_4
maxloc2_4_s1 (gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len)
so back comes before len, ditto for the
GFC_INTEGER_4
smaxloc2_4_s1 (gfc_array_s1 * const restrict array,
               GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
The other problem is that it was just testing if (mask).  In my limited
Fortran understanding that means that the optional argument mask was
supplied but nothing about its actual value.  Other scalar mask generated
routines use if (mask == NULL || *mask) as the condition when to call the
non-masked function, i.e. when mask is not supplied (then it should act like
.true. mask) or when it is supplied and evaluates to .true.).

2025-05-13  Jakub Jelinek  <jakub@redhat.com>

	PR fortran/120191
	* m4/maxloc2s.m4: For smaxloc2 call maxloc2 if mask is NULL or *mask.
	Swap back and len arguments.
	* m4/minloc2s.m4: Likewise.
	* generated/maxloc2_4_s1.c: Regenerate.
	* generated/maxloc2_4_s4.c: Regenerate.
	* generated/maxloc2_8_s1.c: Regenerate.
	* generated/maxloc2_8_s4.c: Regenerate.
	* generated/maxloc2_16_s1.c: Regenerate.
	* generated/maxloc2_16_s4.c: Regenerate.
	* generated/minloc2_4_s1.c: Regenerate.
	* generated/minloc2_4_s4.c: Regenerate.
	* generated/minloc2_8_s1.c: Regenerate.
	* generated/minloc2_8_s4.c: Regenerate.
	* generated/minloc2_16_s1.c: Regenerate.
	* generated/minloc2_16_s4.c: Regenerate.

	* gfortran.dg/pr120191_2.f90: New test.

(cherry picked from commit 482f2192d4ef6af55acae2dc3e0df00b8487cc7d)

diff --git a/gcc/testsuite/gfortran.dg/pr120191_2.f90 b/gcc/testsuite/gfortran.dg/pr120191_2.f90
new file mode 100644 (file)
index 0000000..6334286
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr120191_2.f90
@@ -0,0 +1,84 @@
+! PR fortran/120191
+! { dg-do run }
+
+  character(kind=1, len=2) :: a(4, 4, 4), b(4)
+  logical :: l(4, 4, 4), m, n(4)
+  a = 'aa'
+  b = 'aa'
+  l = .true.
+  m = .true.
+  n = .true.
+  if (any (maxloc (a) .ne. 1)) stop 1
+  if (any (maxloc (a, dim=1) .ne. 1)) stop 2
+  if (any (maxloc (a, 1) .ne. 1)) stop 3
+  if (any (maxloc (a, dim=1, mask=l, kind=4, back=.false.) .ne. 1)) stop 4
+  if (any (maxloc (a, 1, l, 4, .false.) .ne. 1)) stop 5
+  if (any (maxloc (a, dim=1, mask=m, kind=4, back=.false.) .ne. 1)) stop 6
+  if (any (maxloc (a, 1, m, 4, .false.) .ne. 1)) stop 7
+  if (any (maxloc (a, dim=1, mask=l, kind=4, back=.true.) .ne. 4)) stop 8
+  if (any (maxloc (a, 1, l, 4, .true.) .ne. 4)) stop 9
+  if (any (maxloc (a, dim=1, mask=m, kind=4, back=.true.) .ne. 4)) stop 10
+  if (any (maxloc (a, 1, m, 4, .true.) .ne. 4)) stop 11
+  if (any (maxloc (b) .ne. 1)) stop 12
+  if (maxloc (b, dim=1) .ne. 1) stop 13
+  if (maxloc (b, 1) .ne. 1) stop 14
+  if (maxloc (b, dim=1, mask=n, kind=4, back=.false.) .ne. 1) stop 15
+  if (maxloc (b, 1, n, 4, .false.) .ne. 1) stop 16
+  if (maxloc (b, dim=1, mask=m, kind=4, back=.false.) .ne. 1) stop 17
+  if (maxloc (b, 1, m, 4, .false.) .ne. 1) stop 18
+  if (maxloc (b, dim=1, mask=n, kind=4, back=.true.) .ne. 4) stop 19
+  if (maxloc (b, 1, n, 4, .true.) .ne. 4) stop 20
+  if (maxloc (b, dim=1, mask=m, kind=4, back=.true.) .ne. 4) stop 21
+  if (maxloc (b, 1, m, 4, .true.) .ne. 4) stop 22
+  l = .false.
+  m = .false.
+  n = .false.
+  if (any (maxloc (a, dim=1, mask=l, kind=4, back=.false.) .ne. 0)) stop 23
+  if (any (maxloc (a, 1, l, 4, .false.) .ne. 0)) stop 24
+  if (maxloc (b, dim=1, mask=n, kind=4, back=.false.) .ne. 0) stop 25
+  if (maxloc (b, 1, n, 4, .false.) .ne. 0) stop 26
+  if (maxloc (b, dim=1, mask=m, kind=4, back=.false.) .ne. 0) stop 27
+  if (maxloc (b, 1, m, 4, .false.) .ne. 0) stop 28
+  if (maxloc (b, dim=1, mask=n, kind=4, back=.true.) .ne. 0) stop 29
+  if (maxloc (b, 1, n, 4, .true.) .ne. 0) stop 30
+  if (maxloc (b, dim=1, mask=m, kind=4, back=.true.) .ne. 0) stop 31
+  if (maxloc (b, 1, m, 4, .true.) .ne. 0) stop 32
+  l = .true.
+  m = .true.
+  n = .true.
+  if (any (minloc (a) .ne. 1)) stop 1
+  if (any (minloc (a, dim=1) .ne. 1)) stop 2
+  if (any (minloc (a, 1) .ne. 1)) stop 3
+  if (any (minloc (a, dim=1, mask=l, kind=4, back=.false.) .ne. 1)) stop 4
+  if (any (minloc (a, 1, l, 4, .false.) .ne. 1)) stop 5
+  if (any (minloc (a, dim=1, mask=m, kind=4, back=.false.) .ne. 1)) stop 6
+  if (any (minloc (a, 1, m, 4, .false.) .ne. 1)) stop 7
+  if (any (minloc (a, dim=1, mask=l, kind=4, back=.true.) .ne. 4)) stop 8
+  if (any (minloc (a, 1, l, 4, .true.) .ne. 4)) stop 9
+  if (any (minloc (a, dim=1, mask=m, kind=4, back=.true.) .ne. 4)) stop 10
+  if (any (minloc (a, 1, m, 4, .true.) .ne. 4)) stop 11
+  if (any (minloc (b) .ne. 1)) stop 12
+  if (minloc (b, dim=1) .ne. 1) stop 13
+  if (minloc (b, 1) .ne. 1) stop 14
+  if (minloc (b, dim=1, mask=n, kind=4, back=.false.) .ne. 1) stop 15
+  if (minloc (b, 1, n, 4, .false.) .ne. 1) stop 16
+  if (minloc (b, dim=1, mask=m, kind=4, back=.false.) .ne. 1) stop 17
+  if (minloc (b, 1, m, 4, .false.) .ne. 1) stop 18
+  if (minloc (b, dim=1, mask=n, kind=4, back=.true.) .ne. 4) stop 19
+  if (minloc (b, 1, n, 4, .true.) .ne. 4) stop 20
+  if (minloc (b, dim=1, mask=m, kind=4, back=.true.) .ne. 4) stop 21
+  if (minloc (b, 1, m, 4, .true.) .ne. 4) stop 22
+  l = .false.
+  m = .false.
+  n = .false.
+  if (any (minloc (a, dim=1, mask=l, kind=4, back=.false.) .ne. 0)) stop 23
+  if (any (minloc (a, 1, l, 4, .false.) .ne. 0)) stop 24
+  if (minloc (b, dim=1, mask=n, kind=4, back=.false.) .ne. 0) stop 25
+  if (minloc (b, 1, n, 4, .false.) .ne. 0) stop 26
+  if (minloc (b, dim=1, mask=m, kind=4, back=.false.) .ne. 0) stop 27
+  if (minloc (b, 1, m, 4, .false.) .ne. 0) stop 28
+  if (minloc (b, dim=1, mask=n, kind=4, back=.true.) .ne. 0) stop 29
+  if (minloc (b, 1, n, 4, .true.) .ne. 0) stop 30
+  if (minloc (b, dim=1, mask=m, kind=4, back=.true.) .ne. 0) stop 31
+  if (minloc (b, 1, m, 4, .true.) .ne. 0) stop 32
+end

diff --git a/libgfortran/generated/maxloc2_16_s1.c b/libgfortran/generated/maxloc2_16_s1.c
index b3e4c1adf79805dcc15284a544f0b32610d05a6b..91d61e2fa854f27585dea2679581d009b639d989 100644 (file)
--- a/libgfortran/generated/maxloc2_16_s1.c
+++ b/libgfortran/generated/maxloc2_16_s1.c
@@ -152,8 +152,8 @@ GFC_INTEGER_16
 smaxloc2_16_s1 (gfc_array_s1 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return maxloc2_16_s1 (array, len, back);
+  if (mask == NULL || *mask)
+    return maxloc2_16_s1 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/generated/maxloc2_16_s4.c b/libgfortran/generated/maxloc2_16_s4.c
index a44aca7e006ba15d57e92af5d8199b2e7f50de43..51257060676dd478d87443d80e4ef8eef6470e03 100644 (file)
--- a/libgfortran/generated/maxloc2_16_s4.c
+++ b/libgfortran/generated/maxloc2_16_s4.c
@@ -152,8 +152,8 @@ GFC_INTEGER_16
 smaxloc2_16_s4 (gfc_array_s4 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return maxloc2_16_s4 (array, len, back);
+  if (mask == NULL || *mask)
+    return maxloc2_16_s4 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/generated/maxloc2_4_s1.c b/libgfortran/generated/maxloc2_4_s1.c
index 0ce52ff5179d9ae77fc3454899c77fb0a16289fe..963d9b91360d419a4ea6ecc47e2ccd34c950c48a 100644 (file)
--- a/libgfortran/generated/maxloc2_4_s1.c
+++ b/libgfortran/generated/maxloc2_4_s1.c
@@ -152,8 +152,8 @@ GFC_INTEGER_4
 smaxloc2_4_s1 (gfc_array_s1 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return maxloc2_4_s1 (array, len, back);
+  if (mask == NULL || *mask)
+    return maxloc2_4_s1 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/generated/maxloc2_4_s4.c b/libgfortran/generated/maxloc2_4_s4.c
index e7c3ab1942d7c6090fb985b4f59c8a17ccb2a999..6be044b6b4ea9f389b10c30961bb226a189d53be 100644 (file)
--- a/libgfortran/generated/maxloc2_4_s4.c
+++ b/libgfortran/generated/maxloc2_4_s4.c
@@ -152,8 +152,8 @@ GFC_INTEGER_4
 smaxloc2_4_s4 (gfc_array_s4 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return maxloc2_4_s4 (array, len, back);
+  if (mask == NULL || *mask)
+    return maxloc2_4_s4 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/generated/maxloc2_8_s1.c b/libgfortran/generated/maxloc2_8_s1.c
index f99da6f5766c4946a27846acddce19707f9e4e38..93907ea3d97a4efd3cb937f3a1b63b83e0695f79 100644 (file)
--- a/libgfortran/generated/maxloc2_8_s1.c
+++ b/libgfortran/generated/maxloc2_8_s1.c
@@ -152,8 +152,8 @@ GFC_INTEGER_8
 smaxloc2_8_s1 (gfc_array_s1 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return maxloc2_8_s1 (array, len, back);
+  if (mask == NULL || *mask)
+    return maxloc2_8_s1 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/generated/maxloc2_8_s4.c b/libgfortran/generated/maxloc2_8_s4.c
index d160658b209d7261506533c331137181a0a43ff2..37f0b5778a74c62977bf0ae7530e28bc8c5c08e4 100644 (file)
--- a/libgfortran/generated/maxloc2_8_s4.c
+++ b/libgfortran/generated/maxloc2_8_s4.c
@@ -152,8 +152,8 @@ GFC_INTEGER_8
 smaxloc2_8_s4 (gfc_array_s4 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return maxloc2_8_s4 (array, len, back);
+  if (mask == NULL || *mask)
+    return maxloc2_8_s4 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/generated/minloc2_16_s1.c b/libgfortran/generated/minloc2_16_s1.c
index c0b7ae67203e15849af88348cf05995b8e2bfa05..904a38f463b77d3ed3cc1b0ef6e91f34f8b74719 100644 (file)
--- a/libgfortran/generated/minloc2_16_s1.c
+++ b/libgfortran/generated/minloc2_16_s1.c
@@ -154,8 +154,8 @@ GFC_INTEGER_16
 sminloc2_16_s1 (gfc_array_s1 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return minloc2_16_s1 (array, len, back);
+  if (mask == NULL || *mask)
+    return minloc2_16_s1 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/generated/minloc2_16_s4.c b/libgfortran/generated/minloc2_16_s4.c
index 8a42031da01863c12361de178f167dae9cf1ca50..1bedb06fe0ae55941358f4535da1861ad56c519b 100644 (file)
--- a/libgfortran/generated/minloc2_16_s4.c
+++ b/libgfortran/generated/minloc2_16_s4.c
@@ -154,8 +154,8 @@ GFC_INTEGER_16
 sminloc2_16_s4 (gfc_array_s4 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return minloc2_16_s4 (array, len, back);
+  if (mask == NULL || *mask)
+    return minloc2_16_s4 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/generated/minloc2_4_s1.c b/libgfortran/generated/minloc2_4_s1.c
index 80115ca67202a40279575ad53775f94b2b3be2ed..68232a9452cd318358a82f726aef05d103a3348d 100644 (file)
--- a/libgfortran/generated/minloc2_4_s1.c
+++ b/libgfortran/generated/minloc2_4_s1.c
@@ -154,8 +154,8 @@ GFC_INTEGER_4
 sminloc2_4_s1 (gfc_array_s1 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return minloc2_4_s1 (array, len, back);
+  if (mask == NULL || *mask)
+    return minloc2_4_s1 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/generated/minloc2_4_s4.c b/libgfortran/generated/minloc2_4_s4.c
index 207c9414cbe57b5df58a764177b4c9e9e0946380..840537f02e204c3d61b89dc1e55e5ab3285a3113 100644 (file)
--- a/libgfortran/generated/minloc2_4_s4.c
+++ b/libgfortran/generated/minloc2_4_s4.c
@@ -154,8 +154,8 @@ GFC_INTEGER_4
 sminloc2_4_s4 (gfc_array_s4 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return minloc2_4_s4 (array, len, back);
+  if (mask == NULL || *mask)
+    return minloc2_4_s4 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/generated/minloc2_8_s1.c b/libgfortran/generated/minloc2_8_s1.c
index 5f34acf1f2845d51b13738c26f5c29eaeba1f421..5491fb08efcb1a86705f16f515894066fca5cebb 100644 (file)
--- a/libgfortran/generated/minloc2_8_s1.c
+++ b/libgfortran/generated/minloc2_8_s1.c
@@ -154,8 +154,8 @@ GFC_INTEGER_8
 sminloc2_8_s1 (gfc_array_s1 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return minloc2_8_s1 (array, len, back);
+  if (mask == NULL || *mask)
+    return minloc2_8_s1 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/generated/minloc2_8_s4.c b/libgfortran/generated/minloc2_8_s4.c
index 67409daae7903896b3c7bb7f479c1d63845337e8..4b2b5de653e50db62fb58c2999ee7c8b2b5fe394 100644 (file)
--- a/libgfortran/generated/minloc2_8_s4.c
+++ b/libgfortran/generated/minloc2_8_s4.c
@@ -154,8 +154,8 @@ GFC_INTEGER_8
 sminloc2_8_s4 (gfc_array_s4 * const restrict array,
                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
 {
-  if (mask)
-    return minloc2_8_s4 (array, len, back);
+  if (mask == NULL || *mask)
+    return minloc2_8_s4 (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/m4/maxloc2s.m4 b/libgfortran/m4/maxloc2s.m4
index 471ea5d6091f7c43597e9fe069d65b926e2dbec4..94c1854d589557e30b4454be94cda0f2e3e82029 100644 (file)
--- a/libgfortran/m4/maxloc2s.m4
+++ b/libgfortran/m4/maxloc2s.m4
@@ -153,8 +153,8 @@ export_proto(s'name`'rtype_qual`_'atype_code`);
 s'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
                                 GFC_LOGICAL_4 *mask'back_arg`, gfc_charlen_type len)
 {
-  if (mask)
-    return 'name`'rtype_qual`_'atype_code` (array, len, back);
+  if (mask == NULL || *mask)
+    return 'name`'rtype_qual`_'atype_code` (array, back, len);
   else
     return 0;
 }

diff --git a/libgfortran/m4/minloc2s.m4 b/libgfortran/m4/minloc2s.m4
index 8f334ee69750932223ef68c28e55afb6dca0f8d3..14abc653f559627a57eb183ff86c6eed2204d737 100644 (file)
--- a/libgfortran/m4/minloc2s.m4
+++ b/libgfortran/m4/minloc2s.m4
@@ -155,8 +155,8 @@ export_proto(s'name`'rtype_qual`_'atype_code`);
 s'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
                                 GFC_LOGICAL_4 *mask'back_arg`, gfc_charlen_type len)
 {
-  if (mask)
-    return 'name`'rtype_qual`_'atype_code` (array, len, back);
+  if (mask == NULL || *mask)
+    return 'name`'rtype_qual`_'atype_code` (array, back, len);
   else
     return 0;
 }