re PR fortran/57306 ([OOP] [F08] ICE on valid with class pointer initialization)

2013-08-06  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 variables.
	* trans-expr.c (gfc_conv_initializer): Ditto.
	(gfc_trans_subcomponent_assign): Renamed gfc_class_null_initializer.

2013-08-06  Janus Weil  <janus@gcc.gnu.org>

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

From-SVN: r201521

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8faf7ec01e7cc3ff652bd7fc48b2677875647d83..7a9fe6ef8bd3cc7cf16bd401dc4e4a21f3e7b437 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2013-08-06  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 variables.
+       * trans-expr.c (gfc_conv_initializer): Ditto.
+       (gfc_trans_subcomponent_assign): Renamed gfc_class_null_initializer.
+
 2013-07-30  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/57530

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 51bfd5685ea74d1ea993e20ab5dea8d1e4af861b..fb16682e51c0a8a08573ec9403930e90f48c3af3 100644 (file)
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -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_class_null_initializer (gfc_typespec *ts, gfc_expr *init_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_class_null_initializer (gfc_typespec *ts, gfc_expr *init_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);

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index c11ffdda8b9f4642be73e72c2b65dc921da03666..af7b5b99f9ba838568114a321e7e56dea24fe4c5 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -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);

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 2916b4cc52e5d98f578724823350806a7cbac84b..43f401d83d4e71190b7fb81d2ce406270197bfd7 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1491,14 +1491,14 @@ 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=.  */
+
       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);
+                                   TREE_TYPE (decl), sym->attr.dimension
+                                   || (sym->attr.codimension
+                                       && sym->attr.allocatable),
+                                   sym->attr.pointer || sym->attr.allocatable
+                                   || sym->ts.type == BT_CLASS,
+                                   sym->attr.proc_pointer);
     }
 
   if (!TREE_STATIC (decl)

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 74e95b0892806e2a3b081c3eec84438b3b0c77c6..0801eee8b284945b7fc7b58e8f0a1757938a7b98 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5664,7 +5664,15 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
     }
   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
        {
@@ -5683,7 +5691,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
        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);
@@ -5993,7 +6001,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
     {
       /* 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)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 92aff7a9f5116067a44516a790eee08d87efce7f..e8ac8604c769fec14650dfc3ca008afc597f29e2 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2013-08-06  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/57306
+       * gfortran.dg/pointer_init_8.f90: New.
+
 2013-08-05  Paolo Carlini  <paolo.carlini@oracle.com>
 
        PR c++/58080

diff --git a/gcc/testsuite/gfortran.dg/pointer_init_8.f90 b/gcc/testsuite/gfortran.dg/pointer_init_8.f90
new file mode 100644 (file)
index 0000000..aacd9a8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_init_8.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+!
+! 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" } }