[flang] Add semantic checks for intrinsic function REDUCE()

[klausler]

Summary

Support REDUCE's special semantic requirements in intrinsic
procedure semantics.

[clementval]

LGTM

flang/lib/Evaluate/intrinsics.cpp

// NULL() is a special case handled in Probe() below
         IntrinsicClass::inquiryFunction},
     {"real", {{"a", SameComplex, Rank::elemental}},
         SameReal}, // 16.9.160(4)(ii)
     {"real", {{"a", AnyNumeric, Rank::elementalOrBOZ}, DefaultingKIND},
         KINDReal},
     {"reduce",
         {{"array", SameType, Rank::array},
             {"operation", SameType, Rank::reduceOperation}, RequiredDIM,
-            OptionalMASK, {"identity", SameType, Rank::scalar},
+            OptionalMASK,
+            {"identity", SameType, Rank::scalar, Optionality::optional},
             {"ordered", AnyLogical, Rank::scalar, Optionality::optional}},
         SameType, Rank::dimReduced, IntrinsicClass::transformationalFunction},
     {"reduce",
         {{"array", SameType, Rank::array},
             {"operation", SameType, Rank::reduceOperation}, MissingDIM,
-            OptionalMASK, {"identity", SameType, Rank::scalar},
+            OptionalMASK,
+            {"identity", SameType, Rank::scalar, Optionality::optional},
             {"ordered", AnyLogical, Rank::scalar, Optionality::optional}},
         SameType, Rank::scalar, IntrinsicClass::transformationalFunction},
     {"repeat", {{"string", SameChar, Rank::scalar}, {"ncopies", AnyInt}},
         SameChar, Rank::scalar, IntrinsicClass::transformationalFunction},
     {"reshape",
         {{"source", SameType, Rank::array}, {"shape", AnyInt, Rank::shape},
             {"pad", SameType, Rank::array, Optionality::optional},
             {"order", AnyInt, Rank::vector, Optionality::optional}},
if (const ActualArgument * arg{actualForDummy[j]}) {
         argOk = true; // Avoid an additional error message
         break;
       case Rank::dimReduced:
       case Rank::dimRemovedOrScalar:
         CHECK(arrayArg);
         argOk = rank == 0 || rank + 1 == arrayArg->Rank();
         break;
       case Rank::reduceOperation:
-        // TODO: validate the reduction operation -- it must be a pure
-        // function of two arguments with special constraints.
-        CHECK(arrayArg);
-        argOk = rank == 0;
+        // The reduction function is validated in ApplySpecificChecks().
+        argOk = true;
         break;
       case Rank::locReduced:
       case Rank::rankPlus1:
       case Rank::shaped:
         common::die("INTERNAL: result-only rank code appears on argument '%s' "
                     "for intrinsic '%s'",
             d.keyword, name);
       }
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() ||
+          result->type() != *arrayType) {
+        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() == *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 ok;
 }
 
 static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface,
     const common::IntrinsicTypeDefaultKinds &defaults) {
   TypeCategory category{TypeCategory::Integer};
   switch (interface.result.kindCode) {

flang/test/Semantics/reduce01.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+ contains
+  impure real function f1(x,y)
+    f1 = x + y
+  end function
+  pure function f2(x,y)
+    real :: f2(1)
+    real, intent(in) :: x, y
+    f2(1) = x + y
+  end function
+  pure real function f3(x,y,z)
+    real, intent(in) :: x, y, z
+    f3 = x + y + z
+  end function
+  pure real function f4(x,y)
+    interface
+      pure real function x(); end function
+      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)
+  end function
+  pure real function f7(x,y)
+    real, intent(in), allocatable :: x
+    real, intent(in) :: y
+    f7 = x + y
+  end function
+  pure real function f8(x,y)
+    real, intent(in), pointer :: x
+    real, intent(in) :: y
+    f8 = x + y
+  end function
+  pure real function f9(x,y)
+    real, intent(in), optional :: x
+    real, intent(in) :: y
+    f9 = x + y
+  end function
+  pure real function f10(x,y)
+    real, intent(in), target :: x
+    real, intent(in) :: y
+    f10 = x + y
+  end function
+
+  subroutine test
+    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
+    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
+    b = reduce(a, f10)
+  end subroutine
+end module