re PR fortran/47189 ([OOP] calling STORAGE_SIZE on a NULL-initialized class pointer)

2011-01-07  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/47189
	PR fortran/47194
	* gfortran.h (gfc_lval_expr_from_sym): Moved prototype.
	* class.c (gfc_class_null_initializer): Initialize _vptr to declared
	type.
	* expr.c (gfc_lval_expr_from_sym): Moved here from symbol.c.
	* resolve.c (resolve_deallocate_expr): _data component will be added
	at translation stage.
	* symbol.c (gfc_lval_expr_from_sym): Moved to expr.c.
	* trans-stmt.c (gfc_trans_deallocate): Reset _vptr to declared type.


2011-01-07  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/47189
	PR fortran/47194
	* gfortran.dg/storage_size_3.f08: Extended.

From-SVN: r168565

gcc/fortran/ChangeLog

+2011-01-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47189
+	PR fortran/47194
+	* gfortran.h (gfc_lval_expr_from_sym): Moved prototype.
+	* class.c (gfc_class_null_initializer): Initialize _vptr to declared
+	type.
+	* expr.c (gfc_lval_expr_from_sym): Moved here from symbol.c.
+	* resolve.c (resolve_deallocate_expr): _data component will be added
+	at translation stage.
+	* symbol.c (gfc_lval_expr_from_sym): Moved to expr.c.
+	* trans-stmt.c (gfc_trans_deallocate): Reset _vptr to declared type.
+
 2011-01-06  Daniel Franke  <franke.daniel@gmail.com>
 
 	PR fortran/33117

gcc/fortran/class.c

@@ -83,7 +83,8 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
 
 
 /* Build a NULL initializer for CLASS pointers,
-   initializing the _data and _vptr components to zero.  */
+   initializing the _data component to NULL and
+   the _vptr component to the declared type.  */
 
 gfc_expr *
 gfc_class_null_initializer (gfc_typespec *ts)
@@ -98,9 +99,10 @@ gfc_class_null_initializer (gfc_typespec *ts)
   for (comp = ts->u.derived->components; comp; comp = comp->next)
     {
       gfc_constructor *ctor = gfc_constructor_get();
-      ctor->expr = gfc_get_expr ();
-      ctor->expr->expr_type = EXPR_NULL;
-      ctor->expr->ts = comp->ts;
+      if (strcmp (comp->name, "_vptr") == 0)
+	ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived));
+      else
+	ctor->expr = gfc_get_null_expr (NULL);
       gfc_constructor_append (&init->value.constructor, ctor);
     }
 

gcc/fortran/expr.c

@@ -3707,6 +3707,32 @@ gfc_get_variable_expr (gfc_symtree *var)
 }
 
 
+gfc_expr *
+gfc_lval_expr_from_sym (gfc_symbol *sym)
+{
+  gfc_expr *lval;
+  lval = gfc_get_expr ();
+  lval->expr_type = EXPR_VARIABLE;
+  lval->where = sym->declared_at;
+  lval->ts = sym->ts;
+  lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
+
+  /* It will always be a full array.  */
+  lval->rank = sym->as ? sym->as->rank : 0;
+  if (lval->rank)
+    {
+      lval->ref = gfc_get_ref ();
+      lval->ref->type = REF_ARRAY;
+      lval->ref->u.ar.type = AR_FULL;
+      lval->ref->u.ar.dimen = lval->rank;
+      lval->ref->u.ar.where = sym->declared_at;
+      lval->ref->u.ar.as = sym->as;
+    }
+
+  return lval;
+}
+
+
 /* Returns the array_spec of a full array expression.  A NULL is
    returned otherwise.  */
 gfc_array_spec *

gcc/fortran/gfortran.h

@@ -2536,8 +2536,6 @@ void gfc_free_st_label (gfc_st_label *);
 void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *);
 gfc_try gfc_reference_st_label (gfc_st_label *, gfc_sl_type);
 
-gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);
-
 gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
 gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
 gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
@@ -2701,6 +2699,7 @@ gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
 bool gfc_has_default_initializer (gfc_symbol *);
 gfc_expr *gfc_default_initializer (gfc_typespec *);
 gfc_expr *gfc_get_variable_expr (gfc_symtree *);
+gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);
 
 gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr);
 

gcc/fortran/resolve.c

@@ -6417,12 +6417,6 @@ resolve_deallocate_expr (gfc_expr *e)
   if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
     return FAILURE;
 
-  if (e->ts.type == BT_CLASS)
-    {
-      /* Only deallocate the DATA component.  */
-      gfc_add_data_component (e);
-    }
-
   return SUCCESS;
 }
 

gcc/fortran/symbol.c

@@ -2245,35 +2245,6 @@ done:
 }
 
 
-/*******A helper function for creating new expressions*************/
-
-
-gfc_expr *
-gfc_lval_expr_from_sym (gfc_symbol *sym)
-{
-  gfc_expr *lval;
-  lval = gfc_get_expr ();
-  lval->expr_type = EXPR_VARIABLE;
-  lval->where = sym->declared_at;
-  lval->ts = sym->ts;
-  lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
-
-  /* It will always be a full array.  */
-  lval->rank = sym->as ? sym->as->rank : 0;
-  if (lval->rank)
-    {
-      lval->ref = gfc_get_ref ();
-      lval->ref->type = REF_ARRAY;
-      lval->ref->u.ar.type = AR_FULL;
-      lval->ref->u.ar.dimen = lval->rank;
-      lval->ref->u.ar.where = sym->declared_at;
-      lval->ref->u.ar.as = sym->as;
-    }
-
-  return lval;
-}
-
-
 /************** Symbol table management subroutines ****************/
 
 /* Basic details: Fortran 95 requires a potentially unlimited number

gcc/fortran/trans-stmt.c

@@ -4738,7 +4738,6 @@ gfc_trans_deallocate (gfc_code *code)
 {
   gfc_se se;
   gfc_alloc *al;
-  gfc_expr *expr;
   tree apstat, astat, pstat, stat, tmp;
   stmtblock_t block;
 
@@ -4766,9 +4765,12 @@ gfc_trans_deallocate (gfc_code *code)
 
   for (al = code->ext.alloc.list; al != NULL; al = al->next)
     {
-      expr = al->expr;
+      gfc_expr *expr = gfc_copy_expr (al->expr);
       gcc_assert (expr->expr_type == EXPR_VARIABLE);
 
+      if (expr->ts.type == BT_CLASS)
+	gfc_add_data_component (expr);
+
       gfc_init_se (&se, NULL);
       gfc_start_block (&se.pre);
 
@@ -4797,6 +4799,7 @@ gfc_trans_deallocate (gfc_code *code)
 		}
 	    }
 	  tmp = gfc_array_deallocate (se.expr, pstat, expr);
+	  gfc_add_expr_to_block (&se.pre, tmp);
 	}
       else
 	{
@@ -4804,12 +4807,25 @@ gfc_trans_deallocate (gfc_code *code)
 						   expr, expr->ts);
 	  gfc_add_expr_to_block (&se.pre, tmp);
 
+	  /* Set to zero after deallocation.  */
 	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
 				 se.expr,
 				 build_int_cst (TREE_TYPE (se.expr), 0));
-	}
+	  gfc_add_expr_to_block (&se.pre, tmp);
 	  
+	  if (al->expr->ts.type == BT_CLASS)
+	    {
+	      /* Reset _vptr component to declared type.  */
+	      gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr);
+	      gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived);
+	      gfc_add_vptr_component (lhs);
+	      rhs = gfc_lval_expr_from_sym (vtab);
+	      tmp = gfc_trans_pointer_assignment (lhs, rhs);
 	      gfc_add_expr_to_block (&se.pre, tmp);
+	      gfc_free_expr (lhs);
+	      gfc_free_expr (rhs);
+	    }
+	}
 
       /* Keep track of the number of failed deallocations by adding stat
 	 of the last deallocation to the running total.  */
@@ -4822,7 +4838,7 @@ gfc_trans_deallocate (gfc_code *code)
 
       tmp = gfc_finish_block (&se.pre);
       gfc_add_expr_to_block (&block, tmp);
-
+      gfc_free_expr (expr);
     }
 
   /* Set STAT.  */

gcc/testsuite/ChangeLog

+2011-01-07  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/47189
+	PR fortran/47194
+	* gfortran.dg/storage_size_3.f08: Extended.
+
 2011-01-07  Jakub Jelinek  <jakub@redhat.com>
 
 	PR c++/47022

gcc/testsuite/gfortran.dg/storage_size_3.f08

 ! { dg-do run }
 !
 ! PR 47024: [OOP] STORAGE_SIZE (for polymorphic types): Segfault at run time
+! PR 47189: [OOP] calling STORAGE_SIZE on a NULL-initialized class pointer
+! PR 47194: [OOP] EXTENDS_TYPE_OF still returns the wrong result if the polymorphic variable is unallocated
 !
 ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
 
 type t
   integer(kind=4) :: a
 end type
+
+class(t), pointer :: x => null()
 class(t), allocatable :: y
+
+if (storage_size(x)/=32) call abort()
+if (storage_size(y)/=32) call abort()
+
+allocate(y)
+
 if (storage_size(y)/=32) call abort()
+
+deallocate(y)
+
+if (storage_size(y)/=32) call abort()
+
 end