[flang-commits] [flang] [flang] Whether a procedure's interface is explicit or not is not a d… (PR #82796)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Fri Mar 1 11:05:11 PST 2024
https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/82796
>From 5ebbba746cca16e41f259f9d521b9315c2abc0cf Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Fri, 23 Feb 2024 09:16:27 -0800
Subject: [PATCH] [flang] Whether a procedure's interface is explicit or not is
not a distinguishing characteristic
We note whether a procedure's interface is explicit or implicit as an
attribute of its characteristics, so that other semantics can be
checked appropriately, but this internal attribute should not be
used as a distinguishing characteristic in itself.
Fixes https://github.com/llvm/llvm-project/issues/81876.
---
.../include/flang/Evaluate/characteristics.h | 4 +-
flang/include/flang/Evaluate/tools.h | 2 +-
flang/lib/Evaluate/characteristics.cpp | 14 +++--
flang/lib/Evaluate/tools.cpp | 7 +--
flang/lib/Semantics/check-call.cpp | 29 ++++++----
flang/lib/Semantics/check-call.h | 2 +-
flang/lib/Semantics/check-declarations.cpp | 6 ++-
flang/lib/Semantics/expression.cpp | 8 +--
flang/lib/Semantics/pointer-assignment.cpp | 3 +-
flang/lib/Semantics/resolve-names.cpp | 21 +++++---
flang/test/Semantics/implicit14.f90 | 54 +++++++++++++++++++
11 files changed, 118 insertions(+), 32 deletions(-)
create mode 100644 flang/test/Semantics/implicit14.f90
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 04a0d71e1adebe..f2f37866ecde86 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<parser::CharBlock>) const;
bool CanBeCalledViaImplicitInterface(std::string *whyNot = nullptr) const;
bool CanOverride(const Procedure &, std::optional<int> 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<std::string> *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 d257da1a709642..53896072675abc 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1094,7 +1094,7 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
const std::optional<characteristics::Procedure> &lhsProcedure,
const characteristics::Procedure *rhsProcedure,
const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
- std::optional<std::string> &warning);
+ std::optional<std::string> &warning, bool ignoreImplicitVsExplicit);
// Scalar constant expansion
class ScalarConstantExpander {
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 80b0f346c32d38..50e547439ff682 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<CopyableIndirection<Procedure>>(&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<std::string> *warning) const {
// 15.5.2.9(1): if dummy is not pure, actual need not be.
@@ -1265,6 +1268,11 @@ bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
}
Attrs differences{attrs ^ actualAttrs};
differences.reset(Attr::Subroutine); // dealt with specifically later
+ if (ignoreImplicitVsExplicit) {
+ if (getenv("PMK"))
+ CHECK(!differences.test(Attr::ImplicitInterface));
+ 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 131bbd97ce1632..e7fc651b9173fe 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1083,7 +1083,7 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
const std::optional<characteristics::Procedure> &lhsProcedure,
const characteristics::Procedure *rhsProcedure,
const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
- std::optional<std::string> &warning) {
+ std::optional<std::string> &warning, bool ignoreImplicitVsExplicit) {
std::optional<parser::MessageFixedText> msg;
if (!lhsProcedure) {
msg = "In assignment to object %s, the target '%s' is a procedure"
@@ -1097,8 +1097,9 @@ std::optional<parser::MessageFixedText> 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 fdf7805beab7ed..f0e5064f6e3ce4 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<std::string> 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<parser::MessageFixedText> 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 4275606225eb8a..8553f3a31efb52 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 e9adc086402d63..719bea34406aa0 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 8d817f077880b9..46bfac25202e79 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -3129,7 +3129,8 @@ std::optional<characteristics::Procedure> 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<characteristics::Procedure> 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<characteristics::Procedure> 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 4c293e85cf9de9..58155a29da1ee5 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<std::string> warning;
CharacterizeProcedure();
if (std::optional<MessageFixedText> 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 0cbe0b492fa44a..5389456d0f4913 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<parser::PointerAssignmentStmt::Bounds>(x.t)};
const auto &expr{std::get<parser::Expr>(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<parser::Name>(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<ObjectEntityDetails>() &&
- 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<ObjectEntityDetails>() &&
+ 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 00000000000000..d688049a587f7a
--- /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
More information about the flang-commits
mailing list