[flang] Catch impossible but necessary TBP override

flang/include/flang/Semantics/tools.h

@@ -53,7 +53,8 @@ const Symbol *FindPointerComponent(const Symbol &);
 const Symbol *FindInterface(const Symbol &);
 const Symbol *FindSubprogram(const Symbol &);
 const Symbol *FindFunctionResult(const Symbol &);
-const Symbol *FindOverriddenBinding(const Symbol &);
+const Symbol *FindOverriddenBinding(
+    const Symbol &, bool &isInaccessibleDeferred);
 const Symbol *FindGlobal(const Symbol &);
 
 const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &);

flang/lib/Semantics/check-declarations.cpp

@@ -2346,7 +2346,14 @@ void CheckHelper::CheckProcBinding(
         "Intrinsic procedure '%s' is not a specific intrinsic permitted for use in the definition of binding '%s'"_err_en_US,
         binding.symbol().name(), symbol.name());
   }
-  if (const Symbol *overridden{FindOverriddenBinding(symbol)}) {
+  bool isInaccessibleDeferred{false};
+  if (const Symbol *
+      overridden{FindOverriddenBinding(symbol, isInaccessibleDeferred)}) {
+    if (isInaccessibleDeferred) {
+      SayWithDeclaration(*overridden,
+          "Override of PRIVATE DEFERRED '%s' must appear in its module"_err_en_US,
+          symbol.name());
+    }
     if (overridden->attrs().test(Attr::NON_OVERRIDABLE)) {
       SayWithDeclaration(*overridden,
           "Override of NON_OVERRIDABLE '%s' is not permitted"_err_en_US,

flang/lib/Semantics/tools.cpp

@@ -516,7 +516,9 @@ const Symbol *FindSubprogram(const Symbol &symbol) {
       symbol.details());
 }
 
-const Symbol *FindOverriddenBinding(const Symbol &symbol) {
+const Symbol *FindOverriddenBinding(
+    const Symbol &symbol, bool &isInaccessibleDeferred) {
+  isInaccessibleDeferred = false;
   if (symbol.has<ProcBindingDetails>()) {
     if (const DeclTypeSpec * parentType{FindParentTypeSpec(symbol.owner())}) {
       if (const DerivedTypeSpec * parentDerived{parentType->AsDerived()}) {
@@ -525,8 +527,11 @@ const Symbol *FindOverriddenBinding(const Symbol &symbol) {
               overridden{parentScope->FindComponent(symbol.name())}) {
             // 7.5.7.3 p1: only accessible bindings are overridden
             if (!overridden->attrs().test(Attr::PRIVATE) ||
-                (FindModuleContaining(overridden->owner()) ==
-                    FindModuleContaining(symbol.owner()))) {
+                FindModuleContaining(overridden->owner()) ==
+                    FindModuleContaining(symbol.owner())) {
+              return overridden;
+            } else if (overridden->attrs().test(Attr::DEFERRED)) {
+              isInaccessibleDeferred = true;
               return overridden;
             }
           }

flang/test/Semantics/deferred01.f90

@@ -0,0 +1,28 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Deferred TBPs must be overridden, but when they are private, those
+! overrides must appear in the same module.
+module m1
+  type, abstract :: absBase
+   contains
+    procedure(deferredInterface), deferred, private :: deferredTbp
+  end type
+  abstract interface
+    subroutine deferredInterface(x)
+      import absBase
+      class(absBase), intent(in) :: x
+    end
+  end interface
+end
+
+module m2
+  use m1
+  type, extends(absBase) :: ext
+   contains
+    !ERROR: Override of PRIVATE DEFERRED 'deferredtbp' must appear in its module
+    procedure :: deferredTbp => implTbp
+  end type
+ contains
+  subroutine implTbp(x)
+    class(ext), intent(in) :: x
+  end
+end