Bug 47194 - [OOP] EXTENDS_TYPE_OF still returns the wrong result if the polymorphic variable is unallocated
Summary: [OOP] EXTENDS_TYPE_OF still returns the wrong result if the polymorphic varia...
Status: RESOLVED FIXED
Alias: None
Product: gcc
Classification: Unclassified
Component: fortran (show other bugs)
Version: 4.6.0
: P3 normal
Target Milestone: 4.6.0
Assignee: janus
URL:
Keywords: wrong-code
Depends on:
Blocks:
 
Reported: 2011-01-06 17:33 UTC by Tobias Burnus
Modified: 2016-11-16 13:48 UTC (History)
1 user (show)

See Also:
Host:
Target:
Build:
Known to work:
Known to fail:
Last reconfirmed: 2011-01-06 18:29:25


Attachments

Note You need to log in before you can comment on or make changes to this bug.
Description Tobias Burnus 2011-01-06 17:33:12 UTC
Found when looking at PR 41580 -- and related to PR47180, PR47024 and PR47189.

The following programs works if "b1" was never allocated - and if it was last allocated to "t1"; it fails if it was last allocated to "t11".

Thus, the vtab seems to be properly set initially; it also seems to be properly set during allocation, but it does not seem to get reset for DEALLOCATE.


implicit none
type t1
  integer :: a
end type t1
type, extends(t1):: t11
  integer :: b
end type t11

class(t1), allocatable :: b1
class(t11), allocatable :: b11

allocate(t11 :: b1)
deallocate(b1)
if (extends_type_of(b1,b11) .neqv. .false.) call abort()
end
Comment 1 janus 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;
 }
Comment 2 janus 2011-01-07 12:08:48 UTC
Author: janus
Date: Fri Jan  7 12:08:21 2011
New Revision: 168565

URL: http://gcc.gnu.org/viewcvs?root=gcc&view=rev&rev=168565
Log:
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.

Modified:
    trunk/gcc/fortran/ChangeLog
    trunk/gcc/fortran/class.c
    trunk/gcc/fortran/expr.c
    trunk/gcc/fortran/gfortran.h
    trunk/gcc/fortran/resolve.c
    trunk/gcc/fortran/symbol.c
    trunk/gcc/fortran/trans-stmt.c
    trunk/gcc/testsuite/ChangeLog
    trunk/gcc/testsuite/gfortran.dg/storage_size_3.f08
Comment 3 janus 2011-01-07 17:29:57 UTC
Fixed with r168565. Closing.