2014-10-20 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.
@@ -1433,6 +1433,13 @@ check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
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 (!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)
{
- gfc_error ("Support for the A argument at %L which is polymorphic A "
- "argument or has allocatable components is not yet "
- "implemented", &a->where);
- return false;
+ gfc_error ("Support for the A argument at %L which is polymorphic A "
+ "argument or has allocatable components is not yet "
+ "implemented", &a->where);
+ return 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)
{
symbol_attribute attr;
+ gfc_formal_arglist *formal;
+ gfc_symbol *sym;
if (a->ts.type == BT_CLASS)
{
- gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
- &a->where);
- return false;
+ gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
+ &a->where);
+ return false;
}
if (gfc_expr_attr (a).alloc_comp)
{
- gfc_error ("Support for the A argument at %L with allocatable components"
- " is not yet implemented", &a->where);
- return false;
+ gfc_error ("Support for the A argument at %L with allocatable components"
+ " is not yet implemented", &a->where);
+ return false;
}
+ if (!check_co_collective (a, result_image, stat, errmsg, true))
+ return false;
+
+ if (!gfc_resolve_expr (op))
+ 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;
+ 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))
- 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;
+ }
- /* FIXME: After J3/WG5 has decided what they actually exactly want, more
- checks such as same-argument checks have to be added, implemented and
- intrinsic.texi upated. */
+ 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;
- gfc_error("CO_REDUCE at %L is not yet implemented", &a->where);
- return false;
+ 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;
}
@@ -3238,6 +3238,11 @@ caf_register_t;
* _gfortran_caf_sendget:: Sending data between remote images
* _gfortran_caf_lock:: Locking 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
@@ -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 ---------------------------------------------------------------------
@@ -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_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_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{COMMAND_ARGUMENT_COUNT}: COMMAND_ARGUMENT_COUNT, Get number of command line arguments
* @code{COMPILER_OPTIONS}: COMPILER_OPTIONS, Options passed to the compiler
@@ -3340,7 +3341,7 @@ end program test
@end smallexample
@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
@@ -3354,7 +3355,7 @@ end program test
@item @emph{Description}:
@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
-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
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
@@ -3394,7 +3395,7 @@ end program test
@end smallexample
@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
@@ -3408,7 +3409,7 @@ end program test
@item @emph{Description}:
@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
-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
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
@@ -3448,7 +3449,87 @@ end program test
@end smallexample
@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
@@ -3462,7 +3543,7 @@ end program test
@item @emph{Description}:
@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
-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
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
@@ -3502,7 +3583,7 @@ end program test
@end smallexample
@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
@@ -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}
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}
-argument with the highest precision.
+argument with the highest precision.
@item @emph{Example}:
@smallexample
@@ -3689,7 +3770,7 @@ end program test_complex
@node CONJG
-@section @code{CONJG} --- Complex conjugate function
+@section @code{CONJG} --- Complex conjugate function
@fnindex CONJG
@fnindex DCONJG
@cindex complex conjugate
@@ -3739,7 +3820,7 @@ end program test_conjg
@node COS
-@section @code{COS} --- Cosine function
+@section @code{COS} --- Cosine function
@fnindex COS
@fnindex DCOS
@fnindex CCOS
@@ -3798,7 +3879,7 @@ Inverse function: @ref{ACOS}
@node COSH
-@section @code{COSH} --- Hyperbolic cosine function
+@section @code{COSH} --- Hyperbolic cosine function
@fnindex COSH
@fnindex DCOSH
@cindex hyperbolic cosine
@@ -4166,7 +4247,7 @@ end program test_time_and_date
@node DBLE
-@section @code{DBLE} --- Double conversion function
+@section @code{DBLE} --- Double conversion function
@fnindex DBLE
@cindex conversion, to real
@@ -4448,7 +4529,7 @@ end program test_dprod
@item @emph{Specific names}:
@multitable @columnfractions .20 .20 .20 .25
@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 table
@@ -130,6 +130,14 @@ typedef enum
GFC_CAF_ATOMIC_XOR
} 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. */
#define GFC_STDIN_UNIT_NUMBER 5
#define GFC_STDOUT_UNIT_NUMBER 6
@@ -153,6 +153,7 @@ tree gfor_fndecl_caf_unlock;
tree gfor_fndecl_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
+tree gfor_fndecl_co_reduce;
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,
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 (
get_identifier (PREFIX("caf_co_sum")), "W.WW",
void_type_node, 5, pvoid_type_node, integer_type_node,
@@ -8563,15 +8563,31 @@ conv_co_collective (gfc_code *code)
gfc_se argse;
stmtblock_t block, post_block;
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_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. */
- if (code->ext.actual->next->next->expr)
+ if (stat_expr)
{
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 (&post_block, &argse.post);
stat = argse.expr;
@@ -8620,10 +8636,10 @@ conv_co_collective (gfc_code *code)
strlen = integer_zero_node;
/* image_index. */
- if (code->ext.actual->next->expr)
+ if (image_idx_expr)
{
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 (&post_block, &argse.post);
image_index = fold_convert (integer_type_node, argse.expr);
@@ -8632,10 +8648,10 @@ conv_co_collective (gfc_code *code)
image_index = integer_zero_node;
/* errmsg. */
- if (code->ext.actual->next->next->next->expr)
+ if (errmsg_expr)
{
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 (&post_block, &argse.post);
errmsg = argse.expr;
@@ -8659,6 +8675,9 @@ conv_co_collective (gfc_code *code)
case GFC_ISYM_CO_MIN:
fndecl = gfor_fndecl_co_min;
break;
+ case GFC_ISYM_CO_REDUCE:
+ fndecl = gfor_fndecl_co_reduce;
+ break;
case GFC_ISYM_CO_SUM:
fndecl = gfor_fndecl_co_sum;
break;
@@ -8670,9 +8689,44 @@ conv_co_collective (gfc_code *code)
|| code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
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,
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_block_to_block (&block, &post_block);
@@ -9386,12 +9440,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_caf_send (code);
break;
- case GFC_ISYM_CO_REDUCE:
- gcc_unreachable ();
- break;
case GFC_ISYM_CO_BROADCAST:
case GFC_ISYM_CO_MIN:
case GFC_ISYM_CO_MAX:
+ case GFC_ISYM_CO_REDUCE:
case GFC_ISYM_CO_SUM:
res = conv_co_collective (code);
break;
@@ -742,6 +742,7 @@ extern GTY(()) tree gfor_fndecl_caf_unlock;
extern GTY(()) tree gfor_fndecl_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
+extern GTY(()) tree gfor_fndecl_co_reduce;
extern GTY(()) tree gfor_fndecl_co_sum;
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -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" } }
new file mode 100644
@@ -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" } }
@@ -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.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=i, 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) ! { 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) ! 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=5, result_image=1) ! { dg-error "must be CHARACTER" }
call co_reduce(val, red_f, errmsg="abc") ! { dg-error "must be a variable" }