From: Janus Weil <janus@gcc.gnu.org>
Date: Sun, 18 Dec 2016 13:22:13 +0000 (+0100)
Subject: re PR fortran/78848 ([OOP] ICE on writing CLASS variable with non-typebound DTIO... 
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=707024b2e8d74c4a810ba7d2bda5ecd6556d2140;p=gcc.git

re PR fortran/78848 ([OOP] ICE on writing CLASS variable with non-typebound DTIO procedure)

2016-12-18  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/78848
	* trans-io.c (get_dtio_proc): Generate non-typebound DTIO call for class
	variables, if no typebound DTIO procedure is available.

2016-12-18  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/78848
	* gfortran.dg/dtio_22.f90: New test.

From-SVN: r243784
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 693d51fd5ba..d718a3fbbaf 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2016-12-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/78848
+	* trans-io.c (get_dtio_proc): Generate non-typebound DTIO call for class
+	variables, if no typebound DTIO procedure is available.
+
 2016-12-18  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/78592
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index b60685ee157..5f9c1919685 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -2180,41 +2180,39 @@ get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
       formatted = true;
     }
 
-  if (ts->type == BT_DERIVED)
+  if (ts->type == BT_CLASS)
+    derived = ts->u.derived->components->ts.u.derived;
+  else
+    derived = ts->u.derived;
+
+  gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
+						  last_dt == WRITE, formatted);
+  if (ts->type == BT_CLASS && tb_io_st)
+    {
+      // polymorphic DTIO call  (based on the dynamic type)
+      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;
+    }
+  else
     {
-      derived = ts->u.derived;
+      // non-polymorphic DTIO call (based on the declared type)
       *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;
-	}
-    }
-
 
   return NULL_TREE;
-
 }
 
 /* Generate the call for a scalar transfer node.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6583316bbf4..7b91b7b86b0 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2016-12-18  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/78848
+	* gfortran.dg/dtio_22.f90: New test.
+
 2016-12-18  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/78592
diff --git a/gcc/testsuite/gfortran.dg/dtio_22.f90 b/gcc/testsuite/gfortran.dg/dtio_22.f90
new file mode 100644
index 00000000000..f39450cbca2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dtio_22.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+!
+! PR 78848: [OOP] ICE on writing CLASS variable with non-typebound DTIO procedure
+!
+! Contributed by Mikael Morin <morin-mikael@orange.fr>
+
+module m
+  type :: t
+    integer :: i = 123
+  end type
+  interface write(formatted)
+    procedure wf
+  end interface
+contains
+  subroutine wf(this, unit, b, c, iostat, iomsg)
+    class(t), intent(in) :: this
+    integer, intent(in) :: unit
+    character, intent(in) :: b
+    integer, intent(in) :: c(:)
+    integer, intent(out) :: iostat
+    character, intent(inout) :: iomsg
+    write (unit, "(i3)", IOSTAT=iostat, IOMSG=iomsg) this%i
+  end subroutine
+end
+
+program p
+  use m
+  character(3) :: buffer
+  class(t), allocatable :: z
+  allocate(z)
+  write(buffer,"(DT)") z
+  if (buffer /= "123") call abort()
+end