[gcc r14-12803] Fortran: Fix scalar class to derived select type entities. [PR125263]

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

commit r14-12803-gd57996b84cb21104ef58d5dac9455f34fa5ad818
Author: Paul Thomas <[email protected]>
Date:   Sat May 23 14:58:36 2026 +0100

    Fortran: Fix scalar class to derived select type entities. [PR125263]
    
    2026-05-23  Paul Thomas  <[email protected]>
    
    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.
    
    (cherry picked from commit 6e1679ebd5e62dd63ee6c93df2514e0c08a2b674)

Diff:
---
 gcc/fortran/trans-expr.cc              |  8 +++-
 gcc/testsuite/gfortran.dg/pr125263.f90 | 71 ++++++++++++++++++++++++++++++++++
 2 files changed, 78 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index a984130c2277..7bbd6524e543 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12441,13 +12441,19 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
      needed.  */
   lhs_attr = gfc_expr_attr (expr1);
 
+  /* 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;
 
   realloc_flag = flag_realloc_lhs
diff --git a/gcc/testsuite/gfortran.dg/pr125263.f90 b/gcc/testsuite/gfortran.dg/pr125263.f90
new file mode 100644
index 000000000000..9d8d4d089876
--- /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  <[email protected]>
+!
+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