From patchwork Mon Oct 20 20:22:22 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 401248 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 8CFD4140080 for ; Tue, 21 Oct 2014 07:22:43 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=lmhGy5OqiH2O5Uzh5LpiaKKN0c1BLepLl4pR+acv/SNb3K XBaFRQinV1KyzZiF/R/PW71h2kRiHOJoRUaUtjtrojTrFh/m/TjYad3+preA2uIg wXJOxkG89a/p40qDL286RmKAZqq8US9Bq0m/u2PsLx+zMSxZtkb7YoKHvIa5E= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=PuUJBDN6gyKr1/LTfIzk3b562BA=; b=KQCXlhjDbehSyYWHzEcE etgfYYxMmcF2NBuF0SromiPGXKaAfnd/9waSdfT7GitLHTOGCzTpbjmOlpE5sJ+f UY63FaP6xQRs84mRo0Ix7pwg2T75HmOQkP6F41vvsZU8IA+24o0jX8+iUOPXz2fL T2MSFAyyrT1IM71SpUeGWtw= Received: (qmail 18679 invoked by alias); 20 Oct 2014 20:22:34 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 18655 invoked by uid 89); 20 Oct 2014 20:22:33 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=2.6 required=5.0 tests=AWL, BAYES_00, KAM_STOCKTIP autolearn=no version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mx01.qsc.de Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Mon, 20 Oct 2014 20:22:28 +0000 Received: from tux.net-b.de (port-92-194-240-118.dynamic.qsc.de [92.194.240.118]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by mx01.qsc.de (Postfix) with ESMTPSA id A2CED3CEAA; Mon, 20 Oct 2014 22:22:23 +0200 (CEST) Message-ID: <54456EFE.5000903@net-b.de> Date: Mon, 20 Oct 2014 22:22:22 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:31.0) Gecko/20100101 Thunderbird/31.1.0 MIME-Version: 1.0 To: gfortran , gcc-patches Subject: [Patch, Fortran] Add CO_REDUCE This patch adds some more checks and the actual implementation (compiler side and libcaf_single) for CO_REDUCE. It also rejects coindexed variables elsewhere, in line with the recent J3 changes. I also updated the API documentation (adding doc for collectives.) Still unsupported as elsewhere are allocatable components and finalization – the latter also still has to be addressed in the standard itself. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias 2014-10-20 Tobias Burnus 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. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 0a08c73..6f1fe3f 100644 --- a/gcc/fortran/check.c +++ b/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; } diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index d02452c..41d6559 100644 --- a/gcc/fortran/gfortran.texi +++ b/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 --------------------------------------------------------------------- diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 4d884d7..90c9a3a 100644 --- a/gcc/fortran/intrinsic.texi +++ b/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 diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index b7e11cb..dda755b 100644 --- a/gcc/fortran/libgfortran.h +++ b/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 diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 522c0f0..3fbc789 100644 --- a/gcc/fortran/trans-decl.c +++ b/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, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 1815903..932bf79 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/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; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 465661c..51ad910 100644 --- a/gcc/fortran/trans.h +++ b/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; diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_13.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_13.f90 new file mode 100644 index 0000000..906785c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_13.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_14.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_14.f90 new file mode 100644 index 0000000..f0ab932 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_14.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_15.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_15.f90 new file mode 100644 index 0000000..1e14dbb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_15.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 new file mode 100644 index 0000000..d7fb00b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 index 1921bf7..f53eb4e 100644 --- a/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 +++ b/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" }