https://gcc.gnu.org/g:6e1679ebd5e62dd63ee6c93df2514e0c08a2b674
commit r17-686-g6e1679ebd5e62dd63ee6c93df2514e0c08a2b674 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. 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 5e4529e2a4a4..8acee12e9c23 100644 --- 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 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
