diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -472,6 +472,7 @@ Symbol *specific() { return specific_; } const Symbol *specific() const { return specific_; } void set_specific(Symbol &specific); + void clear_specific(); Symbol *derivedType() { return derivedType_; } const Symbol *derivedType() const { return derivedType_; } void set_derivedType(Symbol &derivedType); diff --git a/flang/lib/Semantics/program-tree.cpp b/flang/lib/Semantics/program-tree.cpp --- a/flang/lib/Semantics/program-tree.cpp +++ b/flang/lib/Semantics/program-tree.cpp @@ -217,6 +217,10 @@ } bool ProgramTree::HasModulePrefix() const { + if (std::holds_alternative< + const parser::Statement *>(stmt_)) { + return true; // MODULE PROCEDURE foo + } using ListType = std::list; const auto *prefixes{common::visit( common::visitors{ diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -550,6 +550,7 @@ // Search for name in a derived type scope and its parents. Symbol *FindInTypeOrParents(const Scope &, const parser::Name &); Symbol *FindInTypeOrParents(const parser::Name &); + Symbol *FindSeparateModuleProcedureInterface(const parser::Name &); void EraseSymbol(const parser::Name &); void EraseSymbol(const Symbol &symbol) { currScope().erase(symbol.name()); } // Make a new symbol with the name and attrs of an existing one @@ -608,7 +609,7 @@ // update the existing symbol symbol->attrs() |= attrs; if constexpr (std::is_same_v) { - // Dummy argument defined by explicit interface + // Dummy argument defined by explicit interface? details.set_isDummy(IsDummy(*symbol)); } symbol->set_details(std::move(details)); @@ -3631,14 +3632,28 @@ } } -// A subprogram declared with MODULE PROCEDURE -bool SubprogramVisitor::BeginMpSubprogram(const parser::Name &name) { +Symbol *ScopeHandler::FindSeparateModuleProcedureInterface( + const parser::Name &name) { auto *symbol{FindSymbol(name)}; if (symbol && symbol->has()) { symbol = FindSymbol(currScope().parent(), name); } + if (symbol) { + if (auto *generic{symbol->detailsIf()}) { + symbol = generic->specific(); + } + } if (!IsSeparateModuleProcedureInterface(symbol)) { Say(name, "'%s' was not declared a separate module procedure"_err_en_US); + symbol = nullptr; + } + return symbol; +} + +// A subprogram declared with MODULE PROCEDURE +bool SubprogramVisitor::BeginMpSubprogram(const parser::Name &name) { + Symbol *symbol{FindSeparateModuleProcedureInterface(name)}; + if (!symbol) { return false; } if (symbol->owner() == currScope() && symbol->scope()) { @@ -3682,21 +3697,11 @@ } Symbol *moduleInterface{nullptr}; if (hasModulePrefix && !inInterfaceBlock()) { - moduleInterface = FindSymbol(currScope(), name); - if (IsSeparateModuleProcedureInterface(moduleInterface)) { + moduleInterface = FindSeparateModuleProcedureInterface(name); + if (moduleInterface && &moduleInterface->owner() == &currScope()) { // Subprogram is MODULE FUNCTION or MODULE SUBROUTINE with an interface // previously defined in the same scope. currScope().erase(moduleInterface->name()); - } else { - moduleInterface = nullptr; - } - if (!moduleInterface) { - moduleInterface = FindSymbol(currScope().parent(), name); - if (!IsSeparateModuleProcedureInterface(moduleInterface)) { - Say(name, - "'%s' was not declared a separate module procedure"_err_en_US); - return false; - } } } Symbol &newSymbol{PushSubprogramScope(name, subpFlag, bindingSpec)}; @@ -3865,9 +3870,24 @@ Symbol *SubprogramVisitor::GetSpecificFromGeneric(const parser::Name &name) { // Search for the name but don't resolve it if (auto *symbol{currScope().FindSymbol(name.source)}) { - if (auto *details{symbol->detailsIf()}) { - // found generic, want subprogram + if (symbol->has()) { + if (inInterfaceBlock()) { + // Subtle: clear any MODULE flag so that the new interface + // symbol doesn't inherit it and ruin the ability to check it. + symbol->attrs().reset(Attr::MODULE); + } + } else if (auto *details{symbol->detailsIf()}) { + // found generic, want specific procedure auto *specific{details->specific()}; + if (specific && inInterfaceBlock() && + specific->has() && + specific->attrs().test(Attr::MODULE)) { + // The shadowed procedure is a separate module procedure that is + // actually defined later in this (sub)module. + // Define its interface now as a new symbol. + details->clear_specific(); + specific = nullptr; + } if (!specific) { specific = &currScope().MakeSymbol(name.source, Attrs{}, SubprogramDetails{}); @@ -3880,8 +3900,8 @@ } else if (isGeneric()) { SayAlreadyDeclared(name, *specific); } - if (!specific->has()) { - specific->set_details(SubprogramDetails{}); + if (specific->has()) { + specific->set_details(Details{SubprogramDetails{}}); } return specific; } @@ -7565,6 +7585,9 @@ node.IsModule() ? SubprogramKind::Module : SubprogramKind::Internal}; for (auto &child : node.children()) { auto &symbol{MakeSymbol(child.name(), SubprogramNameDetails{kind, child})}; + if (child.HasModulePrefix()) { + symbol.attrs().set(Attr::MODULE); + } auto childKind{child.GetKind()}; if (childKind == ProgramTree::Kind::Function) { symbol.set(Symbol::Flag::Function); @@ -7578,6 +7601,9 @@ auto &symbol{ MakeSymbol(std::get(entryStmt->t), std::move(details))}; symbol.set(child.GetSubpFlag()); + if (child.HasModulePrefix()) { + symbol.attrs().set(Attr::MODULE); + } } } for (const auto &generic : node.genericSpecs()) { diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -174,6 +174,7 @@ CHECK(!derivedType_); specific_ = &specific; } +void GenericDetails::clear_specific() { specific_ = nullptr; } void GenericDetails::set_derivedType(Symbol &derivedType) { CHECK(!specific_); CHECK(!derivedType_); diff --git a/flang/test/Semantics/nullify02.f90 b/flang/test/Semantics/nullify02.f90 --- a/flang/test/Semantics/nullify02.f90 +++ b/flang/test/Semantics/nullify02.f90 @@ -40,10 +40,12 @@ end interface contains !ERROR: 'ptrfun' was not declared a separate module procedure + !ERROR: 'ptrfun' is already declared in this scoping unit module function ptrFun() integer, pointer :: ptrFun real :: realVar nullify(ptrFun) + !ERROR: name in NULLIFY statement must have the POINTER attribute nullify(realVar) end function end module