From 6c9b8845e9ba7cbce06de5efec02ce391decebfc Mon Sep 17 00:00:00 2001 From: peter klausler Date: Thu, 7 Nov 2019 16:01:38 -0800 Subject: [PATCH] [flang] checkpoint, all tests pass Fix name resolution for undeclared intrinsic actual arguments Original-commit: flang-compiler/f18@12470f06bcc09eb4858af9c3e412752d7ba71aee Reviewed-on: https://github.com/flang-compiler/f18/pull/818 --- flang/lib/evaluate/characteristics.cc | 103 +++++++++++---- flang/lib/evaluate/characteristics.h | 24 +++- flang/lib/evaluate/fold.cc | 2 +- flang/lib/evaluate/integer.h | 3 + flang/lib/evaluate/intrinsics.cc | 4 +- flang/lib/evaluate/tools.cc | 5 +- flang/lib/evaluate/tools.h | 3 +- flang/lib/parser/grammar.h | 7 +- flang/lib/parser/type-parsers.h | 2 +- flang/lib/semantics/assignment.cc | 40 +++--- flang/lib/semantics/check-call.cc | 139 ++++++++++++++++++-- flang/lib/semantics/check-declarations.cc | 16 +++ flang/lib/semantics/expression.cc | 32 ++--- flang/lib/semantics/resolve-names.cc | 45 ++++--- flang/test/semantics/CMakeLists.txt | 1 + flang/test/semantics/call02.f90 | 26 ++-- flang/test/semantics/call09.f90 | 151 ++++++++++++++++++++-- flang/test/semantics/expr-errors02.f90 | 7 +- 18 files changed, 467 insertions(+), 143 deletions(-) diff --git a/flang/lib/evaluate/characteristics.cc b/flang/lib/evaluate/characteristics.cc index 2d921047ad30..83e129335972 100644 --- a/flang/lib/evaluate/characteristics.cc +++ b/flang/lib/evaluate/characteristics.cc @@ -40,8 +40,33 @@ static void CopyAttrs(const semantics::Symbol &src, A &dst, } } +// Shapes of function results and dummy arguments have to have +// the same rank, the same deferred dimensions, and the same +// values for explicit dimensions when constant. +static bool ShapesAreCompatible(const Shape &x, const Shape &y) { + if (x.size() != y.size()) { + return false; + } + auto yIter{y.begin()}; + for (const auto &xDim : x) { + const auto &yDim{*yIter++}; + if (xDim.has_value() != yDim.has_value()) { + return false; + } + if (xDim) { + auto xConst{ToInt64(*xDim)}; + auto yConst{ToInt64(*yDim)}; + if (xConst.has_value() != yConst.has_value() || + (xConst && *xConst != *yConst)) { + return false; + } + } + } + return true; +} + bool TypeAndShape::operator==(const TypeAndShape &that) const { - return type_ == that.type_ && shape_ == that.shape_ && + return type_ == that.type_ && ShapesAreCompatible(shape_, that.shape_) && attrs_ == that.attrs_ && corank_ == that.corank_; } @@ -214,6 +239,18 @@ bool DummyDataObject::operator==(const DummyDataObject &that) const { coshape == that.coshape; } +static common::Intent GetIntent(const semantics::Attrs &attrs) { + if (attrs.test(semantics::Attr::INTENT_IN)) { + return common::Intent::In; + } else if (attrs.test(semantics::Attr::INTENT_OUT)) { + return common::Intent::Out; + } else if (attrs.test(semantics::Attr::INTENT_INOUT)) { + return common::Intent::InOut; + } else { + return common::Intent::Default; + } +} + std::optional DummyDataObject::Characterize( const semantics::Symbol &symbol) { if (const auto *obj{symbol.detailsIf()}) { @@ -231,17 +268,7 @@ std::optional DummyDataObject::Characterize( {Attr::POINTER, DummyDataObject::Attr::Pointer}, {Attr::TARGET, DummyDataObject::Attr::Target}, }); - if (symbol.attrs().test(semantics::Attr::INTENT_IN)) { - result->intent = common::Intent::In; - } - if (symbol.attrs().test(semantics::Attr::INTENT_OUT)) { - CHECK(result->intent == common::Intent::Default); - result->intent = common::Intent::Out; - } - if (symbol.attrs().test(semantics::Attr::INTENT_INOUT)) { - CHECK(result->intent == common::Intent::Default); - result->intent = common::Intent::InOut; - } + result->intent = GetIntent(symbol.attrs()); return result; } } @@ -290,18 +317,25 @@ DummyProcedure::DummyProcedure(Procedure &&p) : procedure{new Procedure{std::move(p)}} {} bool DummyProcedure::operator==(const DummyProcedure &that) const { - return attrs == that.attrs && procedure.value() == that.procedure.value(); + return attrs == that.attrs && intent == that.intent && + procedure.value() == that.procedure.value(); } std::optional DummyProcedure::Characterize( const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) { if (auto procedure{Procedure::Characterize(symbol, intrinsics)}) { + // Dummy procedures may not be elemental. Elemental dummy procedure + // interfaces are errors when the interface is not intrinsic, and that + // error is caught elsewhere. Elemental intrinsic interfaces are + // made non-elemental. + procedure->attrs.reset(Procedure::Attr::Elemental); DummyProcedure result{std::move(procedure.value())}; CopyAttrs(symbol, result, { {semantics::Attr::OPTIONAL, DummyProcedure::Attr::Optional}, {semantics::Attr::POINTER, DummyProcedure::Attr::Pointer}, }); + result.intent = GetIntent(symbol.attrs()); return result; } else { return std::nullopt; @@ -310,6 +344,9 @@ std::optional DummyProcedure::Characterize( std::ostream &DummyProcedure::Dump(std::ostream &o) const { attrs.Dump(o, EnumToString); + if (intent != common::Intent::Default) { + o << "INTENT(" << common::EnumToString(intent) << ')'; + } procedure.value().Dump(o); return o; } @@ -542,14 +579,17 @@ std::optional Procedure::Characterize( [&](const semantics::SubprogramDetails &subp) -> std::optional { if (subp.isFunction()) { - auto fr{FunctionResult::Characterize(subp.result(), intrinsics)}; - if (!fr) { + if (auto fr{FunctionResult::Characterize( + subp.result(), intrinsics)}) { + result.functionResult = std::move(fr); + } else { return std::nullopt; } - result.functionResult = std::move(fr); + } else { + result.attrs.set(Attr::Subroutine); } for (const semantics::Symbol *arg : subp.dummyArgs()) { - if (arg == nullptr) { + if (!arg) { result.dummyArguments.emplace_back(AlternateReturn{}); } else if (auto argCharacteristics{ DummyArgument::Characterize(*arg, intrinsics)}) { @@ -571,20 +611,19 @@ std::optional Procedure::Characterize( if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) { return Characterize(*interfaceSymbol, intrinsics); } else { - result.attrs.set(Procedure::Attr::ImplicitInterface); + result.attrs.set(Attr::ImplicitInterface); const semantics::DeclTypeSpec *type{interface.type()}; - if (symbol.test(semantics::Symbol::Flag::Function)) { - if (type != nullptr) { - if (auto resultType{DynamicType::From(*type)}) { - result.functionResult = FunctionResult{*resultType}; - } + if (symbol.test(semantics::Symbol::Flag::Subroutine)) { + // ignore any implicit typing + result.attrs.set(Attr::Subroutine); + } else if (type) { + if (auto resultType{DynamicType::From(*type)}) { + result.functionResult = FunctionResult{*resultType}; } else { return std::nullopt; } - } else { // subroutine, not function - if (type != nullptr) { - return std::nullopt; - } + } else if (symbol.test(semantics::Symbol::Flag::Function)) { + return std::nullopt; } // The PASS name, if any, is not a characteristic. return result; @@ -630,7 +669,15 @@ std::optional Procedure::Characterize( std::optional Procedure::Characterize( const ProcedureRef &ref, const IntrinsicProcTable &intrinsics) { - return Characterize(ref.proc(), intrinsics); + if (auto callee{Characterize(ref.proc(), intrinsics)}) { + if (callee->functionResult) { + if (const Procedure * + proc{callee->functionResult->IsProcedurePointer()}) { + return {*proc}; + } + } + } + return std::nullopt; } bool Procedure::CanBeCalledViaImplicitInterface() const { diff --git a/flang/lib/evaluate/characteristics.h b/flang/lib/evaluate/characteristics.h index ae4c7dd0d035..aeb7572c6035 100644 --- a/flang/lib/evaluate/characteristics.h +++ b/flang/lib/evaluate/characteristics.h @@ -74,6 +74,7 @@ public: DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(TypeAndShape) bool operator==(const TypeAndShape &) const; + bool operator!=(const TypeAndShape &that) const { return !(*this == that); } static std::optional Characterize(const semantics::Symbol &); static std::optional Characterize( const semantics::ObjectEntityDetails &); @@ -129,6 +130,9 @@ struct DummyDataObject { explicit DummyDataObject(TypeAndShape &&t) : type{std::move(t)} {} explicit DummyDataObject(DynamicType t) : type{t} {} bool operator==(const DummyDataObject &) const; + bool operator!=(const DummyDataObject &that) const { + return !(*this == that); + } static std::optional Characterize(const semantics::Symbol &); bool CanBePassedViaImplicitInterface() const; std::ostream &Dump(std::ostream &) const; @@ -141,19 +145,23 @@ struct DummyDataObject { // 15.3.2.3 struct DummyProcedure { ENUM_CLASS(Attr, Pointer, Optional) + using Attrs = common::EnumSet; DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure) explicit DummyProcedure(Procedure &&); bool operator==(const DummyProcedure &) const; + bool operator!=(const DummyProcedure &that) const { return !(*this == that); } static std::optional Characterize( const semantics::Symbol &, const IntrinsicProcTable &); std::ostream &Dump(std::ostream &) const; CopyableIndirection procedure; - common::EnumSet attrs; + common::Intent intent{common::Intent::Default}; + Attrs attrs; }; // 15.3.2.4 struct AlternateReturn { bool operator==(const AlternateReturn &) const { return true; } + bool operator!=(const AlternateReturn &) const { return false; } std::ostream &Dump(std::ostream &) const; }; @@ -167,6 +175,7 @@ struct DummyArgument { explicit DummyArgument(AlternateReturn &&x) : u{std::move(x)} {} ~DummyArgument(); bool operator==(const DummyArgument &) const; + bool operator!=(const DummyArgument &that) const { return !(*this == that); } static std::optional Characterize( const semantics::Symbol &, const IntrinsicProcTable &); static std::optional FromActual( @@ -187,12 +196,14 @@ using DummyArguments = std::vector; // 15.3.3 struct FunctionResult { ENUM_CLASS(Attr, Allocatable, Pointer, Contiguous) + using Attrs = common::EnumSet; DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult) explicit FunctionResult(DynamicType); explicit FunctionResult(TypeAndShape &&); explicit FunctionResult(Procedure &&); ~FunctionResult(); bool operator==(const FunctionResult &) const; + bool operator!=(const FunctionResult &that) const { return !(*this == that); } static std::optional Characterize( const Symbol &, const IntrinsicProcTable &); @@ -213,19 +224,21 @@ struct FunctionResult { std::ostream &Dump(std::ostream &) const; - common::EnumSet attrs; + Attrs attrs; std::variant> u; }; // 15.3.1 struct Procedure { - ENUM_CLASS(Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer) + ENUM_CLASS( + Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer, Subroutine) using Attrs = common::EnumSet; Procedure(FunctionResult &&, DummyArguments &&, Attrs); Procedure(DummyArguments &&, Attrs); // for subroutines and NULL() DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure) ~Procedure(); bool operator==(const Procedure &) const; + bool operator!=(const Procedure &that) const { return !(*this == that); } // Characterizes the procedure represented by a symbol, which may be an // "unrestricted specific intrinsic function". @@ -236,8 +249,11 @@ struct Procedure { static std::optional Characterize( const ProcedureRef &, const IntrinsicProcTable &); + // At most one of these will return true. + // For "EXTERNAL P" with no calls to P, both will be false. bool IsFunction() const { return functionResult.has_value(); } - bool IsSubroutine() const { return !IsFunction(); } + bool IsSubroutine() const { return attrs.test(Attr::Subroutine); } + bool IsPure() const { return attrs.test(Attr::Pure); } bool IsElemental() const { return attrs.test(Attr::Elemental); } bool IsBindC() const { return attrs.test(Attr::BindC); } diff --git a/flang/lib/evaluate/fold.cc b/flang/lib/evaluate/fold.cc index c6be6fcaf55d..5bbaedde36e5 100644 --- a/flang/lib/evaluate/fold.cc +++ b/flang/lib/evaluate/fold.cc @@ -924,7 +924,7 @@ Expr> ToReal( CHECK(constant != nullptr); Scalar real{constant->GetScalarValue().value()}; From converted{From::ConvertUnsigned(real.RawBits()).value}; - if (!(original == converted)) { // C1601 + if (original != converted) { // C1601 context.messages().Say( "Nonzero bits truncated from BOZ literal constant in REAL intrinsic"_en_US); } diff --git a/flang/lib/evaluate/integer.h b/flang/lib/evaluate/integer.h index c6550e76e0d7..5bcce9d26224 100644 --- a/flang/lib/evaluate/integer.h +++ b/flang/lib/evaluate/integer.h @@ -184,6 +184,9 @@ public: constexpr bool operator==(const Integer &that) const { return CompareUnsigned(that) == Ordering::Equal; } + constexpr bool operator!=(const Integer &that) const { + return !(*this == that); + } // Left-justified mask (e.g., MASKL(1) has only its sign bit set) static constexpr Integer MASKL(int places) { diff --git a/flang/lib/evaluate/intrinsics.cc b/flang/lib/evaluate/intrinsics.cc index f96ec222aeef..47fe024a0ae7 100644 --- a/flang/lib/evaluate/intrinsics.cc +++ b/flang/lib/evaluate/intrinsics.cc @@ -474,8 +474,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ {"lgt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, {"lle", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, {"llt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, - {"loc", {{"x", Addressable, Rank::anyOrAssumedRank}}, SubscriptInt, - Rank::scalar}, + {"loc", {{"loc_argument", Addressable, Rank::anyOrAssumedRank}}, + SubscriptInt, Rank::scalar}, {"log", {{"x", SameFloating}}, SameFloating}, {"log10", {{"x", SameReal}}, SameReal}, {"logical", {{"l", AnyLogical}, DefaultingKIND}, KINDLogical}, diff --git a/flang/lib/evaluate/tools.cc b/flang/lib/evaluate/tools.cc index 3875244eb0ac..974739cb5d22 100644 --- a/flang/lib/evaluate/tools.cc +++ b/flang/lib/evaluate/tools.cc @@ -638,7 +638,10 @@ bool IsAssumedRank(const ActualArgument &arg) { } } -// IsProcedurePointer() +bool IsProcedure(const Expr &expr) { + return std::holds_alternative(expr.u); +} + bool IsProcedurePointer(const Expr &expr) { return std::visit( common::visitors{ diff --git a/flang/lib/evaluate/tools.h b/flang/lib/evaluate/tools.h index 84fa245fbeeb..175e46d3a1cb 100644 --- a/flang/lib/evaluate/tools.h +++ b/flang/lib/evaluate/tools.h @@ -761,7 +761,8 @@ template bool IsAllocatableOrPointer(const A &x) { semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE}); } -// Pointer detection predicates +// Procedure and pointer detection predicates +bool IsProcedure(const Expr &); bool IsProcedurePointer(const Expr &); bool IsNullPointer(const Expr &); diff --git a/flang/lib/parser/grammar.h b/flang/lib/parser/grammar.h index 2e0920b85920..600f6b74a190 100644 --- a/flang/lib/parser/grammar.h +++ b/flang/lib/parser/grammar.h @@ -999,6 +999,9 @@ TYPE_PARSER(construct( // R801 type-declaration-stmt -> // declaration-type-spec [[, attr-spec]... ::] entity-decl-list +constexpr auto entityDeclWithoutEqInit{construct(name, + maybe(arraySpec), maybe(coarraySpec), maybe("*" >> charLength), + !"="_tok >> maybe(initialization))}; // old-style REAL A/0/ still works TYPE_PARSER( construct(declarationTypeSpec, defaulted("," >> nonemptyList(Parser{})) / "::", @@ -1006,8 +1009,8 @@ TYPE_PARSER( // C806: no initializers allowed without colons ("REALA=1" is ambiguous) construct(declarationTypeSpec, construct>(), - nonemptyList( - "expected entity declarations"_err_en_US, entityDeclWithoutInit)) || + nonemptyList("expected entity declarations"_err_en_US, + entityDeclWithoutEqInit)) || // PGI-only extension: comma in place of doubled colons extension(construct( declarationTypeSpec, defaulted("," >> nonemptyList(Parser{})), diff --git a/flang/lib/parser/type-parsers.h b/flang/lib/parser/type-parsers.h index 33dc7c1f7892..7107d5d33697 100644 --- a/flang/lib/parser/type-parsers.h +++ b/flang/lib/parser/type-parsers.h @@ -87,7 +87,7 @@ constexpr Parser typeDeclarationStmt; // R801 constexpr Parser nullInit; // R806 constexpr Parser accessSpec; // R807 constexpr Parser languageBindingSpec; // R808, R1528 -constexpr Parser entityDecl, entityDeclWithoutInit; // R803 +constexpr Parser entityDecl; // R803 constexpr Parser coarraySpec; // R809 constexpr Parser arraySpec; // R815 constexpr Parser explicitShapeSpec; // R816 diff --git a/flang/lib/semantics/assignment.cc b/flang/lib/semantics/assignment.cc index 4023227d6c86..4c1318a99b58 100644 --- a/flang/lib/semantics/assignment.cc +++ b/flang/lib/semantics/assignment.cc @@ -40,8 +40,7 @@ public: const std::string &description, const characteristics::TypeAndShape *type, parser::ContextualMessages &messages, const IntrinsicProcTable &intrinsics, - const std::optional &procedure, - bool isContiguous) + const characteristics::Procedure *procedure, bool isContiguous) : pointer_{pointer}, source_{source}, description_{description}, type_{type}, messages_{messages}, intrinsics_{intrinsics}, procedure_{procedure}, isContiguous_{isContiguous} {} @@ -71,12 +70,12 @@ public: std::optional error; if (const auto &funcResult{proc->functionResult}) { // C1025 const auto *frProc{funcResult->IsProcedurePointer()}; - if (procedure_.has_value()) { + if (procedure_) { // Shouldn't be here in this function unless lhs // is an object pointer. error = "Procedure %s is associated with the result of a reference to function '%s' that does not return a procedure pointer"_err_en_US; - } else if (frProc != nullptr) { + } else if (frProc) { error = "Object %s is associated with the result of a reference to function '%s' that is a procedure pointer"_err_en_US; } else if (!funcResult->attrs.test( @@ -90,7 +89,7 @@ public: "CONTIGUOUS %s is associated with the result of reference to function '%s' that is not contiguous"_err_en_US; } else if (type_) { const auto *frTypeAndShape{funcResult->GetTypeAndShape()}; - CHECK(frTypeAndShape != nullptr); + CHECK(frTypeAndShape); if (!type_->IsCompatibleWith(messages_, *frTypeAndShape)) { error = "%s is associated with the result of a reference to function '%s' whose pointer result has an incompatible type or shape"_err_en_US; @@ -110,14 +109,14 @@ public: template void Check(const Designator &d) { const Symbol *last{d.GetLastSymbol()}; const Symbol *base{d.GetBaseObject().symbol()}; - if (last != nullptr && base != nullptr) { + if (last && base) { std::optional error; - if (procedure_.has_value()) { + if (procedure_) { // Shouldn't be here in this function unless lhs is an // object pointer. error = "In assignment to procedure %s, the target is not a procedure or procedure pointer"_err_en_US; - } else if (GetLastTarget(GetSymbolVector(d)) == nullptr) { // C1025 + } else if (!GetLastTarget(GetSymbolVector(d))) { // C1025 error = "In assignment to object %s, the target '%s' is not an object with POINTER or TARGET attributes"_err_en_US; } else if (auto rhsTypeAndShape{ @@ -161,7 +160,7 @@ private: const characteristics::TypeAndShape *type_{nullptr}; parser::ContextualMessages &messages_; const IntrinsicProcTable &intrinsics_; - const std::optional &procedure_; + const characteristics::Procedure *procedure_{nullptr}; bool isContiguous_{false}; }; @@ -178,9 +177,9 @@ void PointerAssignmentChecker::Check(const Expr &rhs) { // Common handling for procedure pointer right-hand sides void PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall, const characteristics::Procedure *targetChars) { - if (procedure_.has_value()) { - if (targetChars != nullptr) { - if (!(*procedure_ == *targetChars)) { + if (procedure_) { + if (targetChars) { + if (*procedure_ != *targetChars) { if (isCall) { Say("Procedure %s associated with result of reference to function '%s' that is an incompatible procedure pointer"_err_en_US, description_, rhsName); @@ -234,7 +233,7 @@ void CheckPointerAssignment(parser::ContextualMessages &messages, auto proc{characteristics::Procedure::Characterize(lhs, intrinsics)}; std::string description{"pointer '"s + lhs.name().ToString() + '\''}; PointerAssignmentChecker{&lhs, lhs.name(), description, - type ? &*type : nullptr, messages, intrinsics, proc, + type ? &*type : nullptr, messages, intrinsics, proc ? &*proc : nullptr, lhs.attrs().test(semantics::Attr::CONTIGUOUS)} .Check(rhs); } @@ -244,9 +243,8 @@ void CheckPointerAssignment(parser::ContextualMessages &messages, const IntrinsicProcTable &intrinsics, parser::CharBlock source, const std::string &description, const characteristics::DummyDataObject &lhs, const evaluate::Expr &rhs) { - std::optional proc; PointerAssignmentChecker{nullptr, source, description, &lhs.type, messages, - intrinsics, proc, + intrinsics, nullptr /* proc */, lhs.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)} .Check(rhs); } @@ -275,7 +273,7 @@ struct ForallContext { const auto iter{activeNames.find(name)}; if (iter != activeNames.cend()) { return {integerKind}; - } else if (outer != nullptr) { + } else if (outer) { return outer->GetActiveIntKind(name); } else { return std::nullopt; @@ -354,7 +352,7 @@ private: }; void AssignmentContext::Analyze(const parser::AssignmentStmt &) { - if (forall_ != nullptr) { + if (forall_) { // TODO: Warn if some name in forall_->activeNames or its outer // contexts does not appear on LHS } @@ -364,7 +362,7 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &) { void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &) { CHECK(!where_); - if (forall_ != nullptr) { + if (forall_) { // TODO: Warn if some name in forall_->activeNames or its outer // contexts does not appear on LHS } @@ -435,7 +433,7 @@ void AssignmentContext::Analyze(const parser::ForallConstruct &construct) { void AssignmentContext::Analyze( const parser::WhereConstruct::MaskedElsewhere &elsewhere) { - CHECK(where_ != nullptr); + CHECK(where_); const auto &elsewhereStmt{ std::get>(elsewhere.t)}; context_.set_location(elsewhereStmt.source); @@ -454,7 +452,7 @@ void AssignmentContext::Analyze( std::move(where_->cumulativeMaskExpr), std::move(copyMask)); where_->thisMaskExpr = evaluate::BinaryLogicalOperation( evaluate::LogicalOperator::And, std::move(notOldMask), std::move(mask)); - if (where_->outer != nullptr && + if (where_->outer && !evaluate::AreConformable( where_->outer->thisMaskExpr, where_->thisMaskExpr)) { Say(elsewhereStmt.source, @@ -507,7 +505,7 @@ MaskExpr AssignmentContext::GetMask( if (auto maybeExpr{AnalyzeExpr(context_, expr)}) { auto *logical{ std::get_if>(&maybeExpr->u)}; - CHECK(logical != nullptr); + CHECK(logical); mask = evaluate::ConvertTo(mask, std::move(*logical)); } return mask; diff --git a/flang/lib/semantics/check-call.cc b/flang/lib/semantics/check-call.cc index 0df587cc6592..76ba12ff3974 100644 --- a/flang/lib/semantics/check-call.cc +++ b/flang/lib/semantics/check-call.cc @@ -184,15 +184,28 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } } UltimateComponentIterator ultimates{derived}; - if (actualIsCoindexed && dummy.intent != common::Intent::In && - !dummyIsValue) { - if (auto iter{std::find_if( - ultimates.begin(), ultimates.end(), [](const Symbol &component) { - return IsAllocatable(component); - })}) { // 15.5.2.4(6) - evaluate::SayWithDeclaration(messages, &*iter, - "Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US, - iter.BuildResultDesignatorName(), dummyName); + if (actualIsCoindexed) { + if (dummy.intent != common::Intent::In && !dummyIsValue) { + if (auto iter{std::find_if(ultimates.begin(), ultimates.end(), + [](const Symbol &component) { + return IsAllocatable(component); + })}) { // 15.5.2.4(6) + evaluate::SayWithDeclaration(messages, &*iter, + "Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US, + iter.BuildResultDesignatorName(), dummyName); + } + } + if (auto coarrayRef{evaluate::ExtractCoarrayRef(actual)}) { // C1537 + const Symbol &coarray{coarrayRef->GetLastSymbol()}; + if (const DeclTypeSpec * type{coarray.GetType()}) { + if (const DerivedTypeSpec * derived{type->AsDerived()}) { + if (auto ptr{semantics::FindPointerUltimateComponent(*derived)}) { + evaluate::SayWithDeclaration(messages, &coarray, + "Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US, + coarray.name(), ptr->name(), dummyName); + } + } + } } } if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22) @@ -210,7 +223,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, // Rank and shape checks const auto *actualLastSymbol{evaluate::GetLastSymbol(actual)}; - if (actualLastSymbol != nullptr) { + if (actualLastSymbol) { actualLastSymbol = GetAssociationRoot(*actualLastSymbol); } const ObjectEntityDetails *actualLastObject{actualLastSymbol @@ -279,11 +292,11 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } else if (dummyIsVolatile) { reason = "VOLATILE"; } - if (reason != nullptr && scope != nullptr) { + if (reason && scope) { bool vectorSubscriptIsOk{isElemental || dummyIsValue}; // 15.5.2.4(21) std::unique_ptr why{ WhyNotModifiable(messages.at(), actual, *scope, vectorSubscriptIsOk)}; - if (why.get() != nullptr) { + if (why.get()) { if (auto *msg{messages.Say( "Actual argument associated with %s %s must be definable"_err_en_US, reason, dummyName)}) { @@ -437,6 +450,102 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } } +static void CheckProcedureArg(evaluate::ActualArgument &arg, + const characteristics::DummyProcedure &proc, const std::string &dummyName, + evaluate::FoldingContext &context) { + parser::ContextualMessages &messages{context.messages()}; + const characteristics::Procedure &interface{proc.procedure.value()}; + if (const auto *expr{arg.UnwrapExpr()}) { + bool dummyIsPointer{ + proc.attrs.test(characteristics::DummyProcedure::Attr::Pointer)}; + const auto *argProcDesignator{ + std::get_if(&expr->u)}; + const auto *argProcSymbol{ + 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 { + 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); + } + } 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 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 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) { + // 15.5.2.9(5) -- dummy procedure POINTER + // Interface compatibility has already been checked above by comparison. + if (proc.intent != common::Intent::In && !IsVariable(*expr)) { + messages.Say( + "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US, + dummyName); + } + } else { // 15.5.2.9(4) -- dummy procedure is not POINTER + if (!argProcDesignator) { + messages.Say( + "Actual argument associated with non-POINTER procedure %s must be a procedure (and not a procedure pointer)"_err_en_US, + dummyName); + } + } + } + } else { + messages.Say( + "Assumed-type argument may not be forwarded as procedure %s"_err_en_US, + dummyName); + } +} + static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, const characteristics::DummyArgument &dummy, const characteristics::Procedure &proc, evaluate::FoldingContext &context, @@ -475,8 +584,10 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, "Actual argument is not an expression or variable"_err_en_US); } }, - [](const auto &) { - // TODO check actual procedure compatibility + [&](const characteristics::DummyProcedure &proc) { + CheckProcedureArg(arg, proc, dummyName, context); + }, + [&](const characteristics::AlternateReturn &) { // TODO check alternate return }, }, diff --git a/flang/lib/semantics/check-declarations.cc b/flang/lib/semantics/check-declarations.cc index 54c29bdc06b3..587da063c350 100644 --- a/flang/lib/semantics/check-declarations.cc +++ b/flang/lib/semantics/check-declarations.cc @@ -172,6 +172,22 @@ void CheckHelper::Check(const Symbol &symbol) { "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US); } } + } else if (auto *proc{symbol.detailsIf()}) { + if (proc->isDummy()) { + const Symbol *interface{proc->interface().symbol()}; + if (!symbol.attrs().test(Attr::INTRINSIC) && + (symbol.attrs().test(Attr::ELEMENTAL) || + (interface && !interface->attrs().test(Attr::INTRINSIC) && + interface->attrs().test(Attr::ELEMENTAL)))) { + // There's no explicit constraint or "shall" that we can find in the + // standard for this check, but it seems to be implied in multiple + // sites, and ELEMENTAL non-intrinsic actual arguments *are* + // explicitly forbidden. But we allow "PROCEDURE(SIN)::dummy" + // because it is explicitly legal to *pass* the specific intrinsic + // function SIN as an actual argument. + messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US); + } + } } if (symbol.attrs().test(Attr::VALUE)) { CheckValue(symbol, derived); diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc index 79363b264155..46947118508f 100644 --- a/flang/lib/semantics/expression.cc +++ b/flang/lib/semantics/expression.cc @@ -202,7 +202,16 @@ MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) { return Expr{ProcedureDesignator{std::move(*component)}}; } else { CHECK(std::holds_alternative(ref.u)); - return Expr{ProcedureDesignator{symbol}}; + if (symbol.attrs().test(semantics::Attr::INTRINSIC)) { + if (auto interface{ + context_.intrinsics().IsUnrestrictedSpecificIntrinsicFunction( + symbol.name().ToString())}) { + return Expr{ProcedureDesignator{SpecificIntrinsic{ + symbol.name().ToString(), std::move(*interface)}}}; + } + } else { + return Expr{ProcedureDesignator{symbol}}; + } } } else if (auto dyType{DynamicType::From(symbol)}) { return TypedWrapper(*dyType, std::move(ref)); @@ -2520,27 +2529,6 @@ std::optional ArgumentAnalyzer::AnalyzeExpr( return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}}; } else if (MaybeExpr argExpr{context_.Analyze(expr)}) { Expr x{Fold(context_.GetFoldingContext(), std::move(*argExpr))}; - if (const auto *proc{std::get_if(&x.u)}) { - if (!std::holds_alternative(proc->u) && - proc->IsElemental()) { // C1533 - context_.Say(expr.source, - "Non-intrinsic ELEMENTAL procedure cannot be passed as argument"_err_en_US); - } - } - if (auto coarrayRef{ExtractCoarrayRef(x)}) { - const Symbol &coarray{coarrayRef->GetLastSymbol()}; - if (const semantics::DeclTypeSpec * type{coarray.GetType()}) { - if (const semantics::DerivedTypeSpec * derived{type->AsDerived()}) { - if (auto ptr{semantics::FindPointerUltimateComponent(*derived)}) { - AttachDeclaration( - context_.Say(expr.source, - "Coindexed object '%s' with POINTER ultimate component '%s' cannot be passed as argument"_err_en_US, - coarray.name(), ptr->name()), - &*ptr); - } - } - } - } return ActualArgument{std::move(x)}; } else { return std::nullopt; diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc index b24c60418f2d..0d9cf3d44eb0 100644 --- a/flang/lib/semantics/resolve-names.cc +++ b/flang/lib/semantics/resolve-names.cc @@ -1340,6 +1340,7 @@ public: ResolveName(*parser::Unwrap(x.name)); } void Post(const parser::ProcComponentRef &); + bool Pre(const parser::ActualArg &); bool Pre(const parser::FunctionReference &); bool Pre(const parser::CallStmt &); bool Pre(const parser::ImportStmt &); @@ -4301,12 +4302,7 @@ Symbol &DeclarationVisitor::MakeCommonBlockSymbol(const parser::Name &name) { } bool DeclarationVisitor::NameIsKnownOrIntrinsic(const parser::Name &name) { - if (Symbol * symbol{FindSymbol(name)}) { - Resolve(name, *symbol); - return true; - } else { - return HandleUnrestrictedSpecificIntrinsicFunction(name); - } + return FindSymbol(name) || HandleUnrestrictedSpecificIntrinsicFunction(name); } // Check if this derived type can be in a COMMON block. @@ -4342,10 +4338,8 @@ void DeclarationVisitor::CheckCommonBlockDerivedType( bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction( const parser::Name &name) { - if (context() - .intrinsics() - .IsUnrestrictedSpecificIntrinsicFunction(name.source.ToString()) - .has_value()) { + if (context().intrinsics().IsUnrestrictedSpecificIntrinsicFunction( + name.source.ToString())) { // Unrestricted specific intrinsic function names (e.g., "cos") // are acceptable as procedure interfaces. Symbol &symbol{MakeSymbol(InclusiveScope(), name.source, @@ -4794,9 +4788,7 @@ bool ConstructVisitor::Pre(const parser::DataImpliedDo &x) { bool ConstructVisitor::Pre(const parser::DataStmtObject &x) { std::visit( common::visitors{ - [&](const common::Indirection &y) { - Walk(y.value()); - }, + [&](const Indirection &y) { Walk(y.value()); }, [&](const parser::DataImpliedDo &y) { PushScope(Scope::Kind::ImpliedDos, nullptr); Walk(y); @@ -5106,6 +5098,23 @@ const DeclTypeSpec &ConstructVisitor::ToDeclTypeSpec( // ResolveNamesVisitor implementation +// Ensures that bare undeclared intrinsic procedure names passed as actual +// arguments get recognized as being intrinsics. +bool ResolveNamesVisitor::Pre(const parser::ActualArg &arg) { + if (const auto *expr{std::get_if>(&arg.u)}) { + if (const auto *designator{ + std::get_if>(&expr->value().u)}) { + if (const auto *dataRef{ + std::get_if(&designator->value().u)}) { + if (const auto *name{std::get_if(&dataRef->u)}) { + NameIsKnownOrIntrinsic(*name); + } + } + } + } + return true; +} + bool ResolveNamesVisitor::Pre(const parser::FunctionReference &x) { HandleCall(Symbol::Flag::Function, x.v); return false; @@ -5178,11 +5187,11 @@ const parser::Name *DeclarationVisitor::ResolveDataRef( [=](const Indirection &y) { return ResolveStructureComponent(y.value()); }, - [&](const common::Indirection &y) { + [&](const Indirection &y) { Walk(y.value().subscripts); return ResolveDataRef(y.value().base); }, - [&](const common::Indirection &y) { + [&](const Indirection &y) { Walk(y.value().imageSelector); return ResolveDataRef(y.value().base); }, @@ -5194,10 +5203,10 @@ const parser::Name *DeclarationVisitor::ResolveVariable( const parser::Variable &x) { return std::visit( common::visitors{ - [&](const common::Indirection &y) { + [&](const Indirection &y) { return ResolveDesignator(y.value()); }, - [&](const common::Indirection &y) { + [&](const Indirection &y) { const auto &proc{ std::get(y.value().v.t)}; return std::visit( @@ -5398,7 +5407,7 @@ void DeclarationVisitor::Initialization(const parser::Name &name, details->set_init(std::move(*expr)); } }, - [&](const std::list> &) { + [&](const std::list> &) { if (inComponentDecl) { Say(name, "Component '%s' initialized with DATA statement values"_err_en_US); diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt index 267dc0e779f5..3a7e8e61622a 100644 --- a/flang/test/semantics/CMakeLists.txt +++ b/flang/test/semantics/CMakeLists.txt @@ -182,6 +182,7 @@ set(ERROR_TESTS call06.f90 call07.f90 call08.f90 + call09.f90 call13.f90 call14.f90 misc-declarations.f90 diff --git a/flang/test/semantics/call02.f90 b/flang/test/semantics/call02.f90 index 8d42e1248674..e988705b3af5 100644 --- a/flang/test/semantics/call02.f90 +++ b/flang/test/semantics/call02.f90 @@ -16,18 +16,20 @@ subroutine s01(elem, subr) interface - ! Merely declaring an elemental dummy procedure is not an error; - ! if the actual argument were an elemental unrestricted specific - ! intrinsic function, that's okay. elemental real function elem(x) - real, value :: x + real, intent(in), value :: x end function - subroutine subr(elem) - procedure(sin) :: elem + subroutine subr(dummy) + procedure(sin) :: dummy + end subroutine + !ERROR: A dummy procedure may not be ELEMENTAL + subroutine badsubr(dummy) + import :: elem + procedure(elem) :: dummy end subroutine end interface call subr(cos) ! not an error - !ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument + !ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument call subr(elem) ! C1533 end subroutine @@ -47,13 +49,13 @@ module m01 end function subroutine test call callme(cos) ! not an error - !ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument + !ERROR: Non-intrinsic ELEMENTAL procedure 'elem01' may not be passed as an actual argument call callme(elem01) ! C1533 - !ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument + !ERROR: Non-intrinsic ELEMENTAL procedure 'elem02' may not be passed as an actual argument call callme(elem02) ! C1533 - !ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument + !ERROR: Non-intrinsic ELEMENTAL procedure 'elem03' may not be passed as an actual argument call callme(elem03) ! C1533 - !ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument + !ERROR: Non-intrinsic ELEMENTAL procedure 'elem04' may not be passed as an actual argument call callme(elem04) ! C1533 contains elemental real function elem04(x) @@ -72,7 +74,7 @@ module m02 type(t), intent(in) :: x end subroutine subroutine test - !ERROR: Coindexed object 'coarray' with POINTER ultimate component 'ptr' cannot be passed as argument + !ERROR: Coindexed object 'coarray' with POINTER ultimate component 'ptr' cannot be associated with dummy argument 'x=' call callee(coarray[1]) ! C1537 end subroutine end module diff --git a/flang/test/semantics/call09.f90 b/flang/test/semantics/call09.f90 index 2c938c23e4d2..b3b43ab226e4 100644 --- a/flang/test/semantics/call09.f90 +++ b/flang/test/semantics/call09.f90 @@ -12,41 +12,166 @@ ! See the License for the specific language governing permissions and ! limitations under the License. -! Test 15.5.2.9(5) dummy procedure POINTER requirements +! Test 15.5.2.9(2,3,5) dummy procedure requirements module m - 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 + subroutine s01(p) - procedure(sin), pointer, intent(in) :: p + procedure(realfunc), pointer, intent(in) :: p end subroutine subroutine s02(p) - procedure(sin), pointer :: p + procedure(realfunc), pointer :: p + end subroutine + + subroutine selemental1(p) + procedure(cos) :: p ! ok + end subroutine + + real elemental function elemfunc(x) + real, intent(in) :: x + elemfunc = x + end function + !ERROR: A dummy procedure may not be ELEMENTAL + subroutine selemental2(p) + procedure(elemfunc) :: p end subroutine function procptr() - procedure(sin), pointer :: procptr - procptr => cos + procedure(realfunc), pointer :: procptr + procptr => realfunc + end function + function intprocptr() + procedure(intfunc), pointer :: intprocptr + procptr => intfunc end function - subroutine test - procedure(tan), pointer :: p - p => tan + subroutine test1 ! 15.5.2.9(5) + procedure(realfunc), pointer :: p + procedure(intfunc), pointer :: ip + p => realfunc + ip => intfunc + call s01(realfunc) ! ok + !ERROR: Actual argument procedure has interface incompatible with dummy argument 'p=' + call s01(intfunc) call s01(p) ! ok call s01(procptr()) ! ok + !ERROR: Actual argument procedure has interface incompatible with dummy argument 'p=' + call s01(intprocptr()) call s01(null()) ! ok call s01(null(p)) ! ok + !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 pointer dummy argument 'p=' must be a POINTER unless INTENT(IN) + call s02(realfunc) call s02(p) ! ok - !ERROR: Effective argument associated with dummy procedure pointer must be a procedure pointer unless INTENT(IN) + !ERROR: Actual argument procedure has interface incompatible with dummy argument 'p=' + call s02(ip) + !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN) call s02(procptr()) - !ERROR: Effective argument associated with dummy procedure pointer must be a procedure pointer unless INTENT(IN) + !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN) call s02(null()) - !ERROR: Effective argument associated with dummy procedure pointer must be a procedure pointer unless INTENT(IN) + !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN) call s02(null(p)) - !ERROR: Effective argument associated with dummy procedure pointer must be a procedure pointer unless INTENT(IN) + !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN) call s02(sin) end subroutine + subroutine callsub(s) + call s + end subroutine + subroutine takesrealfunc1(f) + external f + real f + end subroutine + subroutine takesrealfunc2(f) + x = f(1) + end subroutine + subroutine forwardproc(p) + implicit none + external :: p ! function or subroutine not known + call foo(p) + end subroutine + + subroutine test2(unknown,ds,drf,dif) ! 15.5.2.9(2,3) + external :: unknown, ds, drf, dif + real :: drf + integer :: dif + procedure(callsub), pointer :: ps + procedure(realfunc), pointer :: prf + procedure(intfunc), pointer :: pif + call ds ! now we know that's it's a subroutine + call callsub(callsub) ! ok apart from infinite recursion + call callsub(unknown) ! ok + call callsub(ds) ! ok + call callsub(ps) ! ok + call takesrealfunc1(realfunc) ! ok + call takesrealfunc1(unknown) ! ok + call takesrealfunc1(drf) ! ok + call takesrealfunc1(prf) ! ok + call takesrealfunc2(realfunc) ! ok + call takesrealfunc2(unknown) ! ok + call takesrealfunc2(drf) ! ok + call takesrealfunc2(prf) ! ok + call forwardproc(callsub) ! ok + call forwardproc(realfunc) ! ok + call forwardproc(intfunc) ! ok + call forwardproc(unknown) ! ok + call forwardproc(ds) ! ok + call forwardproc(drf) ! ok + call forwardproc(dif) ! ok + call forwardproc(ps) ! ok + call forwardproc(prf) ! ok + call forwardproc(pif) ! ok + !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine + call callsub(realfunc) + !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine + call callsub(intfunc) + !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine + call callsub(drf) + !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine + call callsub(dif) + !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine + call callsub(prf) + !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine + call callsub(pif) + !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function + call takesrealfunc1(callsub) + !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function + call takesrealfunc1(ds) + !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function + call takesrealfunc1(ps) + !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type + call takesrealfunc1(intfunc) + !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type + call takesrealfunc1(dif) + !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type + call takesrealfunc1(pif) + !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type + call takesrealfunc1(intfunc) + !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function + call takesrealfunc2(callsub) + !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function + call takesrealfunc2(ds) + !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function + call takesrealfunc2(ps) + !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type + call takesrealfunc2(intfunc) + !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type + call takesrealfunc2(dif) + !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type + call takesrealfunc2(pif) + !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type + call takesrealfunc2(intfunc) + end subroutine end module diff --git a/flang/test/semantics/expr-errors02.f90 b/flang/test/semantics/expr-errors02.f90 index d39cc6ca6e4e..2b32127656df 100644 --- a/flang/test/semantics/expr-errors02.f90 +++ b/flang/test/semantics/expr-errors02.f90 @@ -22,12 +22,13 @@ module m interface integer function foo() end function - pure integer function hasProcArg(p) - procedure(cos) :: p - end function real function realfunc(x) real, intent(in) :: x end function + pure integer function hasProcArg(p) + import realfunc + procedure(realfunc) :: p + end function end interface integer :: coarray[*] contains