OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Janus Weil 2014-12-19 20:28:57 +01:00
parent 34a2b7558b
commit 375550c647
4 changed files with 91 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View File

@ -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

26
gcc/fortran/trans-expr.c
View File

@ -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

5
gcc/testsuite/ChangeLog
View File

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

53
gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 Normal file
View File

@ -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" } }