Hi All, As far as I can tell, the attached patch fixes the problems with the reduce intrinsic. I would be grateful to the reporters if they would confirm that this is the case.
The key to the fix appears in reduce_3.f90, which failed even with -m64. Although it was not apparent from the tree dump, the scalar result was going on the stack. Once it became larger than the word size, it pushed the arguments out of alignment with the library prototype. I took the opportunity to add character length checking to the library. I think that it might be redundant and so might not appear in the submitted version. Thus far, I have failed to trigger the errors because the frontend seems to catch them all. reduce_c and reduce_scalar_c will look a lot neater without them. Harald has been enormously helpful in hunting out remaining problems and providing fixes. These are woven into the patch. Regtests on FC41/x86_64 - OK for mainline after confirmations from the reporters? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 8189d7a1c6f..858ffb1daeb 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 8dd1c93dbdf..70f91f15ffd 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 4b90b06fa0a..6ece39b218d 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 6b55017bb89..6ffc3e0261e 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 52d7c682a85..cacd54a5b60 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 00000000000..c0ed0623e49
--- /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 00000000000..5fd9a16d4e9
--- /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 tstcase 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 c8950e41fd0..be942cb94f2 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 in 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 REDUCE "
+ "intrinsic (%d/%d)", (int)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,70 @@ 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,
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,
+ gfc_charlen_type identity_strlen)
{
+ if (ret->base_addr && (ret_strlen != array_strlen))
+ runtime_error ("Mismatch in ARRAY and result string lengths in REDUCE "
+ "intrinsic (%ld/%ld)", (long int)array_strlen,
+ (long int)ret_strlen);
+
+ if (identity && (identity_strlen != array_strlen))
+ runtime_error ("Mismatch in ARRAY and IDENTITY string lengths in REDUCE "
+ "intrinsic (%ld/%ld)", (long int)array_strlen,
+ (long int)identity_strlen);
+
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,
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,
+ gfc_charlen_type identity_strlen)
{
parray ret;
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);
+ reduce_c (&ret, res_strlen, array, operation, dim, mask, identity, ordered,
+ array_strlen, identity_strlen);
+ if (res)
+ {
+ memcpy (res, ret.base_addr, GFC_DESCRIPTOR_SIZE (array));
+ if (ret.base_addr) free (ret.base_addr);
+ }
+ else
+ res = ret.base_addr;
}
