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 @@ -502,13 +502,14 @@ } static void CheckProcedureArg(evaluate::ActualArgument &arg, - const characteristics::DummyProcedure &proc, const std::string &dummyName, + const characteristics::Procedure &proc, + const characteristics::DummyProcedure &dummy, const std::string &dummyName, evaluate::FoldingContext &context) { parser::ContextualMessages &messages{context.messages()}; - const characteristics::Procedure &interface{proc.procedure.value()}; + const characteristics::Procedure &interface { dummy.procedure.value() }; if (const auto *expr{arg.UnwrapExpr()}) { bool dummyIsPointer{ - proc.attrs.test(characteristics::DummyProcedure::Attr::Pointer)}; + dummy.attrs.test(characteristics::DummyProcedure::Attr::Pointer)}; const auto *argProcDesignator{ std::get_if(&expr->u)}; const auto *argProcSymbol{ @@ -549,6 +550,10 @@ "Actual procedure argument has interface incompatible with %s"_err_en_US, dummyName); return; + } else if (proc.IsPure()) { + messages.Say( + "Actual procedure argument for %s of a PURE procedure must have an explicit interface"_err_en_US, + dummyName); } else { messages.Say( "Actual procedure argument has an implicit interface " @@ -594,7 +599,7 @@ } } if (interface.HasExplicitInterface() && dummyIsPointer && - proc.intent != common::Intent::In) { + dummy.intent != common::Intent::In) { const Symbol *last{GetLastSymbol(*expr)}; if (!(last && IsProcedurePointer(*last))) { // 15.5.2.9(5) -- dummy procedure POINTER @@ -661,8 +666,8 @@ } } }, - [&](const characteristics::DummyProcedure &proc) { - CheckProcedureArg(arg, proc, dummyName, context); + [&](const characteristics::DummyProcedure &dummy) { + CheckProcedureArg(arg, proc, dummy, dummyName, context); }, [&](const characteristics::AlternateReturn &) { // All semantic checking is done elsewhere diff --git a/flang/test/Semantics/call12.f90 b/flang/test/Semantics/call12.f90 --- a/flang/test/Semantics/call12.f90 +++ b/flang/test/Semantics/call12.f90 @@ -18,6 +18,14 @@ real, allocatable :: co[:] end type contains + integer pure function purefunc(x) + integer, intent(in) :: x + purefunc = x + end function + integer pure function f00(p0) + procedure(purefunc) :: p0 + f00 = p0(1) + end function pure function test(ptr, in, hpd) use used type(t), pointer :: ptr, ptr2 @@ -29,6 +37,7 @@ type(hasCoarray), pointer :: hcp integer :: n common /block/ y + external :: extfunc !ERROR: Pure subprogram 'test' may not define 'x' because it is host-associated x%a = 0. !ERROR: Pure subprogram 'test' may not define 'y' because it is in a COMMON block @@ -63,6 +72,8 @@ hp = hpd ! C1594(5) !ERROR: A pure subprogram may not copy the value of 'hpd' because it is an INTENT(IN) dummy argument and has the POINTER component '%p' allocate(alloc, source=hpd) + !ERROR: Actual procedure argument for dummy argument 'p0=' of a PURE procedure must have an explicit interface + n = f00(extfunc) contains pure subroutine internal type(hasPtr) :: localhp