[flang-commits] [PATCH] D145104: [flang] A TBP override may not make a public binding private

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: PeteSteinfeld.
klausler added a project: Flang.
Herald added subscribers: sunshaoce, jdoerfert.
Herald added a project: All.
klausler requested review of this revision.

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.


https://reviews.llvm.org/D145104

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


Index: flang/test/Semantics/bindings01.f90
===================================================================
--- flang/test/Semantics/bindings01.f90
+++ flang/test/Semantics/bindings01.f90
@@ -233,6 +233,48 @@
   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
Index: flang/lib/Semantics/check-declarations.cpp
===================================================================
--- flang/lib/Semantics/check-declarations.cpp
+++ flang/lib/Semantics/check-declarations.cpp
@@ -1901,10 +1901,20 @@
           }
         }
       }
-      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,


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D145104.501621.patch
Type: text/x-patch
Size: 2413 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20230301/ca63cc1b/attachment-0001.bin>