[Patch, fortran] PR121683 - Data corruption with sourced allocation from constructor

From 3b8aca292f08b11f7776ae08f954f2c546616f95 Mon Sep 17 00:00:00 2001
From: Paul Thomas <[email protected]>
Date: Thu, 13 Aug 2026 16:00:15 +0100
Subject: [PATCH] ortran: Fix data corruption with allocation from ctr source
 [P121683]

2026-08-13  Paul Thomas  <[email protected]>

gcc/fortran
	PR fortran/110626
	* 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/110626
	* gfortran.dg/pr11026.f90: structure_constructor_18.f90.
---
 gcc/fortran/trans-expr.cc                     |  69 +++++++++++-
 .../gfortran.dg/structure_constructor_18.f90  | 102 ++++++++++++++++++
 2 files changed, 169 insertions(+), 2 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/structure_constructor_18.f90

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 33b7838f74a..a5fcd26aff4 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -10184,6 +10184,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);
@@ -10245,6 +10246,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)
 	    {
@@ -10255,8 +10267,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)
@@ -10356,6 +10380,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 00000000000..08b12c83ab6
--- /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"
-- 
2.55.0