Fortran: Fix scalar class to derived select type entities. [PR125263]

2026-05-23  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/125263
	* trans-expr.cc (gfc_trans_assignment_1): Pass scalar class to
	derived type assignment expressions to gfc_trans_scalar_assign.

gcc/testsuite/
	PR fortran/125263
	* gfortran.dg/pr125263.f90: New test.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 5e4529e2a4a48b38966391af5a27a7fdb0949291..8acee12e9c23e2c33e21ebf2e442c274f5cd381e 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -13273,13 +13273,19 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
        && !CLASS_DATA (expr2)->attr.class_pointer
        && !CLASS_DATA (expr2)->attr.allocatable);
 
+  /* What can be sent to trans_class_assignment includes all the obvious
+     candidates but scalar assignment of a class expression to a derived type
+     must be done using gfc_trans_scalar_assign; partly because it is simpler
+     and partly because some cases fail, eg. class assignment to derived_type
+     select type temporaries.  */
   is_poly_assign
     = (use_vptr_copy
        || ((lhs_attr.pointer || lhs_attr.allocatable) && !lhs_attr.dimension))
       && (expr1->ts.type == BT_CLASS || gfc_is_class_array_ref (expr1, NULL)
          || gfc_is_class_scalar_expr (expr1)
          || gfc_is_class_array_ref (expr2, NULL)
-         || gfc_is_class_scalar_expr (expr2))
+         || (gfc_is_class_scalar_expr (expr2)
+             && !(expr1->ts.type == BT_DERIVED && !lhs_attr.dimension)))
       && lhs_attr.flavor != FL_PROCEDURE;
 
   assoc_assign = is_assoc_assign (expr1, expr2);

diff --git a/gcc/testsuite/gfortran.dg/pr125263.f90 b/gcc/testsuite/gfortran.dg/pr125263.f90
new file mode 100644 (file)
index 0000000..9d8d4d0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr125263.f90
@@ -0,0 +1,71 @@
+! { dg-do run }
+!
+! Test the fix for pr125263, in which the selector expressions were not
+! correctly set after the first two ASSOCIATE constructs below.
+!
+! Conributed by Bastiaan Braams  <b.j.braams@cwi.nl>
+!
+program Main
+  implicit none (type, external)
+  type :: Foo_Type
+     integer, allocatable :: x(:)
+  end type Foo_Type
+  class (Foo_Type), allocatable :: fv(:), f, g
+  integer :: nx = 2, nf = 3, i
+
+  ! Create fv(:) with all component vectors initialized to 0.
+  allocate (Foo_Type::fv(0:nf-1))
+  do i = 0, nf-1
+     allocate (fv(i)%x(0:nx-1))
+     fv(i)%x(:) = 0
+  end do
+
+  ! Create f with f%x(:) equal to 1 and g with g%x(:) equal to 2.
+  allocate (Foo_Type::f, g)
+  allocate (f%x(0:nx-1),g%x(0:nx-1))
+  f%x(:) = 1
+  g%x(:) = 2
+
+  ! Use intrinsic assignment to copy f to fv(0).
+  associate (ft => fv(0))
+    select type (ft => fv(0))
+    type is (Foo_Type)
+       ft = f
+       ft%x = [2,3,4]
+    class default
+       error stop 'select type (ft): type error'
+    end select
+  end associate
+
+  ! Verify the copy on the element x(0) and that f is not overwritten.
+  if (any (fv(0)%x /= [2,3,4])) stop 1
+  if (any (f%x /= [1,1])) stop 2
+
+  ! All scalar selector-exprs have the same problem, not just array elements.
+  f%x(:) = 1
+  associate (ft => g)
+    select type (ft)
+    type is (Foo_Type)
+       ft = f
+       ft%x = [4,5,6]
+    class default
+       error stop 'select type (ft): type error'
+    end select
+  end associate
+  ! Verify the copy on g and that f is not overwritten.
+  if (any (g%x /= [4,5,6])) stop 3
+  if (any (f%x /= [1,1])) stop 4
+
+  ! Assignment to an element of an array associate name was OK.
+  fv(0)%x(:) = [0,0,0]
+  select type (ft => fv)
+  type is (Foo_Type)
+    ft = f
+    ft(0)%x = [2,3,4]
+  class default
+    error stop 'select type (ft): type error'
+  end select
+  if (any (fv(0)%x /= [2,3,4])) stop 5
+  if (any (f%x /= [1,1])) stop 6
+
+end program Main