diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -247,6 +247,9 @@ if a binding has renaming with "=> proc". The colons are not necessary for an unambiguous parse, C768 notwithstanding. +* 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. ### Extensions supported when enabled by options diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -599,6 +599,10 @@ argProcSymbol->name()); return; } + } else if (argProcSymbol->has()) { + evaluate::SayWithDeclaration(messages, *argProcSymbol, + "Procedure binding '%s' passed as an actual argument"_port_en_US, + argProcSymbol->name()); } } if (auto argChars{characteristics::DummyArgument::FromActual( diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -307,6 +307,10 @@ symbol->name()); return false; } + } else if (symbol->has()) { + evaluate::SayWithDeclaration(context_.messages(), *symbol, + "Procedure binding '%s' used as target of a pointer assignment"_port_en_US, + symbol->name()); } } if (auto chars{Procedure::Characterize(d, context_)}) { diff --git a/flang/test/Semantics/bindings03.f90 b/flang/test/Semantics/bindings03.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/bindings03.f90 @@ -0,0 +1,26 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror +! Confirm a portability warning on use of a procedure binding apart from a call +module m + type t + contains + procedure :: sub + end type + contains + subroutine sub(x) + class(t), intent(in) :: x + end subroutine +end module + +program test + use m + procedure(sub), pointer :: p + type(t) x + !PORTABILITY: Procedure binding 'sub' used as target of a pointer assignment + p => x%sub + !PORTABILITY: Procedure binding 'sub' passed as an actual argument + call sub2(x%sub) + contains + subroutine sub2(s) + procedure(sub) s + end subroutine +end