[flang] Define CO_REDUCE intrinsic procedure

[JDPailleux]

Define the intrinsic CO_REDUCE and add semantic checks.
A test was already present but was at XFAIL. It has been modified to take new messages into the output.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Jean-Didier PAILLEUX (JDPailleux)

Changes

Define the intrinsic CO_REDUCE and add semantic checks.
A test was already present but was at XFAIL. It has been modified to take new messages into the output.

---

Full diff: https://github.com/llvm/llvm-project/pull/125115.diff

3 Files Affected:

• (modified) flang/lib/Evaluate/intrinsics.cpp (+11-2)
• (modified) flang/lib/Semantics/check-call.cpp (+93)
• (modified) flang/test/Semantics/collectives05.f90 (+32-30)

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 1c7e564f706ad47..103d17a8ec7c5c3 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -1450,6 +1450,17 @@ static const IntrinsicInterface intrinsicSubroutine[]{
             {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
                 common::Intent::InOut}},
         {}, Rank::elemental, IntrinsicClass::collectiveSubroutine},
+    {"co_reduce",
+        {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required,
+             common::Intent::InOut},
+            {"operation", SameType, Rank::reduceOperation},
+            {"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},
@@ -1608,8 +1619,6 @@ static const IntrinsicInterface intrinsicSubroutine[]{
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},
 };
 
-// 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) {
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index e396ece3031039e..9ad1f16fed3c680 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1616,6 +1616,97 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
   }
 }
 
+// CO_REDUCE (F'2023 16.9.49)
+static void CheckCoReduce(
+    evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) {
+  parser::ContextualMessages &messages{context.messages()};
+  evaluate::CheckForCoindexedObject(
+      context.messages(), arguments[0], "co_reduce", "a");
+  evaluate::CheckForCoindexedObject(
+      context.messages(), arguments[2], "co_reduce", "stat");
+  evaluate::CheckForCoindexedObject(
+      context.messages(), arguments[3], "co_reduce", "errmsg");
+
+  std::optional<evaluate::DynamicType> aType;
+  if (const auto &a{arguments[0]}) {
+    aType = a->GetType();
+  }
+  std::optional<characteristics::Procedure> procChars;
+  if (const auto &operation{arguments[1]}) {
+    if (const auto *expr{operation->UnwrapExpr()}) {
+      if (const auto *designator{
+              std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {
+        procChars = characteristics::Procedure::Characterize(
+            *designator, context, /*emitError=*/true);
+      } else if (const auto *ref{
+                     std::get_if<evaluate::ProcedureRef>(&expr->u)}) {
+        procChars = characteristics::Procedure::Characterize(*ref, context);
+      }
+    }
+  }
+  const auto *result{
+      procChars ? procChars->functionResult->GetTypeAndShape() : nullptr};
+  if (!procChars || !procChars->IsPure() ||
+      procChars->dummyArguments.size() != 2 || !procChars->functionResult) {
+    messages.Say(
+        "OPERATION= argument of CO_REDUCE() must be a pure function of two data arguments"_err_en_US);
+  } else if (procChars->attrs.test(characteristics::Procedure::Attr::BindC)) {
+    messages.Say(
+        "A BIND(C) OPERATION= argument of CO_REDUCE() is not supported"_err_en_US);
+  } else if (!result || result->Rank() != 0) {
+    messages.Say(
+        "OPERATION= argument of CO_REDUCE() must be a scalar function"_err_en_US);
+  } else if (result->type().IsPolymorphic() ||
+      (aType && !aType->IsTkLenCompatibleWith(result->type()))) {
+    messages.Say(
+        "OPERATION= argument of CO_REDUCE() must have the same type as A="_err_en_US);
+  } else if (procChars->functionResult->attrs.test(
+                 characteristics::FunctionResult::Attr::Allocatable) ||
+      procChars->functionResult->attrs.test(
+          characteristics::FunctionResult::Attr::Pointer) ||
+      procChars->functionResult->GetTypeAndShape()->type().IsPolymorphic()) {
+    messages.Say(
+        "Result of OPERATION= procedure of CO_REDUCE() must be scalar and neither allocatable, pointer, nor polymorphic"_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);
+    }
+    if (!data[0] || !data[1]) {
+      messages.Say(
+          "OPERATION= argument of CO_REDUCE() may not have dummy procedure arguments"_err_en_US);
+    } else {
+      for (int j{0}; j < 2; ++j) {
+        if (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() ||
+            (aType && !data[j]->type.type().IsTkCompatibleWith(*aType))) {
+          messages.Say(
+              "Arguments of OPERATION= procedure of CO_REDUCE() must be both scalar of the same type as A=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US);
+          break;
+        }
+      }
+      static constexpr characteristics::DummyDataObject::Attr attrs[]{
+          characteristics::DummyDataObject::Attr::Asynchronous,
+          characteristics::DummyDataObject::Attr::Target,
+          characteristics::DummyDataObject::Attr::Value,
+      };
+      for (std::size_t j{0}; j < sizeof attrs / sizeof *attrs; ++j) {
+        if (data[0]->attrs.test(attrs[j]) != data[1]->attrs.test(attrs[j])) {
+          messages.Say(
+              "If either argument of the OPERATION= procedure of CO_REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute"_err_en_US);
+          break;
+        }
+      }
+    }
+  }
+}
+
 // EVENT_QUERY (F'2023 16.9.82)
 static void CheckEvent_Query(evaluate::ActualArguments &arguments,
     evaluate::FoldingContext &foldingContext) {
@@ -1982,6 +2073,8 @@ static void CheckSpecificIntrinsic(const characteristics::Procedure &proc,
     const Scope *scope, const evaluate::SpecificIntrinsic &intrinsic) {
   if (intrinsic.name == "associated") {
     CheckAssociated(arguments, context, scope);
+  } else if (intrinsic.name == "co_reduce") {
+    CheckCoReduce(arguments, context.foldingContext());
   } else if (intrinsic.name == "event_query") {
     CheckEvent_Query(arguments, context.foldingContext());
   } else if (intrinsic.name == "image_index") {
diff --git a/flang/test/Semantics/collectives05.f90 b/flang/test/Semantics/collectives05.f90
index bf8cfeff8a33b95..0dea7e6fcff0885 100644
--- a/flang/test/Semantics/collectives05.f90
+++ b/flang/test/Semantics/collectives05.f90
@@ -1,5 +1,4 @@
 ! 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
@@ -63,119 +62,122 @@ program main
   ! executing in multiple images is not.
 
   ! argument 'a' cannot be polymorphic
-  !ERROR: to be determined
+  !ERROR: No explicit type declared for 'derived_type_op'
   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 be scalar and neither allocatable, pointer, nor polymorphic
   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 be scalar and neither allocatable, pointer, nor polymorphic
   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, nor 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, nor 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, nor 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, nor 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, TARGET, or VALUE 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, TARGET, or VALUE 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, TARGET, or VALUE 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: 'errmsg' 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
+  !ERROR: No explicit type declared for 'conindexed_string'
   call co_reduce(i, int_op, result_image=1, stat=status, errmsg=conindexed_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'
+  !ERROR: actual argument #6 without a keyword may not follow an actual argument with a keyword
   call co_reduce(i, int_op, result_image=1, stat=status, errmsg=message, 3.4)
 
   ! non-existent keyword argument

[JDPailleux]

Hi @klausler, @ktras,
Is it possible for you to do a review ? :)

[klausler]

why do you accept an assumed rank dummy argument?

[JDPailleux]

Hi, because, according to the standard, A can be a scalar or an array without specifying whether it can be assumed or not. And the definition of A is almost identical to those of co_min, co_max and so on, without the restriction for the type.

[klausler]

If an assumed rank dummy argument were acceptable here, the standard would explicit say so.

See constraint C840 in subclause 8.5.8.7 in F'2023.

[JDPailleux]

Ok, in that case I agree. I'll update that.

[klausler]

SameType is not correct. operation is a function.

[JDPailleux]

Yes operation is a function. Operation follows the same rules as the 'operation' argument of the 'reduce' intrinsic. He has 2 arguments, which must have the same type, and the same applies to the function's result, as well as other rules. To respect what was done for 'reduce', I've used the same rule as this intrinsic.

[JDPailleux]

@klausler Hi, are you OK with all modifications and answers ?

[JDPailleux]

Hi @klausler, there is no other review, can you merge this PR ? Thank in advance

[klausler]

Please seek commit access and merge it yourself.

[antmox]

Hi. Looks like this patch breaks some bots:

• https://lab.llvm.org/buildbot/#/builders/41/builds/5355
• https://lab.llvm.org/buildbot/#/builders/4/builds/5381
• https://lab.llvm.org/buildbot/#/builders/199/builds/1977
• https://lab.llvm.org/buildbot/#/builders/17/builds/6221
• https://lab.llvm.org/buildbot/#/builders/143/builds/5889
• https://lab.llvm.org/buildbot/#/builders/198/builds/2500

llvm-test-suite should be updated. could you please look at this ?