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;
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);
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);
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
{
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
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);
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
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);
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" }
! (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" }
--- /dev/null
+! { 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
--- /dev/null
+! { 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
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);
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
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)
}
-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,
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;
}
projects / thirdparty / gcc.git / commitdiff
