diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h index 04a0d71e1adeb..f2f37866ecde8 100644 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -381,8 +381,8 @@ struct Procedure { int FindPassIndex(std::optional) const; bool CanBeCalledViaImplicitInterface(std::string *whyNot = nullptr) const; bool CanOverride(const Procedure &, std::optional passIndex) const; - bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr, - const SpecificIntrinsic * = nullptr, + bool IsCompatibleWith(const Procedure &, bool ignoreImplicitVsExplicit, + std::string *whyNot = nullptr, const SpecificIntrinsic * = nullptr, std::optional *warning = nullptr) const; llvm::raw_ostream &Dump(llvm::raw_ostream &) const; diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h index d257da1a70964..53896072675ab 100644 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1094,7 +1094,7 @@ std::optional CheckProcCompatibility(bool isCall, const std::optional &lhsProcedure, const characteristics::Procedure *rhsProcedure, const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible, - std::optional &warning); + std::optional &warning, bool ignoreImplicitVsExplicit); // Scalar constant expansion class ScalarConstantExpander { diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp index 80b0f346c32d3..ee556a1053713 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -533,7 +533,8 @@ bool DummyProcedure::IsCompatibleWith( } return false; } - if (!procedure.value().IsCompatibleWith(actual.procedure.value(), whyNot)) { + if (!procedure.value().IsCompatibleWith(actual.procedure.value(), + /*ignoreImplicitVsExplicit=*/false, whyNot)) { if (whyNot) { *whyNot = "incompatible dummy procedure interfaces: "s + *whyNot; } @@ -1206,7 +1207,8 @@ bool FunctionResult::IsCompatibleWith( CHECK(ifaceProc != nullptr); if (const auto *actualProc{ std::get_if>(&actual.u)}) { - if (ifaceProc->value().IsCompatibleWith(actualProc->value(), whyNot)) { + if (ifaceProc->value().IsCompatibleWith(actualProc->value(), + /*ignoreImplicitVsExplicit=*/false, whyNot)) { return true; } if (whyNot) { @@ -1251,7 +1253,8 @@ bool Procedure::operator==(const Procedure &that) const { cudaSubprogramAttrs == that.cudaSubprogramAttrs; } -bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot, +bool Procedure::IsCompatibleWith(const Procedure &actual, + bool ignoreImplicitVsExplicit, std::string *whyNot, const SpecificIntrinsic *specificIntrinsic, std::optional *warning) const { // 15.5.2.9(1): if dummy is not pure, actual need not be. @@ -1265,6 +1268,9 @@ bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot, } Attrs differences{attrs ^ actualAttrs}; differences.reset(Attr::Subroutine); // dealt with specifically later + if (ignoreImplicitVsExplicit) { + differences.reset(Attr::ImplicitInterface); + } if (!differences.empty()) { if (whyNot) { auto sep{": "s}; diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 131bbd97ce163..e7fc651b9173f 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1083,7 +1083,7 @@ std::optional CheckProcCompatibility(bool isCall, const std::optional &lhsProcedure, const characteristics::Procedure *rhsProcedure, const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible, - std::optional &warning) { + std::optional &warning, bool ignoreImplicitVsExplicit) { std::optional msg; if (!lhsProcedure) { msg = "In assignment to object %s, the target '%s' is a procedure" @@ -1097,8 +1097,9 @@ std::optional CheckProcCompatibility(bool isCall, *rhsProcedure->functionResult, &whyNotCompatible)) { msg = "Function %s associated with incompatible function designator '%s': %s"_err_en_US; - } else if (lhsProcedure->IsCompatibleWith(*rhsProcedure, &whyNotCompatible, - specificIntrinsic, &warning)) { + } else if (lhsProcedure->IsCompatibleWith(*rhsProcedure, + ignoreImplicitVsExplicit, &whyNotCompatible, specificIntrinsic, + &warning)) { // OK } else if (isCall) { msg = "Procedure %s associated with result of reference to function '%s'" diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index fdf7805beab7e..f0e5064f6e3ce 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -912,7 +912,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, static void CheckProcedureArg(evaluate::ActualArgument &arg, const characteristics::Procedure &proc, const characteristics::DummyProcedure &dummy, const std::string &dummyName, - SemanticsContext &context) { + SemanticsContext &context, bool ignoreImplicitVsExplicit) { evaluate::FoldingContext &foldingContext{context.foldingContext()}; parser::ContextualMessages &messages{foldingContext.messages()}; auto restorer{ @@ -975,7 +975,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg, if (interface.HasExplicitInterface()) { std::string whyNot; std::optional warning; - if (!interface.IsCompatibleWith(argInterface, &whyNot, + if (!interface.IsCompatibleWith(argInterface, + ignoreImplicitVsExplicit, &whyNot, /*specificIntrinsic=*/nullptr, &warning)) { // 15.5.2.9(1): Explicit interfaces must match if (argInterface.HasExplicitInterface()) { @@ -1081,7 +1082,8 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, const characteristics::DummyArgument &dummy, const characteristics::Procedure &proc, SemanticsContext &context, const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic, - bool allowActualArgumentConversions, bool extentErrors) { + bool allowActualArgumentConversions, bool extentErrors, + bool ignoreImplicitVsExplicit) { evaluate::FoldingContext &foldingContext{context.foldingContext()}; auto &messages{foldingContext.messages()}; std::string dummyName{"dummy argument"}; @@ -1185,7 +1187,8 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, }, [&](const characteristics::DummyProcedure &dummy) { if (!checkActualArgForLabel(arg)) { - CheckProcedureArg(arg, proc, dummy, dummyName, context); + CheckProcedureArg(arg, proc, dummy, dummyName, context, + ignoreImplicitVsExplicit); } }, [&](const characteristics::AlternateReturn &) { @@ -1371,7 +1374,8 @@ static void CheckAssociated(evaluate::ActualArguments &arguments, : nullptr}; std::optional msg{ CheckProcCompatibility(isCall, pointerProc, &*targetProc, - specificIntrinsic, whyNot, warning)}; + specificIntrinsic, whyNot, warning, + /*ignoreImplicitVsExplicit=*/false)}; if (!msg && warning && semanticsContext.ShouldWarn( common::UsageWarning::ProcDummyArgShapes)) { @@ -1740,7 +1744,8 @@ static parser::Messages CheckExplicitInterface( const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, SemanticsContext &context, const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic, - bool allowActualArgumentConversions, bool extentErrors) { + bool allowActualArgumentConversions, bool extentErrors, + bool ignoreImplicitVsExplicit) { evaluate::FoldingContext &foldingContext{context.foldingContext()}; parser::ContextualMessages &messages{foldingContext.messages()}; parser::Messages buffer; @@ -1754,7 +1759,8 @@ static parser::Messages CheckExplicitInterface( const auto &dummy{proc.dummyArguments.at(index++)}; if (actual) { CheckExplicitInterfaceArg(*actual, dummy, proc, context, scope, intrinsic, - allowActualArgumentConversions, extentErrors); + allowActualArgumentConversions, extentErrors, + ignoreImplicitVsExplicit); } else if (!dummy.IsOptional()) { if (dummy.name.empty()) { messages.Say( @@ -1783,7 +1789,8 @@ bool CheckInterfaceForGeneric(const characteristics::Procedure &proc, bool allowActualArgumentConversions) { return proc.HasExplicitInterface() && !CheckExplicitInterface(proc, actuals, context, nullptr, nullptr, - allowActualArgumentConversions, false /*extentErrors*/) + allowActualArgumentConversions, /*extentErrors=*/false, + /*ignoreImplicitVsExplicit=*/false) .AnyFatalError(); } @@ -1876,6 +1883,7 @@ bool CheckPPCIntrinsic(const Symbol &generic, const Symbol &specific, bool CheckArguments(const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, SemanticsContext &context, const Scope &scope, bool treatingExternalAsImplicit, + bool ignoreImplicitVsExplicit, const evaluate::SpecificIntrinsic *intrinsic) { bool explicitInterface{proc.HasExplicitInterface()}; evaluate::FoldingContext foldingContext{context.foldingContext()}; @@ -1898,8 +1906,9 @@ bool CheckArguments(const characteristics::Procedure &proc, } } if (explicitInterface) { - auto buffer{CheckExplicitInterface( - proc, actuals, context, &scope, intrinsic, true, true)}; + auto buffer{CheckExplicitInterface(proc, actuals, context, &scope, + intrinsic, /*allowArgumentConversions=*/true, /*extentErrors=*/true, + ignoreImplicitVsExplicit)}; if (!buffer.empty()) { if (treatingExternalAsImplicit) { if (auto *msg{messages.Say( diff --git a/flang/lib/Semantics/check-call.h b/flang/lib/Semantics/check-call.h index 4275606225eb8..8553f3a31efb5 100644 --- a/flang/lib/Semantics/check-call.h +++ b/flang/lib/Semantics/check-call.h @@ -35,7 +35,7 @@ class SemanticsContext; // messages were created, true if all is well. bool CheckArguments(const evaluate::characteristics::Procedure &, evaluate::ActualArguments &, SemanticsContext &, const Scope &, - bool treatingExternalAsImplicit, + bool treatingExternalAsImplicit, bool ignoreImplicitVsExplicit, const evaluate::SpecificIntrinsic *intrinsic); bool CheckPPCIntrinsic(const Symbol &generic, const Symbol &specific, diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index e9adc086402d6..719bea34406aa 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -1481,7 +1481,8 @@ void CheckHelper::CheckExternal(const Symbol &symbol) { if (auto globalChars{Characterize(*global)}) { if (chars->HasExplicitInterface()) { std::string whyNot; - if (!chars->IsCompatibleWith(*globalChars, &whyNot)) { + if (!chars->IsCompatibleWith(*globalChars, + /*ignoreImplicitVsExplicit=*/false, &whyNot)) { msg = WarnIfNotInModuleFile( "The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US, global->name(), whyNot); @@ -1507,7 +1508,8 @@ void CheckHelper::CheckExternal(const Symbol &symbol) { if (auto chars{Characterize(symbol)}) { if (auto previousChars{Characterize(previous)}) { std::string whyNot; - if (!chars->IsCompatibleWith(*previousChars, &whyNot)) { + if (!chars->IsCompatibleWith(*previousChars, + /*ignoreImplicitVsExplicit=*/false, &whyNot)) { if (auto *msg{WarnIfNotInModuleFile( "The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US, symbol.name(), whyNot)}) { diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 8d817f077880b..46bfac25202e7 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -3129,7 +3129,8 @@ std::optional ExpressionAnalyzer::CheckCall( if (auto iter{implicitInterfaces_.find(name)}; iter != implicitInterfaces_.end()) { std::string whyNot; - if (!chars->IsCompatibleWith(iter->second.second, &whyNot)) { + if (!chars->IsCompatibleWith(iter->second.second, + /*ignoreImplicitVsExplicit=*/false, &whyNot)) { if (auto *msg{Say(callSite, "Reference to the procedure '%s' has an implicit interface that is distinct from another reference: %s"_warn_en_US, name, whyNot)}) { @@ -3169,7 +3170,7 @@ std::optional ExpressionAnalyzer::CheckCall( } ok &= semantics::CheckArguments(*chars, arguments, context_, context_.FindScope(callSite), treatExternalAsImplicit, - specificIntrinsic); + /*ignoreImplicitVsExplicit=*/false, specificIntrinsic); } if (procSymbol && !IsPureProcedure(*procSymbol)) { if (const semantics::Scope * @@ -3188,7 +3189,8 @@ std::optional ExpressionAnalyzer::CheckCall( if (auto globalChars{characteristics::Procedure::Characterize( *global, context_.foldingContext())}) { semantics::CheckArguments(*globalChars, arguments, context_, - context_.FindScope(callSite), true, + context_.FindScope(callSite), /*treatExternalAsImplicit=*/true, + /*ignoreImplicitVsExplicit=*/false, nullptr /*not specific intrinsic*/); } } diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp index 4c293e85cf9de..58155a29da1ee 100644 --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -362,7 +362,8 @@ bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall, std::optional warning; CharacterizeProcedure(); if (std::optional msg{evaluate::CheckProcCompatibility( - isCall, procedure_, rhsProcedure, specific, whyNot, warning)}) { + isCall, procedure_, rhsProcedure, specific, whyNot, warning, + /*ignoreImplicitVsExplicit=*/isCall)}) { Say(std::move(*msg), description_, rhsName, whyNot); return false; } diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 0cbe0b492fa44..5389456d0f491 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -8362,16 +8362,25 @@ bool ResolveNamesVisitor::Pre(const parser::PointerAssignmentStmt &x) { const auto &bounds{std::get(x.t)}; const auto &expr{std::get(x.t)}; ResolveDataRef(dataRef); + Symbol *ptrSymbol{parser::GetLastName(dataRef).symbol}; Walk(bounds); // Resolve unrestricted specific intrinsic procedures as in "p => cos". if (const parser::Name * name{parser::Unwrap(expr)}) { if (NameIsKnownOrIntrinsic(*name)) { - // If the name is known because it is an object entity from a host - // procedure, create a host associated symbol. - if (Symbol * symbol{name->symbol}; symbol && - symbol->GetUltimate().has() && - IsUplevelReference(*symbol)) { - MakeHostAssocSymbol(*name, *symbol); + if (Symbol * symbol{name->symbol}) { + if (IsProcedurePointer(ptrSymbol) && + !ptrSymbol->test(Symbol::Flag::Function) && + !ptrSymbol->test(Symbol::Flag::Subroutine)) { + if (symbol->test(Symbol::Flag::Function)) { + ApplyImplicitRules(*ptrSymbol); + } + } + // If the name is known because it is an object entity from a host + // procedure, create a host associated symbol. + if (symbol->GetUltimate().has() && + IsUplevelReference(*symbol)) { + MakeHostAssocSymbol(*name, *symbol); + } } return false; } diff --git a/flang/test/Semantics/implicit14.f90 b/flang/test/Semantics/implicit14.f90 new file mode 100644 index 0000000000000..d688049a587f7 --- /dev/null +++ b/flang/test/Semantics/implicit14.f90 @@ -0,0 +1,54 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +module m + type dt + procedure(explicit), pointer, nopass :: p + end type + contains + integer function one() + one = 1 + end + function onePtr() + procedure(one), pointer :: onePtr + onePtr => one + end + function explicit + character(:), allocatable :: explicit + explicit = "abc" + end +end + +program test + use m + procedure(), pointer :: p0 + procedure(one), pointer :: p1 + procedure(integer), pointer :: p2 + procedure(explicit), pointer :: p3 + external implicit + type(dt) x + p0 => one ! ok + p0 => onePtr() ! ok + p0 => implicit ! ok + !ERROR: Procedure pointer 'p0' with implicit interface may not be associated with procedure designator 'explicit' with explicit interface that cannot be called via an implicit interface + p0 => explicit + p1 => one ! ok + p1 => onePtr() ! ok + p1 => implicit ! ok + !ERROR: Function pointer 'p1' associated with incompatible function designator 'explicit': function results have incompatible attributes + p1 => explicit + p2 => one ! ok + p2 => onePtr() ! ok + p2 => implicit ! ok + !ERROR: Function pointer 'p2' associated with incompatible function designator 'explicit': function results have incompatible attributes + p2 => explicit + !ERROR: Function pointer 'p3' associated with incompatible function designator 'one': function results have incompatible attributes + p3 => one + !ERROR: Procedure pointer 'p3' associated with result of reference to function 'oneptr' that is an incompatible procedure pointer: function results have incompatible attributes + p3 => onePtr() + p3 => explicit ! ok + !ERROR: Procedure pointer 'p3' with explicit interface that cannot be called via an implicit interface cannot be associated with procedure designator with an implicit interface + p3 => implicit + !ERROR: Procedure pointer 'p' with explicit interface that cannot be called via an implicit interface cannot be associated with procedure designator with an implicit interface + x = dt(implicit) + !ERROR: Procedure pointer 'p' with explicit interface that cannot be called via an implicit interface cannot be associated with procedure designator with an implicit interface + x%p => implicit +end