[gcc r12-4982] Fix keyword name for co_reduce.

[gcc r12-4982] Fix keyword name for co_reduce.

[Thomas König]

https://gcc.gnu.org/g:962ff7d2849e1fa6a1fe0535aa2dec5c2b9a32a6

commit r12-4982-g962ff7d2849e1fa6a1fe0535aa2dec5c2b9a32a6
Author: Thomas Koenig <tkoenig@gcc.gnu.org>
Date:   Sun Nov 7 15:38:35 2021 +0100

    Fix keyword name for co_reduce.
    
    gcc/fortran/ChangeLog:
    
            * intrinsic.c (add_subroutines): Change keyword "operator"
            to the correct one, "operation".
            * check.c (gfc_check_co_reduce): Change OPERATOR to
            OPERATION in error messages.
            * intrinsic.texi: Change OPERATOR to OPERATION in
            documentation.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/co_reduce_2.f90: New test.
            * gfortran.dg/coarray_collectives_14.f90: Change OPERATOR
            to OPERATION.
            * gfortran.dg/coarray_collectives_16.f90: Likewise.
            * gfortran.dg/coarray_collectives_9.f90: Likewise.
    
            Co-authored by: Steve Kargl <steve@gcc.gnu.org>

Diff:
---
 gcc/fortran/check.c                                | 22 +++++++++++-----------
 gcc/fortran/intrinsic.c                            |  2 +-
 gcc/fortran/intrinsic.texi                         | 10 +++++-----
 gcc/testsuite/gfortran.dg/co_reduce_2.f90          | 15 +++++++++++++++
 .../gfortran.dg/coarray_collectives_14.f90         | 16 ++++++++--------
 .../gfortran.dg/coarray_collectives_16.f90         |  6 +++---
 .../gfortran.dg/coarray_collectives_9.f90          |  6 +++---
 7 files changed, 46 insertions(+), 31 deletions(-)

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 54d2d33c7d5..a5a087be083 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -3806,7 +3806,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" }