[flang] Catch impossible but necessary TBP override

[klausler]

An apparent attempt to override a type-bound procedure is not allowed to be interpreted as on override when the procedure is PRIVATE and the override attempt appears in another module. However, if the TBP that would have been overridden is a DEFERRED procedure in an abstract base type, the override must take place. PRIVATE DEFERRED procedures must therefore have all of their overrides appear in the same module as the abstract base type.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

An apparent attempt to override a type-bound procedure is not allowed to be interpreted as on override when the procedure is PRIVATE and the override attempt appears in another module. However, if the TBP that would have been overridden is a DEFERRED procedure in an abstract base type, the override must take place. PRIVATE DEFERRED procedures must therefore have all of their overrides appear in the same module as the abstract base type.

---

Full diff: https://github.com/llvm/llvm-project/pull/86558.diff

4 Files Affected:

• (modified) flang/include/flang/Semantics/tools.h (+2-1)
• (modified) flang/lib/Semantics/check-declarations.cpp (+8-1)
• (modified) flang/lib/Semantics/tools.cpp (+8-3)
• (added) flang/test/Semantics/deferred01.f90 (+28)

diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index dc3cd6c894a2c2..9630efbb5487a1 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/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 &);
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 581371ff7a0031..dec8fee774c5be 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/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,
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 0484baae93cd59..f5c55243b50b40 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/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;
             }
           }
diff --git a/flang/test/Semantics/deferred01.f90 b/flang/test/Semantics/deferred01.f90
new file mode 100644
index 00000000000000..87818c10bd399e
--- /dev/null
+++ b/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

[github-actions]

✅ With the latest revision this PR passed the C/C++ code formatter.

[github-actions]

✅ With the latest revision this PR passed the Python code formatter.

[clementval]

LGTM