diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 6ea6e136d4f..15772009af4 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2265,7 +2265,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, attr = gfc_expr_attr (op); if (!attr.pure || !attr.function) { - gfc_error ("OPERATOR argument at %L must be a PURE function", + gfc_error ("OPERATION argument at %L must be a PURE function", &op->where); return false; } @@ -2292,7 +2292,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, if (!formal || !formal->next || formal->next->next) { - gfc_error ("The function passed as OPERATOR at %L shall have two " + gfc_error ("The function passed as OPERATION at %L shall have two " "arguments", &op->where); return false; } @@ -2303,7 +2303,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, if (!gfc_compare_types (&a->ts, &sym->result->ts)) { gfc_error ("The A argument at %L has type %s but the function passed as " - "OPERATOR at %L returns %s", + "OPERATION at %L returns %s", &a->where, gfc_typename (a), &op->where, gfc_typename (&sym->result->ts)); return false; @@ -2311,7 +2311,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, 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 " + gfc_error ("The function passed as OPERATION 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)); @@ -2322,7 +2322,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, || 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 " + gfc_error ("The function passed as OPERATION at %L shall have scalar " "nonallocatable nonpointer arguments and return a " "nonallocatable nonpointer scalar", &op->where); return false; @@ -2330,21 +2330,21 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, if (formal->sym->attr.value != formal->next->sym->attr.value) { - gfc_error ("The function passed as OPERATOR at %L shall have the VALUE " + gfc_error ("The function passed as OPERATION 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 " + gfc_error ("The function passed as OPERATION 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 " + gfc_error ("The function passed as OPERATION at %L shall have the " "ASYNCHRONOUS attribute either for none or both arguments", &op->where); return false; @@ -2352,7 +2352,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, if (formal->sym->attr.optional || formal->next->sym->attr.optional) { - gfc_error ("The function passed as OPERATOR at %L shall not have the " + gfc_error ("The function passed as OPERATION at %L shall not have the " "OPTIONAL attribute for either of the arguments", &op->where); return false; } @@ -2383,14 +2383,14 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, || (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", + "arguments of the OPERATION 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", + "function result of the OPERATION at %L shall be the same", &a->where, &op->where); return false; } diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index f5c88d98cc9..cbf76728039 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -3805,7 +3805,7 @@ add_subroutines (void) BT_UNKNOWN, 0, GFC_STD_F2018, gfc_check_co_reduce, NULL, NULL, a, BT_REAL, dr, REQUIRED, INTENT_INOUT, - "operator", BT_INTEGER, di, REQUIRED, INTENT_IN, + "operation", BT_INTEGER, di, REQUIRED, INTENT_IN, result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 9201c38ec65..c757afd8690 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -3841,7 +3841,7 @@ end program test @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} +on all images of the current team. The pure function passed as @var{OPERATION} 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 @@ -3860,7 +3860,7 @@ Technical Specification (TS) 18508 or later Collective subroutine @item @emph{Syntax}: -@code{CALL CO_REDUCE(A, OPERATOR, [, RESULT_IMAGE, STAT, ERRMSG])} +@code{CALL CO_REDUCE(A, OPERATION, [, RESULT_IMAGE, STAT, ERRMSG])} @item @emph{Arguments}: @multitable @columnfractions .20 .65 @@ -3869,12 +3869,12 @@ 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 +@item @var{OPERATION} @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 +associative. Note that @var{OPERATION} 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 value on all images and refer to an @@ -3888,7 +3888,7 @@ image of the current team. program test integer :: val val = this_image () - call co_reduce (val, result_image=1, operator=myprod) + call co_reduce (val, result_image=1, operation=myprod) if (this_image() == 1) then write(*,*) "Product value", val ! prints num_images() factorial end if diff --git a/gcc/testsuite/gfortran.dg/co_reduce_2.f90 b/gcc/testsuite/gfortran.dg/co_reduce_2.f90 new file mode 100644 index 00000000000..42bd02a714e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/co_reduce_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! PR 103054 - wrong keyword name. +! Original test case by Damian Rouson. +program main + implicit none + logical :: co_all= .true. + call co_reduce(co_all, operator=both) ! { dg-error "Cannot find keyword" } + call co_reduce(co_all, operation=both) +contains + logical pure function both(lhs,rhs) + logical, intent(in) :: lhs, rhs + both = lhs .and. rhs + end function +end diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_14.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_14.f90 index 6d53411e149..15679eed894 100644 --- a/gcc/testsuite/gfortran.dg/coarray_collectives_14.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_14.f90 @@ -63,10 +63,10 @@ program test 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 procedure pointer component '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, realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATION 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 OPERATION 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 OPERATION 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 OPERATION 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" } @@ -83,10 +83,10 @@ program test 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" } + call co_reduce(c3, char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATION 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 OPERATION 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 OPERATION 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 OPERATION at .2. shall be the same" } contains pure integer function valid(x,y) diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 index 683beddcddf..8419cf9159d 100644 --- a/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 @@ -15,9 +15,9 @@ program test 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) + call co_reduce(val1, operation=fr, result_image=num_images(), stat=stat1, errmsg=errmesg1) + call co_reduce(val2, operation=gz, result_image=4, stat=stat2, errmsg=errmesg2) + call co_reduce(val3, operation=hc, result_image=res,stat=stat3, errmsg=errmesg3) contains pure real function fr(x,y) real, value :: x, y diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 index f53eb4e2f8d..ee3902c25e2 100644 --- a/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 @@ -26,10 +26,10 @@ program test end interface call co_broadcast("abc") ! { dg-error "Missing actual argument 'source_image' in call to 'co_broadcast'" } - call co_reduce("abc") ! { dg-error "Missing actual argument 'operator' in call to 'co_reduce'" } + call co_reduce("abc") ! { dg-error "Missing actual argument 'operation' in call to 'co_reduce'" } call co_broadcast(1, source_image=1) ! { dg-error "'a' argument of 'co_broadcast' intrinsic at .1. must be a variable" } - call co_reduce(a=1, operator=red_f) ! { dg-error "'a' argument of 'co_reduce' intrinsic at .1. must be a variable" } - call co_reduce(a=val, operator=red_f2) ! { dg-error "OPERATOR argument at \\(1\\) must be a PURE function" } + call co_reduce(a=1, operation=red_f) ! { dg-error "'a' argument of 'co_reduce' intrinsic at .1. must be a variable" } + call co_reduce(a=val, operation=red_f2) ! { dg-error "OPERATION argument at \\(1\\) must be a PURE function" } call co_broadcast(val, source_image=[1,2]) ! { dg-error "must be a scalar" } call co_broadcast(val, source_image=1.0) ! { dg-error "must be INTEGER" }