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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 067b1334ce64b9f4992dc91e9f1eccd77b7a719e..de2d2a91e2696cb71af1c5c39fd60ddfdc7c5436 100644 (file)
--- 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 7772dcafa494372466394dc665ae1ddee80dce74..3793cfb0d92763fee240f5a36e3bab3c535be8da 100644 (file)
--- 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 32e5489513d66accf8e8a7f9eeea59e2ace709bb..15096fdc3f341a7a328c00138017594f1d395f4f 100644 (file)
--- 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 (file)
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" } }