Index: flang/include/flang/Semantics/tools.h =================================================================== --- flang/include/flang/Semantics/tools.h +++ flang/include/flang/Semantics/tools.h @@ -614,5 +614,10 @@ const Symbol *FindUnsafeIoDirectComponent( GenericKind::DefinedIo, const DerivedTypeSpec &, const Scope * = nullptr); +// Some intrinsic operators have more than one name (e.g. `operator(.eq.)` and +// `operator(==)`). GetAllNames() returns them all, including symbolName. +std::forward_list GetAllNames( + const SemanticsContext &, const SourceName &); + } // namespace Fortran::semantics #endif // FORTRAN_SEMANTICS_TOOLS_H_ Index: flang/lib/Semantics/expression.cpp =================================================================== --- flang/lib/Semantics/expression.cpp +++ flang/lib/Semantics/expression.cpp @@ -9,6 +9,7 @@ #include "flang/Semantics/expression.h" #include "check-call.h" #include "pointer-assignment.h" +#include "resolve-names-utils.h" #include "resolve-names.h" #include "flang/Common/Fortran.h" #include "flang/Common/idioms.h" @@ -2106,6 +2107,28 @@ if (mightBeStructureConstructor && details.derivedType()) { return {details.derivedType(), false}; } + // Check for generic or explicit intrinsic of the same name in outer scopes. + // See 15.5.5.2 for details. + const Symbol *outer{nullptr}; + if (!symbol.owner().IsGlobal()) { + for (const std::string &n : GetAllNames(context_, symbol.name())) { + outer = symbol.owner().parent().FindSymbol(n); + if (outer) { + break; + } + } + } + if (outer) { + const Symbol &outerUltimate{outer->GetUltimate()}; + if (outerUltimate.has()) { + return ResolveGeneric( + *outer, actuals, adjustActuals, mightBeStructureConstructor); + } + if (outerUltimate.has() && + outer->attrs().test(semantics::Attr::INTRINSIC)) { + return {outer, false}; + } + } return {nullptr, false}; } Index: flang/lib/Semantics/resolve-names.cpp =================================================================== --- flang/lib/Semantics/resolve-names.cpp +++ flang/lib/Semantics/resolve-names.cpp @@ -4048,11 +4048,13 @@ bool DeclarationVisitor::Pre(const parser::IntrinsicStmt &x) { HandleAttributeStmt(Attr::INTRINSIC, x.v); for (const auto &name : x.v) { + if (!IsIntrinsic(name.source, std::nullopt)) { + Say(name.source, "'%s' is not a known intrinsic procedure"_err_en_US); + } auto &symbol{DEREF(FindSymbol(name))}; if (symbol.has()) { // Generic interface is extending intrinsic; ok - } else if (!symbol.has() && - !ConvertToProcEntity(symbol)) { + } else if (!ConvertToProcEntity(symbol)) { SayWithDecl( name, symbol, "INTRINSIC attribute not allowed on '%s'"_err_en_US); } else if (symbol.attrs().test(Attr::EXTERNAL)) { // C840 @@ -4096,25 +4098,6 @@ } Symbol &DeclarationVisitor::HandleAttributeStmt( Attr attr, const parser::Name &name) { - if (attr == Attr::INTRINSIC) { - if (!IsIntrinsic(name.source, std::nullopt)) { - Say(name.source, "'%s' is not a known intrinsic procedure"_err_en_US); - } else if (currScope().kind() == Scope::Kind::Subprogram || - currScope().kind() == Scope::Kind::Block) { - if (auto *symbol{FindSymbol(name)}) { - if (symbol->GetUltimate().has() && - symbol->owner() != currScope()) { - // Declaring a name INTRINSIC when there is a generic - // interface of the same name in the host scope. - // Host-associate the generic and mark it INTRINSIC - // rather than completely overriding the generic. - symbol = &MakeHostAssocSymbol(name, *symbol); - symbol->attrs().set(Attr::INTRINSIC); - return *symbol; - } - } - } - } auto *symbol{FindInScope(name)}; if (attr == Attr::ASYNCHRONOUS || attr == Attr::VOLATILE) { // these can be set on a symbol that is host-assoc or use-assoc @@ -7056,39 +7039,37 @@ Symbol *existing{nullptr}; // Check all variants of names, e.g. "operator(.ne.)" for "operator(/=)" for (const std::string &n : GetAllNames(context(), symbolName)) { - existing = currScope().FindSymbol(n); - if (existing) { + if (auto iter{currScope().find(n)}; iter != currScope().end()) { + existing = &*iter->second; break; } } if (existing) { Symbol &ultimate{existing->GetUltimate()}; if (const auto *existingGeneric{ultimate.detailsIf()}) { - if (&ultimate.owner() != &currScope()) { - // Create a local copy of a host or use associated generic so that + if (const auto *existingUse{existing->detailsIf()}) { + // Create a local copy of a use associated generic so that // it can be locally extended without corrupting the original. genericDetails.CopyFrom(*existingGeneric); - if (const auto *use{existing->detailsIf()}) { - AddGenericUse(genericDetails, existing->name(), use->symbol()); - EraseSymbol(*existing); - } - existing = &MakeSymbol(symbolName, Attrs{}, std::move(genericDetails)); - } - info.Resolve(existing); - return; - } - if (&existing->owner() == &currScope()) { - if (ultimate.has() || - ultimate.has()) { - genericDetails.set_specific(ultimate); - } else if (ultimate.has()) { - genericDetails.set_derivedType(ultimate); - } else { - SayAlreadyDeclared(symbolName, *existing); + AddGenericUse(genericDetails, existing->name(), existingUse->symbol()); + } else if (existing == &ultimate) { + // Extending an extant generic in the same scope + info.Resolve(existing); return; + } else { + // Host association of a generic is handled in ResolveGeneric() + CHECK(existing->has()); } - EraseSymbol(*existing); + } else if (ultimate.has() || + ultimate.has()) { + genericDetails.set_specific(ultimate); + } else if (ultimate.has()) { + genericDetails.set_derivedType(ultimate); + } else { + SayAlreadyDeclared(symbolName, *existing); + return; } + EraseSymbol(*existing); } info.Resolve(&MakeSymbol(symbolName, Attrs{}, std::move(genericDetails))); } Index: flang/lib/Semantics/tools.cpp =================================================================== --- flang/lib/Semantics/tools.cpp +++ flang/lib/Semantics/tools.cpp @@ -668,7 +668,7 @@ derived.typeSymbol().detailsIf()}) { const auto &finals{details->finals()}; return std::any_of(finals.begin(), finals.end(), - [](const auto &x) { return !x.second->attrs().test(Attr::PURE); }); + [](const auto &x) { return !IsPureProcedure(*x.second); }); } else { return false; } Index: flang/test/Semantics/generic01.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/generic01.f90 @@ -0,0 +1,75 @@ +! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s +! Tests rules of 15.5.5.2 for generics and explicit intrinsics +! competing at various scoping levels. +module m1 + private + public abs + interface abs + module procedure abs_int_redef + end interface +contains + integer function abs_int_redef(j) + integer, intent(in) :: j + abs_int_redef = j + end function +end module + +module m2 + private + public abs + interface abs + module procedure abs_real_redef + end interface +contains + real function abs_real_redef(x) + real, intent(in) :: x + abs_real_redef = x + end function +end module + +module m3 + use m1, only: abs + implicit none +contains + subroutine test1 + use m2, only: abs + !CHECK: abs_int_redef( + print *, abs(1) + !CHECK: abs_real_redef( + print *, abs(1.) + !CHECK: 1.41421353816986083984375_4 + print *, abs((1,1)) + end subroutine + subroutine test2 + intrinsic abs ! override module's use of m1 + block + use m2, only: abs + !CHECK: 1_4 + print *, abs(1) + !CHECK: abs_real_redef( + print *, abs(1.) + !CHECK: 1.41421353816986083984375_4 + print *, abs((1,1)) + end block + end subroutine + subroutine test3 + interface abs + module procedure abs_int_redef2 ! override module's use of m1 + end interface + !CHECK: abs_int_redef2( + print *, abs(1) + !CHECK: 1._4 + print *, abs(1.) + !CHECK: 1.41421353816986083984375_4 + print *, abs((1,1)) + block + use m1, only: abs ! override the override + !CHECK: abs_int_redef( + print *, abs(1) + end block + end subroutine + integer function abs_int_redef2(j) + integer, intent(in) :: j + abs_int_redef2 = j + end function +end module