[gcc r16-8493] Fortran: Bugs found while testing r16-8436 [PR124780]

[Paul Thomas]

https://gcc.gnu.org/g:020d4084028bb4a5280094be6b8d90fb3085ad5b

commit r16-8493-g020d4084028bb4a5280094be6b8d90fb3085ad5b
Author: Paul Thomas <pault@gcc.gnu.org>
Date:   Sun Apr 5 10:53:08 2026 +0100

    Fortran: Bugs found while testing r16-8436 [PR124780]
    
    2026-04-07  Paul Thomas  <pault@gcc.gnu.org>
    
    gcc/fortran
            PR fortran/124780
            * resolve.cc (resolve_ordinary_assign): Do not add the class
            data component to an operator expression.
            * trans-expr.cc (gfc_trans_scalar_assign): If class to class
            assignment uses ordinary scalar assignment and neither lhs or
            rhs are class types, do a deep copy for allocatable components.
    
    gcc/testsuite/
            PR fortran/124780
            * gfortran.dg/pr124780.f90: New test.

Diff:
---
 gcc/fortran/resolve.cc                 |  3 ++-
 gcc/fortran/trans-expr.cc              | 27 +++++++++++++++++++++----
 gcc/testsuite/gfortran.dg/pr124780.f90 | 36 ++++++++++++++++++++++++++++++++++
 3 files changed, 61 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 767bbdea1140..638c36595d9c 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -13219,7 +13219,8 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
   /* Assign the 'data' of a class object to a derived type.  */
   if (lhs->ts.type == BT_DERIVED
       && rhs->ts.type == BT_CLASS
-      && rhs->expr_type != EXPR_ARRAY)
+      && (rhs->expr_type != EXPR_ARRAY
+	  && rhs->expr_type != EXPR_OP))
     gfc_add_data_component (rhs);
 
   /* Make sure there is a vtable and, in particular, a _copy for the
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6c0bd5ce9107..3b9a9337984a 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11777,6 +11777,7 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
   stmtblock_t block;
   tree tmp;
   tree cond;
+  int caf_mode;
 
   gfc_init_block (&block);
 
@@ -11865,7 +11866,7 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
 	 same as the lhs.  */
       if (deep_copy)
 	{
-	  int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
+	  caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
 				       | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
 	  tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
 				     caf_mode);
@@ -11892,12 +11893,30 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
 
       if (!trans_scalar_class_assign (&block, lse, rse))
 	{
-	  /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
-	  for the lhs which ensures that class data rhs cast as a string assigns
-	  correctly.  */
+	  /* ..otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
+	  for the lhs which ensures that class data rhs cast as a string
+	  assigns correctly.  */
 	  tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
 				 TREE_TYPE (rse->expr), lse->expr);
 	  gfc_add_modify (&block, tmp, rse->expr);
+
+	  /* Copy allocatable components but guard against class pointer
+	     assign, which arrives here.  */
+#define DATA_DT ts.u.derived->components->ts.u.derived
+	  if (deep_copy
+	      && !(GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+		   && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
+	      && ts.u.derived->components
+	      && DATA_DT && DATA_DT->attr.alloc_comp)
+	    {
+	      caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
+				       | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
+				    : 0;
+	      tmp = gfc_copy_alloc_comp (DATA_DT, rse->expr, lse->expr, 0,
+					 caf_mode);
+	      gfc_add_expr_to_block (&block, tmp);
+	    }
+#undef DATA_DT
 	}
     }
   else if (ts.type != BT_CLASS)
diff --git a/gcc/testsuite/gfortran.dg/pr124780.f90 b/gcc/testsuite/gfortran.dg/pr124780.f90
new file mode 100644
index 000000000000..79245948a549
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr124780.f90
@@ -0,0 +1,36 @@
+! { dg-do run }
+!
+! Test the fix for PR124780, which failes as in comments below.
+!
+! Contributed by Harald Anlauf  <anlauf@gcc.gnu.org>
+!
+program p
+   integer :: i
+   type :: t
+     integer, allocatable :: i(:)
+   end type
+   type (t), allocatable :: src(:), ans(:)
+   src = [t([1,2]), t([3,4])] ! Leaks memory 16 bytes in 2 blocks;
+                              ! familiar from PDT memory leaks :-(
+   ans = f(src)
+   do i = 1,2
+     if (any (src(i)%i /= ans(i)%i)) stop 1
+     deallocate (ans(i)%i, src(i)%i)
+   enddo
+   deallocate (ans, src) 
+contains
+   function f(x) result(z)
+     class(t), intent(inout) :: x(:)
+     type(t)  :: z (size(x))
+     class(t), allocatable :: a(:)
+     class(t), allocatable :: b(:)
+     allocate (a(size(x)))
+     select type (x)
+       type is (t)
+         a = x                                ! Mangled src and caused
+                                              ! double free at line 12
+     end select
+     b = x
+     z = (b)                                  ! ICE, without patch
+   end
+end