re PR fortran/78737 ([OOP] linking error with deferred, undefined user-defined derived-type I/O)

2016-12-13  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	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-13  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/78737
	* gfortran.dg/dtio_19.f90: New test case.

Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>

From-SVN: r243609

6 files changed, 136 insertions, 18 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7a47db2..2a4b69d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2016-12-13  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	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  <janus@gcc.gnu.org>
 
 	PR fortran/78392
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 24dadf2..f018984 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 8afba84..90f46e5 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 253a5ac..b60685e 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);
+
+      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;
 
-  *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
-					   formatted);
+      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 118d01e..fa954e5 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2016-12-13  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/78737
+	* gfortran.dg/dtio_19.f90: New test case.
+
 2016-12-13  Michael Matz  <matz@suse.de>
 
 	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 0000000..f4d3757
--- /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  <damian@sourceryinstitute.org>
+
+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