Index: flang/include/flang/Semantics/symbol.h =================================================================== --- flang/include/flang/Semantics/symbol.h +++ flang/include/flang/Semantics/symbol.h @@ -698,7 +698,7 @@ Details details_; Symbol() {} // only created in class Symbols - const std::string GetDetailsName() const; + std::string GetDetailsName() const; friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const Symbol &); friend llvm::raw_ostream &DumpForUnparse( llvm::raw_ostream &, const Symbol &, bool); Index: flang/include/flang/Semantics/tools.h =================================================================== --- flang/include/flang/Semantics/tools.h +++ flang/include/flang/Semantics/tools.h @@ -53,6 +53,7 @@ const Symbol *FindSubprogram(const Symbol &); const Symbol *FindFunctionResult(const Symbol &); const Symbol *FindOverriddenBinding(const Symbol &); +const Symbol *FindGlobal(const Symbol &); const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &); const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &); Index: flang/lib/Evaluate/tools.cpp =================================================================== --- flang/lib/Evaluate/tools.cpp +++ flang/lib/Evaluate/tools.cpp @@ -1338,7 +1338,12 @@ bool IsProcedure(const Symbol &symbol) { return common::visit(common::visitors{ - [](const SubprogramDetails &) { return true; }, + [&symbol](const SubprogramDetails &) { + const Scope *scope{symbol.scope()}; + // Main programs & BLOCK DATA are not procedures. + return !scope || + scope->kind() == Scope::Kind::Subprogram; + }, [](const SubprogramNameDetails &) { return true; }, [](const ProcEntityDetails &) { return true; }, [](const GenericDetails &) { return true; }, Index: flang/lib/Semantics/check-call.h =================================================================== --- flang/lib/Semantics/check-call.h +++ flang/lib/Semantics/check-call.h @@ -30,8 +30,9 @@ // Argument treatingExternalAsImplicit should be true when the called procedure // does not actually have an explicit interface at the call site, but // its characteristics are known because it is a subroutine or function -// defined at the top level in the same source file. -void CheckArguments(const evaluate::characteristics::Procedure &, +// defined at the top level in the same source file. Returns false if +// messages were created, true if all is well. +bool CheckArguments(const evaluate::characteristics::Procedure &, evaluate::ActualArguments &, evaluate::FoldingContext &, const Scope &, bool treatingExternalAsImplicit, const evaluate::SpecificIntrinsic *intrinsic); Index: flang/lib/Semantics/check-call.cpp =================================================================== --- flang/lib/Semantics/check-call.cpp +++ flang/lib/Semantics/check-call.cpp @@ -960,7 +960,7 @@ .AnyFatalError(); } -void CheckArguments(const characteristics::Procedure &proc, +bool CheckArguments(const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, evaluate::FoldingContext &context, const Scope &scope, bool treatingExternalAsImplicit, const evaluate::SpecificIntrinsic *intrinsic) { @@ -980,21 +980,25 @@ if (auto *msgs{messages.messages()}) { msgs->Annex(std::move(buffer)); } - return; // don't pile on + return false; // don't pile on } } if (explicitInterface) { auto buffer{ CheckExplicitInterface(proc, actuals, context, scope, intrinsic)}; - if (treatingExternalAsImplicit && !buffer.empty()) { - if (auto *msg{messages.Say( - "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) { - buffer.AttachTo(*msg, parser::Severity::Because); + if (!buffer.empty()) { + if (treatingExternalAsImplicit && !buffer.empty()) { + if (auto *msg{messages.Say( + "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) { + buffer.AttachTo(*msg, parser::Severity::Because); + } } - } - if (auto *msgs{messages.messages()}) { - msgs->Annex(std::move(buffer)); + if (auto *msgs{messages.messages()}) { + msgs->Annex(std::move(buffer)); + } + return false; } } + return true; } } // namespace Fortran::semantics Index: flang/lib/Semantics/check-declarations.cpp =================================================================== --- flang/lib/Semantics/check-declarations.cpp +++ flang/lib/Semantics/check-declarations.cpp @@ -65,6 +65,7 @@ void CheckArraySpec(const Symbol &, const ArraySpec &); void CheckProcEntity(const Symbol &, const ProcEntityDetails &); void CheckSubprogram(const Symbol &, const SubprogramDetails &); + void CheckLocalVsGlobal(const Symbol &); void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &); void CheckDerivedType(const Symbol &, const DerivedTypeDetails &); bool CheckFinal( @@ -103,12 +104,12 @@ return subp && subp->isInterface(); } template - void SayWithDeclaration(const Symbol &symbol, A &&...x) { - if (parser::Message * msg{messages_.Say(std::forward(x)...)}) { - if (messages_.at().begin() != symbol.name().begin()) { - evaluate::AttachDeclaration(*msg, symbol); - } + parser::Message *SayWithDeclaration(const Symbol &symbol, A &&...x) { + parser::Message *msg{messages_.Say(std::forward(x)...)}; + if (msg && messages_.at().begin() != symbol.name().begin()) { + evaluate::AttachDeclaration(*msg, symbol); } + return msg; } bool IsResultOkToDiffer(const FunctionResult &); void CheckBindC(const Symbol &); @@ -867,6 +868,7 @@ "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US, symbol.name()); } + CheckLocalVsGlobal(symbol); } // When a module subprogram has the MODULE prefix the following must match @@ -980,10 +982,56 @@ } } } - if (details.isInterface() && !details.isDummy() && details.isFunction() && - IsAssumedLengthCharacter(details.result())) { // C721 - messages_.Say(details.result().name(), - "A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US); + if (details.isInterface()) { + if (!details.isDummy() && details.isFunction() && + IsAssumedLengthCharacter(details.result())) { // C721 + messages_.Say(details.result().name(), + "A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US); + } + } + CheckLocalVsGlobal(symbol); +} + +void CheckHelper::CheckLocalVsGlobal(const Symbol &symbol) { + if (IsProcedure(symbol) && IsExternal(symbol)) { + if (const Symbol *global{FindGlobal(symbol)}; global && global != &symbol) { + std::string interfaceName{symbol.name().ToString()}; + if (const auto *bind{symbol.GetBindName()}) { + interfaceName = *bind; + } + std::string definitionName{global->name().ToString()}; + if (const auto *bind{global->GetBindName()}) { + definitionName = *bind; + } + if (interfaceName == definitionName) { + parser::Message *msg{nullptr}; + if (!IsProcedure(*global)) { + if (symbol.flags().test(Symbol::Flag::Function) || + symbol.flags().test(Symbol::Flag::Subroutine)) { + msg = messages_.Say( + "The global entity '%s' corresponding to the local procedure '%s' is not a callable subprogram"_err_en_US, + global->name(), symbol.name()); + } + } else if (auto chars{Characterize(symbol)}) { + if (auto globalChars{Characterize(*global)}) { + if (chars->HasExplicitInterface()) { + std::string whyNot; + if (!chars->IsCompatibleWith(*globalChars, &whyNot)) { + msg = messages_.Say( + "The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US, + global->name(), whyNot); + } + } else if (!globalChars->CanBeCalledViaImplicitInterface()) { + msg = messages_.Say( + "The global subprogram '%s' may not be referenced via the implicit interface '%s'"_err_en_US, + global->name(), symbol.name()); + } + } + } + evaluate::AttachDeclaration(msg, *global); + evaluate::AttachDeclaration(msg, symbol); + } + } } } Index: flang/lib/Semantics/expression.cpp =================================================================== --- flang/lib/Semantics/expression.cpp +++ flang/lib/Semantics/expression.cpp @@ -2670,21 +2670,22 @@ std::optional ExpressionAnalyzer::CheckCall( parser::CharBlock callSite, const ProcedureDesignator &proc, ActualArguments &arguments) { + bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)}; + const Symbol *procSymbol{proc.GetSymbol()}; auto chars{characteristics::Procedure::Characterize( proc, context_.foldingContext())}; + bool ok{true}; if (chars) { - bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)}; if (treatExternalAsImplicit && !chars->CanBeCalledViaImplicitInterface()) { Say(callSite, "References to the procedure '%s' require an explicit interface"_err_en_US, - DEREF(proc.GetSymbol()).name()); + DEREF(procSymbol).name()); } // Checks for ASSOCIATED() are done in intrinsic table processing const SpecificIntrinsic *specificIntrinsic{proc.GetSpecificIntrinsic()}; bool procIsAssociated{ specificIntrinsic && specificIntrinsic->name == "associated"}; if (!procIsAssociated) { - const Symbol *procSymbol{proc.GetSymbol()}; bool procIsDummy{procSymbol && IsDummy(*procSymbol)}; if (chars->functionResult && chars->functionResult->IsAssumedLengthCharacter() && @@ -2692,7 +2693,7 @@ Say(callSite, "Assumed-length character function must be defined with a length to be called"_err_en_US); } - semantics::CheckArguments(*chars, arguments, GetFoldingContext(), + ok &= semantics::CheckArguments(*chars, arguments, GetFoldingContext(), context_.FindScope(callSite), treatExternalAsImplicit, specificIntrinsic); if (procSymbol && !IsPureProcedure(*procSymbol)) { @@ -2706,6 +2707,19 @@ } } } + if (ok && !treatExternalAsImplicit && procSymbol && + !(chars && chars->HasExplicitInterface())) { + if (const Symbol *global{FindGlobal(*procSymbol)}; + global && global != procSymbol && IsProcedure(*global)) { + // Check a known global definition behind a local interface + if (auto globalChars{characteristics::Procedure::Characterize( + *global, context_.foldingContext())}) { + semantics::CheckArguments(*globalChars, arguments, GetFoldingContext(), + context_.FindScope(callSite), true, + nullptr /*not specific intrinsic*/); + } + } + } return chars; } Index: flang/lib/Semantics/symbol.cpp =================================================================== --- flang/lib/Semantics/symbol.cpp +++ flang/lib/Semantics/symbol.cpp @@ -253,9 +253,7 @@ details); } -const std::string Symbol::GetDetailsName() const { - return DetailsToString(details_); -} +std::string Symbol::GetDetailsName() const { return DetailsToString(details_); } void Symbol::set_details(Details &&details) { CHECK(CanReplaceDetails(details)); Index: flang/lib/Semantics/tools.cpp =================================================================== --- flang/lib/Semantics/tools.cpp +++ flang/lib/Semantics/tools.cpp @@ -520,6 +520,36 @@ return nullptr; } +const Symbol *FindGlobal(const Symbol &original) { + const Symbol &ultimate{original.GetUltimate()}; + if (ultimate.owner().IsGlobal()) { + return &ultimate; + } + bool isLocal{false}; + if (IsDummy(ultimate)) { + } else if (IsPointer(ultimate)) { + } else if (ultimate.has()) { + isLocal = IsExternal(ultimate); + } else if (const auto *subp{ultimate.detailsIf()}) { + isLocal = subp->isInterface(); + } + if (isLocal) { + const std::string *bind{ultimate.GetBindName()}; + if (!bind || ultimate.name() == *bind) { + const Scope &globalScope{ultimate.owner().context().globalScope()}; + if (auto iter{globalScope.find(ultimate.name())}; + iter != globalScope.end()) { + const Symbol &global{*iter->second}; + const std::string *globalBind{global.GetBindName()}; + if (!globalBind || global.name() == *globalBind) { + return &global; + } + } + } + } + return nullptr; +} + const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &derived) { return FindParentTypeSpec(derived.typeSymbol()); } Index: flang/test/Semantics/global01.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/global01.f90 @@ -0,0 +1,45 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror +! Catch discrepancies between a local interface and a global definition + +subroutine global1(x) + integer, intent(in) :: x +end subroutine + +subroutine global2(x) bind(c,name="xyz") + integer, intent(in) :: x +end subroutine + +subroutine global3(x) + integer, intent(in) :: x +end subroutine + +pure subroutine global4(x) + integer, intent(in) :: x +end subroutine + +subroutine global5(x) + integer, intent(in) :: x +end subroutine + +program test + interface + !WARNING: The global subprogram 'global1' is not compatible with its local procedure declaration (incompatible dummy argument #1: incompatible dummy data object types: REAL(4) vs INTEGER(4)) + subroutine global1(x) + real, intent(in) :: x + end subroutine + subroutine global2(x) + real, intent(in) :: x + end subroutine + subroutine global3(x) bind(c,name="abc") + real, intent(in) :: x + end subroutine + subroutine global4(x) ! not PURE, but that's ok + integer, intent(in) :: x + end subroutine + !WARNING: The global subprogram 'global5' is not compatible with its local procedure declaration (incompatible procedure attributes: Pure) + pure subroutine global5(x) + integer, intent(in) :: x + end subroutine + end interface +end + Index: flang/test/Semantics/local-vs-global.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/local-vs-global.f90 @@ -0,0 +1,164 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 + +module module_before_1 +end + +module module_before_2 +end + +block data block_data_before_1 +end + +block data block_data_before_2 +end + +subroutine explicit_before_1(a) + real, optional :: a +end + +subroutine explicit_before_2(a) + real, optional :: a +end + +subroutine implicit_before_1(a) + real :: a +end + +subroutine implicit_before_2(a) + real :: a +end + +function explicit_func_before_1(a) + real, optional :: a +end + +function explicit_func_before_2(a) + real, optional :: a +end + +function implicit_func_before_1(a) + real :: a +end + +function implicit_func_before_2(a) + real :: a +end + +program test + external justfine ! OK to name a BLOCK DATA if not called + !ERROR: The global entity 'module_before_1' corresponding to the local procedure 'module_before_1' is not a callable subprogram + external module_before_1 + !ERROR: The global entity 'block_data_before_1' corresponding to the local procedure 'block_data_before_1' is not a callable subprogram + external block_data_before_1 + !ERROR: The global subprogram 'explicit_before_1' may not be referenced via the implicit interface 'explicit_before_1' + external explicit_before_1 + external implicit_before_1 + !ERROR: The global subprogram 'explicit_func_before_1' may not be referenced via the implicit interface 'explicit_func_before_1' + external explicit_func_before_1 + external implicit_func_before_1 + !ERROR: The global entity 'module_after_1' corresponding to the local procedure 'module_after_1' is not a callable subprogram + external module_after_1 + !ERROR: The global entity 'block_data_after_1' corresponding to the local procedure 'block_data_after_1' is not a callable subprogram + external block_data_after_1 + !ERROR: The global subprogram 'explicit_after_1' may not be referenced via the implicit interface 'explicit_after_1' + external explicit_after_1 + external implicit_after_1 + !ERROR: The global subprogram 'explicit_func_after_1' may not be referenced via the implicit interface 'explicit_func_after_1' + external explicit_func_after_1 + external implicit_func_after_1 + call module_before_1 + !ERROR: 'module_before_2' is not a callable procedure + call module_before_2 + call block_data_before_1 + !ERROR: 'block_data_before_2' is not a callable procedure + call block_data_before_2 + call explicit_before_1(1.) + !ERROR: References to the procedure 'explicit_before_2' require an explicit interface + call explicit_before_2(1.) + !WARNING: If the procedure's interface were explicit, this reference would be in error + !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference + call implicit_before_1 + !WARNING: If the procedure's interface were explicit, this reference would be in error + !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference + call implicit_before_2 + print *, explicit_func_before_1(1.) + !ERROR: References to the procedure 'explicit_func_before_2' require an explicit interface + print *, explicit_func_before_2(1.) + !WARNING: If the procedure's interface were explicit, this reference would be in error + !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference + print *, implicit_func_before_1() + !WARNING: If the procedure's interface were explicit, this reference would be in error + !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference + print *, implicit_func_before_2() + call module_after_1 + call module_after_2 + call block_data_after_1 + call block_data_after_2 + call explicit_after_1(1.) + !ERROR: References to the procedure 'explicit_after_2' require an explicit interface + call explicit_after_2(1.) + !WARNING: If the procedure's interface were explicit, this reference would be in error + !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference + call implicit_after_1 + !WARNING: If the procedure's interface were explicit, this reference would be in error + !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference + call implicit_after_2 + print *, explicit_func_after_1(1.) + !ERROR: References to the procedure 'explicit_func_after_2' require an explicit interface + print *, explicit_func_after_2(1.) + !WARNING: If the procedure's interface were explicit, this reference would be in error + !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference + print *, implicit_func_after_1() + !WARNING: If the procedure's interface were explicit, this reference would be in error + !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference + print *, implicit_func_after_2() +end program + +block data justfine +end + +module module_after_1 +end + +!ERROR: 'module_after_2' is already declared in this scoping unit +module module_after_2 +end + +block data block_data_after_1 +end + +!ERROR: BLOCK DATA 'block_data_after_2' has been called +block data block_data_after_2 +end + +subroutine explicit_after_1(a) + real, optional :: a +end + +subroutine explicit_after_2(a) + real, optional :: a +end + +subroutine implicit_after_1(a) + real :: a +end + +subroutine implicit_after_2(a) + real :: a +end + +function explicit_func_after_1(a) + real, optional :: a +end + +function explicit_func_after_2(a) + real, optional :: a +end + +function implicit_func_after_1(a) + real :: a +end + +function implicit_func_after_2(a) + real :: a +end Index: flang/test/Semantics/procinterface01.f90 =================================================================== --- flang/test/Semantics/procinterface01.f90 +++ flang/test/Semantics/procinterface01.f90 @@ -130,9 +130,9 @@ end function nested5 end module module1 -!DEF: /explicit1 ELEMENTAL (Function) Subprogram REAL(4) +!DEF: /explicit1 (Function) Subprogram REAL(4) !DEF: /explicit1/x INTENT(IN) ObjectEntity REAL(4) -real elemental function explicit1(x) +real function explicit1(x) !REF: /explicit1/x real, intent(in) :: x !DEF: /explicit1/explicit1 ObjectEntity REAL(4) @@ -150,14 +150,13 @@ logical = x+3. end function logical -!DEF: /tan (Function) Subprogram REAL(4) +!DEF: /tan (Function) Subprogram CHARACTER(1_8,1) !DEF: /tan/x INTENT(IN) ObjectEntity REAL(4) -real function tan(x) +character*1 function tan(x) !REF: /tan/x real, intent(in) :: x - !DEF: /tan/tan ObjectEntity REAL(4) - !REF: /tan/x - tan = x+5. + !DEF: /tan/tan ObjectEntity CHARACTER(1_8,1) + tan = "?" end function tan !DEF: /main MainProgram Index: flang/test/Semantics/resolve102.f90 =================================================================== --- flang/test/Semantics/resolve102.f90 +++ flang/test/Semantics/resolve102.f90 @@ -30,6 +30,7 @@ !ERROR: Procedure 'p' is recursively defined. Procedures in the cycle: 'p', 'sub', 'p2' procedure(sub) :: p interface + !ERROR: Procedure 'sub' is recursively defined. Procedures in the cycle: 'p', 'sub', 'p2' subroutine sub(p2) import p procedure(p) :: p2 Index: flang/test/Semantics/resolve53.f90 =================================================================== --- flang/test/Semantics/resolve53.f90 +++ flang/test/Semantics/resolve53.f90 @@ -97,7 +97,6 @@ end subroutine end interface end - ! Two procedures that differ only by attributes are not distinguishable module m8 @@ -468,7 +467,7 @@ end interface end module -subroutine s1() +subroutine subr1() use m20 interface operator(.not.) !ERROR: Procedure 'f' from module 'm20' is already specified in generic 'OPERATOR(.NOT.)' @@ -478,7 +477,7 @@ !ERROR: Procedure 'f' from module 'm20' is already specified in generic 'OPERATOR(+)' procedure f end interface -end subroutine s1 +end subroutine subr1 ! Extensions for distinguishable allocatable arguments; these should not ! elicit errors from f18 Index: flang/test/Semantics/resolve62.f90 =================================================================== --- flang/test/Semantics/resolve62.f90 +++ flang/test/Semantics/resolve62.f90 @@ -1,6 +1,6 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 ! Resolve generic based on number of arguments -subroutine s1 +subroutine subr1 interface f real function f1(x) optional :: x @@ -15,7 +15,7 @@ end ! Elemental and non-element function both match: non-elemental one should be used -subroutine s2 +subroutine subr2 interface f logical elemental function f1(x) intent(in) :: x @@ -53,10 +53,10 @@ real, protected :: x real :: y interface s - pure subroutine s1(x) + pure subroutine s101(x) real, intent(out) :: x end - subroutine s2(x, y) + subroutine s102(x, y) real :: x, y end end interface