diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h index 43f8134b93c5c..c2cb2f568dffc 100644 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -227,7 +227,7 @@ struct DummyDataObject { std::optional *warning = nullptr) const; static std::optional Characterize( const semantics::Symbol &, FoldingContext &); - bool CanBePassedViaImplicitInterface() const; + bool CanBePassedViaImplicitInterface(std::string *whyNot = nullptr) const; llvm::raw_ostream &Dump(llvm::raw_ostream &) const; TypeAndShape type; @@ -248,7 +248,7 @@ struct DummyProcedure { bool operator!=(const DummyProcedure &that) const { return !(*this == that); } bool IsCompatibleWith( const DummyProcedure &, std::string *whyNot = nullptr) const; - bool CanBePassedViaImplicitInterface() const; + bool CanBePassedViaImplicitInterface(std::string *whyNot = nullptr) const; llvm::raw_ostream &Dump(llvm::raw_ostream &) const; CopyableIndirection procedure; @@ -282,7 +282,7 @@ struct DummyArgument { void SetOptional(bool = true); common::Intent GetIntent() const; void SetIntent(common::Intent); - bool CanBePassedViaImplicitInterface() const; + bool CanBePassedViaImplicitInterface(std::string *whyNot = nullptr) const; bool IsTypelessIntrinsicDummy() const; bool IsCompatibleWith(const DummyArgument &, std::string *whyNot = nullptr, std::optional *warning = nullptr) const; @@ -325,7 +325,7 @@ struct FunctionResult { return std::get_if(&u); } void SetType(DynamicType t) { std::get(u).set_type(t); } - bool CanBeReturnedViaImplicitInterface() const; + bool CanBeReturnedViaImplicitInterface(std::string *whyNot = nullptr) const; bool IsCompatibleWith( const FunctionResult &, std::string *whyNot = nullptr) const; @@ -377,7 +377,7 @@ struct Procedure { return !attrs.test(Attr::ImplicitInterface); } int FindPassIndex(std::optional) const; - bool CanBeCalledViaImplicitInterface() const; + bool CanBeCalledViaImplicitInterface(std::string *whyNot = nullptr) const; bool CanOverride(const Procedure &, std::optional passIndex) const; bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr, const SpecificIntrinsic * = nullptr, diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp index 83ef5d069d3cc..90b8616fda27e 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -419,24 +419,45 @@ std::optional DummyDataObject::Characterize( return std::nullopt; } -bool DummyDataObject::CanBePassedViaImplicitInterface() const { +bool DummyDataObject::CanBePassedViaImplicitInterface( + std::string *whyNot) const { if ((attrs & Attrs{Attr::Allocatable, Attr::Asynchronous, Attr::Optional, Attr::Pointer, Attr::Target, Attr::Value, Attr::Volatile}) .any()) { + if (whyNot) { + *whyNot = "a dummy argument has the allocatable, asynchronous, optional, " + "pointer, target, value, or volatile attribute"; + } return false; // 15.4.2.2(3)(a) } else if ((type.attrs() & TypeAndShape::Attrs{TypeAndShape::Attr::AssumedShape, TypeAndShape::Attr::AssumedRank, TypeAndShape::Attr::Coarray}) .any()) { + if (whyNot) { + *whyNot = "a dummy argument is assumed-shape, assumed-rank, or a coarray"; + } return false; // 15.4.2.2(3)(b-d) } else if (type.type().IsPolymorphic()) { + if (whyNot) { + *whyNot = "a dummy argument is polymorphic"; + } return false; // 15.4.2.2(3)(f) } else if (cudaDataAttr) { + if (whyNot) { + *whyNot = "a dummy argument has a CUDA data attribute"; + } return false; } else if (const auto *derived{GetDerivedTypeSpec(type.type())}) { - return derived->parameters().empty(); // 15.4.2.2(3)(e) + if (derived->parameters().empty()) { // 15.4.2.2(3)(e) + return true; + } else { + if (whyNot) { + *whyNot = "a dummy argument has derived type parameters"; + } + return false; + } } else { return true; } @@ -495,8 +516,12 @@ bool DummyProcedure::IsCompatibleWith( return true; } -bool DummyProcedure::CanBePassedViaImplicitInterface() const { +bool DummyProcedure::CanBePassedViaImplicitInterface( + std::string *whyNot) const { if ((attrs & Attrs{Attr::Optional, Attr::Pointer}).any()) { + if (whyNot) { + *whyNot = "a dummy procedure is optional or a pointer"; + } return false; // 15.4.2.2(3)(a) } return true; @@ -897,11 +922,11 @@ common::Intent DummyArgument::GetIntent() const { u); } -bool DummyArgument::CanBePassedViaImplicitInterface() const { +bool DummyArgument::CanBePassedViaImplicitInterface(std::string *whyNot) const { if (const auto *object{std::get_if(&u)}) { - return object->CanBePassedViaImplicitInterface(); + return object->CanBePassedViaImplicitInterface(whyNot); } else if (const auto *proc{std::get_if(&u)}) { - return proc->CanBePassedViaImplicitInterface(); + return proc->CanBePassedViaImplicitInterface(whyNot); } else { return true; } @@ -972,13 +997,23 @@ bool FunctionResult::IsAssumedLengthCharacter() const { } } -bool FunctionResult::CanBeReturnedViaImplicitInterface() const { +bool FunctionResult::CanBeReturnedViaImplicitInterface( + std::string *whyNot) const { if (attrs.test(Attr::Pointer) || attrs.test(Attr::Allocatable)) { + if (whyNot) { + *whyNot = "the function result is a pointer or allocatable"; + } return false; // 15.4.2.2(4)(b) } else if (cudaDataAttr) { + if (whyNot) { + *whyNot = "the function result has CUDA attributes"; + } return false; } else if (const auto *typeAndShape{GetTypeAndShape()}) { if (typeAndShape->Rank() > 0) { + if (whyNot) { + *whyNot = "the function result is an array"; + } return false; // 15.4.2.2(4)(a) } else { const DynamicType &type{typeAndShape->type()}; @@ -988,31 +1023,52 @@ bool FunctionResult::CanBeReturnedViaImplicitInterface() const { return true; } else if (const auto *param{type.charLengthParamValue()}) { if (const auto &expr{param->GetExplicit()}) { - return IsConstantExpr(*expr); // 15.4.2.2(4)(c) + if (IsConstantExpr(*expr)) { // 15.4.2.2(4)(c) + return true; + } else { + if (whyNot) { + *whyNot = "the function result's length is not constant"; + } + return false; + } } else if (param->isAssumed()) { return true; } } + if (whyNot) { + *whyNot = "the function result's length is not known to the caller"; + } return false; case TypeCategory::Derived: - if (!type.IsPolymorphic()) { + if (type.IsPolymorphic()) { + if (whyNot) { + *whyNot = "the function result is polymorphic"; + } + return false; + } else { const auto &spec{type.GetDerivedTypeSpec()}; for (const auto &pair : spec.parameters()) { if (const auto &expr{pair.second.GetExplicit()}) { if (!IsConstantExpr(*expr)) { + if (whyNot) { + *whyNot = "the function result's derived type has a " + "non-constant parameter"; + } return false; // 15.4.2.2(4)(c) } } } return true; } - return false; default: return true; } } } else { - return false; // 15.4.2.2(4)(b) - procedure pointer + if (whyNot) { + *whyNot = "the function result has unknown type or shape"; + } + return false; // 15.4.2.2(4)(b) - procedure pointer? } } @@ -1343,20 +1399,30 @@ std::optional Procedure::FromActuals(const ProcedureDesignator &proc, return callee; } -bool Procedure::CanBeCalledViaImplicitInterface() const { - // TODO: Pass back information on why we return false - if (attrs.test(Attr::Elemental) || attrs.test(Attr::BindC)) { +bool Procedure::CanBeCalledViaImplicitInterface(std::string *whyNot) const { + if (attrs.test(Attr::Elemental)) { + if (whyNot) { + *whyNot = "the procedure is elemental"; + } + return false; // 15.4.2.2(5,6) + } else if (attrs.test(Attr::BindC)) { + if (whyNot) { + *whyNot = "the procedure is BIND(C)"; + } return false; // 15.4.2.2(5,6) } else if (cudaSubprogramAttrs && *cudaSubprogramAttrs != common::CUDASubprogramAttrs::Host && *cudaSubprogramAttrs != common::CUDASubprogramAttrs::Global) { + if (whyNot) { + *whyNot = "the procedure is CUDA but neither HOST nor GLOBAL"; + } return false; } else if (IsFunction() && - !functionResult->CanBeReturnedViaImplicitInterface()) { + !functionResult->CanBeReturnedViaImplicitInterface(whyNot)) { return false; } else { for (const DummyArgument &arg : dummyArguments) { - if (!arg.CanBePassedViaImplicitInterface()) { + if (!arg.CanBePassedViaImplicitInterface(whyNot)) { return false; } } diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index ddaa1e8a3e70f..bfc380183e23f 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -3088,21 +3088,18 @@ const Assignment *ExpressionAnalyzer::Analyze( } static bool IsExternalCalledImplicitly( - parser::CharBlock callSite, const ProcedureDesignator &proc) { - if (const auto *symbol{proc.GetSymbol()}) { - return symbol->has() && - symbol->owner().IsGlobal() && - (!symbol->scope() /*ENTRY*/ || - !symbol->scope()->sourceRange().Contains(callSite)); - } else { - return false; - } + parser::CharBlock callSite, const Symbol *symbol) { + return symbol && symbol->owner().IsGlobal() && + symbol->has() && + (!symbol->scope() /*ENTRY*/ || + !symbol->scope()->sourceRange().Contains(callSite)); } std::optional ExpressionAnalyzer::CheckCall( parser::CharBlock callSite, const ProcedureDesignator &proc, ActualArguments &arguments) { - bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)}; + bool treatExternalAsImplicit{ + IsExternalCalledImplicitly(callSite, proc.GetSymbol())}; const Symbol *procSymbol{proc.GetSymbol()}; std::optional chars; if (procSymbol && procSymbol->has() && @@ -3138,10 +3135,15 @@ std::optional ExpressionAnalyzer::CheckCall( } bool ok{true}; if (chars) { - if (treatExternalAsImplicit && !chars->CanBeCalledViaImplicitInterface()) { - Say(callSite, - "References to the procedure '%s' require an explicit interface"_err_en_US, - DEREF(procSymbol).name()); + std::string whyNot; + if (treatExternalAsImplicit && + !chars->CanBeCalledViaImplicitInterface(&whyNot)) { + if (auto *msg{Say(callSite, + "References to the procedure '%s' require an explicit interface"_err_en_US, + DEREF(procSymbol).name())}; + msg && !whyNot.empty()) { + msg->Attach(callSite, "%s"_because_en_US, whyNot); + } } const SpecificIntrinsic *specificIntrinsic{proc.GetSpecificIntrinsic()}; bool procIsDummy{procSymbol && IsDummy(*procSymbol)}; diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 64fc7de120873..e9497e7eb6ffd 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -7756,6 +7756,11 @@ void ResolveNamesVisitor::HandleProcedureName( if (!symbol->attrs().test(Attr::INTRINSIC)) { if (CheckImplicitNoneExternal(name.source, *symbol)) { MakeExternal(*symbol); + // Create a place-holder HostAssocDetails symbol to preclude later + // use of this name as a local symbol; but don't actually use this new + // HostAssocDetails symbol in expressions. + MakeHostAssocSymbol(name, *symbol); + name.symbol = symbol; } } CheckEntryDummyUse(name.source, symbol); @@ -7763,7 +7768,14 @@ void ResolveNamesVisitor::HandleProcedureName( } else if (CheckUseError(name)) { // error was reported } else { - symbol = &Resolve(name, symbol)->GetUltimate(); + symbol = &symbol->GetUltimate(); + if (!name.symbol || + (name.symbol->has() && symbol->owner().IsGlobal() && + (symbol->has() || + (symbol->has() && + symbol->scope() /*not ENTRY*/)))) { + name.symbol = symbol; + } CheckEntryDummyUse(name.source, symbol); bool convertedToProcEntity{ConvertToProcEntity(*symbol)}; if (convertedToProcEntity && !symbol->attrs().test(Attr::EXTERNAL) && diff --git a/flang/test/Semantics/call24.f90 b/flang/test/Semantics/call24.f90 index 5fbb441908167..78ee17b488676 100644 --- a/flang/test/Semantics/call24.f90 +++ b/flang/test/Semantics/call24.f90 @@ -27,18 +27,22 @@ subroutine test() ! descriptor involved, copy-in/copy-out...) !ERROR: References to the procedure 'foo' require an explicit interface + !BECAUSE: a dummy argument has the allocatable, asynchronous, optional, pointer, target, value, or volatile attribute call foo(a_pointer) ! This call would be error if the interface was explicit here. !ERROR: References to the procedure 'foo' require an explicit interface + !BECAUSE: a dummy argument has the allocatable, asynchronous, optional, pointer, target, value, or volatile attribute call foo(an_array) !ERROR: References to the procedure 'bar' require an explicit interface + !BECAUSE: a dummy procedure is optional or a pointer !WARNING: If the procedure's interface were explicit, this reference would be in error !BECAUSE: Actual argument associated with procedure pointer dummy argument 'a_pointer=' must be a pointer unless INTENT(IN) call bar(sin) !ERROR: References to the procedure 'baz' require an explicit interface + !BECAUSE: a dummy procedure is optional or a pointer call baz(sin) end subroutine diff --git a/flang/test/Semantics/call25.f90 b/flang/test/Semantics/call25.f90 index d6ecd1320463f..3b683fe4e3c4f 100644 --- a/flang/test/Semantics/call25.f90 +++ b/flang/test/Semantics/call25.f90 @@ -1,4 +1,4 @@ -! RUN: not %flang -fsyntax-only 2>&1 %s | FileCheck %s +! RUN: not %flang -fsyntax-only -pedantic 2>&1 %s | FileCheck %s module m contains subroutine subr1(f) diff --git a/flang/test/Semantics/local-vs-global.f90 b/flang/test/Semantics/local-vs-global.f90 index d903e431f2ae2..d1f0a666a6451 100644 --- a/flang/test/Semantics/local-vs-global.f90 +++ b/flang/test/Semantics/local-vs-global.f90 @@ -74,6 +74,7 @@ program test call block_data_before_2 call explicit_before_1(1.) !ERROR: References to the procedure 'explicit_before_2' require an explicit interface + !BECAUSE: a dummy argument has the allocatable, asynchronous, optional, pointer, target, value, or volatile attribute call explicit_before_2(1.) !WARNING: If the procedure's interface were explicit, this reference would be in error !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference @@ -83,6 +84,7 @@ program test call implicit_before_2 print *, explicit_func_before_1(1.) !ERROR: References to the procedure 'explicit_func_before_2' require an explicit interface + !BECAUSE: a dummy argument has the allocatable, asynchronous, optional, pointer, target, value, or volatile attribute print *, explicit_func_before_2(1.) !WARNING: If the procedure's interface were explicit, this reference would be in error !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference @@ -96,6 +98,7 @@ program test call block_data_after_2 call explicit_after_1(1.) !ERROR: References to the procedure 'explicit_after_2' require an explicit interface + !BECAUSE: a dummy argument has the allocatable, asynchronous, optional, pointer, target, value, or volatile attribute call explicit_after_2(1.) !WARNING: If the procedure's interface were explicit, this reference would be in error !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference @@ -105,6 +108,7 @@ program test call implicit_after_2 print *, explicit_func_after_1(1.) !ERROR: References to the procedure 'explicit_func_after_2' require an explicit interface + !BECAUSE: a dummy argument has the allocatable, asynchronous, optional, pointer, target, value, or volatile attribute print *, explicit_func_after_2(1.) !WARNING: If the procedure's interface were explicit, this reference would be in error !BECAUSE: Dummy argument 'a=' (#1) is not OPTIONAL and is not associated with an actual argument in this procedure reference diff --git a/flang/test/Semantics/reshape.f90 b/flang/test/Semantics/reshape.f90 index ea302ceed66aa..b3b96985affc7 100644 --- a/flang/test/Semantics/reshape.f90 +++ b/flang/test/Semantics/reshape.f90 @@ -56,7 +56,7 @@ program reshaper !ERROR: Size of 'shape=' argument must not be greater than 15 CALL ext_sub(RESHAPE([(n, n=1,20)], & [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1])) - !WARNING: Reference to the procedure 'ext_sub' has an implicit interface that is distinct from another reference: incompatible dummy argument #1: incompatible dummy data object shapes + !ERROR: Reference to the procedure 'ext_sub' has an implicit interface that is distinct from another reference: incompatible dummy argument #1: incompatible dummy data object shapes !ERROR: 'shape=' argument must not have a negative extent CALL ext_sub(RESHAPE([(n, n=1,20)], [1, -5, 3])) !ERROR: 'order=' argument has unacceptable rank 2 diff --git a/flang/test/Semantics/resolve09.f90 b/flang/test/Semantics/resolve09.f90 index 6335de1e23274..c5e4277b3b611 100644 --- a/flang/test/Semantics/resolve09.f90 +++ b/flang/test/Semantics/resolve09.f90 @@ -18,7 +18,6 @@ subroutine s !ERROR: Cannot call function 'f' like a subroutine call f !ERROR: Cannot call subroutine 's' like a function - !ERROR: Function result characteristics are not known i = s() contains function f() @@ -71,8 +70,6 @@ subroutine s4 import, none integer :: i !ERROR: 'm' is not a callable procedure - i = m() - !ERROR: 'm' is not a callable procedure call m() end block end @@ -126,3 +123,9 @@ subroutine s9 !ERROR: Cannot call subroutine 'p2' like a function print *, x%p2() end subroutine + +subroutine s10 + call a10 + !ERROR: Actual argument for 'a=' may not be a procedure + print *, abs(a10) +end