re PR fortran/78661 ([OOP] Namelist output missing object designator under DTIO)

2017-03-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/78661
	* trans-io.c (transfer_namelist_element): Perform a polymorphic call
	to a DTIO procedure if necessary.

2017-03-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/78661
	* gfortran.dg/dtio_25.f90: Modified test case.
	* gfortran.dg/dtio_27.f90: New test case.

2017-03-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/78661
	* io/write.c (nml_write_obj): Build a class container only if necessary.

From-SVN: r246546

5 files changed, 141 insertions, 17 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 20ad857..7528f37 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2017-03-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/78661
+	* trans-io.c (transfer_namelist_element): Perform a polymorphic call
+	to a DTIO procedure if necessary.
+
 2017-03-25  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/80156
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 36e84be..1b70136 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -1701,22 +1701,53 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
   /* Check if the derived type has a specific DTIO for the mode.
      Note that although namelist io is forbidden to have a format
      list, the specific subroutine is of the formatted kind.  */
-  if (ts->type == BT_DERIVED)
+  if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
     {
-      gfc_symbol *dtio_sub = NULL;
-      gfc_symbol *vtab;
-      dtio_sub = gfc_find_specific_dtio_proc (ts->u.derived,
-					      last_dt == WRITE,
-					      true);
-      if (dtio_sub != NULL)
+      gfc_symbol *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, true);
+
+      if (ts->type == BT_CLASS && tb_io_st)
+	{
+	  // polymorphic DTIO call  (based on the dynamic type)
+	  gfc_se se;
+	  gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
+	  // build vtable expr
+	  gfc_expr *expr = gfc_get_variable_expr (st);
+	  gfc_add_vptr_component (expr);
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, expr);
+	  vtable = se.expr;
+	  // build dtio expr
+	  gfc_add_component_ref (expr,
+				tb_io_st->n.tb->u.generic->specific_st->name);
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, expr);
+	  gfc_free_expr (expr);
+	  dtio_proc = se.expr;
+	}
+      else
 	{
-	  dtio_proc = gfc_get_symbol_decl (dtio_sub);
-	  dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
-	  vtab = gfc_find_derived_vtab (ts->u.derived);
-	  vtable = vtab->backend_decl;
-	  if (vtable == NULL_TREE)
-	    vtable = gfc_get_symbol_decl (vtab);
-	  vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
+	  // non-polymorphic DTIO call (based on the declared type)
+	  gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived,
+							last_dt == WRITE, true);
+	  if (dtio_sub != NULL)
+	    {
+	      dtio_proc = gfc_get_symbol_decl (dtio_sub);
+	      dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
+	      gfc_symbol *vtab = gfc_find_derived_vtab (derived);
+	      vtable = vtab->backend_decl;
+	      if (vtable == NULL_TREE)
+		vtable = gfc_get_symbol_decl (vtab);
+	      vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
+	    }
 	}
     }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a3bdf1c..c7c82a3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2017-03-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/78661
+	* gfortran.dg/dtio_25.f90: Modified test case.
+	* gfortran.dg/dtio_27.f90: New test case.
+
 2017-03-28  Uros Bizjak  <ubizjak@gmail.com>
 
 	PR target/53383
diff --git a/gcc/testsuite/gfortran.dg/dtio_25.f90 b/gcc/testsuite/gfortran.dg/dtio_25.f90
index fc049cd..6e66a31 100644
--- a/gcc/testsuite/gfortran.dg/dtio_25.f90
+++ b/gcc/testsuite/gfortran.dg/dtio_25.f90
@@ -8,6 +8,8 @@ module m
   contains
     procedure :: write_formatted
     generic :: write(formatted) => write_formatted
+    procedure :: read_formatted
+    generic :: read(formatted) => read_formatted
   end type
 contains
   subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
@@ -18,11 +20,26 @@ contains
     integer, intent(out) :: iostat
     character(*), intent(inout) :: iomsg
     if (iotype.eq."NAMELIST") then
-      write (unit, '(a,a,a,a,i5)') 'x%c="',dtv%c,'",','x%k=', dtv%k
+      write (unit, '(a3,a1,i3)') dtv%c,',', dtv%k
     else
       write (unit,*) dtv%c, dtv%k
     end if
   end subroutine
+  subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+    class(t), intent(inout) :: dtv
+    integer, intent(in) :: unit
+    character(*), intent(in) :: iotype
+    integer, intent(in) :: v_list(:)
+    integer, intent(out) :: iostat
+    character(*), intent(inout) :: iomsg
+    character :: comma
+    if (iotype.eq."NAMELIST") then
+      read (unit, '(a4,a1,i3)') dtv%c, comma, dtv%k    ! FIXME: need a4 here, with a3 above
+    else
+      read (unit,*) dtv%c, comma, dtv%k
+    end if
+    if (comma /= ',') call abort()
+  end subroutine
 end module
 
 program p
@@ -33,9 +50,8 @@ program p
   namelist /nml/ x
   x = t('a', 5)
   write (buffer, nml)
-  if (buffer.ne.'&NML x%c="a",x%k=    5  /') call abort
+  if (buffer.ne.'&NML  X=  a,  5  /') call abort
   x = t('x', 0)
   read (buffer, nml)
   if (x%c.ne.'a'.or. x%k.ne.5) call abort
 end
-
diff --git a/gcc/testsuite/gfortran.dg/dtio_27.f90 b/gcc/testsuite/gfortran.dg/dtio_27.f90
new file mode 100644
index 0000000..b8b6bad
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dtio_27.f90
@@ -0,0 +1,65 @@
+! { dg-do run }
+!
+! PR 78661: [OOP] Namelist output missing object designator under DTIO
+!
+! Contributed by Ian Harvey <ian_harvey@bigpond.com>
+
+MODULE m
+  IMPLICIT NONE
+  TYPE :: t
+    CHARACTER :: c
+  CONTAINS
+    PROCEDURE :: write_formatted
+    GENERIC :: WRITE(FORMATTED) => write_formatted
+    PROCEDURE :: read_formatted
+    GENERIC :: READ(FORMATTED) => read_formatted
+  END TYPE
+CONTAINS
+  SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+    CLASS(t), INTENT(IN) :: dtv
+    INTEGER, INTENT(IN) :: unit
+    CHARACTER(*), INTENT(IN) :: iotype
+    INTEGER, INTENT(IN) :: v_list(:)
+    INTEGER, INTENT(OUT) :: iostat
+    CHARACTER(*), INTENT(INOUT) :: iomsg
+    WRITE (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) dtv%c
+  END SUBROUTINE
+  SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+    CLASS(t), INTENT(INOUT) :: dtv
+    INTEGER, INTENT(IN) :: unit
+    CHARACTER(*), INTENT(IN) :: iotype
+    INTEGER, INTENT(IN) :: v_list(:)
+    INTEGER, INTENT(OUT) :: iostat
+    CHARACTER(*), INTENT(INOUT) :: iomsg
+    READ (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) dtv%c
+  END SUBROUTINE
+END MODULE
+
+
+PROGRAM p
+
+  USE m
+  IMPLICIT NONE
+  character(len=4), dimension(3) :: buffer
+  call test_type
+  call test_class
+
+contains
+
+  subroutine test_type
+    type(t) :: x
+    namelist /n1/ x
+    x = t('a')
+    write (buffer, n1)
+    if (buffer(2) /= " X=a") call abort()
+  end subroutine
+
+  subroutine test_class
+    class(t), allocatable :: y
+    namelist /n2/ y
+    y = t('b')
+    write (buffer, n2)
+    if (buffer(2) /= " Y=b") call abort()
+  end subroutine
+
+END