diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -813,16 +813,17 @@ if (symbol.attrs().test(Attr::POINTER)) { CheckPointerInitialization(symbol); if (const Symbol * interface{details.interface().symbol()}) { - if (interface->attrs().test(Attr::INTRINSIC)) { + const Symbol &ultimate{interface->GetUltimate()}; + if (ultimate.attrs().test(Attr::INTRINSIC)) { if (const auto intrinsic{ context_.intrinsics().IsSpecificIntrinsicFunction( - interface->name().ToString())}; + ultimate.name().ToString())}; !intrinsic || intrinsic->isRestrictedSpecific) { // C1515 messages_.Say( "Intrinsic procedure '%s' is not an unrestricted specific " "intrinsic permitted for use as the definition of the interface " "to procedure pointer '%s'"_err_en_US, - interface->name(), symbol.name()); + ultimate.name(), symbol.name()); } } else if (IsElementalProcedure(*interface)) { messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US, 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 @@ -2834,6 +2834,25 @@ newSymbol.flags() = useSymbol.flags(); return; } + } else { + auto localClass{ClassifyProcedure(localUltimate)}; + auto useClass{ClassifyProcedure(useUltimate)}; + if (localClass == useClass && + (localClass == ProcedureDefinitionClass::Intrinsic || + localClass == ProcedureDefinitionClass::External) && + localUltimate.name() == useUltimate.name()) { + auto localChars{evaluate::characteristics::Procedure::Characterize( + localUltimate, GetFoldingContext())}; + auto useChars{evaluate::characteristics::Procedure::Characterize( + useUltimate, GetFoldingContext())}; + if (localChars && useChars) { + if (*localChars == *useChars) { + // Same intrinsic or external procedure defined identically in two + // modules + return; + } + } + } } if (!combine) { if (!ConvertToUseError(localSymbol, location, *useModuleScope_)) { @@ -4775,7 +4794,7 @@ } bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) { if (auto *name{std::get_if(&x.u)}) { - return !NameIsKnownOrIntrinsic(*name); + return !NameIsKnownOrIntrinsic(*name) && !CheckUseError(*name); } return true; } @@ -5762,7 +5781,9 @@ void DeclarationVisitor::CheckExplicitInterface(const parser::Name &name) { if (const Symbol * symbol{name.symbol}) { - if (!context().HasError(*symbol) && !symbol->HasExplicitInterface()) { + const Symbol &ultimate{symbol->GetUltimate()}; + if (!context().HasError(*symbol) && !context().HasError(ultimate) && + !ultimate.HasExplicitInterface()) { Say(name, "'%s' must be an abstract interface or a procedure with " "an explicit interface"_err_en_US, @@ -6790,7 +6811,7 @@ CHECK(!details.init()); Walk(target); if (const auto *targetName{std::get_if(&target.u)}) { - if (targetName->symbol) { + if (!CheckUseError(*targetName) && targetName->symbol) { // Validation is done in declaration checking. details.set_init(*targetName->symbol); } diff --git a/flang/test/Semantics/resolve114.f90 b/flang/test/Semantics/resolve114.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/resolve114.f90 @@ -0,0 +1,90 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Allow the same external or intrinsic procedure to be use-associated +! by multiple paths when they are unambiguous. +module m1 + intrinsic :: sin + intrinsic :: iabs + interface + subroutine ext1(a, b) + integer, intent(in) :: a(:) + real, intent(in) :: b(:) + end subroutine + subroutine ext2(a, b) + real, intent(in) :: a(:) + integer, intent(in) :: b(:) + end subroutine + end interface +end module m1 + +module m2 + intrinsic :: sin, tan + intrinsic :: iabs, idim + interface + subroutine ext1(a, b) + integer, intent(in) :: a(:) + real, intent(in) :: b(:) + end subroutine + subroutine ext2(a, b) + real, intent(in) :: a(:) + integer, intent(in) :: b(:) + end subroutine + end interface +end module m2 + +subroutine s2a + use m1 + use m2 + procedure(sin), pointer :: p1 => sin + procedure(iabs), pointer :: p2 => iabs + procedure(ext1), pointer :: p3 => ext1 + procedure(ext2), pointer :: p4 => ext2 +end subroutine + +subroutine s2b + use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2 + use m2, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2 + use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2 + procedure(iface1), pointer :: p1 => x1 + procedure(iface2), pointer :: p2 => x2 + procedure(iface3), pointer :: p3 => x3 + procedure(iface4), pointer :: p4 => x4 +end subroutine + +module m3 + use m1 + use m2 +end module +subroutine s3 + use m3 + procedure(sin), pointer :: p1 => sin + procedure(iabs), pointer :: p2 => iabs + procedure(ext1), pointer :: p3 => ext1 + procedure(ext2), pointer :: p4 => ext2 +end subroutine + +module m4 + use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2 + use m2, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2 +end module +subroutine s4 + use m4 + use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2 + procedure(iface1), pointer :: p1 => x1 + procedure(iface2), pointer :: p2 => x2 + procedure(iface3), pointer :: p3 => x3 + procedure(iface4), pointer :: p4 => x4 +end subroutine + +subroutine s5 + use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2 + use m2, only: x1 => tan, x2 => idim, x3 => ext2, x4 => ext1 + use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2 + !ERROR: Reference to 'x1' is ambiguous + procedure(iface1), pointer :: p1 => x1 + !ERROR: Reference to 'x2' is ambiguous + procedure(iface2), pointer :: p2 => x2 + !ERROR: Reference to 'x3' is ambiguous + procedure(iface3), pointer :: p3 => x3 + !ERROR: Reference to 'x4' is ambiguous + procedure(iface4), pointer :: p4 => x4 +end subroutine