[flang-commits] [PATCH] D132162: [flang] Avoid spurious error message in function result compatibility

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: vdonaldson.
klausler added a project: Flang.
Herald added a subscriber: jdoerfert.
Herald added a project: All.
klausler requested review of this revision.

When checking function interface compatibility for procedure pointer
assignment/initialization or actual/dummy procedure association, don't
emit a diagnositic about function result shape incompatibility unless
the interfaces differ in rank or have distinct constant extents on a
dimension.  Function results whose dimensions are determined by dummy
arguments or host-associated variables are not necessarily incompatible.


https://reviews.llvm.org/D132162

Files:
  flang/lib/Evaluate/characteristics.cpp


Index: flang/lib/Evaluate/characteristics.cpp
===================================================================
--- flang/lib/Evaluate/characteristics.cpp
+++ flang/lib/Evaluate/characteristics.cpp
@@ -875,6 +875,23 @@
   }
 }
 
+static bool AreCompatibleFunctionResultShapes(const Shape &x, const Shape &y) {
+  int rank{GetRank(x)};
+  if (GetRank(y) != rank) {
+    return false;
+  }
+  for (int j{0}; j < rank; ++j) {
+    if (auto xDim{ToInt64(x[j])}) {
+      if (auto yDim{ToInt64(y[j])}) {
+        if (*xDim != *yDim) {
+          return false;
+        }
+      }
+    }
+  }
+  return true;
+}
+
 bool FunctionResult::IsCompatibleWith(
     const FunctionResult &actual, std::string *whyNot) const {
   Attrs actualAttrs{actual.attrs};
@@ -892,9 +909,10 @@
           *whyNot = "function results have distinct ranks";
         }
       } else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) &&
-          ifaceTypeShape->shape() != actualTypeShape->shape()) {
+          !AreCompatibleFunctionResultShapes(
+              ifaceTypeShape->shape(), actualTypeShape->shape())) {
         if (whyNot) {
-          *whyNot = "function results have distinct extents";
+          *whyNot = "function results have distinct constant extents";
         }
       } else if (!ifaceTypeShape->type().IsTkCompatibleWith(
                      actualTypeShape->type())) {


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D132162.453728.patch
Type: text/x-patch
Size: 1388 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20220818/7b275e2b/attachment.bin>