https://gcc.gnu.org/g:ee65440cbd8042a5e5885e18bde70f8d530e4404
commit r15-9328-gee65440cbd8042a5e5885e18bde70f8d530e4404
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Wed Apr 9 09:50:04 2025 +0100
Fortran: Fix some problems with the reduce intrinsic [PR119460]
2025-04-09 Paul Thomas <pa...@gcc.gnu.org>
and Harald Anlauf <anl...@gcc.gnu.org>
gcc/fortran
PR fortran/119460
* iresolve.cc (generate_reduce_op_wrapper): Increase the size
of 'tname'. Change intent of 'a' and 'b' to intent_in.
* trans-decl.cc (add_argument_checking): Do not test artificial
formal symbols.
* trans-expr.cc (gfc_conv_procedure_call): Remove reduce_scalar
and the blocks triggered by it.
* trans-intrinsic.cc (gfc_conv_intrinsic_function): Set the
result of non-character, scalar reduce to be allocatable.
gcc/testsuite/
PR fortran/119460
* gfortran.dg/reduce_2.f90: Add test to check that deferred len
characters cannot slip through.
* gfortran.dg/reduce_3.f90: New test
* gfortran.dg/reduce_4.f90: New test
libgfortran/
PR libfortran/119460
* intrinsics/reduce.c (reduce): Correct error message about
mismatch between dim and the rank of array. Output the values
of both. Correct the evaluation of the result stride and
extent.
(reduce_scalar): The front end treats the result as an
allocatable so eliminate memcpy and free. Return the base-addr
of the local descriptor.
(reduce_c): Correct the type of the string lengths.
(reduce_scalar_c): Correct the type of the string lengths.Test
to see if 'res' is allocated. If not then return the base_addr
of the local descriptor.
Diff:
---
gcc/fortran/iresolve.cc | 6 +--
gcc/fortran/trans-decl.cc | 2 +-
gcc/fortran/trans-expr.cc | 24 -----------
gcc/fortran/trans-intrinsic.cc | 7 ++++
gcc/testsuite/gfortran.dg/reduce_2.f90 | 8 ++++
gcc/testsuite/gfortran.dg/reduce_3.f90 | 56 +++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/reduce_4.f90 | 48 +++++++++++++++++++++
libgfortran/intrinsics/reduce.c | 77 ++++++++++++++++++++--------------
8 files changed, 168 insertions(+), 60 deletions(-)
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 8189d7a1c6f6..858ffb1daebf 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -2417,7 +2417,7 @@ generate_reduce_op_wrapper (gfc_expr *op)
gfc_symbol *operation = op->symtree->n.sym;
gfc_symbol *wrapper, *a, *b, *c;
gfc_symtree *st;
- char tname[GFC_MAX_SYMBOL_LEN+1];
+ char tname[2 * GFC_MAX_SYMBOL_LEN + 2];
char *name;
gfc_namespace *ns;
gfc_expr *e;
@@ -2462,7 +2462,7 @@ generate_reduce_op_wrapper (gfc_expr *op)
a->attr.flavor = FL_VARIABLE;
a->attr.dummy = 1;
a->attr.artificial = 1;
- a->attr.intent = INTENT_INOUT;
+ a->attr.intent = INTENT_IN;
wrapper->formal = gfc_get_formal_arglist ();
wrapper->formal->sym = a;
gfc_set_sym_referenced (a);
@@ -2476,7 +2476,7 @@ generate_reduce_op_wrapper (gfc_expr *op)
b->attr.dummy = 1;
b->attr.optional= 1;
b->attr.artificial = 1;
- b->attr.intent = INTENT_INOUT;
+ b->attr.intent = INTENT_IN;
wrapper->formal->next = gfc_get_formal_arglist ();
wrapper->formal->next->sym = b;
gfc_set_sym_referenced (b);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 9087221dabbf..aea132ded13c 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -6546,7 +6546,7 @@ add_argument_checking (stmtblock_t *block, gfc_symbol
*sym)
message = _("Actual string length does not match the declared one"
" for dummy argument '%s' (%ld/%ld)");
}
- else if (fsym->as && fsym->as->rank != 0)
+ else if ((fsym->as && fsym->as->rank != 0) || fsym->attr.artificial)
continue;
else
{
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 4b90b06fa0a0..6ece39b218d0 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6753,12 +6753,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_intrinsic_sym *isym = expr && expr->rank ?
expr->value.function.isym : NULL;
- /* In order that the library function for intrinsic REDUCE be type and kind
- agnostic, the result is passed by reference. Allocatable components are
- handled within the OPERATION wrapper. */
- bool reduce_scalar = expr && !expr->rank && expr->value.function.isym
- && expr->value.function.isym->id == GFC_ISYM_REDUCE;
-
comp = gfc_get_proc_ptr_comp (expr);
bool elemental_proc = (comp
@@ -8596,16 +8590,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else if (ts.type == BT_CHARACTER)
vec_safe_push (retargs, len);
}
- else if (reduce_scalar)
- {
- /* In order that the library function for intrinsic REDUCE be type and
- kind agnostic, the result is passed by reference. Allocatable
- components are handled within the OPERATION wrapper. */
- type = gfc_typenode_for_spec (&expr->ts);
- result = gfc_create_var (type, "sr");
- tmp = gfc_build_addr_expr (pvoid_type_node, result);
- vec_safe_push (retargs, tmp);
- }
gfc_free_interface_mapping (&mapping);
@@ -8821,14 +8805,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_add_expr_to_block (&se->pre, tmp);
}
}
- else if (reduce_scalar)
- {
- /* Even though the REDUCE intrinsic library function returns the result
- by reference, the scalar call passes the result as se->expr. */
- gfc_add_expr_to_block (&se->pre, se->expr);
- se->expr = result;
- gfc_add_block_to_block (&se->post, &post);
- }
else
{
/* For a function with a class array result, save the result as
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 6b55017bb897..6ffc3e0261e5 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -3883,6 +3883,13 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
append_args->quick_push (null_pointer_node);
}
}
+ /* Non-character scalar reduce returns a pointer to a result of size set by
+ the element size of 'array'. Setting 'sym' allocatable ensures that the
+ result is deallocated at the appropriate time. */
+ else if (expr->value.function.isym->id == GFC_ISYM_REDUCE
+ && expr->rank == 0 && expr->ts.type != BT_CHARACTER)
+ sym->attr.allocatable = 1;
+
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
append_args);
diff --git a/gcc/testsuite/gfortran.dg/reduce_2.f90
b/gcc/testsuite/gfortran.dg/reduce_2.f90
index 52d7c682a853..cacd54a5b608 100644
--- a/gcc/testsuite/gfortran.dg/reduce_2.f90
+++ b/gcc/testsuite/gfortran.dg/reduce_2.f90
@@ -8,6 +8,10 @@
integer, allocatable :: i(:,:,:)
integer :: n(2,2)
Logical :: l1(4), l2(2,3), l3(2,2)
+ type :: string_t
+ character(:), allocatable :: chr(:)
+ end type
+ type(string_t) :: str
! The ARRAY argument at (1) of REDUCE shall not be polymorphic
print *, reduce (cstar, add) ! { dg-error "shall not be polymorphic" }
@@ -54,6 +58,10 @@
! (2) shall be the same
print *, reduce ([character(4) :: 'abcd','efgh'], char_three) ! { dg-error
"arguments of the OPERATION" }
+! The character length of the ARRAY argument at (1) and of the arguments of
the OPERATION at (2)
+! shall be the same
+ str = reduce ([character(4) :: 'abcd','efgh'], char_one) ! { dg-error
"character length of the ARRAY" }
+
! The DIM argument at (1), if present, must be an integer scalar
print *, reduce (i, add, dim = 2.0) ! { dg-error "must be an integer scalar"
}
diff --git a/gcc/testsuite/gfortran.dg/reduce_3.f90
b/gcc/testsuite/gfortran.dg/reduce_3.f90
new file mode 100644
index 000000000000..c0ed0623e49e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/reduce_3.f90
@@ -0,0 +1,56 @@
+! { dg-do run }
+!
+! PR119460: Scalar reduce was failing with ARRAY elements larger than
+! an address size.
+!
+! Contributed by Rainer Orth <r...@gcc.gnu.org>
+!
+program test_reduce
+ implicit none
+ integer :: i
+ integer, parameter :: dp = kind(1.0_8), extent = 4
+
+ real(dp) :: rarray(extent,extent,extent), rmat(extent,extent), &
+ rvec (extent), rscl
+
+ type :: t
+ real(dp) :: field(extent)
+ end type t
+
+ type (t) :: tmat(extent, extent), tarray(extent), tscalar
+
+ rarray = reshape ([(real(i, kind = dp), i = 1, size(rarray))], &
+ shape (rarray))
+
+ rmat = reduce (rarray, add, dim = 1)
+ if (any (rmat /= sum (rarray, 1))) stop 1
+
+ rmat = reduce (rarray, add, dim = 2)
+ if (any (rmat /= sum (rarray, 2))) stop 2
+
+ rmat = reduce (rarray, add, dim = 3)
+ if (any (rmat /= sum (rarray, 3))) stop 3
+
+ rscl = reduce (rarray, add)
+ if (rscl /= sum (rarray)) stop 4
+
+ tmat%field(1) = rmat
+ tarray = reduce (tmat, t_add, dim =1)
+ rvec = reduce (rmat, add, dim = 1)
+ if (any (tarray%field(1) /= rvec)) stop 5
+
+ tscalar = reduce (tmat, t_add)
+ if (tscalar%field(1) /= sum (tmat%field(1))) stop 6
+contains
+
+ pure real(dp) function add (i, j)
+ real(dp), intent(in) :: i, j
+ add = i + j
+ end function add
+
+ pure type(t) function t_add (i, j)
+ type(t), intent(in) :: i, j
+ t_add%field(1) = i%field(1) + j%field(1)
+ end function t_add
+
+end
diff --git a/gcc/testsuite/gfortran.dg/reduce_4.f90
b/gcc/testsuite/gfortran.dg/reduce_4.f90
new file mode 100644
index 000000000000..edea93166c33
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/reduce_4.f90
@@ -0,0 +1,48 @@
+! { dg-do run }
+!
+! PR119540 comment2: REDUCE was getting the shape wrong. This testcase also
+! verifies that the longest possible name for the OPERATION wrapper function
+! is catered for.
+!
+! Contributed by Harald Anlauf <anl...@gcc.gnu.org>
+!
+program p2345678901234567890123456789012345678901234567890123456789_123
+ implicit none
+ integer, parameter :: n = 3
+ integer, parameter :: vec(n) = [2, 5, 10]
+ integer, parameter :: mat(n,2) = reshape([vec,2*vec],[n,2])
+ integer :: mat_shape(2), reduce_shape(1), r
+ integer, dimension(:), allocatable :: res1
+
+ mat_shape = shape (mat)
+ reduce_shape = shape (reduce (mat, add, 1), 1)
+ if (reduce_shape(1) /= mat_shape(2)) stop 1
+
+ reduce_shape = shape (reduce (mat, add, 1), 1)
+ if (reduce_shape(1) /= mat_shape(2)) stop 2
+
+ res1 = reduce (mat, add, 1)
+ if (any (res1 /= [17, 34])) stop 3
+
+ res1 = reduce (mat, add, 2)
+ if (any (res1 /= [6, 15, 30])) stop 4
+
+ r = reduce (vec, &
+ o2345678901234567890123456789012345678901234567890123456789_123)
+ if (r /= 17) stop 5
+
+ deallocate (res1)
+contains
+ pure function add(i,j) result(sum_ij)
+ integer, intent(in) :: i, j
+ integer :: sum_ij
+ sum_ij = i + j
+ end function add
+
+ pure function
o2345678901234567890123456789012345678901234567890123456789_123 (i, j) &
+ result (sum)
+ integer, intent(in) :: i, j
+ integer :: sum
+ sum = i + j
+ end function
+end
diff --git a/libgfortran/intrinsics/reduce.c b/libgfortran/intrinsics/reduce.c
index c8950e41fd01..256394f08501 100644
--- a/libgfortran/intrinsics/reduce.c
+++ b/libgfortran/intrinsics/reduce.c
@@ -52,14 +52,14 @@ reduce (parray *ret,
index_type ext0, ext1, ext2;
index_type str0, str1, str2;
index_type idx0, idx1, idx2;
- index_type dimen, dimen_m1, ldx;
+ index_type dimen, dimen_m1, ldx, ext, str;
bool started;
bool masked = false;
bool dim_present = dim != NULL;
bool mask_present = mask != NULL;
bool identity_present = identity != NULL;
bool scalar_result;
- int i;
+ int i, j;
int array_rank = (int)GFC_DESCRIPTOR_RANK (array);
size_t elem_len = GFC_DESCRIPTOR_SIZE (array);
@@ -83,8 +83,8 @@ reduce (parray *ret,
if (dim_present)
{
if ((*dim < 1) || (*dim > (GFC_INTEGER_4)array_rank))
- runtime_error ("DIM in REDUCE intrinsic is less than 0 or greater than "
- "the rank of ARRAY");
+ runtime_error ("Mismatch between DIM and the rank of ARRAY in the "
+ "REDUCE intrinsic (%d/%d)", (int)*dim, array_rank);
dimen = (index_type) *dim;
}
else
@@ -99,33 +99,39 @@ reduce (parray *ret,
scalar_result = (!dim_present && array_rank > 1) || array_rank == 1;
+ j = 0;
for (i = 0; i < array_rank; i++)
{
/* Obtain the shape of the reshaped ARRAY. */
- index_type ext = GFC_DESCRIPTOR_EXTENT (array,i);
- index_type str = GFC_DESCRIPTOR_STRIDE (array,i);
+ ext = GFC_DESCRIPTOR_EXTENT (array,i);
+ str = GFC_DESCRIPTOR_STRIDE (array,i);
if (masked && (ext != GFC_DESCRIPTOR_EXTENT (mask, i)))
- runtime_error ("shape mismatch between ARRAY and MASK in REDUCE "
- "intrinsic");
+ {
+ int mext = (int)GFC_DESCRIPTOR_EXTENT (mask, i);
+ runtime_error ("shape mismatch between ARRAY and MASK in the REDUCE "
+ "intrinsic (%zd/%d)", ext, mext);
+ }
if (scalar_result)
{
ext1 *= ext;
continue;
}
- else if (i < dimen_m1)
+ else if (i < (int)dimen_m1)
ext0 *= ext;
- else if (i == dimen_m1)
+ else if (i == (int)dimen_m1)
ext1 = ext;
else
ext2 *= ext;
/* The dimensions of the return array. */
- if (i < (int)(dimen - 1))
- GFC_DIMENSION_SET (ret->dim[i], 0, ext - 1, str);
- else if (i < array_rank - 1)
- GFC_DIMENSION_SET (ret->dim[i], 0, ext - 1, str);
+ if (i != (int)dimen_m1)
+ {
+ str = GFC_DESCRIPTOR_STRIDE (array, j);
+ GFC_DIMENSION_SET (ret->dim[j], 0, ext - 1, str);
+ j++;
+ }
}
if (!scalar_result)
@@ -214,14 +220,13 @@ reduce (parray *ret,
}
-extern void reduce_scalar (void *, parray *,
+extern void * reduce_scalar (parray *,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *, gfc_array_l4 *, void *, void *);
export_proto (reduce_scalar);
-void
-reduce_scalar (void *res,
- parray *array,
+void *
+reduce_scalar (parray *array,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *dim,
gfc_array_l4 *mask,
@@ -232,55 +237,63 @@ reduce_scalar (void *res,
ret.base_addr = NULL;
ret.dtype.rank = 0;
reduce (&ret, array, operation, dim, mask, identity, ordered);
- memcpy (res, ret.base_addr, GFC_DESCRIPTOR_SIZE (array));
- if (ret.base_addr) free (ret.base_addr);
+ return (void *)ret.base_addr;
}
-extern void reduce_c (parray *, index_type, parray *,
+extern void reduce_c (parray *, gfc_charlen_type, parray *,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *, gfc_array_l4 *, void *, void *,
- index_type, index_type);
+ gfc_charlen_type, gfc_charlen_type);
export_proto (reduce_c);
void
reduce_c (parray *ret,
- index_type ret_strlen __attribute__ ((unused)),
+ gfc_charlen_type ret_strlen __attribute__ ((unused)),
parray *array,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *dim,
gfc_array_l4 *mask,
void *identity,
void *ordered,
- index_type array_strlen __attribute__ ((unused)),
- index_type identity_strlen __attribute__ ((unused)))
+ gfc_charlen_type array_strlen __attribute__ ((unused)),
+ gfc_charlen_type identity_strlen __attribute__ ((unused)))
{
+ /* The frontend constraints make string length checking redundant. Also, the
+ scalar symbol is flagged to be allocatable in trans-intrinsic.cc so that
+ gfc_conv_procedure_call does the necessary allocation/deallocation. */
reduce (ret, array, operation, dim, mask, identity, ordered);
}
-extern void reduce_scalar_c (void *, index_type, parray *,
+extern void reduce_scalar_c (void *, gfc_charlen_type, parray *,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *, gfc_array_l4 *, void *, void *,
- index_type, index_type);
+ gfc_charlen_type, gfc_charlen_type);
export_proto (reduce_scalar_c);
void
reduce_scalar_c (void *res,
- index_type res_strlen __attribute__ ((unused)),
+ gfc_charlen_type res_strlen __attribute__ ((unused)),
parray *array,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *dim,
gfc_array_l4 *mask,
void *identity,
void *ordered,
- index_type array_strlen __attribute__ ((unused)),
- index_type identity_strlen __attribute__ ((unused)))
+ gfc_charlen_type array_strlen __attribute__ ((unused)),
+ gfc_charlen_type identity_strlen __attribute__ ((unused)))
{
parray ret;
ret.base_addr = NULL;
ret.dtype.rank = 0;
+ /* The frontend constraints make string length checking redundant. */
reduce (&ret, array, operation, dim, mask, identity, ordered);
- memcpy (res, ret.base_addr, GFC_DESCRIPTOR_SIZE (array));
- if (ret.base_addr) free (ret.base_addr);
+ if (res)
+ {
+ memcpy (res, ret.base_addr, GFC_DESCRIPTOR_SIZE (array));
+ if (ret.base_addr) free (ret.base_addr);
+ }
+ else
+ res = ret.base_addr;
}
