diff options
author | Peter Klausler <pklausler@nvidia.com> | 2022-10-25 02:59:55 +0300 |
---|---|---|
committer | Peter Klausler <pklausler@nvidia.com> | 2022-10-31 03:54:22 +0300 |
commit | bd28a0a51181ad33dc9030fb887d26cd6b238c1f (patch) | |
tree | c3554d66d87dc3750f6134e9b8678df743f4fd12 /flang | |
parent | dbfa4a0aa561809db4376103278fa8e824d91a6c (diff) |
[flang] Catch attempts to do anything with statement functions other than call them
A statement function in Fortran may be called, but it may not be the target
of a procedure pointer or passed as an actual argument.
Diffstat (limited to 'flang')
-rw-r--r-- | flang/lib/Semantics/check-call.cpp | 33 | ||||
-rw-r--r-- | flang/lib/Semantics/pointer-assignment.cpp | 11 | ||||
-rw-r--r-- | flang/test/Semantics/assign03.f90 | 7 | ||||
-rw-r--r-- | flang/test/Semantics/call02.f90 | 13 |
4 files changed, 57 insertions, 7 deletions
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index 418d66d3d5db..d36ddd3623ba 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -77,13 +77,21 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg, "actual argument", *expr, context)}) { const auto *argProcDesignator{ std::get_if<evaluate::ProcedureDesignator>(&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()); + if (const auto *argProcSymbol{ + argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}) { + if (!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()); + } else if (const auto *subp{argProcSymbol->GetUltimate() + .detailsIf<SubprogramDetails>()}) { + if (subp->stmtFunction()) { + evaluate::SayWithDeclaration(messages, *argProcSymbol, + "Statement function '%s' may not be passed as an actual argument"_err_en_US, + argProcSymbol->name()); + } + } } } } @@ -574,6 +582,17 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg, std::get_if<evaluate::ProcedureDesignator>(&expr->u)}; const auto *argProcSymbol{ argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}; + if (argProcSymbol) { + if (const auto *subp{ + argProcSymbol->GetUltimate().detailsIf<SubprogramDetails>()}) { + if (subp->stmtFunction()) { + evaluate::SayWithDeclaration(messages, *argProcSymbol, + "Statement function '%s' may not be passed as an actual argument"_err_en_US, + argProcSymbol->name()); + return; + } + } + } if (auto argChars{characteristics::DummyArgument::FromActual( "actual argument", *expr, context)}) { if (!argChars->IsTypelessIntrinsicDummy()) { diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp index 69e80e5a1240..54e36f5b085b 100644 --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -279,6 +279,17 @@ bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall, } bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) { + if (const Symbol * symbol{d.GetSymbol()}) { + if (const auto *subp{ + symbol->GetUltimate().detailsIf<SubprogramDetails>()}) { + if (subp->stmtFunction()) { + evaluate::SayWithDeclaration(context_.messages(), *symbol, + "Statement function '%s' may not be the target of a pointer assignment"_err_en_US, + symbol->name()); + return false; + } + } + } if (auto chars{Procedure::Characterize(d, context_)}) { return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic()); } else { diff --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90 index 5740339edb55..a5d12be48785 100644 --- a/flang/test/Semantics/assign03.f90 +++ b/flang/test/Semantics/assign03.f90 @@ -314,4 +314,11 @@ contains ptr => s_external call ptr end subroutine + + subroutine s14 + procedure(real), pointer :: ptr + sf(x) = x + 1. + !ERROR: Statement function 'sf' may not be the target of a pointer assignment + ptr => sf + end subroutine end diff --git a/flang/test/Semantics/call02.f90 b/flang/test/Semantics/call02.f90 index 8ef10415be80..264a79f8983a 100644 --- a/flang/test/Semantics/call02.f90 +++ b/flang/test/Semantics/call02.f90 @@ -43,6 +43,19 @@ subroutine s02 end function end +subroutine s03 + interface + subroutine sub1(p) + procedure(real) :: p + end subroutine + end interface + sf(x) = x + 1. + !ERROR: Statement function 'sf' may not be passed as an actual argument + call sub1(sf) + !ERROR: Statement function 'sf' may not be passed as an actual argument + call sub2(sf) +end + module m01 procedure(sin) :: elem01 interface |