[flang-commits] [flang] a3c6a7d - [flang] Stricter interface compatibility checking for TBP overrides

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2023-03-02T10:20:33-08:00
New Revision: a3c6a7d53d21e09a45171c47456a33d89bc47738

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

LOG: [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

Added: 
    flang/test/Semantics/bindings04.f90

Modified: 
    flang/lib/Evaluate/characteristics.cpp
    flang/lib/Semantics/check-declarations.cpp

Removed: 
    


################################################################################
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