Dear all,
here's a - once found - seemingly simple and obvious fix for a memory
corruption happening when intrinsic assignment is used to set a scalar
allocatable polymorphic component of a derived type when the latter
is instanciated as an array of rank > 0. Just get the dimension
attribute right when using gfc_variable_attr ...
The testcase is an extended version of the reporter's with unlimited
polymorphism, including another simpler one contributed by a friend.
Without the fix, both tests crash with memory corruption of various
kinds.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
If there are no objections, I would like to backport to at least
15-branch.
Thanks,
Harald
From 0899b826f7196f609fc8991456eb728802061318 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Thu, 11 Sep 2025 20:17:31 +0200
Subject: [PATCH] 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.
---
gcc/fortran/primary.cc | 2 +
.../gfortran.dg/alloc_comp_assign_17.f90 | 96 +++++++++++++++++++
2 files changed, 98 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_assign_17.f90
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 6df95558bb1..2cb930d83b8 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 00000000000..7a659f2e0c0
--- /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
--
2.51.0
