On Tue, 19 May 2026 at 07:17, Paul Richard Thomas
<[email protected]> wrote:
>
> Hello All,
>
> This PR has been fixed using Natural Stupidity, as evidenced by the
> earlier version of the fix posted on the PR.
>
> The patch is so simple that it doesn't warrant any more commentary.
> Suffice it to say that gfc_conv_expr provides the expressions for
> gfc_trans_scalar_assign to do its thing, thereby handling deep copies
> and all that.
>
> Regression tested on Fedora 43/x86_64. OK for mainline and later backporting?
>
> Paul
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 2f14e8c3f6c..4cbbd662670 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -13271,13 +13271,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
index 00000000000..9d8d4d08987
--- /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
