[PATCH v2] Fortran: fix reallocation on assignment of polymorphic variables [PR110415]

[PATCH v2] Fortran: fix reallocation on assignment of polymorphic variables [PR110415]

[Andrew Jenner]

[-- Attachment #1: Type: text/plain, Size: 3194 bytes --]

This is the second version of the patch - previous discussion at:
https://gcc.gnu.org/pipermail/gcc-patches/2023-November/636671.html

This patch adds the testcase from PR110415 and fixes the bug.

The problem is that in a couple of places in trans_class_assignment in
trans-expr.cc, we need to get the run-time size of the polymorphic
object from the vtbl, but we are currently getting that vtbl from the
lhs of the assignment rather than the rhs. This gives us the old value
of the size but we need to pass the new size to __builtin_malloc and
__builtin_realloc.

I'm fixing this by adding a parameter to trans_class_vptr_len_assignment
to retrieve the tree corresponding the vptr from the object on the rhs
of the assignment, and then passing this where it is needed. In the case
where trans_class_vptr_len_assignment returns NULL_TREE for the rhs vptr
we use the lhs vptr as before.

To get this to work I also needed to change the implementation of
trans_class_vptr_len_assignment to create a temporary for the assignment
in more circumstances. Currently, the "a = func()" assignment in MAIN__
doesn't hit the "Create a temporary for complication expressions" case
on line 9951 because "DECL_P (rse->expr)" is true - the expression has
already been placed into a temporary. That means we don't hit the "if
(temp_rhs ..." case on line 10038 and go on to get the vptr_expr from
"gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts))" on line 10057 which
is the vtbl of the static type rather than the dynamic one from the rhs.
So with this fix we create an extra temporary, but that should be
optimised away in the middle-end so there should be no run-time effect.

I'm not sure if this is the best way to fix this (the Fortran front-end
is new territory for me) but I've verified that the testcase passes with
this change, fails without it, and that the change does not introduce
any FAILs when running the gfortran testcases on x86_64-pc-linux-gnu.

After the previous submission, Tobias Burnus found a closely related 
problem and contributed testcases and a fix for it, which I have 
incorporated into this version of the patch. The problem in this case is 
with the __builtin_realloc call that is executed if one polymorphic 
variable is replaced by another. The return value of this call was being 
ignored rather than used to replace the pointer being reallocated.

Is this OK for mainline, GCC 13 and OG13?

Thanks,

Andrew

gcc/fortran/
          PR fortran/110415
          * trans-expr.cc (trans_class_vptr_len_assignment): Add
          from_vptrp parameter. Populate it. Don't check for DECL_P
          when deciding whether to create temporary.
          (trans_class_pointer_fcn, gfc_trans_pointer_assignment): Add
          NULL argument to trans_class_vptr_len_assignment calls.
          (trans_class_assignment): Get rhs_vptr from
          trans_class_vptr_len_assignment and use it for determining size
          for allocation/reallocation. Use return value from realloc.

gcc/testsuite/
          PR fortran/110415
          * gfortran.dg/pr110415.f90: New test.
          * gfortran.dg/asan/pr110415-2.f90: New test.
          * gfortran.dg/asan/pr110415-3.f90: New test.

[-- Attachment #2: pr110415-2.patch --]
[-- Type: text/plain, Size: 8553 bytes --]

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 50c4604a025..bfe9996ced6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9936,7 +9936,8 @@ trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
 static tree
 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
 				 gfc_expr * re, gfc_se *rse,
-				 tree * to_lenp, tree * from_lenp)
+				 tree * to_lenp, tree * from_lenp,
+				 tree * from_vptrp)
 {
   gfc_se se;
   gfc_expr * vptr_expr;
@@ -9944,10 +9945,11 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
   bool set_vptr = false, temp_rhs = false;
   stmtblock_t *pre = block;
   tree class_expr = NULL_TREE;
+  tree from_vptr = NULL_TREE;
 
   /* Create a temporary for complicated expressions.  */
   if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
-      && rse->expr != NULL_TREE && !DECL_P (rse->expr))
+      && rse->expr != NULL_TREE)
     {
       if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
 	class_expr = gfc_get_class_from_expr (rse->expr);
@@ -10044,6 +10046,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
 		tmp = rse->expr;
 
 	      se.expr = gfc_class_vptr_get (tmp);
+	      from_vptr = se.expr;
 	      if (UNLIMITED_POLY (re))
 		from_len = gfc_class_len_get (tmp);
 
@@ -10065,6 +10068,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
 	  gfc_free_expr (vptr_expr);
 	  gfc_add_block_to_block (block, &se.pre);
 	  gcc_assert (se.post.head == NULL_TREE);
+	  from_vptr = se.expr;
 	}
       gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
 						se.expr));
@@ -10093,11 +10097,13 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
 	}
     }
 
-  /* Return the _len trees only, when requested.  */
+  /* Return the _len and _vptr trees only, when requested.  */
   if (to_lenp)
     *to_lenp = to_len;
   if (from_lenp)
     *from_lenp = from_len;
+  if (from_vptrp)
+    *from_vptrp = from_vptr;
   return lhs_vptr;
 }
 
@@ -10166,7 +10172,7 @@ trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
     {
       expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
 						    expr2, rse,
-						    NULL, NULL);
+						    NULL, NULL, NULL);
       gfc_add_block_to_block (block, &rse->pre);
       tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
       gfc_add_modify (&lse->pre, tmp, rse->expr);
@@ -10242,7 +10248,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
 	{
 	  trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
-					   NULL);
+					   NULL, NULL);
 	  lse.expr = gfc_class_data_get (lse.expr);
 	}
 
@@ -10371,7 +10377,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	      if (expr1->ts.type == BT_CLASS)
 		expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
 							      expr2, &rse,
-							      NULL, NULL);
+							      NULL, NULL,
+							      NULL);
 	    }
 	}
       else if (expr2->expr_type == EXPR_VARIABLE)
@@ -10388,7 +10395,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	      rse.expr = NULL_TREE;
 	      rse.string_length = strlen_rhs;
 	      trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
-					       NULL, NULL);
+					       NULL, NULL, NULL);
 	    }
 
 	  if (remap == NULL)
@@ -10421,7 +10428,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	    {
 	      expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
 							    expr2, &rse, NULL,
-							    NULL);
+							    NULL, NULL);
 	      gfc_add_block_to_block (&block, &rse.pre);
 	      tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
 	      gfc_add_modify (&lse.pre, tmp, rse.expr);
@@ -11819,7 +11826,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 			gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
 			bool class_realloc)
 {
-  tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
+  tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
   vec<tree, va_gc> *args = NULL;
   bool final_expr;
 
@@ -11843,7 +11850,9 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
     }
 
   vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
-					 &from_len);
+					  &from_len, &rhs_vptr);
+  if (rhs_vptr == NULL_TREE)
+    rhs_vptr = vptr;
 
   /* Generate (re)allocation of the lhs.  */
   if (class_realloc)
@@ -11856,7 +11865,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
       else
 	old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
 
-      size = gfc_vptr_size_get (vptr);
+      size = gfc_vptr_size_get (rhs_vptr);
       tmp = lse->expr;
       class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
 	  ? gfc_class_data_get (tmp) : tmp;
@@ -11870,12 +11879,14 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 
       /* Reallocate if dynamic types are different. */
       gfc_init_block (&re_alloc);
+      tmp = fold_convert (pvoid_type_node, class_han);
       re = build_call_expr_loc (input_location,
 				builtin_decl_explicit (BUILT_IN_REALLOC), 2,
-				fold_convert (pvoid_type_node, class_han),
-				size);
+				tmp, size);
+      re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
+			    re);
       tmp = fold_build2_loc (input_location, NE_EXPR,
-			     logical_type_node, vptr, old_vptr);
+			     logical_type_node, rhs_vptr, old_vptr);
       re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 			    tmp, re, build_empty_stmt (input_location));
       gfc_add_expr_to_block (&re_alloc, re);
diff --git a/gcc/testsuite/gfortran.dg/asan/pr110415-2.f90 b/gcc/testsuite/gfortran.dg/asan/pr110415-2.f90
new file mode 100755
index 00000000000..f4ff1823e54
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/asan/pr110415-2.f90
@@ -0,0 +1,45 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+implicit none
+  type, abstract :: p
+    integer :: a = 4
+  end type p
+
+  type, extends(p) :: c
+    integer :: b = 7
+    character(len=:), allocatable :: str, str2(:)
+  end type c
+
+  type, extends(p) :: d
+    integer :: ef = 7
+  end type d
+
+  class(p), allocatable :: a
+
+  a = func()
+
+  a = func2()
+
+  a = func()
+
+  deallocate(a)
+
+contains
+  function func2() result(a)
+    class(p), allocatable :: a
+    a = d()
+  end function func2
+
+  function func() result(a)
+    class(p), allocatable :: a
+
+    a = c()
+    select type(a)
+    type is (c)
+      a%str = 'abcd'
+      a%str2 = ['abcd','efgh']
+    end select
+  end function func
+end program
diff --git a/gcc/testsuite/gfortran.dg/asan/pr110415-3.f90 b/gcc/testsuite/gfortran.dg/asan/pr110415-3.f90
new file mode 100755
index 00000000000..65c018d805f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/asan/pr110415-3.f90
@@ -0,0 +1,49 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+implicit none
+  type, abstract :: p
+    integer :: a = 4
+  end type p
+
+  type, extends(p) :: c
+    integer :: b = 7
+    character(len=:), allocatable :: str, str2(:)
+  end type c
+
+  type, extends(p) :: d
+    integer :: ef = 7
+  end type d
+
+  class(p), allocatable :: a(:)
+
+  a = func()
+
+  a = func2()
+
+  a = func()
+
+  deallocate(a)
+
+contains
+  function func2() result(a)
+    class(p), allocatable :: a(:)
+    a = [d(),d()]
+  end function func2
+
+  function func() result(a)
+    class(p), allocatable :: a(:)
+
+    a = [c(),c(),c()]
+    select type(a)
+    type is (c)
+      a(1)%str = 'abcd'
+      a(2)%str = 'abc'
+      a(3)%str = 'abcd4'
+      a(1)%str2 = ['abcd','efgh']
+      a(2)%str2 = ['bcd','fgh']
+      a(3)%str2 = ['abcd6','efgh7']
+    end select
+  end function func
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr110415.f90 b/gcc/testsuite/gfortran.dg/pr110415.f90
new file mode 100644
index 00000000000..f647cc4c52c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr110415.f90
@@ -0,0 +1,20 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+  type, abstract :: p
+  end type p
+
+  type, extends(p) :: c
+  end type c
+
+  class(p), allocatable :: a
+
+  a = func()
+contains
+  function func() result(a)
+    class(p), allocatable :: a
+
+    a = c()
+  end function func
+end program

Re: [PATCH v2] Fortran: fix reallocation on assignment of polymorphic variables [PR110415]

[Tobias Burnus]

Hi Andrew,

On 27.11.23 18:35, Andrew Jenner wrote:
> This is the second version of the patch - previous discussion at:
> https://gcc.gnu.org/pipermail/gcc-patches/2023-November/636671.html
>
> This patch adds the testcase from PR110415 and fixes the bug.
>
> The problem is that in a couple of places in trans_class_assignment in
> trans-expr.cc, we need to get the run-time size of the polymorphic
> object from the vtbl, but we are currently getting that vtbl from the
> lhs of the assignment rather than the rhs. This gives us the old value
> of the size but we need to pass the new size to __builtin_malloc and
> __builtin_realloc.
>
> I'm fixing this by adding a parameter to trans_class_vptr_len_assignment
> to retrieve the tree corresponding the vptr from the object on the rhs
> of the assignment, and then passing this where it is needed. In the case
> where trans_class_vptr_len_assignment returns NULL_TREE for the rhs vptr
> we use the lhs vptr as before.
>
> To get this to work I also needed to change the implementation of
> trans_class_vptr_len_assignment to create a temporary for the assignment
> in more circumstances. Currently, the "a = func()" assignment in MAIN__
> doesn't hit the "Create a temporary for complication expressions" case
> on line 9951 because "DECL_P (rse->expr)" is true - the expression has
> already been placed into a temporary. That means we don't hit the "if
> (temp_rhs ..." case on line 10038 and go on to get the vptr_expr from
> "gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts))" on line 10057 which
> is the vtbl of the static type rather than the dynamic one from the rhs.
> So with this fix we create an extra temporary, but that should be
> optimised away in the middle-end so there should be no run-time effect.
>
> I'm not sure if this is the best way to fix this (the Fortran front-end
> is new territory for me) but I've verified that the testcase passes with
> this change, fails without it, and that the change does not introduce
> any FAILs when running the gfortran testcases on x86_64-pc-linux-gnu.
>
> After the previous submission, Tobias Burnus found a closely related
> problem and contributed testcases and a fix for it, which I have
> incorporated into this version of the patch. The problem in this case
> is with the __builtin_realloc call that is executed if one polymorphic
> variable is replaced by another. The return value of this call was
> being ignored rather than used to replace the pointer being reallocated.
>
> Is this OK for mainline, GCC 13 and OG13?

LGTM – Thanks! OK for mainline and after some grace period for GCC 13.

OG13 does not require approval, hence, either cherry pick directly or
wait until it is in GCC 13 and then "git merge" GCC 13 to OG13.

Thanks,

Tobias


> gcc/fortran/
>          PR fortran/110415
>          * trans-expr.cc (trans_class_vptr_len_assignment): Add
>          from_vptrp parameter. Populate it. Don't check for DECL_P
>          when deciding whether to create temporary.
>          (trans_class_pointer_fcn, gfc_trans_pointer_assignment): Add
>          NULL argument to trans_class_vptr_len_assignment calls.
>          (trans_class_assignment): Get rhs_vptr from
>          trans_class_vptr_len_assignment and use it for determining size
>          for allocation/reallocation. Use return value from realloc.
>
> gcc/testsuite/
>          PR fortran/110415
>          * gfortran.dg/pr110415.f90: New test.
>          * gfortran.dg/asan/pr110415-2.f90: New test.
>          * gfortran.dg/asan/pr110415-3.f90: New test.
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955

Re: [PATCH v2] Fortran: fix reallocation on assignment of polymorphic variables [PR110415]

[Paul Richard Thomas]

[-- Attachment #1.1: Type: text/plain, Size: 3554 bytes --]

Hi Andrew,

This is OK by me.

I attach a slightly edited version of the patch itself in the hope that it
will make the code a bit clearer.

Thanks and welcome!

Paul


On Mon, 27 Nov 2023 at 17:35, Andrew Jenner <andrew@codesourcery.com> wrote:

> This is the second version of the patch - previous discussion at:
> https://gcc.gnu.org/pipermail/gcc-patches/2023-November/636671.html
>
> This patch adds the testcase from PR110415 and fixes the bug.
>
> The problem is that in a couple of places in trans_class_assignment in
> trans-expr.cc, we need to get the run-time size of the polymorphic
> object from the vtbl, but we are currently getting that vtbl from the
> lhs of the assignment rather than the rhs. This gives us the old value
> of the size but we need to pass the new size to __builtin_malloc and
> __builtin_realloc.
>
> I'm fixing this by adding a parameter to trans_class_vptr_len_assignment
> to retrieve the tree corresponding the vptr from the object on the rhs
> of the assignment, and then passing this where it is needed. In the case
> where trans_class_vptr_len_assignment returns NULL_TREE for the rhs vptr
> we use the lhs vptr as before.
>
> To get this to work I also needed to change the implementation of
> trans_class_vptr_len_assignment to create a temporary for the assignment
> in more circumstances. Currently, the "a = func()" assignment in MAIN__
> doesn't hit the "Create a temporary for complication expressions" case
> on line 9951 because "DECL_P (rse->expr)" is true - the expression has
> already been placed into a temporary. That means we don't hit the "if
> (temp_rhs ..." case on line 10038 and go on to get the vptr_expr from
> "gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts))" on line 10057 which
> is the vtbl of the static type rather than the dynamic one from the rhs.
> So with this fix we create an extra temporary, but that should be
> optimised away in the middle-end so there should be no run-time effect.
>
> I'm not sure if this is the best way to fix this (the Fortran front-end
> is new territory for me) but I've verified that the testcase passes with
> this change, fails without it, and that the change does not introduce
> any FAILs when running the gfortran testcases on x86_64-pc-linux-gnu.
>
> After the previous submission, Tobias Burnus found a closely related
> problem and contributed testcases and a fix for it, which I have
> incorporated into this version of the patch. The problem in this case is
> with the __builtin_realloc call that is executed if one polymorphic
> variable is replaced by another. The return value of this call was being
> ignored rather than used to replace the pointer being reallocated.
>
> Is this OK for mainline, GCC 13 and OG13?
>
> Thanks,
>
> Andrew
>
> gcc/fortran/
>           PR fortran/110415
>           * trans-expr.cc (trans_class_vptr_len_assignment): Add
>           from_vptrp parameter. Populate it. Don't check for DECL_P
>           when deciding whether to create temporary.
>           (trans_class_pointer_fcn, gfc_trans_pointer_assignment): Add
>           NULL argument to trans_class_vptr_len_assignment calls.
>           (trans_class_assignment): Get rhs_vptr from
>           trans_class_vptr_len_assignment and use it for determining size
>           for allocation/reallocation. Use return value from realloc.
>
> gcc/testsuite/
>           PR fortran/110415
>           * gfortran.dg/pr110415.f90: New test.
>           * gfortran.dg/asan/pr110415-2.f90: New test.
>           * gfortran.dg/asan/pr110415-3.f90: New test.

[-- Attachment #2: pr110415_prt.diff --]
[-- Type: text/x-patch, Size: 6919 bytes --]

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 1b8be081a17..35b000bf8d5 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9892,7 +9892,9 @@ trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
 static tree
 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
 				 gfc_expr * re, gfc_se *rse,
-				 tree * to_lenp, tree * from_lenp)
+				 tree * to_lenp = NULL,
+				 tree * from_lenp = NULL,
+				 tree * from_vptrp = NULL)
 {
   gfc_se se;
   gfc_expr * vptr_expr;
@@ -9900,12 +9902,15 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
   bool set_vptr = false, temp_rhs = false;
   stmtblock_t *pre = block;
   tree class_expr = NULL_TREE;
+  tree from_vptr = NULL_TREE;
 
   /* Create a temporary for complicated expressions.  */
-  if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
-      && rse->expr != NULL_TREE && !DECL_P (rse->expr))
+  if (re->expr_type != EXPR_VARIABLE
+      && re->expr_type != EXPR_NULL
+      && rse->expr != NULL_TREE)
     {
-      if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
+      if (re->ts.type == BT_CLASS
+          && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
 	class_expr = gfc_get_class_from_expr (rse->expr);
 
       if (rse->loop)
@@ -9959,8 +9964,8 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
       /* Get the vptr from the rhs expression only, when it is variable.
 	 Functions are expected to be assigned to a temporary beforehand.  */
       vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
-	  ? gfc_find_and_cut_at_last_class_ref (re)
-	  : NULL;
+		  ? gfc_find_and_cut_at_last_class_ref (re)
+		  : NULL;
       if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
 	{
 	  if (to_len != NULL_TREE)
@@ -10000,6 +10005,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
 		tmp = rse->expr;
 
 	      se.expr = gfc_class_vptr_get (tmp);
+	      from_vptr = se.expr;
 	      if (UNLIMITED_POLY (re))
 		from_len = gfc_class_len_get (tmp);
 
@@ -10021,9 +10027,10 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
 	  gfc_free_expr (vptr_expr);
 	  gfc_add_block_to_block (block, &se.pre);
 	  gcc_assert (se.post.head == NULL_TREE);
+	  from_vptr = se.expr;
 	}
-      gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
-						se.expr));
+      gfc_add_modify (pre, lhs_vptr,
+		      fold_convert (TREE_TYPE (lhs_vptr), se.expr));
 
       if (to_len != NULL_TREE)
 	{
@@ -10049,11 +10056,13 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
 	}
     }
 
-  /* Return the _len trees only, when requested.  */
+  /* Return the _len and _vptr trees only, when requested.  */
   if (to_lenp)
     *to_lenp = to_len;
   if (from_lenp)
     *from_lenp = from_len;
+  if (from_vptrp)
+    *from_vptrp = from_vptr;
   return lhs_vptr;
 }
 
@@ -10120,9 +10129,7 @@ trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
       rse->expr = gfc_class_data_get (rse->expr);
   else
     {
-      expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
-						    expr2, rse,
-						    NULL, NULL);
+      expr1_vptr = trans_class_vptr_len_assignment (block, expr1, expr2, rse);
       gfc_add_block_to_block (block, &rse->pre);
       tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
       gfc_add_modify (&lse->pre, tmp, rse->expr);
@@ -10197,8 +10204,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 
       if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
 	{
-	  trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
-					   NULL);
+	  trans_class_vptr_len_assignment (&block, expr1, expr2, &rse);
 	  lse.expr = gfc_class_data_get (lse.expr);
 	}
 
@@ -10326,8 +10332,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	      strlen_rhs = rse.string_length;
 	      if (expr1->ts.type == BT_CLASS)
 		expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
-							      expr2, &rse,
-							      NULL, NULL);
+							      expr2, &rse);
 	    }
 	}
       else if (expr2->expr_type == EXPR_VARIABLE)
@@ -10343,8 +10348,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	    {
 	      rse.expr = NULL_TREE;
 	      rse.string_length = strlen_rhs;
-	      trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
-					       NULL, NULL);
+	      trans_class_vptr_len_assignment (&block, expr1, expr2, &rse);
 	    }
 
 	  if (remap == NULL)
@@ -10376,8 +10380,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  else
 	    {
 	      expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
-							    expr2, &rse, NULL,
-							    NULL);
+							    expr2, &rse);
 	      gfc_add_block_to_block (&block, &rse.pre);
 	      tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
 	      gfc_add_modify (&lse.pre, tmp, rse.expr);
@@ -11775,7 +11778,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 			gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
 			bool class_realloc)
 {
-  tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
+  tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
   vec<tree, va_gc> *args = NULL;
   bool final_expr;
 
@@ -11799,7 +11802,9 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
     }
 
   vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
-					 &from_len);
+					  &from_len, &rhs_vptr);
+  if (rhs_vptr == NULL_TREE)
+    rhs_vptr = vptr;
 
   /* Generate (re)allocation of the lhs.  */
   if (class_realloc)
@@ -11812,7 +11817,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
       else
 	old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
 
-      size = gfc_vptr_size_get (vptr);
+      size = gfc_vptr_size_get (rhs_vptr);
       tmp = lse->expr;
       class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
 	  ? gfc_class_data_get (tmp) : tmp;
@@ -11826,12 +11831,14 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 
       /* Reallocate if dynamic types are different. */
       gfc_init_block (&re_alloc);
+      tmp = fold_convert (pvoid_type_node, class_han);
       re = build_call_expr_loc (input_location,
 				builtin_decl_explicit (BUILT_IN_REALLOC), 2,
-				fold_convert (pvoid_type_node, class_han),
-				size);
+				tmp, size);
+      re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
+			    re);
       tmp = fold_build2_loc (input_location, NE_EXPR,
-			     logical_type_node, vptr, old_vptr);
+			     logical_type_node, rhs_vptr, old_vptr);
       re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 			    tmp, re, build_empty_stmt (input_location));
       gfc_add_expr_to_block (&re_alloc, re);