diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -227,8 +227,10 @@ bool operator!=(const DummyArgument &that) const { return !(*this == that); } static std::optional Characterize( const semantics::Symbol &, const IntrinsicProcTable &); + // create the dummy argument characteristics from the actual argument + // bool is true if we want to treat NULL as a typeless intrinsic argument static std::optional FromActual( - std::string &&, const Expr &, FoldingContext &); + std::string &&, const Expr &, FoldingContext &, bool); bool IsOptional() const; void SetOptional(bool = true); bool CanBePassedViaImplicitInterface() const; diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -200,7 +200,8 @@ 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 ASSOCATED ClassKind = -2, // CLASS(T) or CLASS(*) AssumedTypeKind = -3, // TYPE(*) }; diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -343,8 +343,8 @@ return std::nullopt; } -std::optional DummyArgument::FromActual( - std::string &&name, const Expr &expr, FoldingContext &context) { +std::optional DummyArgument::FromActual(std::string &&name, + const Expr &expr, FoldingContext &context, bool nullIsTypeless) { return std::visit( common::visitors{ [&](const BOZLiteralConstant &) { @@ -352,7 +352,14 @@ DummyDataObject{ TypeAndShape{DynamicType::TypelessIntrinsicArgument()}}); }, - [](const NullPointer &) { return std::optional{}; }, + [&](const NullPointer &) { + return nullIsTypeless + ? std::make_optional(std::move(name), + DummyDataObject{TypeAndShape{ + DynamicType::TypelessIntrinsicArgument()}}) + : std::optional{}; + // return std::optional{}; + }, [&](const ProcedureDesignator &designator) { if (auto proc{Procedure::Characterize( designator, context.intrinsics())}) { diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -84,6 +84,7 @@ subscript, // address-sized integer size, // default KIND= for SIZE(), UBOUND, &c. addressable, // for PRESENT(), &c.; anything (incl. procedure) but BOZ + pointerType, // for ASSOCIATED ) struct TypePattern { @@ -152,6 +153,9 @@ 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::pointerType}; + // 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 @@ {"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,9 @@ if (d.typePattern.kindCode == KindCode::addressable || d.rank == Rank::reduceOperation) { continue; + } else if (d.typePattern.kindCode == KindCode::pointerType && + IsNullPointer(expr)) { + continue; } else { messages.Say( "Actual argument for '%s=' may not be a procedure"_err_en_US, @@ -1214,6 +1221,7 @@ d.keyword, name); break; case KindCode::addressable: + case KindCode::pointerType: argOk = true; break; default: @@ -1504,12 +1512,14 @@ // Characterize the specific intrinsic procedure. characteristics::DummyArguments dummyArgs; std::optional 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]}) { if (const Expr *expr{arg->UnwrapExpr()}) { auto dc{characteristics::DummyArgument::FromActual( - std::string{d.keyword}, *expr, context)}; + std::string{d.keyword}, *expr, context, + d.typePattern.kindCode == KindCode::pointerType)}; CHECK(dc); dummyArgs.emplace_back(std::move(*dc)); if (d.typePattern.kindCode == KindCode::same && !sameDummyArg) { diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -499,7 +499,7 @@ const auto *argProcSymbol{ argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}; if (auto argChars{characteristics::DummyArgument::FromActual( - "actual argument", *expr, context)}) { + "actual argument", *expr, context, false)}) { if (auto *argProc{ std::get_if(&argChars->u)}) { characteristics::Procedure &argInterface{argProc->procedure.value()}; @@ -605,6 +605,9 @@ std::holds_alternative( 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/test/Semantics/resolve89.f90 b/flang/test/Semantics/resolve89.f90 --- a/flang/test/Semantics/resolve89.f90 +++ b/flang/test/Semantics/resolve89.f90 @@ -10,6 +10,8 @@ ! functions or the intrinsic functions ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, ! PRESENT, or SAME_TYPE_AS, every specification inquiry reference is a ! constant expression, and the value does not depend on the value of a variable. + +! There are also some tests of the ASSOCIATED intrinsic impure function impureFunc() integer :: impureFunc @@ -87,6 +89,12 @@ real, dimension(merge(1, 2, present(optionalArg))) :: realField5 end type arrayType + logical :: lVar + + !ERROR: Arguments of ASSOCIATED() must be a POINTER and an optional valid target + lVar = associated(allocArg) + lVar = associated(null()) + end subroutine s subroutine s1()