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); + common::Intent GetIntent() const; + void SetIntent(common::Intent); bool CanBePassedViaImplicitInterface() const; bool IsTypelessIntrinsicDummy() const; llvm::raw_ostream &Dump(llvm::raw_ostream &) const; diff --git a/flang/include/flang/Evaluate/intrinsics.h b/flang/include/flang/Evaluate/intrinsics.h --- a/flang/include/flang/Evaluate/intrinsics.h +++ b/flang/include/flang/Evaluate/intrinsics.h @@ -102,5 +102,9 @@ private: Implementation *impl_{nullptr}; // owning pointer }; + +// Check if an intrinsic explicitly allows its INTENT(OUT) arguments to be +// allocatable coarrays. +bool AcceptsIntentOutAllocatableCoarray(const std::string &); } // namespace Fortran::evaluate #endif // FORTRAN_EVALUATE_INTRINSICS_H_ 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 @@ -448,6 +448,26 @@ 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); +} + +common::Intent DummyArgument::GetIntent() const { + return std::visit(common::visitors{ + [](const DummyDataObject &data) { return data.intent; }, + [](const DummyProcedure &proc) { return proc.intent; }, + [](const AlternateReturn &) -> common::Intent { + DIE("Alternate return have no intent"); + }, + }, + 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 @@ -198,6 +198,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; }; @@ -935,68 +936,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}, }; @@ -1542,6 +1578,7 @@ } dummyArgs.back().SetOptional(); } + dummyArgs.back().SetIntent(d.intent); } characteristics::Procedure::Attrs attrs; if (elementalRank > 0) { @@ -2148,7 +2185,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)); } @@ -2230,7 +2267,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 { @@ -2273,4 +2311,15 @@ llvm::raw_ostream &IntrinsicProcTable::Dump(llvm::raw_ostream &o) const { return impl_->Dump(o); } + +// In general C846 prohibits allocatable coarrays to be passed to INTENT(OUT) +// dummy arguments. This rule does not apply to intrinsics in general. +// Some intrinsic explicitly allow coarray allocatable in their description. +// It is assumed that unless explicitly allowed for an intrinsic, +// this is forbidden. +// Since there are very few intrinsic identified that allow this, they are +// listed here instead of adding a field in the table. +bool AcceptsIntentOutAllocatableCoarray(const std::string &intrinsic) { + return intrinsic == "move_alloc"; +} } // namespace Fortran::evaluate 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,21 @@ 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, + const evaluate::SpecificIntrinsic *intrinsic); // 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 &, + const evaluate::SpecificIntrinsic *intrinsic); // 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 @@ -140,7 +140,7 @@ const std::string &dummyName, evaluate::Expr &actual, characteristics::TypeAndShape &actualType, bool isElemental, bool actualIsArrayElement, evaluate::FoldingContext &context, - const Scope *scope) { + const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic) { // Basic type & rank checking parser::ContextualMessages &messages{context.messages()}; @@ -314,8 +314,10 @@ } } if (actualLastObject && actualLastObject->IsCoarray() && - IsAllocatable(*actualLastSymbol) && - dummy.intent == common::Intent::Out) { // C846 + IsAllocatable(*actualLastSymbol) && dummy.intent == common::Intent::Out && + !(intrinsic && + evaluate::AcceptsIntentOutAllocatableCoarray( + intrinsic->name))) { // C846 messages.Say( "ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US, actualLastSymbol->name(), dummyName); @@ -594,7 +596,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, const characteristics::DummyArgument &dummy, const characteristics::Procedure &proc, evaluate::FoldingContext &context, - const Scope *scope) { + const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic) { auto &messages{context.messages()}; std::string dummyName{"dummy argument"}; if (!dummy.name.empty()) { @@ -609,7 +611,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), context, scope, + intrinsic); } else if (object.type.type().IsTypelessIntrinsicArgument() && std::holds_alternative( expr->u)) { @@ -701,7 +704,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, + const evaluate::SpecificIntrinsic *intrinsic) { parser::Messages buffer; parser::ContextualMessages messages{context.messages().at(), &buffer}; RearrangeArguments(proc, actuals, messages); @@ -711,7 +715,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, intrinsic); } else if (!dummy.IsOptional()) { if (dummy.name.empty()) { messages.Say( @@ -732,22 +737,25 @@ 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, const evaluate::SpecificIntrinsic *intrinsic) { + return CheckExplicitInterface(proc, actuals, context, &scope, intrinsic); } 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, nullptr) + .empty(); } void CheckArguments(const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, evaluate::FoldingContext &context, - const Scope &scope, bool treatingExternalAsImplicit) { + const Scope &scope, bool treatingExternalAsImplicit, + const evaluate::SpecificIntrinsic *intrinsic) { bool explicitInterface{proc.HasExplicitInterface()}; if (explicitInterface) { - auto buffer{CheckExplicitInterface(proc, actuals, context, scope)}; + auto buffer{ + CheckExplicitInterface(proc, actuals, context, scope, intrinsic)}; 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 @@ -2157,7 +2157,8 @@ } if (!procIsAssociated) { semantics::CheckArguments(*chars, arguments, GetFoldingContext(), - context_.FindScope(callSite), treatExternalAsImplicit); + context_.FindScope(callSite), treatExternalAsImplicit, + proc.GetSpecificIntrinsic()); 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)