[flang-commits] [flang] [flang] Define CO_REDUCE intrinsic procedure (PR #125115)
Jean-Didier PAILLEUX via flang-commits
flang-commits at lists.llvm.org
Thu Jan 30 12:57:46 PST 2025
https://github.com/JDPailleux created https://github.com/llvm/llvm-project/pull/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.
>From a0570565bf156feae123e19a4239f91e77ebcf9c Mon Sep 17 00:00:00 2001
From: Jean-Didier Pailleux <jean-didier.pailleux at sipearl.com>
Date: Thu, 30 Jan 2025 15:52:14 +0100
Subject: [PATCH] [flang] Define CO_REDUCE intrinsic procedure and add semantic
checks
---
flang/lib/Evaluate/intrinsics.cpp | 13 +++-
flang/lib/Semantics/check-call.cpp | 93 ++++++++++++++++++++++++++
flang/test/Semantics/collectives05.f90 | 62 ++++++++---------
3 files changed, 136 insertions(+), 32 deletions(-)
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
More information about the flang-commits
mailing list