diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h index b6a9ebefec9df..4cf82e7c14d70 100644 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -251,7 +251,8 @@ struct DummyDataObject { std::optional *warning = nullptr) const; static std::optional Characterize( const semantics::Symbol &, FoldingContext &); - bool CanBePassedViaImplicitInterface(std::string *whyNot = nullptr) const; + bool CanBePassedViaImplicitInterface( + std::string *whyNot = nullptr, bool checkCUDA = true) const; bool IsPassedByDescriptor(bool isBindC) const; llvm::raw_ostream &Dump(llvm::raw_ostream &) const; @@ -307,7 +308,8 @@ struct DummyArgument { void SetOptional(bool = true); common::Intent GetIntent() const; void SetIntent(common::Intent); - bool CanBePassedViaImplicitInterface(std::string *whyNot = nullptr) const; + bool CanBePassedViaImplicitInterface( + std::string *whyNot = nullptr, bool checkCUDA = true) const; bool IsTypelessIntrinsicDummy() const; bool IsCompatibleWith(const DummyArgument &, std::string *whyNot = nullptr, std::optional *warning = nullptr) const; @@ -402,7 +404,8 @@ struct Procedure { return !attrs.test(Attr::ImplicitInterface); } std::optional FindPassIndex(std::optional) const; - bool CanBeCalledViaImplicitInterface(std::string *whyNot = nullptr) const; + bool CanBeCalledViaImplicitInterface( + std::string *whyNot = nullptr, bool checkCUDA = true) const; bool CanOverride(const Procedure &, std::optional passIndex) const; bool IsCompatibleWith(const Procedure &, bool ignoreImplicitVsExplicit, std::string *whyNot = nullptr, const SpecificIntrinsic * = nullptr, diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp index 37c62c93a87df..542f1223e658d 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -458,7 +458,7 @@ std::optional DummyDataObject::Characterize( } bool DummyDataObject::CanBePassedViaImplicitInterface( - std::string *whyNot) const { + std::string *whyNot, bool checkCUDA) const { if ((attrs & Attrs{Attr::Allocatable, Attr::Asynchronous, Attr::Optional, Attr::Pointer, Attr::Target, Attr::Value, Attr::Volatile}) @@ -482,7 +482,7 @@ bool DummyDataObject::CanBePassedViaImplicitInterface( *whyNot = "a dummy argument is polymorphic"; } return false; // 15.4.2.2(3)(f) - } else if (cudaDataAttr) { + } else if (checkCUDA && cudaDataAttr) { if (whyNot) { *whyNot = "a dummy argument has a CUDA data attribute"; } @@ -1012,9 +1012,10 @@ common::Intent DummyArgument::GetIntent() const { u); } -bool DummyArgument::CanBePassedViaImplicitInterface(std::string *whyNot) const { +bool DummyArgument::CanBePassedViaImplicitInterface( + std::string *whyNot, bool checkCUDA) const { if (const auto *object{std::get_if(&u)}) { - return object->CanBePassedViaImplicitInterface(whyNot); + return object->CanBePassedViaImplicitInterface(whyNot, checkCUDA); } else if (const auto *proc{std::get_if(&u)}) { return proc->CanBePassedViaImplicitInterface(whyNot); } else { @@ -1501,7 +1502,8 @@ std::optional Procedure::FromActuals(const ProcedureDesignator &proc, return callee; } -bool Procedure::CanBeCalledViaImplicitInterface(std::string *whyNot) const { +bool Procedure::CanBeCalledViaImplicitInterface( + std::string *whyNot, bool checkCUDA) const { if (attrs.test(Attr::Elemental)) { if (whyNot) { *whyNot = "the procedure is elemental"; @@ -1524,7 +1526,7 @@ bool Procedure::CanBeCalledViaImplicitInterface(std::string *whyNot) const { return false; } else { for (const DummyArgument &arg : dummyArguments) { - if (!arg.CanBePassedViaImplicitInterface(whyNot)) { + if (!arg.CanBePassedViaImplicitInterface(whyNot, checkCUDA)) { return false; } } diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index 4939d8d64a999..81c53aaf9e339 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -56,28 +56,44 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg, "%VAL argument must be a scalar numeric or logical expression"_err_en_US); } if (const auto *expr{arg.UnwrapExpr()}) { - if (const Symbol * base{GetFirstSymbol(*expr)}; - base && IsFunctionResult(*base)) { - context.NoteDefinedSymbol(*base); + if (const Symbol *base{GetFirstSymbol(*expr)}) { + const Symbol &symbol{GetAssociationRoot(*base)}; + if (IsFunctionResult(symbol)) { + context.NoteDefinedSymbol(symbol); + } } if (IsBOZLiteral(*expr)) { - messages.Say("BOZ argument requires an explicit interface"_err_en_US); + messages.Say("BOZ argument %s requires an explicit interface"_err_en_US, + expr->AsFortran()); } else if (evaluate::IsNullPointerOrAllocatable(expr)) { messages.Say( - "Null pointer argument requires an explicit interface"_err_en_US); + "Null pointer argument '%s' requires an explicit interface"_err_en_US, + expr->AsFortran()); } else if (auto named{evaluate::ExtractNamedEntity(*expr)}) { - const Symbol &symbol{named->GetLastSymbol()}; - if (IsAssumedRank(symbol)) { + const Symbol &resolved{ResolveAssociations(named->GetLastSymbol())}; + if (IsAssumedRank(resolved)) { messages.Say( - "Assumed rank argument requires an explicit interface"_err_en_US); + "Assumed rank argument '%s' requires an explicit interface"_err_en_US, + expr->AsFortran()); } + const Symbol &symbol{GetAssociationRoot(resolved)}; if (symbol.attrs().test(Attr::ASYNCHRONOUS)) { messages.Say( - "ASYNCHRONOUS argument requires an explicit interface"_err_en_US); + "ASYNCHRONOUS argument '%s' requires an explicit interface"_err_en_US, + expr->AsFortran()); } if (symbol.attrs().test(Attr::VOLATILE)) { messages.Say( - "VOLATILE argument requires an explicit interface"_err_en_US); + "VOLATILE argument '%s' requires an explicit interface"_err_en_US, + expr->AsFortran()); + } + if (const auto *object{symbol.detailsIf()}) { + if (object->cudaDataAttr()) { + messages.Warn(/*inModuleFile=*/false, context.languageFeatures(), + common::UsageWarning::CUDAUsage, + "Actual argument '%s' with CUDA data attributes should be passed via an explicit interface"_warn_en_US, + expr->AsFortran()); + } } } else if (auto argChars{characteristics::DummyArgument::FromActual( "actual argument", *expr, context.foldingContext(), @@ -2387,44 +2403,51 @@ bool CheckArguments(const characteristics::Procedure &proc, evaluate::FoldingContext foldingContext{context.foldingContext()}; parser::ContextualMessages &messages{foldingContext.messages()}; bool allowArgumentConversions{true}; + parser::Messages implicitBuffer; if (!explicitInterface || treatingExternalAsImplicit) { - parser::Messages buffer; { - auto restorer{messages.SetMessages(buffer)}; + auto restorer{messages.SetMessages(implicitBuffer)}; for (auto &actual : actuals) { if (actual) { CheckImplicitInterfaceArg(*actual, messages, context); } } } - if (!buffer.empty()) { + if (implicitBuffer.AnyFatalError()) { if (auto *msgs{messages.messages()}) { - msgs->Annex(std::move(buffer)); + msgs->Annex(std::move(implicitBuffer)); } return false; // don't pile on } allowArgumentConversions = false; } if (explicitInterface) { - auto buffer{CheckExplicitInterface(proc, actuals, context, &scope, + auto explicitBuffer{CheckExplicitInterface(proc, actuals, context, &scope, intrinsic, allowArgumentConversions, /*extentErrors=*/true, ignoreImplicitVsExplicit)}; - if (!buffer.empty()) { + if (!explicitBuffer.empty()) { if (treatingExternalAsImplicit) { - if (auto *msg{foldingContext.Warn( + // Combine all messages into one warning + if (auto *warning{messages.Warn(/*inModuleFile=*/false, + context.languageFeatures(), common::UsageWarning::KnownBadImplicitInterface, "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) { - buffer.AttachTo(*msg, parser::Severity::Because); - } else { - buffer.clear(); + explicitBuffer.AttachTo(*warning, parser::Severity::Because); } + } else if (auto *msgs{messages.messages()}) { + msgs->Annex(std::move(explicitBuffer)); } - if (auto *msgs{messages.messages()}) { - msgs->Annex(std::move(buffer)); - } + // These messages override any in implicitBuffer. return false; } } - return true; + if (!implicitBuffer.empty()) { + if (auto *msgs{messages.messages()}) { + msgs->Annex(std::move(implicitBuffer)); + } + return false; + } else { + return true; // no messages + } } } // namespace Fortran::semantics diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 836500145e4a2..fc268886c5feb 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -3628,7 +3628,7 @@ std::optional ExpressionAnalyzer::CheckCall( if (chars) { std::string whyNot; if (treatExternalAsImplicit && - !chars->CanBeCalledViaImplicitInterface(&whyNot)) { + !chars->CanBeCalledViaImplicitInterface(&whyNot, /*checkCUDA=*/false)) { if (auto *msg{Say(callSite, "References to the procedure '%s' require an explicit interface"_err_en_US, DEREF(procSymbol).name())}; diff --git a/flang/test/Semantics/boz-literal-constants.f90 b/flang/test/Semantics/boz-literal-constants.f90 index 4d957d13f3f67..67e9ce78537b7 100644 --- a/flang/test/Semantics/boz-literal-constants.f90 +++ b/flang/test/Semantics/boz-literal-constants.f90 @@ -120,7 +120,7 @@ subroutine explicit(n, x, c) !ERROR: Actual argument 'z'55'' associated with dummy argument 'c=' is not a variable or typed expression call explicit(z'deadbeef', o'666', b'01010101') - !ERROR: BOZ argument requires an explicit interface + !ERROR: BOZ argument z'12345' requires an explicit interface call implictSub(Z'12345') !ERROR: Output item must not be a BOZ literal constant diff --git a/flang/test/Semantics/call13.f90 b/flang/test/Semantics/call13.f90 index 3f7fb2efc8f63..90e19180f9c56 100644 --- a/flang/test/Semantics/call13.f90 +++ b/flang/test/Semantics/call13.f90 @@ -20,7 +20,7 @@ subroutine s(assumedRank, coarray, class, classStar, typeStar) real :: array(implicit01()) ! 15.4.2.2(2) !ERROR: Keyword 'keyword=' may not appear in a reference to a procedure with an implicit interface call implicit10(1, 2, keyword=3) ! 15.4.2.2(1) - !ERROR: Assumed rank argument requires an explicit interface + !ERROR: Assumed rank argument 'assumedrank' requires an explicit interface call implicit11(assumedRank) ! 15.4.2.2(3)(c) call implicit12(coarray) ! ok call implicit12a(coarray[1]) ! ok diff --git a/flang/test/Semantics/cuf24.cuf b/flang/test/Semantics/cuf24.cuf new file mode 100644 index 0000000000000..67c9d5d72ebbd --- /dev/null +++ b/flang/test/Semantics/cuf24.cuf @@ -0,0 +1,40 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 -fopenacc + +subroutine implicitDeviceInSameFile(v) + real, device :: v(10) +end + +subroutine implicitNonDeviceInSameFile(v) + real :: v(10) +end + +program p + real, device :: dev(10) + real :: host(10) + interface + subroutine explicitDevice(v) + real, device :: v(10) + end + subroutine explicitNonDevice(v) + real :: v(10) + end + end interface + !WARNING: Actual argument 'dev' with CUDA data attributes should be passed via an explicit interface [-Wcuda-usage] + call implicit1(dev) + call implicit2(host) + !WARNING: Actual argument 'dev' with CUDA data attributes should be passed via an explicit interface [-Wcuda-usage] + call implicitDeviceInSameFile(dev) + !WARNING: If the procedure's interface were explicit, this reference would be in error [-Wknown-bad-implicit-interface] + !BECAUSE: dummy argument 'v=' has ATTRIBUTES(DEVICE) but its associated actual argument has no CUDA data attribute + call implicitDeviceInSameFile(host) + !WARNING: If the procedure's interface were explicit, this reference would be in error [-Wknown-bad-implicit-interface] + !BECAUSE: dummy argument 'v=' has no CUDA data attribute but its associated actual argument has ATTRIBUTES(DEVICE) + call implicitNonDeviceInSameFile(dev) + call implicitNonDeviceInSameFile(host) + call explicitDevice(dev) + !ERROR: dummy argument 'v=' has ATTRIBUTES(DEVICE) but its associated actual argument has no CUDA data attribute + call explicitDevice(host) + !ERROR: dummy argument 'v=' has no CUDA data attribute but its associated actual argument has ATTRIBUTES(DEVICE) + call explicitNonDevice(dev) + call explicitNonDevice(host) +end diff --git a/flang/test/Semantics/null01.f90 b/flang/test/Semantics/null01.f90 index 64c9881297308..ccf617996c30b 100644 --- a/flang/test/Semantics/null01.f90 +++ b/flang/test/Semantics/null01.f90 @@ -116,9 +116,9 @@ function f3() call optionalAllocatable(null(mold=ip0)) call optionalAllocatable(null(mold=ia0)) ! fine call optionalAllocatable(null()) ! fine - !ERROR: Null pointer argument requires an explicit interface + !ERROR: Null pointer argument 'NULL()' requires an explicit interface call implicit(null()) - !ERROR: Null pointer argument requires an explicit interface + !ERROR: Null pointer argument 'null(mold=ip0)' requires an explicit interface call implicit(null(mold=ip0)) !ERROR: A NULL() pointer is not allowed for 'x=' intrinsic argument print *, sin(null(rp0))