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 @@ -233,6 +233,8 @@ std::string &&, const Expr &, FoldingContext &); bool IsOptional() const; void SetOptional(bool = true); + bool HasIntent(common::Intent) const; + void SetIntent(common::Intent); bool CanBePassedViaImplicitInterface() const; llvm::raw_ostream &Dump(llvm::raw_ostream &) const; // name and pass are not characteristics and so does not participate in 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 @@ -444,6 +444,28 @@ u); } +void DummyArgument::SetIntent(common::Intent intent) { + std::visit(common::visitors{ + [intent](DummyDataObject &data) { data.intent = intent; }, + [intent](DummyProcedure &proc) { proc.intent = intent; }, + [](AlternateReturn &) { DIE("cannot set intent"); }, + }, + u); +} + +bool DummyArgument::HasIntent(common::Intent intent) const { + return std::visit(common::visitors{ + [intent](const DummyDataObject &data) { + return data.intent == intent; + }, + [intent](const DummyProcedure &proc) { + return proc.intent == intent; + }, + [](const AlternateReturn &) { return false; }, + }, + u); +} + bool DummyArgument::CanBePassedViaImplicitInterface() const { if (const auto *object{std::get_if(&u)}) { return object->CanBePassedViaImplicitInterface(); 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 @@ -194,6 +194,7 @@ TypePattern typePattern; Rank rank{Rank::elemental}; Optionality optionality{Optionality::required}; + common::Intent intent{common::Intent::In}; llvm::raw_ostream &Dump(llvm::raw_ostream &) const; }; @@ -931,68 +932,103 @@ }; static const IntrinsicInterface intrinsicSubroutine[]{ - {"cpu_time", {{"time", AnyReal, Rank::scalar}}, {}, Rank::elemental, - IntrinsicClass::impureSubroutine}, + {"cpu_time", + {{"time", AnyReal, Rank::scalar, Optionality::required, + common::Intent::Out}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"date_and_time", - {{"date", DefaultChar, Rank::scalar, Optionality::optional}, - {"time", DefaultChar, Rank::scalar, Optionality::optional}, - {"zone", DefaultChar, Rank::scalar, Optionality::optional}, - {"values", AnyInt, Rank::vector, Optionality::optional}}, + {{"date", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"time", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"zone", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"values", AnyInt, Rank::vector, Optionality::optional, + common::Intent::Out}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"execute_command_line", {{"command", DefaultChar, Rank::scalar}, {"wait", AnyLogical, Rank::scalar, Optionality::optional}, - {"exitstat", AnyInt, Rank::scalar, Optionality::optional}, - {"cmdstat", AnyInt, Rank::scalar, Optionality::optional}, - {"cmdmsg", DefaultChar, Rank::scalar, Optionality::optional}}, + {"exitstat", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::InOut}, + {"cmdstat", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"cmdmsg", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::InOut}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"get_command", - {{"command", DefaultChar, Rank::scalar, Optionality::optional}, - {"length", AnyInt, Rank::scalar, Optionality::optional}, - {"status", AnyInt, Rank::scalar, Optionality::optional}, - {"errmsg", DefaultChar, Rank::scalar, Optionality::optional}}, + {{"command", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"length", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"status", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::InOut}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"get_command_argument", {{"number", AnyInt, Rank::scalar}, - {"value", DefaultChar, Rank::scalar, Optionality::optional}, - {"length", AnyInt, Rank::scalar, Optionality::optional}, - {"status", AnyInt, Rank::scalar, Optionality::optional}, - {"errmsg", DefaultChar, Rank::scalar, Optionality::optional}}, + {"value", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"length", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"status", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::InOut}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"get_environment_variable", {{"name", DefaultChar, Rank::scalar}, - {"value", DefaultChar, Rank::scalar, Optionality::optional}, - {"length", AnyInt, Rank::scalar, Optionality::optional}, - {"status", AnyInt, Rank::scalar, Optionality::optional}, + {"value", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"length", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"status", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, {"trim_name", AnyLogical, Rank::scalar, Optionality::optional}, - {"errmsg", DefaultChar, Rank::scalar, Optionality::optional}}, + {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::InOut}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"move_alloc", - {{"from", SameType, Rank::known}, {"to", SameType, Rank::known}, - {"stat", AnyInt, Rank::scalar, Optionality::optional}, - {"errmsg", DefaultChar, Rank::scalar, Optionality::optional}}, + {{"from", SameType, Rank::known, Optionality::required, + common::Intent::InOut}, + {"to", SameType, Rank::known, Optionality::required, + common::Intent::Out}, + {"stat", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::InOut}}, {}, Rank::elemental, IntrinsicClass::pureSubroutine}, {"mvbits", {{"from", SameInt}, {"frompos", AnyInt}, {"len", AnyInt}, - {"to", SameInt}, {"topos", AnyInt}}, + {"to", SameInt, Rank::elemental, Optionality::required, + common::Intent::Out}, + {"topos", AnyInt}}, {}, Rank::elemental, IntrinsicClass::elementalSubroutine}, // elemental {"random_init", {{"repeatable", AnyLogical, Rank::scalar}, {"image_distinct", AnyLogical, Rank::scalar}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, - {"random_number", {{"harvest", AnyReal, Rank::known}}, {}, Rank::elemental, - IntrinsicClass::impureSubroutine}, + {"random_number", + {{"harvest", AnyReal, Rank::known, Optionality::required, + common::Intent::Out}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"random_seed", - {{"size", DefaultInt, Rank::scalar, Optionality::optional}, + {{"size", DefaultInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, {"put", DefaultInt, Rank::vector, Optionality::optional}, - {"get", DefaultInt, Rank::vector, Optionality::optional}}, + {"get", DefaultInt, Rank::vector, Optionality::optional, + common::Intent::Out}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, // TODO: at most one argument can be // present {"system_clock", - {{"count", AnyInt, Rank::scalar, Optionality::optional}, - {"count_rate", AnyIntOrReal, Rank::scalar, Optionality::optional}, - {"count_max", AnyInt, Rank::scalar, Optionality::optional}}, + {{"count", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"count_rate", AnyIntOrReal, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"count_max", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, }; @@ -1534,6 +1570,7 @@ } dummyArgs.back().SetOptional(); } + dummyArgs.back().SetIntent(d.intent); } characteristics::Procedure::Attrs attrs; if (elementalRank > 0) { @@ -2047,7 +2084,7 @@ for (int j{0}; j < dummies; ++j) { characteristics::DummyDataObject dummy{ GetSpecificType(specific.dummy[j].typePattern)}; - dummy.intent = common::Intent::In; + dummy.intent = specific.dummy[j].intent; args.emplace_back( std::string{specific.dummy[j].keyword}, std::move(dummy)); } @@ -2129,7 +2166,8 @@ o << keyword << '='; } return typePattern.Dump(o) - << ' ' << EnumToString(rank) << ' ' << EnumToString(optionality); + << ' ' << EnumToString(rank) << ' ' << EnumToString(optionality) + << EnumToString(intent); } llvm::raw_ostream &IntrinsicInterface::Dump(llvm::raw_ostream &o) const { diff --git a/flang/lib/Semantics/check-call.h b/flang/lib/Semantics/check-call.h --- a/flang/lib/Semantics/check-call.h +++ b/flang/lib/Semantics/check-call.h @@ -27,19 +27,19 @@ namespace Fortran::semantics { class Scope; -// The Boolean flag argument should be true when the called procedure +// Argument treatingExternalAsImplicit should be true when the called procedure // does not actually have an explicit interface at the call site, but // its characteristics are known because it is a subroutine or function // defined at the top level in the same source file. void CheckArguments(const evaluate::characteristics::Procedure &, evaluate::ActualArguments &, evaluate::FoldingContext &, const Scope &, - bool treatingExternalAsImplicit = false); + bool treatingExternalAsImplicit, bool isIntrinsicCall); // Checks actual arguments against a procedure with an explicit interface. // Reports a buffer of errors when not compatible. parser::Messages CheckExplicitInterface( const evaluate::characteristics::Procedure &, evaluate::ActualArguments &, - const evaluate::FoldingContext &, const Scope &); + const evaluate::FoldingContext &, const Scope &, bool isIntrinsicCall); // Checks actual arguments for the purpose of resolving a generic interface. bool CheckInterfaceForGeneric(const evaluate::characteristics::Procedure &, 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 @@ -139,8 +139,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, const std::string &dummyName, evaluate::Expr &actual, characteristics::TypeAndShape &actualType, bool isElemental, - bool actualIsArrayElement, evaluate::FoldingContext &context, - const Scope *scope) { + bool actualIsArrayElement, bool isIntrinsicCall, + evaluate::FoldingContext &context, const Scope *scope) { // Basic type & rank checking parser::ContextualMessages &messages{context.messages()}; @@ -313,7 +313,7 @@ dummyName); } } - if (actualLastObject && actualLastObject->IsCoarray() && + if (!isIntrinsicCall && actualLastObject && actualLastObject->IsCoarray() && IsAllocatable(*actualLastSymbol) && dummy.intent == common::Intent::Out) { // C846 messages.Say( @@ -590,7 +590,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, const characteristics::DummyArgument &dummy, const characteristics::Procedure &proc, evaluate::FoldingContext &context, - const Scope *scope) { + const Scope *scope, bool isIntrinsicCall) { auto &messages{context.messages()}; std::string dummyName{"dummy argument"}; if (!dummy.name.empty()) { @@ -605,7 +605,8 @@ arg.set_dummyIntent(object.intent); bool isElemental{object.type.Rank() == 0 && proc.IsElemental()}; CheckExplicitDataArg(object, dummyName, *expr, *type, - isElemental, IsArrayElement(*expr), context, scope); + isElemental, IsArrayElement(*expr), isIntrinsicCall, + context, scope); } else if (object.type.type().IsTypelessIntrinsicArgument() && std::holds_alternative( expr->u)) { @@ -694,7 +695,8 @@ static parser::Messages CheckExplicitInterface( const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, - const evaluate::FoldingContext &context, const Scope *scope) { + const evaluate::FoldingContext &context, const Scope *scope, + bool isIntrinsicCall) { parser::Messages buffer; parser::ContextualMessages messages{context.messages().at(), &buffer}; RearrangeArguments(proc, actuals, messages); @@ -704,7 +706,8 @@ for (auto &actual : actuals) { const auto &dummy{proc.dummyArguments.at(index++)}; if (actual) { - CheckExplicitInterfaceArg(*actual, dummy, proc, localContext, scope); + CheckExplicitInterfaceArg( + *actual, dummy, proc, localContext, scope, isIntrinsicCall); } else if (!dummy.IsOptional()) { if (dummy.name.empty()) { messages.Say( @@ -725,22 +728,26 @@ parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context, - const Scope &scope) { - return CheckExplicitInterface(proc, actuals, context, &scope); + const Scope &scope, bool isIntrinsicCall) { + return CheckExplicitInterface( + proc, actuals, context, &scope, isIntrinsicCall); } bool CheckInterfaceForGeneric(const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context) { - return CheckExplicitInterface(proc, actuals, context, nullptr).empty(); + return CheckExplicitInterface( + proc, actuals, context, nullptr, false /* isIntrinsicCall */) + .empty(); } void CheckArguments(const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, evaluate::FoldingContext &context, - const Scope &scope, bool treatingExternalAsImplicit) { + const Scope &scope, bool treatingExternalAsImplicit, bool isIntrinsicCall) { bool explicitInterface{proc.HasExplicitInterface()}; if (explicitInterface) { - auto buffer{CheckExplicitInterface(proc, actuals, context, scope)}; + auto buffer{ + CheckExplicitInterface(proc, actuals, context, scope, isIntrinsicCall)}; if (treatingExternalAsImplicit && !buffer.empty()) { if (auto *msg{context.messages().Say( "Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) { diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2147,8 +2147,9 @@ "References to the procedure '%s' require an explicit interface"_en_US, DEREF(proc.GetSymbol()).name()); } + bool isIntrinsicCall{proc.GetSpecificIntrinsic() != nullptr}; semantics::CheckArguments(*chars, arguments, GetFoldingContext(), - context_.FindScope(callSite), treatExternalAsImplicit); + context_.FindScope(callSite), treatExternalAsImplicit, isIntrinsicCall); const Symbol *procSymbol{proc.GetSymbol()}; if (procSymbol && !IsPureProcedure(*procSymbol)) { if (const semantics::Scope * diff --git a/flang/test/Semantics/call03.f90 b/flang/test/Semantics/call03.f90 --- a/flang/test/Semantics/call03.f90 +++ b/flang/test/Semantics/call03.f90 @@ -189,6 +189,8 @@ call intentout(x) ! ok !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable call intentout((x)) + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'count=' must be definable + call system_clock(count=2) !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable call intentinout(in) !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable @@ -198,6 +200,8 @@ call intentinout(x) ! ok !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable call intentinout((x)) + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'exitstat=' must be definable + call execute_command_line(command="echo hello", exitstat=0) end subroutine subroutine test12 ! 15.5.2.4(21)