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.

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 6e860eeaa67d68e8ba77a37ce1cbb9050ac05ddb..d38d4229c4896c7f5f3b8391ae7bd34bfd9ec5c9 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 e4ac04cc2583d03e28e1325e5aab9d684ce042c3..09fdbf8ad12b1114149cd56b3330c7e56e32ca32 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 78a501230e08f4afa5341dfbbbfba3e36b475505..0804f593ccb3f2e3f1fb3bee7d9fd159fd616e01 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 399dab76a9ec83f8331c70211bebc607818cba3c..6dac06e438c1904ea89af836076bd61719254b6c 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 9e1d36f927423e830f728c70293b416bc7752bb2..5ced3c6a087283ee640f223ec6eeef540fabcaf6 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 a44c6f67308fa6c56ecb6ca4e520f1c9420ab376..78ae1be37129cd7d611e9e871752989bdc5c376f 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 6381ad6a82182d46ac80c2d9e96766437e5e3e20..9b4a92d81ebc66826c5779c410dccf27d993a1b1 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 11011b78a7b00b9df543f0faa13775375f0cf671..eac46faeef2fbb01941bf393aeec2fa9f352460d 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 631484abfba4a19b21a14e0023341cdb6583988e..bb22f6cad4c2f83037b02cf2589e79fa361cc4b0 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 d6064371fca95565daa8ed8340e4abe0d74c1f27..f3020d607674455bae20688c978dc5f36f41206c 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 b02200b3b3d72ba33a0bdc6a1bfaf163524fc9f3..04ec9134b2b6facac5e58022de3c7240babc7044 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 9d33d134c1216c7921ef912548ec81987d10c8a3..fbb6d08aec4d99cf73efc9699a86448193315a98 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 49ecae70d649322c48256e9f6147f813a3933032..b6070b41d26fd7512ea65a263c961053d0384ecb 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 8e7b4ab32f0944d7b0221e7934e476ae240677ef..9524fc4c62a7562224e334c6a663d9018e68506c 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;
 }