diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -250,6 +250,8 @@ * A type-bound procedure binding can be passed as an actual argument corresponding to a dummy procedure and can be used as the target of a procedure pointer assignment statement. +* An explicit `INTERFACE` can declare the interface of a + procedure pointer even if it is not a dummy argument. ### Extensions supported when enabled by options 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 @@ -3856,7 +3856,7 @@ if (auto *prev{FindSymbol(name)}) { if (IsDummy(*prev)) { } else if (auto *entity{prev->detailsIf()}; - IsPointer(*prev) && !entity->type()) { + IsPointer(*prev) && entity && !entity->type()) { // POINTER attribute set before interface } else if (inInterfaceBlock() && currScope() != prev->owner()) { // Procedures in an INTERFACE block do not resolve to symbols @@ -4071,6 +4071,17 @@ symbol.ReplaceName(name.source); EndArraySpec(); } else { + if (const auto *symbol{FindInScope(name)}) { + const auto *subp{symbol->detailsIf()}; + if (!symbol->has() && // error caught elsewhere + !symbol->has() && + !symbol->has() && + !symbol->CanReplaceDetails(ObjectEntityDetails{}) && + !symbol->CanReplaceDetails(ProcEntityDetails{}) && + !(subp && subp->isInterface())) { + Say(name, "'%s' cannot have the POINTER attribute"_err_en_US); + } + } HandleAttributeStmt(Attr::POINTER, std::get(x.t)); } } diff --git a/flang/test/Semantics/pointer01.f90 b/flang/test/Semantics/pointer01.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/pointer01.f90 @@ -0,0 +1,37 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +module m + real mobj + contains + subroutine msubr + end subroutine +end module +program main + use m + !PORTABILITY: Name 'main' declared in a main program should not have the same name as the main program + pointer main + !ERROR: Cannot change POINTER attribute on use-associated 'mobj' + pointer mobj + !ERROR: Cannot change POINTER attribute on use-associated 'msubr' + pointer msubr + !ERROR: 'inner' cannot have the POINTER attribute + pointer inner + real obj + !ERROR: 'ip' may not have both the POINTER and PARAMETER attributes + integer, parameter :: ip = 123 + pointer ip + type dt; end type + !ERROR: 'dt' cannot have the POINTER attribute + pointer dt + interface generic + subroutine extsub + end subroutine + end interface + !ERROR: 'generic' cannot have the POINTER attribute + pointer generic + namelist /nml/ obj + !ERROR: 'nml' cannot have the POINTER attribute + pointer nml + contains + subroutine inner + end subroutine +end