diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -356,6 +356,15 @@ 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 --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -354,7 +354,8 @@ 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 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -174,8 +174,8 @@ 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 @@ // 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 @@ 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 @@ } 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 @@ std::move(specificCall->arguments)}; } else { if (isGenericInterface) { - EmitGenericResolutionError(*symbol, dueToNullActual); + EmitGenericResolutionError(*symbol, dueToNullActual, isSubroutine); } return std::nullopt; } @@ -3654,8 +3660,8 @@ } } 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 @@ 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 @@ } // 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 &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 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -3246,9 +3246,8 @@ 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 @@ } 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 @@ 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 @@ " 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 --- /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 --- a/flang/test/Semantics/resolve62.f90 +++ b/flang/test/Semantics/resolve62.f90 @@ -10,7 +10,7 @@ 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 --- a/flang/test/Semantics/resolve68.f90 +++ b/flang/test/Semantics/resolve68.f90 @@ -21,14 +21,14 @@ 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 --- a/flang/test/Semantics/resolve77.f90 +++ b/flang/test/Semantics/resolve77.f90 @@ -10,7 +10,7 @@ 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)