[flang] Emit error when DEFERRED binding overrides non-DEFERRED (#139325)

Fixes https://github.com/llvm/llvm-project/issues/138915.

3 files changed, 32 insertions, 13 deletions

diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index d39e4c4..7ce009c 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1196,16 +1196,6 @@ parser::Message *AttachDeclaration(
       const auto *assoc{unhosted->detailsIf<semantics::HostAssocDetails>()}) {
     unhosted = &assoc->symbol();
   }
-  if (const auto *binding{
-          unhosted->detailsIf<semantics::ProcBindingDetails>()}) {
-    if (binding->symbol().name() != symbol.name()) {
-      message.Attach(binding->symbol().name(),
-          "Procedure '%s' of type '%s' is bound to '%s'"_en_US, symbol.name(),
-          symbol.owner().GetName().value(), binding->symbol().name());
-      return &message;
-    }
-    unhosted = &binding->symbol();
-  }
   if (const auto *use{symbol.detailsIf<semantics::UseDetails>()}) {
     message.Attach(use->location(),
         "'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(),
@@ -1214,6 +1204,14 @@ parser::Message *AttachDeclaration(
     message.Attach(
         unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name());
   }
+  if (const auto *binding{
+          unhosted->detailsIf<semantics::ProcBindingDetails>()}) {
+    if (binding->symbol().name() != symbol.name()) {
+      message.Attach(binding->symbol().name(),
+          "Procedure '%s' of type '%s' is bound to '%s'"_en_US, symbol.name(),
+          symbol.owner().GetName().value(), binding->symbol().name());
+    }
+  }
   return &message;
 }
 
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 3180855..9425844 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -2555,6 +2555,9 @@ void CheckHelper::CheckProcBinding(
     const Symbol &symbol, const ProcBindingDetails &binding) {
   const Scope &dtScope{symbol.owner()};
   CHECK(dtScope.kind() == Scope::Kind::DerivedType);
+  bool isInaccessibleDeferred{false};
+  const Symbol *overridden{
+      FindOverriddenBinding(symbol, isInaccessibleDeferred)};
   if (symbol.attrs().test(Attr::DEFERRED)) {
     if (const Symbol *dtSymbol{dtScope.symbol()}) {
       if (!dtSymbol->attrs().test(Attr::ABSTRACT)) { // C733
@@ -2568,6 +2571,11 @@ void CheckHelper::CheckProcBinding(
           "Type-bound procedure '%s' may not be both DEFERRED and NON_OVERRIDABLE"_err_en_US,
           symbol.name());
     }
+    if (overridden && !overridden->attrs().test(Attr::DEFERRED)) {
+      SayWithDeclaration(*overridden,
+          "Override of non-DEFERRED '%s' must not be DEFERRED"_err_en_US,
+          symbol.name());
+    }
   }
   if (binding.symbol().attrs().test(Attr::INTRINSIC) &&
       !context_.intrinsics().IsSpecificIntrinsicFunction(
@@ -2576,9 +2584,7 @@ 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());
   }
-  bool isInaccessibleDeferred{false};
-  if (const Symbol *
-      overridden{FindOverriddenBinding(symbol, isInaccessibleDeferred)}) {
+  if (overridden) {
     if (isInaccessibleDeferred) {
       SayWithDeclaration(*overridden,
           "Override of PRIVATE DEFERRED '%s' must appear in its module"_err_en_US,
diff --git a/flang/test/Semantics/bug138915.f90 b/flang/test/Semantics/bug138915.f90
new file mode 100644
index 0000000..786a4ac
--- /dev/null
+++ b/flang/test/Semantics/bug138915.f90
@@ -0,0 +1,15 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  type base
+   contains
+     procedure, nopass :: tbp
+  end type
+  type, extends(base), abstract :: child
+   contains
+     !ERROR: Override of non-DEFERRED 'tbp' must not be DEFERRED
+     procedure(tbp), deferred, nopass :: tbp
+  end type
+ contains
+  subroutine tbp
+  end
+end