diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -367,7 +367,7 @@ const semantics::Symbol &original, FoldingContext &context, semantics::UnorderedSymbolSet &seenProcs) { Procedure result; - const auto &symbol{original.GetUltimate()}; + const auto &symbol{ResolveAssociations(original)}; if (seenProcs.find(symbol) != seenProcs.end()) { std::string procsList{GetSeenProcs(seenProcs)}; context.messages().Say(symbol.name(), @@ -417,6 +417,11 @@ [&](const semantics::ProcEntityDetails &proc) -> std::optional { if (symbol.attrs().test(semantics::Attr::INTRINSIC)) { + // Fails when the intrinsic is not a specific intrinsic function + // from F'2018 table 16.2. In order to handle forward references, + // attempts to use impermissible intrinsic procedures as the + // interfaces of procedure pointers are caught and flagged in + // declaration checking in Semantics. return context.intrinsics().IsSpecificIntrinsicFunction( symbol.name().ToString()); } @@ -786,7 +791,7 @@ const ProcedureDesignator &proc, FoldingContext &context) { if (const auto *symbol{proc.GetSymbol()}) { if (auto result{characteristics::Procedure::Characterize( - symbol->GetUltimate(), context)}) { + ResolveAssociations(*symbol), context)}) { return result; } } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) { diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -575,6 +575,12 @@ // or an unrestricted specific intrinsic function. const Symbol &ultimate{(*proc->init())->GetUltimate()}; if (ultimate.attrs().test(Attr::INTRINSIC)) { + if (!context_.intrinsics().IsSpecificIntrinsicFunction( + ultimate.name().ToString())) { // C1030 + context_.Say( + "Intrinsic procedure '%s' is not a specific intrinsic permitted for use as the initializer for procedure pointer '%s'"_err_en_US, + ultimate.name(), symbol.name()); + } } else if (!ultimate.attrs().test(Attr::EXTERNAL) && ultimate.owner().kind() != Scope::Kind::Module) { context_.Say("Procedure pointer '%s' initializer '%s' is neither " @@ -715,8 +721,14 @@ if (symbol.attrs().test(Attr::POINTER)) { CheckPointerInitialization(symbol); if (const Symbol * interface{details.interface().symbol()}) { - if (interface->attrs().test(Attr::ELEMENTAL) && - !interface->attrs().test(Attr::INTRINSIC)) { + if (interface->attrs().test(Attr::INTRINSIC)) { + if (!context_.intrinsics().IsSpecificIntrinsicFunction( + interface->name().ToString())) { // C1515 + messages_.Say( + "Intrinsic procedure '%s' is not a specific intrinsic permitted for use as the definition of the interface to procedure pointer '%s'"_err_en_US, + interface->name(), symbol.name()); + } + } else if (interface->attrs().test(Attr::ELEMENTAL)) { messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US, symbol.name()); // C1517 }