[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, 79 insertions, 8 deletions

diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index dd05b7a253a..31bc642910a 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -70,7 +70,7 @@ free_format_hash_table (gfc_unit *u)
 	  free (u->format_hash_table[i].key);
 	}
       u->format_hash_table[i].key = NULL;
-      u->format_hash_table[i].key_len = 0;      
+      u->format_hash_table[i].key_len = 0;
       u->format_hash_table[i].hashed_fmt = NULL;
     }
 }
@@ -84,7 +84,7 @@ reset_node (fnode *fn)
 
   fn->count = 0;
   fn->current = NULL;
-  
+
   if (fn->format != FMT_LPAREN)
     return;
 
@@ -261,11 +261,20 @@ void
 free_format_data (format_data *fmt)
 {
   fnode_array *fa, *fa_next;
-
+  fnode *fnp;
 
   if (fmt == NULL)
     return;
 
+  /* Free vlist descriptors in the fnode_array if one was allocated.  */
+  for (fnp = fmt->array.array; fnp->format != FMT_NONE; fnp++)
+    if (fnp->format == FMT_DT)
+	{
+	  if (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist))
+	    free (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist));
+	  free (fnp->u.udf.vlist);
+	}
+
   for (fa = fmt->array.next; fa; fa = fa_next)
     {
       fa_next = fa->next;
@@ -545,6 +554,9 @@ format_lex (format_data *fmt)
 	case 'C':
 	  token = FMT_DC;
 	  break;
+	case 'T':
+	  token = FMT_DT;
+	  break;
 	default:
 	  token = FMT_D;
 	  unget_char (fmt);
@@ -740,7 +752,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
       tail->u.string.length = fmt->value;
       tail->repeat = 1;
       goto optional_comma;
-      
+
     case FMT_RC:
     case FMT_RD:
     case FMT_RN:
@@ -806,6 +818,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
     case FMT_EN:
     case FMT_ES:
     case FMT_D:
+    case FMT_DT:
     case FMT_L:
     case FMT_A:
     case FMT_F:
@@ -849,6 +862,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
   /* In this state, t must currently be a data descriptor.  Deal with
      things that can/must follow the descriptor */
  data_desc:
+
   switch (t)
     {
     case FMT_L:
@@ -997,7 +1011,57 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
 	}
 
       break;
+    case FMT_DT:
+      *seen_dd = true;
+      get_fnode (fmt, &head, &tail, t);
+      tail->repeat = repeat;
+
+      t = format_lex (fmt);
+
+      /* Initialize the vlist to a zero size array.  */
+      tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4));
+      GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL;
+      GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0);
 
+      if (t == FMT_STRING)
+        {
+	  /* Get pointer to the optional format string.  */
+	  tail->u.udf.string = fmt->string;
+	  tail->u.udf.string_len = fmt->value;
+	  t = format_lex (fmt);
+	}
+      if (t == FMT_LPAREN)
+        {
+	  /* Temporary buffer to hold the vlist values.  */
+	  GFC_INTEGER_4 temp[FARRAY_SIZE];
+	  int i = 0;
+	loop:
+	  t = format_lex (fmt);
+	  if (t != FMT_POSINT)
+	    {
+	      fmt->error = posint_required;
+	      goto finished;
+	    }
+	  /* Save the positive integer value.  */
+	  temp[i++] = fmt->value;
+	  t = format_lex (fmt);
+	  if (t == FMT_COMMA)
+	    goto loop;
+	  if (t == FMT_RPAREN)
+	    {
+	      /* We have parsed the complete vlist so initialize the
+	         array descriptor and save it in the format node.  */
+	      gfc_array_i4 *vp = tail->u.udf.vlist;
+	      GFC_DESCRIPTOR_DATA(vp) = xmalloc (i * sizeof(GFC_INTEGER_4));
+	      GFC_DIMENSION_SET(vp->dim[0],1, i, 1);
+	      memcpy (GFC_DESCRIPTOR_DATA(vp), temp, i * sizeof(GFC_INTEGER_4));
+	      break;
+	    }
+	  fmt->error = unexpected_element;
+	  goto finished;
+	}
+      fmt->saved_token = t;
+      break;
     case FMT_H:
       if (repeat > fmt->format_string_len)
 	{
@@ -1219,9 +1283,12 @@ parse_format (st_parameter_dt *dtp)
   format_data *fmt;
   bool format_cache_ok, seen_data_desc = false;
 
-  /* Don't cache for internal units and set an arbitrary limit on the size of
-     format strings we will cache.  (Avoids memory issues.)  */
-  format_cache_ok = !is_internal_unit (dtp);
+  /* Don't cache for internal units and set an arbitrary limit on the
+     size of format strings we will cache.  (Avoids memory issues.)
+     Also, the format_hash_table resides in the current_unit, so
+     child_dtio procedures would overwrite the parent table  */
+  format_cache_ok = !is_internal_unit (dtp)
+		    && (dtp->u.p.current_unit->child_dtio == 0);
 
   /* Lookup format string to see if it has already been parsed.  */
   if (format_cache_ok)
@@ -1257,6 +1324,10 @@ parse_format (st_parameter_dt *dtp)
   fmt->reversion_ok = 0;
   fmt->saved_format = NULL;
 
+  /* Initialize the fnode_array.  */
+
+  memset (&(fmt->array), 0, sizeof(fmt->array));
+
   /* Allocate the first format node as the root of the tree.  */
 
   fmt->last = &fmt->array;
@@ -1392,7 +1463,7 @@ next_format (st_parameter_dt *dtp)
   if (!fmt->reversion_ok &&
       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
-       t == FMT_A || t == FMT_D))
+       t == FMT_A || t == FMT_D || t == FMT_DT))
     fmt->reversion_ok = 1;
   return f;
 }