[flang] Fix generic resolution case
Don't try to convert INTEGER argument expressions to the kind of
the dummy argument when performing generic resolution; specific
procedures may be distinguished only by their kinds.
Differential Revision: https://reviews.llvm.org/D112240
GitOrigin-RevId: 14b90d1fe0d79c8adbe8531ebc79199a8892a781
diff --git a/docs/Extensions.md b/docs/Extensions.md
index b7cedd9..67a087d 100644
--- a/docs/Extensions.md
+++ b/docs/Extensions.md
@@ -31,7 +31,8 @@
This conversion allows the results of the intrinsics like
`SIZE` that (as mentioned below) may return non-default
`INTEGER` results by default to be passed. A warning is
- emitted when truncation is possible.
+ emitted when truncation is possible. These conversions
+ are not applied in calls to non-intrinsic generic procedures.
* We are not strict on the contents of `BLOCK DATA` subprograms
so long as they contain no executable code, no internal subprograms,
and allocate no storage outside a named `COMMON` block. (C1415)
diff --git a/lib/Semantics/check-call.cpp b/lib/Semantics/check-call.cpp
index e6a8434..5e71dd0 100644
--- a/lib/Semantics/check-call.cpp
+++ b/lib/Semantics/check-call.cpp
@@ -145,12 +145,15 @@
const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,
characteristics::TypeAndShape &actualType, bool isElemental,
evaluate::FoldingContext &context, const Scope *scope,
- const evaluate::SpecificIntrinsic *intrinsic) {
+ const evaluate::SpecificIntrinsic *intrinsic,
+ bool allowIntegerConversions) {
// Basic type & rank checking
parser::ContextualMessages &messages{context.messages()};
PadShortCharacterActual(actual, dummy.type, actualType, context, messages);
- ConvertIntegerActual(actual, dummy.type, actualType, messages);
+ if (allowIntegerConversions) {
+ ConvertIntegerActual(actual, dummy.type, actualType, messages);
+ }
bool typesCompatible{dummy.type.type().IsTkCompatibleWith(actualType.type())};
if (typesCompatible) {
if (isElemental) {
@@ -631,7 +634,8 @@
static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
const characteristics::DummyArgument &dummy,
const characteristics::Procedure &proc, evaluate::FoldingContext &context,
- const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic) {
+ const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
+ bool allowIntegerConversions) {
auto &messages{context.messages()};
std::string dummyName{"dummy argument"};
if (!dummy.name.empty()) {
@@ -646,7 +650,8 @@
arg.set_dummyIntent(object.intent);
bool isElemental{object.type.Rank() == 0 && proc.IsElemental()};
CheckExplicitDataArg(object, dummyName, *expr, *type,
- isElemental, context, scope, intrinsic);
+ isElemental, context, scope, intrinsic,
+ allowIntegerConversions);
} else if (object.type.type().IsTypelessIntrinsicArgument() &&
IsBOZLiteral(*expr)) {
// ok
@@ -779,7 +784,8 @@
static parser::Messages CheckExplicitInterface(
const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
const evaluate::FoldingContext &context, const Scope *scope,
- const evaluate::SpecificIntrinsic *intrinsic) {
+ const evaluate::SpecificIntrinsic *intrinsic,
+ bool allowIntegerConversions) {
parser::Messages buffer;
parser::ContextualMessages messages{context.messages().at(), &buffer};
RearrangeArguments(proc, actuals, messages);
@@ -789,8 +795,8 @@
for (auto &actual : actuals) {
const auto &dummy{proc.dummyArguments.at(index++)};
if (actual) {
- CheckExplicitInterfaceArg(
- *actual, dummy, proc, localContext, scope, intrinsic);
+ CheckExplicitInterfaceArg(*actual, dummy, proc, localContext, scope,
+ intrinsic, allowIntegerConversions);
} else if (!dummy.IsOptional()) {
if (dummy.name.empty()) {
messages.Say(
@@ -815,13 +821,15 @@
parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc,
evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context,
const Scope &scope, const evaluate::SpecificIntrinsic *intrinsic) {
- return CheckExplicitInterface(proc, actuals, context, &scope, intrinsic);
+ return CheckExplicitInterface(
+ proc, actuals, context, &scope, intrinsic, true);
}
bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,
- evaluate::ActualArguments &actuals,
- const evaluate::FoldingContext &context) {
- return !CheckExplicitInterface(proc, actuals, context, nullptr, nullptr)
+ evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context,
+ bool allowIntegerConversions) {
+ return !CheckExplicitInterface(
+ proc, actuals, context, nullptr, nullptr, allowIntegerConversions)
.AnyFatalError();
}
diff --git a/lib/Semantics/check-call.h b/lib/Semantics/check-call.h
index 43d6b2a..7c68f2b 100644
--- a/lib/Semantics/check-call.h
+++ b/lib/Semantics/check-call.h
@@ -45,6 +45,7 @@
// Checks actual arguments for the purpose of resolving a generic interface.
bool CheckInterfaceForGeneric(const evaluate::characteristics::Procedure &,
- evaluate::ActualArguments &, const evaluate::FoldingContext &);
+ evaluate::ActualArguments &, const evaluate::FoldingContext &,
+ bool allowIntegerConversions = false);
} // namespace Fortran::semantics
#endif
diff --git a/lib/Semantics/expression.cpp b/lib/Semantics/expression.cpp
index 0f8eef3..9635659 100644
--- a/lib/Semantics/expression.cpp
+++ b/lib/Semantics/expression.cpp
@@ -2021,8 +2021,8 @@
continue;
}
}
- if (semantics::CheckInterfaceForGeneric(
- *procedure, localActuals, GetFoldingContext()) &&
+ if (semantics::CheckInterfaceForGeneric(*procedure, localActuals,
+ GetFoldingContext(), false /* no integer conversions */) &&
CheckCompatibleArguments(*procedure, localActuals)) {
if ((procedure->IsElemental() && elemental) ||
(!procedure->IsElemental() && nonElemental)) {
