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
