[flang-commits] [flang] 3b7b7fa - [flang] Accept a separate module procedure interface as a specific procedure
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Fri Sep 23 11:31:40 PDT 2022
Author: Peter Klausler
Date: 2022-09-23T11:18:01-07:00
New Revision: 3b7b7fa7138c58e878567f6fed8f954f0e4e00a0
URL: https://github.com/llvm/llvm-project/commit/3b7b7fa7138c58e878567f6fed8f954f0e4e00a0
DIFF: https://github.com/llvm/llvm-project/commit/3b7b7fa7138c58e878567f6fed8f954f0e4e00a0.diff
LOG: [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
Added:
flang/test/Semantics/generic02.f90
Modified:
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/tools.cpp
flang/test/Semantics/resolve15.f90
Removed:
################################################################################
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 00636c052bfb..1f2af55cbdd2 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 935c99401b3b..1326baeb6a35 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 f4430d97a000..3f56a257c75f 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<SubprogramDetails>() &&
- !ultimate.has<SubprogramNameDetails>()) {
- 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<SubprogramNameDetails>()}) {
- 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<SubprogramDetails>()};
- 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 6f91024e3b52..f57548016f93 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<SubprogramNameDetails>()}) {
+ 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<SubprogramDetails>()}) {
if (subpDetails->stmtFunction()) {
diff --git a/flang/test/Semantics/generic02.f90 b/flang/test/Semantics/generic02.f90
new file mode 100644
index 000000000000..e4f7fe671aae
--- /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 3a2f3d78b569..29fcf6f7ee15 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 @@ subroutine sub(x, y)
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
More information about the flang-commits
mailing list