https://gcc.gnu.org/g:9bfc496528d5e82e728cf07c9af69386083d252f
commit r15-10380-g9bfc496528d5e82e728cf07c9af69386083d252f Author: Harald Anlauf <[email protected]> Date: Thu Sep 11 20:17:31 2025 +0200 Fortran: fix assignment to allocatable scalar polymorphic component [PR121616] PR fortran/121616 gcc/fortran/ChangeLog: * primary.cc (gfc_variable_attr): Properly set dimension attribute from a component ref. gcc/testsuite/ChangeLog: * gfortran.dg/alloc_comp_assign_17.f90: New test. (cherry picked from commit 0899b826f7196f609fc8991456eb728802061318) Diff: --- gcc/fortran/primary.cc | 2 + gcc/testsuite/gfortran.dg/alloc_comp_assign_17.f90 | 96 ++++++++++++++++++++++ 2 files changed, 98 insertions(+) diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index f0e1fef6812e..9f8df7d2fe84 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -3057,12 +3057,14 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) if (comp->ts.type == BT_CLASS) { + dimension = CLASS_DATA (comp)->attr.dimension; codimension = CLASS_DATA (comp)->attr.codimension; pointer = CLASS_DATA (comp)->attr.class_pointer; allocatable = CLASS_DATA (comp)->attr.allocatable; } else { + dimension = comp->attr.dimension; codimension = comp->attr.codimension; if (expr->ts.type == BT_CLASS && strcmp (comp->name, "_data") == 0) pointer = comp->attr.class_pointer; diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_assign_17.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_assign_17.f90 new file mode 100644 index 000000000000..7a659f2e0c02 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_assign_17.f90 @@ -0,0 +1,96 @@ +! { dg-do run } +! PR fortran/121616 +! +! Test fix for intrinsic assignment to allocatable scalar polymorphic component + +program p + call pr121616 () + call test_ts () +end + +! Derived from original PR (contributed by Jean Vézina) +subroutine pr121616 () + implicit none + integer :: i + type general + class(*), allocatable :: x + end type general + type(general) :: a(4), b(4) + ! Intrinsic assignment to a variable of unlimited polymorphic type + a(1)%x = 1 + a(2)%x = 3.14 + a(3)%x = .true. + a(4)%x = 'abc' + ! The workaround was to use a structure constructor + b(1) = general(1) + b(2) = general(3.14) + b(3) = general(.true.) + b(4) = general('abc') + do i = 1, 4 + if (.not. allocated (a(i)%x)) stop 10+i + if (.not. allocated (b(i)%x)) stop 20+i + call prt (a(i)%x, b(i)%x) + end do + do i = 1, 4 + deallocate (a(i)%x, b(i)%x) + end do +contains + subroutine prt (x, y) + class(*), intent(in) :: x, y + select type (v=>x) + type is (integer) + print *,v + type is (real) + print *,v + type is (logical) + print *,v + type is (character(*)) + print *,v + class default + error stop 99 + end select + if (.not. same_type_as (x, y)) stop 30+i + end subroutine prt +end + +! Contributed by a friend (private communication) +subroutine test_ts () + implicit none + + type :: t_inner + integer :: i + end type + + type :: t_outer + class(t_inner), allocatable :: inner + end type + + class(t_inner), allocatable :: inner + type(t_outer), allocatable :: outer(:) + integer :: i + + allocate(t_inner :: inner) + inner% i = 0 + + !------------------------------------------------ + ! Size of outer must be > 1 for the bug to appear + !------------------------------------------------ + allocate(outer(2)) + + !------------------------------ + ! Loop is necessary for the bug + !------------------------------ + do i = 1, size(outer) + write(*,*) i + !---------------------------------------------------- + ! Expect intrinsic assignment to polymorphic variable + !---------------------------------------------------- + outer(i)% inner = inner + deallocate (outer(i)% inner) + end do + + write(*,*) 'Loop DONE' + deallocate(outer) + deallocate(inner) + write(*,*) 'Dellocation DONE' +end
