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

[via flang-commits]

Author: Peter Klausler
Date: 2023-10-31T12:05:29-07:00
New Revision: 11529d5b3b7cb763cd7ec9e117f33543ca7d6a90

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

LOG: [flang] Fine-tune function result equivalence checking (#70260)

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.

Added: 
    

Modified: 
    flang/lib/Evaluate/characteristics.cpp
    flang/lib/Semantics/check-declarations.cpp
    flang/test/Semantics/separate-mp02.f90
    flang/test/Semantics/separate-mp03.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 3074fc0516b46af..c600cea5c420ccf 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 0b847f5c3408bf9..3626aaf3f44924d 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 39a469b6ccc09e8..c39f18064796bb3 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 1bbeced44a4f7a2..8bf21b37ae2b9c1 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