[Bug fortran/47194] [OOP] EXTENDS_TYPE_OF still returns the wrong result if the polymorphic variable is unallocated

[janus at gcc dot gnu.org]

http://gcc.gnu.org/bugzilla/show_bug.cgi?id=47194

janus at gcc dot gnu.org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
             Status|UNCONFIRMED                 |ASSIGNED
   Last reconfirmed|                            |2011.01.06 18:29:25
         AssignedTo|unassigned at gcc dot       |janus at gcc dot gnu.org
                   |gnu.org                     |
     Ever Confirmed|0                           |1

--- Comment #1 from janus at gcc dot gnu.org 2011-01-06 18:29:25 UTC ---
(In reply to comment #0)
> Found when looking at PR 41580 -- and related to PR47180, PR47024 and PR47189.

Seems we opened a nice can of worms here ;)


Patch:

Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c    (revision 168539)
+++ 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.  */
+          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/resolve.c
===================================================================
--- gcc/fortran/resolve.c    (revision 168539)
+++ 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;
 }