[patch, fortran] PR80333 Namelist dtio write of array of class does not traverse the array

[Jerry DeLisle <jvdelisle at charter dot net>]

Hello,

With some important help from Paul regarding how to access the class data and 
array specs, we have the attached patch.

This fixes both READ and WRITE of arrays of class/type objects.  The namelist 
routines are updated to set the array specifications correctly in the frontend 
so that the call to set the namelist dimensions is completed.

Likewise in the NAMELIST READ arena, we have to then take the given loop 
specification information and compute the index into the class/type data and set 
pointers to the right place on the array.  The existing namelist code already 
sequences through the loop and needed to be initialized correctly.

Regression tested on x86_64. New test case attached. The test case is little 
interesting. You will see use of the unlimited repeat specifier '*' on the DT 
format specifier. One can see how useful that is when you have allocated arrays 
that could change during program execution. (Just a little side note)

OK for trunk? and then to 7 in about a week?

Regards,

Jerry

2017-05-18  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-18  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.

diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index c557c114..a81a0c16 100644
--- 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
@@ -1671,7 +1675,11 @@ 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;
+
+  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);
 
@@ -1683,6 +1691,9 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
       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/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 9175a6bb..d8d06823 100644
--- 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;

Attachment: dtio_30.f03
Description: Text document