From 7076b27b7488bd8395310811a9c0d39ed5404490 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Wed, 27 Mar 2019 23:40:22 +0100 Subject: [PATCH] re PR fortran/85537 ([F08] Invalid memory reference at runtime when calling subroutine through procedure pointer) fix PR 85537 2019-03-27 Janus Weil PR fortran/85537 * expr.c (gfc_check_assign_symbol): Reject internal and dummy procedures in procedure pointer initialization. 2019-03-27 Janus Weil PR fortran/85537 * gfortran.dg/dummy_procedure_11.f90: Fix test case. * gfortran.dg/pointer_init_11.f90: New test case. From-SVN: r269980 --- gcc/fortran/ChangeLog | 6 +++ gcc/fortran/expr.c | 14 ++++++ gcc/testsuite/ChangeLog | 6 +++ .../gfortran.dg/dummy_procedure_11.f90 | 6 ++- gcc/testsuite/gfortran.dg/pointer_init_11.f90 | 44 +++++++++++++++++++ 5 files changed, 74 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pointer_init_11.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e1fdb93f3d0..372c517487f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2019-03-27 Janus Weil + + PR fortran/85537 + * expr.c (gfc_check_assign_symbol): Reject internal and dummy procedures + in procedure pointer initialization. + 2019-03-27 Paul Thomas PR fortran/88247 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index f54affae18d..478a5557723 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4407,6 +4407,20 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) "may not be a procedure pointer", &rvalue->where); return false; } + if (attr.proc == PROC_INTERNAL) + { + gfc_error ("Internal procedure %qs is invalid in " + "procedure pointer initialization at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } + if (attr.dummy) + { + gfc_error ("Dummy procedure %qs is invalid in " + "procedure pointer initialization at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } } return true; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 97908fef01e..f29455331f5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2019-03-27 Janus Weil + + PR fortran/85537 + * gfortran.dg/dummy_procedure_11.f90: Fix test case. + * gfortran.dg/pointer_init_11.f90: New test case. + 2019-03-27 Mateusz B PR target/85667 diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_11.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_11.f90 index f51c5455c05..3e4b2b1d6f0 100644 --- a/gcc/testsuite/gfortran.dg/dummy_procedure_11.f90 +++ b/gcc/testsuite/gfortran.dg/dummy_procedure_11.f90 @@ -5,16 +5,18 @@ ! Contributed by Vladimir Fuka type :: t - procedure(g), pointer, nopass :: ppc => g + procedure(g), pointer, nopass :: ppc end type -procedure(g), pointer :: pp => g +procedure(g), pointer :: pp type(t)::x print *, f(g) print *, f(g()) ! { dg-error "Expected a procedure for argument" } +pp => g print *, f(pp) print *, f(pp()) ! { dg-error "Expected a procedure for argument" } +x%ppc => g print *, f(x%ppc) print *, f(x%ppc()) ! { dg-error "Expected a procedure for argument" } diff --git a/gcc/testsuite/gfortran.dg/pointer_init_11.f90 b/gcc/testsuite/gfortran.dg/pointer_init_11.f90 new file mode 100644 index 00000000000..3113e157687 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_init_11.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! +! PR 85537: [F08] Invalid memory reference at runtime when calling subroutine through procedure pointer +! +! Contributed by Tiziano Müller + +module m1 + implicit none +contains + subroutine foo() + integer :: a + + abstract interface + subroutine ibar() + end subroutine + end interface + + procedure(ibar), pointer :: bar_ptr => bar_impl ! { dg-error "invalid in procedure pointer initialization" } + + contains + subroutine bar_impl() + write (*,*) "foo" + a = a + 1 + end subroutine + + end subroutine +end module + + +module m2 + implicit none +contains + subroutine foo(dbar) + interface + subroutine dbar() + end subroutine + end interface + + procedure(dbar), pointer :: bar_ptr => dbar ! { dg-error "invalid in procedure pointer initialization" } + + call bar_ptr() + + end subroutine +end module -- 2.30.2