From 332477628507525e3f252183a864d74bddb5c77f Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 18 Dec 2015 09:34:13 +0000 Subject: [PATCH] re PR fortran/68196 (ICE on function result with procedure pointer component) 2015-12-18 Paul Thomas PR fortran/68196 *expr.c (gfc_has_default_initializer): Prevent infinite recursion through this function for procedure pointer components. * trans-array.c (structure_alloc_comps): Ditto twice. 2015-12-18 Paul Thomas PR fortran/68196 * gfortran.dg/proc_ptr_48.f90: New test. From-SVN: r231807 --- gcc/fortran/ChangeLog | 7 +++++ gcc/fortran/expr.c | 2 +- gcc/fortran/trans-array.c | 5 ++-- gcc/testsuite/ChangeLog | 7 ++++- gcc/testsuite/gfortran.dg/proc_ptr_48.f90 | 50 +++++++++++++++++++++++++++++++ 5 files changed, 67 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_48.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 27dc78c..eeb79d9 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2015-12-18 Paul Thomas + + PR fortran/68196 + *expr.c (gfc_has_default_initializer): Prevent infinite recursion + through this function for procedure pointer components. + * trans-array.c (structure_alloc_comps): Ditto twice. + 2015-12-15 Alessandro Fanfarillo * resolve.c (resolve_critical): Committing symbols of diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 5dd90ef..5d7bcee 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3930,7 +3930,7 @@ gfc_has_default_initializer (gfc_symbol *der) for (c = der->components; c; c = c->next) if (c->ts.type == BT_DERIVED) { - if (!c->attr.pointer + if (!c->attr.pointer && !c->attr.proc_pointer && gfc_has_default_initializer (c->ts.u.derived)) return true; if (c->attr.pointer && c->initializer) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 6e24e2e..71e0482 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -8074,7 +8074,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, } if (cmp_has_alloc_comps - && !c->attr.pointer + && !c->attr.pointer && !c->attr.proc_pointer && !called_dealloc_with_status) { /* Do not deallocate the components of ultimate pointer @@ -8264,7 +8264,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, components that are really allocated, the deep copy code has to be generated first and then added to the if-block in gfc_duplicate_allocatable (). */ - if (cmp_has_alloc_comps) + if (cmp_has_alloc_comps + && !c->attr.proc_pointer) { rank = c->as ? c->as->rank : 0; tmp = fold_convert (TREE_TYPE (dcmp), comp); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 319cec6..324f549 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2015-12-18 Paul Thomas + + PR fortran/68196 + * gfortran.dg/proc_ptr_48.f90: New test. + 2015-12-18 Andreas Krebbel * gcc.target/s390/hotpatch-8.c: Add -Wno-deprecated to options. @@ -16,7 +21,7 @@ 2015-12-17 Nathan Sidwell * gcc.dg/ipa/ipa-icf-merge-1.c: New. - + 2015-12-17 David Malcolm * gcc.dg/diagnostic-range-bad-return.c: New test case. diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_48.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_48.f90 new file mode 100644 index 0000000..deed635 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_48.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! +! Checks the fix for PR68196, comment #8 +! +! Contributed by Damian Rouson +! + type Bug ! Failed at trans--array.c:8269 + real, allocatable :: scalar + procedure(boogInterface),pointer :: boog + end type + interface + function boogInterface(A) result(C) + import Bug + class(Bug) A + type(Bug) C + end function + end interface + + real, parameter :: ninetynine = 99.0 + real, parameter :: onenineeight = 198.0 + + type(bug) :: actual, res + + actual%scalar = ninetynine + actual%boog => boogImplementation + + res = actual%boog () ! Failed on bug in expr.c:3933 + if (res%scalar .ne. onenineeight) call abort + +! Make sure that the procedure pointer is assigned correctly + if (actual%scalar .ne. ninetynine) call abort + actual = res%boog () + if (actual%scalar .ne. onenineeight) call abort + +! Deallocate so that we can use valgrind to check for memory leaks + deallocate (res%scalar, actual%scalar) + +contains + function boogImplementation(A) result(C) ! Failed at trans--array.c:8078 + class(Bug) A + type(Bug) C + select type (A) + type is (bug) + C = A + C%scalar = onenineeight + class default + call abort + end select + end function +end -- 2.7.4