From 3b7b7fa7138c58e878567f6fed8f954f0e4e00a0 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Thu, 1 Sep 2022 10:14:24 -0700 Subject: [PATCH] [flang] Accept a separate module procedure interface as a specific procedure The code snippet module m interface module subroutine specific end subroutine end interface interface generic module procedure specific end interface end module elicits a bogus semantic error about "specific" not being an acceptable module procedure for the generic interface; fix. Differential Revision: https://reviews.llvm.org/D134402 --- flang/lib/Semantics/check-call.cpp | 7 +++--- flang/lib/Semantics/check-declarations.cpp | 17 ++++++++++----- flang/lib/Semantics/resolve-names.cpp | 35 +++++++++++++++--------------- flang/lib/Semantics/tools.cpp | 8 +++++++ flang/test/Semantics/generic02.f90 | 12 ++++++++++ flang/test/Semantics/resolve15.f90 | 14 ++++++++++-- 6 files changed, 66 insertions(+), 27 deletions(-) create mode 100644 flang/test/Semantics/generic02.f90 diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index 00636c0..1f2af55c 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -931,9 +931,10 @@ parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc, bool CheckInterfaceForGeneric(const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context, bool allowActualArgumentConversions) { - return !CheckExplicitInterface( - proc, actuals, context, nullptr, nullptr, allowActualArgumentConversions) - .AnyFatalError(); + return proc.HasExplicitInterface() && + !CheckExplicitInterface(proc, actuals, context, nullptr, nullptr, + allowActualArgumentConversions) + .AnyFatalError(); } void CheckArguments(const characteristics::Procedure &proc, diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index 935c994..1326bae 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -1188,15 +1188,22 @@ void CheckHelper::CheckGeneric( void CheckHelper::CheckSpecificsAreDistinguishable( const Symbol &generic, const GenericDetails &details) { GenericKind kind{details.kind()}; - const SymbolVector &specifics{details.specificProcs()}; - std::size_t count{specifics.size()}; - if (count < 2 || !kind.IsName()) { + if (!kind.IsName()) { return; } DistinguishabilityHelper helper{context_}; - for (const Symbol &specific : specifics) { + for (const Symbol &specific : details.specificProcs()) { if (const Procedure * procedure{Characterize(specific)}) { - helper.Add(generic, kind, specific, *procedure); + if (procedure->HasExplicitInterface()) { + helper.Add(generic, kind, specific, *procedure); + } else { + if (auto *msg{messages_.Say(specific.name(), + "Specific procedure '%s' of generic interface '%s' must have an explicit interface"_err_en_US, + specific.name(), generic.name())}) { + msg->Attach( + generic.name(), "Definition of '%s'"_en_US, generic.name()); + } + } } } helper.Check(generic.owner()); diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index f4430d9..3f56a25 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -3138,24 +3138,25 @@ void InterfaceVisitor::ResolveSpecificsInGeneric(Symbol &generic) { const Symbol &specific{ symbol == &symbol->GetUltimate() ? bypassed : *symbol}; const Symbol &ultimate{bypassed.GetUltimate()}; - if (!ultimate.has() && - !ultimate.has()) { - Say(*name, "'%s' is not a subprogram"_err_en_US); + ProcedureDefinitionClass defClass{ClassifyProcedure(ultimate)}; + if (defClass == ProcedureDefinitionClass::Module) { + // ok + } else if (kind == ProcedureKind::ModuleProcedure) { + Say(*name, "'%s' is not a module procedure"_err_en_US); continue; - } - if (kind == ProcedureKind::ModuleProcedure) { - if (const auto *nd{ultimate.detailsIf()}) { - if (nd->kind() != SubprogramKind::Module) { - Say(*name, "'%s' is not a module procedure"_err_en_US); - } - } else { - // USE-associated procedure - const auto *sd{ultimate.detailsIf()}; - CHECK(sd); - if (ultimate.owner().kind() != Scope::Kind::Module || - sd->isInterface()) { - Say(*name, "'%s' is not a module procedure"_err_en_US); - } + } else { + switch (defClass) { + case ProcedureDefinitionClass::Intrinsic: + case ProcedureDefinitionClass::External: + case ProcedureDefinitionClass::Internal: + break; + case ProcedureDefinitionClass::None: + Say(*name, "'%s' is not a procedure"_err_en_US); + continue; + default: + Say(*name, + "'%s' is not a procedure that can appear in a generic interface"_err_en_US); + continue; } } if (symbolsSeen.insert(ultimate).second /*true if added*/) { diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp index 6f91024..f575480 100644 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -1149,6 +1149,14 @@ ProcedureDefinitionClass ClassifyProcedure(const Symbol &symbol) { // 15.2.2 } else if (IsPointer(ultimate)) { return ProcedureDefinitionClass::Pointer; } + } else if (const auto *nameDetails{ + ultimate.detailsIf()}) { + switch (nameDetails->kind()) { + case SubprogramKind::Module: + return ProcedureDefinitionClass::Module; + case SubprogramKind::Internal: + return ProcedureDefinitionClass::Internal; + } } else if (const Symbol * subp{FindSubprogram(symbol)}) { if (const auto *subpDetails{subp->detailsIf()}) { if (subpDetails->stmtFunction()) { diff --git a/flang/test/Semantics/generic02.f90 b/flang/test/Semantics/generic02.f90 new file mode 100644 index 0000000..e4f7fe6 --- /dev/null +++ b/flang/test/Semantics/generic02.f90 @@ -0,0 +1,12 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +program test + interface generic + subroutine explicit(n) + integer, intent(in) :: n + end subroutine + procedure implicit + end interface +!ERROR: Specific procedure 'implicit' of generic interface 'generic' must have an explicit interface + external implicit + call generic(1) +end diff --git a/flang/test/Semantics/resolve15.f90 b/flang/test/Semantics/resolve15.f90 index 3a2f3d7..29fcf6f 100644 --- a/flang/test/Semantics/resolve15.f90 +++ b/flang/test/Semantics/resolve15.f90 @@ -2,13 +2,13 @@ module m real :: var interface i - !ERROR: 'var' is not a subprogram + !ERROR: 'var' is not a procedure procedure :: sub, var !ERROR: Procedure 'bad' not found procedure :: bad end interface interface operator(.foo.) - !ERROR: 'var' is not a subprogram + !ERROR: 'var' is not a procedure procedure :: var !ERROR: OPERATOR(.foo.) procedure 'sub' must be a function procedure :: sub @@ -35,3 +35,13 @@ contains logical, intent(in) :: y end end + +module m2 + interface + module subroutine specific + end subroutine + end interface + interface generic + module procedure specific + end interface +end module -- 2.7.4