[flang-commits] [flang] ae426a0 - [flang] Detect obvious argument shape incompatibility when checking procedure compatibility

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2023-03-10T09:45:00-08:00
New Revision: ae426a054b0c54155f27388ded800006da78268d

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

LOG: [flang] Detect obvious argument shape incompatibility when checking procedure compatibility

The compiler presently detects different dummy object array ranks;
extend the compatibility check to also note discrepancies in corresponding
constant dummy argument extents.

Differential Revision: https://reviews.llvm.org/D145748

Added: 
    flang/test/Semantics/argshape01.f90

Modified: 
    flang/lib/Evaluate/characteristics.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 0fe965aeab12..1906f5a44608 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -263,8 +263,22 @@ bool DummyDataObject::operator==(const DummyDataObject &that) const {
 }
 
 static bool AreCompatibleDummyDataObjectShapes(const Shape &x, const Shape &y) {
-  // TODO: Validate more than just compatible ranks
-  return GetRank(x) == GetRank(y);
+  int n{GetRank(x)};
+  if (n != GetRank(y)) {
+    return false;
+  }
+  auto xIter{x.begin()};
+  auto yIter{y.begin()};
+  for (; n-- > 0; ++xIter, ++yIter) {
+    if (auto xVal{ToInt64(*xIter)}) {
+      if (auto yVal{ToInt64(*yIter)}) {
+        if (*xVal != *yVal) {
+          return false;
+        }
+      }
+    }
+  }
+  return true;
 }
 
 bool DummyDataObject::IsCompatibleWith(

diff  --git a/flang/test/Semantics/argshape01.f90 b/flang/test/Semantics/argshape01.f90
new file mode 100644
index 000000000000..42ba0fab4a5e
--- /dev/null
+++ b/flang/test/Semantics/argshape01.f90
@@ -0,0 +1,41 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Detect incompatible argument shapes
+module m
+ contains
+  subroutine s1(a)
+    real, intent(in) :: a(2,3)
+  end
+  subroutine s2(a)
+    real, intent(in) :: a(3,2)
+  end
+  subroutine s1c(s)
+    procedure(s1) :: s
+  end
+  subroutine s2c(s)
+    procedure(s2) :: s
+  end
+end
+
+program main
+  use m
+  procedure(s1), pointer :: ps1
+  procedure(s2), pointer :: ps2
+  call s1c(s1)
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
+  call s1c(s2)
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
+  call s2c(s1)
+  call s2c(s2)
+  ps1 => s1
+  !ERROR: Procedure pointer 'ps1' associated with incompatible procedure designator 's2': incompatible dummy argument #1: incompatible dummy data object shapes
+  ps1 => s2
+  !ERROR: Procedure pointer 'ps2' associated with incompatible procedure designator 's1': incompatible dummy argument #1: incompatible dummy data object shapes
+  ps2 => s1
+  ps2 => s2
+  call s1c(ps1)
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
+  call s1c(ps2)
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 's=': incompatible dummy argument #1: incompatible dummy data object shapes
+  call s2c(ps1)
+  call s2c(ps2)
+end