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

gcc/fortran/ChangeLog

+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

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);
+	    }
 	}
     }
 

gcc/testsuite/ChangeLog

+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

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
-

gcc/testsuite/gfortran.dg/dtio_27.f90

+! { 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

libgfortran/ChangeLog

+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.
+
 2017-03-27  Dominique d'Humieres  <dominiq@lps.ens.fr>
 
 	* io/list_read.c: Insert /* Fall through. */ in the macro

libgfortran/io/write.c

@@ -2075,7 +2075,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
   /* Write namelist variable names in upper case. If a derived type,
      nothing is output.  If a component, base and base_name are set.  */
 
-  if (obj->type != BT_DERIVED)
+  if (obj->type != BT_DERIVED || obj->dtio_sub != NULL)
     {
       namelist_write_newline (dtp);
       write_character (dtp, " ", 1, 1, NODELIM);
@@ -2227,15 +2227,10 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 		  int noiostat;
 		  int *child_iostat = NULL;
 		  gfc_array_i4 vlist;
-		  gfc_class list_obj;
 		  formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
 
 		  GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
 
-		  list_obj.data = p;
-		  list_obj.vptr = obj->vtable;
-		  list_obj.len = 0;
-
 		  /* Set iostat, intent(out).  */
 		  noiostat = 0;
 		  child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
@@ -2252,7 +2247,6 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 		      child_iomsg = tmp_iomsg;
 		      child_iomsg_len = IOMSG_LEN;
 		    }
-		  namelist_write_newline (dtp);
 
 		  /* If writing to an internal unit, stash it to allow
 		     the child procedure to access it.  */
@@ -2261,9 +2255,23 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 		      
 		  /* Call the user defined formatted WRITE procedure.  */
 		  dtp->u.p.current_unit->child_dtio++;
-		  dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
-			    child_iostat, child_iomsg,
-			    iotype_len, child_iomsg_len);
+		  if (obj->type == BT_DERIVED)
+		    {
+		      // build a class container
+		      gfc_class list_obj;
+		      list_obj.data = p;
+		      list_obj.vptr = obj->vtable;
+		      list_obj.len = 0;
+		      dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
+				child_iostat, child_iomsg,
+				iotype_len, child_iomsg_len);
+		    }
+		  else
+		    {
+		      dtio_ptr (p, &unit, iotype, &vlist,
+				child_iostat, child_iomsg,
+				iotype_len, child_iomsg_len);
+		    }
 		  dtp->u.p.current_unit->child_dtio--;
 
 		  goto obj_loop;