re PR fortran/77657 (link error with implementation of user-defined derived type...

2016-09-21  Paul Thomas  <pault@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-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/77657
	* gfortran.dg/dtio_12.f90: New test.

From-SVN: r240301

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1a799ad39dc271f384ea8b30a985462e9e027789..5d9a10df6b27173e26c60ab6a832e62005cc7138 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2016-09-21  Paul Thomas  <pault@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  Marek Polacek  <polacek@redhat.com>
 
        * trans-intrinsic.c (conv_expr_ref_to_caf_ref): Adjust fall through
@@ -96,7 +104,7 @@
 2016-09-16  Steven G. Kargl  <kargl@gcc.gnu.org>
 
        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  <louis.krupp@zoho.com>
@@ -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  <jakub@redhat.com>
@@ -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  <kargl@gcc.gnu.org>
 
        PR fortran/77460

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 45a9afe568568491e16430a47566dc8659bc211c..f8a4edb9b6249c45ecc46a621ae7ecc82eeb913b 100644 (file)
--- 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 2f5518f53396839fe075c2877c71140287116c8d..c355f2142337d1d993b1949324f0a7d8b2986bef 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2016-09-21  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/77657
+       * gfortran.dg/dtio_12.f90: New test.
+
 2016-09-21  Senthil Kumar Selvaraj  <senthil_kumar.selvaraj@atmel.com>
 
        * 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 (file)
index 0000000..213f7eb
--- /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  <damian@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