[flang] Warn about inconsistent external procedure interfaces

[klausler]

Summary

When multiple scopes in a compilation define interfaces (explicit
or implicit) for an external procedure, warn when those interfaces
are inconsistent.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Semantics/check-declarations.cpp

private:
   void CheckPassArg(
       const Symbol &proc, const Symbol *interface, const WithPassArg &);
   void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
   void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &);
   void CheckPointerInitialization(const Symbol &);
   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(
       const Symbol &subroutine, SourceName, const Symbol &derivedType);
   bool CheckDistinguishableFinals(const Symbol &f1, SourceName f1name,
       const Symbol &f2, SourceName f2name, const Symbol &derivedType);
   void CheckGeneric(const Symbol &, const GenericDetails &);
   void CheckHostAssoc(const Symbol &, const HostAssocDetails &);
private:
   // Cache of calls to Procedure::Characterize(Symbol)
   std::map<SymbolRef, std::optional<Procedure>, SymbolAddressCompare>
       characterizeCache_;
   // Collection of module procedure symbols with non-BIND(C)
   // global names, qualified by their module.
   std::map<std::pair<SourceName, const Symbol *>, SymbolRef> moduleProcs_;
   // Collection of symbols with global names, BIND(C) or otherwise
   std::map<std::string, SymbolRef> globalNames_;
+  // Collection of external procedures without global definitions
+  std::map<std::string, SymbolRef> externalNames_;
 };
 
 class DistinguishabilityHelper {
 public:
   DistinguishabilityHelper(SemanticsContext &context) : context_{context} {}
   void Add(const Symbol &, GenericKind, const Symbol &, const Procedure &);
   void Check(const Scope &);
 
if (const Symbol * interface{details.procInterface()}) {
             symbol.name()); // C1517
       }
     }
   } else if (IsSave(symbol)) {
     messages_.Say(
         "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
 // with the corresponding separate module procedure interface body:
 // - C1549: characteristics and dummy argument names
 // - C1550: binding label
 // - C1551: NON_RECURSIVE prefix
 class SubprogramMatchHelper {
void CheckHelper::CheckSubprogram(
   }
   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);
+  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;
-      }
+    if (const Symbol * global{FindGlobal(symbol)};
+        global && global != &symbol) {
       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) ||
if (const Symbol * global{FindGlobal(symbol)};
         if (msg) {
           if (msg->IsFatal()) {
             context_.SetError(symbol);
           }
           evaluate::AttachDeclaration(msg, *global);
           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);
     }
   }
 }
 
 void CheckHelper::CheckDerivedType(
     const Symbol &derivedType, const DerivedTypeDetails &details) {
   if (details.isForwardReferenced() && !context_.HasError(derivedType)) {
     messages_.Say("The derived type '%s' has not been defined"_err_en_US,

flang/test/Semantics/null-init.f90

 module m6
   !ERROR: Symbol 'null' cannot have both INTRINSIC and EXTERNAL attributes
   integer, pointer :: p => null()
   external :: null
 end module
 
 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
   end interface
   !ERROR: Pointer initializer must be intrinsic NULL()
   integer, pointer :: p => null()
 end module
 

flang/test/Semantics/resolve24.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 subroutine test1
   !ERROR: Generic interface 'foo' has both a function and a subroutine
   interface foo
     subroutine s1(x)
     end subroutine
     subroutine s2(x, y)
     end subroutine
     function f()
     end function
   end interface
 end subroutine
 
 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
 
 module test3
   !ERROR: Generic interface 'foo' has both a function and a subroutine
   interface foo
     module procedure s
subroutine test4
   interface foo
     subroutine s()
     end subroutine
   end interface
 end subroutine
 
 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
   call foo()
   !ERROR: Cannot call subroutine 'bar' like a function
   x = bar()
 end subroutine

flang/test/Semantics/resolve53.f90

contains
   subroutine s3
   end
   subroutine s4(x)
     integer x
   end
 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
 
 module m4
   type :: t1
   end type
   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
   end interface
 end
 
 ! 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
 end
 
 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
 end
 
 ! 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
 end
 
 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
 end
 
 module m12
   !ERROR: Generic 'g1' may not have specific procedures 's1' and 's2' as their interfaces are not distinguishable
   generic :: g1 => s1, s2  ! rank-1 and assumed-rank
contains
   end
   integer function f3(i, j)
     integer, intent(in) :: i, j
   end
 end
 
 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
 
 ! Extensions for distinguishable allocatable arguments; these should not
 ! elicit errors from f18
 module m21
   type :: t
   end type

flang/test/Semantics/resolve62.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! 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)
   z = f(1.0, 2.0)
   !ERROR: No specific function of generic 'f' matches the actual arguments
   z = f(1.0, 2.0, 3.0)
 end
 
 ! 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
   real :: x, y(10), z
   logical :: a
   a = f(1.0)
   !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types LOGICAL(4) and REAL(4)
   a = f(y)

flang/test/Semantics/resolve67.f90

complex function add(x, y)
       integer, value :: y
     end
     !ERROR: OPERATOR(+) function 'plus' conflicts with intrinsic operator
     real function plus(x)
       complex, intent(in) :: x
     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
     !ERROR: OPERATOR(.NOT.) function 'not2' conflicts with intrinsic operator
     logical(8) function not2(x)
       logical(8), value :: x
     end
   end interface