[multiple changes]

2016-08-31  Paul Thomas  <pault@gcc.gnu.org>
	Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/48298

	* decl.c (access_attr_decl): Include case INTERFACE_DTIO as
	appropriate.
	* gfortran.h : Add INTRINSIC_FORMATTED and
	INTRINSIC_UNFORMATTED to gfc_intrinsic_op. Add INTERFACE_DTIO
	to interface type. Add new enum 'dtio_codes'. Add bitfield
	'has_dtio_procs' to symbol_attr. Add prototypes
	'gfc_check_dtio_interfaces' and 'gfc_find_specific_dtio_proc'.
	* interface.c (dtio_op): New function.
	(gfc_match_generic_spec): Match generic DTIO interfaces.
	(gfc_match_interface): Treat DTIO interfaces in the same way as
	(gfc_current_interface_head): Add INTERFACE_DTIO appropriately.
	(check_dtio_arg_TKR_intent): New function.
	(check_dtio_interface1): New function.
	(gfc_check_dtio_interfaces): New function.
	(gfc_find_specific_dtio_proc): New function.
	* io.c : Add FMT_DT to format_token.
	(format_lex): Handle DTIO formatting.
	* match.c (gfc_op2string): Add DTIO operators.
	* resolve.c (derived_inaccessible): Ignore pointer components
	to enclosing derived type.
	(resolve_transfer): Resolve transfers that involve DTIO.
	procedures. Find the specific subroutine for the transfer and
	use its existence to over-ride some of the constraints on
	derived types. If the transfer is recursive, require that the
	subroutine be so qualified.
	(dtio_procs_present): New function.
	(resolve_fl_namelist): Remove inhibition of polymorphic objects
	in namelists if DTIO read and write subroutines exist. Likewise
	for derived types.
	(resolve_types): Invoke 'gfc_verify_dtio_procedures'.
	* symbol.c : Set 'dtio_procs' using 'minit'.
	* trans-decl.c (gfc_finish_var_decl): If a derived-type/class
	object is associated with DTIO procedures, make it TREE_STATIC.
	* trans-expr.c (gfc_get_vptr_from_expr): If the expression
	drills down to a PARM_DECL, extract the vptr correctly.
	(gfc_conv_derived_to_class): Check 'info' in the test for
	'useflags'. If the se expression exists and is a pointer, use
	it as the class _data.
	* trans-io.c : Add IOCALL_X_DERIVED to iocall and the function
	prototype. Likewise for IOCALL_SET_NML_DTIO_VAL.
	(set_parameter_tree): Renamed from 'set_parameter_const', now
	returns void and has new tree argument. Calls modified to match
	new interface.
	(transfer_namelist_element): Transfer DTIO procedure pointer
	and vpointer using the new function IOCALL_SET_NML_DTIO_VAL.
	(get_dtio_proc): New function.
	(transfer_expr): Add new argument for the vptr field of class
	objects. Add the code to call the specific DTIO proc, convert
	derived types to class and call IOCALL_X_DERIVED.
	(trans_transfer): Add BT_CLASS to structures for treatment by
	the scalarizer. Obtain the vptr for the dynamic type, both for
	scalar and array transfer.

2016-08-31  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
	Paul Thomas  <pault@gcc.gnu.org>

	PR libgfortran/48298
	* gfortran.map : Flag _st_set_nml_dtio_var and
	_gfortran_transfer_derived.
	* io/format.c (format_lex): Detect DTIO formatting.
	(parse_format_list): Parse the DTIO format.
	(next_format): Include FMT_DT.
	* io/format.h : Likewise. Add structure 'udf' to structure
	'fnode' to carry the IOTYPE string and the 'vlist'.
	* io/io.h : Add prototypes for the two types of DTIO subroutine
	and a typedef for gfc_class. Also, add to 'namelist_type'
	fields for the pointer to the DTIO procedure and the vtable.
	Add fields to struct st_parameter_dt for pointers to the two
	types of DTIO subroutine. Add to gfc_unit DTIO specific fields.
	(internal_proto): Add prototype for 'read_user_defined' and
	'write_user_defined'.
	* io/list_read.c (check_buffers): Use the 'current_unit' field.
	(unget_char): Likewise.
	(eat_spaces): Likewise.
	(list_formatted_read_scalar): For case BT_CLASS, call the DTIO
	procedure.
	(nml_get_obj_data): Likewise when DTIO procedure is present,.
	* io/transfer.c : Export prototypes for 'transfer_derived' and
	'transfer_derived_write'.
	(unformatted_read): For case BT_CLASS, call the DTIO procedure.
	(unformatted_write): Likewise.
	(formatted_transfer_scalar_read): Likewise.
	(formatted_transfer_scalar_write: Likewise.
	(transfer_derived): New function.
	(data_transfer_init): Set last_char if no child_dtio.
	(finalize_transfer): Return if child_dtio set.
	(st_write_done): Add condition for child_dtio not set.
	Add extra arguments for st_set_nml_var prototype.
	(set_nml_var): New function that contains the contents of the
	old version of st_set_nml_var. Also sets the 'dtio_sub' and
	'vtable' fields of the 'nml' structure.
	(st_set_nml_var): Now just calls set_nml_var with 'dtio_sub'
	and 'vtable' NULL.
	(st_set_nml_dtio_var): New function that calls set_nml_var.
	* io/unit.c (get_external_unit): If the found unit child_dtio
	is non zero, don't do any mutex locking/unlocking.  Just
	return the unit.
	* io/unix.c (tempfile_open): Revert to C style comment.
	* io/write.c (list_formatted_write_scalar): Do the DTIO call.
	(nml_write_obj): Add BT_CLASS and do the DTIO call.

2016-08-31  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
	Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/48298
	* gfortran.dg/dtio_1.f90: New test.
	* gfortran.dg/dtio_2.f90: New test.
	* gfortran.dg/dtio_3.f90: New test.
	* gfortran.dg/dtio_4.f90: New test.
	* gfortran.dg/dtio_5.f90: New test.
	* gfortran.dg/dtio_6.f90: New test.
	* gfortran.dg/dtio_7.f90: New test.
	* gfortran.dg/dtio_8.f90: New test.
	* gfortran.dg/dtio_9.f90: New test.
	* gfortran.dg/dtio_10.f90: New test.

From-SVN: r239880

1 files changed, 122 insertions, 36 deletions

diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index db27f2d..15f7158 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -44,7 +44,7 @@ static void
 memcpy4 (gfc_char4_t *dest, const char *source, int k)
 {
   int j;
-  
+
   const char *p = source;
   for (j = 0; j < k; j++)
     *dest++ = (gfc_char4_t) *p++;
@@ -63,7 +63,7 @@ write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source,
   int j, k = 0;
   gfc_char4_t c;
   uchar d;
-      
+
   /* Take care of preceding blanks.  */
   if (w_len > src_len)
     {
@@ -153,7 +153,7 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
   static const uchar masks[6] =  { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
   static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
   int nbytes;
-  uchar buf[6], d, *q; 
+  uchar buf[6], d, *q;
 
   /* Take care of preceding blanks.  */
   if (w_len > src_len)
@@ -273,7 +273,7 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 		  bytes = 0;
 		}
 
-	      /* Write out the CR_LF sequence.  */ 
+	      /* Write out the CR_LF sequence.  */
 	      q++;
 	      p = write_block (dtp, 2);
               if (p == NULL)
@@ -381,7 +381,7 @@ write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len
 		  bytes = 0;
 		}
 
-	      /* Write out the CR_LF sequence.  */ 
+	      /* Write out the CR_LF sequence.  */
 	      write_default_char4 (dtp, crlf, 2, 0);
 	    }
 	  else
@@ -528,7 +528,7 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
   GFC_INTEGER_LARGEST n;
 
   wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
-  
+
   p = write_block (dtp, wlen);
   if (p == NULL)
     return;
@@ -694,7 +694,7 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
   if (n < 0)
     n = -n;
   nsign = sign == S_NONE ? 0 : 1;
-  
+
   /* conv calls itoa which sets the negative sign needed
      by write_integer. The sign '+' or '-' is set below based on sign
      calculated above, so we just point past the sign in the string
@@ -847,7 +847,7 @@ btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
 {
   char *q;
   int i, j;
-  
+
   q = buffer;
   if (big_endian)
     {
@@ -893,7 +893,7 @@ btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
   if (*n == 0)
     return "0";
 
-  /* Move past any leading zeros.  */  
+  /* Move past any leading zeros.  */
   while (*buffer == '0')
     buffer++;
 
@@ -968,7 +968,7 @@ otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
   if (*n == 0)
     return "0";
 
-  /* Move past any leading zeros.  */  
+  /* Move past any leading zeros.  */
   while (*q == '0')
     q++;
 
@@ -986,9 +986,9 @@ ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
   char *q;
   uint8_t h, l;
   int i;
-  
+
   q = buffer;
-  
+
   if (big_endian)
     {
       const char *p = s;
@@ -1021,11 +1021,11 @@ ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
     }
 
   *q = '\0';
-  
+
   if (*n == 0)
     return "0";
-    
-  /* Move past any leading zeros.  */  
+
+  /* Move past any leading zeros.  */
   while (*buffer == '0')
     buffer++;
 
@@ -1067,7 +1067,7 @@ write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
   const char *p;
   char itoa_buf[GFC_OTOA_BUF_SIZE];
   GFC_UINTEGER_LARGEST n = 0;
-  
+
   if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
     {
       p = otoa_big (source, itoa_buf, len, &n);
@@ -1407,12 +1407,12 @@ write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kin
 
   /* Precision for snprintf call.  */
   int precision = get_precision (dtp, f, source, kind);
-  
+
   /* String buffer to hold final result.  */
   result = select_string (f, str_buf, &res_len);
-  
+
   buffer = select_buffer (precision, buf_stack, &buf_size);
-  
+
   get_float_string (dtp, f, source , kind, 0, buffer,
                            precision, buf_size, result, &res_len);
   write_float_string (dtp, result, res_len);
@@ -1525,13 +1525,13 @@ write_real (st_parameter_dt *dtp, const char *source, int kind)
 
   /* Precision for snprintf call.  */
   int precision = get_precision (dtp, &f, source, kind);
-  
+
   /* String buffer to hold final result.  */
   result = select_string (&f, str_buf, &res_len);
 
   /* scratch buffer to hold final result.  */
   buffer = select_buffer (precision, buf_stack, &buf_size);
-  
+
   get_float_string (dtp, &f, source , kind, 1, buffer,
                            precision, buf_size, result, &res_len);
   write_float_string (dtp, result, res_len);
@@ -1554,7 +1554,7 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
   char str_buf[BUF_STACK_SZ];
   char *buffer, *result;
   size_t buf_size, res_len;
-  int comp_d; 
+  int comp_d;
   set_fnode_default (dtp, &f, kind);
 
   if (d > 0)
@@ -1570,7 +1570,7 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
 
   /* Precision for snprintf call.  */
   int precision = get_precision (dtp, &f, source, kind);
-  
+
   /* String buffer to hold final result.  */
   result = select_string (&f, str_buf, &res_len);
 
@@ -1608,36 +1608,36 @@ write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
 
   dtp->u.p.scale_factor = 1;
   set_fnode_default (dtp, &f, kind);
-  
+
   /* Set width for two values, parenthesis, and comma.  */
   width = 2 * f.u.real.w + 3;
 
   /* Set for no blanks so we get a string result with no leading
      blanks.  We will pad left later.  */
   dtp->u.p.g0_no_blanks = 1;
-  
+
   /* Precision for snprintf call.  */
   int precision = get_precision (dtp, &f, source, kind);
-  
+
   /* String buffers to hold final result.  */
   result1 = select_string (&f, str1_buf, &res_len1);
   result2 = select_string (&f, str2_buf, &res_len2);
 
   buffer = select_buffer (precision, buf_stack, &buf_size);
-  
+
   get_float_string (dtp, &f, source , kind, 0, buffer,
                            precision, buf_size, result1, &res_len1);
   get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
                            precision, buf_size, result2, &res_len2);
   lblanks = width - res_len1 - res_len2 - 3;
-  
+
   write_x (dtp, lblanks, lblanks);
   write_char (dtp, '(');
   write_float_string (dtp, result1, res_len1);
   write_char (dtp, semi_comma);
   write_float_string (dtp, result2, res_len2);
   write_char (dtp, ')');
-  
+
   dtp->u.p.scale_factor = orig_scale;
   dtp->u.p.g0_no_blanks = 0;
   if (buf_size > BUF_STACK_SZ)
@@ -1710,6 +1710,46 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
     case BT_COMPLEX:
       write_complex (dtp, p, kind, size);
       break;
+    case BT_CLASS:
+      {
+	  int unit = dtp->u.p.current_unit->unit_number;
+	  char iotype[] = "LISTDIRECTED";
+	  gfc_charlen_type iotype_len = 12;
+	  char tmp_iomsg[IOMSG_LEN] = "";
+	  char *child_iomsg;
+	  gfc_charlen_type child_iomsg_len;
+	  int noiostat;
+	  int *child_iostat = NULL;
+	  gfc_array_i4 vlist;
+
+	  GFC_DESCRIPTOR_DATA(&vlist) = NULL;
+	  GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+	  /* Set iostat, intent(out).  */
+	  noiostat = 0;
+	  child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+			  dtp->common.iostat : &noiostat;
+
+	  /* Set iomsge, intent(inout).  */
+	  if (dtp->common.flags & IOPARM_HAS_IOMSG)
+	    {
+	      child_iomsg = dtp->common.iomsg;
+	      child_iomsg_len = dtp->common.iomsg_len;
+	    }
+	  else
+	    {
+	      child_iomsg = tmp_iomsg;
+	      child_iomsg_len = IOMSG_LEN;
+	    }
+
+	  /* Call the user defined formatted WRITE procedure.  */
+	  dtp->u.p.current_unit->child_dtio++;
+	  dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
+			      child_iostat, child_iomsg,
+			      iotype_len, child_iomsg_len);
+	  dtp->u.p.current_unit->child_dtio--;
+      }
+      break;
     default:
       internal_error (&dtp->common, "list_formatted_write(): Bad type");
     }
@@ -1844,7 +1884,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
   size_t base_name_len;
   size_t base_var_name_len;
   size_t tot_len;
-  
+
   /* Set the character to be used to separate values
      to a comma or semi-colon.  */
 
@@ -1903,7 +1943,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
       break;
 
     default:
-      obj_size = len;      
+      obj_size = len;
     }
 
   if (obj->var_rank)
@@ -1985,7 +2025,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
               break;
 
 	    case BT_DERIVED:
-
+	    case BT_CLASS:
 	      /* To treat a derived type, we need to build two strings:
 		 ext_name = the name, including qualifiers that prepends
 			    component names in the output - passed to
@@ -1995,19 +2035,65 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 			    components.  */
 
 	      /* First ext_name => get length of all possible components  */
+	      if (obj->dtio_sub != NULL)
+		{
+		  int unit = dtp->u.p.current_unit->unit_number;
+		  char iotype[] = "NAMELIST";
+		  gfc_charlen_type iotype_len = 8;
+		  char tmp_iomsg[IOMSG_LEN] = "";
+		  char *child_iomsg;
+		  gfc_charlen_type child_iomsg_len;
+		  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) ?
+				  dtp->common.iostat : &noiostat;
+
+		  /* Set iomsg, intent(inout).  */
+		  if (dtp->common.flags & IOPARM_HAS_IOMSG)
+		    {
+		      child_iomsg = dtp->common.iomsg;
+		      child_iomsg_len = dtp->common.iomsg_len;
+		    }
+		  else
+		    {
+		      child_iomsg = tmp_iomsg;
+		      child_iomsg_len = IOMSG_LEN;
+		    }
+		  namelist_write_newline (dtp);
+		  /* 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);
+		  dtp->u.p.current_unit->child_dtio--;
+
+		  goto obj_loop;
+		}
 
 	      base_name_len = base_name ? strlen (base_name) : 0;
 	      base_var_name_len = base ? strlen (base->var_name) : 0;
-	      ext_name_len = base_name_len + base_var_name_len 
+	      ext_name_len = base_name_len + base_var_name_len
 		+ strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
 	      ext_name = xmalloc (ext_name_len);
 
 	      if (base_name)
 		memcpy (ext_name, base_name, base_name_len);
 	      clen = strlen (obj->var_name + base_var_name_len);
-	      memcpy (ext_name + base_name_len, 
+	      memcpy (ext_name + base_name_len,
 		      obj->var_name + base_var_name_len, clen);
-	      
+
 	      /* Append the qualifier.  */
 
 	      tot_len = base_name_len + clen;
@@ -2018,7 +2104,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 		      ext_name[tot_len] = '(';
 		      tot_len++;
 		    }
-		  snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d", 
+		  snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
 			    (int) obj->ls[dim_i].idx);
 		  tot_len += strlen (ext_name + tot_len);
 		  ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';