diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -527,6 +527,19 @@ scope, with a portability warning, since that global name is not actually capable of being "used" in its scope. +* In the definition of the `ASSOCIATED` intrinsic function (16.9.16), its optional + second argument `TARGET=` is required to be "allowable as the data-target or + proc-target in a pointer assignment statement (10.2.2) in which POINTER is + data-pointer-object or proc-pointer-object." Some Fortran compilers + interpret this to require that the first argument (`POINTER=`) be a valid + left-hand side for a pointer assignment statement -- in particular, it + cannot be `NULL()`, but also it is required to be modifiable. + As there is no good reason to disallow (say) an `INTENT(IN)` pointer here, + or even `NULL()` as a well-defined case that is always `.FALSE.`, + this compiler doesn't require the `POINTER=` argument to be a valid + left-hand side for a pointer assignment statement, and we emit a + portability warning when it is not. + ## De Facto Standard Features * `EXTENDS_TYPE_OF()` returns `.TRUE.` if both of its arguments have the diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -970,6 +970,7 @@ // Procedure and pointer detection predicates bool IsProcedure(const Expr &); bool IsFunction(const Expr &); +bool IsProcedurePointer(const Expr &); bool IsProcedurePointerTarget(const Expr &); bool IsBareNullPointer(const Expr *); // NULL() w/o MOLD= or type bool IsNullObjectPointer(const Expr &); diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2656,129 +2656,6 @@ } } -static bool CheckAssociated(SpecificCall &call, FoldingContext &context) { - bool ok{true}; - if (const auto &pointerArg{call.arguments[0]}) { - if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) { - if (const Symbol *pointerSymbol{GetLastSymbol(*pointerExpr)}) { - if (!pointerSymbol->attrs().test(semantics::Attr::POINTER)) { - AttachDeclaration(context.messages().Say(pointerArg->sourceLocation(), - "POINTER= argument of ASSOCIATED() must be a " - "POINTER"_err_en_US), - *pointerSymbol); - } else { - if (const auto &targetArg{call.arguments[1]}) { - if (const auto *targetExpr{targetArg->UnwrapExpr()}) { - std::optional pointerProc, targetProc; - const auto *targetProcDesignator{ - UnwrapExpr(*targetExpr)}; - const Symbol *targetSymbol{GetLastSymbol(*targetExpr)}; - bool isCall{false}; - std::string targetName; - if (const auto *targetProcRef{// target is a function call - std::get_if(&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 (IsProcedure(*pointerSymbol)) { - pointerProc = characteristics::Procedure::Characterize( - *pointerSymbol, context); - } - if (pointerProc) { - if (targetProc) { - // procedure pointer and procedure target - std::string whyNot; - const SpecificIntrinsic *specificIntrinsic{nullptr}; - if (targetProcDesignator) { - specificIntrinsic = - targetProcDesignator->GetSpecificIntrinsic(); - } - if (std::optional msg{ - CheckProcCompatibility(isCall, pointerProc, - &*targetProc, specificIntrinsic, whyNot)}) { - msg->set_severity(parser::Severity::Warning); - AttachDeclaration( - context.messages().Say(std::move(*msg), - "pointer '" + pointerSymbol->name().ToString() + - "'", - targetName, whyNot), - *pointerSymbol); - } - } else if (!IsNullProcedurePointer(*targetExpr)) { - // procedure pointer and object target - 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 - 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 (!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 = 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()); - } - if (const auto pointerType{pointerArg->GetType()}) { - if (const auto targetType{targetArg->GetType()}) { - ok = pointerType->IsTkCompatibleWith(*targetType); - } - } - } - } - } - } - } - } - } else { - // No arguments to ASSOCIATED() - ok = false; - } - if (!ok) { - context.messages().Say( - "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US); - } - return ok; -} - static bool CheckForNonPositiveValues(FoldingContext &context, const ActualArgument &arg, const std::string &procName, const std::string &argName) { @@ -2875,6 +2752,8 @@ } // Applies any semantic checks peculiar to an intrinsic. +// TODO: Move the rest of these checks to Semantics/check-call.cpp, which is +// where ASSOCIATED() is now validated. static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { bool ok{true}; const std::string &name{call.specificIntrinsic.name}; @@ -2891,7 +2770,7 @@ "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US); } } else if (name == "associated") { - return CheckAssociated(call, context); + // Now handled in Semantics/check-call.cpp } else if (name == "atomic_and" || name == "atomic_or" || name == "atomic_xor") { return CheckForCoindexedObject(context, call.arguments[2], name, "stat"); diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -737,6 +737,18 @@ return designator && designator->GetType().has_value(); } +bool IsProcedurePointer(const Expr &expr) { + return common::visit(common::visitors{ + [](const NullPointer &) { return true; }, + [](const ProcedureRef &) { return false; }, + [&](const auto &) { + const Symbol *last{GetLastSymbol(expr)}; + return last && IsProcedurePointer(*last); + }, + }, + expr.u); +} + bool IsProcedurePointerTarget(const Expr &expr) { return common::visit(common::visitors{ [](const NullPointer &) { return true; }, diff --git a/flang/lib/Semantics/check-call.h b/flang/lib/Semantics/check-call.h --- a/flang/lib/Semantics/check-call.h +++ b/flang/lib/Semantics/check-call.h @@ -37,13 +37,6 @@ bool treatingExternalAsImplicit, const evaluate::SpecificIntrinsic *intrinsic); -// Checks actual arguments against a procedure with an explicit interface. -// Reports a buffer of errors when not compatible. -parser::Messages CheckExplicitInterface( - const evaluate::characteristics::Procedure &, evaluate::ActualArguments &, - const evaluate::FoldingContext &, const Scope &, - const evaluate::SpecificIntrinsic *intrinsic); - // Checks actual arguments for the purpose of resolving a generic interface. bool CheckInterfaceForGeneric(const evaluate::characteristics::Procedure &, evaluate::ActualArguments &, const evaluate::FoldingContext &, 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 @@ -930,6 +930,156 @@ return true; } +// ASSOCIATED (16.9.16) +static void CheckAssociated(evaluate::ActualArguments &arguments, + evaluate::FoldingContext &context, const Scope *scope) { + bool ok{true}; + if (arguments.size() < 2) { + return; + } + if (const auto &pointerArg{arguments[0]}) { + if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) { + const Symbol *pointerSymbol{GetLastSymbol(*pointerExpr)}; + if (pointerSymbol && !IsPointer(*pointerSymbol)) { + evaluate::AttachDeclaration( + context.messages().Say(pointerArg->sourceLocation(), + "POINTER= argument of ASSOCIATED() must be a POINTER"_err_en_US), + *pointerSymbol); + return; + } + if (const auto &targetArg{arguments[1]}) { + // The standard requires that the POINTER= argument be a valid LHS for + // a pointer assignment when the TARGET= argument is present. This, + // perhaps unintentionally, excludes function results, including NULL(), + // from being used there, as well as INTENT(IN) dummy pointers. + // Allow this usage as a benign extension with a portability warning. + if (!evaluate::ExtractDataRef(*pointerExpr) && + !evaluate::IsProcedurePointer(*pointerExpr)) { + context.messages().Say(pointerArg->sourceLocation(), + "POINTER= argument of ASSOCIATED() should be a pointer"_port_en_US); + } else if (scope) { + if (auto whyNot{WhyNotDefinable(pointerArg->sourceLocation().value_or( + context.messages().at()), + *scope, + DefinabilityFlags{DefinabilityFlag::PointerDefinition}, + *pointerExpr)}) { + if (auto *msg{context.messages().Say(pointerArg->sourceLocation(), + "POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement"_port_en_US)}) { + msg->Attach(std::move(*whyNot)); + } + } + } + const auto *targetExpr{targetArg->UnwrapExpr()}; + if (targetExpr && pointerSymbol) { + std::optional pointerProc, targetProc; + const auto *targetProcDesignator{ + evaluate::UnwrapExpr(*targetExpr)}; + const Symbol *targetSymbol{GetLastSymbol(*targetExpr)}; + bool isCall{false}; + std::string targetName; + if (const auto *targetProcRef{// target is a function call + std::get_if(&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 (std::optional 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)) { + // 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 (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 { + // No arguments to ASSOCIATED() + ok = false; + } + if (!ok) { + context.messages().Say( + "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US); + } +} + +static void CheckSpecificIntrinsic(evaluate::ActualArguments &arguments, + evaluate::FoldingContext &context, const Scope *scope, + const evaluate::SpecificIntrinsic &intrinsic) { + if (intrinsic.name == "associated") { + CheckAssociated(arguments, context, scope); + } +} + static parser::Messages CheckExplicitInterface( const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context, const Scope *scope, @@ -939,41 +1089,38 @@ parser::ContextualMessages messages{context.messages().at(), &buffer}; RearrangeArguments(proc, actuals, messages); evaluate::FoldingContext localContext{context, messages}; - if (buffer.empty()) { - int index{0}; - for (auto &actual : actuals) { - const auto &dummy{proc.dummyArguments.at(index++)}; - if (actual) { - CheckExplicitInterfaceArg(*actual, dummy, proc, localContext, scope, - intrinsic, allowActualArgumentConversions); - } else if (!dummy.IsOptional()) { - if (dummy.name.empty()) { - messages.Say( - "Dummy argument #%d is not OPTIONAL and is not associated with " - "an actual argument in this procedure reference"_err_en_US, - index); - } else { - messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not " - "associated with an actual argument in this procedure " - "reference"_err_en_US, - dummy.name, index); - } + if (!buffer.empty()) { + return buffer; + } + int index{0}; + for (auto &actual : actuals) { + const auto &dummy{proc.dummyArguments.at(index++)}; + if (actual) { + CheckExplicitInterfaceArg(*actual, dummy, proc, localContext, scope, + intrinsic, allowActualArgumentConversions); + } else if (!dummy.IsOptional()) { + if (dummy.name.empty()) { + messages.Say( + "Dummy argument #%d is not OPTIONAL and is not associated with " + "an actual argument in this procedure reference"_err_en_US, + index); + } else { + messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not " + "associated with an actual argument in this procedure " + "reference"_err_en_US, + dummy.name, index); } } - if (proc.IsElemental() && !buffer.AnyFatalError()) { - CheckElementalConformance(messages, proc, actuals, localContext); - } + } + if (proc.IsElemental() && !buffer.AnyFatalError()) { + CheckElementalConformance(messages, proc, actuals, localContext); + } + if (intrinsic) { + CheckSpecificIntrinsic(actuals, localContext, scope, *intrinsic); } return buffer; } -parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc, - evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context, - const Scope &scope, const evaluate::SpecificIntrinsic *intrinsic) { - return CheckExplicitInterface( - proc, actuals, context, &scope, intrinsic, true); -} - bool CheckInterfaceForGeneric(const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context, bool allowActualArgumentConversions) { @@ -1007,8 +1154,8 @@ } } if (explicitInterface) { - auto buffer{ - CheckExplicitInterface(proc, actuals, context, scope, intrinsic)}; + auto buffer{CheckExplicitInterface( + proc, actuals, context, &scope, intrinsic, true)}; if (!buffer.empty()) { if (treatingExternalAsImplicit && !buffer.empty()) { if (auto *msg{messages.Say( diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp --- a/flang/lib/Semantics/definable.cpp +++ b/flang/lib/Semantics/definable.cpp @@ -289,6 +289,10 @@ } } } + if (evaluate::IsNullPointer(expr)) { + return parser::Message{ + at, "'%s' is a null pointer"_because_en_US, expr.AsFortran()}; + } return parser::Message{ at, "'%s' is not a variable or pointer"_because_en_US, expr.AsFortran()}; } diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2766,28 +2766,24 @@ "References to the procedure '%s' require an explicit interface"_err_en_US, DEREF(procSymbol).name()); } - // Checks for ASSOCIATED() are done in intrinsic table processing const SpecificIntrinsic *specificIntrinsic{proc.GetSpecificIntrinsic()}; - bool procIsAssociated{ - specificIntrinsic && specificIntrinsic->name == "associated"}; - if (!procIsAssociated) { - bool procIsDummy{procSymbol && IsDummy(*procSymbol)}; - if (chars->functionResult && - chars->functionResult->IsAssumedLengthCharacter() && - !specificIntrinsic && !procIsDummy) { + bool procIsDummy{procSymbol && IsDummy(*procSymbol)}; + if (chars->functionResult && + chars->functionResult->IsAssumedLengthCharacter() && + !specificIntrinsic && !procIsDummy) { + Say(callSite, + "Assumed-length character function must be defined with a length to be called"_err_en_US); + } + ok &= semantics::CheckArguments(*chars, arguments, GetFoldingContext(), + context_.FindScope(callSite), treatExternalAsImplicit, + specificIntrinsic); + if (procSymbol && !IsPureProcedure(*procSymbol)) { + if (const semantics::Scope * + pure{semantics::FindPureProcedureContaining( + context_.FindScope(callSite))}) { Say(callSite, - "Assumed-length character function must be defined with a length to be called"_err_en_US); - } - ok &= semantics::CheckArguments(*chars, arguments, GetFoldingContext(), - context_.FindScope(callSite), treatExternalAsImplicit, - specificIntrinsic); - if (procSymbol && !IsPureProcedure(*procSymbol)) { - if (const semantics::Scope *pure{semantics::FindPureProcedureContaining( - context_.FindScope(callSite))}) { - Say(callSite, - "Procedure '%s' referenced in pure subprogram '%s' must be pure too"_err_en_US, - procSymbol->name(), DEREF(pure->symbol()).name()); - } + "Procedure '%s' referenced in pure subprogram '%s' must be pure too"_err_en_US, + procSymbol->name(), DEREF(pure->symbol()).name()); } } } diff --git a/flang/test/Evaluate/folding06.f90 b/flang/test/Evaluate/folding06.f90 --- a/flang/test/Evaluate/folding06.f90 +++ b/flang/test/Evaluate/folding06.f90 @@ -7,10 +7,16 @@ integer, pointer :: int_pointer integer, allocatable :: int_allocatable logical, parameter :: test_Assoc1 = .not.(associated(null())) + !WARN: portability: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement + !WARN: because: 'NULL()' is a null pointer logical, parameter :: test_Assoc2 = .not.(associated(null(), null())) logical, parameter :: test_Assoc3 = .not.(associated(null(int_pointer))) logical, parameter :: test_Assoc4 = .not.(associated(null(int_allocatable))) + !WARN: portability: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement + !WARN: because: 'NULL()' is a null pointer logical, parameter :: test_Assoc5 = .not.(associated(null(), null(int_pointer))) + !WARN: portability: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement + !WARN: because: 'NULL()' is a null pointer logical, parameter :: test_Assoc6 = .not.(associated(null(), null(int_allocatable))) type A diff --git a/flang/test/Semantics/associated.f90 b/flang/test/Semantics/associated.f90 --- a/flang/test/Semantics/associated.f90 +++ b/flang/test/Semantics/associated.f90 @@ -84,10 +84,15 @@ lVar = associated(null(intAllocVar)) !OK lVar = associated(null()) !OK lVar = associated(null(intPointerVar1)) !OK + !PORTABILITY: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement + !BECAUSE: 'NULL()' is a null pointer lVar = associated(null(), null()) !OK lVar = associated(intPointerVar1, null(intPointerVar2)) !OK lVar = associated(intPointerVar1, null()) !OK + !PORTABILITY: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement + !BECAUSE: 'NULL()' is a null pointer lVar = associated(null(), null(intPointerVar1)) !OK + !PORTABILITY: POINTER= argument of ASSOCIATED() should be a pointer lVar = associated(null(intPointerVar1), null()) !OK !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER lVar = associated(intVar) @@ -141,6 +146,7 @@ !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible procedure attributes: Elemental intProcPointer1 => elementalProc !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 lvar = associated (intPointerVar1, intFunc)