[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, 206 insertions, 60 deletions

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: