Re: [Patch, Fortran, OOP] PR 57306: ICE on valid with class pointer initialization

[Janus Weil <janus@gcc.gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 1606 bytes --]

2013/7/30 Janus Weil <janus@gcc.gnu.org>:
>>> The attached new version should do the right thing now. At least it
>>> shows the correct dump for the original test case as well as yours. It
>>> is currently being regtested.
>>
>> unfortunately it shows a couple of runtime problems with type-bound operators:
>>
>> FAIL: gfortran.dg/class_defined_operator_1.f03  -O0  execution test
>> FAIL: gfortran.dg/typebound_operator_13.f03  -O0  execution test
>> FAIL: gfortran.dg/typebound_operator_7.f03  -O0  execution test
>> FAIL: gfortran.dg/typebound_operator_8.f03  -O0  execution test
>> FAIL: gfortran.dg/typebound_operator_9.f03  -O0  execution test
>
> The attached update fixes it, and thus should hopefully be
> regression-free. It also renames 'gfc_class_null_initializer' to
> 'gfc_class_initializer', since it now also does other initializations
> beside EXPR_NULL.
>
> Will do another regtest to make sure it's clean.

No failures observed. As a test case I'm using now Tobias' extended
version (attached). New ChangeLog below.

Ok for trunk?

Cheers,
Janus


2013-07-30  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/57306
    * class.c (gfc_class_null_initializer): Rename to
    'gfc_class_initializer'. Treat non-NULL init-exprs.
    * gfortran.h (gfc_class_null_initializer): Update prototype.
    * trans-decl.c (gfc_get_symbol_decl): Treat class pointers.
    * trans-expr.c (gfc_conv_initializer): Ditto.
    (gfc_trans_subcomponent_assign): Renamed gfc_class_null_initializer.

2013-07-30  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/57306
    * gfortran.dg/pointer_init_8.f90: New.

[-- Attachment #2: pr57306_v4.diff --]
[-- Type: application/octet-stream, Size: 4699 bytes --]

Index: gcc/fortran/class.c
===================================================================
--- gcc/fortran/class.c	(revision 201283)
+++ gcc/fortran/class.c	(working copy)
@@ -412,12 +412,12 @@ gfc_is_class_container_ref (gfc_expr *e)
 }
 
 
-/* Build a NULL initializer for CLASS pointers,
-   initializing the _data component to NULL and
-   the _vptr component to the declared type.  */
+/* Build an initializer for CLASS pointers,
+   initializing the _data component to the init_expr (or NULL) and the _vptr
+   component to the corresponding type (or the declared type, given by ts).  */
 
 gfc_expr *
-gfc_class_null_initializer (gfc_typespec *ts, gfc_expr *init_expr)
+gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
 {
   gfc_expr *init;
   gfc_component *comp;
@@ -430,6 +430,8 @@ gfc_expr *
 
   if (is_unlimited_polymorphic && init_expr)
     vtab = gfc_find_intrinsic_vtab (&ts->u.derived->components->ts);
+  else if (init_expr && init_expr->expr_type != EXPR_NULL)
+    vtab = gfc_find_derived_vtab (init_expr->ts.u.derived);
   else
     vtab = gfc_find_derived_vtab (ts->u.derived);
 
@@ -442,6 +444,8 @@ gfc_expr *
       gfc_constructor *ctor = gfc_constructor_get();
       if (strcmp (comp->name, "_vptr") == 0 && vtab)
 	ctor->expr = gfc_lval_expr_from_sym (vtab);
+      else if (init_expr && init_expr->expr_type != EXPR_NULL)
+	  ctor->expr = gfc_copy_expr (init_expr);
       else
 	ctor->expr = gfc_get_null_expr (NULL);
       gfc_constructor_append (&init->value.constructor, ctor);
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 201283)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2983,7 +2983,7 @@ void gfc_add_class_array_ref (gfc_expr *);
 bool gfc_is_class_array_ref (gfc_expr *, bool *);
 bool gfc_is_class_scalar_expr (gfc_expr *);
 bool gfc_is_class_container_ref (gfc_expr *e);
-gfc_expr *gfc_class_null_initializer (gfc_typespec *, gfc_expr *);
+gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
 unsigned int gfc_hash_value (gfc_symbol *);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 				gfc_array_spec **, bool);
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 201283)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -1491,14 +1491,16 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	 SAVE is specified otherwise they need to be reinitialized
 	 every time the procedure is entered. The TREE_STATIC is
 	 in this case due to -fmax-stack-var-size=.  */
+      bool ptr = sym->attr.pointer || sym->attr.allocatable
+		 || (sym->ts.type == BT_CLASS
+		     && CLASS_DATA (sym)->attr.class_pointer);
+						  
       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
 						  TREE_TYPE (decl),
 						  sym->attr.dimension
 						  || (sym->attr.codimension
 						      && sym->attr.allocatable),
-						  sym->attr.pointer
-						  || sym->attr.allocatable,
-						  sym->attr.proc_pointer);
+						  ptr, sym->attr.proc_pointer);
     }
 
   if (!TREE_STATIC (decl)
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 201283)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -5663,7 +5663,15 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespe
     }
   else if (pointer || procptr)
     {
-      if (!expr || expr->expr_type == EXPR_NULL)
+      if (ts->type == BT_CLASS && !procptr)
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
+	  gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
+	  TREE_STATIC (se.expr) = 1;
+	  return se.expr;
+	}
+      else if (!expr || expr->expr_type == EXPR_NULL)
 	return fold_convert (type, null_pointer_node);
       else
 	{
@@ -5682,7 +5690,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespe
 	case BT_CLASS:
 	  gfc_init_se (&se, NULL);
 	  if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
-	    gfc_conv_structure (&se, gfc_class_null_initializer(ts, expr), 1);
+	    gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
 	  else
 	    gfc_conv_structure (&se, expr, 1);
 	  gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
@@ -5992,7 +6000,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_comp
     {
       /* NULL initialization for CLASS components.  */
       tmp = gfc_trans_structure_assign (dest,
-					gfc_class_null_initializer (&cm->ts, expr));
+					gfc_class_initializer (&cm->ts, expr));
       gfc_add_expr_to_block (&block, tmp);
     }
   else if (cm->attr.dimension && !cm->attr.proc_pointer)

[-- Attachment #3: pointer_init_8.f90 --]
[-- Type: application/octet-stream, Size: 573 bytes --]

! { dg-do compile }
!
! PR 57306: [OOP] ICE on valid with class pointer initialization
!
! Contributed by Andrew Benson <abensonca@gmail.com>

module m
  type :: c
  end type c
  type, extends(c) :: d
  end type d
  type(c), target :: x
  type(d), target :: y
end module m

 use m
  class(c), pointer :: px => x
  class(c), pointer :: py => y

  if (.not. associated(px, x))   call abort()
  if (.not. same_type_as(px, x)) call abort()
  if (.not. associated(py, y))   call abort()
  if (.not. same_type_as(py, y)) call abort()
end 

! { dg-final { cleanup-modules "m" } }