diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index b7cedd987043..67a087d5daae 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -31,7 +31,8 @@ accepted if enabled by command-line options. 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/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index e6a8434b1d7b..5e71dd0e2ec1 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -145,12 +145,15 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, const std::string &dummyName, evaluate::Expr &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 CheckProcedureArg(evaluate::ActualArgument &arg, 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 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, 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 bool CheckElementalConformance(parser::ContextualMessages &messages, 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 @@ static parser::Messages CheckExplicitInterface( 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 @@ static parser::Messages CheckExplicitInterface( 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/flang/lib/Semantics/check-call.h b/flang/lib/Semantics/check-call.h index 43d6b2ac817a..7c68f2bd8e2a 100644 --- a/flang/lib/Semantics/check-call.h +++ b/flang/lib/Semantics/check-call.h @@ -45,6 +45,7 @@ parser::Messages CheckExplicitInterface( // 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/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 0f8eef362a83..9635659c47c6 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2021,8 +2021,8 @@ std::pair ExpressionAnalyzer::ResolveGeneric( 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)) {