Skip to content

Commit

Permalink
[flang] Catch more bad TARGET= arguments to ASSOCIATED()
Browse files Browse the repository at this point in the history 
The TARGET= argument to the intrinsic function ASSOCIATED() must be
a valid target for the POINTER= argument, but we are missing some
cases, such as parenthesized expressions.  Add more checking, and
restructure the logic a bit to make the case analysis structure
more clear.

Fixes llvm-test-suite/Fortran/gfortran/regression/associated_target_1.f90.

Differential Revision: https://reviews.llvm.org/D157341
  • Loading branch information
@klausler
klausler committed Aug 8, 2023
1 parent 87b6f85 commit 458d9fb
Show file tree
Hide file tree
Showing 2 changed files with 78 additions and 78 deletions.
150 changes: 73 additions & 77 deletions flang/lib/Semantics/check-call.cpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1252,95 +1252,91 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
}
}
}
const auto *targetExpr{targetArg->UnwrapExpr()};
if (targetExpr && pointerSymbol) {
std::optional<characteristics::Procedure> pointerProc, targetProc;
const auto *targetProcDesignator{
evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(*targetExpr)};
const Symbol *targetSymbol{GetLastSymbol(*targetExpr)};
bool isCall{false};
std::string targetName;
if (const auto *targetProcRef{// target is a function call
std::get_if<evaluate::ProcedureRef>(&targetExpr->u)}) {
if (auto targetRefedChars{characteristics::Procedure::Characterize(
*targetProcRef, context)}) {
targetProc = *targetRefedChars;
targetName = targetProcRef->proc().GetName() + "()";
isCall = true;
}
} else if (targetProcDesignator) {
targetProc = characteristics::Procedure::Characterize(
*targetProcDesignator, context);
targetName = targetProcDesignator->GetName();
} else if (targetSymbol) {
if (IsProcedure(*targetSymbol)) {
// proc that's not a call
targetProc = characteristics::Procedure::Characterize(
*targetSymbol, context);
}
targetName = targetSymbol->name().ToString();
}
if (pointerSymbol && IsProcedure(*pointerSymbol)) {
pointerProc = characteristics::Procedure::Characterize(
*pointerSymbol, context);
}
if (pointerProc) {
if (targetProc) {
// procedure pointer and procedure target
std::string whyNot;
const evaluate::SpecificIntrinsic *specificIntrinsic{nullptr};
if (targetProcDesignator) {
specificIntrinsic =
targetProcDesignator->GetSpecificIntrinsic();
if (const auto *targetExpr{targetArg->UnwrapExpr()};
targetExpr && pointerSymbol) {
if (IsProcedure(*pointerSymbol)) {
if (auto pointerProc{characteristics::Procedure::Characterize(
*pointerSymbol, context)}) {
// Characterize the target procedure
std::optional<characteristics::Procedure> targetProc;
const auto *targetProcDesignator{
evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(
*targetExpr)};
bool isCall{false};
std::string targetName;
if (IsProcedure(*targetExpr) ||
IsNullProcedurePointer(*targetExpr)) {
if (const auto *targetProcRef{
std::get_if<evaluate::ProcedureRef>(&targetExpr->u)}) {
// target is a function call returning a procedure pointer
targetProc = characteristics::Procedure::Characterize(
*targetProcRef, context);
isCall = true;
targetName = targetProcRef->proc().GetName() + "()";
} else if (targetProcDesignator) {
targetProc = characteristics::Procedure::Characterize(
*targetProcDesignator, context);
targetName = targetProcDesignator->GetName();
} else if (const Symbol * targSym{GetLastSymbol(*targetExpr)}) {
targetProc = characteristics::Procedure::Characterize(
*targSym, context);
targetName = targSym->name().ToString();
}
}
if (std::optional<parser::MessageFixedText> msg{
CheckProcCompatibility(isCall, pointerProc, &*targetProc,
specificIntrinsic, whyNot)}) {
msg->set_severity(parser::Severity::Warning);
if (targetProc) {
std::string whyNot;
const evaluate::SpecificIntrinsic *specificIntrinsic{
targetProcDesignator
? targetProcDesignator->GetSpecificIntrinsic()
: nullptr};
if (std::optional<parser::MessageFixedText> msg{
CheckProcCompatibility(isCall, pointerProc,
&*targetProc, specificIntrinsic, whyNot)}) {
msg->set_severity(parser::Severity::Warning);
evaluate::AttachDeclaration(
context.messages().Say(std::move(*msg),
"pointer '" + pointerSymbol->name().ToString() + "'",
targetName, whyNot),
*pointerSymbol);
}
} else if (!IsNullProcedurePointer(*targetExpr)) {
evaluate::AttachDeclaration(
context.messages().Say(std::move(*msg),
"pointer '" + pointerSymbol->name().ToString() + "'",
targetName, whyNot),
context.messages().Say(
"POINTER= argument '%s' is a procedure pointer but the TARGET= argument '%s' is not a procedure or procedure pointer"_err_en_US,
pointerSymbol->name(), targetExpr->AsFortran()),
*pointerSymbol);
}
} else if (!IsNullProcedurePointer(*targetExpr)) {
// procedure pointer and object target
evaluate::AttachDeclaration(
context.messages().Say(
"POINTER= argument '%s' is a procedure pointer but the TARGET= argument '%s' is not a procedure or procedure pointer"_err_en_US,
pointerSymbol->name(), targetName),
*pointerSymbol);
}
} else if (targetProc) {
// object pointer and procedure target
evaluate::AttachDeclaration(
context.messages().Say(
"POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is a procedure designator"_err_en_US,
pointerSymbol->name(), targetName),
*pointerSymbol);
} else if (targetSymbol) {
// object pointer and target
SymbolVector symbols{GetSymbolVector(*targetExpr)};
CHECK(!symbols.empty());
if (!evaluate::GetLastTarget(symbols)) {
parser::Message *msg{context.messages().Say(
targetArg->sourceLocation(),
"TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US,
targetExpr->AsFortran())};
for (SymbolRef ref : symbols) {
msg = evaluate::AttachDeclaration(msg, *ref);
} else if (IsVariable(*targetExpr) || IsNullPointer(*targetExpr)) {
// Object pointer and target
if (ExtractDataRef(*targetExpr)) {
if (SymbolVector symbols{GetSymbolVector(*targetExpr)};
!evaluate::GetLastTarget(symbols)) {
parser::Message *msg{context.messages().Say(
targetArg->sourceLocation(),
"TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US,
targetExpr->AsFortran())};
for (SymbolRef ref : symbols) {
msg = evaluate::AttachDeclaration(msg, *ref);
}
} else if (HasVectorSubscript(*targetExpr) ||
ExtractCoarrayRef(*targetExpr)) {
context.messages().Say(targetArg->sourceLocation(),
"TARGET= argument '%s' may not have a vector subscript or coindexing"_err_en_US,
targetExpr->AsFortran());
}
} else if (HasVectorSubscript(*targetExpr) ||
ExtractCoarrayRef(*targetExpr)) {
context.messages().Say(targetArg->sourceLocation(),
"TARGET= argument '%s' may not have a vector subscript or coindexing"_err_en_US,
targetExpr->AsFortran());
}
if (const auto pointerType{pointerArg->GetType()}) {
if (const auto targetType{targetArg->GetType()}) {
ok = pointerType->IsTkCompatibleWith(*targetType);
}
}
} else {
evaluate::AttachDeclaration(
context.messages().Say(
"POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is not a variable"_err_en_US,
pointerSymbol->name(), targetExpr->AsFortran()),
*pointerSymbol);
}
}
}
Expand Down
6 changes: 5 additions & 1 deletion flang/test/Semantics/associated.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -95,6 +95,10 @@ subroutine test(assumedRank)
lvar = associated(realMatPtr, targetRealMat) ! ok
!ERROR: missing mandatory 'pointer=' argument
lVar = associated()
!ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument '(targetintvar1)' is not a procedure or procedure pointer
lvar = associated(intprocPointer1, (targetIntVar1))
!ERROR: POINTER= argument 'intpointervar1' is an object pointer but the TARGET= argument '(targetintvar1)' is not a variable
lvar = associated(intPointerVar1, (targetIntVar1))
!ERROR: MOLD= argument to NULL() must be a pointer or allocatable
lVar = associated(null(intVar))
lVar = associated(null(intAllocVar)) !OK
Expand Down Expand Up @@ -164,7 +168,7 @@ subroutine test(assumedRank)
!WARNING: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible procedure attributes: Elemental
!ERROR: Non-intrinsic ELEMENTAL procedure 'elementalproc' may not be passed as an actual argument
lvar = associated(intProcPointer1, elementalProc)
!ERROR: POINTER= argument 'intpointervar1' is an object pointer but the TARGET= argument 'intfunc' is a procedure designator
!ERROR: POINTER= argument 'intpointervar1' is an object pointer but the TARGET= argument 'intfunc' is not a variable
lvar = associated (intPointerVar1, intFunc)
!ERROR: In assignment to object pointer 'intpointervar1', the target 'intfunc' is a procedure designator
intPointerVar1 => intFunc
Expand Down

0 comments on commit 458d9fb

Please sign in to comment.