[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

11 files changed, 909 insertions, 106 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b4227be..62bdd9e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,61 @@
+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-30  Fritz Reese  <fritzoreese@gmail.com>
 
 	* gfortran.texi: Fix typo in STRUCTURE documentation.
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index ce7254f..b524239 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -7469,6 +7469,7 @@ access_attr_decl (gfc_statement st)
 	  goto syntax;
 
 	case INTERFACE_GENERIC:
+	case INTERFACE_DTIO:
 	  if (gfc_get_symbol (name, NULL, &sym))
 	    goto done;
 
@@ -9378,6 +9379,7 @@ gfc_match_generic (void)
   switch (op_type)
     {
     case INTERFACE_GENERIC:
+    case INTERFACE_DTIO:
       snprintf (bind_name, sizeof (bind_name), "%s", name);
       break;
 
@@ -9413,6 +9415,7 @@ gfc_match_generic (void)
 
   switch (op_type)
     {
+    case INTERFACE_DTIO:
     case INTERFACE_USER_OP:
     case INTERFACE_GENERIC:
       {
@@ -9467,6 +9470,7 @@ gfc_match_generic (void)
 
       switch (op_type)
 	{
+	case INTERFACE_DTIO:
 	case INTERFACE_GENERIC:
 	case INTERFACE_USER_OP:
 	  {
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 813f7d9..2acf64c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -177,8 +177,10 @@ enum gfc_intrinsic_op
   /* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style)  */
   INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS,
   INTRINSIC_LT_OS, INTRINSIC_LE_OS,
-  INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN,
-  INTRINSIC_PARENTHESES, GFC_INTRINSIC_END /* Sentinel */
+  INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN, INTRINSIC_PARENTHESES,
+  /* User defined derived type pseudo operator.  */
+  INTRINSIC_FORMATTED, INTRINSIC_UNFORMATTED,
+  GFC_INTRINSIC_END /* Sentinel */
 };
 
 /* This macro is the number of intrinsic operators that exist.
@@ -261,7 +263,8 @@ enum gfc_statement
 enum interface_type
 {
   INTERFACE_NAMELESS = 1, INTERFACE_GENERIC,
-  INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT
+  INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT,
+  INTERFACE_DTIO
 };
 
 /* Symbol flavors: these are all mutually exclusive.
@@ -313,6 +316,12 @@ extern const mstring access_types[];
 extern const mstring ifsrc_types[];
 extern const mstring save_status[];
 
+/* Strings for DTIO procedure names.  In symbol.c.  */
+extern const mstring dtio_procs[];
+
+enum dtio_codes
+{ DTIO_RF = 0, DTIO_WF, DTIO_RUF, DTIO_WUF };
+
 /* Enumeration of all the generic intrinsic functions.  Used by the
    backend for identification of a function.  */
 
@@ -784,7 +793,7 @@ typedef struct
   unsigned implicit_pure:1;
 
   /* This is set for a procedure that contains expressions referencing
-     arrays coming from outside its namespace.  
+     arrays coming from outside its namespace.
      This is used to force the creation of a temporary when the LHS of
      an array assignment may be used by an elemental procedure appearing
      on the RHS.  */
@@ -841,7 +850,8 @@ typedef struct
      entities.  */
   unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
 	   private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
-	   event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1;
+	   event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1,
+	   has_dtio_procs:1;
 
   /* This is a temporary selector for SELECT TYPE or an associate
      variable for SELECT_TYPE or ASSOCIATE.  */
@@ -3170,6 +3180,9 @@ bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
 int gfc_has_vector_subscript (gfc_expr*);
 gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
 bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
+void gfc_check_dtio_interfaces (gfc_symbol*);
+gfc_symbol* gfc_find_specific_dtio_proc (gfc_symbol*, bool, bool);
+
 
 /* io.c */
 extern gfc_st_label format_asterisk;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index eba0454..fece316 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -115,6 +115,19 @@ fold_unary_intrinsic (gfc_intrinsic_op op)
 }
 
 
+/* Return the operator depending on the DTIO moded string.  */
+
+static gfc_intrinsic_op
+dtio_op (char* mode)
+{
+  if (strncmp (mode, "formatted", 9) == 0)
+    return INTRINSIC_FORMATTED;
+  if (strncmp (mode, "unformatted", 9) == 0)
+    return INTRINSIC_UNFORMATTED;
+  return INTRINSIC_NONE;
+}
+
+
 /* Match a generic specification.  Depending on which type of
    interface is found, the 'name' or 'op' pointers may be set.
    This subroutine doesn't return MATCH_NO.  */
@@ -162,6 +175,40 @@ gfc_match_generic_spec (interface_type *type,
       return MATCH_YES;
     }
 
+  if (gfc_match (" read ( %n )", buffer) == MATCH_YES)
+    {
+      *op = dtio_op (buffer);
+      if (*op == INTRINSIC_FORMATTED)
+	{
+	  strcpy (name, gfc_code2string (dtio_procs, DTIO_RF));
+	  *type = INTERFACE_DTIO;
+	}
+      if (*op == INTRINSIC_UNFORMATTED)
+	{
+	  strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF));
+	  *type = INTERFACE_DTIO;
+	}
+      if (*op != INTRINSIC_NONE)
+	return MATCH_YES;
+    }
+
+  if (gfc_match (" write ( %n )", buffer) == MATCH_YES)
+    {
+      *op = dtio_op (buffer);
+      if (*op == INTRINSIC_FORMATTED)
+	{
+	  strcpy (name, gfc_code2string (dtio_procs, DTIO_WF));
+	  *type = INTERFACE_DTIO;
+	}
+      if (*op == INTRINSIC_UNFORMATTED)
+	{
+	  strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF));
+	  *type = INTERFACE_DTIO;
+	}
+      if (*op != INTRINSIC_NONE)
+	return MATCH_YES;
+    }
+
   if (gfc_match_name (buffer) == MATCH_YES)
     {
       strcpy (name, buffer);
@@ -209,6 +256,7 @@ gfc_match_interface (void)
 
   switch (type)
     {
+    case INTERFACE_DTIO:
     case INTERFACE_GENERIC:
       if (gfc_get_symbol (name, NULL, &sym))
 	return MATCH_ERROR;
@@ -349,7 +397,7 @@ gfc_match_end_interface (void)
 	      if (strcmp(s2, "none") == 0)
 		gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
 			   "at %C, ", s1);
-	      else		
+	      else
 		gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
 			   "but got %s", s1, s2);
 	    }
@@ -371,6 +419,7 @@ gfc_match_end_interface (void)
 
       break;
 
+    case INTERFACE_DTIO:
     case INTERFACE_GENERIC:
       if (type != current_interface.type
 	  || strcmp (current_interface.sym->name, name) != 0)
@@ -3957,7 +4006,7 @@ gfc_extend_expr (gfc_expr *e)
       else
 	return MATCH_YES;
     }
- 
+
   if (i == INTRINSIC_USER)
     {
       for (ns = gfc_current_ns; ns; ns = ns->parent)
@@ -4148,60 +4197,60 @@ gfc_add_interface (gfc_symbol *new_sym)
 	  {
 	    case INTRINSIC_EQ:
 	    case INTRINSIC_EQ_OS:
-	      if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym, 
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
 					    gfc_current_locus)
-	          || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], 
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
 					       new_sym, gfc_current_locus))
 		return false;
 	      break;
 
 	    case INTRINSIC_NE:
 	    case INTRINSIC_NE_OS:
-	      if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym, 
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
 					    gfc_current_locus)
-	          || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], 
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
 					       new_sym, gfc_current_locus))
 		return false;
 	      break;
 
 	    case INTRINSIC_GT:
 	    case INTRINSIC_GT_OS:
-	      if (!gfc_check_new_interface (ns->op[INTRINSIC_GT], 
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
 					    new_sym, gfc_current_locus)
-	          || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], 
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
 					       new_sym, gfc_current_locus))
 		return false;
 	      break;
 
 	    case INTRINSIC_GE:
 	    case INTRINSIC_GE_OS:
-	      if (!gfc_check_new_interface (ns->op[INTRINSIC_GE], 
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
 					    new_sym, gfc_current_locus)
-	          || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], 
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
 					       new_sym, gfc_current_locus))
 		return false;
 	      break;
 
 	    case INTRINSIC_LT:
 	    case INTRINSIC_LT_OS:
-	      if (!gfc_check_new_interface (ns->op[INTRINSIC_LT], 
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
 					    new_sym, gfc_current_locus)
-	          || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], 
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
 					       new_sym, gfc_current_locus))
 		return false;
 	      break;
 
 	    case INTRINSIC_LE:
 	    case INTRINSIC_LE_OS:
-	      if (!gfc_check_new_interface (ns->op[INTRINSIC_LE], 
+	      if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
 					    new_sym, gfc_current_locus)
-	          || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], 
+	          || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
 					       new_sym, gfc_current_locus))
 		return false;
 	      break;
 
 	    default:
-	      if (!gfc_check_new_interface (ns->op[current_interface.op], 
+	      if (!gfc_check_new_interface (ns->op[current_interface.op],
 					    new_sym, gfc_current_locus))
 		return false;
 	  }
@@ -4210,13 +4259,14 @@ gfc_add_interface (gfc_symbol *new_sym)
       break;
 
     case INTERFACE_GENERIC:
+    case INTERFACE_DTIO:
       for (ns = current_interface.ns; ns; ns = ns->parent)
 	{
 	  gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
 	  if (sym == NULL)
 	    continue;
 
-	  if (!gfc_check_new_interface (sym->generic, 
+	  if (!gfc_check_new_interface (sym->generic,
 					new_sym, gfc_current_locus))
 	    return false;
 	}
@@ -4225,7 +4275,7 @@ gfc_add_interface (gfc_symbol *new_sym)
       break;
 
     case INTERFACE_USER_OP:
-      if (!gfc_check_new_interface (current_interface.uop->op, 
+      if (!gfc_check_new_interface (current_interface.uop->op,
 				    new_sym, gfc_current_locus))
 	return false;
 
@@ -4257,6 +4307,7 @@ gfc_current_interface_head (void)
 	break;
 
       case INTERFACE_GENERIC:
+      case INTERFACE_DTIO:
 	return current_interface.sym->generic;
 	break;
 
@@ -4280,6 +4331,7 @@ gfc_set_current_interface_head (gfc_interface *i)
 	break;
 
       case INTERFACE_GENERIC:
+      case INTERFACE_DTIO:
 	current_interface.sym->generic = i;
 	break;
 
@@ -4496,3 +4548,310 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
 
   return true;
 }
+
+
+/* The following three functions check that the formal arguments
+   of user defined derived type IO procedures are compliant with
+   the requirements of the standard.  */
+
+static void
+check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
+			   int kind, int rank, sym_intent intent)
+{
+  if (fsym->ts.type != type)
+    gfc_error ("DTIO dummy argument at %L must be of type %s",
+	       &fsym->declared_at, gfc_basic_typename (type));
+
+  if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED
+      && fsym->ts.kind != kind)
+    gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
+	       &fsym->declared_at, kind);
+
+  if (!typebound
+      && rank == 0
+      && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension)
+	  || ((type != BT_CLASS) && fsym->attr.dimension)))
+    gfc_error ("DTIO dummy argument at %L be a scalar",
+	       &fsym->declared_at);
+  else if (rank == 1
+	   && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
+    gfc_error ("DTIO dummy argument at %L must be an "
+	       "ASSUMED SHAPE ARRAY", &fsym->declared_at);
+
+  if (fsym->attr.intent != intent)
+    gfc_error ("DTIO dummy argument at %L must have intent %s",
+	       &fsym->declared_at, gfc_code2string (intents, (int)intent));
+  return;
+}
+
+
+static void
+check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
+		       bool typebound, bool formatted, int code)
+{
+  gfc_symbol *dtio_sub, *generic_proc, *fsym;
+  gfc_typebound_proc *tb_io_proc, *specific_proc;
+  gfc_interface *intr;
+  gfc_formal_arglist *formal;
+  int arg_num;
+
+  bool read = ((dtio_codes)code == DTIO_RF)
+	       || ((dtio_codes)code == DTIO_RUF);
+  bt type;
+  sym_intent intent;
+  int kind;
+
+  dtio_sub = NULL;
+  if (typebound)
+    {
+      /* Typebound DTIO binding.  */
+      tb_io_proc = tb_io_st->n.tb;
+      gcc_assert (tb_io_proc != NULL);
+      gcc_assert (tb_io_proc->is_generic);
+      gcc_assert (tb_io_proc->u.generic->next == NULL);
+
+      specific_proc = tb_io_proc->u.generic->specific;
+      gcc_assert (!specific_proc->is_generic);
+
+      dtio_sub = specific_proc->u.specific->n.sym;
+    }
+  else
+    {
+      generic_proc = tb_io_st->n.sym;
+      gcc_assert (generic_proc);
+      gcc_assert (generic_proc->generic);
+
+      for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
+	{
+	  if (intr->sym && intr->sym->formal
+	      && ((intr->sym->formal->sym->ts.type == BT_CLASS
+	           && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
+							     == derived)
+		  || (intr->sym->formal->sym->ts.type == BT_DERIVED
+		      && intr->sym->formal->sym->ts.u.derived == derived)))
+	    {
+	      dtio_sub = intr->sym;
+	      break;
+	    }
+	}
+
+      if (dtio_sub == NULL)
+	return;
+    }
+
+  gcc_assert (dtio_sub);
+  if (!dtio_sub->attr.subroutine)
+    gfc_error ("DTIO procedure %s at %L must be a subroutine",
+	       dtio_sub->name, &dtio_sub->declared_at);
+
+  /* Now go through the formal arglist.  */
+  arg_num = 1;
+  for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
+    {
+      if (!formatted && arg_num == 3)
+	arg_num = 5;
+      fsym = formal->sym;
+      switch (arg_num)
+	{
+	case(1):			/* DTV  */
+	  type = derived->attr.sequence || derived->attr.is_bind_c ?
+		 BT_DERIVED : BT_CLASS;
+	  kind = 0;
+	  intent = read ? INTENT_INOUT : INTENT_IN;
+	  check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+				     0, intent);
+	  break;
+
+	case(2):			/* UNIT  */
+	  type = BT_INTEGER;
+	  kind = gfc_default_integer_kind;
+	  intent = INTENT_IN;
+	  check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+				     0, intent);
+	  break;
+	case(3):			/* IOTYPE  */
+	  type = BT_CHARACTER;
+	  kind = gfc_default_character_kind;
+	  intent = INTENT_IN;
+	  check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+				     0, intent);
+	  break;
+	case(4):			/* VLIST  */
+	  type = BT_INTEGER;
+	  kind = gfc_default_integer_kind;
+	  intent = INTENT_IN;
+	  check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+				     1, intent);
+	  break;
+	case(5):			/* IOSTAT  */
+	  type = BT_INTEGER;
+	  kind = gfc_default_integer_kind;
+	  intent = INTENT_OUT;
+	  check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+				     0, intent);
+	  break;
+	case(6):			/* IOMSG  */
+	  type = BT_CHARACTER;
+	  kind = gfc_default_character_kind;
+	  intent = INTENT_INOUT;
+	  check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+				     0, intent);
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+    }
+  derived->attr.has_dtio_procs = 1;
+  return;
+}
+
+void
+gfc_check_dtio_interfaces (gfc_symbol *derived)
+{
+  gfc_symtree *tb_io_st;
+  bool t = false;
+  int code;
+  bool formatted;
+
+  if (derived->attr.is_class == 1 || derived->attr.vtype == 1)
+    return;
+
+  /* Check typebound DTIO bindings.  */
+  for (code = 0; code < 4; code++)
+    {
+      formatted = ((dtio_codes)code == DTIO_RF)
+		   || ((dtio_codes)code == DTIO_WF);
+
+      tb_io_st = gfc_find_typebound_proc (derived, &t,
+					  gfc_code2string (dtio_procs, code),
+					  true, &derived->declared_at);
+      if (tb_io_st != NULL)
+	check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
+    }
+
+  /* Check generic DTIO interfaces.  */
+  for (code = 0; code < 4; code++)
+    {
+      formatted = ((dtio_codes)code == DTIO_RF)
+		   || ((dtio_codes)code == DTIO_WF);
+
+      tb_io_st = gfc_find_symtree (derived->ns->sym_root,
+				   gfc_code2string (dtio_procs, code));
+      if (tb_io_st != NULL)
+	check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
+    }
+}
+
+
+gfc_symbol *
+gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
+{
+  gfc_symtree *tb_io_st = NULL;
+  gfc_symbol *dtio_sub = NULL;
+  gfc_symbol *extended;
+  gfc_typebound_proc *tb_io_proc, *specific_proc;
+  bool t = false;
+
+  /* Try to find a typebound DTIO binding.  */
+  if (formatted == true)
+    {
+      if (write == true)
+        tb_io_st = gfc_find_typebound_proc (derived, &t,
+					    gfc_code2string (dtio_procs,
+							     DTIO_WF),
+					    true,
+					    &derived->declared_at);
+      else
+        tb_io_st = gfc_find_typebound_proc (derived, &t,
+					    gfc_code2string (dtio_procs,
+							     DTIO_RF),
+					    true,
+					    &derived->declared_at);
+    }
+  else
+    {
+      if (write == true)
+        tb_io_st = gfc_find_typebound_proc (derived, &t,
+					    gfc_code2string (dtio_procs,
+							     DTIO_WUF),
+					    true,
+					    &derived->declared_at);
+      else
+        tb_io_st = gfc_find_typebound_proc (derived, &t,
+					    gfc_code2string (dtio_procs,
+							     DTIO_RUF),
+					    true,
+					    &derived->declared_at);
+    }
+
+  if (tb_io_st != NULL)
+    {
+      tb_io_proc = tb_io_st->n.tb;
+      gcc_assert (tb_io_proc != NULL);
+      gcc_assert (tb_io_proc->is_generic);
+      gcc_assert (tb_io_proc->u.generic->next == NULL);
+
+      specific_proc = tb_io_proc->u.generic->specific;
+      gcc_assert (!specific_proc->is_generic);
+
+      dtio_sub = specific_proc->u.specific->n.sym;
+    }
+
+  if (tb_io_st != NULL)
+    goto finish;
+
+  /* If there is not a typebound binding, look for a generic
+     DTIO interface.  */
+  for (extended = derived; extended;
+       extended = gfc_get_derived_super_type (extended))
+    {
+      if (formatted == true)
+	{
+	  if (write == true)
+	    tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+					 gfc_code2string (dtio_procs,
+							  DTIO_WF));
+	  else
+	    tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+					 gfc_code2string (dtio_procs,
+							  DTIO_RF));
+	}
+      else
+	{
+	  if (write == true)
+	    tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+					 gfc_code2string (dtio_procs,
+							  DTIO_WUF));
+	  else
+	    tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+					 gfc_code2string (dtio_procs,
+							  DTIO_RUF));
+	}
+
+      if (tb_io_st != NULL
+	  && tb_io_st->n.sym
+	  && tb_io_st->n.sym->generic)
+	{
+	  gfc_interface *intr;
+	  for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
+	    {
+	      gfc_symbol *fsym = intr->sym->formal->sym;
+	      if (intr->sym && intr->sym->formal
+		  && ((fsym->ts.type == BT_CLASS
+		      && CLASS_DATA (fsym)->ts.u.derived == extended)
+		    || (fsym->ts.type == BT_DERIVED
+			&& fsym->ts.u.derived == extended)))
+		{
+		  dtio_sub = intr->sym;
+		  break;
+		}
+	    }
+	}
+    }
+
+finish:
+  if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
+    gfc_find_derived_vtab (derived);
+
+  return dtio_sub;
+}
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 0881261..53037e2 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -113,7 +113,7 @@ enum format_token
   FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
   FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
   FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
-  FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
+  FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
 };
 
 /* Local variables for checking format strings.  The saved_token is
@@ -463,6 +463,44 @@ format_lex (void)
 	    return FMT_ERROR;
 	  token = FMT_DC;
 	}
+      else if (c == 'T')
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DT format "
+	      "specifier not allowed at %C"))
+	    return FMT_ERROR;
+	  token = FMT_DT;
+	  c = next_char_not_space (&error);
+	  if (c == '\'' || c == '"')
+	    {
+	      delim = c;
+	      value = 0;
+
+	      for (;;)
+		{
+		  c = next_char (INSTRING_WARN);
+		  if (c == '\0')
+		    {
+		      token = FMT_END;
+		      break;
+		    }
+
+		  if (c == delim)
+		    {
+		      c = next_char (NONSTRING);
+
+		      if (c == '\0')
+			{
+			  token = FMT_END;
+			  break;
+			}
+		      unget_char ();
+		      break;
+		    }
+		}
+	    }
+	  else
+	    unget_char ();
+	}
       else
 	{
 	  token = FMT_D;
@@ -652,6 +690,54 @@ format_item_1:
 	return false;
       goto between_desc;
 
+    case FMT_DT:
+      t = format_lex ();
+      if (t == FMT_ERROR)
+	goto fail;
+      switch (t)
+	{
+	case FMT_RPAREN:
+	  level--;
+	  if (level < 0)
+	    goto finished;
+	  goto between_desc;
+
+	case FMT_COMMA:
+	  goto format_item;
+
+	case FMT_LPAREN:
+
+  dtio_vlist:
+	  t = format_lex ();
+	  if (t == FMT_ERROR)
+	    goto fail;
+
+	  if (t != FMT_POSINT)
+	    {
+	      error = posint_required;
+	      goto syntax;
+	    }
+
+	  t = format_lex ();
+	  if (t == FMT_ERROR)
+	    goto fail;
+
+	  if (t == FMT_COMMA)
+	    goto dtio_vlist;
+	  if (t != FMT_RPAREN)
+	    {
+	      error = _("Right parenthesis expected at %C");
+	      goto syntax;
+	    }
+	  goto between_desc;
+
+	default:
+	  error = unexpected_element;
+	  goto syntax;
+	}
+
+      goto format_item;
+
     case FMT_SIGN:
     case FMT_BLANK:
     case FMT_DP:
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index f3a4a43..9056cb7 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -102,6 +102,12 @@ gfc_op2string (gfc_intrinsic_op op)
     case INTRINSIC_NONE:
       return "none";
 
+    /* DTIO  */
+    case INTRINSIC_FORMATTED:
+      return "formatted";
+    case INTRINSIC_UNFORMATTED:
+      return "unformatted";
+
     default:
       break;
     }
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 0a92efe..72be6e5 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6689,6 +6689,11 @@ derived_inaccessible (gfc_symbol *sym)
 
   for (c = sym->components; c; c = c->next)
     {
+	/* Prevent an infinite loop through this function.  */
+	if (c->ts.type == BT_DERIVED && c->attr.pointer
+	    && sym == c->ts.u.derived)
+	  continue;
+
 	if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
 	  return 1;
     }
@@ -8642,9 +8647,13 @@ static void
 resolve_transfer (gfc_code *code)
 {
   gfc_typespec *ts;
-  gfc_symbol *sym;
+  gfc_symbol *sym, *derived;
   gfc_ref *ref;
   gfc_expr *exp;
+  bool write = false;
+  bool formatted = false;
+  gfc_dt *dt = code->ext.dt;
+  gfc_symbol *dtio_sub = NULL;
 
   exp = code->expr1;
 
@@ -8668,7 +8677,7 @@ resolve_transfer (gfc_code *code)
   /* If we are reading, the variable will be changed.  Note that
      code->ext.dt may be NULL if the TRANSFER is related to
      an INQUIRE statement -- but in this case, we are not reading, either.  */
-  if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
+  if (dt && dt->dt_io_kind->value.iokind == M_READ
       && !gfc_check_vardef_context (exp, false, false, false,
 				    _("item in READ")))
     return;
@@ -8680,9 +8689,53 @@ resolve_transfer (gfc_code *code)
     if (ref->type == REF_COMPONENT)
       ts = &ref->u.c.component->ts;
 
-  if (ts->type == BT_CLASS)
+  if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
+      && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
+    {
+      if (ts->type == BT_DERIVED)
+	derived = ts->u.derived;
+      else
+	derived = ts->u.derived->components->ts.u.derived;
+
+      if (dt->format_expr)
+	{
+	  char *fmt;
+	  fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
+				      -1);
+	  if (strtok (fmt, "DT") != NULL)
+	    formatted = true;
+	}
+      else if (dt->format_label == &format_asterisk)
+	{
+	  /* List directed io must call the formatted DTIO procedure.  */
+	  formatted = true;
+	}
+
+      write = dt->dt_io_kind->value.iokind == M_WRITE
+	      || dt->dt_io_kind->value.iokind == M_PRINT;
+      dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
+
+      if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
+	{
+	  sym = exp->symtree->n.sym->ns->proc_name;
+	  /* Check to see if this is a nested DTIO call, with the
+	     dummy as the io-list object.  */
+	  if (sym && sym == dtio_sub && sym->formal
+	      && sym->formal->sym == exp->symtree->n.sym
+	      && exp->ref == NULL)
+	    {
+	      if (!sym->attr.recursive)
+		{
+		  gfc_error ("DTIO %s procedure at %L must be recursive",
+			     sym->name, &sym->declared_at);
+		  return;
+		}
+	    }
+	}
+    }
+
+  if (ts->type == BT_CLASS && dtio_sub == NULL)
     {
-      /* FIXME: Test for defined input/output.  */
       gfc_error ("Data transfer element at %L cannot be polymorphic unless "
                 "it is processed by a defined input/output procedure",
                 &code->loc);
@@ -8692,8 +8745,9 @@ resolve_transfer (gfc_code *code)
   if (ts->type == BT_DERIVED)
     {
       /* Check that transferred derived type doesn't contain POINTER
-	 components.  */
-      if (ts->u.derived->attr.pointer_comp)
+	 components unless it is processed by a defined input/output
+	 procedure".  */
+      if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
 	{
 	  gfc_error ("Data transfer element at %L cannot have POINTER "
 		     "components unless it is processed by a defined "
@@ -8709,7 +8763,7 @@ resolve_transfer (gfc_code *code)
 	  return;
 	}
 
-      if (ts->u.derived->attr.alloc_comp)
+      if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
 	{
 	  gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
 		     "components unless it is processed by a defined "
@@ -8726,10 +8780,11 @@ resolve_transfer (gfc_code *code)
 			       "cannot have PRIVATE components", &code->loc))
 	    return;
 	}
-      else if (derived_inaccessible (ts->u.derived))
+      else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
 	{
 	  gfc_error ("Data transfer element at %L cannot have "
-		     "PRIVATE components",&code->loc);
+		     "PRIVATE components unless it is processed by "
+		     "a defined input/output procedure", &code->loc);
 	  return;
 	}
     }
@@ -10901,6 +10956,21 @@ resolve_bind_c_derived_types (gfc_symbol *derived_sym)
 }
 
 
+/* Check the interfaces of DTIO procedures associated with derived
+   type 'sym'.  These procedures can either have typebound bindings or
+   can appear in DTIO generic interfaces.  */
+
+static void
+gfc_verify_DTIO_procedures (gfc_symbol *sym)
+{
+  if (!sym || sym->attr.flavor != FL_DERIVED)
+    return;
+
+  gfc_check_dtio_interfaces (sym);
+
+  return;
+}
+
 /* Verify that any binding labels used in a given namespace do not collide
    with the names or binding labels of any global symbols.  Multiple INTERFACE
    for the same procedure are permitted.  */
@@ -13421,11 +13491,31 @@ resolve_fl_derived (gfc_symbol *sym)
 }
 
 
+/* Check for formatted read and write DTIO procedures.  */
+
+static bool
+dtio_procs_present (gfc_symbol *sym)
+{
+  gfc_symbol *derived;
+
+  if (sym->ts.type == BT_CLASS)
+    derived = CLASS_DATA (sym)->ts.u.derived;
+  else if (sym->ts.type == BT_DERIVED)
+    derived = sym->ts.u.derived;
+  else
+    return false;
+
+  return gfc_find_specific_dtio_proc (derived, true, true) != NULL
+	 && gfc_find_specific_dtio_proc (derived, false, true) != NULL;
+}
+
+
 static bool
 resolve_fl_namelist (gfc_symbol *sym)
 {
   gfc_namelist *nl;
   gfc_symbol *nlsym;
+  bool dtio;
 
   for (nl = sym->namelist; nl; nl = nl->next)
     {
@@ -13459,9 +13549,9 @@ resolve_fl_namelist (gfc_symbol *sym)
 			      sym->name, &sym->declared_at))
 	return false;
 
-      /* FIXME: Once UDDTIO is implemented, the following can be
-	 removed.  */
-      if (nl->sym->ts.type == BT_CLASS)
+      dtio = dtio_procs_present (nl->sym);
+
+      if (nl->sym->ts.type == BT_CLASS && !dtio)
 	{
 	  gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
 		     "polymorphic and requires a defined input/output "
@@ -13479,13 +13569,14 @@ resolve_fl_namelist (gfc_symbol *sym)
 			       sym->name, &sym->declared_at))
 	    return false;
 
-	 /* FIXME: Once UDDTIO is implemented, the following can be
-	    removed.  */
-	  gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
-		     "ALLOCATABLE or POINTER components and thus requires "
-		     "a defined input/output procedure", nl->sym->name,
-		     sym->name, &sym->declared_at);
-	  return false;
+	  if (!dtio)
+	    {
+	      gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
+			"ALLOCATABLE or POINTER components and thus requires "
+			"a defined input/output procedure", nl->sym->name,
+			sym->name, &sym->declared_at);
+	      return false;
+	    }
 	}
     }
 
@@ -13504,6 +13595,11 @@ resolve_fl_namelist (gfc_symbol *sym)
 	      return false;
 	    }
 
+	  /* If the derived type has specific DTIO procedures for both read and
+	     write then namelist objects with private components are OK.  */
+	  if (dtio_procs_present (nl->sym))
+	    continue;
+
 	  /* Types with private components that came here by USE-association.  */
 	  if (nl->sym->ts.type == BT_DERIVED
 	      && derived_inaccessible (nl->sym->ts.u.derived))
@@ -15527,6 +15623,8 @@ resolve_types (gfc_namespace *ns)
 
   gfc_resolve_uops (ns->uop_root);
 
+  gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
+
   gfc_resolve_omp_declare_simd (ns);
 
   gfc_resolve_omp_udrs (ns->omp_udr_root);
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index c967f25..1b94622 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -87,6 +87,15 @@ const mstring save_status[] =
     minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
 };
 
+/* Set the mstrings for DTIO procedure names.  */
+const mstring dtio_procs[] =
+{
+    minit ("_dtio_formatted_read", DTIO_RF),
+    minit ("_dtio_formatted_write", DTIO_WF),
+    minit ("_dtio_unformatted_read", DTIO_RUF),
+    minit ("_dtio_unformatted_write", DTIO_WUF),
+};
+
 /* This is to make sure the backend generates setup code in the correct
    order.  */
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 96d413e..5bae8ca 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -638,6 +638,16 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 		&& sym->attr.codimension && !sym->attr.allocatable)))
     TREE_STATIC (decl) = 1;
 
+  /* If derived-type variables with DTIO procedures are not made static
+     some bits of code referencing them get optimized away.
+     TODO Understand why this is so and fix it.  */
+  if (!sym->attr.use_assoc
+      && ((sym->ts.type == BT_DERIVED
+           && sym->ts.u.derived->attr.has_dtio_procs)
+	  || (sym->ts.type == BT_CLASS
+	      && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
+    TREE_STATIC (decl) = 1;
+
   if (sym->attr.volatile_)
     {
       TREE_THIS_VOLATILE (decl) = 1;
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e3559f4..19239fb 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -430,9 +430,17 @@ gfc_get_vptr_from_expr (tree expr)
 	  else
 	    type = NULL_TREE;
 	}
-      if (TREE_CODE (tmp) == VAR_DECL)
+      if (TREE_CODE (tmp) == VAR_DECL
+	  || TREE_CODE (tmp) == PARM_DECL)
 	break;
     }
+
+  if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+
+  if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+    return gfc_class_vptr_get (tmp);
+
   return NULL_TREE;
 }
 
@@ -511,7 +519,14 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
   if (optional)
     cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
 
-  if (parmse->ss && parmse->ss->info->useflags)
+  if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+    {
+      /* If there is a ready made pointer to a derived type, use it
+	 rather than evaluating the expression again.  */
+      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+      gfc_add_modify (&parmse->pre, ctree, tmp);
+    }
+  else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
     {
       /* For an array reference in an elemental procedure call we need
 	 to retain the ss to provide the scalarized array reference.  */
@@ -522,7 +537,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 			  cond_optional, tmp,
 			  fold_convert (TREE_TYPE (tmp), null_pointer_node));
       gfc_add_modify (&parmse->pre, ctree, tmp);
-
     }
   else
     {
@@ -2319,7 +2333,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
      On the other hand, if the context is a UNION or a MAP (a
      RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL.  */
 
-  if (context != TREE_TYPE (decl) 
+  if (context != TREE_TYPE (decl)
       && !(   TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
            || TREE_CODE (context) == UNION_TYPE))         /* Field is map */
     {
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index aefa96d..2c84349 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -132,6 +132,7 @@ enum iocall
   IOCALL_X_COMPLEX128_WRITE,
   IOCALL_X_ARRAY,
   IOCALL_X_ARRAY_WRITE,
+  IOCALL_X_DERIVED,
   IOCALL_OPEN,
   IOCALL_CLOSE,
   IOCALL_INQUIRE,
@@ -142,6 +143,7 @@ enum iocall
   IOCALL_ENDFILE,
   IOCALL_FLUSH,
   IOCALL_SET_NML_VAL,
+  IOCALL_SET_NML_DTIO_VAL,
   IOCALL_SET_NML_VAL_DIM,
   IOCALL_WAIT,
   IOCALL_NUM
@@ -397,6 +399,10 @@ gfc_build_io_library_fndecls (void)
 	void_type_node, 4, dt_parm_type, pvoid_type_node,
 	integer_type_node, gfc_charlen_type_node);
 
+  iocall[IOCALL_X_DERIVED] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("transfer_derived")), ".wrR",
+	void_type_node, 2, dt_parm_type, pvoid_type_node, pchar_type_node);
+
   /* Library entry points */
 
   iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
@@ -468,6 +474,12 @@ gfc_build_io_library_fndecls (void)
 	void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
 	gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node);
 
+  iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R",
+	void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node,
+	gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node,
+	pvoid_type_node, pvoid_type_node);
+
   iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
 	void_type_node, 5, dt_parm_type, gfc_int4_type_node,
@@ -475,12 +487,8 @@ gfc_build_io_library_fndecls (void)
 }
 
 
-/* Generate code to store an integer constant into the
-   st_parameter_XXX structure.  */
-
-static unsigned int
-set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
-		     unsigned int val)
+static void
+set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value)
 {
   tree tmp;
   gfc_st_parameter_field *p = &st_parameter_field[type];
@@ -491,7 +499,21 @@ set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
 			   var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
 			 var, p->field, NULL_TREE);
-  gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
+  gfc_add_modify (block, tmp, value);
+}
+
+
+/* Generate code to store an integer constant into the
+   st_parameter_XXX structure.  */
+
+static unsigned int
+set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
+		     unsigned int val)
+{
+  gfc_st_parameter_field *p = &st_parameter_field[type];
+
+  set_parameter_tree (block, var, type,
+		      build_int_cst (TREE_TYPE (p->field), val));
   return p->mask;
 }
 
@@ -637,7 +659,7 @@ set_parameter_value_inquire (stmtblock_t *block, tree var,
 
       body = gfc_finish_block (&newblock);
 
-      cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);    
+      cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
       var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
       gfc_add_expr_to_block (&se.pre, var);
     }
@@ -697,13 +719,7 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
       gfc_add_modify (postblock, se.expr, tmp);
      }
 
-  if (p->param_type == IOPARM_ptype_common)
-    var = fold_build3_loc (input_location, COMPONENT_REF,
-			   st_parameter[IOPARM_ptype_common].type,
-			   var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
-  tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
-			 var, p->field, NULL_TREE);
-  gfc_add_modify (block, tmp, addr);
+  set_parameter_tree (block, var, type, addr);
   return p->mask;
 }
 
@@ -1618,6 +1634,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
   tree dt_parm_addr;
   tree decl = NULL_TREE;
   tree gfc_int4_type_node = gfc_get_int_type (4);
+  tree dtio_proc = null_pointer_node;
+  tree vtable = null_pointer_node;
   int n_dim;
   int itype;
   int rank = 0;
@@ -1659,15 +1677,45 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
 
   dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
 
+  /* 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)
+    {
+      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)
+	{
+	  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);
+	}
+    }
+
   if (ts->type == BT_CHARACTER)
     tmp = ts->u.cl->backend_decl;
   else
     tmp = build_int_cst (gfc_charlen_type_node, 0);
-  tmp = build_call_expr_loc (input_location,
-			 iocall[IOCALL_SET_NML_VAL], 6,
-			 dt_parm_addr, addr_expr, string,
-			 build_int_cst (gfc_int4_type_node, ts->kind),
-			 tmp, dtype);
+
+  if (dtio_proc == NULL_TREE)
+    tmp = build_call_expr_loc (input_location,
+			   iocall[IOCALL_SET_NML_VAL], 6,
+			   dt_parm_addr, addr_expr, string,
+			   build_int_cst (gfc_int4_type_node, ts->kind),
+			   tmp, dtype);
+  else
+    tmp = build_call_expr_loc (input_location,
+			   iocall[IOCALL_SET_NML_DTIO_VAL], 8,
+			   dt_parm_addr, addr_expr, string,
+			   build_int_cst (gfc_int4_type_node, ts->kind),
+			   tmp, dtype, dtio_proc, vtable);
   gfc_add_expr_to_block (block, tmp);
 
   /* If the object is an array, transfer rank times:
@@ -1685,7 +1733,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
       gfc_add_expr_to_block (block, tmp);
     }
 
-  if (gfc_bt_struct (ts->type) && ts->u.derived->components)
+  if (gfc_bt_struct (ts->type) && ts->u.derived->components
+      && dtio_proc == null_pointer_node)
     {
       gfc_component *cmp;
 
@@ -1995,7 +2044,8 @@ gfc_trans_dt_end (gfc_code * code)
 }
 
 static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
+	       gfc_code * code, tree vptr);
 
 /* Given an array field in a derived type variable, generate the code
    for the loop that iterates over array elements, and the code that
@@ -2061,7 +2111,7 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where)
   /* Now se.expr contains an element of the array.  Take the address and pass
      it to the IO routines.  */
   tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
-  transfer_expr (&se, &cm->ts, tmp, NULL);
+  transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
 
   /* We are done now with the loop body.  Wrap up the scalarizer and
      return.  */
@@ -2081,10 +2131,53 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where)
   return gfc_finish_block (&block);
 }
 
+
+/* Helper function for transfer_expr that looks for the DTIO procedure
+   either as a typebound binding or in a generic interface. If present,
+   the address expression of the procedure is returned. It is assumed
+   that the procedure interface has been checked during resolution.  */
+
+static tree
+get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
+{
+  gfc_symbol *derived;
+  bool formatted = false;
+  gfc_dt *dt = code->ext.dt;
+
+  if (dt && dt->format_expr)
+    {
+      char *fmt;
+      fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
+				  -1);
+      if (strtok (fmt, "DT") != NULL)
+	formatted = true;
+    }
+  else if (dt && dt->format_label == &format_asterisk)
+    {
+      /* List directed io must call the formatted DTIO procedure.  */
+      formatted = true;
+    }
+
+  if (ts->type == BT_DERIVED)
+    derived = ts->u.derived;
+  else
+    derived = ts->u.derived->components->ts.u.derived;
+
+  *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
+					   formatted);
+
+  if (*dtio_sub)
+    return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
+
+  return NULL_TREE;
+
+}
+
 /* Generate the call for a scalar transfer node.  */
 
 static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
+	       gfc_code * code, tree vptr)
 {
   tree tmp, function, arg2, arg3, field, expr;
   gfc_component *c;
@@ -2212,43 +2305,81 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
       break;
 
     case_bt_struct:
+    case BT_CLASS:
       if (ts->u.derived->components == NULL)
 	return;
+      if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
+	{
+	  gfc_symbol *derived;
+	  gfc_symbol *dtio_sub = NULL;
+	  /* Test for a specific DTIO subroutine.  */
+	  if (ts->type == BT_DERIVED)
+	    derived = ts->u.derived;
+	  else
+	    derived = ts->u.derived->components->ts.u.derived;
 
-      /* Recurse into the elements of the derived type.  */
-      expr = gfc_evaluate_now (addr_expr, &se->pre);
-      expr = build_fold_indirect_ref_loc (input_location,
-				      expr);
+	  if (derived->attr.has_dtio_procs)
+	    arg2 = get_dtio_proc (ts, code, &dtio_sub);
 
-      /* Make sure that the derived type has been built.  An external
-	 function, if only referenced in an io statement, requires this
-	 check (see PR58771).  */
-      if (ts->u.derived->backend_decl == NULL_TREE)
-	(void) gfc_typenode_for_spec (ts);
+	  if (dtio_sub != NULL)
+	    {
+	      tree decl;
+	      decl = build_fold_indirect_ref_loc (input_location,
+						  se->expr);
+	      /* Remember that the first dummy of the DTIO subroutines
+		 is CLASS(derived) for extensible derived types, so the
+		 conversion must be done here for derived type and for
+		 scalarized CLASS array element io-list objects.  */
+	      if ((ts->type == BT_DERIVED
+		   && !(ts->u.derived->attr.sequence
+			|| ts->u.derived->attr.is_bind_c))
+		  || (ts->type == BT_CLASS
+		      && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
+		gfc_conv_derived_to_class (se, code->expr1,
+					   dtio_sub->formal->sym->ts,
+					   vptr, false, false);
+	      addr_expr = se->expr;
+	      function = iocall[IOCALL_X_DERIVED];
+	      break;
+	    }
+	  else if (ts->type == BT_DERIVED)
+	    {
+	      /* Recurse into the elements of the derived type.  */
+	      expr = gfc_evaluate_now (addr_expr, &se->pre);
+	      expr = build_fold_indirect_ref_loc (input_location,
+				      expr);
 
-      for (c = ts->u.derived->components; c; c = c->next)
-	{
-	  field = c->backend_decl;
-	  gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
-
-	  tmp = fold_build3_loc (UNKNOWN_LOCATION,
-			     COMPONENT_REF, TREE_TYPE (field),
-			     expr, field, NULL_TREE);
-
-          if (c->attr.dimension)
-            {
-              tmp = transfer_array_component (tmp, c, & code->loc);
-              gfc_add_expr_to_block (&se->pre, tmp);
-            }
-          else
-            {
-              if (!c->attr.pointer)
-                tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-              transfer_expr (se, &c->ts, tmp, code);
-            }
+	      /* Make sure that the derived type has been built.  An external
+		 function, if only referenced in an io statement, requires this
+		 check (see PR58771).  */
+	      if (ts->u.derived->backend_decl == NULL_TREE)
+		(void) gfc_typenode_for_spec (ts);
+
+	      for (c = ts->u.derived->components; c; c = c->next)
+		{
+		  field = c->backend_decl;
+		  gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+
+		  tmp = fold_build3_loc (UNKNOWN_LOCATION,
+					 COMPONENT_REF, TREE_TYPE (field),
+					 expr, field, NULL_TREE);
+
+		  if (c->attr.dimension)
+		    {
+		      tmp = transfer_array_component (tmp, c, & code->loc);
+		      gfc_add_expr_to_block (&se->pre, tmp);
+		    }
+		  else
+		    {
+		      if (!c->attr.pointer)
+			tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+		      transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
+		   }
+		}
+	      return;
+	    }
+	  /* If a CLASS object gets through to here, fall through and ICE.  */
 	}
-      return;
-
     default:
       gfc_internal_error ("Bad IO basetype (%d)", ts->type);
     }
@@ -2303,6 +2434,7 @@ gfc_trans_transfer (gfc_code * code)
   gfc_ss *ss;
   gfc_se se;
   tree tmp;
+  tree vptr;
   int n;
 
   gfc_start_block (&block);
@@ -2315,8 +2447,18 @@ gfc_trans_transfer (gfc_code * code)
   if (expr->rank == 0)
     {
       /* Transfer a scalar value.  */
-      gfc_conv_expr_reference (&se, expr);
-      transfer_expr (&se, &expr->ts, se.expr, code);
+      if (expr->ts.type == BT_CLASS)
+	{
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, expr);
+	  vptr = gfc_get_vptr_from_expr (se.expr);
+	}
+      else
+	{
+	  vptr = NULL_TREE;
+	  gfc_conv_expr_reference (&se, expr);
+	}
+      transfer_expr (&se, &expr->ts, se.expr, code, vptr);
     }
   else
     {
@@ -2330,7 +2472,8 @@ gfc_trans_transfer (gfc_code * code)
 	  gcc_assert (ref && ref->type == REF_ARRAY);
 	}
 
-      if (!gfc_bt_struct (expr->ts.type)
+      if (!(gfc_bt_struct (expr->ts.type)
+	      || expr->ts.type == BT_CLASS)
 	    && ref && ref->next == NULL
 	    && !is_subref_array (expr))
 	{
@@ -2378,9 +2521,12 @@ gfc_trans_transfer (gfc_code * code)
 
       gfc_copy_loopinfo_to_se (&se, &loop);
       se.ss = ss;
-
       gfc_conv_expr_reference (&se, expr);
-      transfer_expr (&se, &expr->ts, se.expr, code);
+      if (expr->ts.type == BT_CLASS)
+	vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
+      else
+	vptr = NULL_TREE;
+      transfer_expr (&se, &expr->ts, se.expr, code, vptr);
     }
 
  finish_block_label: