diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7a47db2e999..2a4b69dabc7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2016-12-13 Janus Weil + Paul Thomas + + PR fortran/78737 + * gfortran.h (gfc_find_typebound_dtio_proc): New prototype. + * interface.c (gfc_compare_interfaces): Whitespace fix. + (gfc_find_typebound_dtio_proc): New function. + (gfc_find_specific_dtio_proc): Use it. Improve error recovery. + * trans-io.c (get_dtio_proc): Implement polymorphic calls to DTIO + procedures. + 2016-12-12 Janus Weil PR fortran/78392 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 24dadf26a12..f0189840f27 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3252,6 +3252,7 @@ int gfc_has_vector_subscript (gfc_expr*); gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op); bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*); void gfc_check_dtio_interfaces (gfc_symbol*); +gfc_symtree* gfc_find_typebound_dtio_proc (gfc_symbol *, bool, bool); gfc_symbol* gfc_find_specific_dtio_proc (gfc_symbol*, bool, bool); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 8afba84a697..90f46e56e4d 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1712,8 +1712,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, return 0; /* Special case: alternate returns. If both f1->sym and f2->sym are - NULL, then the leading formal arguments are alternate returns. - The previous conditional should catch argument lists with + NULL, then the leading formal arguments are alternate returns. + The previous conditional should catch argument lists with different number of argument. */ if (f1 && f1->sym == NULL && f2 && f2->sym == NULL) return 1; @@ -4826,13 +4826,10 @@ gfc_check_dtio_interfaces (gfc_symbol *derived) } -gfc_symbol * -gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) +gfc_symtree* +gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted) { gfc_symtree *tb_io_st = NULL; - gfc_symbol *dtio_sub = NULL; - gfc_symbol *extended; - gfc_typebound_proc *tb_io_proc, *specific_proc; bool t = false; if (!derived || derived->attr.flavor != FL_DERIVED) @@ -4869,6 +4866,19 @@ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) true, &derived->declared_at); } + return tb_io_st; +} + + +gfc_symbol * +gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) +{ + gfc_symtree *tb_io_st = NULL; + gfc_symbol *dtio_sub = NULL; + gfc_symbol *extended; + gfc_typebound_proc *tb_io_proc, *specific_proc; + + tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted); if (tb_io_st != NULL) { @@ -4893,17 +4903,17 @@ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) dtio_sub = st->n.tb->u.specific->n.sym; else dtio_sub = specific_proc->u.specific->n.sym; - } - if (tb_io_st != NULL) - goto finish; + goto finish; + } /* If there is not a typebound binding, look for a generic DTIO interface. */ for (extended = derived; extended; extended = gfc_get_derived_super_type (extended)) { - if (extended == NULL || extended->ns == NULL) + if (extended == NULL || extended->ns == NULL + || extended->attr.flavor == FL_UNKNOWN) return NULL; if (formatted == true) diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 253a5ac70a9..b60685ee157 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -2181,15 +2181,37 @@ get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub) } if (ts->type == BT_DERIVED) - derived = ts->u.derived; - else - derived = ts->u.derived->components->ts.u.derived; + { + derived = ts->u.derived; + *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE, + formatted); - *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; + } + } - if (*dtio_sub) - return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub)); return NULL_TREE; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 118d01e2f58..fa954e539ff 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2016-12-13 Janus Weil + Paul Thomas + + PR fortran/78737 + * gfortran.dg/dtio_19.f90: New test case. + 2016-12-13 Michael Matz PR tree-optimization/78725 diff --git a/gcc/testsuite/gfortran.dg/dtio_19.f90 b/gcc/testsuite/gfortran.dg/dtio_19.f90 new file mode 100644 index 00000000000..f4d375748ec --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_19.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! +! PR78737: [OOP] linking error with deferred, undefined user-defined derived-type I/O +! +! Contributed by Damian Rouson + +module object_interface + character(30) :: buffer(2) + type, abstract :: object + contains + procedure(write_formatted_interface), deferred :: write_formatted + generic :: write(formatted) => write_formatted + end type + abstract interface + subroutine write_formatted_interface(this,unit,iotype,vlist,iostat,iomsg) + import object + class(object), intent(in) :: this + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + end subroutine + end interface + type, extends(object) :: non_abstract_child1 + integer :: i + contains + procedure :: write_formatted => write_formatted1 + end type + type, extends(object) :: non_abstract_child2 + real :: r + contains + procedure :: write_formatted => write_formatted2 + end type +contains + subroutine write_formatted1(this,unit,iotype,vlist,iostat,iomsg) + class(non_abstract_child1), intent(in) :: this + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + write(unit,'(a,i2/)') "write_formatted1 => ", this%i + end subroutine + subroutine write_formatted2(this,unit,iotype,vlist,iostat,iomsg) + class(non_abstract_child2), intent(in) :: this + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + write(unit,'(a,f4.1/)') "write_formatted2 => ", this%r + end subroutine + subroutine assert(a) + class(object):: a + write(buffer,'(DT)') a + end subroutine +end module + +program p + use object_interface + + call assert (non_abstract_child1 (99)) + if (trim (buffer(1)) .ne. "write_formatted1 => 99") call abort + + call assert (non_abstract_child2 (42.0)) + if (trim (buffer(1)) .ne. "write_formatted2 => 42.0") call abort +end