[flang-commits] [flang] aad5984 - [flang] Portability warnings for an ambiguous ASSOCIATED() case
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Fri Jan 27 16:51:13 PST 2023
Author: Peter Klausler
Date: 2023-01-27T16:51:03-08:00
New Revision: aad5984b56280d7dc71a43c258c5ed349c9a239f
URL: https://github.com/llvm/llvm-project/commit/aad5984b56280d7dc71a43c258c5ed349c9a239f
DIFF: https://github.com/llvm/llvm-project/commit/aad5984b56280d7dc71a43c258c5ed349c9a239f.diff
LOG: [flang] Portability warnings for an ambiguous ASSOCIATED() case
The standard's specification for the ASSOCIATED() intrinsic function
describes its optional second argument (TARGET=) as being required
to be a valid target for a pointer assignment statement in which the
first argument (POINTER=) was the left-hand side. Some Fortran compilers
apparently interpret this text as a requirement that the POINTER= argument
actually be a valid left-hand side to a pointer assignment statement,
and emit an error if it is not so. This particularly affects the
use of an explicit NULL pointer as the first argument.
Such usage is well-defined, benign, useful, and supported by at least
two other compilers, so we should continue to accept it. This patch
adds a portability warning and some documentation.
In order to implement the portability warning in the best way, the
special checks on calls to the ASSOCIATED() intrinsic function have
been moved from intrinsic processing to Semantics/check-calls.cpp,
whence they have access to semantics' toolchest. Special checks for
other intrinsic functions might also migrate in the future in order
to keep them all in one place.
Differential Revision: https://reviews.llvm.org/D142768
Added:
Modified:
flang/docs/Extensions.md
flang/include/flang/Evaluate/tools.h
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/check-call.h
flang/lib/Semantics/definable.cpp
flang/lib/Semantics/expression.cpp
flang/test/Evaluate/folding06.f90
flang/test/Semantics/associated.f90
Removed:
################################################################################
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 31f2fda8c4cc8..928fe07a79068 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -527,6 +527,19 @@ end module
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
index 35e785843d9f4..291557153453b 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -970,6 +970,7 @@ bool IsAllocatableDesignator(const Expr<SomeType> &);
// Procedure and pointer detection predicates
bool IsProcedure(const Expr<SomeType> &);
bool IsFunction(const Expr<SomeType> &);
+bool IsProcedurePointer(const Expr<SomeType> &);
bool IsProcedurePointerTarget(const Expr<SomeType> &);
bool IsBareNullPointer(const Expr<SomeType> *); // NULL() w/o MOLD= or type
bool IsNullObjectPointer(const Expr<SomeType> &);
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 6f4914d8fa715..9a1062d0478a6 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2656,129 +2656,6 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
}
}
-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<characteristics::Procedure> pointerProc, targetProc;
- const auto *targetProcDesignator{
- UnwrapExpr<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<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 (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<parser::MessageFixedText> 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 @@ static bool CheckAtomicDefineAndRef(FoldingContext &context,
}
// 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 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
"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
index 3b472e7249e4a..840932c0e0dd6 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -737,6 +737,18 @@ bool IsFunction(const Expr<SomeType> &expr) {
return designator && designator->GetType().has_value();
}
+bool IsProcedurePointer(const Expr<SomeType> &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<SomeType> &expr) {
return common::visit(common::visitors{
[](const NullPointer &) { return true; },
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 104ea7acb8d37..fc02b9127712e 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -930,6 +930,156 @@ static bool CheckElementalConformance(parser::ContextualMessages &messages,
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<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 (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)) {
+ // 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 @@ static parser::Messages CheckExplicitInterface(
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 @@ bool CheckArguments(const characteristics::Procedure &proc,
}
}
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/check-call.h b/flang/lib/Semantics/check-call.h
index cef77f39cc8cb..439bdd0241e3a 100644
--- a/flang/lib/Semantics/check-call.h
+++ b/flang/lib/Semantics/check-call.h
@@ -37,13 +37,6 @@ bool CheckArguments(const evaluate::characteristics::Procedure &,
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/definable.cpp b/flang/lib/Semantics/definable.cpp
index 092cfaf4ae46c..79d57d0b394fa 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -289,6 +289,10 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
}
}
}
+ 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
index cd418606521ab..9abb698d7d69d 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2766,28 +2766,24 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
"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
index 4dccedd931e50..cb954c2ac17eb 100644
--- a/flang/test/Evaluate/folding06.f90
+++ b/flang/test/Evaluate/folding06.f90
@@ -7,10 +7,16 @@ module m
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
index 6cb7a9386f796..c63668ea78695 100644
--- a/flang/test/Semantics/associated.f90
+++ b/flang/test/Semantics/associated.f90
@@ -84,10 +84,15 @@ subroutine test()
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 @@ subroutine test()
!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)
More information about the flang-commits
mailing list