[multiple changes]

2017-05-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/80333
	* trans-io.c (nml_get_addr_expr): If we are dealing with class
	type data set tmp tree to get that address.
	(transfer_namelist_element): Set the array spec to point to the
	the class data.

2017-05-19  Paul Thomas  <pault@gcc.gnu.org>
	    Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/80333
	* list_read.c (nml_read_obj): Compute pointer into class/type
	arrays from the nl->dim information. Update it for each iteration
	of the loop for the given object.

2017-05-19  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/80333
	* gfortran.dg/dtio_30.f03: New test.

From-SVN: r248293

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 928e5bbe5d74c4ccde6a43662b40c633d9d0eae6..76418d94948b34a5c78995cea8ddf8efe4960d30 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2017-05-19  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/80333
+       * trans-io.c (nml_get_addr_expr): If we are dealing with class
+       type data set tmp tree to get that address.
+       (transfer_namelist_element): Set the array spec to point to the
+       the class data.
+
 2017-05-19  David Malcolm  <dmalcolm@redhat.com>
 
        PR fortran/79852

diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index c557c1140d82bc76ef846ad340511834e576004b..c3c56f296238ed6ed4724d32e5bdc6f34eb80822 100644 (file)
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -1613,6 +1613,10 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
     tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
                           base_addr, tmp, NULL_TREE);
 
+  if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp))))
+    tmp = gfc_class_data_get (tmp);
+
   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
     tmp = gfc_conv_array_data (tmp);
   else
@@ -1670,8 +1674,12 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
 
   /* Build ts, as and data address using symbol or component.  */
 
-  ts = (sym) ? &sym->ts : &c->ts;
-  as = (sym) ? sym->as : c->as;
+  ts = sym ? &sym->ts : &c->ts;
+
+  if (ts->type != BT_CLASS)
+    as = sym ? sym->as : c->as;
+  else
+    as = sym ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as;
 
   addr_expr = nml_get_addr_expr (sym, c, base_addr);
 
@@ -1680,9 +1688,12 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
 
   if (rank)
     {
-      decl = (sym) ? sym->backend_decl : c->backend_decl;
+      decl = sym ? sym->backend_decl : c->backend_decl;
       if (sym && sym->attr.dummy)
         decl = build_fold_indirect_ref_loc (input_location, decl);
+
+      if (ts->type == BT_CLASS)
+       decl = gfc_class_data_get (decl);
       dt =  TREE_TYPE (decl);
       dtype = gfc_get_dtype (dt);
     }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index dafa0343d1abc2b37dfe71d65382b52e63d32795..fb4b1bd2db07705ec09fa4e18abd68001f6c32ad 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2017-05-19  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       PR libgfortran/80333
+       * gfortran.dg/dtio_30.f03: New test.
+
 2017-05-19  Marek Polacek  <polacek@redhat.com>
 
        PR sanitizer/80800

diff --git a/gcc/testsuite/gfortran.dg/dtio_30.f03 b/gcc/testsuite/gfortran.dg/dtio_30.f03
new file mode 100644 (file)
index 0000000..9edc8f3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dtio_30.f03
@@ -0,0 +1,60 @@
+! { dg-do run }
+! PR80333  Namelist dtio write of array of class does not traverse the array
+! This test checks both NAMELIST WRITE and READ of an array of class
+module m
+  implicit none
+  type :: t
+    character :: c
+    character :: d
+  contains
+    procedure :: read_formatted
+    generic :: read(formatted) => read_formatted
+    procedure :: write_formatted
+    generic :: write(formatted) => write_formatted
+  end type t
+contains
+  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
+    integer :: i
+    read(unit,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d
+  end subroutine read_formatted
+
+  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,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d
+  end subroutine write_formatted
+end module m
+
+program p
+  use m
+  implicit none
+  class(t), dimension(:,:), allocatable :: w
+  namelist /nml/  w
+  integer :: unit, iostatus
+  character(256) :: str = ""
+
+  open(10, status='scratch')
+  allocate(w(10,3))
+  w = t('j','r')
+  w(5:7,2)%c='k'
+  write(10, nml)
+  rewind(10)
+  w = t('p','z')
+  read(10, nml)
+  write(str,*) w
+  if (str.ne." jr jr jr jr jr jr jr jr jr jr jr jr jr jr kr kr kr jr jr jr jr jr jr jr jr jr jr jr jr jr") &
+      & call abort
+  str = ""
+  write(str,"(*(DT))") w
+  if (str.ne."jrjrjrjrjrjrjrjrjrjrjrjrjrjrkrkrkrjrjrjrjrjrjrjrjrjrjrjrjrjr") call abort
+end program p

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 7fe527dda3e3bc7f8e462150c94725effed1c29e..4ada8b8074a5a696ff070afc61b63f7eab440486 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,11 @@
+2017-05-19  Paul Thomas  <pault@gcc.gnu.org>
+           Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       PR fortran/80333
+       * list_read.c (nml_read_obj): Compute pointer into class/type
+       arrays from the nl->dim information. Update it for each iteration
+       of the loop for the given object.
+
 2017-05-17  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR libgfortran/80741

diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 9175a6bb677f3f2c7fd7992a225ed4eb7cf8eb9d..6c00d11bf0537379074134876c4dae947cc944e1 100644 (file)
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -2871,6 +2871,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
   index_type m;
   size_t obj_name_len;
   void *pdata;
+  gfc_class list_obj;
 
   /* If we have encountered a previous read error or this object has not been
      touched in name parsing, just return.  */
@@ -2909,11 +2910,28 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
     {
       /* Update the pointer to the data, using the current index vector  */
 
-      pdata = (void*)(nl->mem_pos + offset);
-      for (dim = 0; dim < nl->var_rank; dim++)
-       pdata = (void*)(pdata + (nl->ls[dim].idx
-                                - GFC_DESCRIPTOR_LBOUND(nl,dim))
-                       * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
+      if ((nl->type == BT_DERIVED || nl->type == BT_CLASS)
+         && nl->dtio_sub != NULL)
+       {
+         pdata = NULL;  /* Not used under these conidtions.  */
+         if (nl->type == BT_CLASS)
+           list_obj.data = ((gfc_class*)nl->mem_pos)->data;
+         else
+           list_obj.data = (void *)nl->mem_pos;
+
+         for (dim = 0; dim < nl->var_rank; dim++)
+           list_obj.data = list_obj.data + (nl->ls[dim].idx
+             - GFC_DESCRIPTOR_LBOUND(nl,dim))
+             * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size;
+       }
+      else
+       {
+         pdata = (void*)(nl->mem_pos + offset);
+         for (dim = 0; dim < nl->var_rank; dim++)
+           pdata = (void*)(pdata + (nl->ls[dim].idx
+             - GFC_DESCRIPTOR_LBOUND(nl,dim))
+             * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
+       }
 
       /* If we are finished with the repeat count, try to read next value.  */
 
@@ -2958,6 +2976,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
            break;
 
          case BT_DERIVED:
+         case BT_CLASS:
            /* If this object has a User Defined procedure, call it.  */
            if (nl->dtio_sub != NULL)
              {
@@ -2970,13 +2989,11 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
                int noiostat;
                int *child_iostat = NULL;
                gfc_array_i4 vlist;
-               gfc_class list_obj;
                formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub;
 
                GFC_DESCRIPTOR_DATA(&vlist) = NULL;
                GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
-
-               list_obj.data = (void *)nl->mem_pos;
+               
                list_obj.vptr = nl->vtable;
                list_obj.len = 0;