[flang-commits] [flang] 19afc49 - [flang] Enforce array conformance in actual arguments to ELEMENTALs

[peter klausler via flang-commits]

Author: peter klausler
Date: 2021-09-16T16:17:36-07:00
New Revision: 19afc495dc2797803b3da7f0797f214483215bb8

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

LOG: [flang] Enforce array conformance in actual arguments to ELEMENTALs

When the shapes of actual arguments to ELEMENTAL procedures are
sufficiently well known during semantics, require them to conform.

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

Added: 
    flang/test/Semantics/call22.f90

Modified: 
    flang/lib/Semantics/check-call.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 91b5c074e0a4..c47c5265b09d 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -722,6 +722,41 @@ static void RearrangeArguments(const characteristics::Procedure &proc,
   }
 }
 
+// The actual argument arrays to an ELEMENTAL procedure must conform.
+static bool CheckElementalConformance(parser::ContextualMessages &messages,
+    const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
+    evaluate::FoldingContext &context) {
+  std::optional<evaluate::Shape> shape;
+  std::string shapeName;
+  int index{0};
+  for (const auto &arg : actuals) {
+    const auto &dummy{proc.dummyArguments.at(index++)};
+    if (arg) {
+      if (const auto *expr{arg->UnwrapExpr()}) {
+        if (auto argShape{evaluate::GetShape(context, *expr)}) {
+          if (GetRank(*argShape) > 0) {
+            std::string argName{"actual argument ("s + expr->AsFortran() +
+                ") corresponding to dummy argument #" + std::to_string(index) +
+                " ('" + dummy.name + "')"};
+            if (shape) {
+              auto tristate{evaluate::CheckConformance(messages, *shape,
+                  *argShape, evaluate::CheckConformanceFlags::None,
+                  shapeName.c_str(), argName.c_str())};
+              if (tristate && !*tristate) {
+                return false;
+              }
+            } else {
+              shape = std::move(argShape);
+              shapeName = argName;
+            }
+          }
+        }
+      }
+    }
+  }
+  return true;
+}
+
 static parser::Messages CheckExplicitInterface(
     const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
     const evaluate::FoldingContext &context, const Scope *scope,
@@ -751,6 +786,9 @@ static parser::Messages CheckExplicitInterface(
         }
       }
     }
+    if (proc.IsElemental() && !buffer.AnyFatalError()) {
+      CheckElementalConformance(messages, proc, actuals, localContext);
+    }
   }
   return buffer;
 }

diff  --git a/flang/test/Semantics/call22.f90 b/flang/test/Semantics/call22.f90
new file mode 100644
index 000000000000..e418b98964cd
--- /dev/null
+++ b/flang/test/Semantics/call22.f90
@@ -0,0 +1,18 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Enforce array conformance across actual arguments to ELEMENTAL
+module m
+ contains
+  real elemental function f(a, b)
+    real, intent(in) :: a, b
+    f = a + b
+  end function
+  real function g(n)
+    integer, value :: n
+    g = sqrt(real(n))
+  end function
+  subroutine test
+    real :: a(3) = [1, 2, 3]
+    !ERROR: Dimension 1 of actual argument (a) corresponding to dummy argument #1 ('a') has extent 3, but actual argument ([REAL(4)::(g(int(j,kind=4)),INTEGER(8)::j=1_8,2_8,1_8)]) corresponding to dummy argument #2 ('b') has extent 2
+    print *, f(a, [(g(j), j=1, 2)])
+  end subroutine
+end