Dear all, the attached patch fixes a silent wrong-code issue in the simplification of TRANSFER when derived types with array components were involved, and the constructor had a scalar initialization for the array.
The solution is rather straightforward: just set all elements. Regtested on x86_64-pc-linux-gnu. OK for mainline? Backports (16-branch)? Thanks, Harald
From a15721490ef48230fcb0b2ddb5d57f6c66ea8a0a Mon Sep 17 00:00:00 2001 From: Harald Anlauf <[email protected]> Date: Thu, 29 Oct 2026 22:03:32 +0100 Subject: [PATCH] fortran: Fix simplification of TRANSFER of derived types [PR128042] The simplification of TRANSFER of a derived type containing an array component that was initialized by a scalar constant was mishandled: only the first array element was set in encode_derived, although all elements of that array should be set to the same value. PR fortran/128042 gcc/fortran/ChangeLog: * target-memory.cc (encode_derived): Handle the case where an array component of a derived type is initialized by a scalar. gcc/testsuite/ChangeLog: * gfortran.dg/transfer_simplify_17.f90: New test. --- gcc/fortran/target-memory.cc | 36 +++++ .../gfortran.dg/transfer_simplify_17.f90 | 124 ++++++++++++++++++ 2 files changed, 160 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/transfer_simplify_17.f90 diff --git a/gcc/fortran/target-memory.cc b/gcc/fortran/target-memory.cc index 9bea40f4c94..a4f0080e4b0 100644 --- a/gcc/fortran/target-memory.cc +++ b/gcc/fortran/target-memory.cc @@ -287,6 +287,42 @@ encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size) gcc_assert (size >= 0); memset (&buffer[ptr], 0, size); } + else if (c->expr->rank == 0 && cmp->as && cmp->as->rank) + { + /* Replicate a scalar constant initializer for an array component as + many times as needed. */ + gfc_constructor_base ctor_head = NULL; + gfc_array_spec *as = cmp->as; + gfc_typespec *ts = &c->expr->ts; + HOST_WIDE_INT ctor_size; + mpz_t as_size, cons_size; + gfc_expr *expr; + + spec_size (as, &as_size); + ctor_size = gfc_mpz_get_hwi (as_size); + for (HOST_WIDE_INT k = 0; k < ctor_size; k++) + gfc_constructor_append_expr (&ctor_head, gfc_copy_expr (c->expr), + &gfc_current_locus); + + /* Set up expr as an array constructor. */ + expr = gfc_get_array_expr (ts->type, ts->kind, &c->expr->where); + expr->value.constructor = ctor_head; + expr->rank = as->rank; + expr->shape = gfc_get_shape (as->rank); + for (int i = 0; i < as->rank; ++i) + spec_dimen_size (as, i, &expr->shape[i]); + + /* Validate size of array initializer. */ + if (!gfc_array_size (expr, &cons_size) + || mpz_cmp (cons_size, as_size)) + gfc_error ("Bad size of array initializer at %C"); + mpz_clear (cons_size); + mpz_clear (as_size); + + gfc_target_encode_expr (expr, &buffer[ptr], + buffer_size - ptr); + gfc_free_expr (expr); + } else gfc_target_encode_expr (c->expr, &buffer[ptr], buffer_size - ptr); diff --git a/gcc/testsuite/gfortran.dg/transfer_simplify_17.f90 b/gcc/testsuite/gfortran.dg/transfer_simplify_17.f90 new file mode 100644 index 00000000000..d67b8c7121b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_simplify_17.f90 @@ -0,0 +1,124 @@ +! { dg-do run } +! { dg-additional-options "-Wno-character-truncation" } +! +! PR fortran/128042 - simplification of TRANSFER of derived types + +program pr128042 + implicit none + type tag3 + character(4) :: c3(2) + end type tag3 + type tag2 + type(tag3) :: t3(2) + character(2) :: ch2(3) + end type tag2 + type tag1 + character(3) :: ch1 + type(tag2) :: t2(3) + end type tag1 + + call test1 () + call test2 () + call test3 () + call test4 () + +contains + + ! Non-nested derived type, scalar TRANSFER result + subroutine test1 () + character(*), parameter :: abc(2) = 'opqr' + type(tag3), parameter :: a1 = tag3(['opqr','strv']) + type(tag3), parameter :: a2 = tag3( 'opqr' ) + type(tag3), parameter :: a3 = tag3( abc(1) ) + type(tag3), parameter :: a4 = tag3( abc(:) ) + type(tag3) :: b1 = a1, b2 = a2, b3 = a3, b4 = a4 + + integer, parameter :: m = storage_size (a1) / 8 + character(m), parameter :: u = "" + character(m), parameter :: s1 = transfer (a1, u) + character(m), parameter :: s2 = transfer (a2, u) + character(m), parameter :: s3 = transfer (a3, u) + character(m), parameter :: s4 = transfer (a4, u) + character(m) :: t1, t2, t3, t4 + t1 = transfer (b1, t1) + t2 = transfer (b2, t2) + t3 = transfer (b3, t3) + t4 = transfer (b4, t4) + if (s1 /= t1) stop 1 + if (s2 /= t2) stop 2 + if (s3 /= t3) stop 3 + if (s4 /= t4) stop 4 + if (s2 /= s3) stop 5 + if (s3 /= s4) stop 6 + end subroutine test1 + + ! Non-nested derived type, array TRANSFER result + subroutine test2 () + type(tag3), parameter :: u = tag3( 'opqr' ) + type(tag3) :: v = u + integer, parameter :: m = storage_size (u) / 8 + integer :: j = m + character, dimension(m) :: ww1, ww2, ww3, ww4 + + ww1 = transfer(u,'*',j) ! not simplified (j is variable) + ww2 = transfer(v,'*',j) + ww3 = transfer(v,'*',m) ! not simplified (v is variable) + ww4 = transfer(u,'*',m) ! this was mis-simplified + + if (any (ww1 /= ww2)) stop 11 + if (any (ww1 /= ww3)) stop 12 + if (any (ww1 /= ww4)) stop 13 + end subroutine test2 + + ! Nested derived types, simple case + subroutine test3 () + type(tag2), parameter :: x = tag2(tag3('opqr'),'12') + type(tag2) :: y = x + integer, parameter :: n = storage_size (x) / 8 + integer :: k = n + character, dimension(n) :: zz1, zz2, zz3, zz4 + + zz1 = transfer(x,'*',k) ! not simplified (k is variable) + zz2 = transfer(y,'*',k) + zz3 = transfer(y,'*',n) ! not simplified (y is variable) + zz4 = transfer(x,'*',n) ! this was mis-simplified + + if (any (zz1 /= zz2)) stop 14 + if (any (zz1 /= zz3)) stop 15 + if (any (zz1 /= zz4)) stop 16 + end subroutine test3 + + ! Derived from original test in PR + subroutine test4 () + type(tag1) :: sourceTAG(2) + parameter (sourceTAG = & + (/tag1('abc', & + tag2((/tag3('klmn'),tag3((/'opqr','strv'/))/), & + (/'ef','gh','ij'/))), & + tag1('xyz',tag2(tag3('6789'),'123')) /) ) + + character(10) :: moldCH, rcCH(10), rrCH(10) + parameter (moldCH = ' ') + parameter (rcCH = transfer (sourceTAG,moldCH,10)) + integer :: i + + rrCH = transfer (sourceTAG,moldCH,10) + + do i=1,10 + call checkch(rcCH(i),rrCH(i)) + enddo + + end subroutine test4 + + subroutine checkch(ch,cht) + character(*) ch,cht + if (ch /= cht) then + print *,len(ch),len(cht),len_trim(ch),len_trim(cht) + print *,ch + print *,cht + print *,'??? ng ???' + stop 99 + endif + end subroutine checkch + +end -- 2.51.0
