Fortran: Fix some problems with the reduce intrinsic [PR119460]
2025-04-09 Paul Thomas <pault@gcc.gnu.org> and Harald Anlauf <anlauf@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.
This commit is contained in:
Paul Thomas
parent
faff25435b
commit
ee65440cbd
8 changed files with 168 additions and 60 deletions
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
||||
|
|
|
|||
56
gcc/testsuite/gfortran.dg/reduce_3.f90
Normal file
56
gcc/testsuite/gfortran.dg/reduce_3.f90
Normal file
|
|
@ -0,0 +1,56 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! PR119460: Scalar reduce was failing with ARRAY elements larger than
|
||||
! an address size.
|
||||
!
|
||||
! Contributed by Rainer Orth <ro@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
|
||||
48
gcc/testsuite/gfortran.dg/reduce_4.f90
Normal file
48
gcc/testsuite/gfortran.dg/reduce_4.f90
Normal file
|
|
@ -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 <anlauf@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
|
||||
|
|
@ -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);
|
||||
if (res)
|
||||
{
|
||||
memcpy (res, ret.base_addr, GFC_DESCRIPTOR_SIZE (array));
|
||||
if (ret.base_addr) free (ret.base_addr);
|
||||
}
|
||||
else
|
||||
res = ret.base_addr;
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue