Dear All,
Once found, the fix for this PR is trivial. The generic name is only
to be found in the parent derived type. Since this is over-ridden in
the type extension, not only is the wrong symbol selected for the dtio
procedure but, being abstract, the procedure does not exist. The
mechanism is borrowed from resolve.c(resolve_typebound_generic_call).
This goes back with the generic procedure name and looks again for the
procedure in the type extension. The testcase is a dejagnuified
version of the original.
Bootstraps and regtests on x86_64/FC21 - OK for trunk?
Paul
2016-09-20 Paul Thomas <pa...@gcc.gnu.org>
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 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/77657
* gfortran.dg/dtio_12.f90: New test.
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 240270)
--- gcc/fortran/interface.c (working copy)
*************** gfc_find_specific_dtio_proc (gfc_symbol
*** 4792,4797 ****
--- 4792,4800 ----
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);
*************** gfc_find_specific_dtio_proc (gfc_symbol
*** 4800,4806 ****
specific_proc = tb_io_proc->u.generic->specific;
gcc_assert (!specific_proc->is_generic);
! dtio_sub = specific_proc->u.specific->n.sym;
}
if (tb_io_st != NULL)
--- 4803,4818 ----
specific_proc = tb_io_proc->u.generic->specific;
gcc_assert (!specific_proc->is_generic);
! /* 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)
Index: gcc/testsuite/gfortran.dg/dtio_12.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_12.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_12.f90 (working copy)
***************
*** 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 <dam...@sourceryinstitute.org>
+ !
+ 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
