[Patch, Fortran, OOP] PR 64209: runtime segfault with CLASS(*), INTENT(OUT) dummy argument

[Janus Weil]

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