[flang] Add `co_reduce` to the list of intrinsics and update test

[ktras]

Summary

Add the collective subroutine, co_reduce, to the list of
intrinsic subroutines. Move the check in ApplySpecificChecks()
for the intrinsic function, reduce, to a new function that can
perform the same checks on co_reduce as well. Add to the new
function, CheckReduceAndCoReduce, the additional checks that
only apply for the operation argument for co_reduce. Also
change the check for the volatile attribute on the operation
argument for reduce and co_reduce to a check for the value
attribute, since that is the attribute that is disallowed by the
standard. Update the co_reduce and reduce semantics tests.

[ktras]

flang/lib/Evaluate/intrinsics.cpp

2807

Here, I have transformed the string with the name of the intrinsic, if it is reduce, to match the form of the error messages that occurred before this patch for the reduce intrinsic. However, I don't have to do this. I am happy to do whatever is preferred. At the moment, for other error messages for other intrinsics, some of them have the intrinsic name and the argument names in all caps, and some have them all in lower case, so I wasn't sure which pattern I should try to match.

flang/docs/Intrinsics.md

 | Intrinsic Category | Intrinsic Procedures Lacking Support |
 | --- | --- |
 | Coarray intrinsic functions | IMAGE_INDEX, COSHAPE |
 | Object characteristic inquiry functions | ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, IS_CONTIGUOUS, PRESENT, RANK, SAME_TYPE, STORAGE_SIZE |
 | Type inquiry intrinsic functions | BIT_SIZE, DIGITS, EPSILON, HUGE, KIND, MAXEXPONENT, MINEXPONENT, NEW_LINE, PRECISION, RADIX, RANGE, TINY|
 | Non-standard intrinsic functions | AND, OR, XOR, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, NUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR, IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC |
 | Intrinsic subroutines |MVBITS (elemental), CPU_TIME, DATE_AND_TIME, EVENT_QUERY, EXECUTE_COMMAND_LINE, GET_COMMAND, GET_COMMAND_ARGUMENT, GET_ENVIRONMENT_VARIABLE, MOVE_ALLOC, RANDOM_INIT, RANDOM_NUMBER, RANDOM_SEED, SYSTEM_CLOCK |
 | Atomic intrinsic subroutines | ATOMIC_ADD |
-| Collective intrinsic subroutines | CO_REDUCE |
 
 
 ### Intrinsic Function Folding
 Fortran Constant Expressions can contain references to a certain number of
 intrinsic functions (see Fortran 2018 standard section 10.1.12 for more details).
 Constant Expressions may be used to define kind arguments. Therefore, the semantic
 expression analysis phase must be able to fold references to intrinsic functions
 listed in section 10.1.12.

flang/lib/Evaluate/intrinsics.cpp

static const IntrinsicInterface intrinsicSubroutine[]{
              Optionality::required, common::Intent::InOut},
             {"result_image", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::In},
             {"stat", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::Out},
             {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
                 common::Intent::InOut}},
         {}, Rank::elemental, IntrinsicClass::collectiveSubroutine},
+    {"co_reduce",
+        {{"a", SameType, Rank::anyOrAssumedRank, Optionality::required,
+             common::Intent::InOut},
+            {"operation", SameType, Rank::reduceOperation,
+                Optionality::required, common::Intent::In},
+            {"result_image", AnyInt, Rank::scalar, Optionality::optional,
+                common::Intent::In},
+            {"stat", AnyInt, Rank::scalar, Optionality::optional,
+                common::Intent::Out},
+            {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
+                common::Intent::InOut}},
+        {}, Rank::elemental, IntrinsicClass::collectiveSubroutine},
     {"co_sum",
         {{"a", AnyNumeric, Rank::anyOrAssumedRank, Optionality::required,
              common::Intent::InOut},
             {"result_image", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::In},
             {"stat", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::Out},
             {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
static const IntrinsicInterface intrinsicSubroutine[]{
                 common::Intent::Out},
             {"count_max", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::Out}},
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},
 };
 
 // TODO: Intrinsic subroutine EVENT_QUERY
 // TODO: Atomic intrinsic subroutines: ATOMIC_ADD
-// TODO: Collective intrinsic subroutines: co_reduce
 
 // Finds a built-in derived type and returns it as a DynamicType.
 static DynamicType GetBuiltinDerivedType(
     const semantics::Scope *builtinsScope, const char *which) {
   if (!builtinsScope) {
     common::die("INTERNAL: The __fortran_builtins module was not found, and "
                 "the type '%s' was required",
         which);
if (valueArg->GetType()->category() != atomArg->GetType()->category()) {
           procName, valueArg->GetType()->AsFortran());
     }
   }
 
   return sameType &&
       CheckForCoindexedObject(context, statArg, procName, "stat");
 }
 
+static bool CheckReduceAndCoReduce(
+    SpecificCall &call, FoldingContext &context) {
+  bool ok{true};
+  std::string name{call.specificIntrinsic.name};
+  const std::string argName{name == "reduce" ? "ARRAY" : "a"};
+  CHECK(name == "reduce" || name == "co_reduce");
+  if (name == "reduce") {
+    std::transform(name.begin(), name.end(), name.begin(), ::toupper);
+  }
+
+  std::optional<DynamicType> argType;
+  if (const auto &arg{call.arguments[0]}) {
+    argType = arg->GetType();
+  }
+  std::optional<characteristics::Procedure> procChars;
+  parser::CharBlock at{context.messages().at()};
+  if (const auto &operation{call.arguments[1]}) {
+    if (const auto *expr{operation->UnwrapExpr()}) {
+      if (const auto *designator{std::get_if<ProcedureDesignator>(&expr->u)}) {
+        procChars =
+            characteristics::Procedure::Characterize(*designator, context);
+      } else if (const auto *ref{std::get_if<ProcedureRef>(&expr->u)}) {
+        procChars = characteristics::Procedure::Characterize(*ref, context);
+      }
+    }
+    if (auto operationAt{operation->sourceLocation()}) {
+      at = *operationAt;
+    }
+  }
+  if (!argType || !procChars) {
+    ok = false; // error recovery
+  } else {
+    const auto *result{procChars->functionResult->GetTypeAndShape()};
+    const auto resultAttrs{procChars->functionResult->attrs};
+
+    if (name == "co_reduce") {
+      if (resultAttrs.test(
+              characteristics::FunctionResult::Attr::Allocatable)) {
+        ok = false;
+        context.messages().Say(at,
+            "Result of OPERATION= procedure of %s() must not be allocatable"_err_en_US,
+            name);
+      } else if (resultAttrs.test(
+                     characteristics::FunctionResult::Attr::Pointer)) {
+        ok = false;
+        context.messages().Say(at,
+            "Result of OPERATION= procedure of %s() must not be a pointer"_err_en_US,
+            name);
+      }
+    }
+
+    if (ok) {
+      if (!procChars->IsPure() || procChars->dummyArguments.size() != 2 ||
+          !procChars->functionResult) {
+        ok = false;
+        context.messages().Say(at,
+            "OPERATION= argument of %s() must be a pure function of two data arguments"_err_en_US,
+            name);
+      } else if (!result || result->Rank() != 0) {
+        ok = false;
+        context.messages().Say(at,
+            "OPERATION= argument of %s() must be a scalar function"_err_en_US,
+            name);
+      } else if (result->type().IsPolymorphic() ||
+          !argType->IsTkLenCompatibleWith(result->type())) {
+        ok = false;
+        context.messages().Say(at,
+            "OPERATION= argument of %s() must have the same type as %s="_err_en_US,
+            name, argName);
+      } else {
+        const characteristics::DummyDataObject *data[2]{};
+        for (int j{0}; j < 2; ++j) {
+          const auto &dummy{procChars->dummyArguments.at(j)};
+          data[j] = std::get_if<characteristics::DummyDataObject>(&dummy.u);
+          ok = ok && data[j];
+        }
+        if (!ok) {
+          context.messages().Say(at,
+              "OPERATION= argument of %s() may not have dummy procedure arguments"_err_en_US,
+              name);
+        } else {
+          for (int j{0}; j < 2; ++j) {
+            ok = ok &&
+                !data[j]->attrs.test(
+                    characteristics::DummyDataObject::Attr::Optional) &&
+                !data[j]->attrs.test(
+                    characteristics::DummyDataObject::Attr::Allocatable) &&
+                !data[j]->attrs.test(
+                    characteristics::DummyDataObject::Attr::Pointer) &&
+                data[j]->type.Rank() == 0 &&
+                !data[j]->type.type().IsPolymorphic() &&
+                data[j]->type.type().IsTkCompatibleWith(*argType);
+          }
+          if (!ok) {
+            context.messages().Say(at,
+                "Arguments of OPERATION= procedure of %s() must be both scalar of the same type as %s=, and neither allocatable, pointer, polymorphic, or optional"_err_en_US,
+                name, argName);
+          } else if (data[0]->attrs.test(characteristics::DummyDataObject::
+                             Attr::Asynchronous) !=
+                  data[1]->attrs.test(
+                      characteristics::DummyDataObject::Attr::Asynchronous) ||
+              data[0]->attrs.test(
+                  characteristics::DummyDataObject::Attr::Value) !=
+                  data[1]->attrs.test(
+                      characteristics::DummyDataObject::Attr::Value) ||
+              data[0]->attrs.test(
+                  characteristics::DummyDataObject::Attr::Target) !=
+                  data[1]->attrs.test(
+                      characteristics::DummyDataObject::Attr::Target)) {
+            ok = false;
+            context.messages().Say(at,
+                "If either argument of the OPERATION= procedure of %s() has the ASYNCHRONOUS, VALUE, or TARGET attribute, both must have that attribute"_err_en_US,
+                name);
+          }
+        }
+      }
+    }
+  }
+  return ok;
+}
+
 // Applies any semantic checks peculiar to an intrinsic.
 // TODO: Move the rest of these checks to Semantics/check-call.cpp, which is
 // where ASSOCIATED() and TRANSFER() are now validated.
 static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
   bool ok{true};
   const std::string &name{call.specificIntrinsic.name};
   if (name == "allocated") {
     const auto &arg{call.arguments[0]};
static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
   } else if (name == "atomic_fetch_add" || name == "atomic_fetch_and" ||
       name == "atomic_fetch_or" || name == "atomic_fetch_xor") {
     return CheckForCoindexedObject(context, call.arguments[3], name, "stat");
   } else if (name == "atomic_ref") {
     return CheckAtomicDefineAndRef(
         context, call.arguments[1], call.arguments[0], call.arguments[2], name);
   } else if (name == "co_broadcast" || name == "co_max" || name == "co_min" ||
       name == "co_sum") {
-    bool aOk{CheckForCoindexedObject(context, call.arguments[0], name, "a")};
-    bool statOk{
-        CheckForCoindexedObject(context, call.arguments[2], name, "stat")};
-    bool errmsgOk{
-        CheckForCoindexedObject(context, call.arguments[3], name, "errmsg")};
-    ok = aOk && statOk && errmsgOk;
+    ok &= CheckForCoindexedObject(context, call.arguments[0], name, "a");
+    ok &= CheckForCoindexedObject(context, call.arguments[2], name, "stat");
+    ok &= CheckForCoindexedObject(context, call.arguments[3], name, "errmsg");
+  } else if (name == "co_reduce") {
+    const auto &aArg{call.arguments[0]};
+
+    if (aArg->UnwrapExpr()->GetType()->IsPolymorphic()) {
+      ok = false;
+      context.messages().Say(aArg->sourceLocation(),
+          "'a=' argument for intrinsic '%s' must not be polymorphic"_err_en_US,
+          name);
+    } else {
+      ok = CheckReduceAndCoReduce(call, context);
+    }
+
+    ok &= CheckForCoindexedObject(context, call.arguments[0], name, "a");
+    ok &= CheckForCoindexedObject(context, call.arguments[3], name, "stat");
+    ok &= CheckForCoindexedObject(context, call.arguments[4], name, "errmsg");
   } else if (name == "image_status") {
     if (const auto &arg{call.arguments[0]}) {
       ok = CheckForNonPositiveValues(context, *arg, name, "image");
     }
   } else if (name == "lcobound") {
     return CheckDimAgainstCorank(call, context);
   } else if (name == "loc") {
     const auto &arg{call.arguments[0]};
if (arg) {
       }
     }
     if (!ok) {
       context.messages().Say(
           arg ? arg->sourceLocation() : context.messages().at(),
           "Argument of PRESENT() must be the name of an OPTIONAL dummy argument"_err_en_US);
     }
   } else if (name == "reduce") { // 16.9.161
-    std::optional<DynamicType> arrayType;
-    if (const auto &array{call.arguments[0]}) {
-      arrayType = array->GetType();
-    }
-    std::optional<characteristics::Procedure> procChars;
-    parser::CharBlock at{context.messages().at()};
-    if (const auto &operation{call.arguments[1]}) {
-      if (const auto *expr{operation->UnwrapExpr()}) {
-        if (const auto *designator{
-                std::get_if<ProcedureDesignator>(&expr->u)}) {
-          procChars =
-              characteristics::Procedure::Characterize(*designator, context);
-        } else if (const auto *ref{std::get_if<ProcedureRef>(&expr->u)}) {
-          procChars = characteristics::Procedure::Characterize(*ref, context);
-        }
-      }
-      if (auto operationAt{operation->sourceLocation()}) {
-        at = *operationAt;
-      }
-    }
-    if (!arrayType || !procChars) {
-      ok = false; // error recovery
-    } else {
-      const auto *result{procChars->functionResult->GetTypeAndShape()};
-      if (!procChars->IsPure() || procChars->dummyArguments.size() != 2 ||
-          !procChars->functionResult) {
-        ok = false;
-        context.messages().Say(at,
-            "OPERATION= argument of REDUCE() must be a pure function of two data arguments"_err_en_US);
-      } else if (!result || result->Rank() != 0) {
-        ok = false;
-        context.messages().Say(at,
-            "OPERATION= argument of REDUCE() must be a scalar function"_err_en_US);
-      } else if (result->type().IsPolymorphic() ||
-          !arrayType->IsTkLenCompatibleWith(result->type())) {
-        ok = false;
-        context.messages().Say(at,
-            "OPERATION= argument of REDUCE() must have the same type as ARRAY="_err_en_US);
-      } else {
-        const characteristics::DummyDataObject *data[2]{};
-        for (int j{0}; j < 2; ++j) {
-          const auto &dummy{procChars->dummyArguments.at(j)};
-          data[j] = std::get_if<characteristics::DummyDataObject>(&dummy.u);
-          ok = ok && data[j];
-        }
-        if (!ok) {
-          context.messages().Say(at,
-              "OPERATION= argument of REDUCE() may not have dummy procedure arguments"_err_en_US);
-        } else {
-          for (int j{0}; j < 2; ++j) {
-            ok = ok &&
-                !data[j]->attrs.test(
-                    characteristics::DummyDataObject::Attr::Optional) &&
-                !data[j]->attrs.test(
-                    characteristics::DummyDataObject::Attr::Allocatable) &&
-                !data[j]->attrs.test(
-                    characteristics::DummyDataObject::Attr::Pointer) &&
-                data[j]->type.Rank() == 0 &&
-                !data[j]->type.type().IsPolymorphic() &&
-                data[j]->type.type().IsTkCompatibleWith(*arrayType);
-          }
-          if (!ok) {
-            context.messages().Say(at,
-                "Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional"_err_en_US);
-          } else if (data[0]->attrs.test(characteristics::DummyDataObject::
-                             Attr::Asynchronous) !=
-                  data[1]->attrs.test(
-                      characteristics::DummyDataObject::Attr::Asynchronous) ||
-              data[0]->attrs.test(
-                  characteristics::DummyDataObject::Attr::Volatile) !=
-                  data[1]->attrs.test(
-                      characteristics::DummyDataObject::Attr::Volatile) ||
-              data[0]->attrs.test(
-                  characteristics::DummyDataObject::Attr::Target) !=
-                  data[1]->attrs.test(
-                      characteristics::DummyDataObject::Attr::Target)) {
-            ok = false;
-            context.messages().Say(at,
-                "If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VOLATILE, or TARGET attribute, both must have that attribute"_err_en_US);
-          }
-        }
-      }
-    }
+    return CheckReduceAndCoReduce(call, context);
   } else if (name == "ucobound") {
     return CheckDimAgainstCorank(call, context);
   }
   return ok;
 }
 
 static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface,
     const common::IntrinsicTypeDefaultKinds &defaults) {

flang/test/Semantics/collectives05.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
-! XFAIL: *
 ! This test checks for semantic errors in co_reduce subroutine calls based on
 ! the co_reduce interface defined in section 16.9.49 of the Fortran 2018 standard.
-! To Do: add co_reduce to the list of intrinsics
 
 module foo_m
   implicit none
 
   type foo_t
     integer :: n=0
   contains
     procedure :: derived_type_op
     generic :: operator(+) => derived_type_op
   end type
 
 contains
 
   pure function derived_type_op(lhs, rhs) result(lhs_op_rhs)
     class(foo_t), intent(in) :: lhs, rhs
     type(foo_t) lhs_op_rhs
     lhs_op_rhs%n = lhs%n + rhs%n
   end function
 
 end module foo_m
 
 program main
-  use foo_m, only : foo_t
+  use foo_m, only : foo_t, derived_type_op
   implicit none
 
   type(foo_t) foo
   class(foo_t), allocatable :: polymorphic
-  integer i, status, integer_array(1)
+  integer i, status, integer_array(1), repeated_status
   real x
   real vector(1)
   real array(1,1,1, 1,1,1, 1,1,1, 1,1,1, 1,1,1)
-  character(len=1) string, message, character_array(1)
+  character(len=1) string, message, character_array(1), coindexed_string[*], repeated_message
   integer coindexed[*]
   logical bool
 
   ! correct calls, should produce no errors
   call co_reduce(i,      int_op)
   call co_reduce(i,      int_op,                            status)
   call co_reduce(i,      int_op,                            stat=status)
   call co_reduce(i,      int_op,                                         errmsg=message)
   call co_reduce(i,      int_op,                            stat=status, errmsg=message)
   call co_reduce(i,      int_op,            result_image=1, stat=status, errmsg=message)
   call co_reduce(i,      operation=int_op,  result_image=1, stat=status, errmsg=message)
   call co_reduce(a=i,    operation=int_op,  result_image=1, stat=status, errmsg=message)
   call co_reduce(array,  operation=real_op, result_image=1, stat=status, errmsg=message)
   call co_reduce(vector, operation=real_op, result_image=1, stat=status, errmsg=message)
   call co_reduce(string, operation=char_op, result_image=1, stat=status, errmsg=message)
   call co_reduce(foo,    operation=left,    result_image=1, stat=status, errmsg=message)
 
   call co_reduce(result_image=1, operation=left,     a=foo, errmsg=message, stat=status)
+  call co_reduce(i, value_match)
+  call co_reduce(i, target_match)
+  call co_reduce(i, asynchronous_match)
 
   allocate(foo_t :: polymorphic)
 
   ! Test all statically verifiable semantic requirements on co_reduce arguments
   ! Note: We cannot check requirements that relate to "corresponding references." 
   ! References can correspond only if they execute on differing images.  A code that
   ! executes in a single image might be standard-conforming even if the same code
   ! executing in multiple images is not.
 
-  ! argument 'a' cannot be polymorphic
-  !ERROR: to be determined
+  !ERROR: 'a=' argument for intrinsic 'co_reduce' must not be polymorphic
   call co_reduce(polymorphic, derived_type_op)
 
-  ! argument 'a' cannot be coindexed
-  !ERROR: (message to be determined)
+  !ERROR: 'a' argument to 'co_reduce' may not be a coindexed object
   call co_reduce(coindexed[1], int_op)
 
-  ! argument 'a' is intent(inout)
-  !ERROR: (message to be determined)
+  !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' is not definable
+  !ERROR: 'i+1_4' is not a variable or pointer
   call co_reduce(i + 1, int_op)
 
-  ! operation must be a pure function
-  !ERROR: (message to be determined)
+  !ERROR: OPERATION= argument of co_reduce() must be a pure function of two data arguments
   call co_reduce(i, operation=not_pure)
 
-  ! operation must have exactly two arguments
-  !ERROR: (message to be determined)
+  !ERROR: OPERATION= argument of co_reduce() must be a pure function of two data arguments
   call co_reduce(i, too_many_args)
 
-  ! operation result must be a scalar
-  !ERROR: (message to be determined)
+  !ERROR: OPERATION= argument of co_reduce() must be a scalar function
   call co_reduce(i, array_result)
 
-  ! operation result must be non-allocatable
-  !ERROR: (message to be determined)
+  !ERROR: Result of OPERATION= procedure of co_reduce() must not be allocatable
   call co_reduce(i, allocatable_result)
 
-  ! operation result must be non-pointer
-  !ERROR: (message to be determined)
+  !ERROR: Result of OPERATION= procedure of co_reduce() must not be a pointer
   call co_reduce(i, pointer_result)
 
-  ! operation's arguments must be scalars
-  !ERROR: (message to be determined)
+  !ERROR: Arguments of OPERATION= procedure of co_reduce() must be both scalar of the same type as a=, and neither allocatable, pointer, polymorphic, or optional
   call co_reduce(i, array_args)
 
-  ! operation arguments must be non-allocatable
-  !ERROR: (message to be determined)
+  !ERROR: Arguments of OPERATION= procedure of co_reduce() must be both scalar of the same type as a=, and neither allocatable, pointer, polymorphic, or optional
   call co_reduce(i, allocatable_args)
 
-  ! operation arguments must be non-pointer
-  !ERROR: (message to be determined)
+  !ERROR: Arguments of OPERATION= procedure of co_reduce() must be both scalar of the same type as a=, and neither allocatable, pointer, polymorphic, or optional
   call co_reduce(i, pointer_args)
 
-  ! operation arguments must be non-polymorphic
-  !ERROR: (message to be determined)
+  !ERROR: OPERATION= argument of co_reduce() must have the same type as a=
   call co_reduce(i, polymorphic_args)
 
-  ! operation: type of 'operation' result and arguments must match type of argument 'a'
-  !ERROR: (message to be determined)
+  !ERROR: OPERATION= argument of co_reduce() must have the same type as a=
   call co_reduce(i, real_op)
 
   ! operation: kind type parameter of 'operation' result and arguments must match kind type parameter of argument 'a'
-  !ERROR: (message to be determined)
+  !ERROR: OPERATION= argument of co_reduce() must have the same type as a=
   call co_reduce(x, double_precision_op)
 
-  ! arguments must be non-optional
-  !ERROR: (message to be determined)
+  !ERROR: Arguments of OPERATION= procedure of co_reduce() must be both scalar of the same type as a=, and neither allocatable, pointer, polymorphic, or optional
   call co_reduce(i, optional_args)
 
-  ! if one argument is asynchronous, the other must be also
-  !ERROR: (message to be determined)
+  !ERROR: If either argument of the OPERATION= procedure of co_reduce() has the ASYNCHRONOUS, VALUE, or TARGET attribute, both must have that attribute
   call co_reduce(i, asynchronous_mismatch)
 
-  ! if one argument is a target, the other must be also
-  !ERROR: (message to be determined)
+  !ERROR: If either argument of the OPERATION= procedure of co_reduce() has the ASYNCHRONOUS, VALUE, or TARGET attribute, both must have that attribute
   call co_reduce(i, target_mismatch)
 
-  ! if one argument has the value attribute, the other must have it also
-  !ERROR: (message to be determined)
+  !ERROR: If either argument of the OPERATION= procedure of co_reduce() has the ASYNCHRONOUS, VALUE, or TARGET attribute, both must have that attribute
   call co_reduce(i, value_mismatch)
 
-  ! result_image argument must be an integer scalar
-  !ERROR: to be determined
+  !ERROR: 'result_image=' argument has unacceptable rank 1
   call co_reduce(i, int_op, result_image=integer_array)
 
-  ! result_image argument must be an integer
-  !ERROR: to be determined
+  !ERROR: Actual argument for 'result_image=' has bad type 'LOGICAL(4)'
   call co_reduce(i, int_op, result_image=bool)
 
-  ! stat not allowed to be coindexed
-  !ERROR: to be determined
+  !ERROR: 'stat' argument to 'co_reduce' may not be a coindexed object
   call co_reduce(i, int_op, stat=coindexed[1])
 
-  ! stat argument must be an integer scalar
-  !ERROR: to be determined
+  !ERROR: 'stat=' argument has unacceptable rank 1
   call co_reduce(i, int_op, result_image=1, stat=integer_array)
 
-  ! stat argument has incorrect type
   !ERROR: Actual argument for 'stat=' has bad type 'CHARACTER(KIND=1,LEN=1_8)'
-  call co_reduce(i, int_op, result_image=1, string)
+  call co_reduce(i, int_op, result_image=1, stat=string)
 
-  ! stat argument is intent(out)
-  !ERROR: to be determined
+  !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable
+  !ERROR: '2_4' is not a variable or pointer
   call co_reduce(i, int_op, result_image=1, stat=1+1)
 
-  ! errmsg argument must not be coindexed
-  !ERROR: to be determined
-  call co_reduce(i, int_op, result_image=1, stat=status, errmsg=conindexed_string[1])
+  !ERROR: 'errmsg' argument to 'co_reduce' may not be a coindexed object
+  call co_reduce(i, int_op, result_image=1, stat=status, errmsg=coindexed_string[1])
 
-  ! errmsg argument must be a character scalar
-  !ERROR: to be determined
+  !ERROR: 'errmsg=' argument has unacceptable rank 1
   call co_reduce(i, int_op, result_image=1, stat=status, errmsg=character_array)
 
-  ! errmsg argument must be a character
-  !ERROR: to be determined
+  !ERROR: Actual argument for 'errmsg=' has bad type 'INTEGER(4)'
   call co_reduce(i, int_op, result_image=1, stat=status, errmsg=i)
 
-  ! errmsg argument is intent(inout)
-  !ERROR: to be determined
+  !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' is not definable
+  !ERROR: '"literal constant"' is not a variable or pointer
   call co_reduce(i, int_op, result_image=1, stat=status, errmsg="literal constant")
 
-  ! too many arguments to the co_reduce() call
   !ERROR: too many actual arguments for intrinsic 'co_reduce'
-  call co_reduce(i, int_op, result_image=1, stat=status, errmsg=message, 3.4)
+  call co_reduce(i, int_op, 1, status, message, 3.4)
+
+  !ERROR: actual argument #5 without a keyword may not follow an actual argument with a keyword
+  call co_reduce(i, int_op, result_image=1, stat=status, message)
 
-  ! non-existent keyword argument
   !ERROR: unknown keyword argument to intrinsic 'co_reduce'
   call co_reduce(fake=3.4)
 
+  !ERROR: missing mandatory 'a=' argument
+  call co_reduce()
+
+  !ERROR: missing mandatory 'a=' argument
+  call co_reduce(operation=int_op)
+
+  !ERROR: missing mandatory 'operation=' argument
+  call co_reduce(i)
+
+  !ERROR: repeated keyword argument to intrinsic 'co_reduce'
+  call co_reduce(a=i, a=i, operation=int_op)
+
+  !ERROR: repeated keyword argument to intrinsic 'co_reduce'
+  call co_reduce(i, operation=int_op, operation=repeated_int_op)
+
+  !ERROR: repeated keyword argument to intrinsic 'co_reduce'
+  call co_reduce(i, int_op, result_image=1, result_image=2)
+
+  !ERROR: repeated keyword argument to intrinsic 'co_reduce'
+  call co_reduce(stat=status, a=i, operation=int_op, result_image=1, stat=repeated_status)
+
+  !ERROR: repeated keyword argument to intrinsic 'co_reduce'
+  call co_reduce(i, int_op, 1, errmsg=message, errmsg=repeated_message)
+
+  !ERROR: keyword argument to intrinsic 'co_reduce' was supplied positionally by an earlier actual argument
+  call co_reduce(i, int_op, a=i)
+
+  !ERROR: keyword argument to intrinsic 'co_reduce' was supplied positionally by an earlier actual argument
+  call co_reduce(i, int_op, operation=repeated_int_op)
+
+  !ERROR: keyword argument to intrinsic 'co_reduce' was supplied positionally by an earlier actual argument
+  call co_reduce(i, int_op, 1, result_image=2)
+
+  !ERROR: keyword argument to intrinsic 'co_reduce' was supplied positionally by an earlier actual argument
+  call co_reduce(i, int_op, 1, status, stat=repeated_status)
+
+  !ERROR: keyword argument to intrinsic 'co_reduce' was supplied positionally by an earlier actual argument
+  call co_reduce(i, int_op, 1, status, message, errmsg=repeated_message)
+
 contains
 
   pure function left(lhs, rhs) result(lhs_op_rhs)
     type(foo_t), intent(in)  :: lhs, rhs
     type(foo_t) :: lhs_op_rhs
     lhs_op_rhs = lhs
   end function
 
contains
   end function
 
   pure function int_op(lhs, rhs) result(lhs_op_rhs)
     integer, intent(in) :: lhs, rhs
     integer :: lhs_op_rhs
     lhs_op_rhs = lhs + rhs
   end function
 
+  pure function repeated_int_op(lhs, rhs) result(lhs_op_rhs)
+    integer, intent(in) :: lhs, rhs
+    integer :: lhs_op_rhs
+    lhs_op_rhs = lhs + rhs
+  end function
+
   function not_pure(lhs, rhs) result(lhs_op_rhs)
     integer, intent(in) :: lhs, rhs
     integer :: lhs_op_rhs
     lhs_op_rhs = lhs + rhs
   end function
 
   pure function too_many_args(lhs, rhs, foo) result(lhs_op_rhs)
     integer, intent(in) :: lhs, rhs, foo
contains
 
   pure function target_mismatch(lhs, rhs) result(lhs_op_rhs)
     integer, intent(in), target  :: lhs
     integer, intent(in) :: rhs
     integer lhs_op_rhs
     lhs_op_rhs = lhs + rhs
   end function
 
+  pure function target_match(lhs, rhs) result(lhs_op_rhs)
+    integer, intent(in), target :: lhs, rhs
+    integer lhs_op_rhs
+    lhs_op_rhs = lhs + rhs
+  end function
+
   pure function value_mismatch(lhs, rhs) result(lhs_op_rhs)
     integer, intent(in), value:: lhs
     integer, intent(in) :: rhs
     integer lhs_op_rhs
     lhs_op_rhs = lhs + rhs
   end function
 
+  pure function value_match(lhs, rhs) result(lhs_op_rhs)
+    integer, intent(in), value :: lhs, rhs
+    integer lhs_op_rhs
+    lhs_op_rhs = lhs + rhs
+  end function
+
   pure function asynchronous_mismatch(lhs, rhs) result(lhs_op_rhs)
     integer, intent(in), asynchronous:: lhs
     integer, intent(in) :: rhs
     integer lhs_op_rhs
     lhs_op_rhs = lhs + rhs
   end function
 
+  pure function asynchronous_match(lhs, rhs) result(lhs_op_rhs)
+    integer, intent(in), asynchronous :: lhs, rhs
+    integer lhs_op_rhs
+    lhs_op_rhs = lhs + rhs
+  end function
+
 end program

flang/test/Semantics/reduce01.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 module m
+  use iso_fortran_env, only: REAL128
   type :: pdt(len)
     integer, len :: len
     character(len=len) :: ch
   end type
  contains
   impure real function f1(x,y)
     f1 = x + y
   end function
interface
       pure real function y(); end function
     end interface
     f4 = x() + y()
   end function
   pure integer function f5(x,y)
     real, intent(in) :: x, y
     f5 = x + y
   end function
-  pure real function f6(x,y)
-    real, intent(in) :: x(*), y(*)
-    f6 = x(1) + y(1)
+  pure real(kind=REAL128) function f6(x,y)
+    real(kind=REAL128), intent(in) :: x, y
+    f6 = x + y
   end function
   pure real function f7(x,y)
-    real, intent(in), allocatable :: x
-    real, intent(in) :: y
+    real(kind=REAL128), intent(in) :: x, y
     f7 = x + y
   end function
   pure real function f8(x,y)
-    real, intent(in), pointer :: x
-    real, intent(in) :: y
-    f8 = x + y
+    real, intent(in) :: x(*), y(*)
+    f8 = x(1) + y(1)
   end function
   pure real function f9(x,y)
-    real, intent(in), optional :: x
+    real, intent(in), allocatable :: x
     real, intent(in) :: y
     f9 = x + y
   end function
   pure real function f10(x,y)
-    real, intent(in), target :: x
+    real, intent(in), pointer :: x
     real, intent(in) :: y
     f10 = x + y
   end function
-  pure function f11(x,y) result(res)
+  pure real function f11(x,y)
+    real, intent(in), optional :: x
+    real, intent(in) :: y
+    f11 = x + y
+  end function
+  pure real function f12(x,y)
+    real, intent(in), target :: x
+    real, intent(in) :: y
+    f12 = x + y
+  end function
+  pure real function f13(x,y)
+    real, intent(in), value :: x
+    real, intent(in) :: y
+    f13 = x + y
+  end function
+  pure real function f14(x,y)
+    real, intent(in), asynchronous :: x
+    real, intent(in) :: y
+    f14 = x + y
+  end function
+  pure function f15(x,y) result(res)
     type(pdt(*)), intent(in) :: x, y
     type(pdt(max(x%len, y%len))) :: res
     res%ch = x%ch // y%ch
   end function
+  pure real function f16(x,y)
+    real, intent(in), value :: x
+    real, intent(in), value :: y
+    f16 = x + y
+  end function
+  pure real function f17(x,y)
+    real, intent(in), asynchronous :: x
+    real, intent(in), asynchronous :: y
+    f17 = x + y
+  end function
+  pure real function f18(x,y)
+    real, intent(in), target :: x
+    real, intent(in), target :: y
+    f18 = x + y
+  end function
 
   subroutine errors
     real :: a(10,10), b
     !ERROR: OPERATION= argument of REDUCE() must be a pure function of two data arguments
     b = reduce(a, f1)
     !ERROR: OPERATION= argument of REDUCE() must be a scalar function
     b = reduce(a, f2)
     !ERROR: OPERATION= argument of REDUCE() must be a pure function of two data arguments
     b = reduce(a, f3)
     !ERROR: OPERATION= argument of REDUCE() may not have dummy procedure arguments
     b = reduce(a, f4)
     !ERROR: OPERATION= argument of REDUCE() must have the same type as ARRAY=
     b = reduce(a, f5)
-    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
+    !ERROR: OPERATION= argument of REDUCE() must have the same type as ARRAY=
     b = reduce(a, f6)
     !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
     b = reduce(a, f7)
     !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
     b = reduce(a, f8)
     !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
     b = reduce(a, f9)
-    !ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VOLATILE, or TARGET attribute, both must have that attribute
+    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
     b = reduce(a, f10)
+    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
+    b = reduce(a, f11)
+    !ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VALUE, or TARGET attribute, both must have that attribute
+    b = reduce(a, f12)
+    !ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VALUE, or TARGET attribute, both must have that attribute
+    b = reduce(a, f13)
+    !ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VALUE, or TARGET attribute, both must have that attribute
+    b = reduce(a, f14)
   end subroutine
   subroutine not_errors
     type(pdt(10)) :: a(10), b
-    b = reduce(a, f11) ! check no bogus type incompatibility diagnostic
+    real :: c(10,10), d
+    b = reduce(a, f15) ! check no bogus type incompatibility diagnostic
+    d = reduce(c, f16)
+    d = reduce(c, f17)
+    d = reduce(c, f18)
   end subroutine
 end module