Hi!
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.).
Bootstrapped/regtested on x86_64-linux and i686-linux, ok for trunk?
Note, there is another bug in _gfortran_s{max,min}loc1_{4,8,16}_s{1,4} which
I don't have a fix for yet and not sure where to fix that.
Initially I had in the testcase also
if (any (maxloc (a, dim=1, mask=m, kind=4, back=.false.) .ne. 0)) stop 33
if (any (maxloc (a, 1, m, 4, .false.) .ne. 0)) stop 34
if (any (maxloc (a, dim=1, mask=l, kind=4, back=.true.) .ne. 0)) stop 35
if (any (maxloc (a, 1, l, 4, .true.) .ne. 0)) stop 36
if (any (maxloc (a, dim=1, mask=m, kind=4, back=.true.) .ne. 0)) stop 37
if (any (maxloc (a, 1, m, 4, .true.) .ne. 0)) stop 38
for both m/l being .true. and .false., but that doesn't work, the functions
return but then crash in the caller.
Seems that is because buffer overflows, I believe those functions for
if (mask == NULL || *mask) condition being false are supposed to fill in
the result array with all zeros (or allocate it and fill it with zeros).
My understanding is the result array in that case is integer(kind={4,8,16})
and should have the extents the character input array has.
The problem is that it uses * string_len in the extent multiplication:
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
and
extent[n] =
GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
which is I guess fine and desirable for the extents of the character array,
but not for the extents of the destination array. Yet the code uses
that extent array for that purpose (and no other purposes).
Here it uses it to set the dimensions for the case where it needs to
allocate (as well as size):
for (n = 0; n < rank; n++)
{
if (n == 0)
str = 1;
else
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
}
Here it uses it for bounds checking of the destination:
if (unlikely (compile_options.bounds_check))
{
for (n=0; n < rank; n++)
{
index_type ret_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
and here to find out how many retarray elements to actually fill in each
dimension:
while(1)
{
*dest = 0;
count[0]++;
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
dest -= dstride[n] * extent[n];
So, I believe the easiest fix would be to somehow arrange for the
" * string_len" subtrings to be omitted twice, but am not sure where and
how.
2025-05-12 Jakub Jelinek <ja...@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: Regenerate.
* generated/maxloc2_4_s4: Regenerate.
* generated/maxloc2_8_s1: Regenerate.
* generated/maxloc2_8_s4: Regenerate.
* generated/maxloc2_16_s1: Regenerate.
* generated/maxloc2_16_s4: Regenerate.
* generated/minloc2_4_s1: Regenerate.
* generated/minloc2_4_s4: Regenerate.
* generated/minloc2_8_s1: Regenerate.
* generated/minloc2_8_s4: Regenerate.
* generated/minloc2_16_s1: Regenerate.
* generated/minloc2_16_s4: Regenerate.
* gfortran.dg/pr120191_2.f90: New test.
--- libgfortran/m4/maxloc2s.m4.jj 2025-01-02 20:54:32.795120703 +0100
+++ libgfortran/m4/maxloc2s.m4 2025-05-11 23:46:48.434112597 +0200
@@ -153,8 +153,8 @@ export_proto(s'name`'rtype_qual`_'atype_
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;
}
--- libgfortran/m4/minloc2s.m4.jj 2025-01-02 20:54:32.796120689 +0100
+++ libgfortran/m4/minloc2s.m4 2025-05-11 23:47:07.321857891 +0200
@@ -155,8 +155,8 @@ export_proto(s'name`'rtype_qual`_'atype_
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;
}
--- libgfortran/generated/maxloc2_4_s1.c.jj 2025-01-02 20:54:32.772121021
+0100
+++ libgfortran/generated/maxloc2_4_s1.c 2025-05-11 23:48:40.990594745
+0200
@@ -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;
}
--- libgfortran/generated/maxloc2_4_s4.c.jj 2025-01-02 20:54:32.772121021
+0100
+++ libgfortran/generated/maxloc2_4_s4.c 2025-05-11 23:48:55.287401948
+0200
@@ -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;
}
--- libgfortran/generated/maxloc2_8_s1.c.jj 2025-01-02 20:54:32.772121021
+0100
+++ libgfortran/generated/maxloc2_8_s1.c 2025-05-11 23:49:08.873218741
+0200
@@ -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;
}
--- libgfortran/generated/maxloc2_8_s4.c.jj 2025-01-02 20:54:32.772121021
+0100
+++ libgfortran/generated/maxloc2_8_s4.c 2025-05-11 23:49:25.272997581
+0200
@@ -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;
}
--- libgfortran/generated/maxloc2_16_s1.c.jj 2025-01-02 20:54:32.772121021
+0100
+++ libgfortran/generated/maxloc2_16_s1.c 2025-05-11 23:48:10.522005618
+0200
@@ -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;
}
--- libgfortran/generated/maxloc2_16_s4.c.jj 2025-01-02 20:54:32.772121021
+0100
+++ libgfortran/generated/maxloc2_16_s4.c 2025-05-11 23:48:24.686814601
+0200
@@ -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;
}
--- libgfortran/generated/minloc2_4_s1.c.jj 2025-01-02 20:54:32.778120938
+0100
+++ libgfortran/generated/minloc2_4_s1.c 2025-05-11 23:50:32.329093317
+0200
@@ -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;
}
--- libgfortran/generated/minloc2_4_s4.c.jj 2025-01-02 20:54:32.778120938
+0100
+++ libgfortran/generated/minloc2_4_s4.c 2025-05-11 23:50:43.893937363
+0200
@@ -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;
}
--- libgfortran/generated/minloc2_8_s1.c.jj 2025-01-02 20:54:32.778120938
+0100
+++ libgfortran/generated/minloc2_8_s1.c 2025-05-11 23:50:54.741791070
+0200
@@ -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;
}
--- libgfortran/generated/minloc2_8_s4.c.jj 2025-01-02 20:54:32.778120938
+0100
+++ libgfortran/generated/minloc2_8_s4.c 2025-05-11 23:51:05.657643874
+0200
@@ -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;
}
--- libgfortran/generated/minloc2_16_s1.c.jj 2025-01-02 20:54:32.778120938
+0100
+++ libgfortran/generated/minloc2_16_s1.c 2025-05-11 23:49:58.613547972
+0200
@@ -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;
}
--- libgfortran/generated/minloc2_16_s4.c.jj 2025-01-02 20:54:32.778120938
+0100
+++ libgfortran/generated/minloc2_16_s4.c 2025-05-11 23:50:21.717236424
+0200
@@ -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;
}
--- gcc/testsuite/gfortran.dg/pr120191_2.f90.jj 2025-05-12 00:22:16.867423880
+0200
+++ gcc/testsuite/gfortran.dg/pr120191_2.f90 2025-05-12 00:22:10.890504388
+0200
@@ -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
Jakub
