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 @@ -232,6 +232,7 @@ 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/type.h b/flang/include/flang/Evaluate/type.h --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -102,7 +102,8 @@ // 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; @@ -200,7 +201,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 ASSOCIATED 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 @@ -352,7 +352,11 @@ DummyDataObject{ TypeAndShape{DynamicType::TypelessIntrinsicArgument()}}); }, - [](const NullPointer &) { return std::optional{}; }, + [&](const NullPointer &) { + return std::make_optional(std::move(name), + DummyDataObject{ + TypeAndShape{DynamicType::TypelessIntrinsicArgument()}}); + }, [&](const ProcedureDesignator &designator) { if (auto proc{Procedure::Characterize( designator, context.intrinsics())}) { @@ -423,6 +427,15 @@ } } +bool DummyArgument::IsTypelessIntrinsicDummy() const { + if (const auto *argObj{std::get_if(&u)}) { + if (argObj->type.type().IsTypelessIntrinsicArgument()) { + return true; + } + } + return false; +} + llvm::raw_ostream &DummyArgument::Dump(llvm::raw_ostream &o) const { if (!name.empty()) { o << name << '='; 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 + nullPointerType, // for ASSOCIATED(NULL()) ) 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::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 @@ {"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 @@ 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 @@ d.keyword, name); break; case KindCode::addressable: + case KindCode::nullPointerType: argOk = true; break; default: @@ -1504,6 +1511,7 @@ // 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]}) { @@ -1707,6 +1715,7 @@ if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1) && arguments[0]) { if (Expr * mold{arguments[0]->UnwrapExpr()}) { + bool goodProcPointer{true}; if (IsAllocatableOrPointer(*mold)) { characteristics::DummyArguments args; std::optional fResult; @@ -1716,10 +1725,15 @@ 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 @@ 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( 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 @@ -500,63 +500,67 @@ argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}; if (auto argChars{characteristics::DummyArgument::FromActual( "actual argument", *expr, context)}) { - if (auto *argProc{ - std::get_if(&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(&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) { @@ -605,6 +609,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/call02.f90 b/flang/test/Semantics/call02.f90 --- a/flang/test/Semantics/call02.f90 +++ b/flang/test/Semantics/call02.f90 @@ -19,6 +19,12 @@ 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 --- a/flang/test/Semantics/call09.f90 +++ b/flang/test/Semantics/call09.f90 @@ -46,6 +46,7 @@ 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 @@ !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/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,34 @@ real, dimension(merge(1, 2, present(optionalArg))) :: realField5 end type arrayType + abstract interface + function realfunc(x) + real, intent(in) :: x + real realfunc + end function realfunc + end interface + procedure(realfunc) :: procVar + procedure(realfunc), pointer :: procPointerVar1 + procedure(realfunc), pointer :: procPointerVar2 + + integer, allocatable :: intVar + integer, pointer :: intPointerVar1 + integer, pointer :: intPointerVar2 + logical :: lVar + + lVar = associated(null()) + lVar = associated(null(), null()) + lVar = associated(intPointerVar1) + lVar = associated(intPointerVar1, intPointerVar2) + lVar = associated(intPointerVar1, null(intPointerVar2)) + lVar = associated(intPointerVar1, null()) + lVar = associated(procPointerVar1, procVar) + lVar = associated(procPointerVar1, procPointerVar2) + !ERROR: Arguments of ASSOCIATED() must be a POINTER and an optional valid target + lVar = associated(allocArg) + !ERROR: Arguments of ASSOCIATED() must be a POINTER and an optional valid target + lVar = associated(intVar) + end subroutine s subroutine s1()