From cf474530613eaaa4d28534a5a53ef61fcc71180d Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Tue, 28 Mar 2017 19:01:05 +0200 Subject: [PATCH] re PR fortran/78661 ([OOP] Namelist output missing object designator under DTIO) 2017-03-28 Janus Weil PR fortran/78661 * trans-io.c (transfer_namelist_element): Perform a polymorphic call to a DTIO procedure if necessary. 2017-03-28 Janus Weil PR fortran/78661 * gfortran.dg/dtio_25.f90: Modified test case. * gfortran.dg/dtio_27.f90: New test case. 2017-03-28 Janus Weil PR fortran/78661 * io/write.c (nml_write_obj): Build a class container only if necessary. From-SVN: r246546 --- gcc/fortran/ChangeLog | 6 +++ gcc/fortran/trans-io.c | 59 ++++++++++++++++++------ gcc/testsuite/ChangeLog | 6 +++ gcc/testsuite/gfortran.dg/dtio_25.f90 | 22 +++++++-- gcc/testsuite/gfortran.dg/dtio_27.f90 | 65 +++++++++++++++++++++++++++ libgfortran/ChangeLog | 5 +++ libgfortran/io/write.c | 28 +++++++----- 7 files changed, 164 insertions(+), 27 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dtio_27.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 20ad8578bfa..7528f37a020 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2017-03-28 Janus Weil + + PR fortran/78661 + * trans-io.c (transfer_namelist_element): Perform a polymorphic call + to a DTIO procedure if necessary. + 2017-03-25 Paul Thomas PR fortran/80156 diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 36e84be83c1..1b70136f493 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -1701,22 +1701,53 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, /* Check if the derived type has a specific DTIO for the mode. Note that although namelist io is forbidden to have a format list, the specific subroutine is of the formatted kind. */ - if (ts->type == BT_DERIVED) + if (ts->type == BT_DERIVED || ts->type == BT_CLASS) { - gfc_symbol *dtio_sub = NULL; - gfc_symbol *vtab; - dtio_sub = gfc_find_specific_dtio_proc (ts->u.derived, - last_dt == WRITE, - true); - if (dtio_sub != NULL) + gfc_symbol *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, true); + + if (ts->type == BT_CLASS && tb_io_st) + { + // polymorphic DTIO call (based on the dynamic type) + gfc_se se; + gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name); + // build vtable expr + gfc_expr *expr = gfc_get_variable_expr (st); + gfc_add_vptr_component (expr); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, expr); + vtable = se.expr; + // build dtio expr + gfc_add_component_ref (expr, + tb_io_st->n.tb->u.generic->specific_st->name); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, expr); + gfc_free_expr (expr); + dtio_proc = se.expr; + } + else { - dtio_proc = gfc_get_symbol_decl (dtio_sub); - dtio_proc = gfc_build_addr_expr (NULL, dtio_proc); - vtab = gfc_find_derived_vtab (ts->u.derived); - vtable = vtab->backend_decl; - if (vtable == NULL_TREE) - vtable = gfc_get_symbol_decl (vtab); - vtable = gfc_build_addr_expr (pvoid_type_node, vtable); + // non-polymorphic DTIO call (based on the declared type) + gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived, + last_dt == WRITE, true); + if (dtio_sub != NULL) + { + dtio_proc = gfc_get_symbol_decl (dtio_sub); + dtio_proc = gfc_build_addr_expr (NULL, dtio_proc); + gfc_symbol *vtab = gfc_find_derived_vtab (derived); + vtable = vtab->backend_decl; + if (vtable == NULL_TREE) + vtable = gfc_get_symbol_decl (vtab); + vtable = gfc_build_addr_expr (pvoid_type_node, vtable); + } } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a3bdf1c8611..c7c82a3e39d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2017-03-28 Janus Weil + + PR fortran/78661 + * gfortran.dg/dtio_25.f90: Modified test case. + * gfortran.dg/dtio_27.f90: New test case. + 2017-03-28 Uros Bizjak PR target/53383 diff --git a/gcc/testsuite/gfortran.dg/dtio_25.f90 b/gcc/testsuite/gfortran.dg/dtio_25.f90 index fc049cd3e37..6e66a3121fe 100644 --- a/gcc/testsuite/gfortran.dg/dtio_25.f90 +++ b/gcc/testsuite/gfortran.dg/dtio_25.f90 @@ -8,6 +8,8 @@ module m contains procedure :: write_formatted generic :: write(formatted) => write_formatted + procedure :: read_formatted + generic :: read(formatted) => read_formatted end type contains subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) @@ -18,11 +20,26 @@ contains integer, intent(out) :: iostat character(*), intent(inout) :: iomsg if (iotype.eq."NAMELIST") then - write (unit, '(a,a,a,a,i5)') 'x%c="',dtv%c,'",','x%k=', dtv%k + write (unit, '(a3,a1,i3)') dtv%c,',', dtv%k else write (unit,*) dtv%c, dtv%k end if end subroutine + subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + character :: comma + if (iotype.eq."NAMELIST") then + read (unit, '(a4,a1,i3)') dtv%c, comma, dtv%k ! FIXME: need a4 here, with a3 above + else + read (unit,*) dtv%c, comma, dtv%k + end if + if (comma /= ',') call abort() + end subroutine end module program p @@ -33,9 +50,8 @@ program p namelist /nml/ x x = t('a', 5) write (buffer, nml) - if (buffer.ne.'&NML x%c="a",x%k= 5 /') call abort + if (buffer.ne.'&NML X= a, 5 /') call abort x = t('x', 0) read (buffer, nml) if (x%c.ne.'a'.or. x%k.ne.5) call abort end - diff --git a/gcc/testsuite/gfortran.dg/dtio_27.f90 b/gcc/testsuite/gfortran.dg/dtio_27.f90 new file mode 100644 index 00000000000..b8b6bad98f5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_27.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! PR 78661: [OOP] Namelist output missing object designator under DTIO +! +! Contributed by Ian Harvey + +MODULE m + IMPLICIT NONE + TYPE :: t + CHARACTER :: c + CONTAINS + PROCEDURE :: write_formatted + GENERIC :: WRITE(FORMATTED) => write_formatted + PROCEDURE :: read_formatted + GENERIC :: READ(FORMATTED) => read_formatted + END TYPE +CONTAINS + SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + CLASS(t), INTENT(IN) :: dtv + 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) dtv%c + END SUBROUTINE + SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + CLASS(t), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER(*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER(*), INTENT(INOUT) :: iomsg + READ (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) dtv%c + END SUBROUTINE +END MODULE + + +PROGRAM p + + USE m + IMPLICIT NONE + character(len=4), dimension(3) :: buffer + call test_type + call test_class + +contains + + subroutine test_type + type(t) :: x + namelist /n1/ x + x = t('a') + write (buffer, n1) + if (buffer(2) /= " X=a") call abort() + end subroutine + + subroutine test_class + class(t), allocatable :: y + namelist /n2/ y + y = t('b') + write (buffer, n2) + if (buffer(2) /= " Y=b") call abort() + end subroutine + +END diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index d585b214833..13fe6bbeb44 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,8 @@ +2017-03-28 Janus Weil + + PR fortran/78661 + * io/write.c (nml_write_obj): Build a class container only if necessary. + 2017-03-27 Dominique d'Humieres * io/list_read.c: Insert /* Fall through. */ in the macro diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index f03929e49f8..af46fe8e623 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -2075,7 +2075,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, /* Write namelist variable names in upper case. If a derived type, nothing is output. If a component, base and base_name are set. */ - if (obj->type != BT_DERIVED) + if (obj->type != BT_DERIVED || obj->dtio_sub != NULL) { namelist_write_newline (dtp); write_character (dtp, " ", 1, 1, NODELIM); @@ -2227,15 +2227,10 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, int noiostat; int *child_iostat = NULL; gfc_array_i4 vlist; - gfc_class list_obj; formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub; GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); - list_obj.data = p; - list_obj.vptr = obj->vtable; - list_obj.len = 0; - /* Set iostat, intent(out). */ noiostat = 0; child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? @@ -2252,7 +2247,6 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, child_iomsg = tmp_iomsg; child_iomsg_len = IOMSG_LEN; } - namelist_write_newline (dtp); /* If writing to an internal unit, stash it to allow the child procedure to access it. */ @@ -2261,9 +2255,23 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, /* Call the user defined formatted WRITE procedure. */ dtp->u.p.current_unit->child_dtio++; - dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist, - child_iostat, child_iomsg, - iotype_len, child_iomsg_len); + if (obj->type == BT_DERIVED) + { + // build a class container + gfc_class list_obj; + list_obj.data = p; + list_obj.vptr = obj->vtable; + list_obj.len = 0; + dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist, + child_iostat, child_iomsg, + iotype_len, child_iomsg_len); + } + else + { + dtio_ptr (p, &unit, iotype, &vlist, + child_iostat, child_iomsg, + iotype_len, child_iomsg_len); + } dtp->u.p.current_unit->child_dtio--; goto obj_loop; -- 2.30.2