Index: flang/lib/Evaluate/intrinsics.cpp =================================================================== --- flang/lib/Evaluate/intrinsics.cpp +++ flang/lib/Evaluate/intrinsics.cpp @@ -671,13 +671,15 @@ {"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}}, @@ -1600,10 +1602,8 @@ 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: @@ -2357,6 +2357,90 @@ 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 arrayType; + if (const auto &array{call.arguments[0]}) { + arrayType = array->GetType(); + } + std::optional 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(&expr->u)}) { + procChars = + characteristics::Procedure::Characterize(*designator, context); + } else if (const auto *ref{std::get_if(&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(&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; } Index: flang/test/Semantics/reduce01.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/reduce01.f90 @@ -0,0 +1,75 @@ +! 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