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/54603
        * gfortran.dg/structure_constructor_11.f90: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@191382 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b2950f7..3f6e3be 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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" } }