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 @@ -24,8 +24,8 @@ namespace Fortran::semantics { -static void CheckImplicitInterfaceArg( - evaluate::ActualArgument &arg, parser::ContextualMessages &messages) { +static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg, + parser::ContextualMessages &messages, evaluate::FoldingContext &context) { auto restorer{ messages.SetLocation(arg.sourceLocation().value_or(messages.at()))}; if (auto kw{arg.keyword()}) { @@ -73,6 +73,18 @@ messages.Say( "VOLATILE argument requires an explicit interface"_err_en_US); } + } else if (auto argChars{characteristics::DummyArgument::FromActual( + "actual argument", *expr, context)}) { + const auto *argProcDesignator{ + std::get_if(&expr->u)}; + const auto *argProcSymbol{ + argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}; + if (argProcSymbol && !argChars->IsTypelessIntrinsicDummy() && + argProcDesignator && argProcDesignator->IsElemental()) { // C1533 + evaluate::SayWithDeclaration(messages, *argProcSymbol, + "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US, + argProcSymbol->name()); + } } } } @@ -877,7 +889,7 @@ auto restorer{messages.SetMessages(buffer)}; for (auto &actual : actuals) { if (actual) { - CheckImplicitInterfaceArg(*actual, messages); + CheckImplicitInterfaceArg(*actual, messages, context); } } } diff --git a/flang/test/Semantics/call02.f90 b/flang/test/Semantics/call02.f90 --- a/flang/test/Semantics/call02.f90 +++ b/flang/test/Semantics/call02.f90 @@ -26,6 +26,15 @@ call subr(B"1010") end subroutine +subroutine s02 + !ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument + call sub(elem) + contains + elemental integer function elem() + elem = 1 + end function +end + module m01 procedure(sin) :: elem01 interface @@ -73,6 +82,18 @@ end subroutine end module +module m03 + contains + subroutine test + !ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument + call sub(elem) + contains + elemental integer function elem() + elem = 1 + end function + end +end + program p03 logical :: l call s1(index)