diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 9 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/structure_constructor_11.f90 | 96 |
4 files changed, 115 insertions, 2 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b2950f7..3f6e3be 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,12 @@ 2012-09-17 Tobias Burnus <burnus@net-b.de> + PR fortran/54603 + * trans-expr.c (gfc_trans_subcomponent_assign): Handle + proc-pointer components. + +2012-09-17 Tobias Burnus <burnus@net-b.de> + + PR fortran/54599 * error.c (error_print): Move increment out of the assert. * interface.c (gfc_compare_derived_types): Add assert. (get_expr_storage_size): Remove always-true logical condition. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 84a4b34..98634c3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5506,11 +5506,11 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_start_block (&block); - if (cm->attr.pointer) + if (cm->attr.pointer || cm->attr.proc_pointer) { gfc_init_se (&se, NULL); /* Pointer component. */ - if (cm->attr.dimension) + if (cm->attr.dimension && !cm->attr.proc_pointer) { /* Array pointer. */ if (expr->expr_type == EXPR_NULL) @@ -5530,6 +5530,11 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) se.want_pointer = 1; gfc_conv_expr (&se, expr); gfc_add_block_to_block (&block, &se.pre); + + if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer + && expr->symtree->n.sym->attr.dummy) + se.expr = build_fold_indirect_ref_loc (input_location, se.expr); + gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest), se.expr)); gfc_add_block_to_block (&block, &se.post); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ead2a97..eb1f595 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2012-09-17 Tobias Burnus <burnus@net-b.de> + + PR fortran/54603 + * gfortran.dg/structure_constructor_11.f90: New. + 2012-09-17 Jakub Jelinek <jakub@redhat.com> PR tree-optimization/54563 diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_11.f90 b/gcc/testsuite/gfortran.dg/structure_constructor_11.f90 new file mode 100644 index 0000000..167f8e7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_11.f90 @@ -0,0 +1,96 @@ +! { dg-do run} +! { dg-options "-fdump-tree-original" } +! +! PR fortran/54603 +! +! Contributed by Kacper Kowalik +! +module foo + implicit none + + interface + subroutine cg_ext + implicit none + end subroutine cg_ext + end interface + + type :: ext_ptr + procedure(cg_ext), nopass, pointer :: init + procedure(cg_ext), nopass, pointer :: cleanup + end type ext_ptr + + type :: ext_ptr_array + type(ext_ptr) :: a + contains + procedure :: epa_init + end type ext_ptr_array + + type(ext_ptr_array) :: bar + +contains + subroutine epa_init(this, init, cleanup) + implicit none + class(ext_ptr_array), intent(inout) :: this + procedure(cg_ext), pointer, intent(in) :: init + procedure(cg_ext), pointer, intent(in) :: cleanup + + this%a = ext_ptr(null(), null()) ! Wrong code + this%a = ext_ptr(init, cleanup) ! Wrong code + + this%a%init => init ! OK + this%a%cleanup => cleanup ! OK + + this%a = ext_ptr(this%a%init,this%a%cleanup) ! ICE in fold_convert_loc + end subroutine epa_init + +end module foo + +program ala + use foo, only: bar + implicit none + integer :: count1, count2 + count1 = 0 + count2 = 0 + + call setme + call bar%a%cleanup() + call bar%a%init() + + ! They should be called once + if (count1 /= 23 .or. count2 /= 42) call abort () + +contains + + subroutine dummy1 + implicit none + !print *, 'dummy1' + count1 = 23 + end subroutine dummy1 + + subroutine dummy2 + implicit none + !print *, 'dummy2' + count2 = 42 + end subroutine dummy2 + + subroutine setme + use foo, only: bar, cg_ext + implicit none + procedure(cg_ext), pointer :: a_init, a_clean + + a_init => dummy1 + a_clean => dummy2 + call bar%epa_init(a_init, a_clean) + end subroutine setme + +end program ala + +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.init = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.cleanup = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.1.init = \\*init;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.1.cleanup = \\*cleanup;" 1 "original" } } +! { dg-final { scan-tree-dump-times "this->_data->a.init = \\*init;" 1 "original" } } +! { dg-final { scan-tree-dump-times "this->_data->a.cleanup = \\*cleanup;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.init = this->_data->a.init;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.cleanup = this->_data->a.cleanup;" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } } |