From a9b2e31fb0fbb6ce3cbc4ae2b77301c95647b617 Mon Sep 17 00:00:00 2001 From: Jean-Didier PAILLEUX Date: Mon, 3 Mar 2025 20:50:02 +0100 Subject: [PATCH] [flang] Define CO_REDUCE intrinsic procedure (#125115) 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. --- flang/lib/Evaluate/intrinsics.cpp | 13 +++- flang/lib/Semantics/check-call.cpp | 95 ++++++++++++++++++++++++++ flang/test/Semantics/collectives05.f90 | 62 +++++++++-------- 3 files changed, 138 insertions(+), 32 deletions(-) diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index e55a22dce8e9..cdc49e89a978 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -1440,6 +1440,17 @@ static const IntrinsicInterface intrinsicSubroutine[]{ {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, common::Intent::InOut}}, {}, Rank::elemental, IntrinsicClass::collectiveSubroutine}, + {"co_reduce", + {{"a", AnyData, Rank::known, 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}, @@ -1598,8 +1609,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 4042d7504396..35ce3a430a83 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -1632,6 +1632,99 @@ 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 aType; + if (const auto &a{arguments[0]}) { + aType = a->GetType(); + } + std::optional procChars; + if (const auto &operation{arguments[1]}) { + if (const auto *expr{operation->UnwrapExpr()}) { + if (const auto *designator{ + std::get_if(&expr->u)}) { + procChars = characteristics::Procedure::Characterize( + *designator, context, /*emitError=*/true); + } else if (const auto *ref{ + std::get_if(&expr->u)}) { + procChars = characteristics::Procedure::Characterize(*ref, context); + } + } + } + + static constexpr characteristics::DummyDataObject::Attrs notAllowedArgAttrs{ + characteristics::DummyDataObject::Attr::Optional, + characteristics::DummyDataObject::Attr::Allocatable, + characteristics::DummyDataObject::Attr::Pointer, + }; + static constexpr characteristics::FunctionResult::Attrs + notAllowedFuncResAttrs{ + characteristics::FunctionResult::Attr::Allocatable, + characteristics::FunctionResult::Attr::Pointer, + }; + 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 & notAllowedFuncResAttrs) != + characteristics::FunctionResult::Attrs{}) || + 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(&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 & notAllowedArgAttrs) != + characteristics::DummyDataObject::Attrs{}) || + 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::Attrs attrs{ + characteristics::DummyDataObject::Attr::Asynchronous, + characteristics::DummyDataObject::Attr::Target, + characteristics::DummyDataObject::Attr::Value, + }; + if ((data[0]->attrs & attrs) != (data[1]->attrs & attrs)) { + 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); + } + } + } +} + // EVENT_QUERY (F'2023 16.9.82) static void CheckEvent_Query(evaluate::ActualArguments &arguments, evaluate::FoldingContext &foldingContext) { @@ -1998,6 +2091,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 bf8cfeff8a33..0dea7e6fcff0 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