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

[via flang-commits]

Author: Peter Klausler
Date: 2024-03-26T10:11:19-07:00
New Revision: f4fc959c35eb862776ac2e83cb9f41aa88989e3f

URL: https://github.com/llvm/llvm-project/commit/f4fc959c35eb862776ac2e83cb9f41aa88989e3f
DIFF: https://github.com/llvm/llvm-project/commit/f4fc959c35eb862776ac2e83cb9f41aa88989e3f.diff

LOG: [flang] Catch impossible but necessary TBP override (#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.

Added: 
    flang/test/Semantics/deferred01.f90

Modified: 
    flang/include/flang/Semantics/tools.h
    flang/lib/Semantics/check-declarations.cpp
    flang/lib/Semantics/tools.cpp

Removed: 
    


################################################################################
diff  --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 66774b51316cbf..f0eb82eebefa31 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 654ebb1fa335dc..df435906af68d0 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -528,7 +528,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()}) {
@@ -537,8 +539,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