[flang-commits] [flang] [flang] Move and extend REDUCE() compile-time checking (PR #72570)
via flang-commits
flang-commits at lists.llvm.org
Thu Nov 16 13:03:29 PST 2023
llvmbot wrote:
<!--LLVM PR SUMMARY COMMENT-->
@llvm/pr-subscribers-flang-semantics
Author: Peter Klausler (klausler)
<details>
<summary>Changes</summary>
Move the code to check the arguments of references to the intrinsic function REDUCE() into Semantics/check-calls.cpp, and add checks for several requirements from the standard that weren't yet caught.
---
Full diff: https://github.com/llvm/llvm-project/pull/72570.diff
4 Files Affected:
- (modified) flang/lib/Evaluate/intrinsics.cpp (+30-87)
- (modified) flang/lib/Semantics/check-call.cpp (+139-1)
- (modified) flang/test/Semantics/misc-intrinsics.f90 (+4-4)
- (modified) flang/test/Semantics/reduce01.f90 (+40-5)
``````````diff
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index c5faf319fafb7d1..08cec73d88ced28 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2330,6 +2330,12 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
}
if (auto dc{characteristics::DummyArgument::FromActual(std::move(kw),
*expr, context, /*forImplicitInterface=*/false)}) {
+ if (auto *dummyProc{
+ std::get_if<characteristics::DummyProcedure>(&dc->u)}) {
+ // Dummy procedures are never elemental.
+ dummyProc->procedure.value().attrs.reset(
+ characteristics::Procedure::Attr::Elemental);
+ }
dummyArgs.emplace_back(std::move(*dc));
if (d.typePattern.kindCode == KindCode::same && !sameDummyArg) {
sameDummyArg = j;
@@ -2874,8 +2880,7 @@ static bool CheckAtomicDefineAndRef(FoldingContext &context,
}
// Applies any semantic checks peculiar to an intrinsic.
-// TODO: Move the rest of these checks to Semantics/check-call.cpp, which is
-// where ASSOCIATED() and TRANSFER() are now validated.
+// TODO: Move the rest of these checks to Semantics/check-call.cpp.
static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
bool ok{true};
const std::string &name{call.specificIntrinsic.name};
@@ -2891,7 +2896,7 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
arg ? arg->sourceLocation() : context.messages().at(),
"Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
}
- } else if (name == "associated") {
+ } else if (name == "associated" || name == "reduce") {
// Now handled in Semantics/check-call.cpp
} else if (name == "atomic_and" || name == "atomic_or" ||
name == "atomic_xor") {
@@ -2967,90 +2972,6 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
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() ||
- !arrayType->IsTkLenCompatibleWith(result->type())) {
- 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().IsTkCompatibleWith(*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, nor 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);
- }
- }
- }
- }
} else if (name == "ucobound") {
return CheckDimAgainstCorank(call, context);
}
@@ -3143,6 +3064,28 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
} else if (buffer.empty()) {
buffer.Annex(std::move(localBuffer));
} else {
+ // When there are multiple entries in the table for an
+ // intrinsic that has multiple forms depending on the
+ // presence of DIM=, use messages from a later entry if
+ // the messages from an earlier entry complain about the
+ // DIM= argument and it wasn't specified with a keyword.
+ for (const auto &m : buffer.messages()) {
+ if (m.ToString().find("'dim='") != std::string::npos) {
+ bool hadDimKeyword{false};
+ for (const auto &a : arguments) {
+ if (a) {
+ if (auto kw{a->keyword()}; kw && kw == "dim") {
+ hadDimKeyword = true;
+ break;
+ }
+ }
+ }
+ if (!hadDimKeyword) {
+ buffer = std::move(localBuffer);
+ }
+ break;
+ }
+ }
localBuffer.clear();
}
return std::nullopt;
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index efc2cb0a291ddce..970c7cbd26cac88 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1159,7 +1159,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
messages.Say(
"Assumed-type '%s' may be associated only with an assumed-type %s"_err_en_US,
assumed.name(), dummyName);
- } else if (object.type.attrs().test(evaluate::characteristics::
+ } else if (object.type.attrs().test(characteristics::
TypeAndShape::Attr::AssumedRank) &&
!IsAssumedShape(assumed) &&
!evaluate::IsAssumedRank(assumed)) {
@@ -1411,6 +1411,142 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
}
}
+// REDUCE (F'2023 16.9.173)
+static void CheckReduce(
+ evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) {
+ std::optional<evaluate::DynamicType> arrayType;
+ parser::ContextualMessages &messages{context.messages()};
+ if (const auto &array{arguments[0]}) {
+ arrayType = array->GetType();
+ if (!arguments[/*identity=*/4]) {
+ if (const auto *expr{array->UnwrapExpr()}) {
+ if (auto shape{
+ evaluate::GetShape(context, *expr, /*invariantOnly=*/false)}) {
+ if (const auto &dim{arguments[2]}; dim && array->Rank() > 1) {
+ // Partial reduction
+ auto dimVal{evaluate::ToInt64(dim->UnwrapExpr())};
+ std::int64_t j{0};
+ int zeroDims{0};
+ bool isSelectedDimEmpty{false};
+ for (const auto &extent : *shape) {
+ ++j;
+ if (evaluate::ToInt64(extent) == 0) {
+ ++zeroDims;
+ isSelectedDimEmpty |= dimVal && j == *dimVal;
+ }
+ }
+ if (isSelectedDimEmpty && zeroDims == 1) {
+ messages.Say(
+ "IDENTITY= must be present when DIM=%d and the array has zero extent on that dimension"_err_en_US,
+ static_cast<int>(dimVal.value()));
+ }
+ } else { // no DIM= or DIM=1 on a vector: total reduction
+ for (const auto &extent : *shape) {
+ if (evaluate::ToInt64(extent) == 0) {
+ messages.Say(
+ "IDENTITY= must be present when the array is empty and the result is scalar"_err_en_US);
+ break;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ 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);
+ } 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 REDUCE() must be a pure function of two data arguments"_err_en_US);
+ } else if (!result || result->Rank() != 0) {
+ messages.Say(
+ "OPERATION= argument of REDUCE() must be a scalar function"_err_en_US);
+ } else if (result->type().IsPolymorphic() ||
+ (arrayType && !arrayType->IsTkLenCompatibleWith(result->type()))) {
+ messages.Say(
+ "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);
+ }
+ if (!data[0] || !data[1]) {
+ messages.Say(
+ "OPERATION= argument of 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() ||
+ (arrayType &&
+ !data[j]->type.type().IsTkCompatibleWith(*arrayType))) {
+ messages.Say(
+ "Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US);
+ }
+ }
+ 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 REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute"_err_en_US);
+ break;
+ }
+ }
+ }
+ }
+ // When the MASK= is present and has no .TRUE. element, and there is
+ // no IDENTITY=, it's an error.
+ if (const auto &mask{arguments[3]}; mask && !arguments[/*identity*/ 4]) {
+ if (const auto *expr{mask->UnwrapExpr()}) {
+ if (const auto *logical{
+ std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&expr->u)}) {
+ if (common::visit(
+ [](const auto &kindExpr) {
+ using KindExprType = std::decay_t<decltype(kindExpr)>;
+ using KindLogical = typename KindExprType::Result;
+ if (const auto *c{evaluate::UnwrapConstantValue<KindLogical>(
+ kindExpr)}) {
+ for (const auto &element : c->values()) {
+ if (element.IsTrue()) {
+ return false;
+ }
+ }
+ return true;
+ }
+ return false;
+ },
+ logical->u)) {
+ messages.Say(
+ "MASK= has no .TRUE. element, so IDENTITY= must be present"_err_en_US);
+ }
+ }
+ }
+ }
+}
+
// TRANSFER (16.9.193)
static void CheckTransferOperandType(SemanticsContext &context,
const evaluate::DynamicType &type, const char *which) {
@@ -1483,6 +1619,8 @@ static void CheckSpecificIntrinsic(evaluate::ActualArguments &arguments,
const evaluate::SpecificIntrinsic &intrinsic) {
if (intrinsic.name == "associated") {
CheckAssociated(arguments, context, scope);
+ } else if (intrinsic.name == "reduce") {
+ CheckReduce(arguments, context.foldingContext());
} else if (intrinsic.name == "transfer") {
CheckTransfer(arguments, context, scope);
}
diff --git a/flang/test/Semantics/misc-intrinsics.f90 b/flang/test/Semantics/misc-intrinsics.f90
index 195906eef9d79e5..14dcdb05ac6c6ed 100644
--- a/flang/test/Semantics/misc-intrinsics.f90
+++ b/flang/test/Semantics/misc-intrinsics.f90
@@ -10,17 +10,17 @@ subroutine test(arg, assumedRank)
real, dimension(..) :: assumedRank
!ERROR: A dim= argument is required for 'size' when the array is assumed-size
print *, size(arg)
- !ERROR: missing mandatory 'dim=' argument
+ !ERROR: A dim= argument is required for 'ubound' when the array is assumed-size
print *, ubound(arg)
!ERROR: The 'source=' argument to the intrinsic function 'shape' may not be assumed-size
print *, shape(arg)
!ERROR: The 'harvest=' argument to the intrinsic procedure 'random_number' may not be assumed-size
call random_number(arg)
- !ERROR: missing mandatory 'dim=' argument
+ !ERROR: 'array=' argument has unacceptable rank 0
print *, lbound(scalar)
!ERROR: 'array=' argument has unacceptable rank 0
print *, size(scalar)
- !ERROR: missing mandatory 'dim=' argument
+ !ERROR: 'array=' argument has unacceptable rank 0
print *, ubound(scalar)
!ERROR: DIM=0 dimension must be positive
print *, lbound(arg, 0)
@@ -45,7 +45,7 @@ subroutine test(arg, assumedRank)
rank(*)
!ERROR: A dim= argument is required for 'size' when the array is assumed-size
print *, size(assumedRank)
- !ERROR: missing mandatory 'dim=' argument
+ !ERROR: A dim= argument is required for 'ubound' when the array is assumed-size
print *, ubound(assumedRank)
!ERROR: The 'source=' argument to the intrinsic function 'shape' may not be assumed-size
print *, shape(assumedRank)
diff --git a/flang/test/Semantics/reduce01.f90 b/flang/test/Semantics/reduce01.f90
index 8c5a46312ec0a52..ad63a42d73cae11 100644
--- a/flang/test/Semantics/reduce01.f90
+++ b/flang/test/Semantics/reduce01.f90
@@ -5,6 +5,10 @@ module m
character(len=len) :: ch
end type
contains
+ pure real function f(x,y)
+ real, intent(in) :: x, y
+ f = x + y
+ end function
impure real function f1(x,y)
f1 = x + y
end function
@@ -47,10 +51,20 @@ pure real function f9(x,y)
real, intent(in) :: y
f9 = x + y
end function
- pure real function f10(x,y)
+ pure real function f10a(x,y)
+ real, intent(in), asynchronous :: x
+ real, intent(in) :: y
+ f10a = x + y
+ end function
+ pure real function f10b(x,y)
real, intent(in), target :: x
real, intent(in) :: y
- f10 = x + y
+ f10b = x + y
+ end function
+ pure real function f10c(x,y)
+ real, intent(in), value :: x
+ real, intent(in) :: y
+ f10c = x + y
end function
pure function f11(x,y) result(res)
type(pdt(*)), intent(in) :: x, y
@@ -59,7 +73,7 @@ pure function f11(x,y) result(res)
end function
subroutine errors
- real :: a(10,10), b
+ real :: a(10,10), b, c(10)
!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
@@ -78,8 +92,29 @@ subroutine errors
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, nor 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)
+ !ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute
+ b = reduce(a, f10a)
+ !ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute
+ b = reduce(a, f10b)
+ !ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute
+ b = reduce(a, f10c)
+ !ERROR: IDENTITY= must be present when the array is empty and the result is scalar
+ b = reduce(a(1:0,:), f)
+ !ERROR: IDENTITY= must be present when the array is empty and the result is scalar
+ b = reduce(a(1:0, 1), f, dim=1)
+ !ERROR: IDENTITY= must be present when DIM=1 and the array has zero extent on that dimension
+ c = reduce(a(1:0, :), f, dim=1)
+ !ERROR: IDENTITY= must be present when DIM=1 and the array has zero extent on that dimension
+ c = reduce(a(1:0, :), f, dim=1)
+ !ERROR: IDENTITY= must be present when DIM=2 and the array has zero extent on that dimension
+ c = reduce(a(:, 1:0), f, dim=2)
+ c(1:0) = reduce(a(1:0, 1:0), f, dim=1) ! ok, result is empty
+ c(1:0) = reduce(a(1:0, 1:0), f, dim=2) ! ok, result is empty
+ !ERROR: MASK= has no .TRUE. element, so IDENTITY= must be present
+ b = reduce(a, f, .false.)
+ !ERROR: MASK= has no .TRUE. element, so IDENTITY= must be present
+ b = reduce(a, f, reshape([(j > 100, j=1, 100)], shape(a)))
+ b = reduce(a, f, reshape([(j == 50, j=1, 100)], shape(a))) ! ok
end subroutine
subroutine not_errors
type(pdt(10)) :: a(10), b
``````````
</details>
https://github.com/llvm/llvm-project/pull/72570
More information about the flang-commits
mailing list