diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp index 3074fc0516b46a..c600cea5c420cc 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -1069,13 +1069,32 @@ bool FunctionResult::IsCompatibleWith( actual.IsAssumedLengthCharacter()) { return true; } else { - const auto *ifaceLenParam{ - ifaceTypeShape->type().charLengthParamValue()}; - const auto *actualLenParam{ - actualTypeShape->type().charLengthParamValue()}; - if (ifaceLenParam && actualLenParam && - *ifaceLenParam == *actualLenParam) { - return true; + auto len{ToInt64(ifaceTypeShape->LEN())}; + auto actualLen{ToInt64(actualTypeShape->LEN())}; + if (len.has_value() != actualLen.has_value()) { + if (whyNot) { + *whyNot = "constant-length vs non-constant-length character " + "results"; + } + } else if (len && *len != *actualLen) { + if (whyNot) { + *whyNot = "character results with distinct lengths"; + } + } else { + const auto *ifaceLenParam{ + ifaceTypeShape->type().charLengthParamValue()}; + const auto *actualLenParam{ + actualTypeShape->type().charLengthParamValue()}; + if (ifaceLenParam && actualLenParam && + ifaceLenParam->isExplicit() != + actualLenParam->isExplicit()) { + if (whyNot) { + *whyNot = + "explicit-length vs deferred-length character results"; + } + } else { + return true; + } } } } diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index 0b847f5c3408bf..3626aaf3f44924 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -3289,11 +3289,14 @@ void SubprogramMatchHelper::Check( Say(symbol1, symbol2, "Module subprogram '%s' and its corresponding interface body are not both BIND(C)"_err_en_US); } - if (proc1->functionResult && proc2->functionResult && - *proc1->functionResult != *proc2->functionResult) { - Say(symbol1, symbol2, - "Return type of function '%s' does not match return type of" - " the corresponding interface body"_err_en_US); + if (proc1->functionResult && proc2->functionResult) { + std::string whyNot; + if (!proc1->functionResult->IsCompatibleWith( + *proc2->functionResult, &whyNot)) { + Say(symbol1, symbol2, + "Result of function '%s' is not compatible with the result of the corresponding interface body: %s"_err_en_US, + whyNot); + } } for (int i{0}; i < nargs1; ++i) { const Symbol *arg1{args1[i]}; diff --git a/flang/test/Semantics/separate-mp02.f90 b/flang/test/Semantics/separate-mp02.f90 index 39a469b6ccc09e..c39f18064796bb 100644 --- a/flang/test/Semantics/separate-mp02.f90 +++ b/flang/test/Semantics/separate-mp02.f90 @@ -272,10 +272,10 @@ module function f3() !OK real module function f1() end - !ERROR: Return type of function 'f2' does not match return type of the corresponding interface body + !ERROR: Result of function 'f2' is not compatible with the result of the corresponding interface body: function results have distinct types: INTEGER(4) vs REAL(4) integer module function f2() end - !ERROR: Return type of function 'f3' does not match return type of the corresponding interface body + !ERROR: Result of function 'f3' is not compatible with the result of the corresponding interface body: function results have incompatible attributes module function f3() real :: f3 pointer :: f3 @@ -334,3 +334,16 @@ module subroutine sub2(s) character(len=1) s end subroutine end submodule + +module m10 + interface + module character(2) function f() + end function + end interface +end module +submodule(m10) sm10 + contains + !ERROR: Result of function 'f' is not compatible with the result of the corresponding interface body: function results have distinct types: CHARACTER(KIND=1,LEN=3_8) vs CHARACTER(KIND=1,LEN=2_8) + module character(3) function f() + end function +end submodule diff --git a/flang/test/Semantics/separate-mp03.f90 b/flang/test/Semantics/separate-mp03.f90 index 1bbeced44a4f7a..8bf21b37ae2b9c 100644 --- a/flang/test/Semantics/separate-mp03.f90 +++ b/flang/test/Semantics/separate-mp03.f90 @@ -81,7 +81,7 @@ integer module function f1(x) !ERROR: 'notf2' was not declared a separate module procedure module procedure notf2 end procedure - !ERROR: Return type of function 'f3' does not match return type of the corresponding interface body + !ERROR: Result of function 'f3' is not compatible with the result of the corresponding interface body: function results have distinct types: REAL(4) vs INTEGER(4) module function f3(x) result(res) real :: res real, intent(in) :: x