[flang] Stricter interface compatibility checking for TBP overrides

The compiler currently ignores attributes for PASS dummy arguments that
are incompatible between a type-bound procedure in an extended type and
the binding of the same name that it overrides in an ancestor type,
if any.  Strengthen this checking so that discrepancies between attributes
and intents are caught, and add some tests.

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

3 files changed, 64 insertions, 4 deletions

diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 8c9002f3ca1d..bed45fa0e570 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -1089,8 +1089,11 @@ bool Procedure::CanOverride(
     return false;
   }
   for (int j{0}; j < argCount; ++j) {
-    if ((!passIndex || j != *passIndex) &&
-        dummyArguments[j] != that.dummyArguments[j]) {
+    if (passIndex && j == *passIndex) {
+      if (!that.dummyArguments[j].IsCompatibleWith(dummyArguments[j])) {
+        return false;
+      }
+    } else if (dummyArguments[j] != that.dummyArguments[j]) {
       return false;
     }
   }
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index bfb90e2f8fa3..fc93022af209 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -1918,7 +1918,7 @@ void CheckHelper::CheckProcBinding(
           if (isNopass) {
             if (!bindingChars->CanOverride(*overriddenChars, std::nullopt)) {
               SayWithDeclaration(*overridden,
-                  "A type-bound procedure and its override must have compatible interfaces"_err_en_US);
+                  "A NOPASS type-bound procedure and its override must have identical interfaces"_err_en_US);
             }
           } else if (!context_.HasError(binding.symbol())) {
             int passIndex{bindingChars->FindPassIndex(binding.passName())};
@@ -1930,7 +1930,7 @@ void CheckHelper::CheckProcBinding(
             } else if (!bindingChars->CanOverride(
                            *overriddenChars, passIndex)) {
               SayWithDeclaration(*overridden,
-                  "A type-bound procedure and its override must have compatible interfaces apart from their passed argument"_err_en_US);
+                  "A type-bound procedure and its override must have compatible interfaces"_err_en_US);
             }
           }
         }
diff --git a/flang/test/Semantics/bindings04.f90 b/flang/test/Semantics/bindings04.f90
new file mode 100644
index 000000000000..02902719a290
--- /dev/null
+++ b/flang/test/Semantics/bindings04.f90
@@ -0,0 +1,57 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m1
+  type t1
+   contains
+    procedure :: tbp => s1
+  end type
+  type, extends(t1) :: t1e
+   contains
+    !ERROR: A type-bound procedure and its override must have compatible interfaces
+    procedure :: tbp => s1e
+  end type
+ contains
+  subroutine s1(x)
+    class(t1) :: x
+  end
+  subroutine s1e(x)
+    class(t1e), intent(in out) :: x
+  end
+end
+
+module m2
+  type t1
+   contains
+    procedure :: tbp => s1
+  end type
+  type, extends(t1) :: t1e
+   contains
+    !ERROR: A type-bound procedure and its override must have compatible interfaces
+    procedure :: tbp => s1e
+  end type
+ contains
+  subroutine s1(x)
+    class(t1), intent(in out) :: x
+  end
+  subroutine s1e(x)
+    class(t1e) :: x
+  end
+end
+
+module m3
+  type t1
+   contains
+    procedure, nopass :: tbp => s1
+  end type
+  type, extends(t1) :: t1e
+   contains
+   !ERROR: A NOPASS type-bound procedure and its override must have identical interfaces
+    procedure, nopass :: tbp => s1e
+  end type
+ contains
+  subroutine s1(x)
+    real, intent(in out) :: x
+  end
+  subroutine s1e(x)
+    real :: x
+  end
+end