caio/clang-p2996
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

[flang] Define CO_REDUCE intrinsic procedure (#125115)

Browse Source 
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.
This commit is contained in:
Jean-Didier PAILLEUX
2025-03-03 20:50:02 +01:00
committed by GitHub
parent 83f8721201
commit a9b2e31fb0
3 changed files with 138 additions and 32 deletions
Download Patch File Download Diff File Expand all files Collapse all files

13
flang/lib/Evaluate/intrinsics.cpp
View File

@@ -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) {

95
flang/lib/Semantics/check-call.cpp
View File

@@ -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<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);
}
}
}
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<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 & 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") {

62
flang/test/Semantics/collectives05.f90
View File

@@ -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