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

gcc/fortran/ChangeLog

+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>
 
 	PR fortran/48979

gcc/fortran/check.c

@@ -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;
 }
 
 

gcc/fortran/gfortran.texi

@@ -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 ---------------------------------------------------------------------
 

gcc/fortran/intrinsic.texi

@@ -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

gcc/fortran/libgfortran.h

@@ -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

gcc/fortran/trans-decl.c

@@ -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,

gcc/fortran/trans-intrinsic.c

@@ -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;

gcc/fortran/trans.h

@@ -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;
 
 

gcc/testsuite/ChangeLog

+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>
 
 	* gcc.target/arm/aapcs/abitest.h: Declare memcpy.

gcc/testsuite/gfortran.dg/coarray_collectives_13.f90

+! { 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

gcc/testsuite/gfortran.dg/coarray_collectives_14.f90

+! { 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

gcc/testsuite/gfortran.dg/coarray_collectives_15.f90

+! { 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" } }

gcc/testsuite/gfortran.dg/coarray_collectives_16.f90

+! { 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" } }

gcc/testsuite/gfortran.dg/coarray_collectives_9.f90

@@ -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" }