[flang-commits] [flang] 7020180 - [flang] A TBP override may not make a public binding private

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2023-03-02T09:51:21-08:00
New Revision: 702018022649890e654acd3eb53b3b6a831fd8d0

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

LOG: [flang] A TBP override may not make a public binding private

When a procedure binding in a derived type has PRIVATE accessibility,
it may not be an override of a type-bound procedure that is accessible.

Differential Revision: https://reviews.llvm.org/D145104

Added: 
    

Modified: 
    flang/lib/Semantics/check-declarations.cpp
    flang/test/Semantics/bindings01.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index fe899466130b..d7839fd5d235 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -1935,10 +1935,20 @@ void CheckHelper::CheckProcBinding(
           }
         }
       }
-      if (symbol.attrs().test(Attr::PRIVATE) &&
-          overridden->attrs().test(Attr::PUBLIC)) {
-        SayWithDeclaration(*overridden,
-            "A PRIVATE procedure may not override a PUBLIC procedure"_err_en_US);
+      if (symbol.attrs().test(Attr::PRIVATE)) {
+        if (FindModuleContaining(dtScope) ==
+            FindModuleContaining(overridden->owner())) {
+          // types declared in same madule
+          if (overridden->attrs().test(Attr::PUBLIC)) {
+            SayWithDeclaration(*overridden,
+                "A PRIVATE procedure may not override a PUBLIC procedure"_err_en_US);
+          }
+        } else { // types declared in distinct madules
+          if (!CheckAccessibleSymbol(dtScope.parent(), *overridden)) {
+            SayWithDeclaration(*overridden,
+                "A PRIVATE procedure may not override an accessible procedure"_err_en_US);
+          }
+        }
       }
     } else {
       SayWithDeclaration(*overridden,

diff  --git a/flang/test/Semantics/bindings01.f90 b/flang/test/Semantics/bindings01.f90
index 7e8cbb032f93..12e31dfc994c 100644
--- a/flang/test/Semantics/bindings01.f90
+++ b/flang/test/Semantics/bindings01.f90
@@ -233,6 +233,48 @@ subroutine test
   end subroutine
 end module
 
+module m9
+  type t1
+   contains
+    procedure, public :: tbp => sub1
+  end type
+  type, extends(t1) :: t2
+   contains
+    !ERROR: A PRIVATE procedure may not override a PUBLIC procedure
+    procedure, private :: tbp => sub2
+  end type
+ contains
+  subroutine sub1(x)
+    class(t1), intent(in) :: x
+  end subroutine
+  subroutine sub2(x)
+    class(t2), intent(in) :: x
+  end subroutine
+end module
+
+module m10a
+  type t1
+   contains
+    procedure :: tbp => sub1
+  end type
+ contains
+  subroutine sub1(x)
+    class(t1), intent(in) :: x
+  end subroutine
+end module
+module m10b
+  use m10a
+  type, extends(t1) :: t2
+   contains
+    !ERROR: A PRIVATE procedure may not override an accessible procedure
+    procedure, private :: tbp => sub2
+  end type
+ contains
+  subroutine sub2(x)
+    class(t2), intent(in) :: x
+  end subroutine
+end module
+
 program test
   use m1
   type,extends(t) :: t2