From 2f999cce195946b66f968d50e38b06e6a1f60b8e Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Sun, 6 Nov 2022 11:37:12 -0800 Subject: [PATCH] [flang] Respect function vs subroutine distinction in generic matching When checking the specific procedures of a generic interface for a match against a given set of actual arguments, be sure to not match a function against a subroutine call or vice versa. (We generally catch and warn about attempts to declare mixed interfaces, but they are usually conforming and can be inadvertently created when generics are merged due to USE and host association.) Differential Revision: https://reviews.llvm.org/D139059 --- flang/docs/Extensions.md | 9 +++++++ flang/include/flang/Semantics/expression.h | 3 ++- flang/lib/Semantics/expression.cpp | 40 ++++++++++++++++++------------ flang/lib/Semantics/resolve-names.cpp | 15 +++++++---- flang/test/Semantics/generic03.f90 | 34 +++++++++++++++++++++++++ flang/test/Semantics/resolve62.f90 | 2 +- flang/test/Semantics/resolve68.f90 | 4 +-- flang/test/Semantics/resolve77.f90 | 2 +- 8 files changed, 83 insertions(+), 26 deletions(-) create mode 100644 flang/test/Semantics/generic03.f90 diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 039b1f9..a512048 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -356,6 +356,15 @@ end appears as part of a complex-literal-constant be a scalar, but most compilers emit an error when an array appears. f18 supports them with a portability warning. +* f18 does not enforce a blanket prohibition against generic + interfaces containing a mixture of functions and subroutines. + Apart from some contexts in which the standard requires all of + a particular generic interface to have only all functions or + all subroutines as its specific procedures, we allow both to + appear, unlike several other Fortran compilers. + This is especially desirable when two generics of the same + name are combined due to USE association and the mixture may + be inadvertent. ## Behavior in cases where the standard is ambiguous or indefinite diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h index bb6a14a..8474ec6 100644 --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -354,7 +354,8 @@ private: std::pair ResolveGeneric(const Symbol &, const ActualArguments &, const AdjustActuals &, bool isSubroutine, bool mightBeStructureConstructor = false); - void EmitGenericResolutionError(const Symbol &, bool dueToNullActuals); + void EmitGenericResolutionError( + const Symbol &, bool dueToNullActuals, bool isSubroutine); const Symbol &AccessSpecific( const Symbol &originalGeneric, const Symbol &specific); std::optional GetCalleeAndArguments(const parser::Name &, diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 7b9b367..cd0c717 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -174,8 +174,8 @@ private: std::optional AnalyzeExpr(const parser::Expr &); MaybeExpr AnalyzeExprOrWholeAssumedSizeArray(const parser::Expr &); bool AreConformable() const; - const Symbol *FindBoundOp( - parser::CharBlock, int passIndex, const Symbol *&definedOp); + const Symbol *FindBoundOp(parser::CharBlock, int passIndex, + const Symbol *&definedOp, bool isSubroutine); void AddAssignmentConversion( const DynamicType &lhsType, const DynamicType &rhsType); bool OkLogicalIntegerAssignment(TypeCategory lhs, TypeCategory rhs); @@ -2078,7 +2078,8 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef( // re-resolve the name to the specific binding sc.component.symbol = const_cast(sym); } else { - EmitGenericResolutionError(*sc.component.symbol, pair.second); + EmitGenericResolutionError( + *sc.component.symbol, pair.second, isSubroutine); return std::nullopt; } } @@ -2223,6 +2224,9 @@ std::pair ExpressionAnalyzer::ResolveGeneric( return IsBareNullPointer(iter->UnwrapExpr()); }) != actuals.end()}; for (const Symbol &specific : details->specificProcs()) { + if (isSubroutine != !IsFunction(specific)) { + continue; + } if (!ResolveForward(specific)) { continue; } @@ -2327,12 +2331,14 @@ const Symbol &ExpressionAnalyzer::AccessSpecific( } void ExpressionAnalyzer::EmitGenericResolutionError( - const Symbol &symbol, bool dueToNullActuals) { + const Symbol &symbol, bool dueToNullActuals, bool isSubroutine) { Say(dueToNullActuals ? "One or more NULL() actual arguments to the generic procedure '%s' requires a MOLD= for disambiguation"_err_en_US : semantics::IsGenericDefinedOp(symbol) ? "No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US - : "No specific procedure of generic '%s' matches the actual arguments"_err_en_US, + : isSubroutine + ? "No specific subroutine of generic '%s' matches the actual arguments"_err_en_US + : "No specific function of generic '%s' matches the actual arguments"_err_en_US, symbol.name()); } @@ -2395,7 +2401,7 @@ auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name, std::move(specificCall->arguments)}; } else { if (isGenericInterface) { - EmitGenericResolutionError(*symbol, dueToNullActual); + EmitGenericResolutionError(*symbol, dueToNullActual, isSubroutine); } return std::nullopt; } @@ -3654,8 +3660,8 @@ MaybeExpr ArgumentAnalyzer::TryDefinedOp(const char *opr, } } for (std::size_t passIndex{0}; passIndex < actuals_.size(); ++passIndex) { - if (const Symbol *symbol{ - FindBoundOp(oprName, passIndex, *definedOpSymbolPtr)}) { + if (const Symbol * + symbol{FindBoundOp(oprName, passIndex, *definedOpSymbolPtr, false)}) { if (MaybeExpr result{TryBoundOp(*symbol, passIndex)}) { return result; } @@ -3773,15 +3779,16 @@ std::optional ArgumentAnalyzer::GetDefinedAssignmentProc() { if (pair.first) { proc = pair.first; } else { - context_.EmitGenericResolutionError(*symbol, pair.second); + context_.EmitGenericResolutionError(*symbol, pair.second, true); } } int passedObjectIndex{-1}; const Symbol *definedOpSymbol{nullptr}; for (std::size_t i{0}; i < actuals_.size(); ++i) { - if (const Symbol *specific{FindBoundOp(oprName, i, definedOpSymbol)}) { - if (const Symbol *resolution{ - GetBindingResolution(GetType(i), *specific)}) { + if (const Symbol * + specific{FindBoundOp(oprName, i, definedOpSymbol, true)}) { + if (const Symbol * + resolution{GetBindingResolution(GetType(i), *specific)}) { proc = resolution; } else { proc = specific; @@ -3863,8 +3870,8 @@ bool ArgumentAnalyzer::AreConformable() const { } // Look for a type-bound operator in the type of arg number passIndex. -const Symbol *ArgumentAnalyzer::FindBoundOp( - parser::CharBlock oprName, int passIndex, const Symbol *&definedOp) { +const Symbol *ArgumentAnalyzer::FindBoundOp(parser::CharBlock oprName, + int passIndex, const Symbol *&definedOp, bool isSubroutine) { const auto *type{GetDerivedTypeSpec(GetType(passIndex))}; if (!type || !type->scope()) { return nullptr; @@ -3878,9 +3885,10 @@ const Symbol *ArgumentAnalyzer::FindBoundOp( [&](const Symbol &proc, ActualArguments &) { return passIndex == GetPassIndex(proc); }}; - auto pair{context_.ResolveGeneric(*symbol, actuals_, adjustment, false)}; + auto pair{ + context_.ResolveGeneric(*symbol, actuals_, adjustment, isSubroutine)}; if (!pair.first) { - context_.EmitGenericResolutionError(*symbol, pair.second); + context_.EmitGenericResolutionError(*symbol, pair.second, isSubroutine); } return pair.first; } diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 510f7cb..980f1b1 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -3246,9 +3246,8 @@ void InterfaceVisitor::ResolveSpecificsInGeneric(Symbol &generic) { specificProcs_.erase(range.first, range.second); } -// Check that the specific procedures are all functions or all subroutines. -// If there is a derived type with the same name they must be functions. -// Set the corresponding flag on generic. +// Mixed interfaces are allowed by the standard. +// If there is a derived type with the same name, they must all be functions. void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) { ResolveSpecificsInGeneric(generic); auto &details{generic.get()}; @@ -3271,10 +3270,11 @@ void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) { } const Symbol &firstSpecific{specifics.front()}; bool isFunction{firstSpecific.test(Symbol::Flag::Function)}; + bool isBoth{false}; for (const Symbol &specific : specifics) { if (isFunction != specific.test(Symbol::Flag::Function)) { // C1514 auto &msg{Say(generic.name(), - "Generic interface '%s' has both a function and a subroutine"_err_en_US)}; + "Generic interface '%s' has both a function and a subroutine"_warn_en_US)}; if (isFunction) { msg.Attach(firstSpecific.name(), "Function declaration"_en_US); msg.Attach(specific.name(), "Subroutine declaration"_en_US); @@ -3282,6 +3282,9 @@ void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) { msg.Attach(firstSpecific.name(), "Subroutine declaration"_en_US); msg.Attach(specific.name(), "Function declaration"_en_US); } + isFunction = false; + isBoth = true; + break; } } if (!isFunction && details.derivedType()) { @@ -3290,7 +3293,9 @@ void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) { " with same name"_err_en_US, *details.derivedType()->GetUltimate().scope()); } - generic.set(isFunction ? Symbol::Flag::Function : Symbol::Flag::Subroutine); + if (!isBoth) { + generic.set(isFunction ? Symbol::Flag::Function : Symbol::Flag::Subroutine); + } } // SubprogramVisitor implementation diff --git a/flang/test/Semantics/generic03.f90 b/flang/test/Semantics/generic03.f90 new file mode 100644 index 0000000..829780f --- /dev/null +++ b/flang/test/Semantics/generic03.f90 @@ -0,0 +1,34 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Exercise function vs subroutine distinction in generics +module m1 + type t1 + integer n + end type + interface g1 + integer function f1(x, j) + import t1 + class(t1), intent(in out) :: x + integer, intent(in) :: j + end + end interface +end module + +program test + use m1 + !WARNING: Generic interface 'g1' has both a function and a subroutine + interface g1 + subroutine s1(x, a) + import t1 + class(t1), intent(in out) :: x + real, intent(in) :: a + end subroutine + end interface + type(t1) :: x + print *, g1(x,1) ! ok + !ERROR: No specific function of generic 'g1' matches the actual arguments + print *, g1(x,1.) + !ERROR: No specific subroutine of generic 'g1' matches the actual arguments + call g1(x,1) + call g1(x, 1.) ! ok + contains +end diff --git a/flang/test/Semantics/resolve62.f90 b/flang/test/Semantics/resolve62.f90 index ee4049f..5d297f0 100644 --- a/flang/test/Semantics/resolve62.f90 +++ b/flang/test/Semantics/resolve62.f90 @@ -10,7 +10,7 @@ subroutine subr1 end interface z = f(1.0) z = f(1.0, 2.0) - !ERROR: No specific procedure of generic 'f' matches the actual arguments + !ERROR: No specific function of generic 'f' matches the actual arguments z = f(1.0, 2.0, 3.0) end diff --git a/flang/test/Semantics/resolve68.f90 b/flang/test/Semantics/resolve68.f90 index 0221fbc..28d90a6 100644 --- a/flang/test/Semantics/resolve68.f90 +++ b/flang/test/Semantics/resolve68.f90 @@ -21,14 +21,14 @@ contains type(t) :: x integer :: y integer :: z - !ERROR: No specific procedure of generic 'g' matches the actual arguments + !ERROR: No specific function of generic 'g' matches the actual arguments z = x%g(y) end subroutine test2(x, y, z) type(t) :: x real :: y integer :: z - !ERROR: No specific procedure of generic 'g' matches the actual arguments + !ERROR: No specific function of generic 'g' matches the actual arguments z = x%g(x, y) end end diff --git a/flang/test/Semantics/resolve77.f90 b/flang/test/Semantics/resolve77.f90 index d762781..1f5e4d4 100644 --- a/flang/test/Semantics/resolve77.f90 +++ b/flang/test/Semantics/resolve77.f90 @@ -10,7 +10,7 @@ module m end interface !ERROR: Automatic data object 'a' may not appear in the specification part of a module real :: a(if1(1)) - !ERROR: No specific procedure of generic 'ifn2' matches the actual arguments + !ERROR: No specific function of generic 'ifn2' matches the actual arguments real :: b(ifn2(1)) contains subroutine t1(n) -- 2.7.4