[flang-commits] [flang] [flang] Fine-tune function result equivalence checking (PR #70260)

[Peter Klausler via flang-commits]

https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/70260

>From b59dd1ce60d7ac01fe41d7aa77a07e168bc8ecfa Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Wed, 25 Oct 2023 14:46:43 -0700
Subject: [PATCH] [flang] Fine-tune function result equivalence checking

When a separate module function's definition has a redundant
interface -- it's defined with MODULE FUNCTION, not
MODULE PROCEDURE -- the check for result type equivalence
needs to allow for character lengths that are the results of
specification expressions.  At present, identical-looking length
specification expression don't compare equal, since they can refer
to distinct dummy argument symbols.  Ensure just that they are both
constant or not, and if constant, that the lengths have the
same value.
---
 flang/lib/Evaluate/characteristics.cpp     | 33 +++++++++++++++++-----
 flang/lib/Semantics/check-declarations.cpp | 13 +++++----
 flang/test/Semantics/separate-mp02.f90     | 17 +++++++++--
 flang/test/Semantics/separate-mp03.f90     |  2 +-
 4 files changed, 50 insertions(+), 15 deletions(-)

diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index ac61e72f428a97e..854cecf015c5760 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -1060,13 +1060,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 2c2866d590ae5a4..3fcef83595d693f 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -3285,11 +3285,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 fd9c4c3cc18f98b..9eeca0886f93dc4 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 33bf1cf8e414fd5..f6c02c5add3fdaa 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