From 707024b2e8d74c4a810ba7d2bda5ecd6556d2140 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Sun, 18 Dec 2016 14:22:13 +0100 Subject: [PATCH] re PR fortran/78848 ([OOP] ICE on writing CLASS variable with non-typebound DTIO procedure) 2016-12-18 Janus Weil PR fortran/78848 * trans-io.c (get_dtio_proc): Generate non-typebound DTIO call for class variables, if no typebound DTIO procedure is available. 2016-12-18 Janus Weil PR fortran/78848 * gfortran.dg/dtio_22.f90: New test. From-SVN: r243784 --- gcc/fortran/ChangeLog | 6 ++++ gcc/fortran/trans-io.c | 50 +++++++++++++-------------- gcc/testsuite/ChangeLog | 5 +++ gcc/testsuite/gfortran.dg/dtio_22.f90 | 33 ++++++++++++++++++ 4 files changed, 68 insertions(+), 26 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dtio_22.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 693d51fd5ba..d718a3fbbaf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2016-12-18 Janus Weil + + PR fortran/78848 + * trans-io.c (get_dtio_proc): Generate non-typebound DTIO call for class + variables, if no typebound DTIO procedure is available. + 2016-12-18 Janus Weil PR fortran/78592 diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index b60685ee157..5f9c1919685 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -2180,41 +2180,39 @@ get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub) formatted = true; } - if (ts->type == BT_DERIVED) + if (ts->type == BT_CLASS) + derived = ts->u.derived->components->ts.u.derived; + else + derived = ts->u.derived; + + gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived, + last_dt == WRITE, formatted); + 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); + *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; + } + else { - derived = ts->u.derived; + // non-polymorphic DTIO call (based on the declared type) *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE, formatted); if (*dtio_sub) return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub)); } - else if (ts->type == BT_CLASS) - { - gfc_symtree *tb_io_st; - - derived = ts->u.derived->components->ts.u.derived; - tb_io_st = gfc_find_typebound_dtio_proc (derived, - last_dt == WRITE, formatted); - if (tb_io_st) - { - 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); - *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; - } - } - return NULL_TREE; - } /* Generate the call for a scalar transfer node. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6583316bbf4..7b91b7b86b0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-12-18 Janus Weil + + PR fortran/78848 + * gfortran.dg/dtio_22.f90: New test. + 2016-12-18 Janus Weil PR fortran/78592 diff --git a/gcc/testsuite/gfortran.dg/dtio_22.f90 b/gcc/testsuite/gfortran.dg/dtio_22.f90 new file mode 100644 index 00000000000..f39450cbca2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_22.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR 78848: [OOP] ICE on writing CLASS variable with non-typebound DTIO procedure +! +! Contributed by Mikael Morin + +module m + type :: t + integer :: i = 123 + end type + interface write(formatted) + procedure wf + end interface +contains + subroutine wf(this, unit, b, c, iostat, iomsg) + class(t), intent(in) :: this + integer, intent(in) :: unit + character, intent(in) :: b + integer, intent(in) :: c(:) + integer, intent(out) :: iostat + character, intent(inout) :: iomsg + write (unit, "(i3)", IOSTAT=iostat, IOMSG=iomsg) this%i + end subroutine +end + +program p + use m + character(3) :: buffer + class(t), allocatable :: z + allocate(z) + write(buffer,"(DT)") z + if (buffer /= "123") call abort() +end -- 2.30.2