diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc index 00cef1e7653c..a79f6d609c7a 100644 --- a/flang/lib/semantics/resolve-names.cc +++ b/flang/lib/semantics/resolve-names.cc @@ -763,6 +763,7 @@ public: const parser::Name &, const parser::InitialDataTarget &); void PointerInitialization( const parser::Name &, const parser::ProcPointerInit &); + void CheckExplicitInterface(const parser::Name &); void CheckBindings(const parser::TypeBoundProcedureStmt::WithoutInterface &); protected: @@ -799,8 +800,6 @@ protected: const parser::Name *ResolveName(const parser::Name &); bool PassesSharedLocalityChecks(const parser::Name &name, Symbol &symbol); Symbol *NoteInterfaceName(const parser::Name &); - void CheckExplicitInterface(Symbol &); - void CheckBinding(Symbol &); private: // The attribute corresponding to the statement containing an ObjectDecl @@ -845,7 +844,6 @@ private: Symbol &DeclareProcEntity(const parser::Name &, Attrs, const ProcInterface &); void SetType(const parser::Name &, const DeclTypeSpec &); const Symbol *ResolveDerivedType(const parser::Name &); - bool CanBeTypeBoundProc(const Symbol &); Symbol *MakeTypeSymbol(const SourceName &, Details &&); Symbol *MakeTypeSymbol(const parser::Name &, Details &&); bool OkToAddComponent(const parser::Name &, const Symbol * = nullptr); @@ -1660,7 +1658,8 @@ void ScopeHandler::PopScope() { // assumed to be objects. // TODO: Statement functions for (auto &pair : currScope()) { - ConvertToObjectEntity(*pair.second); + Symbol &symbol{*pair.second}; + ConvertToObjectEntity(symbol); } SetScope(currScope_->parent()); } @@ -3435,13 +3434,21 @@ void DeclarationVisitor::CheckBindings( auto &bindingName{std::get(declaration.t)}; if (Symbol * binding{FindInScope(currScope(), bindingName)}) { if (auto *details{binding->detailsIf()}) { - const Symbol &procedure{details->symbol().GetUltimate()}; + const Symbol *procedure{FindSubprogram(details->symbol())}; if (!CanBeTypeBoundProc(procedure)) { - auto &optName{std::get>(declaration.t)}; - const parser::Name &procedureName{optName ? *optName : bindingName}; - SayWithDecl(procedureName, const_cast(procedure), - "'%s' is not a module procedure or external procedure" - " with explicit interface"_err_en_US); + if (details->symbol().name() != binding->name()) { + Say(binding->name(), + "The binding of '%s' ('%s') must be either an accessible " + "module procedure or an external procedure with " + "an explicit interface"_err_en_US, + binding->name(), details->symbol().name()); + } else { + Say(binding->name(), + "'%s' must be either an accessible module procedure " + "or an external procedure with an explicit interface"_err_en_US, + binding->name()); + } + context().SetError(*binding); } } } @@ -4067,55 +4074,23 @@ const Symbol *DeclarationVisitor::ResolveDerivedType(const parser::Name &name) { return symbol; } -// Check this symbol suitable as a type-bound procedure - C769 -bool DeclarationVisitor::CanBeTypeBoundProc(const Symbol &symbol) { - if (symbol.has()) { - return symbol.owner().kind() == Scope::Kind::Module; - } else if (auto *details{symbol.detailsIf()}) { - return symbol.owner().kind() == Scope::Kind::Module || - details->isInterface(); - } else if (auto *proc{symbol.detailsIf()}) { - return !symbol.IsDummy() && !symbol.attrs().test(Attr::POINTER) && - proc->HasExplicitInterface(); - } else { - return false; - } -} - Symbol *DeclarationVisitor::NoteInterfaceName(const parser::Name &name) { - // The symbol is checked later by CheckExplicitInterface() or - // CheckBinding() to ensure that it defines an explicit interface - // or binds to a procedure. The name can be a forward reference. + // The symbol is checked later by CheckExplicitInterface() and + // CheckBindings(). It can be a forward reference. if (!NameIsKnownOrIntrinsic(name)) { - Resolve(name, MakeSymbol(InclusiveScope(), name.source, Attrs{})); + Symbol &symbol{MakeSymbol(InclusiveScope(), name.source, Attrs{})}; + Resolve(name, symbol); } return name.symbol; } -void DeclarationVisitor::CheckExplicitInterface(Symbol &symbol) { - if (const Symbol * interface{FindInterface(symbol)}) { - const Symbol *subp{FindSubprogram(*interface)}; - if (subp == nullptr || !subp->HasExplicitInterface()) { - Say(symbol.name(), - "The interface of '%s' ('%s') is not an abstract interface or a " - "procedure with an explicit interface"_err_en_US, - symbol.name(), interface->name()); - context().SetError(symbol); - } - } -} - -void DeclarationVisitor::CheckBinding(Symbol &symbol) { - if (const auto *details{symbol.detailsIf()}) { - const Symbol &binding{details->symbol()}; - const Symbol *subp{FindSubprogram(binding)}; - if (subp == nullptr || !subp->HasExplicitInterface() || IsDummy(*subp) || - IsProcedurePointer(*subp)) { - Say(symbol.name(), - "The binding of '%s' ('%s') is not a " - "procedure with an explicit interface"_err_en_US, - symbol.name(), binding.name()); - context().SetError(symbol); +void DeclarationVisitor::CheckExplicitInterface(const parser::Name &name) { + if (const Symbol * symbol{name.symbol}) { + if (!symbol->HasExplicitInterface()) { + Say(name, + "'%s' must be an abstract interface or a procedure with " + "an explicit interface"_err_en_US, + symbol->name()); } } } @@ -4764,11 +4739,6 @@ const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) { } return &name; } - // TODO pmk: if in a variable or component initialization with deferred - // semantic analysis, just MakeSymbol() for now and don't apply any - // implicit typing rules. Then do object conversion and implicit - // typing (or not) in DeferredInitializationHelper (taking Pointer - // out of the name). Still not sure how to deal with PDT components. if (isImplicitNoneType()) { Say(name, "No explicit type declared for '%s'"_err_en_US); return nullptr; @@ -5027,7 +4997,7 @@ void DeclarationVisitor::PointerInitialization( details.set_init(*targetName->symbol); } } else { - details.set_init(nullptr); // NULL() + details.set_init(nullptr); // explicit NULL() } } else { Say(name, @@ -5074,9 +5044,7 @@ void ResolveNamesVisitor::HandleProcedureName( } MakeExternal(*symbol); } - if (!symbol->has()) { - ConvertToProcEntity(*symbol); - } + ConvertToProcEntity(*symbol); SetProcFlag(name, *symbol, flag); } else if (symbol->has()) { CHECK(!"unexpected UnknownDetails"); @@ -5525,12 +5493,13 @@ bool ResolveNamesVisitor::BeginScope(const ProgramTree &node) { } } -// The processing of initializers of pointers is deferred until all of -// the pertinent specification parts have been visited. This deferred -// processing enables the use of forward references in those initializers. -class DeferredPointerInitializationVisitor { +// Some analyses and checks, such as the processing of initializers of +// pointers, is deferred until all of the pertinent specification parts +// have been visited. This deferred processing enables the use of forward +// references in these circumstances. +class DeferredCheckVisitor { public: - explicit DeferredPointerInitializationVisitor(ResolveNamesVisitor &resolver) + explicit DeferredCheckVisitor(ResolveNamesVisitor &resolver) : resolver_{resolver} {} template void Walk(const A &x) { parser::Walk(x, *this); } @@ -5539,7 +5508,7 @@ public: template void Post(const A &) {} void Post(const parser::DerivedTypeStmt &x) { - auto &name{std::get(x.t)}; + const auto &name{std::get(x.t)}; if (Symbol * symbol{name.symbol}) { if (Scope * scope{symbol->scope()}) { if (scope->kind() == Scope::Kind::DerivedType) { @@ -5556,6 +5525,11 @@ public: } } + void Post(const parser::ProcInterface &pi) { + if (const auto *name{std::get_if(&pi.u)}) { + resolver_.CheckExplicitInterface(*name); + } + } bool Pre(const parser::EntityDecl &decl) { Init(std::get(decl.t), std::get>(decl.t)); @@ -5573,6 +5547,9 @@ public: } return false; } + void Post(const parser::TypeBoundProcedureStmt::WithInterface &tbps) { + resolver_.CheckExplicitInterface(tbps.interfaceName); + } void Post(const parser::TypeBoundProcedureStmt::WithoutInterface &tbps) { if (pushedScope_) { resolver_.CheckBindings(tbps); @@ -5605,14 +5582,12 @@ void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) { // type-bound procedure bindings have not yet been traversed. // We do that now, when any (formerly) forward references that appear // in those initializers will resolve to the right symbols. - DeferredPointerInitializationVisitor{*this}.Walk(node.spec()); - DeferredPointerInitializationVisitor{*this}.Walk(node.exec()); // for BLOCK + DeferredCheckVisitor{*this}.Walk(node.spec()); + DeferredCheckVisitor{*this}.Walk(node.exec()); // for BLOCK for (auto &pair : currScope()) { Symbol &symbol{*pair.second}; if (const auto *details{symbol.detailsIf()}) { CheckSpecificsAreDistinguishable(symbol, details->specificProcs()); - } else if (symbol.has()) { - CheckExplicitInterface(symbol); } } // Finish the definitions of derived types and parameterized derived @@ -5643,7 +5618,7 @@ static int FindIndexOfName( return -1; } -// Perform checks on procedure bindings of this type +// Perform final checks on a derived type and set the pass arguments. void ResolveNamesVisitor::FinishDerivedTypeDefinition(Scope &scope) { CHECK(scope.IsDerivedType() && scope.symbol()); for (auto &pair : scope) { @@ -5652,12 +5627,8 @@ void ResolveNamesVisitor::FinishDerivedTypeDefinition(Scope &scope) { common::visitors{ [&](ProcEntityDetails &x) { SetPassArg(comp, x.interface().symbol(), x); - CheckExplicitInterface(comp); - }, - [&](ProcBindingDetails &x) { - SetPassArg(comp, &x.symbol(), x); - CheckBinding(comp); }, + [&](ProcBindingDetails &x) { SetPassArg(comp, &x.symbol(), x); }, [](auto &) {}, }, comp.details()); diff --git a/flang/lib/semantics/scope.cc b/flang/lib/semantics/scope.cc index 5e19bb082fcb..da88b9eeece2 100644 --- a/flang/lib/semantics/scope.cc +++ b/flang/lib/semantics/scope.cc @@ -216,7 +216,7 @@ void Scope::add_importName(const SourceName &name) { // true if name can be imported or host-associated from parent scope. bool Scope::CanImport(const SourceName &name) const { - if (IsGlobal()) { + if (IsGlobal() || parent_.IsGlobal()) { return false; } switch (GetImportKind()) { diff --git a/flang/lib/semantics/tools.cc b/flang/lib/semantics/tools.cc index 1b2de9a69183..1b07022bc6d1 100644 --- a/flang/lib/semantics/tools.cc +++ b/flang/lib/semantics/tools.cc @@ -418,6 +418,23 @@ bool IsSaved(const Symbol &symbol) { } } +// Check this symbol suitable as a type-bound procedure - C769 +bool CanBeTypeBoundProc(const Symbol *symbol) { + if (symbol == nullptr || IsDummy(*symbol) || IsProcedurePointer(*symbol)) { + return false; + } else if (symbol->has()) { + return symbol->owner().kind() == Scope::Kind::Module; + } else if (auto *details{symbol->detailsIf()}) { + return symbol->owner().kind() == Scope::Kind::Module || + details->isInterface(); + } else if (const auto *proc{symbol->detailsIf()}) { + return !symbol->attrs().test(Attr::INTRINSIC) && + proc->HasExplicitInterface(); + } else { + return false; + } +} + bool IsFinalizable(const Symbol &symbol) { if (const DeclTypeSpec * type{symbol.GetType()}) { if (const DerivedTypeSpec * derived{type->AsDerived()}) { diff --git a/flang/lib/semantics/tools.h b/flang/lib/semantics/tools.h index e0c7bf049b97..66e074f66953 100644 --- a/flang/lib/semantics/tools.h +++ b/flang/lib/semantics/tools.h @@ -84,6 +84,7 @@ const Symbol *HasEventOrLockPotentialComponent(const DerivedTypeSpec &); bool IsOrContainsEventOrLockComponent(const Symbol &); // Has an explicit or implied SAVE attribute bool IsSaved(const Symbol &); +bool CanBeTypeBoundProc(const Symbol *); // Return an ultimate component of type that matches predicate, or nullptr. const Symbol *FindUltimateComponent( diff --git a/flang/test/semantics/allocate08.f90 b/flang/test/semantics/allocate08.f90 index 6c9ebd9e5bc4..1ca520ff7d10 100644 --- a/flang/test/semantics/allocate08.f90 +++ b/flang/test/semantics/allocate08.f90 @@ -119,6 +119,12 @@ end function program test_typeless class(*), allocatable :: x + interface + subroutine sub + end subroutine + real function func() + end function + end interface procedure (sub), pointer :: subp => sub procedure (func), pointer :: funcp => func diff --git a/flang/test/semantics/dosemantics03.f90 b/flang/test/semantics/dosemantics03.f90 index a83f359958a1..baaab6b4ffcb 100644 --- a/flang/test/semantics/dosemantics03.f90 +++ b/flang/test/semantics/dosemantics03.f90 @@ -25,12 +25,6 @@ ! C1120 -- DO variable (and associated expressions) must be INTEGER. ! This is extended by allowing REAL and DOUBLE PRECISION -SUBROUTINE sub() -END SUBROUTINE sub - -FUNCTION ifunc() -END FUNCTION ifunc - MODULE share INTEGER :: intvarshare REAL :: realvarshare @@ -56,6 +50,12 @@ PROGRAM do_issue_458 REAL, POINTER :: prvar DOUBLE PRECISION, POINTER :: pdvar LOGICAL, POINTER :: plvar + INTERFACE + SUBROUTINE sub() + END SUBROUTINE sub + FUNCTION ifunc() + END FUNCTION ifunc + END INTERFACE PROCEDURE(ifunc), POINTER :: pifunc => NULL() ! DO variables diff --git a/flang/test/semantics/resolve20.f90 b/flang/test/semantics/resolve20.f90 index 5e908e68901a..200bf8930d8a 100644 --- a/flang/test/semantics/resolve20.f90 +++ b/flang/test/semantics/resolve20.f90 @@ -22,20 +22,20 @@ module m procedure(integer) :: b procedure(foo) :: c procedure(bar) :: d - !ERROR: The interface of 'e' ('missing') is not an abstract interface or a procedure with an explicit interface + !ERROR: 'missing' must be an abstract interface or a procedure with an explicit interface procedure(missing) :: e - !ERROR: The interface of 'f' ('b') is not an abstract interface or a procedure with an explicit interface + !ERROR: 'b' must be an abstract interface or a procedure with an explicit interface procedure(b) :: f procedure(c) :: g external :: h - !ERROR: The interface of 'i' ('h') is not an abstract interface or a procedure with an explicit interface + !ERROR: 'h' must be an abstract interface or a procedure with an explicit interface procedure(h) :: i procedure(forward) :: j - !ERROR: The interface of 'k1' ('bad1') is not an abstract interface or a procedure with an explicit interface + !ERROR: 'bad1' must be an abstract interface or a procedure with an explicit interface procedure(bad1) :: k1 - !ERROR: The interface of 'k2' ('bad2') is not an abstract interface or a procedure with an explicit interface + !ERROR: 'bad2' must be an abstract interface or a procedure with an explicit interface procedure(bad2) :: k2 - !ERROR: The interface of 'k3' ('bad3') is not an abstract interface or a procedure with an explicit interface + !ERROR: 'bad3' must be an abstract interface or a procedure with an explicit interface procedure(bad3) :: k3 abstract interface diff --git a/flang/test/semantics/resolve32.f90 b/flang/test/semantics/resolve32.f90 index 6587681822e3..37d39985e692 100644 --- a/flang/test/semantics/resolve32.f90 +++ b/flang/test/semantics/resolve32.f90 @@ -35,21 +35,21 @@ module m type t1 integer :: c contains - !ERROR: Procedure 'missing' not found + !ERROR: The binding of 'a' ('missing') must be either an accessible module procedure or an external procedure with an explicit interface procedure, nopass :: a => missing procedure, nopass :: b => s, s2 - !ERROR: 'c' is not a module procedure or external procedure with explicit interface + !ERROR: Type parameter, component, or procedure binding 'c' already defined in this type procedure, nopass :: c !ERROR: DEFERRED is only allowed when an interface-name is provided procedure, nopass, deferred :: d => s !Note: s3 not found because it's not accessible -- should we issue a message !to that effect? - !ERROR: Procedure 's3' not found + !ERROR: 's3' must be either an accessible module procedure or an external procedure with an explicit interface procedure, nopass :: s3 procedure, nopass :: foo - !ERROR: 'bar' is not a module procedure or external procedure with explicit interface + !ERROR: 'bar' must be either an accessible module procedure or an external procedure with an explicit interface procedure, nopass :: bar - !ERROR: 'i' is not a module procedure or external procedure with explicit interface + !ERROR: 'i' must be either an accessible module procedure or an external procedure with an explicit interface procedure, nopass :: i !ERROR: Type parameter, component, or procedure binding 'b' already defined in this type procedure, nopass :: b => s4 @@ -59,7 +59,7 @@ module m procedure(foo), nopass, deferred :: f !ERROR: DEFERRED is required when an interface-name is provided procedure(foo), nopass :: g - !ERROR: The interface of 'h' ('bar') is not an abstract interface or a procedure with an explicit interface + !ERROR: 'bar' must be an abstract interface or a procedure with an explicit interface procedure(bar), nopass, deferred :: h end type type t2