diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2017-03-28 19:01:05 +0200 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2017-03-28 19:01:05 +0200 |
| commit | cf474530613eaaa4d28534a5a53ef61fcc71180d (patch) | |
| tree | 6beb828d036294eea66384e7a4eb740ad9421682 /gcc/fortran/trans-io.c | |
| parent | 189d9d3a8fca52e18a62f16a4e316dc690a4d856 (diff) | |
| download | gcc-cf474530613eaaa4d28534a5a53ef61fcc71180d.zip gcc-cf474530613eaaa4d28534a5a53ef61fcc71180d.tar.gz gcc-cf474530613eaaa4d28534a5a53ef61fcc71180d.tar.bz2 | |
re PR fortran/78661 ([OOP] Namelist output missing object designator under DTIO)
2017-03-28 Janus Weil <janus@gcc.gnu.org>
PR fortran/78661
* trans-io.c (transfer_namelist_element): Perform a polymorphic call
to a DTIO procedure if necessary.
2017-03-28 Janus Weil <janus@gcc.gnu.org>
PR fortran/78661
* gfortran.dg/dtio_25.f90: Modified test case.
* gfortran.dg/dtio_27.f90: New test case.
2017-03-28 Janus Weil <janus@gcc.gnu.org>
PR fortran/78661
* io/write.c (nml_write_obj): Build a class container only if necessary.
From-SVN: r246546
Diffstat (limited to 'gcc/fortran/trans-io.c')
| -rw-r--r-- | gcc/fortran/trans-io.c | 59 |
1 files changed, 45 insertions, 14 deletions
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 36e84be..1b70136 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); + } } } |