diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 702711e3cff53..865020e050b03 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1196,16 +1196,6 @@ parser::Message *AttachDeclaration( const auto *assoc{unhosted->detailsIf()}) { unhosted = &assoc->symbol(); } - if (const auto *binding{ - unhosted->detailsIf()}) { - if (binding->symbol().name() != symbol.name()) { - message.Attach(binding->symbol().name(), - "Procedure '%s' of type '%s' is bound to '%s'"_en_US, symbol.name(), - symbol.owner().GetName().value(), binding->symbol().name()); - return &message; - } - unhosted = &binding->symbol(); - } if (const auto *use{symbol.detailsIf()}) { message.Attach(use->location(), "'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(), @@ -1214,6 +1204,14 @@ parser::Message *AttachDeclaration( message.Attach( unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name()); } + if (const auto *binding{ + unhosted->detailsIf()}) { + if (binding->symbol().name() != symbol.name()) { + message.Attach(binding->symbol().name(), + "Procedure '%s' of type '%s' is bound to '%s'"_en_US, symbol.name(), + symbol.owner().GetName().value(), binding->symbol().name()); + } + } return &message; } diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index 318085518cc57..94258444cf7ef 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -2555,6 +2555,9 @@ void CheckHelper::CheckProcBinding( const Symbol &symbol, const ProcBindingDetails &binding) { const Scope &dtScope{symbol.owner()}; CHECK(dtScope.kind() == Scope::Kind::DerivedType); + bool isInaccessibleDeferred{false}; + const Symbol *overridden{ + FindOverriddenBinding(symbol, isInaccessibleDeferred)}; if (symbol.attrs().test(Attr::DEFERRED)) { if (const Symbol *dtSymbol{dtScope.symbol()}) { if (!dtSymbol->attrs().test(Attr::ABSTRACT)) { // C733 @@ -2568,6 +2571,11 @@ void CheckHelper::CheckProcBinding( "Type-bound procedure '%s' may not be both DEFERRED and NON_OVERRIDABLE"_err_en_US, symbol.name()); } + if (overridden && !overridden->attrs().test(Attr::DEFERRED)) { + SayWithDeclaration(*overridden, + "Override of non-DEFERRED '%s' must not be DEFERRED"_err_en_US, + symbol.name()); + } } if (binding.symbol().attrs().test(Attr::INTRINSIC) && !context_.intrinsics().IsSpecificIntrinsicFunction( @@ -2576,9 +2584,7 @@ void CheckHelper::CheckProcBinding( "Intrinsic procedure '%s' is not a specific intrinsic permitted for use in the definition of binding '%s'"_err_en_US, binding.symbol().name(), symbol.name()); } - bool isInaccessibleDeferred{false}; - if (const Symbol * - overridden{FindOverriddenBinding(symbol, isInaccessibleDeferred)}) { + if (overridden) { if (isInaccessibleDeferred) { SayWithDeclaration(*overridden, "Override of PRIVATE DEFERRED '%s' must appear in its module"_err_en_US, diff --git a/flang/test/Semantics/bug138915.f90 b/flang/test/Semantics/bug138915.f90 new file mode 100644 index 0000000000000..786a4ac2d930b --- /dev/null +++ b/flang/test/Semantics/bug138915.f90 @@ -0,0 +1,15 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +module m + type base + contains + procedure, nopass :: tbp + end type + type, extends(base), abstract :: child + contains + !ERROR: Override of non-DEFERRED 'tbp' must not be DEFERRED + procedure(tbp), deferred, nopass :: tbp + end type + contains + subroutine tbp + end +end