[Patch, Fortran, OOP] PR 47189/47194

[Janus Weil <janus at gcc dot gnu dot org>]

Hi all,

here is another OOP patch, following up on my recent patches for
PR47024 and PR47180. All of them are dealing with the dynamic type of
disassociated pointers and unallocated allocatables (which equals the
declared type). Previously we set the class container's _vptr
component to NULL for these cases, now we have to make sure that they
point to the correct vtab (thereby indicating the dynamic type of the
object). The patch consists of the following parts:

1) PR47189 deals with the case of a NULL-initialized pointer and is
fixed by the hunk in class.c.
2) PR47194 deals with the case of deallocating an allocatable and is
fixed by the hunks in trans-stmt.c and resolve.c
3) Additionally I'm moving the routine 'gfc_lval_expr_from_sym' from
symbol.c to expr.c, next to the very similar 'gfc_get_variable_expr'.
4) I extended the existing test case 'storage_size_3.f08' by the cases
from both PRs (it does not matter which intrinsic procedure we use to
trigger the bug, we just need one that is sensitive to the dynamic
type).

The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2011-01-06  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  Janus Weil  <janus@gcc.gnu.org>

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

Index: gcc/testsuite/gfortran.dg/storage_size_3.f08
===================================================================
--- gcc/testsuite/gfortran.dg/storage_size_3.f08	(revision 168552)
+++ gcc/testsuite/gfortran.dg/storage_size_3.f08	(working copy)
@@ -1,12 +1,27 @@
 ! { 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 
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 168552)
+++ gcc/fortran/symbol.c	(working copy)
@@ -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
Index: gcc/fortran/class.c
===================================================================
--- gcc/fortran/class.c	(revision 168552)
+++ gcc/fortran/class.c	(working copy)
@@ -83,7 +83,8 @@ gfc_add_component_ref (gfc_expr *e, const char *na
 
 
 /* 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);
     }
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 168552)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -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
 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);
 
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 168552)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -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,13 +4807,26 @@ 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);
+	    }
 	}
 
-      gfc_add_expr_to_block (&se.pre, tmp);
-
       /* Keep track of the number of failed deallocations by adding stat
 	 of the last deallocation to the running total.  */
       if (code->expr1 || code->expr2)
@@ -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.  */
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 168552)
+++ gcc/fortran/expr.c	(working copy)
@@ -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 *
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 168552)
+++ gcc/fortran/resolve.c	(working copy)
@@ -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;
 }