[flang-commits] [flang] [flang] Catch impossible but necessary TBP override (PR #86558)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/86558

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.

>From 0eec89b9ef0c76eb1ce748a4e34023a05983092d Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Mon, 25 Mar 2024 11:37:00 -0700
Subject: [PATCH] [flang] Catch impossible but necessary TBP override

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.
---
 flang/include/flang/Semantics/tools.h      |  3 ++-
 flang/lib/Semantics/check-declarations.cpp |  9 ++++++-
 flang/lib/Semantics/tools.cpp              | 11 ++++++---
 flang/test/Semantics/deferred01.f90        | 28 ++++++++++++++++++++++
 4 files changed, 46 insertions(+), 5 deletions(-)
 create mode 100644 flang/test/Semantics/deferred01.f90

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