Hi all, the attached patch fixes a wrong-code issue with unlimited poylmorphic INTENT(OUT) arguments.
We default-initialize all polymorphic INTENT(OUT) arguments via the _def_init component of the vtable. The problem is that the intrinsic types don't have a default initialization. Therefore their _def_init is NULL and we simply failed to check for that condition. That's what the patch does. It regtests cleanly on x86_64-unknown-linux-gnu. Ok for trunk? Cheers, Janus 2014-12-19 Janus Weil <ja...@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 <ja...@gcc.gnu.org> PR fortran/64209 * gfortran.dg/unlimited_polymorphic_19.f90: New.
Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 218896) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -912,7 +912,8 @@ gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_actual_arglist *actual; gfc_expr *ppc; gfc_code *ppc_code; - tree res; + tree res, cond; + gfc_se src; actual = gfc_get_actual_arglist (); actual->expr = gfc_copy_expr (rhs); @@ -932,6 +933,16 @@ gfc_trans_class_array_init_assign (gfc_expr *rhs, of arrays in gfc_trans_call. */ res = gfc_trans_call (ppc_code, false, NULL, NULL, false); gfc_free_statements (ppc_code); + + gfc_init_se (&src, NULL); + gfc_conv_expr (&src, rhs); + src.expr = gfc_build_addr_expr (NULL_TREE, src.expr); + 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; } @@ -943,7 +954,7 @@ tree gfc_trans_class_init_assign (gfc_code *code) { stmtblock_t block; - tree tmp; + tree tmp, cond; gfc_se dst,src,memsz; gfc_expr *lhs, *rhs, *sz; @@ -980,6 +991,12 @@ 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); + + 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
! { dg-do run } ! ! PR 64209: [OOP] runtime segfault with CLASS(*), INTENT(OUT) dummy argument ! ! Contributed by Miha Polajnar <polajnar.m...@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" } }