re PR fortran/64209 ([OOP] runtime segfault with CLASS(*), INTENT(OUT) dummy argument)

2014-12-19  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/64209
	* trans-expr.c (gfc_trans_class_array_init_assign): Check if _def_init
	component is non-NULL.
	(gfc_trans_class_init_assign): Ditto.

2014-12-19  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/64209
	* gfortran.dg/unlimited_polymorphic_19.f90: New.

From-SVN: r218968

4 files changed, 91 insertions, 0 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 067b133..de2d2a9 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2014-12-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/64209
+	* trans-expr.c (gfc_trans_class_array_init_assign): Check if _def_init
+	component is non-NULL.
+	(gfc_trans_class_init_assign): Ditto.
+
 2014-12-17  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/64173
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7772dca..3793cfb 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -932,6 +932,21 @@ gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
      of arrays in gfc_trans_call.  */
   res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
   gfc_free_statements (ppc_code);
+
+  if (UNLIMITED_POLY(obj))
+    {
+      /* Check if rhs is non-NULL. */
+      gfc_se src;
+      gfc_init_se (&src, NULL);
+      gfc_conv_expr (&src, rhs);
+      src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
+      tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				   src.expr, fold_convert (TREE_TYPE (src.expr),
+							   null_pointer_node));
+      res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
+			build_empty_stmt (input_location));
+    }
+
   return res;
 }
 
@@ -980,6 +995,17 @@ gfc_trans_class_init_assign (gfc_code *code)
       src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
 
       tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
+
+      if (UNLIMITED_POLY(code->expr1))
+	{
+	  /* Check if _def_init is non-NULL. */
+	  tree cond = fold_build2_loc (input_location, NE_EXPR,
+				       boolean_type_node, src.expr,
+				       fold_convert (TREE_TYPE (src.expr),
+						     null_pointer_node));
+	  tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
+			    tmp, build_empty_stmt (input_location));
+	}
     }
 
   if (code->expr1->symtree->n.sym->attr.optional
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 32e5489..15096fd 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2014-12-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/64209
+	* gfortran.dg/unlimited_polymorphic_19.f90: New.
+
 2014-12-19  Alan Lawrence  <alan.lawrence@arm.com>
 
 	* gcc.target/aarch64/eon_1.c: New test.
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90
new file mode 100644
index 0000000..a2dbaef
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90
@@ -0,0 +1,53 @@
+! { dg-do run }
+!
+! PR 64209: [OOP] runtime segfault with CLASS(*), INTENT(OUT) dummy argument
+!
+! Contributed by Miha Polajnar <polajnar.miha@gmail.com>
+
+MODULE m
+  IMPLICIT NONE
+  TYPE :: t
+    CLASS(*), ALLOCATABLE :: x(:)
+  CONTAINS
+    PROCEDURE :: copy
+  END TYPE t
+  INTERFACE 
+    PURE SUBROUTINE copy_proc_intr(a,b)
+      CLASS(*), INTENT(IN) :: a
+      CLASS(*), INTENT(OUT) :: b
+    END SUBROUTINE copy_proc_intr
+  END INTERFACE 
+CONTAINS
+  SUBROUTINE copy(self,cp,a)
+    CLASS(t), INTENT(IN) :: self
+    PROCEDURE(copy_proc_intr) :: cp
+    CLASS(*), INTENT(OUT) :: a(:)
+    INTEGER :: i
+    IF( .not.same_type_as(self%x(1),a(1)) ) STOP -1
+    DO i = 1, size(self%x)
+      CALL cp(self%x(i),a(i))
+    END DO
+  END SUBROUTINE copy
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+  INTEGER, PARAMETER :: n = 3, x(n) = [ 1, 2, 3 ] 
+  INTEGER :: copy_x(n)
+  TYPE(t) :: test
+  ALLOCATE(test%x(n),SOURCE=x)
+  CALL test%copy(copy_int,copy_x)
+!   PRINT '(*(I0,:2X))', copy_x
+CONTAINS
+  PURE SUBROUTINE copy_int(a,b)
+    CLASS(*), INTENT(IN) :: a
+    CLASS(*), INTENT(OUT) :: b
+    SELECT TYPE(a); TYPE IS(integer) 
+    SELECT TYPE(b); TYPE IS(integer)
+      b = a
+    END SELECT; END SELECT
+  END SUBROUTINE copy_int 
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }