See the attached patch.
I have been working on this one for a while. After getting the ICE sorted out,
testing with -fsanitize=address showed a leak. To fix the leak I set
must_finalize to 1. This fixed the memory leak. However, I am a bit unclear if
that is the right place to do this.
Regardless, regression tested on x86_64.
OK for mainline?
Regards,
Jerry
---
fortran: [PR89219] ICE with polymorphic function result in
DTIO output list
This fixes several problems with CLASS items in an output list when
the type has a user-defined derived type I/O (DTIO) procedure.
1. A scalar CLASS function result caused an ICE. The I/O code
expects the address of the CLASS object, but a function returns
its result by value. The result is now saved in a temporary and
its address is used. The result was also never finalized or
deallocated, as required by 7.5.6.3 and 9.7.3.2 of the Fortran
2023 standard. An allocatable result, even inside parentheses,
is now finalized and deallocated after it is transferred.
2. get_dtio_proc found the DTIO procedure by walking the I/O list
item back to its last CLASS reference. A function result has no
such reference. The procedure is now looked up in the vtable of
the dynamic type, which gfc_trans_transfer already has.
3. For an assumed-shape or assumed-size CLASS dummy array, the
dynamic type was looked for in the array descriptor, which does
not carry it. The DTIO procedure then saw an object of the
declared type. The dynamic type is now taken from the dummy
argument itself.
4. For an array valued CLASS function result, each element was copied
to a temporary of the declared type before the transfer, which also
lost the dynamic type. The address of the element is now used
directly.
PR fortran/89219
gcc/fortran/ChangeLog:
* trans-io.cc (get_dtio_proc): Add vptr argument. Get the location
from the vtable of the dynamic type.
(transfer_expr): Pass vptr to get_dtio_proc.
(gfc_trans_transfer): Store a scalar CLASS function result in a
temporary and use its address. Mark an allocatable CLASS function
result for finalization. Take the address of a CLASS array element
that is not a variable in place. Obtain the vptr of a scalarized
CLASS array from the CLASS object recorded by the scalarizer.
gcc/testsuite/ChangeLog:
* gfortran.dg/dtio_38.f90: New test.
* gfortran.dg/dtio_39.f90: New test.
---From ec852fee00a0a67b521511b9c8180b4db2784367 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Fri, 9 Oct 2026 09:11:24 -0700
Subject: [PATCH] fortran: [PR89219] ICE with polymorphic function result in
DTIO output list
This fixes several problems with CLASS items in an output list when
the type has a user-defined derived type I/O (DTIO) procedure.
1. A scalar CLASS function result caused an ICE. The I/O code
expects the address of the CLASS object, but a function returns
its result by value. The result is now saved in a temporary and
its address is used. The result was also never finalized or
deallocated, as required by 7.5.6.3 and 9.7.3.2 of the Fortran
2023 standard. An allocatable result, even inside parentheses,
is now finalized and deallocated after it is transferred.
2. get_dtio_proc found the DTIO procedure by walking the I/O list
item back to its last CLASS reference. A function result has no
such reference. The procedure is now looked up in the vtable of
the dynamic type, which gfc_trans_transfer already has.
3. For an assumed-shape or assumed-size CLASS dummy array, the
dynamic type was looked for in the array descriptor, which does
not carry it. The DTIO procedure then saw an object of the
declared type. The dynamic type is now taken from the dummy
argument itself.
4. For an array valued CLASS function result, each element was copied
to a temporary of the declared type before the transfer, which also
lost the dynamic type. The address of the element is now used
directly.
PR fortran/89219
gcc/fortran/ChangeLog:
* trans-io.cc (get_dtio_proc): Add vptr argument. Get the location
from the vtable of the dynamic type.
(transfer_expr): Pass vptr to get_dtio_proc.
(gfc_trans_transfer): Store a scalar CLASS function result in a
temporary and use its address. Mark an allocatable CLASS function
result for finalization. Take the address of a CLASS array element
that is not a variable in place. Obtain the vptr of a scalarized
CLASS array from the CLASS object recorded by the scalarizer.
gcc/testsuite/ChangeLog:
* gfortran.dg/dtio_38.f90: New test.
* gfortran.dg/dtio_39.f90: New test.
---
gcc/fortran/trans-io.cc | 57 +++++++++---
gcc/testsuite/gfortran.dg/dtio_38.f90 | 127 ++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/dtio_39.f90 | 58 ++++++++++++
3 files changed, 228 insertions(+), 14 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/dtio_38.f90
create mode 100644 gcc/testsuite/gfortran.dg/dtio_39.f90
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 48fdaa5e733..8cc57f16659 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2255,7 +2255,8 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where)
that the procedure interface has been checked during resolution. */
static tree
-get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
+get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub,
+ tree vptr)
{
gfc_symbol *derived;
bool formatted = false;
@@ -2275,17 +2276,21 @@ get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
if (ts->type == BT_CLASS && tb_io_st)
{
// polymorphic DTIO call (based on the dynamic type)
- gfc_se se;
- gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1);
- gfc_add_vptr_component (expr);
- gfc_add_component_ref (expr,
- tb_io_st->n.tb->u.generic->specific_st->name);
+ tree name, vtab, field;
+
*dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym;
- gfc_init_se (&se, NULL);
- se.want_pointer = 1;
- gfc_conv_expr (&se, expr);
- gfc_free_expr (expr);
- return se.expr;
+
+ /* Get the location from the vtable of the dynamic type. */
+ gcc_assert (vptr != NULL_TREE);
+ name = get_identifier (tb_io_st->n.tb->u.generic->specific_st->name);
+ vtab = build_fold_indirect_ref_loc (input_location, vptr);
+ for (field = TYPE_FIELDS (TREE_TYPE (vtab)); field;
+ field = DECL_CHAIN (field))
+ if (DECL_NAME (field) == name)
+ break;
+ gcc_assert (field);
+ return fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field), vtab, field, NULL_TREE);
}
else
{
@@ -2463,7 +2468,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
derived = ts->u.derived->components->ts.u.derived;
if (derived->attr.has_dtio_procs)
- arg2 = get_dtio_proc (ts, code, &dtio_sub);
+ arg2 = get_dtio_proc (ts, code, &dtio_sub, vptr);
if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
{
@@ -2620,8 +2625,23 @@ gfc_trans_transfer (gfc_code * code)
/* Transfer a scalar value. */
if (expr->ts.type == BT_CLASS)
{
+ gfc_expr *e = expr;
+
+ /* Mark an allocatable function result to be finalized
+ after the transfer. */
+ while (e->expr_type == EXPR_OP
+ && e->value.op.op == INTRINSIC_PARENTHESES)
+ e = e->value.op.op1;
+ if (gfc_is_alloc_class_scalar_function (e))
+ e->must_finalize = 1;
+
se.want_pointer = 1;
gfc_conv_expr (&se, expr);
+
+ /* A function result is returned by value. */
+ if (!POINTER_TYPE_P (TREE_TYPE (se.expr)))
+ se.expr = gfc_build_addr_expr (NULL_TREE,
+ gfc_evaluate_now (se.expr, &se.pre));
vptr = gfc_get_vptr_from_expr (se.expr);
}
else
@@ -2731,10 +2751,19 @@ scalarize:
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
- gfc_conv_expr_reference (&se, expr);
+ /* Pass the address of the class element itself. */
+ if (expr->ts.type == BT_CLASS && expr->expr_type != EXPR_VARIABLE)
+ {
+ gfc_conv_expr (&se, expr);
+ se.expr = gfc_build_addr_expr (NULL_TREE, se.expr);
+ }
+ else
+ gfc_conv_expr_reference (&se, expr);
if (expr->ts.type == BT_CLASS)
- vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
+ vptr = gfc_get_vptr_from_expr (ss->info->class_container
+ ? ss->info->class_container
+ : ss->info->data.array.descriptor);
else
vptr = NULL_TREE;
transfer_expr (&se, &expr->ts, se.expr, code, vptr);
diff --git a/gcc/testsuite/gfortran.dg/dtio_38.f90 b/gcc/testsuite/gfortran.dg/dtio_38.f90
new file mode 100644
index 00000000000..0b6666b4445
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dtio_38.f90
@@ -0,0 +1,127 @@
+! { dg-do run }
+!
+! PR fortran/89219
+!
+! Test the fix for PR89219, in which a polymorphic function result in an
+! output list with user defined derived type i/o caused an ICE.
+!
+module m
+ implicit none
+
+ type :: parent
+ contains
+ procedure :: to_string
+ procedure :: wio
+ generic :: write(formatted) => wio
+ end type
+
+ type, extends(parent) :: child
+ integer :: i = 0
+ contains
+ procedure :: to_string => to_string_child
+ end type
+
+ type :: holder
+ class(parent), pointer :: p => null()
+ contains
+ procedure :: get
+ end type
+
+ integer :: ncalls = 0
+
+contains
+
+ function to_string (this) result (str)
+ class(parent), intent(in) :: this
+ character(8) :: str
+ str = "parent"
+ end function
+
+ function to_string_child (this) result (str)
+ class(child), intent(in) :: this
+ character(8) :: str
+ write (str, '(a,i0)') "child", this%i
+ end function
+
+ subroutine wio (this, unit, iotype, v_list, iostat, iomsg)
+ class(parent), intent(in) :: this
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: v_list(:)
+ integer, intent(out) :: iostat
+ character(*), intent(inout) :: iomsg
+ write (unit, '(a)', iostat = iostat, iomsg = iomsg) trim (this%to_string ())
+ end subroutine
+
+ function get (this) result (p)
+ class(holder), intent(in) :: this
+ class(parent), pointer :: p
+ ncalls = ncalls + 1
+ p => this%p
+ end function
+
+ function alloc_result (i) result (r)
+ integer, intent(in) :: i
+ class(parent), allocatable :: r
+ allocate (r, source = child (i))
+ end function
+
+ function alloc_array () result (r)
+ class(parent), allocatable :: r(:)
+ allocate (r(2), source = [child (1), child (2)])
+ end function
+
+ subroutine write_dummy (a, buffer)
+ class(parent), intent(in) :: a(:)
+ character(*), intent(out) :: buffer
+ write (buffer, '(2dt)') a
+ end subroutine
+
+end module
+
+program main
+ use m
+ implicit none
+
+ type(holder) :: h
+ class(parent), pointer :: p
+ class(parent), allocatable :: arr(:)
+ character(32) :: buffer
+
+ allocate (h%p, source = child (42))
+
+! The pointer assignment worked before the fix.
+ p => h%get ()
+ write (buffer, '(dt)') p
+ if (trim (buffer) /= "child42") stop 1
+
+! A polymorphic function result used to ICE.
+ write (buffer, '(dt)') h%get ()
+ if (trim (buffer) /= "child42") stop 2
+
+! The function must be evaluated exactly once.
+ if (ncalls /= 2) stop 3
+
+! Likewise for an allocatable result.
+ write (buffer, '(dt)') alloc_result (7)
+ if (trim (buffer) /= "child7") stop 4
+
+! List directed output takes the same path.
+ write (buffer, *) h%get ()
+ if (trim (adjustl (buffer)) /= "child42") stop 5
+
+! A parenthesized function result.
+ write (buffer, '(dt)') (h%get ())
+ if (trim (buffer) /= "child42") stop 6
+
+! An array valued result must keep the dynamic type of its elements.
+ write (buffer, '(2dt)') alloc_array ()
+ if (trim (buffer) /= "child1child2") stop 7
+
+! Likewise for an assumed-shape dummy.
+ allocate (arr(2), source = [child (3), child (4)])
+ call write_dummy (arr, buffer)
+ if (trim (buffer) /= "child3child4") stop 8
+
+ deallocate (h%p)
+end program
diff --git a/gcc/testsuite/gfortran.dg/dtio_39.f90 b/gcc/testsuite/gfortran.dg/dtio_39.f90
new file mode 100644
index 00000000000..a3a375a37f4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dtio_39.f90
@@ -0,0 +1,58 @@
+! { dg-do run }
+!
+! PR fortran/89219
+!
+! Check that an allocatable polymorphic function result in an output list
+! is finalized once after the transfer.
+!
+module m
+ implicit none
+ integer :: nfinal = 0
+
+ type :: t
+ integer :: i = 0
+ contains
+ procedure :: wio
+ generic :: write(formatted) => wio
+ final :: done
+ end type
+
+contains
+
+ subroutine done (this)
+ type(t), intent(inout) :: this
+ nfinal = nfinal + 1
+ end subroutine
+
+ subroutine wio (this, unit, iotype, v_list, iostat, iomsg)
+ class(t), intent(in) :: this
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: v_list(:)
+ integer, intent(out) :: iostat
+ character(*), intent(inout) :: iomsg
+ write (unit, '(a,i0)', iostat = iostat, iomsg = iomsg) "t", this%i
+ end subroutine
+
+ function mk (i) result (r)
+ integer, intent(in) :: i
+ class(t), allocatable :: r
+ allocate (r)
+ r%i = i
+ end function
+
+end module
+
+program main
+ use m
+ implicit none
+ character(16) :: buffer
+
+ write (buffer, '(dt)') mk (5)
+ if (trim (buffer) /= "t5") stop 1
+ if (nfinal /= 1) stop 2
+
+ write (buffer, '(dt)') (mk (6))
+ if (trim (buffer) /= "t6") stop 3
+ if (nfinal /= 2) stop 4
+end program
--
2.56.0
