git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

check.c (check_co_collective): Reject coindexed A args. 

2014-10-24  Tobias Burnus  <burnus@net-b.de>

gcc/fortran
        * check.c (check_co_collective): Reject coindexed A args.
        (gfc_check_co_reduce): Add OPERATOR checks.
        * gfortran.texi (_gfortran_caf_co_broadcast,
        * _gfortran_caf_co_max,
        _gfortran_caf_co_min, _gfortran_caf_co_sum,
        _gfortran_caf_co_reduce): Add ABI documentation.
        * intrinsic.texi (CO_REDUCE): Document intrinsic.
        (DPROD): Returns double not single precision.
        * trans-decl.c (gfor_fndecl_co_reduce): New global var.
        (gfc_build_builtin_function_decls): Init it.
        * trans.h (gfor_fndecl_co_reduce): Declare it.
        * trans-intrinsic.c (conv_co_collective,
        gfc_conv_intrinsic_subroutine): Handle CO_REDUCE.

gcc/testsuite/
        * gfortran.dg/coarray_collectives_9.f90: Remove dg-error.
        * gfortran.dg/coarray_collectives_13.f90: New.
        * gfortran.dg/coarray_collectives_14.f90: New.
        * gfortran.dg/coarray_collectives_15.f90: New.
        * gfortran.dg/coarray_collectives_16.f90: New.

From-SVN: r216678
This commit is contained in:
Tobias Burnus 2014-10-24 22:52:41 +02:00 committed by Tobias Burnus
parent 763206befb
commit 229c59193a
14 changed files with 761 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View File

@ -1,3 +1,18 @@
2014-10-24 Tobias Burnus <burnus@net-b.de>
* check.c (check_co_collective): Reject coindexed A args.
(gfc_check_co_reduce): Add OPERATOR checks.
* gfortran.texi (_gfortran_caf_co_broadcast, _gfortran_caf_co_max,
_gfortran_caf_co_min, _gfortran_caf_co_sum,
_gfortran_caf_co_reduce): Add ABI documentation.
* intrinsic.texi (CO_REDUCE): Document intrinsic.
(DPROD): Returns double not single precision.
* trans-decl.c (gfor_fndecl_co_reduce): New global var.
(gfc_build_builtin_function_decls): Init it.
* trans.h (gfor_fndecl_co_reduce): Declare it.
* trans-intrinsic.c (conv_co_collective,
gfc_conv_intrinsic_subroutine): Handle CO_REDUCE.
2014-10-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> 2014-10-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/48979 PR fortran/48979

179
gcc/fortran/check.c
View File

@ -1433,6 +1433,13 @@ check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
return false; return false;
} }
if (gfc_is_coindexed (a))
{
gfc_error ("The A argument at %L to the intrinsic %s shall not be "
"coindexed", &a->where, gfc_current_intrinsic);
return false;
}
if (image_idx != NULL) if (image_idx != NULL)
{ {
if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER)) if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER))
@ -1490,10 +1497,10 @@ gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat,
{ {
if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp) if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp)
{ {
gfc_error ("Support for the A argument at %L which is polymorphic A " gfc_error ("Support for the A argument at %L which is polymorphic A "
"argument or has allocatable components is not yet " "argument or has allocatable components is not yet "
"implemented", &a->where); "implemented", &a->where);
return false; return false;
} }
return check_co_collective (a, source_image, stat, errmsg, false); return check_co_collective (a, source_image, stat, errmsg, false);
} }
@ -1504,38 +1511,164 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
gfc_expr *stat, gfc_expr *errmsg) gfc_expr *stat, gfc_expr *errmsg)
{ {
symbol_attribute attr; symbol_attribute attr;
gfc_formal_arglist *formal;
gfc_symbol *sym;
if (a->ts.type == BT_CLASS) if (a->ts.type == BT_CLASS)
{ {
gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic", gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
&a->where); &a->where);
return false; return false;
} }
if (gfc_expr_attr (a).alloc_comp) if (gfc_expr_attr (a).alloc_comp)
{ {
gfc_error ("Support for the A argument at %L with allocatable components" gfc_error ("Support for the A argument at %L with allocatable components"
" is not yet implemented", &a->where); " is not yet implemented", &a->where);
return false; return false;
}
attr = gfc_expr_attr (op);
if (!attr.pure || !attr.function)
{
gfc_error ("OPERATOR argument at %L must be a PURE function",
&op->where);
return false;
} }
if (!check_co_collective (a, result_image, stat, errmsg, true)) if (!check_co_collective (a, result_image, stat, errmsg, true))
return false; return false;
/* FIXME: After J3/WG5 has decided what they actually exactly want, more if (!gfc_resolve_expr (op))
checks such as same-argument checks have to be added, implemented and return false;
intrinsic.texi upated. */
gfc_error("CO_REDUCE at %L is not yet implemented", &a->where); attr = gfc_expr_attr (op);
return false; if (!attr.pure || !attr.function)
{
gfc_error ("OPERATOR argument at %L must be a PURE function",
&op->where);
return false;
}
if (attr.intrinsic)
{
/* None of the intrinsics fulfills the criteria of taking two arguments,
returning the same type and kind as the arguments and being permitted
as actual argument. */
gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
op->symtree->n.sym->name, &op->where);
return false;
}
if (gfc_is_proc_ptr_comp (op))
{
gfc_component *comp = gfc_get_proc_ptr_comp (op);
sym = comp->ts.interface;
}
else
sym = op->symtree->n.sym;
formal = sym->formal;
if (!formal || !formal->next || formal->next->next)
{
gfc_error ("The function passed as OPERATOR at %L shall have two "
"arguments", &op->where);
return false;
}
if (sym->result->ts.type == BT_UNKNOWN)
gfc_set_default_type (sym->result, 0, NULL);
if (!gfc_compare_types (&a->ts, &sym->result->ts))
{
gfc_error ("A argument at %L has type %s but the function passed as "
"OPERATOR at %L returns %s",
&a->where, gfc_typename (&a->ts), &op->where,
gfc_typename (&sym->result->ts));
return false;
}
if (!gfc_compare_types (&a->ts, &formal->sym->ts)
|| !gfc_compare_types (&a->ts, &formal->next->sym->ts))
{
gfc_error ("The function passed as OPERATOR at %L has arguments of type "
"%s and %s but shall have type %s", &op->where,
gfc_typename (&formal->sym->ts),
gfc_typename (&formal->next->sym->ts), gfc_typename (&a->ts));
return false;
}
if (op->rank || attr.allocatable || attr.pointer || formal->sym->as
|| formal->next->sym->as || formal->sym->attr.allocatable
|| formal->next->sym->attr.allocatable || formal->sym->attr.pointer
|| formal->next->sym->attr.pointer)
{
gfc_error ("The function passed as OPERATOR at %L shall have scalar "
"nonallocatable nonpointer arguments and return a "
"nonallocatable nonpointer scalar", &op->where);
return false;
}
if (formal->sym->attr.value != formal->next->sym->attr.value)
{
gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
"attribute either for none or both arguments", &op->where);
return false;
}
if (formal->sym->attr.target != formal->next->sym->attr.target)
{
gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
"attribute either for none or both arguments", &op->where);
return false;
}
if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous)
{
gfc_error ("The function passed as OPERATOR at %L shall have the "
"ASYNCHRONOUS attribute either for none or both arguments",
&op->where);
return false;
}
if (formal->sym->attr.optional || formal->next->sym->attr.optional)
{
gfc_error ("The function passed as OPERATOR at %L shall not have the "
"OPTIONAL attribute for either of the arguments", &op->where);
return false;
}
if (a->ts.type == BT_CHARACTER)
{
gfc_charlen *cl;
unsigned long actual_size, formal_size1, formal_size2, result_size;
cl = a->ts.u.cl;
actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
? mpz_get_ui (cl->length->value.integer) : 0;
cl = formal->sym->ts.u.cl;
formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
? mpz_get_ui (cl->length->value.integer) : 0;
cl = formal->next->sym->ts.u.cl;
formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
? mpz_get_ui (cl->length->value.integer) : 0;
cl = sym->ts.u.cl;
result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
? mpz_get_ui (cl->length->value.integer) : 0;
if (actual_size
&& ((formal_size1 && actual_size != formal_size1)
|| (formal_size2 && actual_size != formal_size2)))
{
gfc_error ("The character length of the A argument at %L and of the "
"arguments of the OPERATOR at %L shall be the same",
&a->where, &op->where);
return false;
}
if (actual_size && result_size && actual_size != result_size)
{
gfc_error ("The character length of the A argument at %L and of the "
"function result of the OPERATOR at %L shall be the same",
&a->where, &op->where);
return false;
}
}
return true;
} }

190
gcc/fortran/gfortran.texi
View File

@ -3238,6 +3238,11 @@ caf_register_t;
* _gfortran_caf_sendget:: Sending data between remote images * _gfortran_caf_sendget:: Sending data between remote images
* _gfortran_caf_lock:: Locking a lock variable * _gfortran_caf_lock:: Locking a lock variable
* _gfortran_caf_unlock:: Unlocking a lock variable * _gfortran_caf_unlock:: Unlocking a lock variable
* _gfortran_caf_co_broadcast:: Sending data to all images
* _gfortran_caf_co_max:: Collective maximum reduction
* _gfortran_caf_co_min:: Collective minimum reduction
* _gfortran_caf_co_sum:: Collective summing reduction
* _gfortran_caf_co_reduce:: Generic collective reduction
@end menu @end menu
@ -3680,6 +3685,191 @@ images for critical-block locking variables.
@node _gfortran_caf_co_broadcast
@subsection @code{_gfortran_caf_co_broadcast} --- Sending data to all images
@cindex Coarray, _gfortran_caf_co_broadcast
@table @asis
@item @emph{Description}:
Distribute a value from a given image to all other images in the team. Has to
be called collectively.
@item @emph{Syntax}:
@code{void _gfortran_caf_co_broadcast (gfc_descriptor_t *a,
int source_image, int *stat, char *errmsg, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{a} @tab intent(inout) And array descriptor with the data to be
breoadcasted (on @var{source_image}) or to be received (other images).
@item @var{source_image} @tab The ID of the image from which the data should
be taken.
@item @var{stat} @tab intent(out) Stores the status STAT= and my may be NULL.
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@end multitable
@end table
@node _gfortran_caf_co_max
@subsection @code{_gfortran_caf_co_max} --- Collective maximum reduction
@cindex Coarray, _gfortran_caf_co_max
@table @asis
@item @emph{Description}:
Calculates the for the each array element of the variable @var{a} the maximum
value for that element in the current team; if @var{result_image} has the
value 0, the result shall be stored on all images, otherwise, only on the
specified image. This function operates on numeric values and character
strings.
@item @emph{Syntax}:
@code{void _gfortran_caf_co_max (gfc_descriptor_t *a, int result_image,
int *stat, char *errmsg, int a_len, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{a} @tab intent(inout) And array descriptor with the data to be
breoadcasted (on @var{source_image}) or to be received (other images).
@item @var{result_image} @tab The ID of the image to which the reduced
value should be copied to; if zero, it has to be copied to all images.
@item @var{stat} @tab intent(out) Stores the status STAT= and my may be NULL.
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{a_len} @tab The string length of argument @var{a}.
@item @var{errmsg_len} @tab the buffer size of errmsg.
@end multitable
@item @emph{NOTES}
If @var{result_image} is nonzero, the value on all images except of the
specified one become undefined; hence, the library may make use of this.
@end table
@node _gfortran_caf_co_min
@subsection @code{_gfortran_caf_co_min} --- Collective minimum reduction
@cindex Coarray, _gfortran_caf_co_min
@table @asis
@item @emph{Description}:
Calculates the for the each array element of the variable @var{a} the minimum
value for that element in the current team; if @var{result_image} has the
value 0, the result shall be stored on all images, otherwise, only on the
specified image. This function operates on numeric values and character
strings.
@item @emph{Syntax}:
@code{void _gfortran_caf_co_min (gfc_descriptor_t *a, int result_image,
int *stat, char *errmsg, int a_len, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{a} @tab intent(inout) And array descriptor with the data to be
breoadcasted (on @var{source_image}) or to be received (other images).
@item @var{result_image} @tab The ID of the image to which the reduced
value should be copied to; if zero, it has to be copied to all images.
@item @var{stat} @tab intent(out) Stores the status STAT= and my may be NULL.
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{a_len} @tab The string length of argument @var{a}.
@item @var{errmsg_len} @tab the buffer size of errmsg.
@end multitable
@item @emph{NOTES}
If @var{result_image} is nonzero, the value on all images except of the
specified one become undefined; hence, the library may make use of this.
@end table
@node _gfortran_caf_co_sum
@subsection @code{_gfortran_caf_co_sum} --- Collective summing reduction
@cindex Coarray, _gfortran_caf_co_sum
@table @asis
@item @emph{Description}:
Calculates the for the each array element of the variable @var{a} the sum
value for that element in the current team; if @var{result_image} has the
value 0, the result shall be stored on all images, otherwise, only on the
specified image. This function operates on numeric values.
@item @emph{Syntax}:
@code{void _gfortran_caf_co_sum (gfc_descriptor_t *a, int result_image,
int *stat, char *errmsg, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{a} @tab intent(inout) And array descriptor with the data to be
breoadcasted (on @var{source_image}) or to be received (other images).
@item @var{result_image} @tab The ID of the image to which the reduced
value should be copied to; if zero, it has to be copied to all images.
@item @var{stat} @tab intent(out) Stores the status STAT= and my may be NULL.
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@end multitable
@item @emph{NOTES}
If @var{result_image} is nonzero, the value on all images except of the
specified one become undefined; hence, the library may make use of this.
@end table
@node _gfortran_caf_co_reduce
@subsection @code{_gfortran_caf_co_reduce} --- Generic collective reduction
@cindex Coarray, _gfortran_caf_co_reduce
@table @asis
@item @emph{Description}:
Calculates the for the each array element of the variable @var{a} the reduction
value for that element in the current team; if @var{result_image} has the
value 0, the result shall be stored on all images, otherwise, only on the
specified image. The @var{opr} is a pure function doing a mathematically
commutative and associative operation.
The @var{opr_flags} denote the following; the values are bitwise ored.
@code{GFC_CAF_BYREF} (1) if the result should be returned
by value; @code{GFC_CAF_HIDDENLEN} (2) whether the result and argument
string lengths shall be specified as hidden argument;
@code{GFC_CAF_ARG_VALUE} (4) whether the arguments shall be passed by value,
@code{GFC_CAF_ARG_DESC} (8) whether the arguments shall be passed by descriptor.
@item @emph{Syntax}:
@code{void _gfortran_caf_co_reduce (gfc_descriptor_t *a,
void * (*opr) (void *, void *), int opr_flags, int result_image,
int *stat, char *errmsg, int a_len, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{opr} @tab Function pointer to the reduction function.
@item @var{opr_flags} @tab Flags regarding the reduction function
@item @var{a} @tab intent(inout) And array descriptor with the data to be
breoadcasted (on @var{source_image}) or to be received (other images).
@item @var{result_image} @tab The ID of the image to which the reduced
value should be copied to; if zero, it has to be copied to all images.
@item @var{stat} @tab intent(out) Stores the status STAT= and my may be NULL.
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{a_len} @tab The string length of argument @var{a}.
@item @var{errmsg_len} @tab the buffer size of errmsg.
@end multitable
@item @emph{NOTES}
If @var{result_image} is nonzero, the value on all images except of the
specified one become undefined; hence, the library may make use of this.
For character arguments, the result is passed as first argument, followed
by the result string length, next come the two string arguments, followed
by the two hidden arguments. With C binding, there are no hidden arguments
and by-reference passing and either only a single character is passed or
an array descriptor.
@end table
@c Intrinsic Procedures @c Intrinsic Procedures
@c --------------------------------------------------------------------- @c ---------------------------------------------------------------------

107
gcc/fortran/intrinsic.texi
View File

@ -98,6 +98,7 @@ Some basic guidelines for editing this document:
* @code{CO_BROADCAST}: CO_BROADCAST, Copy a value to all images the current set of images * @code{CO_BROADCAST}: CO_BROADCAST, Copy a value to all images the current set of images
* @code{CO_MAX}: CO_MAX, Maximal value on the current set of images * @code{CO_MAX}: CO_MAX, Maximal value on the current set of images
* @code{CO_MIN}: CO_MIN, Minimal value on the current set of images * @code{CO_MIN}: CO_MIN, Minimal value on the current set of images
* @code{CO_REDUCE}: CO_REDUCE, Reduction of values on the current set of images
* @code{CO_SUM}: CO_SUM, Sum of values on the current set of images * @code{CO_SUM}: CO_SUM, Sum of values on the current set of images
* @code{COMMAND_ARGUMENT_COUNT}: COMMAND_ARGUMENT_COUNT, Get number of command line arguments * @code{COMMAND_ARGUMENT_COUNT}: COMMAND_ARGUMENT_COUNT, Get number of command line arguments
* @code{COMPILER_OPTIONS}: COMPILER_OPTIONS, Options passed to the compiler * @code{COMPILER_OPTIONS}: COMPILER_OPTIONS, Options passed to the compiler
@ -3340,7 +3341,7 @@ end program test
@end smallexample @end smallexample
@item @emph{See also}: @item @emph{See also}:
@ref{CO_MAX}, @ref{CO_MIN}, @ref{CO_SUM} @ref{CO_MAX}, @ref{CO_MIN}, @ref{CO_SUM}, @ref{CO_REDUCE}
@end table @end table
@ -3354,7 +3355,7 @@ end program test
@item @emph{Description}: @item @emph{Description}:
@code{CO_MAX} determines element-wise the maximal value of @var{A} on all @code{CO_MAX} determines element-wise the maximal value of @var{A} on all
images of the current team. If @var{RESULT_IMAGE} is present, the maximum images of the current team. If @var{RESULT_IMAGE} is present, the maximum
values are returned on in @var{A} on the specified image only and the value values are returned in @var{A} on the specified image only and the value
of @var{A} on the other images become undefined. If @var{RESULT_IMAGE} is of @var{A} on the other images become undefined. If @var{RESULT_IMAGE} is
not present, the value is returned on all images. If the execution was not present, the value is returned on all images. If the execution was
successful and @var{STAT} is present, it is assigned the value zero. If the successful and @var{STAT} is present, it is assigned the value zero. If the
@ -3394,7 +3395,7 @@ end program test
@end smallexample @end smallexample
@item @emph{See also}: @item @emph{See also}:
@ref{CO_MIN}, @ref{CO_SUM}, @ref{CO_BROADCAST} @ref{CO_MIN}, @ref{CO_SUM}, @ref{CO_REDUCE}, @ref{CO_BROADCAST}
@end table @end table
@ -3408,7 +3409,7 @@ end program test
@item @emph{Description}: @item @emph{Description}:
@code{CO_MIN} determines element-wise the minimal value of @var{A} on all @code{CO_MIN} determines element-wise the minimal value of @var{A} on all
images of the current team. If @var{RESULT_IMAGE} is present, the minimal images of the current team. If @var{RESULT_IMAGE} is present, the minimal
values are returned on in @var{A} on the specified image only and the value values are returned in @var{A} on the specified image only and the value
of @var{A} on the other images become undefined. If @var{RESULT_IMAGE} is of @var{A} on the other images become undefined. If @var{RESULT_IMAGE} is
not present, the value is returned on all images. If the execution was not present, the value is returned on all images. If the execution was
successful and @var{STAT} is present, it is assigned the value zero. If the successful and @var{STAT} is present, it is assigned the value zero. If the
@ -3448,7 +3449,87 @@ end program test
@end smallexample @end smallexample
@item @emph{See also}: @item @emph{See also}:
@ref{CO_MAX}, @ref{CO_SUM}, @ref{CO_BROADCAST} @ref{CO_MAX}, @ref{CO_SUM}, @ref{CO_REDUCE}, @ref{CO_BROADCAST}
@end table
@node CO_REDUCE
@section @code{CO_REDUCE} --- Reduction of values on the current set of images
@fnindex CO_REDUCE
@cindex Collectives, generic reduction
@table @asis
@item @emph{Description}:
@code{CO_REDUCE} determines element-wise the reduction of the value of @var{A}
on all images of the current team. The pure function passed as @var{OPERATOR}
is used to pairwise reduce the values of @var{A} by passing either the value
of @var{A} of different images or the result values of such a reduction as
argument. If @var{A} is an array, the deduction is done element wise. If
@var{RESULT_IMAGE} is present, the result values are returned in @var{A} on
the specified image only and the value of @var{A} on the other images become
undefined. If @var{RESULT_IMAGE} is not present, the value is returned on all
images. If the execution was successful and @var{STAT} is present, it is
assigned the value zero. If the execution failed, @var{STAT} gets assigned
a nonzero value and, if present, @var{ERRMSG} gets assigned a value describing
the occurred error.
@item @emph{Standard}:
Technical Specification (TS) 18508 or later
@item @emph{Class}:
Collective subroutine
@item @emph{Syntax}:
@code{CALL CO_REDUCE(A, OPERATOR, [, RESULT_IMAGE, STAT, ERRMSG])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{A} @tab is an @code{INTENT(INOUT)} argument and shall be
nonpolymorphic. If it is allocatable, it shall be allocated; if it is a pointer,
it shall be associated. @var{A} shall have the same type and type parameters on
all images of the team; if it is an array, it shall have the same shape on all
images.
@item @var{OPERATOR} @tab pure function with two scalar nonallocatable
arguments, which shall be nonpolymorphic and have the same type and type
parameters as @var{A}. The function shall return a nonallocatable scalar of
the same type and type parameters as @var{A}. The function shall be the same on
all images and with regards to the arguments mathematically commutative and
associative. Note that @var{OPERATOR} may not be an elemental function, unless
it is an intrisic function.
@item @var{RESULT_IMAGE} @tab (optional) a scalar integer expression; if
present, it shall have the same the same value on all images and refer to an
image of the current team.
@item @var{STAT} @tab (optional) a scalar integer variable
@item @var{ERRMSG} @tab (optional) a scalar character variable
@end multitable
@item @emph{Example}:
@smallexample
program test
integer :: val
val = this_image ()
call co_reduce (val, result_image=1, operator=myprod)
if (this_image() == 1) then
write(*,*) "Product value", val ! prints num_images() factorial
end if
contains
pure function myprod(a, b)
integer, value :: a, b
integer :: myprod
myprod = a * b
end function myprod
end program test
@end smallexample
@item @emph{Note}:
While the rules permit in principle an intrinsic function, none of the
intrinsics in the standard fulfill the criteria of having a specific
function, which takes two arguments of the same type and returning that
type as result.
@item @emph{See also}:
@ref{CO_MIN}, @ref{CO_MAX}, @ref{CO_SUM}, @ref{CO_BROADCAST}
@end table @end table
@ -3462,7 +3543,7 @@ end program test
@item @emph{Description}: @item @emph{Description}:
@code{CO_SUM} sums up the values of each element of @var{A} on all @code{CO_SUM} sums up the values of each element of @var{A} on all
images of the current team. If @var{RESULT_IMAGE} is present, the summed-up images of the current team. If @var{RESULT_IMAGE} is present, the summed-up
values are returned on in @var{A} on the specified image only and the value values are returned in @var{A} on the specified image only and the value
of @var{A} on the other images become undefined. If @var{RESULT_IMAGE} is of @var{A} on the other images become undefined. If @var{RESULT_IMAGE} is
not present, the value is returned on all images. If the execution was not present, the value is returned on all images. If the execution was
successful and @var{STAT} is present, it is assigned the value zero. If the successful and @var{STAT} is present, it is assigned the value zero. If the
@ -3502,7 +3583,7 @@ end program test
@end smallexample @end smallexample
@item @emph{See also}: @item @emph{See also}:
@ref{CO_MAX}, @ref{CO_MIN}, @ref{CO_BROADCAST} @ref{CO_MAX}, @ref{CO_MIN}, @ref{CO_REDUCE}, @ref{CO_BROADCAST}
@end table @end table
@ -3671,7 +3752,7 @@ value is of default @code{COMPLEX} type.
If @var{X} and @var{Y} are of @code{REAL} type, or one is of @code{REAL} If @var{X} and @var{Y} are of @code{REAL} type, or one is of @code{REAL}
type and one is of @code{INTEGER} type, then the return value is of type and one is of @code{INTEGER} type, then the return value is of
@code{COMPLEX} type with a kind equal to that of the @code{REAL} @code{COMPLEX} type with a kind equal to that of the @code{REAL}
argument with the highest precision. argument with the highest precision.
@item @emph{Example}: @item @emph{Example}:
@smallexample @smallexample
@ -3689,7 +3770,7 @@ end program test_complex
@node CONJG @node CONJG
@section @code{CONJG} --- Complex conjugate function @section @code{CONJG} --- Complex conjugate function
@fnindex CONJG @fnindex CONJG
@fnindex DCONJG @fnindex DCONJG
@cindex complex conjugate @cindex complex conjugate
@ -3739,7 +3820,7 @@ end program test_conjg
@node COS @node COS
@section @code{COS} --- Cosine function @section @code{COS} --- Cosine function
@fnindex COS @fnindex COS
@fnindex DCOS @fnindex DCOS
@fnindex CCOS @fnindex CCOS
@ -3798,7 +3879,7 @@ Inverse function: @ref{ACOS}
@node COSH @node COSH
@section @code{COSH} --- Hyperbolic cosine function @section @code{COSH} --- Hyperbolic cosine function
@fnindex COSH @fnindex COSH
@fnindex DCOSH @fnindex DCOSH
@cindex hyperbolic cosine @cindex hyperbolic cosine
@ -4166,7 +4247,7 @@ end program test_time_and_date
@node DBLE @node DBLE
@section @code{DBLE} --- Double conversion function @section @code{DBLE} --- Double conversion function
@fnindex DBLE @fnindex DBLE
@cindex conversion, to real @cindex conversion, to real
@ -4448,7 +4529,7 @@ end program test_dprod
@item @emph{Specific names}: @item @emph{Specific names}:
@multitable @columnfractions .20 .20 .20 .25 @multitable @columnfractions .20 .20 .20 .25
@item Name @tab Argument @tab Return type @tab Standard @item Name @tab Argument @tab Return type @tab Standard
@item @code{DPROD(X,Y)} @tab @code{REAL(4) X, Y} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DPROD(X,Y)} @tab @code{REAL(4) X, Y} @tab @code{REAL(8)} @tab Fortran 77 and later
@end multitable @end multitable
@end table @end table

8
gcc/fortran/libgfortran.h
View File

@ -130,6 +130,14 @@ typedef enum
GFC_CAF_ATOMIC_XOR GFC_CAF_ATOMIC_XOR
} libcaf_atomic_codes; } libcaf_atomic_codes;
/* For CO_REDUCE. */
#define GFC_CAF_BYREF (1<<0)
#define GFC_CAF_HIDDENLEN (1<<1)
#define GFC_CAF_ARG_VALUE (1<<2)
#define GFC_CAF_ARG_DESC (1<<3)
/* Default unit number for preconnected standard input and output. */ /* Default unit number for preconnected standard input and output. */
#define GFC_STDIN_UNIT_NUMBER 5 #define GFC_STDIN_UNIT_NUMBER 5
#define GFC_STDOUT_UNIT_NUMBER 6 #define GFC_STDOUT_UNIT_NUMBER 6

9
gcc/fortran/trans-decl.c
View File

@ -153,6 +153,7 @@ tree gfor_fndecl_caf_unlock;
tree gfor_fndecl_co_broadcast; tree gfor_fndecl_co_broadcast;
tree gfor_fndecl_co_max; tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min; tree gfor_fndecl_co_min;
tree gfor_fndecl_co_reduce;
tree gfor_fndecl_co_sum; tree gfor_fndecl_co_sum;
@ -3445,6 +3446,14 @@ gfc_build_builtin_function_decls (void)
void_type_node, 6, pvoid_type_node, integer_type_node, void_type_node, 6, pvoid_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node, integer_type_node); pint_type, pchar_type_node, integer_type_node, integer_type_node);
gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_reduce")), "W.R.WW",
void_type_node, 8, pvoid_type_node,
build_pointer_type (build_varargs_function_type_list (void_type_node,
NULL_TREE)),
integer_type_node, integer_type_node, pint_type, pchar_type_node,
integer_type_node, integer_type_node);
gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec ( gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_sum")), "W.WW", get_identifier (PREFIX("caf_co_sum")), "W.WW",
void_type_node, 5, pvoid_type_node, integer_type_node, void_type_node, 5, pvoid_type_node, integer_type_node,

72
gcc/fortran/trans-intrinsic.c
View File

@ -8563,15 +8563,31 @@ conv_co_collective (gfc_code *code)
gfc_se argse; gfc_se argse;
stmtblock_t block, post_block; stmtblock_t block, post_block;
tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len; tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len;
gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
gfc_start_block (&block); gfc_start_block (&block);
gfc_init_block (&post_block); gfc_init_block (&post_block);
if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
{
opr_expr = code->ext.actual->next->expr;
image_idx_expr = code->ext.actual->next->next->expr;
stat_expr = code->ext.actual->next->next->next->expr;
errmsg_expr = code->ext.actual->next->next->next->next->expr;
}
else
{
opr_expr = NULL;
image_idx_expr = code->ext.actual->next->expr;
stat_expr = code->ext.actual->next->next->expr;
errmsg_expr = code->ext.actual->next->next->next->expr;
}
/* stat. */ /* stat. */
if (code->ext.actual->next->next->expr) if (stat_expr)
{ {
gfc_init_se (&argse, NULL); gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, code->ext.actual->next->next->expr); gfc_conv_expr (&argse, stat_expr);
gfc_add_block_to_block (&block, &argse.pre); gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post); gfc_add_block_to_block (&post_block, &argse.post);
stat = argse.expr; stat = argse.expr;
@ -8620,10 +8636,10 @@ conv_co_collective (gfc_code *code)
strlen = integer_zero_node; strlen = integer_zero_node;
/* image_index. */ /* image_index. */
if (code->ext.actual->next->expr) if (image_idx_expr)
{ {
gfc_init_se (&argse, NULL); gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, code->ext.actual->next->expr); gfc_conv_expr (&argse, image_idx_expr);
gfc_add_block_to_block (&block, &argse.pre); gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post); gfc_add_block_to_block (&post_block, &argse.post);
image_index = fold_convert (integer_type_node, argse.expr); image_index = fold_convert (integer_type_node, argse.expr);
@ -8632,10 +8648,10 @@ conv_co_collective (gfc_code *code)
image_index = integer_zero_node; image_index = integer_zero_node;
/* errmsg. */ /* errmsg. */
if (code->ext.actual->next->next->next->expr) if (errmsg_expr)
{ {
gfc_init_se (&argse, NULL); gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr); gfc_conv_expr (&argse, errmsg_expr);
gfc_add_block_to_block (&block, &argse.pre); gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post); gfc_add_block_to_block (&post_block, &argse.post);
errmsg = argse.expr; errmsg = argse.expr;
@ -8659,6 +8675,9 @@ conv_co_collective (gfc_code *code)
case GFC_ISYM_CO_MIN: case GFC_ISYM_CO_MIN:
fndecl = gfor_fndecl_co_min; fndecl = gfor_fndecl_co_min;
break; break;
case GFC_ISYM_CO_REDUCE:
fndecl = gfor_fndecl_co_reduce;
break;
case GFC_ISYM_CO_SUM: case GFC_ISYM_CO_SUM:
fndecl = gfor_fndecl_co_sum; fndecl = gfor_fndecl_co_sum;
break; break;
@ -8670,9 +8689,44 @@ conv_co_collective (gfc_code *code)
|| code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
fndecl = build_call_expr_loc (input_location, fndecl, 5, array, fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
image_index, stat, errmsg, errmsg_len); image_index, stat, errmsg, errmsg_len);
else else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index, fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index,
stat, errmsg, strlen, errmsg_len); stat, errmsg, strlen, errmsg_len);
else
{
tree opr, opr_flags;
// FIXME: Handle TS29113's bind(C) strings with descriptor.
int opr_flag_int;
if (gfc_is_proc_ptr_comp (opr_expr))
{
gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
opr_flag_int = sym->attr.dimension
|| (sym->ts.type == BT_CHARACTER
&& !sym->attr.is_bind_c)
? GFC_CAF_BYREF : 0;
opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
&& !sym->attr.is_bind_c
? GFC_CAF_HIDDENLEN : 0;
opr_flag_int |= sym->formal->sym->attr.value ? GFC_CAF_ARG_VALUE : 0;
}
else
{
opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
? GFC_CAF_BYREF : 0;
opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
&& !opr_expr->symtree->n.sym->attr.is_bind_c
? GFC_CAF_HIDDENLEN : 0;
opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
? GFC_CAF_ARG_VALUE : 0;
}
opr_flags = build_int_cst (integer_type_node, opr_flag_int);
gfc_conv_expr (&argse, opr_expr);
opr = gfc_build_addr_expr (NULL_TREE, argse.expr);
fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags,
image_index, stat, errmsg, strlen, errmsg_len);
}
gfc_add_expr_to_block (&block, fndecl); gfc_add_expr_to_block (&block, fndecl);
gfc_add_block_to_block (&block, &post_block); gfc_add_block_to_block (&block, &post_block);
@ -9386,12 +9440,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_caf_send (code); res = conv_caf_send (code);
break; break;
case GFC_ISYM_CO_REDUCE:
gcc_unreachable ();
break;
case GFC_ISYM_CO_BROADCAST: case GFC_ISYM_CO_BROADCAST:
case GFC_ISYM_CO_MIN: case GFC_ISYM_CO_MIN:
case GFC_ISYM_CO_MAX: case GFC_ISYM_CO_MAX:
case GFC_ISYM_CO_REDUCE:
case GFC_ISYM_CO_SUM: case GFC_ISYM_CO_SUM:
res = conv_co_collective (code); res = conv_co_collective (code);
break; break;

1
gcc/fortran/trans.h
View File

@ -742,6 +742,7 @@ extern GTY(()) tree gfor_fndecl_caf_unlock;
extern GTY(()) tree gfor_fndecl_co_broadcast; extern GTY(()) tree gfor_fndecl_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max; extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min; extern GTY(()) tree gfor_fndecl_co_min;
extern GTY(()) tree gfor_fndecl_co_reduce;
extern GTY(()) tree gfor_fndecl_co_sum; extern GTY(()) tree gfor_fndecl_co_sum;

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
2014-10-24 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_collectives_9.f90: Remove dg-error.
* gfortran.dg/coarray_collectives_13.f90: New.
* gfortran.dg/coarray_collectives_14.f90: New.
* gfortran.dg/coarray_collectives_15.f90: New.
* gfortran.dg/coarray_collectives_16.f90: New.
2014-10-24 Jiong Wang <jiong.wang@arm.com> 2014-10-24 Jiong Wang <jiong.wang@arm.com>
* gcc.target/arm/aapcs/abitest.h: Declare memcpy. * gcc.target/arm/aapcs/abitest.h: Declare memcpy.

11
gcc/testsuite/gfortran.dg/coarray_collectives_13.f90 Normal file
View File

@ -0,0 +1,11 @@
! { dg-do compile }
! { dg-options "-fcoarray=single -std=f2008" }
!
!
! CO_REDUCE/CO_BROADCAST
!
program test
implicit none
intrinsic co_reduce ! { dg-error "is not available in the current standard settings but new in TS 29113/TS 18508." }
intrinsic co_broadcast ! { dg-error "is not available in the current standard settings but new in TS 29113/TS 18508." }
end program test

146
gcc/testsuite/gfortran.dg/coarray_collectives_14.f90 Normal file
View File

@ -0,0 +1,146 @@
! { dg-do compile }
! { dg-options "-fcoarray=single -fmax-errors=80" }
!
!
! CO_REDUCE (plus CO_MIN/MAX/SUM/BROADCAST)
!
program test
implicit none (external, type)
intrinsic co_reduce
intrinsic co_broadcast
intrinsic co_min
intrinsic co_max
intrinsic co_sum
intrinsic dprod
external ext
type t
procedure(), nopass :: ext
procedure(valid), nopass :: valid
procedure(sub), nopass :: sub
procedure(nonpure), nopass :: nonpure
procedure(arg1), nopass :: arg1
procedure(arg2), nopass :: arg2
procedure(elem), nopass :: elem
procedure(realo), nopass :: realo
procedure(int8), nopass :: int8
procedure(arr), nopass :: arr
procedure(ptr), nopass :: ptr
procedure(alloc), nopass :: alloc
procedure(opt), nopass :: opt
procedure(val), nopass :: val
procedure(async), nopass :: async
procedure(tgt), nopass :: tgt
procedure(char44), nopass :: char44
procedure(char34), nopass :: char34
end type t
type(t) :: dt
integer :: caf[*]
character(len=3) :: c3
character(len=4) :: c4
call co_min(caf[1]) ! { dg-error "shall not be coindexed" }
call co_max(caf[1]) ! { dg-error "shall not be coindexed" }
call co_sum(caf[1]) ! { dg-error "shall not be coindexed" }
call co_broadcast(caf[1], source_image=1) ! { dg-error "shall not be coindexed" }
call co_reduce(caf[1], valid) ! { dg-error "shall not be coindexed" }
call co_reduce(caf, valid) ! OK
call co_reduce(caf, dt%valid) ! OK
call co_reduce(caf, dprod) ! { dg-error "is not permitted for CO_REDUCE" }
call co_reduce(caf, ext) ! { dg-error "must be a PURE function" }
call co_reduce(caf, dt%ext) ! { dg-error "must be a PURE function" }
call co_reduce(caf, sub) ! { dg-error "must be a PURE function" }
call co_reduce(caf, dt%sub) ! { dg-error "must be a PURE function" }
call co_reduce(caf, nonpure) ! { dg-error "must be a PURE function" }
call co_reduce(caf, dt%nonpure) ! { dg-error "must be a PURE function" }
call co_reduce(caf, arg1) ! { dg-error "shall have two arguments" }
call co_reduce(caf, dt%arg1) ! { dg-error "shall have two arguments" }
call co_reduce(caf, arg3) ! { dg-error "shall have two arguments" }
call co_reduce(caf, dt%arg3) ! { dg-error "shall have two arguments" }
call co_reduce(caf, elem) ! { dg-error "ELEMENTAL non-INTRINSIC procedure 'elem' is not allowed as an actual argument" }
call co_reduce(caf, dt%elem) ! { dg-error "ELEMENTAL non-INTRINSIC procedure 'elem' is not allowed as an actual argument" }
call co_reduce(caf, realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns REAL.4." }
call co_reduce(caf, dt%realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns REAL.4." }
call co_reduce(caf, int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns INTEGER.8." }
call co_reduce(caf, dt%int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns INTEGER.8." }
call co_reduce(caf, arr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
call co_reduce(caf, dt%arr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
call co_reduce(caf, ptr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
call co_reduce(caf, dt%ptr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
call co_reduce(caf, alloc) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
call co_reduce(caf, dt%alloc) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
call co_reduce(caf, opt) ! { dg-error "shall not have the OPTIONAL attribute for either of the arguments" }
call co_reduce(caf, dt%opt) ! { dg-error "shall not have the OPTIONAL attribute for either of the arguments" }
call co_reduce(caf, val) ! { dg-error "shall have the VALUE attribute either for none or both arguments" }
call co_reduce(caf, dt%val) ! { dg-error "shall have the VALUE attribute either for none or both arguments" }
call co_reduce(caf, async) ! { dg-error "shall have the ASYNCHRONOUS attribute either for none or both arguments" }
call co_reduce(caf, dt%async) ! { dg-error "shall have the ASYNCHRONOUS attribute either for none or both arguments" }
call co_reduce(caf, tgt) ! { dg-error "shall have the TARGET attribute either for none or both arguments" }
call co_reduce(caf, dt%tgt) ! { dg-error "shall have the TARGET attribute either for none or both arguments" }
call co_reduce(c4, char44) ! OK
call co_reduce(c4, dt%char44) ! OK
call co_reduce(c3, char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATOR at .2. shall be the same" }
call co_reduce(c3, dt%char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATOR at .2. shall be the same" }
call co_reduce(c4, char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATOR at .2. shall be the same" }
call co_reduce(c4, dt%char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATOR at .2. shall be the same" }
contains
pure integer function valid(x,y)
integer, value :: x, y
end function valid
impure integer function nonpure(x,y)
integer, value :: x, y
end function nonpure
pure subroutine sub()
end subroutine sub
pure integer function arg3(x, y, z)
integer, value :: x, y, z
end function arg3
pure integer function arg1(x)
integer, value :: x
end function arg1
pure elemental integer function elem(x,y)
integer, value :: x, y
end function elem
pure real function realo(x,y)
integer, value :: x, y
end function realo
pure integer(8) function int8(x,y)
integer, value :: x, y
end function int8
pure integer function arr(x,y)
integer, intent(in) :: x(:), y
end function arr
pure integer function ptr(x,y)
integer, intent(in), pointer :: x, y
end function ptr
pure integer function alloc(x,y)
integer, intent(in), allocatable :: x, y
end function alloc
pure integer function opt(x,y)
integer, intent(in) :: x, y
optional :: x, y
end function opt
pure integer function val(x,y)
integer, value :: x
integer, intent(in) :: y
end function val
pure integer function tgt(x,y)
integer, intent(in) :: x, y
target :: x
end function tgt
pure integer function async(x,y)
integer, intent(in) :: x, y
asynchronous :: y
end function async
pure character(4) function char44(x,y)
character(len=4), value :: x, y
end function char44
pure character(3) function char34(x,y)
character(len=4), value :: x, y
end function char34
end program test

20
gcc/testsuite/gfortran.dg/coarray_collectives_15.f90 Normal file
View File

@ -0,0 +1,20 @@
! { dg-do compile }
! { dg-options "-fdump-tree-original -fcoarray=single" }
!
! CO_REDUCE
!
program test
implicit none
intrinsic co_reduce
integer :: stat1
real :: val
call co_reduce(val, valid, result_image=1, stat=stat1)
contains
pure real function valid(x,y)
real, value :: x, y
valid = x * y
end function valid
end program test
! { dg-final { scan-tree-dump-times "stat1 = 0;" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

39
gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 Normal file
View File

@ -0,0 +1,39 @@
! { dg-do compile }
! { dg-options "-fdump-tree-original -fcoarray=lib" }
!
! CO_REDUCE
!
program test
implicit none
intrinsic co_max
integer :: stat1, stat2, stat3
character(len=6) :: errmesg1
character(len=7) :: errmesg2
character(len=8) :: errmesg3
real :: val1
complex, allocatable :: val2(:)
character(len=99) :: val3
integer :: res
call co_reduce(val1, operator=fr, result_image=num_images(), stat=stat1, errmsg=errmesg1)
call co_reduce(val2, operator=gz, result_image=4, stat=stat2, errmsg=errmesg2)
call co_reduce(val3, operator=hc, result_image=res,stat=stat3, errmsg=errmesg3)
contains
pure real function fr(x,y)
real, value :: x, y
fr = x * y
end function fr
pure complex function gz(x,y)
complex, intent(in):: x, y
gz = x *y
end function gz
pure character(len=99) function hc(x,y)
character(len=99), intent(in):: x, y
hc = x(1:50) // y(1:49)
end function hc
end program test
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., &fr, 4, _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 0, 6\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&val2, &gz, 0, 4, &stat2, errmesg2, 0, 7\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., &hc, 1, res, &stat3, errmesg3, 99, 8\\);" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

4
gcc/testsuite/gfortran.dg/coarray_collectives_9.f90
View File

@ -49,8 +49,8 @@ program test
call co_reduce(val, red_f, stat=[1,2]) ! { dg-error "must be a scalar" } call co_reduce(val, red_f, stat=[1,2]) ! { dg-error "must be a scalar" }
call co_reduce(val, red_f, stat=1.0) ! { dg-error "must be INTEGER" } call co_reduce(val, red_f, stat=1.0) ! { dg-error "must be INTEGER" }
call co_reduce(val, red_f, stat=1) ! { dg-error "must be a variable" } call co_reduce(val, red_f, stat=1) ! { dg-error "must be a variable" }
call co_reduce(val, red_f, stat=i, result_image=1) ! { dg-error "CO_REDUCE at \\(1\\) is not yet implemented" } call co_reduce(val, red_f, stat=i, result_image=1) ! OK
call co_reduce(val, red_f, stat=i, errmsg=errmsg, result_image=1) ! { dg-error "CO_REDUCE at \\(1\\) is not yet implemented" } call co_reduce(val, red_f, stat=i, errmsg=errmsg, result_image=1) ! OK
call co_reduce(val, red_f, stat=i, errmsg=[errmsg], result_image=1) ! { dg-error "must be a scalar" } call co_reduce(val, red_f, stat=i, errmsg=[errmsg], result_image=1) ! { dg-error "must be a scalar" }
call co_reduce(val, red_f, stat=i, errmsg=5, result_image=1) ! { dg-error "must be CHARACTER" } call co_reduce(val, red_f, stat=i, errmsg=5, result_image=1) ! { dg-error "must be CHARACTER" }
call co_reduce(val, red_f, errmsg="abc") ! { dg-error "must be a variable" } call co_reduce(val, red_f, errmsg="abc") ! { dg-error "must be a variable" }