[gcc r17-3385] ortran: Fix data corruption with allocation from ctr source [P121683]

https://gcc.gnu.org/g:ad78f61449bc9ef1d585e69ff48c46574f9a9382

commit r17-3385-gad78f61449bc9ef1d585e69ff48c46574f9a9382
Author: Paul Thomas <[email protected]>
Date:   Thu Aug 13 16:00:15 2026 +0100

    ortran: Fix data corruption with allocation from ctr source [P121683]
    
    2026-08-13  Paul Thomas  <[email protected]>
    
    gcc/fortran
            PR fortran/121683
            * trans-expr.cc (gfc_trans_subcomponent_assign): For derived
            type expressions assigned to a class or derived type component
            copy allocatable components if necessary. Likewise, for a class
            expression assigned to a scalar class component, allocate the
            component and use the vptr copy.
    
    gcc/testsuite/
            PR fortran/121683
            * gfortran.dg/structure_constructor_18.f90: New test

Diff:
---
 gcc/fortran/trans-expr.cc                          |  69 +++++++++++++-
 .../gfortran.dg/structure_constructor_18.f90       | 102 +++++++++++++++++++++
 2 files changed, 169 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 51bb943f9ff2..1c95f1ce2c42 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -10238,6 +10238,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
 	       && expr->ts.type != BT_CLASS)))
     {
       tree size;
+      tree tmp2;
 
       gfc_init_se (&se, NULL);
       gfc_conv_expr (&se, expr);
@@ -10299,6 +10300,17 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
 	  gfc_add_expr_to_block (&block,
 				 gfc_build_memcpy_call (tmp, se.expr, size));
 
+	  if (expr->ts.type == BT_DERIVED
+	      && expr->ts.u.derived->attr.alloc_comp
+	      && expr->expr_type != EXPR_NULL)
+	    {
+	      tmp2 = gfc_class_data_get (dest);
+	      tmp2 = gfc_copy_alloc_comp (expr->ts.u.derived, tmp2,
+					  gfc_class_data_get (dest),
+					  expr->rank, 0);
+	      gfc_add_expr_to_block (&block, tmp2);
+	    }
+
 	  /* Fill the unlimited polymorphic _len field.  */
 	  if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
 	    {
@@ -10309,8 +10321,20 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
 	    }
 	}
       else
-	gfc_add_modify (&block, tmp,
-			fold_convert (TREE_TYPE (tmp), se.expr));
+	{
+	  gfc_add_modify (&block, tmp,
+			  fold_convert (TREE_TYPE (tmp), se.expr));
+	  if (expr->ts.type == BT_DERIVED
+	      && expr->ts.u.derived->attr.alloc_comp
+	      && expr->expr_type != EXPR_NULL)
+	    {
+	      tmp2 = build_fold_indirect_ref_loc (input_location, dest);
+	      tmp2 = gfc_copy_alloc_comp (cm->ts.u.derived, tmp2,
+					  se.expr, expr->rank, 0);
+	      gfc_add_expr_to_block (&block, tmp2);
+	    }
+	}
+
       gfc_add_block_to_block (&block, &se.post);
     }
   else if (expr->ts.type == BT_UNION)
@@ -10410,6 +10434,47 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
 	  gfc_add_expr_to_block (&block, tmp);
 	}
     }
+  else if (cm->ts.type == BT_CLASS
+	   && !CLASS_DATA (cm)->as
+	   && expr->ts.type == BT_CLASS)
+    {
+      tree vptr1, vptr2;
+      tree data1, data2;
+      tree size, fcn;
+
+      gfc_init_se (&se, NULL);
+
+      gfc_conv_expr (&se, expr);
+
+      /* Copy the _vptr to the destination....  */
+      vptr1 = gfc_class_vptr_get (dest);
+      vptr2 = gfc_class_vptr_get (se.expr);
+      gfc_add_modify (&block, vptr1,
+		      fold_convert (TREE_TYPE (vptr1), vptr2));
+
+      /* ....and the _len field if necessary.  */
+      size = gfc_vptr_size_get (vptr2);
+      if (UNLIMITED_POLY (cm) && UNLIMITED_POLY (expr))
+	{
+	  gfc_add_modify (&block, gfc_class_len_get (dest),
+			  gfc_class_len_get (se.expr));
+	  size = gfc_resize_class_size_with_len (&block, se.expr, size);
+	}
+
+      /* Allocate the destination data.  */
+      data1 = gfc_class_data_get (dest);
+      data2 = gfc_class_data_get (se.expr);
+      tmp = gfc_call_malloc (&block, TREE_TYPE (data1), size);
+      gfc_add_modify (&block, data1, tmp);
+
+      /* Now call the copy function. */
+      fcn = gfc_vptr_copy_get (vptr2);
+      if (POINTER_TYPE_P (TREE_TYPE (fcn)))
+	fcn = build_fold_indirect_ref_loc (input_location, fcn);
+      tmp = build_call_expr_loc (input_location, fcn, 2,
+				 data2, data1);
+      gfc_add_expr_to_block (&block, tmp);
+    }
   else if (!cm->attr.artificial)
     {
       /* Scalar component (excluding deferred parameters).  */
diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_18.f90 b/gcc/testsuite/gfortran.dg/structure_constructor_18.f90
new file mode 100644
index 000000000000..08b12c83ab63
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/structure_constructor_18.f90
@@ -0,0 +1,102 @@
+! { dg-do run }
+!
+! Test the fix for PR121683 and a variant from Jerry Delisle. Explicit
+! deallocations were added, when both original and variant were stand
+! alone programs.
+!
+! Contributed by Neil Carlson  <[email protected]>
+!            and Jerry Delisle  <[email protected]>
+!
+module mod
+  implicit none
+  type, abstract :: func
+  end type
+  type, extends(func) :: poly
+    real, allocatable :: array(:)
+  end type
+  type, extends(func) :: func_deriv
+    class(func), allocatable :: f
+  end type
+
+contains
+
+  subroutine alloc_deriv(f, df)
+    class(func), intent(in) :: f
+    class(func), allocatable, intent(out) :: df
+    allocate(df, source=func_deriv(f)) ! THIS CORRUPTS F
+  end subroutine
+
+end module
+
+program fubar
+  call original
+  call variant
+contains
+
+  subroutine original
+    use mod
+    type(poly), allocatable :: p
+    class(func), allocatable :: f, df
+    real :: array(2) = [1, 2]
+    allocate(p)
+    p%array = array
+    call move_alloc(p, f)
+    call alloc_deriv(f, df)
+    if (.not.allocated(f)) stop 1
+    select type (f)
+      type is (poly)
+        if (.not.allocated(f%array)) stop 2 ! SANITIZER: HEAP-USE-AFTER-FREE
+        if (size(f%array) /= size(array)) stop 3
+        if (any(f%array /= array)) stop 4   ! SEGFAULTS HERE WITHOUT SANITIZER
+      class default
+        stop 5
+    end select
+    deallocate (f)
+    select type (df)                        ! Verify that df is OK
+      type is (func_deriv)
+      if (.not.allocated(df%f)) stop 6
+      select type (f => df%f)
+        type is (poly)
+          if (.not.allocated(f%array)) stop 7
+          if (size(f%array) /= size(array)) stop 8
+          if (any(f%array /= array)) stop 9
+        class default
+          stop 10
+        end select
+      class default
+        stop 11
+    end select
+    deallocate (df)
+  end
+
+  subroutine variant
+    type :: base
+      integer :: i = 1
+    end type
+    type, extends(base) :: t1
+      integer, allocatable :: array(:)
+    end type
+    type(t1) :: x
+    type :: t2
+      class(base), allocatable :: b
+    end type
+    type(t2), allocatable :: y
+    type :: t3
+      type(t1), allocatable :: b
+    end type
+    type(t3), allocatable :: z
+    type :: t4
+      type(t1) :: b
+    end type
+    type(t4), allocatable :: z2
+
+    x%array = [1,2]
+    allocate(y, source = t2(x))             ! This was the original problem...
+    if (any (x%array /= [1,2])) stop 12     ! ... x%array was overwritten
+    allocate(z, source = t3(x))
+    if (any (x%array /= [1,2])) stop 13     !    -ditto-
+    allocate(z2, source = t4(x))
+    if (any (x%array /= [1,2])) stop 14     ! Was already OK
+    deallocate (x%array, y, z, z2%b%array)
+  end
+end ! Valgrind shows "     in use at exit: 0 bytes in 0 blocks"