diff options
| -rw-r--r-- | flang/lib/Evaluate/characteristics.cpp | 7 | ||||
| -rw-r--r-- | flang/lib/Semantics/check-declarations.cpp | 4 | ||||
| -rw-r--r-- | flang/test/Semantics/bindings04.f90 | 57 |
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 |