diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 6d872094811e3..8a94004f3d20b 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -939,6 +939,17 @@ print *, [(j,j=1,10)] This design allows format-driven input with `DT` editing to retain control over advancement in child input, while otherwise allowing it. +* Many compilers interpret `PROCEDURE()` as meaning a subroutine, + but it does not do so; it defines an entity that is not declared + to be either a subroutine or a function. + If it is referenced, its references must be consistent. + If it is never referenced, it may be associated with any + procedure. + +* A `PROCEDURE()` component (necessarily also a pointer) without an + explicit interface or result type cannot be called as a function, + and will elicit an optional warning when called as a subroutine. + ## De Facto Standard Features * `EXTENDS_TYPE_OF()` returns `.TRUE.` if both of its arguments have the diff --git a/flang/include/flang/Support/Fortran-features.h b/flang/include/flang/Support/Fortran-features.h index 51364d552be64..5be3cc3674563 100644 --- a/flang/include/flang/Support/Fortran-features.h +++ b/flang/include/flang/Support/Fortran-features.h @@ -56,7 +56,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines, IgnoreIrrelevantAttributes, Unsigned, AmbiguousStructureConstructor, ContiguousOkForSeqAssociation, ForwardRefExplicitTypeDummy, InaccessibleDeferredOverride, CudaWarpMatchFunction, DoConcurrentOffload, - TransferBOZ, Coarray) + TransferBOZ, Coarray, CallImplicitProcComponent) // Portability and suspicious usage warnings ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable, diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 4af6cf6a91239..91f0f7b608802 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -9456,13 +9456,35 @@ bool ResolveNamesVisitor::SetProcFlag( SayWithDecl(name, symbol, "Implicit declaration of function '%s' has a different result type than in previous declaration"_err_en_US); return false; - } else if (symbol.has()) { - symbol.set(flag); // in case it hasn't been set yet - if (flag == Symbol::Flag::Function) { - ApplyImplicitRules(symbol); - } - if (symbol.attrs().test(Attr::INTRINSIC)) { - AcquireIntrinsicProcedureFlags(symbol); + } else if (const auto *procDetails{symbol.detailsIf()}) { + if (symbol.owner().IsDerivedType()) { // procedure pointer component + bool isFunction{IsFunction(symbol)}; + const Symbol *explicitInterface{procDetails->procInterface()}; + if (flag == Symbol::Flag::Function) { + if (!isFunction) { + SayWithDecl(name, symbol, + "Procedure pointer component '%s' was not declared to be a function"_err_en_US); + } + } else if (isFunction || + (!explicitInterface && + !context().IsEnabled( + common::LanguageFeature::CallImplicitProcComponent))) { + SayWithDecl(name, symbol, + "Procedure pointer component '%s' was not declared to be a subroutine"_err_en_US); + } else if (!explicitInterface && + context().ShouldWarn( + common::LanguageFeature::CallImplicitProcComponent)) { + SayWithDecl(name, symbol, + "Procedure pointer component '%s' should have been declared to be a subroutine"_warn_en_US); + } + } else { + symbol.set(flag); // in case it hasn't been set yet + if (flag == Symbol::Flag::Function) { + ApplyImplicitRules(symbol); + } + if (symbol.attrs().test(Attr::INTRINSIC)) { + AcquireIntrinsicProcedureFlags(symbol); + } } } else if (symbol.GetType() && flag == Symbol::Flag::Subroutine) { SayWithDecl( diff --git a/flang/test/Semantics/resolve09.f90 b/flang/test/Semantics/resolve09.f90 index 2fe21aebf66bd..59d9a1901c58e 100644 --- a/flang/test/Semantics/resolve09.f90 +++ b/flang/test/Semantics/resolve09.f90 @@ -1,4 +1,4 @@ -! RUN: %python %S/test_errors.py %s %flang_fc1 +! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic integer :: y procedure() :: a procedure(real) :: b @@ -136,16 +136,34 @@ function b8() end subroutine s9 + abstract interface + subroutine subr + end + real function realfunc() + end + end interface type t procedure(), nopass, pointer :: p1, p2 + procedure(subr), nopass, pointer :: psub + procedure(realfunc), nopass, pointer :: pfunc end type type(t) x + !ERROR: Function result characteristics are not known + !ERROR: Procedure pointer component 'p1' was not declared to be a function print *, x%p1() - call x%p2 - !ERROR: Cannot call function 'p1' like a subroutine + !ERROR: Procedure pointer component 'p1' should have been declared to be a subroutine call x%p1 - !ERROR: Cannot call subroutine 'p2' like a function + !ERROR: Procedure pointer component 'p2' should have been declared to be a subroutine + call x%p2 + !ERROR: Function result characteristics are not known + !ERROR: Procedure pointer component 'p2' was not declared to be a function print *, x%p2() + !ERROR: Cannot call subroutine 'psub' like a function + print *, x%psub() + print *, x%pfunc() ! ok + call x%psub ! ok + !ERROR: Cannot call function 'pfunc' like a subroutine + call x%pfunc end subroutine subroutine s10