From 096506bb6e4bea8d0f8beafb5eff866e4a7ce3fe Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Wed, 21 Sep 2016 06:57:28 +0000 Subject: [PATCH] re PR fortran/77657 (link error with implementation of user-defined derived type input/output (UD-DTIO) in child extending abstract parent) 2016-09-21 Paul Thomas PR fortran/77657 * interface.c (gfc_find_specific_dtio_proc): Borrow trick from resolve_typebound_generic_call to find dtio procedures that over-ride those in the declared type. 2016-09-21 Paul Thomas PR fortran/77657 * gfortran.dg/dtio_12.f90: New test. From-SVN: r240301 --- gcc/fortran/ChangeLog | 14 +++-- gcc/fortran/interface.c | 14 ++++- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/dtio_12.f90 | 74 +++++++++++++++++++++++++++ 4 files changed, 103 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dtio_12.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1a799ad39dc..5d9a10df6b2 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2016-09-21 Paul Thomas + + PR fortran/77657 + + * interface.c (gfc_find_specific_dtio_proc): Borrow trick from + resolve_typebound_generic_call to find dtio procedures that + over-ride those in the declared type. + 2016-09-20 Marek Polacek * trans-intrinsic.c (conv_expr_ref_to_caf_ref): Adjust fall through @@ -96,7 +104,7 @@ 2016-09-16 Steven G. Kargl PR fortran/77612 - * decl.c (char_len_param_value): Check parent namespace for + * decl.c (char_len_param_value): Check parent namespace for seen_implicit_none. 2016-09-15 Louis Krupp @@ -144,7 +152,7 @@ PR fortran/69514 * array.c (gfc_match_array_constructor): If type-spec is present, - walk the array constructor performing possible conversions for + walk the array constructor performing possible conversions for numeric types. 2016-09-08 Jakub Jelinek @@ -159,7 +167,7 @@ PR fortran/77391 * resolve.c (deferred_requirements): New function to check F2008:C402. (resolve_fl_variable,resolve_fl_parameter): Use it. - + 2016-09-04 Steven G. Kargl PR fortran/77460 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 45a9afe5685..f8a4edb9b62 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -4792,6 +4792,9 @@ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) if (tb_io_st != NULL) { + const char *genname; + gfc_symtree *st; + tb_io_proc = tb_io_st->n.tb; gcc_assert (tb_io_proc != NULL); gcc_assert (tb_io_proc->is_generic); @@ -4800,7 +4803,16 @@ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) specific_proc = tb_io_proc->u.generic->specific; gcc_assert (!specific_proc->is_generic); - dtio_sub = specific_proc->u.specific->n.sym; + /* Go back and make sure that we have the right specific procedure. + Here we most likely have a procedure from the parent type, which + can be overridden in extensions. */ + genname = tb_io_proc->u.generic->specific_st->name; + st = gfc_find_typebound_proc (derived, NULL, genname, + true, &tb_io_proc->where); + if (st) + dtio_sub = st->n.tb->u.specific->n.sym; + else + dtio_sub = specific_proc->u.specific->n.sym; } if (tb_io_st != NULL) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2f5518f5339..c355f214233 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-09-21 Paul Thomas + + PR fortran/77657 + * gfortran.dg/dtio_12.f90: New test. + 2016-09-21 Senthil Kumar Selvaraj * gcc.dg/tree-ssa/pr64130.c: Use __UINT32_TYPE__ instead of int. diff --git a/gcc/testsuite/gfortran.dg/dtio_12.f90 b/gcc/testsuite/gfortran.dg/dtio_12.f90 new file mode 100644 index 00000000000..213f7ebbb1e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_12.f90 @@ -0,0 +1,74 @@ +! { dg-do run } +! +! Test the fix for PR77657 in which the DTIO subroutine was not found, +! which led to an error in attempting to link to the abstract interface. +! +! Contributed by Damian Rouson +! +MODULE abstract_parent + implicit none + + type, abstract :: parent + contains + procedure(write_formatted_interface), deferred :: write_formatted + generic :: write(formatted) => write_formatted + end type parent + + abstract interface + subroutine write_formatted_interface(this,unit,iotype,vlist,iostat,iomsg) + import parent + class(parent), 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 + +end module + +module child_module + use abstract_parent, only : parent + implicit none + + type, extends(parent) :: child + integer :: i = 99 + contains + procedure :: write_formatted + end type +contains + subroutine write_formatted(this,unit,iotype,vlist,iostat,iomsg) + class(child), 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, "(i4)") this%i + end subroutine +end module + + use child_module, only : child + implicit none + type (child) :: baby + integer :: v(1), istat + character(20) :: msg + open (10, status = "scratch") + call baby%write_formatted(10, "abcd", v, istat, msg) ! Call the dtio proc directly + rewind (10) + read (10, *) msg + if (trim (msg) .ne. "99") call abort + rewind (10) + baby%i = 42 + write (10,"(DT)") baby ! Call the dtio proc via the library + rewind (10) + read (10, *) msg + if (trim (msg) .ne. "42") call abort + rewind (10) + write (10,"(DT)") child (77) ! The original testcase + rewind (10) + read (10, *) msg + if (trim (msg) .ne. "77") call abort + close(10) +end -- 2.30.2