[Patch, Fortran] PR54603 - fix structure constructors with proc-pointers

[Tobias Burnus <burnus at net-b dot de>]

structure constructures with proc-pointer arguments were either leading 
to wrong results or to ICEs.
I use now the same condition as in gfc_trans_pointer_assignment.

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias
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.

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);
--- /dev/null	2012-09-17 07:46:24.707708299 +0200
+++ gcc/gcc/testsuite/gfortran.dg/structure_constructor_11.f90	2012-09-17 12:11:02.000000000 +0200
@@ -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" } }