Skip to content

Commit

Permalink
[flang] Move and extend REDUCE() compile-time checking (#72570)
Browse files Browse the repository at this point in the history 
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.
  • Loading branch information
@klausler
klausler committed Nov 30, 2023
1 parent f1eddf5 commit bf4a876
Show file tree
Hide file tree
Showing 4 changed files with 213 additions and 97 deletions.
117 changes: 30 additions & 87 deletions flang/lib/Evaluate/intrinsics.cpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down Expand Up @@ -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};
Expand All @@ -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") {
Expand Down Expand Up @@ -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);
}
Expand Down Expand Up @@ -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;
Expand Down
140 changes: 139 additions & 1 deletion flang/lib/Semantics/check-call.cpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1162,7 +1162,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)) {
Expand Down Expand Up @@ -1414,6 +1414,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) {
Expand Down Expand Up @@ -1486,6 +1622,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);
}
Expand Down
8 changes: 4 additions & 4 deletions flang/test/Semantics/misc-intrinsics.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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)
Expand Down

0 comments on commit bf4a876

Please sign in to comment.