From 22c359acdaf673da9bf675bb5fdf1eb2e3015bee Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Fri, 28 Feb 2025 16:59:13 -0800 Subject: [PATCH] [flang] Further work on NULL(MOLD=allocatable) Refine handling of NULL(...) in semantics to properly distinguish NULL(), NULL(objectPointer), NULL(procPointer), and NULL(allocatable) from each other in relevant contexts. Add IsNullAllocatable() and IsNullPointerOrAllocatable() utility functions. IsNullAllocatable() is true only for NULL(allocatable); it is false for a bare NULL(), which can be detected independently with IsBareNullPointer(). IsNullPointer() now returns false for NULL(allocatable). ALLOCATED(NULL(allocatable)) now works, and folds to .FALSE. These utilities were modified to accept const pointer arguments rather than const references; I usually prefer this style when the result should clearly be false for a null argument (in the C sense), and it helped me find all of their use sites in the code. --- .../include/flang/Evaluate/characteristics.h | 4 +- flang/include/flang/Evaluate/tools.h | 8 ++-- flang/lib/Evaluate/check-expression.cpp | 12 ++--- flang/lib/Evaluate/fold-logical.cpp | 17 +++---- flang/lib/Evaluate/fold.cpp | 7 +-- flang/lib/Evaluate/intrinsics.cpp | 44 +++++++++++++------ flang/lib/Evaluate/shape.cpp | 6 ++- flang/lib/Evaluate/tools.cpp | 40 +++++++++++++---- flang/lib/Lower/ConvertConstant.cpp | 4 +- flang/lib/Semantics/check-call.cpp | 36 ++++++++++----- flang/lib/Semantics/data-to-inits.cpp | 6 +-- flang/lib/Semantics/definable.cpp | 2 +- flang/lib/Semantics/expression.cpp | 32 +++++++------- flang/lib/Semantics/pointer-assignment.cpp | 2 +- flang/lib/Semantics/resolve-names.cpp | 7 +-- flang/test/Evaluate/folding06.f90 | 9 ++-- flang/test/Lower/HLFIR/null.f90 | 13 +----- flang/test/Semantics/associated.f90 | 3 +- flang/test/Semantics/call27.f90 | 5 +-- flang/test/Semantics/null01.f90 | 5 ++- 20 files changed, 157 insertions(+), 105 deletions(-) diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h index 3aa980db5d931..2fecb44fc0082 100644 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -349,8 +349,8 @@ struct FunctionResult { // 15.3.1 struct Procedure { - ENUM_CLASS( - Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer, Subroutine) + ENUM_CLASS(Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer, + NullAllocatable, Subroutine) using Attrs = common::EnumSet; Procedure(){}; Procedure(FunctionResult &&, DummyArguments &&, Attrs); diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h index 44e0e73028bf7..050990d1cd7ed 100644 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1059,9 +1059,11 @@ bool IsProcedurePointer(const Expr &); bool IsProcedure(const Expr &); bool IsProcedurePointerTarget(const Expr &); bool IsBareNullPointer(const Expr *); // NULL() w/o MOLD= or type -bool IsNullObjectPointer(const Expr &); -bool IsNullProcedurePointer(const Expr &); -bool IsNullPointer(const Expr &); +bool IsNullObjectPointer(const Expr *); // NULL() or NULL(objptr) +bool IsNullProcedurePointer(const Expr *); // NULL() or NULL(procptr) +bool IsNullPointer(const Expr *); // NULL() or NULL(pointer) +bool IsNullAllocatable(const Expr *); // NULL(allocatable) +bool IsNullPointerOrAllocatable(const Expr *); // NULL of any form bool IsObjectPointer(const Expr &); // Can Expr be passed as absent to an optional dummy argument. diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp index 6ace5bbcd0c77..823f8fd49baeb 100644 --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -100,9 +100,9 @@ template bool IsConstantExprHelper::IsConstantStructureConstructorComponent( const Symbol &component, const Expr &expr) const { if (IsAllocatable(component)) { - return IsNullObjectPointer(expr); + return IsNullObjectPointer(&expr); } else if (IsPointer(component)) { - return IsNullPointer(expr) || IsInitialDataTarget(expr) || + return IsNullPointerOrAllocatable(&expr) || IsInitialDataTarget(expr) || IsInitialProcedureTarget(expr); } else { return (*this)(expr); @@ -194,7 +194,7 @@ struct IsActuallyConstantHelper { const bool compIsConstant{(*this)(y)}; // If an allocatable component is initialized by a constant, // the structure constructor is not a constant. - if ((!compIsConstant && !IsNullPointer(y)) || + if ((!compIsConstant && !IsNullPointerOrAllocatable(&y)) || (compIsConstant && IsAllocatable(sym))) { return false; } @@ -311,7 +311,9 @@ class IsInitialDataTargetHelper bool operator()(const ProcedureRef &x) const { if (const SpecificIntrinsic * intrinsic{x.proc().GetSpecificIntrinsic()}) { return intrinsic->characteristics.value().attrs.test( - characteristics::Procedure::Attr::NullPointer); + characteristics::Procedure::Attr::NullPointer) || + intrinsic->characteristics.value().attrs.test( + characteristics::Procedure::Attr::NullAllocatable); } return false; } @@ -388,7 +390,7 @@ bool IsInitialProcedureTarget(const Expr &expr) { if (const auto *proc{std::get_if(&expr.u)}) { return IsInitialProcedureTarget(*proc); } else { - return IsNullProcedurePointer(expr); + return IsNullProcedurePointer(&expr); } } diff --git a/flang/lib/Evaluate/fold-logical.cpp b/flang/lib/Evaluate/fold-logical.cpp index 77f8e0f616878..2e060ac94e34f 100644 --- a/flang/lib/Evaluate/fold-logical.cpp +++ b/flang/lib/Evaluate/fold-logical.cpp @@ -652,21 +652,18 @@ Expr> FoldIntrinsicFunction( if (name == "all") { return FoldAllAnyParity( context, std::move(funcRef), &Scalar::AND, Scalar{true}); + } else if (name == "allocated") { + if (IsNullAllocatable(args[0]->UnwrapExpr())) { + return Expr{false}; + } } else if (name == "any") { return FoldAllAnyParity( context, std::move(funcRef), &Scalar::OR, Scalar{false}); } else if (name == "associated") { - bool gotConstant{true}; - const Expr *firstArgExpr{args[0]->UnwrapExpr()}; - if (!firstArgExpr || !IsNullPointer(*firstArgExpr)) { - gotConstant = false; - } else if (args[1]) { // There's a second argument - const Expr *secondArgExpr{args[1]->UnwrapExpr()}; - if (!secondArgExpr || !IsNullPointer(*secondArgExpr)) { - gotConstant = false; - } + if (IsNullPointer(args[0]->UnwrapExpr()) || + (args[1] && IsNullPointer(args[1]->UnwrapExpr()))) { + return Expr{false}; } - return gotConstant ? Expr{false} : Expr{std::move(funcRef)}; } else if (name == "bge" || name == "bgt" || name == "ble" || name == "blt") { static_assert(std::is_same_v, BOZLiteralConstant>); diff --git a/flang/lib/Evaluate/fold.cpp b/flang/lib/Evaluate/fold.cpp index cf6262d9a7c65..5fc31728ce5d6 100644 --- a/flang/lib/Evaluate/fold.cpp +++ b/flang/lib/Evaluate/fold.cpp @@ -73,7 +73,7 @@ Expr FoldOperation( for (auto &&[symbol, value] : std::move(structure)) { auto expr{Fold(context, std::move(value.value()))}; if (IsPointer(symbol)) { - if (IsNullPointer(expr)) { + if (IsNullPointer(&expr)) { // Handle x%c when x designates a named constant of derived // type and %c is NULL() in that constant. expr = Expr{NullPointer{}}; @@ -86,9 +86,10 @@ Expr FoldOperation( // F2023: 10.1.12 (3)(a) // If comp-spec is not null() for the allocatable component the // structure constructor is not a constant expression. - isConstant &= IsNullPointer(expr); + isConstant &= IsNullAllocatable(&expr) || IsBareNullPointer(&expr); } else { - isConstant &= IsActuallyConstant(expr) || IsNullPointer(expr); + isConstant &= + IsActuallyConstant(expr) || IsNullPointerOrAllocatable(&expr); if (auto valueShape{GetConstantExtents(context, expr)}) { if (auto componentShape{GetConstantExtents(context, symbol)}) { if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0) { diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index cdc49e89a978c..fe691e85ee011 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -247,8 +247,10 @@ ENUM_CLASS(Optionality, required, ) ENUM_CLASS(ArgFlag, none, - canBeNull, // actual argument can be NULL(with or without MOLD=) - canBeMoldNull, // actual argument can be NULL(with MOLD=) + canBeNullPointer, // actual argument can be NULL(with or without + // MOLD=pointer) + canBeMoldNull, // actual argument can be NULL(MOLD=any) + canBeNullAllocatable, // actual argument can be NULL(MOLD=allocatable) defaultsToSameKind, // for MatchingDefaultKIND defaultsToSizeKind, // for SizeDefaultKIND defaultsToDefaultForResult, // for DefaultingKIND @@ -343,8 +345,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"allocated", {{"scalar", AnyData, Rank::scalar}}, DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction}, - {"allocated", {{"array", AnyData, Rank::anyOrAssumedRank}}, DefaultLogical, - Rank::elemental, IntrinsicClass::inquiryFunction}, + {"allocated", + {{"array", AnyData, Rank::anyOrAssumedRank, Optionality::required, + common::Intent::In, {ArgFlag::canBeNullAllocatable}}}, + DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction}, {"anint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal}, {"any", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical, Rank::dimReduced, IntrinsicClass::transformationalFunction}, @@ -353,10 +357,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ {"asinh", {{"x", SameFloating}}, SameFloating}, {"associated", {{"pointer", AnyPointer, Rank::anyOrAssumedRank, Optionality::required, - common::Intent::In, {ArgFlag::canBeNull}}, + common::Intent::In, {ArgFlag::canBeNullPointer}}, {"target", Addressable, Rank::anyOrAssumedRank, Optionality::optional, common::Intent::In, - {ArgFlag::canBeNull}}}, + {ArgFlag::canBeNullPointer}}}, DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction}, {"atan", {{"x", SameFloating}}, SameFloating}, {"atan", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, @@ -1892,9 +1896,9 @@ std::optional IntrinsicInterface::Match( d.keyword); return std::nullopt; } - if (!d.flags.test(ArgFlag::canBeNull)) { - if (const auto *expr{arg->UnwrapExpr()}; expr && IsNullPointer(*expr)) { - if (!IsBareNullPointer(expr) && IsNullObjectPointer(*expr) && + if (!d.flags.test(ArgFlag::canBeNullPointer)) { + if (const auto *expr{arg->UnwrapExpr()}; IsNullPointer(expr)) { + if (!IsBareNullPointer(expr) && IsNullObjectPointer(expr) && d.flags.test(ArgFlag::canBeMoldNull)) { // ok } else { @@ -1905,6 +1909,14 @@ std::optional IntrinsicInterface::Match( } } } + if (!d.flags.test(ArgFlag::canBeNullAllocatable) && + IsNullAllocatable(arg->UnwrapExpr()) && + !d.flags.test(ArgFlag::canBeMoldNull)) { + messages.Say(arg->sourceLocation(), + "A NULL() allocatable is not allowed for '%s=' intrinsic argument"_err_en_US, + d.keyword); + return std::nullopt; + } if (d.flags.test(ArgFlag::notAssumedSize)) { if (auto named{ExtractNamedEntity(*arg)}) { if (semantics::IsAssumedSizeArray(named->GetLastSymbol())) { @@ -2862,14 +2874,15 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull( "MOLD= argument to NULL() must not be assumed-rank"_err_en_US); } bool isProcPtrTarget{ - IsProcedurePointerTarget(*mold) && !IsNullObjectPointer(*mold)}; + IsProcedurePointerTarget(*mold) && !IsNullObjectPointer(mold)}; if (isProcPtrTarget || IsAllocatableOrPointerObject(*mold)) { characteristics::DummyArguments args; std::optional fResult; + bool isAllocatableMold{false}; if (isProcPtrTarget) { // MOLD= procedure pointer std::optional procPointer; - if (IsNullProcedurePointer(*mold)) { + if (IsNullProcedurePointer(mold)) { procPointer = characteristics::Procedure::Characterize(*mold, context); } else { @@ -2885,12 +2898,13 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull( fResult.emplace(std::move(*procPointer)); } } else if (auto type{mold->GetType()}) { - // MOLD= object pointer + // MOLD= object pointer or allocatable characteristics::TypeAndShape typeAndShape{ *type, GetShape(context, *mold)}; args.emplace_back( "mold"s, characteristics::DummyDataObject{typeAndShape}); fResult.emplace(std::move(typeAndShape)); + isAllocatableMold = IsAllocatableDesignator(*mold); } else { context.messages().Say(arguments[0]->sourceLocation(), "MOLD= argument to NULL() lacks type"_err_en_US); @@ -2898,7 +2912,9 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull( if (fResult) { fResult->attrs.set(characteristics::FunctionResult::Attr::Pointer); characteristics::Procedure::Attrs attrs; - attrs.set(characteristics::Procedure::Attr::NullPointer); + attrs.set(isAllocatableMold + ? characteristics::Procedure::Attr::NullAllocatable + : characteristics::Procedure::Attr::NullPointer); characteristics::Procedure chars{ std::move(*fResult), std::move(args), attrs}; return SpecificCall{SpecificIntrinsic{"null"s, std::move(chars)}, @@ -3257,7 +3273,7 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { const auto &arg{call.arguments[0]}; if (arg) { if (const auto *expr{arg->UnwrapExpr()}) { - ok = evaluate::IsAllocatableDesignator(*expr); + ok = IsAllocatableDesignator(*expr) || IsNullAllocatable(expr); } } if (!ok) { diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp index fa957cfc08495..f620ecd4a24bb 100644 --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -1173,8 +1173,10 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result { if (call.arguments().size() >= 2) { return (*this)(call.arguments()[1]); // MASK= } - } else if (intrinsic->characteristics.value().attrs.test(characteristics:: - Procedure::Attr::NullPointer)) { // NULL(MOLD=) + } else if (intrinsic->characteristics.value().attrs.test( + characteristics::Procedure::Attr::NullPointer) || + intrinsic->characteristics.value().attrs.test( + characteristics::Procedure::Attr::NullAllocatable)) { // NULL(MOLD=) return (*this)(call.arguments()); } else { // TODO: shapes of other non-elemental intrinsic results diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 36b7d0a69d2ba..fcd6860917247 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -929,7 +929,7 @@ bool IsPointer(const Expr &expr) { } bool IsProcedurePointer(const Expr &expr) { - if (IsNullProcedurePointer(expr)) { + if (IsNullProcedurePointer(&expr)) { return true; } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) { if (const Symbol * proc{funcRef->proc().GetSymbol()}) { @@ -963,7 +963,7 @@ bool IsProcedurePointerTarget(const Expr &expr) { } bool IsObjectPointer(const Expr &expr) { - if (IsNullObjectPointer(expr)) { + if (IsNullObjectPointer(&expr)) { return true; } else if (IsProcedurePointerTarget(expr)) { return false; @@ -1030,15 +1030,15 @@ template struct IsNullPointerHelper { } }; -bool IsNullObjectPointer(const Expr &expr) { - return IsNullPointerHelper{}(expr); +bool IsNullObjectPointer(const Expr *expr) { + return expr && IsNullPointerHelper{}(*expr); } -bool IsNullProcedurePointer(const Expr &expr) { - return IsNullPointerHelper{}(expr); +bool IsNullProcedurePointer(const Expr *expr) { + return expr && IsNullPointerHelper{}(*expr); } -bool IsNullPointer(const Expr &expr) { +bool IsNullPointer(const Expr *expr) { return IsNullObjectPointer(expr) || IsNullProcedurePointer(expr); } @@ -1046,6 +1046,30 @@ bool IsBareNullPointer(const Expr *expr) { return expr && std::holds_alternative(expr->u); } +struct IsNullAllocatableHelper { + template bool operator()(const A &) const { return false; } + template bool operator()(const FunctionRef &call) const { + const auto *intrinsic{call.proc().GetSpecificIntrinsic()}; + return intrinsic && + intrinsic->characteristics.value().attrs.test( + characteristics::Procedure::Attr::NullAllocatable); + } + template bool operator()(const Parentheses &x) const { + return (*this)(x.left()); + } + template bool operator()(const Expr &x) const { + return common::visit(*this, x.u); + } +}; + +bool IsNullAllocatable(const Expr *x) { + return x && IsNullAllocatableHelper{}(*x); +} + +bool IsNullPointerOrAllocatable(const Expr *x) { + return IsNullPointer(x) || IsNullAllocatable(x); +} + // GetSymbolVector() auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result { if (const auto *details{x.detailsIf()}) { @@ -1393,7 +1417,7 @@ bool IsAllocatableOrPointerObject(const Expr &expr) { const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)}; return (sym && semantics::IsAllocatableOrObjectPointer(&sym->GetUltimate())) || - evaluate::IsObjectPointer(expr); + evaluate::IsObjectPointer(expr) || evaluate::IsNullAllocatable(&expr); } bool IsAllocatableDesignator(const Expr &expr) { diff --git a/flang/lib/Lower/ConvertConstant.cpp b/flang/lib/Lower/ConvertConstant.cpp index e56fde247828b..38f83f1deceb8 100644 --- a/flang/lib/Lower/ConvertConstant.cpp +++ b/flang/lib/Lower/ConvertConstant.cpp @@ -370,7 +370,7 @@ static mlir::Value genStructureComponentInit( /*typeParams=*/mlir::ValueRange{} /*TODO*/); if (Fortran::semantics::IsAllocatable(sym)) { - if (!Fortran::evaluate::IsNullPointer(expr)) { + if (!Fortran::evaluate::IsNullPointerOrAllocatable(&expr)) { fir::emitFatalError(loc, "constant structure constructor with an " "allocatable component value that is not NULL"); } else { @@ -414,7 +414,7 @@ static mlir::Value genStructureComponentInit( // must fall through to genConstantValue() below. if (Fortran::semantics::IsBuiltinCPtr(sym) && sym.Rank() == 0 && (Fortran::evaluate::GetLastSymbol(expr) || - Fortran::evaluate::IsNullPointer(expr))) { + Fortran::evaluate::IsNullPointer(&expr))) { // Builtin c_ptr and c_funptr have special handling because designators // and NULL() are handled as initial values for them as an extension // (otherwise only c_ptr_null/c_funptr_null are allowed and these are diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index 35ce3a430a830..ecc1e3d27e3bf 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -62,7 +62,7 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg, } if (IsBOZLiteral(*expr)) { messages.Say("BOZ argument requires an explicit interface"_err_en_US); - } else if (evaluate::IsNullPointer(*expr)) { + } else if (evaluate::IsNullPointerOrAllocatable(expr)) { messages.Say( "Null pointer argument requires an explicit interface"_err_en_US); } else if (auto named{evaluate::ExtractNamedEntity(*expr)}) { @@ -783,7 +783,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, // 15.5.2.6 -- dummy is ALLOCATABLE bool dummyIsOptional{ dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)}; - bool actualIsNull{evaluate::IsNullPointer(actual)}; if (dummyIsAllocatable) { if (actualIsAllocatable) { if (actualIsCoindexed && dummy.intent != common::Intent::In) { @@ -791,7 +790,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, "ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US, dummyName); } - } else if (actualIsNull) { + } else if (evaluate::IsBareNullPointer(&actual)) { if (dummyIsOptional) { } else if (dummy.intent == common::Intent::Default && context.ShouldWarn( @@ -808,6 +807,16 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } // INTENT(OUT) and INTENT(IN OUT) cases are caught elsewhere as being // undefinable actual arguments. + } else if (evaluate::IsNullAllocatable(&actual)) { + if (dummyIsOptional) { + } else if (dummy.intent == common::Intent::Default && + context.ShouldWarn( + common::UsageWarning::NullActualForDefaultIntentAllocatable)) { + messages.Say( + "A null allocatable should not be associated with allocatable %s without INTENT(IN)"_warn_en_US, + dummyName); + } + // INTENT(OUT) and INTENT(IN OUT) cases are caught elsewhere } else { messages.Say( "ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US, @@ -946,7 +955,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, // NULL(MOLD=) checking for non-intrinsic procedures if (!intrinsic && !dummyIsAllocatableOrPointer && !dummyIsOptional && - actualIsNull) { + evaluate::IsNullPointer(&actual)) { messages.Say( "Actual argument associated with %s may not be null pointer %s"_err_en_US, dummyName, actual.AsFortran()); @@ -1091,6 +1100,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg, characteristics::Procedure &argInterface{argProc->procedure.value()}; argInterface.attrs.reset( characteristics::Procedure::Attr::NullPointer); + argInterface.attrs.reset( + characteristics::Procedure::Attr::NullAllocatable); if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) { // It's ok to pass ELEMENTAL unrestricted intrinsic functions. argInterface.attrs.reset( @@ -1105,6 +1116,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg, } else { argInterface.attrs.reset( characteristics::Procedure::Attr::NullPointer); + argInterface.attrs.reset( + characteristics::Procedure::Attr::NullAllocatable); } } if (interface.HasExplicitInterface()) { @@ -1161,7 +1174,7 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg, "Actual argument associated with procedure %s is not a procedure"_err_en_US, dummyName); } - } else if (IsNullPointer(*expr)) { + } else if (IsNullPointer(expr)) { if (!dummyIsPointer && !dummy.attrs.test( characteristics::DummyProcedure::Attr::Optional)) { @@ -1263,11 +1276,11 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, IsBOZLiteral(*expr)) { // ok } else if (object.type.type().IsTypelessIntrinsicArgument() && - evaluate::IsNullObjectPointer(*expr)) { + evaluate::IsNullObjectPointer(expr)) { // ok, ASSOCIATED(NULL(without MOLD=)) } else if (object.type.attrs().test(characteristics:: TypeAndShape::Attr::AssumedRank) && - evaluate::IsNullObjectPointer(*expr) && + evaluate::IsNullObjectPointer(expr) && (object.attrs.test( characteristics::DummyDataObject::Attr::Allocatable) || object.attrs.test( @@ -1280,7 +1293,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, Attr::Pointer) || object.attrs.test(characteristics:: DummyDataObject::Attr::Optional)) && - evaluate::IsNullObjectPointer(*expr)) { + evaluate::IsNullObjectPointer(expr)) { // FOO(NULL(without MOLD=)) if (object.type.type().IsAssumedLengthCharacter()) { messages.Say( @@ -1299,7 +1312,8 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, } } else if (object.attrs.test(characteristics::DummyDataObject:: Attr::Allocatable) && - evaluate::IsNullPointer(*expr)) { + (evaluate::IsNullAllocatable(expr) || + evaluate::IsBareNullPointer(expr))) { if (object.intent == common::Intent::Out || object.intent == common::Intent::InOut) { messages.Say( @@ -1573,13 +1587,13 @@ static void CheckAssociated(evaluate::ActualArguments &arguments, } } } - } else if (!IsNullProcedurePointer(*targetExpr)) { + } else if (!IsNullProcedurePointer(targetExpr)) { messages.Say( "POINTER= argument '%s' is a procedure pointer but the TARGET= argument '%s' is not a procedure or procedure pointer"_err_en_US, pointerExpr->AsFortran(), targetExpr->AsFortran()); } } - } else if (IsVariable(*targetExpr) || IsNullPointer(*targetExpr)) { + } else if (IsVariable(*targetExpr) || IsNullPointer(targetExpr)) { // Object pointer and target if (ExtractDataRef(*targetExpr)) { if (SymbolVector symbols{GetSymbolVector(*targetExpr)}; diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp index c9b86a930437a..b4c83bab67088 100644 --- a/flang/lib/Semantics/data-to-inits.cpp +++ b/flang/lib/Semantics/data-to-inits.cpp @@ -381,7 +381,7 @@ bool DataInitializationCompiler::InitElement( if (static_cast(offsetSymbol.offset() + offsetSymbol.size()) > symbol.size()) { OutOfRangeError(); - } else if (evaluate::IsNullPointer(*expr)) { + } else if (evaluate::IsNullPointer(expr)) { // nothing to do; rely on zero initialization return true; } else if (isProcPointer) { @@ -414,7 +414,7 @@ bool DataInitializationCompiler::InitElement( GetImage().AddPointer(offsetSymbol.offset(), *expr); return true; } - } else if (evaluate::IsNullPointer(*expr)) { + } else if (evaluate::IsNullPointer(expr)) { exprAnalyzer_.Say("Initializer for '%s' must not be a pointer"_err_en_US, DescribeElement()); } else if (evaluate::IsProcedureDesignator(*expr)) { @@ -900,7 +900,7 @@ void ConstructInitializer(const Symbol &symbol, mutableProc.set_init(DEREF(procDesignator->GetSymbol())); } } else { - CHECK(evaluate::IsNullProcedurePointer(*expr)); + CHECK(evaluate::IsNullProcedurePointer(&*expr)); mutableProc.set_init(nullptr); } } else { diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp index 6d0155c24c31a..99a31553f2782 100644 --- a/flang/lib/Semantics/definable.cpp +++ b/flang/lib/Semantics/definable.cpp @@ -381,7 +381,7 @@ std::optional WhyNotDefinable(parser::CharBlock at, if (auto whyNotDataRef{WhyNotDefinable(at, scope, flags, *dataRef)}) { return whyNotDataRef; } - } else if (evaluate::IsNullPointer(expr)) { + } else if (evaluate::IsNullPointerOrAllocatable(&expr)) { return parser::Message{ at, "'%s' is a null pointer"_err_en_US, expr.AsFortran()}; } else if (flags.test(DefinabilityFlag::PointerDefinition)) { diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 3efdfb3fa49b8..827defd605f7f 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2167,7 +2167,7 @@ MaybeExpr ExpressionAnalyzer::Analyze( result.Add(*symbol, Fold(std::move(*value))); continue; } - if (IsNullPointer(*value)) { + if (IsNullPointer(&*value)) { if (IsAllocatable(*symbol)) { if (IsBareNullPointer(&*value)) { // NULL() with no arguments allowed by 7.5.10 para 6 for @@ -2175,7 +2175,7 @@ MaybeExpr ExpressionAnalyzer::Analyze( result.Add(*symbol, Expr{NullPointer{}}); continue; } - if (IsNullObjectPointer(*value)) { + if (IsNullObjectPointer(&*value)) { AttachDeclaration( Warn(common::LanguageFeature:: NullMoldAllocatableComponentValue, @@ -2200,8 +2200,11 @@ MaybeExpr ExpressionAnalyzer::Analyze( *symbol); continue; } + } else if (IsNullAllocatable(&*value) && IsAllocatable(*symbol)) { + result.Add(*symbol, Expr{NullPointer{}}); + continue; } else if (const Symbol * pointer{FindPointerComponent(*symbol)}; - pointer && pureContext) { // C1594(4) + pointer && pureContext) { // C1594(4) if (const Symbol * visible{semantics::FindExternallyVisibleObject( *value, *pureContext)}) { @@ -2522,10 +2525,13 @@ static bool CheckCompatibleArgument(bool isElemental, return common::visit( common::visitors{ [&](const characteristics::DummyDataObject &x) { - if (x.attrs.test(characteristics::DummyDataObject::Attr::Pointer) && + if ((x.attrs.test( + characteristics::DummyDataObject::Attr::Pointer) || + x.attrs.test( + characteristics::DummyDataObject::Attr::Allocatable)) && IsBareNullPointer(expr)) { // NULL() without MOLD= is compatible with any dummy data pointer - // but cannot be allowed to lead to ambiguity. + // or allocatable, but cannot be allowed to lead to ambiguity. return true; } else if (!isElemental && actual.Rank() != x.type.Rank() && !x.type.attrs().test( @@ -3877,7 +3883,7 @@ MaybeExpr ExpressionAnalyzer::ExprOrVariable( } if (result) { if constexpr (std::is_same_v) { - if (!isNullPointerOk_ && IsNullPointer(*result)) { + if (!isNullPointerOk_ && IsNullPointerOrAllocatable(&*result)) { Say(source, "NULL() may not be used as an expression in this context"_err_en_US); } @@ -4396,15 +4402,11 @@ bool ArgumentAnalyzer::CheckAssignmentConformance() { bool ArgumentAnalyzer::CheckForNullPointer(const char *where) { for (const std::optional &arg : actuals_) { - if (arg) { - if (const Expr *expr{arg->UnwrapExpr()}) { - if (IsNullPointer(*expr)) { - context_.Say( - source_, "A NULL() pointer is not allowed %s"_err_en_US, where); - fatalErrors_ = true; - return false; - } - } + if (arg && IsNullPointerOrAllocatable(arg->UnwrapExpr())) { + context_.Say( + source_, "A NULL() pointer is not allowed %s"_err_en_US, where); + fatalErrors_ = true; + return false; } } return true; diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp index 7f4548c7327e3..654c01856cfd4 100644 --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -184,7 +184,7 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) { if (!common::visit([&](const auto &x) { return Check(x); }, rhs.u)) { return false; } - if (IsNullPointer(rhs)) { + if (IsNullPointer(&rhs)) { return true; } if (lhs_ && IsProcedure(*lhs_)) { diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index c582b690a293d..02b91f15e7cf4 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -6225,7 +6225,8 @@ bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) { const auto &null{DEREF(std::get_if(&x.u))}; Walk(null); if (auto nullInit{EvaluateExpr(null)}) { - if (!evaluate::IsNullPointer(*nullInit)) { + if (!evaluate::IsNullProcedurePointer(&*nullInit) && + !evaluate::IsBareNullPointer(&*nullInit)) { Say(null.v.value().source, "Procedure pointer initializer must be a name or intrinsic NULL()"_err_en_US); } @@ -8634,7 +8635,7 @@ void DeclarationVisitor::Initialization(const parser::Name &name, [&](const parser::NullInit &null) { // => NULL() Walk(null); if (auto nullInit{EvaluateExpr(null)}) { - if (!evaluate::IsNullPointer(*nullInit)) { // C813 + if (!evaluate::IsNullPointer(&*nullInit)) { // C813 Say(null.v.value().source, "Pointer initializer must be intrinsic NULL()"_err_en_US); } else if (IsPointer(ultimate)) { @@ -8684,7 +8685,7 @@ void DeclarationVisitor::PointerInitialization( ultimate.set(Symbol::Flag::InDataStmt, false); } else if (auto *details{ultimate.detailsIf()}) { // something like "REAL, EXTERNAL, POINTER :: p => t" - if (evaluate::IsNullProcedurePointer(*expr)) { + if (evaluate::IsNullProcedurePointer(&*expr)) { CHECK(!details->init()); details->set_init(nullptr); } else if (const Symbol * diff --git a/flang/test/Evaluate/folding06.f90 b/flang/test/Evaluate/folding06.f90 index 132407387140e..da434fb6d4869 100644 --- a/flang/test/Evaluate/folding06.f90 +++ b/flang/test/Evaluate/folding06.f90 @@ -3,7 +3,7 @@ module m - ! Testing ASSOCATED + ! Testing ASSOCIATED and ALLOCATED integer, pointer :: int_pointer integer, allocatable :: int_allocatable logical, parameter :: test_Assoc1 = .not.(associated(null())) @@ -11,13 +11,10 @@ module m !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))) + logical, parameter :: test_Alloc1 = .not.(allocated(null(int_allocatable))) !WARN: portability: POINTER= argument of ASSOCIATED() is required by some other compilers to 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() is required by some other compilers to 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))) + logical, parameter :: test_Assoc5 = .not. associated(null(), null(int_pointer)) type A real(4) x diff --git a/flang/test/Lower/HLFIR/null.f90 b/flang/test/Lower/HLFIR/null.f90 index f80fb0b0d20b1..7b69bbb285c8a 100644 --- a/flang/test/Lower/HLFIR/null.f90 +++ b/flang/test/Lower/HLFIR/null.f90 @@ -25,7 +25,6 @@ subroutine test2 l = associated(null(),i) end subroutine test2 ! CHECK-LABEL: func.func @_QPtest2() { -! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.box> ! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.box> {bindc_name = "i", uniq_name = "_QFtest2Ei"} ! CHECK: %[[VAL_2:.*]] = fir.zero_bits !fir.ptr ! CHECK: %[[VAL_3:.*]] = fir.embox %[[VAL_2]] : (!fir.ptr) -> !fir.box> @@ -33,16 +32,8 @@ end subroutine test2 ! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_1]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest2Ei"} : (!fir.ref>>) -> (!fir.ref>>, !fir.ref>>) ! CHECK: %[[VAL_5:.*]] = fir.alloca !fir.logical<4> {bindc_name = "l", uniq_name = "_QFtest2El"} ! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_5]] {uniq_name = "_QFtest2El"} : (!fir.ref>) -> (!fir.ref>, !fir.ref>) -! CHECK: %[[VAL_7:.*]] = fir.zero_bits !fir.ptr -! CHECK: %[[VAL_8:.*]] = fir.embox %[[VAL_7]] : (!fir.ptr) -> !fir.box> -! CHECK: fir.store %[[VAL_8]] to %[[VAL_0]] : !fir.ref>> -! CHECK: %[[VAL_9:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = ".tmp.null_box"} : (!fir.ref>>) -> (!fir.ref>>, !fir.ref>>) -! CHECK: %[[VAL_10:.*]] = fir.load %[[VAL_4]]#1 : !fir.ref>> -! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_9]]#1 : !fir.ref>> -! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.box>) -> !fir.box -! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_10]] : (!fir.box>) -> !fir.box -! CHECK: %[[VAL_14:.*]] = fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_12]], %[[VAL_13]]) fastmath : (!fir.box, !fir.box) -> i1 -! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (i1) -> !fir.logical<4> +! CHECK: %false = arith.constant false +! CHECK: %[[VAL_15:.*]] = fir.convert %false : (i1) -> !fir.logical<4> ! CHECK: hlfir.assign %[[VAL_15]] to %[[VAL_6]]#0 : !fir.logical<4>, !fir.ref> ! CHECK: return ! CHECK: } diff --git a/flang/test/Semantics/associated.f90 b/flang/test/Semantics/associated.f90 index c814980377b9f..3f3f5488ad9fe 100644 --- a/flang/test/Semantics/associated.f90 +++ b/flang/test/Semantics/associated.f90 @@ -119,7 +119,8 @@ subroutine test(assumedRank) lvar = associated(intPointerVar1, (targetIntVar1)) !ERROR: MOLD= argument to NULL() must be a pointer or allocatable lVar = associated(null(intVar)) - lVar = associated(null(intAllocVar)) !OK + !ERROR: A NULL() allocatable is not allowed for 'pointer=' intrinsic argument + lVar = associated(null(intAllocVar)) lVar = associated(null()) !OK lVar = associated(null(intPointerVar1)) !OK !PORTABILITY: POINTER= argument of ASSOCIATED() is required by some other compilers to be a valid left-hand side of a pointer assignment statement diff --git a/flang/test/Semantics/call27.f90 b/flang/test/Semantics/call27.f90 index 135d6c06dcb4a..f401eb254fde0 100644 --- a/flang/test/Semantics/call27.f90 +++ b/flang/test/Semantics/call27.f90 @@ -12,10 +12,9 @@ program test !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' is not definable !BECAUSE: 'null(mold=a)' is a null pointer call foo0(null(mold=a)) - !WARNING: A null pointer should not be associated with allocatable dummy argument 'a=' without INTENT(IN) + !WARNING: A null allocatable should not be associated with allocatable dummy argument 'a=' without INTENT(IN) call foo1(null(mold=a)) - !PORTABILITY: Allocatable dummy argument 'a=' is associated with a null pointer - call foo2(null(mold=a)) + call foo2(null(mold=a)) ! ok call foo3(null(mold=a)) ! ok contains subroutine foo0(a) diff --git a/flang/test/Semantics/null01.f90 b/flang/test/Semantics/null01.f90 index 04d94865356b0..b21ee91a0be0a 100644 --- a/flang/test/Semantics/null01.f90 +++ b/flang/test/Semantics/null01.f90 @@ -112,7 +112,10 @@ function f3() dt4x = dt4(null(dt2x%pps0)) call canbenull(null(), null()) ! fine call canbenull(null(mold=ip0), null(mold=rp0)) ! fine - call optionalAllocatable(null(mold=ip0)) ! fine + !ERROR: ALLOCATABLE dummy argument 'x=' must be associated with an ALLOCATABLE actual argument + call optionalAllocatable(null(mold=ip0)) + call optionalAllocatable(null(mold=ia0)) ! fine + call optionalAllocatable(null()) ! fine !ERROR: Null pointer argument requires an explicit interface call implicit(null()) !ERROR: Null pointer argument requires an explicit interface