VladPolskiy/gcc
1
0
Fork 0
mirror of https://github.com/gcc-mirror/gcc.git synced 2025-08-06 10:55:56 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
master
gcc/libgfortran/generated/minloc1_16_s1.c
Jakub Jelinek 781cfc454b libfortran: Fix up _gfortran_s{max,min}loc1_{4,8,16}_s{1,4} [PR120191] 
There is a bug in _gfortran_s{max,min}loc1_{4,8,16}_s{1,4} which the
following testcase shows.
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];
Seems maxloc1s.m4 and minloc1s.m4 are the only users of ifunction-s.m4,
so we can change SCALAR_ARRAY_FUNCTION in there without breaking anything
else.

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

	PR fortran/120191
	* m4/ifunction-s.m4 (SCALAR_ARRAY_FUNCTION): Don't multiply
	GFC_DESCRIPTOR_EXTENT(array,) by string_len.
	* generated/maxloc1_4_s1.c: Regenerate.
	* generated/maxloc1_4_s4.c: Regenerate.
	* generated/maxloc1_8_s1.c: Regenerate.
	* generated/maxloc1_8_s4.c: Regenerate.
	* generated/maxloc1_16_s1.c: Regenerate.
	* generated/maxloc1_16_s4.c: Regenerate.
	* generated/minloc1_4_s1.c: Regenerate.
	* generated/minloc1_4_s4.c: Regenerate.
	* generated/minloc1_8_s1.c: Regenerate.
	* generated/minloc1_8_s4.c: Regenerate.
	* generated/minloc1_16_s1.c: Regenerate.
	* generated/minloc1_16_s4.c: Regenerate.

	* gfortran.dg/pr120191_3.f90: New test.
2025-05-13 14:25:08 +02:00

557 lines
14 KiB
C
Raw Permalink Blame History

/* Implementation of the MINLOC intrinsic
Copyright (C) 2017-2025 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16)
#define HAVE_BACK_ARG 1
#include <string.h>
#include <assert.h>
static inline int
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
{
if (sizeof (GFC_UINTEGER_1) == 1)
return memcmp (a, b, n);
else
return memcmp_char4 (a, b, n);
}
extern void minloc1_16_s1 (gfc_array_i16 * const restrict,
gfc_array_s1 * const restrict, const index_type * const restrict , GFC_LOGICAL_4 back,
gfc_charlen_type);
export_proto(minloc1_16_s1);
void
minloc1_16_s1 (gfc_array_i16 * const restrict retarray,
gfc_array_s1 * const restrict array,
const index_type * const restrict pdim, GFC_LOGICAL_4 back,
gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
const GFC_UINTEGER_1 * restrict base;
GFC_INTEGER_16 * restrict dest;
index_type rank;
index_type n;
index_type len;
index_type delta;
index_type dim;
int continue_loop;
/* Make dim zero based to avoid confusion. */
rank = GFC_DESCRIPTOR_RANK (array) - 1;
dim = (*pdim) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len < 0)
len = 0;
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
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);
}
retarray->offset = 0;
retarray->dtype.rank = rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
if (alloc_size == 0)
return;
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MINLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (unlikely (compile_options.bounds_check))
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "MINLOC");
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
if (extent[n] <= 0)
return;
}
base = array->base_addr;
dest = retarray->base_addr;
continue_loop = 1;
while (continue_loop)
{
const GFC_UINTEGER_1 * restrict src;
GFC_INTEGER_16 result;
src = base;
{
const GFC_UINTEGER_1 *minval;
minval = NULL;
result = 0;
if (len <= 0)
*dest = 0;
else
{
for (n = 0; n < len; n++, src += delta)
{
if (minval == NULL || (back ? compare_fcn (src, minval, string_len) <= 0 :
compare_fcn (src, minval, string_len) < 0))
{
minval = src;
result = (GFC_INTEGER_16)n + 1;
}
}
*dest = result;
}
}
/* Advance to the next element. */
count[0]++;
base += sstride[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. */
base -= sstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
continue_loop = 0;
break;
}
else
{
count[n]++;
base += sstride[n];
dest += dstride[n];
}
}
}
}
extern void mminloc1_16_s1 (gfc_array_i16 * const restrict,
gfc_array_s1 * const restrict, const index_type * const restrict,
gfc_array_l1 * const restrict, GFC_LOGICAL_4 back, gfc_charlen_type);
export_proto(mminloc1_16_s1);
void
mminloc1_16_s1 (gfc_array_i16 * const restrict retarray,
gfc_array_s1 * const restrict array,
const index_type * const restrict pdim,
gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
const GFC_UINTEGER_1 * restrict base;
const GFC_LOGICAL_1 * restrict mbase;
index_type rank;
index_type dim;
index_type n;
index_type len;
index_type delta;
index_type mdelta;
int mask_kind;
if (mask == NULL)
{
#ifdef HAVE_BACK_ARG
minloc1_16_s1 (retarray, array, pdim, back, string_len);
#else
minloc1_16_s1 (retarray, array, pdim, string_len);
#endif
return;
}
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
len = GFC_DESCRIPTOR_EXTENT(array,dim);
if (len < 0)
len = 0;
mbase = mask->base_addr;
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
runtime_error ("Funny sized logical array");
delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
for (n = 0; n < dim; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
if (extent[n] < 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
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);
}
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
retarray->offset = 0;
retarray->dtype.rank = rank;
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
if (alloc_size == 0)
return;
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in MINLOC intrinsic");
if (unlikely (compile_options.bounds_check))
{
bounds_ifunction_return ((array_t *) retarray, extent,
"return value", "MINLOC");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "MINLOC");
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
if (extent[n] <= 0)
return;
}
dest = retarray->base_addr;
base = array->base_addr;
while (base)
{
const GFC_UINTEGER_1 * restrict src;
const GFC_LOGICAL_1 * restrict msrc;
GFC_INTEGER_16 result;
src = base;
msrc = mbase;
{
const GFC_UINTEGER_1 *minval;
minval = base;
result = 0;
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc)
{
minval = src;
result = (GFC_INTEGER_16)n + 1;
break;
}
}
for (; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc && (back ? compare_fcn (src, minval, string_len) <= 0 :
compare_fcn (src, minval, string_len) < 0))
{
minval = src;
result = (GFC_INTEGER_16)n + 1;
}
}
*dest = result;
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
mbase += mstride[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. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n >= rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
dest += dstride[n];
}
}
}
}
extern void sminloc1_16_s1 (gfc_array_i16 * const restrict,
gfc_array_s1 * const restrict, const index_type * const restrict,
GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type);
export_proto(sminloc1_16_s1);
void
sminloc1_16_s1 (gfc_array_i16 * const restrict retarray,
gfc_array_s1 * const restrict array,
const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask , GFC_LOGICAL_4 back, gfc_charlen_type string_len)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
index_type rank;
index_type n;
index_type dim;
if (mask == NULL || *mask)
{
#ifdef HAVE_BACK_ARG
minloc1_16_s1 (retarray, array, pdim, back, string_len);
#else
minloc1_16_s1 (retarray, array, pdim, string_len);
#endif
return;
}
/* Make dim zero based to avoid confusion. */
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
if (unlikely (dim < 0 || dim > rank))
{
runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
"is %ld, should be between 1 and %ld",
(long int) dim + 1, (long int) rank + 1);
}
for (n = 0; n < dim; n++)
{
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] <= 0)
extent[n] = 0;
}
for (n = dim; n < rank; n++)
{
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1);
if (extent[n] <= 0)
extent[n] = 0;
}
if (retarray->base_addr == NULL)
{
size_t alloc_size, str;
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);
}
retarray->offset = 0;
retarray->dtype.rank = rank;
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
if (alloc_size == 0)
return;
}
else
{
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MINLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
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"
" MINLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
}
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
}
dest = retarray->base_addr;
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];
n++;
if (n >= rank)
return;
else
{
count[n]++;
dest += dstride[n];
}
}
}
}
#endif
Reference in New Issue View Git Blame Copy Permalink