[flang-commits] [flang] c757418 - [flang] Failed call to CHECK() for call to ASSOCIATED(NULL())
Peter Steinfeld via flang-commits
flang-commits at lists.llvm.org
Fri Oct 16 07:17:29 PDT 2020
Author: Peter Steinfeld
Date: 2020-10-16T07:12:57-07:00
New Revision: c757418869c01f5ee08f05661debabbba92edcf9
URL: https://github.com/llvm/llvm-project/commit/c757418869c01f5ee08f05661debabbba92edcf9
DIFF: https://github.com/llvm/llvm-project/commit/c757418869c01f5ee08f05661debabbba92edcf9.diff
LOG: [flang] Failed call to CHECK() for call to ASSOCIATED(NULL())
Calling "ASSOCATED(NULL()) was causing an internal check of the compiler to
fail.
I fixed this by changing the entry for "ASSOCIATED" in the intrinsics table to
accept "AnyPointer" which contains a new "KindCode" of "pointerType". I also
changed the function "FromActual()" to return a typeless intrinsic when called
on a pointer, which duplicates its behavior for BOZ literals. This required
changing the analysis of procedure arguments. While testing processing for
procedure arguments, I found another bad call to `CHECK()` which I fixed.
I made several other changes:
-- I implemented constant folding for ASSOCIATED().
-- I fixed handling of NULL() in relational operations.
-- I implemented semantic analysis for ASSOCIATED().
-- I noticed that the semantics for ASSOCIATED() are similar to those for
pointer assignment. So I extracted the code that pointer assignment uses
for procedure pointer compatibility to a place where it could be used by
the semantic analysis for ASSOCIATED().
-- I couldn't figure out how to make the general semantic analysis for
procedure arguments work with ASSOCIATED()'s second argument, which can
be either a pointer or a target. So I stopped using normal semantic
analysis for arguments for ASSOCIATED().
-- I added tests for all of this.
Differential Revision: https://reviews.llvm.org/D88313
Added:
flang/test/Semantics/associated.f90
Modified:
flang/include/flang/Evaluate/characteristics.h
flang/include/flang/Evaluate/tools.h
flang/include/flang/Evaluate/type.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/fold-logical.cpp
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/pointer-assignment.cpp
flang/test/Evaluate/folding06.f90
flang/test/Semantics/call02.f90
flang/test/Semantics/call09.f90
flang/test/Semantics/resolve63.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 5d3058694cf9..a0e4cc5bedad 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -234,6 +234,7 @@ struct DummyArgument {
bool IsOptional() const;
void SetOptional(bool = true);
bool CanBePassedViaImplicitInterface() const;
+ bool IsTypelessIntrinsicDummy() const;
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
// name and pass are not characteristics and so does not participate in
// operator== but are needed to determine if procedures are distinguishable
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 98d4a516054e..4ae85b9c0d56 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -892,6 +892,13 @@ template <typename T> bool IsExpandableScalar(const Expr<T> &expr) {
return !UnexpandabilityFindingVisitor{}(expr);
}
+// Common handling for procedure pointer compatibility of left- and right-hand
+// sides. Returns nullopt if they're compatible. Otherwise, it returns a
+// message that needs to be augmented by the names of the left and right sides
+std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
+ const std::optional<characteristics::Procedure> &lhsProcedure,
+ const characteristics::Procedure *rhsProcedure);
+
} // namespace Fortran::evaluate
namespace Fortran::semantics {
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index 0619f9290cbf..fc274bf05398 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -103,7 +103,8 @@ class DynamicType {
// A rare use case used for representing the characteristics of an
// intrinsic function like REAL() that accepts a typeless BOZ literal
- // argument, which is something that real user Fortran can't do.
+ // argument and for typeless pointers -- things that real user Fortran can't
+ // do.
static constexpr DynamicType TypelessIntrinsicArgument() {
DynamicType result;
result.category_ = TypeCategory::Integer;
@@ -199,7 +200,8 @@ class DynamicType {
private:
// Special kind codes are used to distinguish the following Fortran types.
enum SpecialKind {
- TypelessKind = -1, // BOZ actual argument to intrinsic function
+ TypelessKind = -1, // BOZ actual argument to intrinsic function or pointer
+ // argument to ASSOCIATED
ClassKind = -2, // CLASS(T) or CLASS(*)
AssumedTypeKind = -3, // TYPE(*)
};
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 3206f0a25208..f42bde07b75b 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -381,7 +381,11 @@ std::optional<DummyArgument> DummyArgument::FromActual(
DummyDataObject{
TypeAndShape{DynamicType::TypelessIntrinsicArgument()}});
},
- [](const NullPointer &) { return std::optional<DummyArgument>{}; },
+ [&](const NullPointer &) {
+ return std::make_optional<DummyArgument>(std::move(name),
+ DummyDataObject{
+ TypeAndShape{DynamicType::TypelessIntrinsicArgument()}});
+ },
[&](const ProcedureDesignator &designator) {
if (auto proc{Procedure::Characterize(
designator, context.intrinsics())}) {
@@ -452,6 +456,11 @@ bool DummyArgument::CanBePassedViaImplicitInterface() const {
}
}
+bool DummyArgument::IsTypelessIntrinsicDummy() const {
+ const auto *argObj{std::get_if<characteristics::DummyDataObject>(&u)};
+ return argObj && argObj->type.type().IsTypelessIntrinsicArgument();
+}
+
llvm::raw_ostream &DummyArgument::Dump(llvm::raw_ostream &o) const {
if (!name.empty()) {
o << name << '=';
diff --git a/flang/lib/Evaluate/fold-logical.cpp b/flang/lib/Evaluate/fold-logical.cpp
index 99b95a962443..48f82125e2eb 100644
--- a/flang/lib/Evaluate/fold-logical.cpp
+++ b/flang/lib/Evaluate/fold-logical.cpp
@@ -46,6 +46,18 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
return Expr<T>{result};
}
}
+ } else if (name == "associated") {
+ bool gotConstant{true};
+ const Expr<SomeType> *firstArgExpr{args[0]->UnwrapExpr()};
+ if (!firstArgExpr || !IsNullPointer(*firstArgExpr)) {
+ gotConstant = false;
+ } else if (args[1]) { // There's a second argument
+ const Expr<SomeType> *secondArgExpr{args[1]->UnwrapExpr()};
+ if (!secondArgExpr || !IsNullPointer(*secondArgExpr)) {
+ gotConstant = false;
+ }
+ }
+ return gotConstant ? Expr<T>{false} : Expr<T>{std::move(funcRef)};
} else if (name == "bge" || name == "bgt" || name == "ble" || name == "blt") {
using LargestInt = Type<TypeCategory::Integer, 16>;
static_assert(std::is_same_v<Scalar<LargestInt>, BOZLiteralConstant>);
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 9744c18fc2e4..2cbf8ef2725d 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -84,6 +84,7 @@ ENUM_CLASS(KindCode, none, defaultIntegerKind,
subscript, // address-sized integer
size, // default KIND= for SIZE(), UBOUND, &c.
addressable, // for PRESENT(), &c.; anything (incl. procedure) but BOZ
+ nullPointerType, // for ASSOCIATED(NULL())
)
struct TypePattern {
@@ -152,6 +153,9 @@ static constexpr TypePattern SameType{AnyType, KindCode::same};
static constexpr TypePattern OperandReal{RealType, KindCode::operand};
static constexpr TypePattern OperandIntOrReal{IntOrRealType, KindCode::operand};
+// For ASSOCIATED, the first argument is a typeless pointer
+static constexpr TypePattern AnyPointer{AnyType, KindCode::nullPointerType};
+
// For DOT_PRODUCT and MATMUL, the result type depends on the arguments
static constexpr TypePattern ResultLogical{LogicalType, KindCode::likeMultiply};
static constexpr TypePattern ResultNumeric{NumericType, KindCode::likeMultiply};
@@ -278,7 +282,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"asind", {{"x", SameFloating}}, SameFloating},
{"asinh", {{"x", SameFloating}}, SameFloating},
{"associated",
- {{"pointer", Addressable, Rank::known},
+ {{"pointer", AnyPointer, Rank::known},
{"target", Addressable, Rank::known, Optionality::optional}},
DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction},
{"atan", {{"x", SameFloating}}, SameFloating},
@@ -1140,6 +1144,8 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
if (d.typePattern.kindCode == KindCode::addressable ||
d.rank == Rank::reduceOperation) {
continue;
+ } else if (d.typePattern.kindCode == KindCode::nullPointerType) {
+ continue;
} else {
messages.Say(
"Actual argument for '%s=' may not be a procedure"_err_en_US,
@@ -1214,6 +1220,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
d.keyword, name);
break;
case KindCode::addressable:
+ case KindCode::nullPointerType:
argOk = true;
break;
default:
@@ -1504,6 +1511,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
// Characterize the specific intrinsic procedure.
characteristics::DummyArguments dummyArgs;
std::optional<int> sameDummyArg;
+
for (std::size_t j{0}; j < dummies; ++j) {
const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
if (const auto &arg{rearranged[j]}) {
@@ -1707,6 +1715,7 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1) &&
arguments[0]) {
if (Expr<SomeType> * mold{arguments[0]->UnwrapExpr()}) {
+ bool goodProcPointer{true};
if (IsAllocatableOrPointer(*mold)) {
characteristics::DummyArguments args;
std::optional<characteristics::FunctionResult> fResult;
@@ -1716,10 +1725,15 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
CHECK(last);
auto procPointer{
characteristics::Procedure::Characterize(*last, intrinsics)};
- CHECK(procPointer);
- args.emplace_back("mold"s,
- characteristics::DummyProcedure{common::Clone(*procPointer)});
- fResult.emplace(std::move(*procPointer));
+ // procPointer is null if there was an error with the analysis
+ // associated with the procedure pointer
+ if (procPointer) {
+ args.emplace_back("mold"s,
+ characteristics::DummyProcedure{common::Clone(*procPointer)});
+ fResult.emplace(std::move(*procPointer));
+ } else {
+ goodProcPointer = false;
+ }
} else if (auto type{mold->GetType()}) {
// MOLD= object pointer
characteristics::TypeAndShape typeAndShape{
@@ -1731,13 +1745,15 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
context.messages().Say(
"MOLD= argument to NULL() lacks type"_err_en_US);
}
- fResult->attrs.set(characteristics::FunctionResult::Attr::Pointer);
- characteristics::Procedure::Attrs attrs;
- attrs.set(characteristics::Procedure::Attr::NullPointer);
- characteristics::Procedure chars{
- std::move(*fResult), std::move(args), attrs};
- return SpecificCall{
- SpecificIntrinsic{"null"s, std::move(chars)}, std::move(arguments)};
+ if (goodProcPointer) {
+ fResult->attrs.set(characteristics::FunctionResult::Attr::Pointer);
+ characteristics::Procedure::Attrs attrs;
+ attrs.set(characteristics::Procedure::Attr::NullPointer);
+ characteristics::Procedure chars{
+ std::move(*fResult), std::move(args), attrs};
+ return SpecificCall{SpecificIntrinsic{"null"s, std::move(chars)},
+ std::move(arguments)};
+ }
}
}
context.messages().Say(
@@ -1833,9 +1849,105 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
}
}
+static bool CheckAssociated(SpecificCall &call,
+ parser::ContextualMessages &messages,
+ const IntrinsicProcTable &intrinsics) {
+ 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(
+ messages.Say("POINTER= argument of ASSOCIATED() must be a "
+ "POINTER"_err_en_US),
+ *pointerSymbol);
+ } else {
+ const auto pointerProc{characteristics::Procedure::Characterize(
+ *pointerSymbol, intrinsics)};
+ if (const auto &targetArg{call.arguments[1]}) {
+ if (const auto *targetExpr{targetArg->UnwrapExpr()}) {
+ std::optional<characteristics::Procedure> targetProc{
+ std::nullopt};
+ 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, intrinsics)}) {
+ targetProc = *targetRefedChars;
+ targetName = targetProcRef->proc().GetName() + "()";
+ isCall = true;
+ }
+ } else if (targetSymbol && !targetProc) {
+ // proc that's not a call
+ targetProc = characteristics::Procedure::Characterize(
+ *targetSymbol, intrinsics);
+ targetName = targetSymbol->name().ToString();
+ }
+
+ if (pointerProc) {
+ if (targetProc) {
+ // procedure pointer and procedure target
+ if (std::optional<parser::MessageFixedText> msg{
+ CheckProcCompatibility(
+ isCall, pointerProc, &*targetProc)}) {
+ AttachDeclaration(
+ messages.Say(std::move(*msg),
+ "pointer '" + pointerSymbol->name().ToString() +
+ "'",
+ targetName),
+ *pointerSymbol);
+ }
+ } else {
+ // procedure pointer and object target
+ if (!IsNullPointer(*targetExpr)) {
+ AttachDeclaration(
+ 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(
+ 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 {
+ // object pointer and target
+ 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) {
+ messages.Say(
+ "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US);
+ }
+ return ok;
+}
+
// Applies any semantic checks peculiar to an intrinsic.
-static bool ApplySpecificChecks(
- SpecificCall &call, parser::ContextualMessages &messages) {
+static bool ApplySpecificChecks(SpecificCall &call,
+ parser::ContextualMessages &messages,
+ const IntrinsicProcTable &intrinsics) {
bool ok{true};
const std::string &name{call.specificIntrinsic.name};
if (name == "allocated") {
@@ -1851,18 +1963,7 @@ static bool ApplySpecificChecks(
"Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
}
} else if (name == "associated") {
- if (const auto &arg{call.arguments[0]}) {
- if (const auto *expr{arg->UnwrapExpr()}) {
- if (const Symbol * symbol{GetLastSymbol(*expr)}) {
- ok = symbol->attrs().test(semantics::Attr::POINTER);
- // TODO: validate the TARGET= argument vs. the pointer
- }
- }
- }
- if (!ok) {
- messages.Say(
- "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US);
- }
+ return CheckAssociated(call, messages, intrinsics);
} else if (name == "loc") {
if (const auto &arg{call.arguments[0]}) {
ok = arg->GetAssumedTypeDummy() || GetLastSymbol(arg->UnwrapExpr());
@@ -1964,7 +2065,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
for (auto iter{genericRange.first}; iter != genericRange.second; ++iter) {
if (auto specificCall{
matchOrBufferMessages(*iter->second, genericBuffer)}) {
- ApplySpecificChecks(*specificCall, context.messages());
+ ApplySpecificChecks(*specificCall, context.messages(), intrinsics);
return specificCall;
}
}
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index b560cce1192d..22b881a98a7f 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -870,6 +870,62 @@ std::optional<std::string> FindImpureCall(
return FindImpureCallHelper{intrinsics}(proc);
}
+// Compare procedure characteristics for equality except that lhs may be
+// Pure or Elemental when rhs is not.
+static bool CharacteristicsMatch(const characteristics::Procedure &lhs,
+ const characteristics::Procedure &rhs) {
+ using Attr = characteristics::Procedure::Attr;
+ auto lhsAttrs{rhs.attrs};
+ lhsAttrs.set(
+ Attr::Pure, lhs.attrs.test(Attr::Pure) | rhs.attrs.test(Attr::Pure));
+ lhsAttrs.set(Attr::Elemental,
+ lhs.attrs.test(Attr::Elemental) | rhs.attrs.test(Attr::Elemental));
+ return lhsAttrs == rhs.attrs && lhs.functionResult == rhs.functionResult &&
+ lhs.dummyArguments == rhs.dummyArguments;
+}
+
+// Common handling for procedure pointer compatibility of left- and right-hand
+// sides. Returns nullopt if they're compatible. Otherwise, it returns a
+// message that needs to be augmented by the names of the left and right sides
+std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
+ const std::optional<characteristics::Procedure> &lhsProcedure,
+ const characteristics::Procedure *rhsProcedure) {
+ std::optional<parser::MessageFixedText> msg;
+ if (!lhsProcedure) {
+ msg = "In assignment to object %s, the target '%s' is a procedure"
+ " designator"_err_en_US;
+ } else if (!rhsProcedure) {
+ msg = "In assignment to procedure %s, the characteristics of the target"
+ " procedure '%s' could not be determined"_err_en_US;
+ } else if (CharacteristicsMatch(*lhsProcedure, *rhsProcedure)) {
+ // OK
+ } else if (isCall) {
+ msg = "Procedure %s associated with result of reference to function '%s'"
+ " that is an incompatible procedure pointer"_err_en_US;
+ } else if (lhsProcedure->IsPure() && !rhsProcedure->IsPure()) {
+ msg = "PURE procedure %s may not be associated with non-PURE"
+ " procedure designator '%s'"_err_en_US;
+ } else if (lhsProcedure->IsFunction() && !rhsProcedure->IsFunction()) {
+ msg = "Function %s may not be associated with subroutine"
+ " designator '%s'"_err_en_US;
+ } else if (!lhsProcedure->IsFunction() && rhsProcedure->IsFunction()) {
+ msg = "Subroutine %s may not be associated with function"
+ " designator '%s'"_err_en_US;
+ } else if (lhsProcedure->HasExplicitInterface() &&
+ !rhsProcedure->HasExplicitInterface()) {
+ msg = "Procedure %s with explicit interface may not be associated with"
+ " procedure designator '%s' with implicit interface"_err_en_US;
+ } else if (!lhsProcedure->HasExplicitInterface() &&
+ rhsProcedure->HasExplicitInterface()) {
+ msg = "Procedure %s with implicit interface may not be associated with"
+ " procedure designator '%s' with explicit interface"_err_en_US;
+ } else {
+ msg = "Procedure %s associated with incompatible procedure"
+ " designator '%s'"_err_en_US;
+ }
+ return msg;
+}
+
} // namespace Fortran::evaluate
namespace Fortran::semantics {
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 74cf2f89479a..fcc395ad1f44 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -505,63 +505,67 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};
if (auto argChars{characteristics::DummyArgument::FromActual(
"actual argument", *expr, context)}) {
- if (auto *argProc{
- std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {
- characteristics::Procedure &argInterface{argProc->procedure.value()};
- argInterface.attrs.reset(characteristics::Procedure::Attr::NullPointer);
- if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) {
- // It's ok to pass ELEMENTAL unrestricted intrinsic functions.
- argInterface.attrs.reset(characteristics::Procedure::Attr::Elemental);
- } else if (argInterface.attrs.test(
- characteristics::Procedure::Attr::Elemental)) {
- if (argProcSymbol) { // C1533
- evaluate::SayWithDeclaration(messages, *argProcSymbol,
- "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
- argProcSymbol->name());
- return; // avoid piling on with checks below
- } else {
+ if (!argChars->IsTypelessIntrinsicDummy()) {
+ if (auto *argProc{
+ std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {
+ characteristics::Procedure &argInterface{argProc->procedure.value()};
+ argInterface.attrs.reset(
+ characteristics::Procedure::Attr::NullPointer);
+ if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) {
+ // It's ok to pass ELEMENTAL unrestricted intrinsic functions.
argInterface.attrs.reset(
- characteristics::Procedure::Attr::NullPointer);
+ characteristics::Procedure::Attr::Elemental);
+ } else if (argInterface.attrs.test(
+ characteristics::Procedure::Attr::Elemental)) {
+ if (argProcSymbol) { // C1533
+ evaluate::SayWithDeclaration(messages, *argProcSymbol,
+ "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
+ argProcSymbol->name());
+ return; // avoid piling on with checks below
+ } else {
+ argInterface.attrs.reset(
+ characteristics::Procedure::Attr::NullPointer);
+ }
}
- }
- if (!interface.IsPure()) {
- // 15.5.2.9(1): if dummy is not pure, actual need not be.
- argInterface.attrs.reset(characteristics::Procedure::Attr::Pure);
- }
- if (interface.HasExplicitInterface()) {
- if (interface != argInterface) {
- messages.Say(
- "Actual argument procedure has interface incompatible with %s"_err_en_US,
- dummyName);
+ if (!interface.IsPure()) {
+ // 15.5.2.9(1): if dummy is not pure, actual need not be.
+ argInterface.attrs.reset(characteristics::Procedure::Attr::Pure);
}
- } else { // 15.5.2.9(2,3)
- if (interface.IsSubroutine() && argInterface.IsFunction()) {
- messages.Say(
- "Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US,
- dummyName);
- } else if (interface.IsFunction()) {
- if (argInterface.IsFunction()) {
- if (interface.functionResult != argInterface.functionResult) {
+ if (interface.HasExplicitInterface()) {
+ if (interface != argInterface) {
+ messages.Say(
+ "Actual argument procedure has interface incompatible with %s"_err_en_US,
+ dummyName);
+ }
+ } else { // 15.5.2.9(2,3)
+ if (interface.IsSubroutine() && argInterface.IsFunction()) {
+ messages.Say(
+ "Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US,
+ dummyName);
+ } else if (interface.IsFunction()) {
+ if (argInterface.IsFunction()) {
+ if (interface.functionResult != argInterface.functionResult) {
+ messages.Say(
+ "Actual argument function associated with procedure %s has incompatible result type"_err_en_US,
+ dummyName);
+ }
+ } else if (argInterface.IsSubroutine()) {
messages.Say(
- "Actual argument function associated with procedure %s has incompatible result type"_err_en_US,
+ "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,
dummyName);
}
- } else if (argInterface.IsSubroutine()) {
- messages.Say(
- "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,
- dummyName);
}
}
+ } else {
+ messages.Say(
+ "Actual argument associated with procedure %s is not a procedure"_err_en_US,
+ dummyName);
}
- } else {
+ } else if (!(dummyIsPointer && IsNullPointer(*expr))) {
messages.Say(
"Actual argument associated with procedure %s is not a procedure"_err_en_US,
dummyName);
}
- } else if (!(dummyIsPointer && IsNullPointer(*expr))) {
- messages.Say(
- "Actual argument associated with procedure %s is not a procedure"_err_en_US,
- dummyName);
}
if (interface.HasExplicitInterface()) {
if (dummyIsPointer) {
@@ -610,6 +614,9 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
std::holds_alternative<evaluate::BOZLiteralConstant>(
expr->u)) {
// ok
+ } else if (object.type.type().IsTypelessIntrinsicArgument() &&
+ evaluate::IsNullPointer(*expr)) {
+ // ok, calling ASSOCIATED(NULL())
} else {
messages.Say(
"Actual argument '%s' associated with %s is not a variable or typed expression"_err_en_US,
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 661024f6990d..57de714edaff 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2147,16 +2147,26 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
"References to the procedure '%s' require an explicit interface"_en_US,
DEREF(proc.GetSymbol()).name());
}
- semantics::CheckArguments(*chars, arguments, GetFoldingContext(),
- context_.FindScope(callSite), treatExternalAsImplicit);
- const Symbol *procSymbol{proc.GetSymbol()};
- 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());
+ // Checks for ASSOCIATED() are done in intrinsic table processing
+ bool procIsAssociated{false};
+ if (const SpecificIntrinsic *
+ specificIntrinsic{proc.GetSpecificIntrinsic()}) {
+ if (specificIntrinsic->name == "associated") {
+ procIsAssociated = true;
+ }
+ }
+ if (!procIsAssociated) {
+ semantics::CheckArguments(*chars, arguments, GetFoldingContext(),
+ context_.FindScope(callSite), treatExternalAsImplicit);
+ const Symbol *procSymbol{proc.GetSymbol()};
+ 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());
+ }
}
}
}
@@ -2346,6 +2356,12 @@ MaybeExpr RelationHelper(ExpressionAnalyzer &context, RelationalOperator opr,
if (analyzer.fatalErrors()) {
return std::nullopt;
} else {
+ if (IsNullPointer(analyzer.GetExpr(0)) ||
+ IsNullPointer(analyzer.GetExpr(1))) {
+ context.Say("NULL() not allowed as an operand of a relational "
+ "operator"_err_en_US);
+ return std::nullopt;
+ }
analyzer.ConvertBOZ(0, analyzer.GetType(1));
analyzer.ConvertBOZ(1, analyzer.GetType(0));
if (analyzer.IsIntrinsicRelational(opr)) {
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 735e842411b1..761d66482e24 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -250,59 +250,11 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
return true;
}
-// Compare procedure characteristics for equality except that lhs may be
-// Pure or Elemental when rhs is not.
-static bool CharacteristicsMatch(const Procedure &lhs, const Procedure &rhs) {
- using Attr = Procedure::Attr;
- auto lhsAttrs{rhs.attrs};
- lhsAttrs.set(
- Attr::Pure, lhs.attrs.test(Attr::Pure) | rhs.attrs.test(Attr::Pure));
- lhsAttrs.set(Attr::Elemental,
- lhs.attrs.test(Attr::Elemental) | rhs.attrs.test(Attr::Elemental));
- return lhsAttrs == rhs.attrs && lhs.functionResult == rhs.functionResult &&
- lhs.dummyArguments == rhs.dummyArguments;
-}
-
// Common handling for procedure pointer right-hand sides
bool PointerAssignmentChecker::Check(
parser::CharBlock rhsName, bool isCall, const Procedure *rhsProcedure) {
- std::optional<MessageFixedText> msg;
- if (!procedure_) {
- msg = "In assignment to object %s, the target '%s' is a procedure"
- " designator"_err_en_US;
- } else if (!rhsProcedure) {
- msg = "In assignment to procedure %s, the characteristics of the target"
- " procedure '%s' could not be determined"_err_en_US;
- } else if (CharacteristicsMatch(*procedure_, *rhsProcedure)) {
- // OK
- } else if (isCall) {
- msg = "Procedure %s associated with result of reference to function '%s'"
- " that is an incompatible procedure pointer"_err_en_US;
- } else if (procedure_->IsPure() && !rhsProcedure->IsPure()) {
- msg = "PURE procedure %s may not be associated with non-PURE"
- " procedure designator '%s'"_err_en_US;
- } else if (procedure_->IsElemental() && !rhsProcedure->IsElemental()) {
- msg = "ELEMENTAL procedure %s may not be associated with non-ELEMENTAL"
- " procedure designator '%s'"_err_en_US;
- } else if (procedure_->IsFunction() && !rhsProcedure->IsFunction()) {
- msg = "Function %s may not be associated with subroutine"
- " designator '%s'"_err_en_US;
- } else if (!procedure_->IsFunction() && rhsProcedure->IsFunction()) {
- msg = "Subroutine %s may not be associated with function"
- " designator '%s'"_err_en_US;
- } else if (procedure_->HasExplicitInterface() &&
- !rhsProcedure->HasExplicitInterface()) {
- msg = "Procedure %s with explicit interface may not be associated with"
- " procedure designator '%s' with implicit interface"_err_en_US;
- } else if (!procedure_->HasExplicitInterface() &&
- rhsProcedure->HasExplicitInterface()) {
- msg = "Procedure %s with implicit interface may not be associated with"
- " procedure designator '%s' with explicit interface"_err_en_US;
- } else {
- msg = "Procedure %s associated with incompatible procedure"
- " designator '%s'"_err_en_US;
- }
- if (msg) {
+ if (std::optional<MessageFixedText> msg{
+ evaluate::CheckProcCompatibility(isCall, procedure_, rhsProcedure)}) {
Say(std::move(*msg), description_, rhsName);
return false;
}
diff --git a/flang/test/Evaluate/folding06.f90 b/flang/test/Evaluate/folding06.f90
index 3cfe3098ba1d..d3cbf1b663e3 100644
--- a/flang/test/Evaluate/folding06.f90
+++ b/flang/test/Evaluate/folding06.f90
@@ -3,6 +3,16 @@
module m
+ ! Testing ASSOCATED
+ integer, pointer :: int_pointer
+ integer, allocatable :: int_allocatable
+ logical, parameter :: test_Assoc1 = .not.(associated(null()))
+ 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)))
+ logical, parameter :: test_Assoc5 = .not.(associated(null(), null(int_pointer)))
+ logical, parameter :: test_Assoc6 = .not.(associated(null(), null(int_allocatable)))
+
type A
real(4) x
integer(8) i
diff --git a/flang/test/Semantics/associated.f90 b/flang/test/Semantics/associated.f90
new file mode 100644
index 000000000000..b78ccb017b16
--- /dev/null
+++ b/flang/test/Semantics/associated.f90
@@ -0,0 +1,149 @@
+! RUN: %S/test_errors.sh %s %t %f18
+! Tests for the ASSOCIATED() and NULL() intrinsics
+subroutine assoc()
+
+ abstract interface
+ subroutine subrInt(i)
+ integer :: i
+ end subroutine subrInt
+
+ integer function abstractIntFunc(x)
+ integer, intent(in) :: x
+ end function
+ end interface
+
+ contains
+ integer function intFunc(x)
+ integer, intent(in) :: x
+ intFunc = x
+ end function
+
+ real function realFunc(x)
+ real, intent(in) :: x
+ realFunc = x
+ end function
+
+ pure integer function pureFunc()
+ pureFunc = 343
+ end function pureFunc
+
+ elemental integer function elementalFunc()
+ elementalFunc = 343
+ end function elementalFunc
+
+ subroutine subr(i)
+ integer :: i
+ end subroutine subr
+
+ subroutine test()
+ integer :: intVar
+ integer, target :: targetIntVar1
+ integer(kind=2), target :: targetIntVar2
+ real, target :: targetRealVar
+ integer, pointer :: intPointerVar1
+ integer, pointer :: intPointerVar2
+ integer, allocatable :: intAllocVar
+ procedure(intFunc) :: intProc
+ procedure(intFunc), pointer :: intprocPointer1
+ procedure(intFunc), pointer :: intprocPointer2
+ procedure(realFunc) :: realProc
+ procedure(realFunc), pointer :: realprocPointer1
+ procedure(pureFunc), pointer :: pureFuncPointer
+ procedure(elementalFunc) :: elementalProc
+ external :: externalProc
+ procedure(subrInt) :: subProc
+ procedure(subrInt), pointer :: subProcPointer
+ procedure(), pointer :: implicitProcPointer
+ logical :: lVar
+
+ !ERROR: missing mandatory 'pointer=' argument
+ lVar = associated()
+ !ERROR: MOLD= argument to NULL() must be a pointer or allocatable
+ lVar = associated(null(intVar))
+ lVar = associated(null(intAllocVar)) !OK
+ lVar = associated(null()) !OK
+ lVar = associated(null(intPointerVar1)) !OK
+ lVar = associated(null(), null()) !OK
+ lVar = associated(intPointerVar1, null(intPointerVar2)) !OK
+ lVar = associated(intPointerVar1, null()) !OK
+ lVar = associated(null(), null(intPointerVar1)) !OK
+ lVar = associated(null(intPointerVar1), null()) !OK
+ !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+ lVar = associated(intVar)
+ !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+ lVar = associated(intVar, intVar)
+ !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+ lVar = associated(intAllocVar)
+ lVar = associated(intPointerVar1, intVar) !OK
+ !ERROR: Arguments of ASSOCIATED() must be a POINTER and an optional valid target
+ lVar = associated(intPointerVar1, targetRealVar)
+ lVar = associated(intPointerVar1, targetIntVar1) !OK
+ !ERROR: Arguments of ASSOCIATED() must be a POINTER and an optional valid target
+ lVar = associated(intPointerVar1, targetIntVar2)
+ lVar = associated(intPointerVar1) !OK
+ lVar = associated(intPointerVar1, intPointerVar2) !OK
+
+ ! Procedure pointer tests
+ intprocPointer1 => intProc !OK
+ lVar = associated(intprocPointer1, intProc) !OK
+ intprocPointer1 => intProcPointer2 !OK
+ lVar = associated(intprocPointer1, intProcPointer2) !OK
+ intProcPointer1 => null(intProcPointer2) ! ok
+ lvar = associated(intProcPointer1, null(intProcPointer2)) ! ok
+ intProcPointer1 => null() ! ok
+ lvar = associated(intProcPointer1, null()) ! ok
+ intProcPointer1 => intProcPointer2 ! ok
+ lvar = associated(intProcPointer1, intProcPointer2) ! ok
+ intProcPointer1 => null(intProcPointer2) ! ok
+ lvar = associated(intProcPointer1, null(intProcPointer2)) ! ok
+ intProcPointer1 =>null() ! ok
+ lvar = associated(intProcPointer1, null()) ! ok
+ intPointerVar1 => null(intPointerVar1) ! ok
+ lvar = associated (intPointerVar1, null(intPointerVar1)) ! ok
+
+ !ERROR: In assignment to procedure pointer 'intprocpointer1', the target is not a procedure or procedure pointer
+ intprocPointer1 => intVar
+ !ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'intvar' is not a procedure or procedure pointer
+ lVar = associated(intprocPointer1, intVar)
+ !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc'
+ intProcPointer1 => elementalProc
+ !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc'
+ 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)
+ !ERROR: In assignment to object pointer 'intpointervar1', the target 'intfunc' is a procedure designator
+ intPointerVar1 => intFunc
+ !ERROR: In assignment to procedure pointer 'intprocpointer1', the target is not a procedure or procedure pointer
+ intProcPointer1 => targetIntVar1
+ !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: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null' that is an incompatible procedure pointer
+ intProcPointer1 => null(mold=realProcPointer1)
+ !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null()' that is an incompatible procedure pointer
+ lvar = associated(intProcPointer1, null(mold=realProcPointer1))
+ !ERROR: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
+ pureFuncPointer => intProc
+ !ERROR: PURE procedure pointer 'purefuncpointer' may not be associated with non-PURE procedure designator 'intproc'
+ lvar = associated(pureFuncPointer, intProc)
+ !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc'
+ realProcPointer1 => intProc
+ !ERROR: Procedure pointer 'realprocpointer1' associated with incompatible procedure designator 'intproc'
+ lvar = associated(realProcPointer1, intProc)
+ !ERROR: Procedure pointer 'subprocpointer' with explicit interface may not be associated with procedure designator 'externalproc' with implicit interface
+ subProcPointer => externalProc
+ !ERROR: Procedure pointer 'subprocpointer' with explicit interface may not be associated with procedure designator 'externalproc' with implicit interface
+ lvar = associated(subProcPointer, externalProc)
+ !ERROR: Subroutine pointer 'subprocpointer' may not be associated with function designator 'intproc'
+ subProcPointer => intProc
+ !ERROR: Subroutine pointer 'subprocpointer' may not be associated with function designator 'intproc'
+ lvar = associated(subProcPointer, intProc)
+ !ERROR: Function pointer 'intprocpointer1' may not be associated with subroutine designator 'subproc'
+ intProcPointer1 => subProc
+ !ERROR: Function pointer 'intprocpointer1' may not be associated with subroutine designator 'subproc'
+ lvar = associated(intProcPointer1, subProc)
+ !ERROR: Procedure pointer 'implicitprocpointer' with implicit interface may not be associated with procedure designator 'subr' with explicit interface
+ implicitProcPointer => subr
+ !ERROR: Procedure pointer 'implicitprocpointer' with implicit interface may not be associated with procedure designator 'subr' with explicit interface
+ lvar = associated(implicitProcPointer, subr)
+ end subroutine test
+end subroutine assoc
diff --git a/flang/test/Semantics/call02.f90 b/flang/test/Semantics/call02.f90
index 2012544894f4..4418837d61ea 100644
--- a/flang/test/Semantics/call02.f90
+++ b/flang/test/Semantics/call02.f90
@@ -19,6 +19,12 @@ subroutine badsubr(dummy)
call subr(cos) ! not an error
!ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument
call subr(elem) ! C1533
+ !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is not a procedure
+ !ERROR: Actual argument associated with non-POINTER procedure dummy argument 'dummy=' must be a procedure (and not a procedure pointer)
+ call subr(null())
+ !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is not a procedure
+ !ERROR: Actual argument associated with non-POINTER procedure dummy argument 'dummy=' must be a procedure (and not a procedure pointer)
+ call subr(B"1010")
end subroutine
module m01
diff --git a/flang/test/Semantics/call09.f90 b/flang/test/Semantics/call09.f90
index 577867aaa333..8c21d376fd60 100644
--- a/flang/test/Semantics/call09.f90
+++ b/flang/test/Semantics/call09.f90
@@ -46,6 +46,7 @@ subroutine test1 ! 15.5.2.9(5)
intrinsic :: sin
procedure(realfunc), pointer :: p
procedure(intfunc), pointer :: ip
+ integer, pointer :: intPtr
p => realfunc
ip => intfunc
call s01(realfunc) ! ok
@@ -60,6 +61,10 @@ subroutine test1 ! 15.5.2.9(5)
!ERROR: Actual argument procedure has interface incompatible with dummy argument 'p='
call s01(null(ip))
call s01(sin) ! ok
+ !ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure
+ call s01(null(intPtr))
+ !ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure
+ call s01(B"0101")
!ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
call s02(realfunc)
call s02(p) ! ok
diff --git a/flang/test/Semantics/resolve63.f90 b/flang/test/Semantics/resolve63.f90
index 141945a26227..7fe6facf0511 100644
--- a/flang/test/Semantics/resolve63.f90
+++ b/flang/test/Semantics/resolve63.f90
@@ -161,6 +161,7 @@ logical function add(x, y)
subroutine s1(x, y)
logical :: x
integer :: y
+ integer, pointer :: px
logical :: l
complex :: z
y = y + z'1' !OK
@@ -171,8 +172,18 @@ subroutine s1(x, y)
y = -z'1'
!ERROR: Operands of + must be numeric; have LOGICAL(4) and untyped
y = x + z'1'
- !ERROR: Operands of .NE. must have comparable types; have LOGICAL(4) and untyped
+ !ERROR: NULL() not allowed as an operand of a relational operator
l = x /= null()
+ !ERROR: NULL() not allowed as an operand of a relational operator
+ l = null(px) /= null(px)
+ !ERROR: NULL() not allowed as an operand of a relational operator
+ l = x /= null(px)
+ !ERROR: NULL() not allowed as an operand of a relational operator
+ l = px /= null()
+ !ERROR: NULL() not allowed as an operand of a relational operator
+ l = px /= null(px)
+ !ERROR: NULL() not allowed as an operand of a relational operator
+ l = null() /= null()
end
end
More information about the flang-commits
mailing list