[flang] Enforce array conformance in actual arguments to ELEMENTALs

[klausler]

Summary

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

[PeteSteinfeld]

Looks great!

flang/lib/Semantics/check-call.cpp

for (auto &bad : kwArgs) {
       evaluate::ActualArgument &x{bad.second};
       messages.Say(*x.keyword(),
           "Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US,
           *x.keyword());
     }
   }
 }
 
+// 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,
     const evaluate::SpecificIntrinsic *intrinsic) {
   parser::Messages buffer;
   parser::ContextualMessages messages{context.messages().at(), &buffer};
   RearrangeArguments(proc, actuals, messages);
   if (buffer.empty()) {
for (auto &actual : actuals) {
         } else {
           messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not "
                        "associated with an actual argument in this procedure "
                        "reference"_err_en_US,
               dummy.name, index);
         }
       }
     }
+    if (proc.IsElemental() && !buffer.AnyFatalError()) {
+      CheckElementalConformance(messages, proc, actuals, localContext);
+    }
   }
   return buffer;
 }
 
 parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc,
     evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context,
     const Scope &scope, const evaluate::SpecificIntrinsic *intrinsic) {
   return CheckExplicitInterface(proc, actuals, context, &scope, intrinsic);

flang/test/Semantics/call22.f90

+! 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