[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, 376 insertions, 17 deletions

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;
+}