mirrors/llvm-project
0
0
Fork 0
mirror of https://github.com/llvm/llvm-project.git synced 2025-04-29 05:56:06 +00:00
Code Issues Projects Releases Wiki Activity

[flang] Catch attempts to do anything with statement functions other than call them

Browse Source 
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.
This commit is contained in:
Peter Klausler 2022-10-24 16:59:55 -07:00
parent dbfa4a0aa5
commit bd28a0a511
4 changed files with 57 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
flang/lib/Semantics/check-call.cpp
View File

@ -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()) {

11
flang/lib/Semantics/pointer-assignment.cpp
View File

@ -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 {

7
flang/test/Semantics/assign03.f90
View File

@ -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

13
flang/test/Semantics/call02.f90
View File

@ -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