diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -66,7 +66,7 @@ void CheckArraySpec(const Symbol &, const ArraySpec &); void CheckProcEntity(const Symbol &, const ProcEntityDetails &); void CheckSubprogram(const Symbol &, const SubprogramDetails &); - void CheckLocalVsGlobal(const Symbol &); + void CheckExternal(const Symbol &); void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &); void CheckDerivedType(const Symbol &, const DerivedTypeDetails &); bool CheckFinal( @@ -161,6 +161,8 @@ std::map, SymbolRef> moduleProcs_; // Collection of symbols with global names, BIND(C) or otherwise std::map globalNames_; + // Collection of external procedures without global definitions + std::map externalNames_; }; class DistinguishabilityHelper { @@ -957,7 +959,7 @@ "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US, symbol.name()); } - CheckLocalVsGlobal(symbol); + CheckExternal(symbol); } // When a module subprogram has the MODULE prefix the following must match @@ -1098,17 +1100,18 @@ "A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US); } } - CheckLocalVsGlobal(symbol); + CheckExternal(symbol); CheckModuleProcedureDef(symbol); } -void CheckHelper::CheckLocalVsGlobal(const Symbol &symbol) { +void CheckHelper::CheckExternal(const Symbol &symbol) { if (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 interfaceName{symbol.name().ToString()}; + if (const auto *bind{symbol.GetBindName()}) { + interfaceName = *bind; + } + if (const Symbol * global{FindGlobal(symbol)}; + global && global != &symbol) { std::string definitionName{global->name().ToString()}; if (const auto *bind{global->GetBindName()}) { definitionName = *bind; @@ -1146,6 +1149,24 @@ evaluate::AttachDeclaration(msg, symbol); } } + } else if (auto iter{externalNames_.find(interfaceName)}; + iter != externalNames_.end()) { + const Symbol &previous{*iter->second}; + if (auto chars{Characterize(symbol)}) { + if (auto previousChars{Characterize(previous)}) { + std::string whyNot; + if (!chars->IsCompatibleWith(*previousChars, &whyNot)) { + if (auto *msg{messages_.Say( + "The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US, + symbol.name(), whyNot)}) { + evaluate::AttachDeclaration(msg, previous); + evaluate::AttachDeclaration(msg, symbol); + } + } + } + } + } else { + externalNames_.emplace(interfaceName, symbol); } } } diff --git a/flang/test/Semantics/null-init.f90 b/flang/test/Semantics/null-init.f90 --- a/flang/test/Semantics/null-init.f90 +++ b/flang/test/Semantics/null-init.f90 @@ -37,6 +37,7 @@ module m7 interface + !WARNING: The external interface 'null' is not compatible with an earlier definition (incompatible procedure attributes: ImplicitInterface) function null() result(p) integer, pointer :: p end function diff --git a/flang/test/Semantics/resolve24.f90 b/flang/test/Semantics/resolve24.f90 --- a/flang/test/Semantics/resolve24.f90 +++ b/flang/test/Semantics/resolve24.f90 @@ -14,11 +14,11 @@ subroutine test2 !ERROR: Generic interface 'foo' has both a function and a subroutine interface foo - function f1(x) + function t2f1(x) end function subroutine s() end subroutine - function f2(x, y) + function t2f2(x, y) end function end interface end subroutine @@ -48,13 +48,13 @@ subroutine test5 interface foo - function f1() + function t5f1() end function end interface interface bar - subroutine s1() + subroutine t5s1() end subroutine - subroutine s2(x) + subroutine t5s2(x) end subroutine end interface !ERROR: Cannot call function 'foo' like a subroutine diff --git a/flang/test/Semantics/resolve53.f90 b/flang/test/Semantics/resolve53.f90 --- a/flang/test/Semantics/resolve53.f90 +++ b/flang/test/Semantics/resolve53.f90 @@ -25,22 +25,22 @@ end module m2 - !ERROR: Generic 'g' may not have specific procedures 's1' and 's2' as their interfaces are not distinguishable + !ERROR: Generic 'g' may not have specific procedures 'm2s1' and 'm2s2' as their interfaces are not distinguishable interface g - subroutine s1(x) + subroutine m2s1(x) end subroutine - subroutine s2(x) + subroutine m2s2(x) real x end subroutine end interface end module m3 - !ERROR: Generic 'g' may not have specific procedures 'f1' and 'f2' as their interfaces are not distinguishable + !ERROR: Generic 'g' may not have specific procedures 'm3f1' and 'm3f2' as their interfaces are not distinguishable interface g - integer function f1() + integer function m3f1() end function - real function f2() + real function m3f2() end function end interface end @@ -51,11 +51,11 @@ type, extends(t1) :: t2 end type interface g - subroutine s1(x) + subroutine m4s1(x) import :: t1 type(t1) :: x end - subroutine s2(x) + subroutine m4s2(x) import :: t2 type(t2) :: x end @@ -65,13 +65,13 @@ ! These are all different ranks so they are distinguishable module m5 interface g - subroutine s1(x) + subroutine m5s1(x) real x end subroutine - subroutine s2(x) + subroutine m5s2(x) real x(:) end subroutine - subroutine s3(x) + subroutine m5s3(x) real x(:,:) end subroutine end interface @@ -79,20 +79,20 @@ module m6 use m5 - !ERROR: Generic 'g' may not have specific procedures 's1' and 's4' as their interfaces are not distinguishable + !ERROR: Generic 'g' may not have specific procedures 'm5s1' and 'm6s4' as their interfaces are not distinguishable interface g - subroutine s4(x) + subroutine m6s4(x) end subroutine end interface end module m7 use m5 - !ERROR: Generic 'g' may not have specific procedures 's1' and 's5' as their interfaces are not distinguishable - !ERROR: Generic 'g' may not have specific procedures 's2' and 's5' as their interfaces are not distinguishable - !ERROR: Generic 'g' may not have specific procedures 's3' and 's5' as their interfaces are not distinguishable + !ERROR: Generic 'g' may not have specific procedures 'm5s1' and 'm7s5' as their interfaces are not distinguishable + !ERROR: Generic 'g' may not have specific procedures 'm5s2' and 'm7s5' as their interfaces are not distinguishable + !ERROR: Generic 'g' may not have specific procedures 'm5s3' and 'm7s5' as their interfaces are not distinguishable interface g - subroutine s5(x) + subroutine m7s5(x) real x(..) end subroutine end interface @@ -100,36 +100,36 @@ ! Two procedures that differ only by attributes are not distinguishable module m8 - !ERROR: Generic 'g' may not have specific procedures 's1' and 's2' as their interfaces are not distinguishable + !ERROR: Generic 'g' may not have specific procedures 'm8s1' and 'm8s2' as their interfaces are not distinguishable interface g - pure subroutine s1(x) + pure subroutine m8s1(x) real, intent(in) :: x end subroutine - subroutine s2(x) + subroutine m8s2(x) real, intent(in) :: x end subroutine end interface end module m9 - !ERROR: Generic 'g' may not have specific procedures 's1' and 's2' as their interfaces are not distinguishable + !ERROR: Generic 'g' may not have specific procedures 'm9s1' and 'm9s2' as their interfaces are not distinguishable interface g - subroutine s1(x) + subroutine m9s1(x) real :: x(10) end subroutine - subroutine s2(x) + subroutine m9s2(x) real :: x(100) end subroutine end interface end module m10 - !ERROR: Generic 'g' may not have specific procedures 's1' and 's2' as their interfaces are not distinguishable + !ERROR: Generic 'g' may not have specific procedures 'm10s1' and 'm10s2' as their interfaces are not distinguishable interface g - subroutine s1(x) + subroutine m10s1(x) real :: x(10) end subroutine - subroutine s2(x) + subroutine m10s2(x) real :: x(..) end subroutine end interface @@ -137,19 +137,19 @@ program m11 interface g1 - subroutine s1(x) + subroutine m11s1(x) real, pointer, intent(out) :: x end subroutine - subroutine s2(x) + subroutine m11s2(x) real, allocatable :: x end subroutine end interface - !ERROR: Generic 'g2' may not have specific procedures 's3' and 's4' as their interfaces are not distinguishable + !ERROR: Generic 'g2' may not have specific procedures 'm11s3' and 'm11s4' as their interfaces are not distinguishable interface g2 - subroutine s3(x) + subroutine m11s3(x) real, pointer, intent(in) :: x end subroutine - subroutine s4(x) + subroutine m11s4(x) real, allocatable :: x end subroutine end interface @@ -458,24 +458,24 @@ module m20 interface operator(.not.) - real function f(x) + real function m20f(x) character(*),intent(in) :: x end function end interface interface operator(+) - procedure f + procedure m20f end interface end module subroutine subr1() use m20 interface operator(.not.) - !ERROR: Procedure 'f' from module 'm20' is already specified in generic 'OPERATOR(.NOT.)' - procedure f + !ERROR: Procedure 'm20f' from module 'm20' is already specified in generic 'OPERATOR(.NOT.)' + procedure m20f end interface interface operator(+) - !ERROR: Procedure 'f' from module 'm20' is already specified in generic 'OPERATOR(+)' - procedure f + !ERROR: Procedure 'm20f' from module 'm20' is already specified in generic 'OPERATOR(+)' + procedure m20f end interface end subroutine subr1 diff --git a/flang/test/Semantics/resolve62.f90 b/flang/test/Semantics/resolve62.f90 --- a/flang/test/Semantics/resolve62.f90 +++ b/flang/test/Semantics/resolve62.f90 @@ -2,10 +2,10 @@ ! Resolve generic based on number of arguments subroutine subr1 interface f - real function f1(x) + real function s1f1(x) optional :: x end - real function f2(x, y) + real function s1f2(x, y) end end interface z = f(1.0) @@ -17,10 +17,10 @@ ! Elemental and non-element function both match: non-elemental one should be used subroutine subr2 interface f - logical elemental function f1(x) + logical elemental function s2f1(x) intent(in) :: x end - real function f2(x) + real function s2f2(x) real :: x(10) end end interface diff --git a/flang/test/Semantics/resolve67.f90 b/flang/test/Semantics/resolve67.f90 --- a/flang/test/Semantics/resolve67.f90 +++ b/flang/test/Semantics/resolve67.f90 @@ -89,6 +89,7 @@ end end interface interface operator(.not.) + !WARNING: The external interface 'not1' is not compatible with an earlier definition (distinct numbers of dummy arguments) real function not1(x) real, value :: x end