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 29c44cc3d2f410d8861ee74136b2120f75bb5294..1ce8d1a18fa6c9e79d9fd4533d457eb2e8bf1a67 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 0bbc4d9b6a0bc4dee0fec1ca0196275b5f1f1b87..850be782103ff02c85cb7adf67e89ed901f325be 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 ed12d83bbe0ae3b44ca8f3bf406d6a4f3e7ef275..9cc821fdc8a19ed957b5b737a3d12ea132787c5a 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 8bab7a6cd0d984055999d217a16e299f04639a88..aa2dd4f9d36c79ad1cb52ca36fd95e4625072973 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 65e561b182074688312bdfc99b3559a6d55d2164..c49a79319046c760b7e9d43ac01e6bf74e65752a 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 8a9525fed656fa5b0b29257d971ee07919fe6bc4..ca9aa23cae1e853650b4221cf0c6b10e62d8a7f6 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 382a3c81c65c5147e3982204377ca59b5dd643d9..2e0a487080020159755c629e862e51b43254e947 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 1d5d8344e9e570bc3c4a9b8842b6015c9da0c99d..459d22d0d467036427dd78affbaec4e26bc7bf15 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 041dc4cd59acf341a83cfbf573607703d839f243..5f1bdac27394a3d752a3bb68873afe362c8a85ab 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 32dfa74a67270f30e00329dd33c3f66d9662e95a..4f18a0321345f7d1d3f6719bdb58843b6eba73d6 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 5b8851664b1163ff135a66cbebf7c0d2dc393c3c..11974fe38ae3ee818cad3f9e6d16f386348fe7b2 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 207060caa26a2ef375ab2b7d7bf945bbca7128d5..7994b7b3794ea7830f489791d5f5fe39aa7fbc80 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 ca33cc06c5ededd722678574191dc28e9e3c8ccd..9afb03dacb65ea1384044e6fc1a7df5ab2d016d1 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 db8507b52bd3ce7570b98ecdc1af00c00f35061a..5456259cf15d4cb038140b350a063ac516eb2f83 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;
 }