diff mbox

[Fortran] reset dynamic type with MOVE_ALLOC (was: Re: [Patch, Fortran] Small patch for calls to gfc_deallocate_scalar_with_status)

Message ID 50C4E0CE.9000906@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Dec. 9, 2012, 7:04 p.m. UTC 
Janus Weil wrote:
>> >The expr to al->expr change is to pass a BT_CLASS instead of a
>> >BT_DERIVED. And the NULL to gfc_lval_expr_from_sym change allows to access
>> >var->_vtab->_final for a BT_CLASS deferred variable.
> It seems that both of them will not have any effect right now, but are
> useful only as preparation for FINAL, right?

I think that's true. I wanted to claim that it also fixes the following, 
but it doesn't:

  class(t), allocatable :: a, b, c
  allocate (t2 :: a)
  call move_alloc (from=a, to=b)

"a" should not only be deallocated but same_type_as(a,c) should be true, 
i.e. one has to reset the "a->_vtab" pointer to the declared type.

A follow-up patch which fixes this is attached.

Build and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias

Comments

Paul Richard Thomas Dec. 16, 2012, 1:03 p.m. UTC | #1 
Dear Tobias,

This does what it is advertised to do - OK for trunk

Thanks for the patch.

Paul

PS Thomas has beaten it to me on the other two patches; they look OK
for trunk to me too.

On 9 December 2012 20:04, Tobias Burnus <burnus@net-b.de> wrote:
> Janus Weil wrote:
>>>
>>> >The expr to al->expr change is to pass a BT_CLASS instead of a
>>> >BT_DERIVED. And the NULL to gfc_lval_expr_from_sym change allows to
>>> > access
>>> >var->_vtab->_final for a BT_CLASS deferred variable.
>>
>> It seems that both of them will not have any effect right now, but are
>> useful only as preparation for FINAL, right?
>
>
> I think that's true. I wanted to claim that it also fixes the following, but
> it doesn't:
>
>  class(t), allocatable :: a, b, c
>  allocate (t2 :: a)
>  call move_alloc (from=a, to=b)
>
> "a" should not only be deallocated but same_type_as(a,c) should be true,
> i.e. one has to reset the "a->_vtab" pointer to the declared type.
>
> A follow-up patch which fixes this is attached.
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?
>
> Tobias
diff mbox

Patch

2012-12-09  Tobias Burnus  <burnus@net-b.de>

	* trans-intrinsic.c (conv_intrinsic_move_alloc): Set dynamic
	type of the FROM variable to the declared type.

2012-12-09  Tobias Burnus  <burnus@net-b.de>

	* gfortran.dg/move_alloc_14.f90: New.

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 504a9f3..4f74c3f 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7338,6 +7338,8 @@  conv_intrinsic_move_alloc (gfc_code *code)
       /* Set _vptr.  */
       if (to_expr->ts.type == BT_CLASS)
 	{
+	  gfc_symbol *vtab;
+
 	  gfc_free_expr (to_expr2);
 	  gfc_init_se (&to_se, NULL);
 	  to_se.want_pointer = 1;
@@ -7346,23 +7348,31 @@  conv_intrinsic_move_alloc (gfc_code *code)
 
 	  if (from_expr->ts.type == BT_CLASS)
 	    {
+	      vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+	      gcc_assert (vtab);
+
 	      gfc_free_expr (from_expr2);
 	      gfc_init_se (&from_se, NULL);
 	      from_se.want_pointer = 1;
 	      gfc_add_vptr_component (from_expr);
 	      gfc_conv_expr (&from_se, from_expr);
-	      tmp = from_se.expr;
+	      gfc_add_modify_loc (input_location, &block, to_se.expr,
+				  fold_convert (TREE_TYPE (to_se.expr),
+				  from_se.expr));
+
+              /* Reset _vptr component to declared type.  */
+	      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+	      gfc_add_modify_loc (input_location, &block, from_se.expr,
+				  fold_convert (TREE_TYPE (from_se.expr), tmp));
 	    }
 	  else
 	    {
-	      gfc_symbol *vtab;
 	      vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
 	      gcc_assert (vtab);
 	      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+	      gfc_add_modify_loc (input_location, &block, to_se.expr,
+				  fold_convert (TREE_TYPE (to_se.expr), tmp));
 	    }
-
-	  gfc_add_modify_loc (input_location, &block, to_se.expr,
-			      fold_convert (TREE_TYPE (to_se.expr), tmp));
 	}
 
       return gfc_finish_block (&block);
@@ -7371,6 +7381,8 @@  conv_intrinsic_move_alloc (gfc_code *code)
   /* Update _vptr component.  */
   if (to_expr->ts.type == BT_CLASS)
     {
+      gfc_symbol *vtab;
+
       to_se.want_pointer = 1;
       to_expr2 = gfc_copy_expr (to_expr);
       gfc_add_vptr_component (to_expr2);
@@ -7378,22 +7390,31 @@  conv_intrinsic_move_alloc (gfc_code *code)
 
       if (from_expr->ts.type == BT_CLASS)
 	{
+	  vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+	  gcc_assert (vtab);
+
 	  from_se.want_pointer = 1;
 	  from_expr2 = gfc_copy_expr (from_expr);
 	  gfc_add_vptr_component (from_expr2);
 	  gfc_conv_expr (&from_se, from_expr2);
-	  tmp = from_se.expr;
+	  gfc_add_modify_loc (input_location, &block, to_se.expr,
+			      fold_convert (TREE_TYPE (to_se.expr),
+			      from_se.expr));
+
+	  /* Reset _vptr component to declared type.  */
+	  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+	  gfc_add_modify_loc (input_location, &block, from_se.expr,
+			      fold_convert (TREE_TYPE (from_se.expr), tmp));
 	}
       else
 	{
-	  gfc_symbol *vtab;
 	  vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
 	  gcc_assert (vtab);
 	  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+	  gfc_add_modify_loc (input_location, &block, to_se.expr,
+			      fold_convert (TREE_TYPE (to_se.expr), tmp));
 	}
 
-      gfc_add_modify_loc (input_location, &block, to_se.expr,
-			  fold_convert (TREE_TYPE (to_se.expr), tmp));
       gfc_free_expr (to_expr2);
       gfc_init_se (&to_se, NULL);
 
@@ -7449,7 +7470,7 @@  conv_intrinsic_move_alloc (gfc_code *code)
   /* Move the pointer and update the array descriptor data.  */
   gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
 
-  /* Set "to" to NULL.  */
+  /* Set "from" to NULL.  */
   tmp = gfc_conv_descriptor_data_get (from_se.expr);
   gfc_add_modify_loc (input_location, &block, tmp,
 		      fold_convert (TREE_TYPE (tmp), null_pointer_node));
diff --git a/gcc/testsuite/gfortran.dg/move_alloc_14.f90 b/gcc/testsuite/gfortran.dg/move_alloc_14.f90
new file mode 100644
index 0000000..bc5e491
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/move_alloc_14.f90
@@ -0,0 +1,22 @@ 
+! { dg-do run }
+!
+! Ensure that move_alloc for CLASS resets the FROM variable's dynamic type
+! to the declared one
+!
+implicit none
+type t
+end type t
+type, extends(t) :: t2
+end type t2
+
+class(t), allocatable :: a, b, c
+class(t), allocatable :: a2(:), b2(:), c2(:)
+allocate (t2 :: a)
+allocate (t2 :: a2(5))
+call move_alloc (from=a, to=b)
+call move_alloc (from=a2, to=b2)
+!print *, same_type_as (a,c), same_type_as (a,b)
+!print *, same_type_as (a2,c2), same_type_as (a2,b2)
+if (.not. same_type_as (a,c) .or. same_type_as (a,b)) call abort ()
+if (.not. same_type_as (a2,c2) .or. same_type_as (a2,b2)) call abort ()
+end