diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -722,6 +722,41 @@ } } +// 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 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 @@ } } } + 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 --- /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