From 375550c647d112d5ae064401074507ff14092ddd Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Fri, 19 Dec 2014 20:28:57 +0100 Subject: [PATCH] re PR fortran/64209 ([OOP] runtime segfault with CLASS(*), INTENT(OUT) dummy argument) 2014-12-19 Janus Weil 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 PR fortran/64209 * gfortran.dg/unlimited_polymorphic_19.f90: New. From-SVN: r218968 --- gcc/fortran/ChangeLog | 7 +++ gcc/fortran/trans-expr.c | 26 +++++++++ gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/unlimited_polymorphic_19.f90 | 53 +++++++++++++++++++ 4 files changed, 91 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 067b1334ce6..de2d2a91e26 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2014-12-19 Janus Weil + + 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 PR fortran/64173 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7772dcafa49..3793cfb0d92 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 32e5489513d..15096fdc3f3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2014-12-19 Janus Weil + + PR fortran/64209 + * gfortran.dg/unlimited_polymorphic_19.f90: New. + 2014-12-19 Alan Lawrence * 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 00000000000..a2dbaef2e4d --- /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 + +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" } } -- 2.30.2