RFC: Partial patch for DTIO

[Jerry DeLisle <jvdelisle at charter dot net>]

Hi all,

I wanted to get this patch out for comment for two reasons:

1. Make sure it does not get lost between now and when I get back to this.

2. See what others think of the approach to help determine where we go from here.

The patch provides most of the front-end parsing.  There still may need to be 
some error checking added.  I have only done a little testing.  I think it 
compiles still.

After I worked out the parsing, Michael helped with some front-end work which 
builds a call to a run-time library function to handle dispatching.  The 
run-time function is not implemented yet.

How can you help?  I need to make a punch list of items to complete (things I 
missed from the standard, etc)

At what point can we commit the front-end portion with perhaps a stub in the 
library so that test cases can start to be developed?

best Regards,

Jerry

Index: interface.c
===================================================================
--- interface.c	(revision 176360)
+++ interface.c	(working copy)
@@ -114,6 +114,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.  */
@@ -161,6 +174,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, "dtio_read_formatted");
+	  *type = INTERFACE_DTIO;
+	}
+      if (*op == INTRINSIC_UNFORMATTED)
+	{
+	  strcpy (name, "dtio_read_unformatted");
+	  *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, "dtio_write_formatted");
+	  *type = INTERFACE_DTIO;
+	}
+      if (*op == INTRINSIC_UNFORMATTED)
+	{
+	  strcpy (name, "dtio_write_unformatted");
+	  *type = INTERFACE_DTIO;
+	}
+      if (*op != INTRINSIC_NONE)
+	return MATCH_YES;
+    }
+
   if (gfc_match_name (buffer) == MATCH_YES)
     {
       strcpy (name, buffer);
@@ -208,7 +255,9 @@ gfc_match_interface (void)
 
   switch (type)
     {
+    case INTERFACE_DTIO:
     case INTERFACE_GENERIC:
+      printf("interface: name=%s\n", name);
       if (gfc_get_symbol (name, NULL, &sym))
 	return MATCH_ERROR;
 
@@ -367,6 +416,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)
Index: decl.c
===================================================================
--- decl.c	(revision 176360)
+++ decl.c	(working copy)
@@ -6467,6 +6467,7 @@ access_attr_decl (gfc_statement st)
 	  goto syntax;
 
 	case INTERFACE_GENERIC:
+	case INTERFACE_DTIO:
 	  if (gfc_get_symbol (name, NULL, &sym))
 	    goto done;
 
@@ -8050,7 +8051,9 @@ gfc_match_generic (void)
   switch (op_type)
     {
     case INTERFACE_GENERIC:
+    case INTERFACE_DTIO:
       snprintf (bind_name, sizeof (bind_name), "%s", name);
+      printf("bind name: %s\n", bind_name);
       break;
  
     case INTERFACE_USER_OP:
@@ -8080,6 +8083,7 @@ gfc_match_generic (void)
 
   switch (op_type)
     {
+    case INTERFACE_DTIO:
     case INTERFACE_USER_OP:
     case INTERFACE_GENERIC:
       {
@@ -8134,6 +8138,7 @@ gfc_match_generic (void)
 
       switch (op_type)
 	{
+	case INTERFACE_DTIO:
 	case INTERFACE_GENERIC:
 	case INTERFACE_USER_OP:
 	  {
Index: gfortran.h
===================================================================
--- gfortran.h	(revision 176360)
+++ gfortran.h	(working copy)
@@ -163,7 +163,10 @@ typedef enum
   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_PARENTHESES,
+  /* User defined derived type pseudo operator.  */
+  INTRINSIC_FORMATTED, INTRINSIC_UNFORMATTED,
+  GFC_INTRINSIC_END /* Sentinel */
 }
 gfc_intrinsic_op;
 
@@ -217,7 +220,8 @@ gfc_statement;
 typedef enum
 {
   INTERFACE_NAMELESS = 1, INTERFACE_GENERIC,
-  INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT
+  INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT,
+  INTERFACE_DTIO
 }
 interface_type;
 
Index: io.c
===================================================================
--- io.c	(revision 176360)
+++ io.c	(working copy)
@@ -113,7 +113,7 @@ typedef enum
   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
 }
 format_token;
 
@@ -462,6 +462,13 @@ 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") == FAILURE)
+	    return FMT_ERROR;
+	  token = FMT_DT;
+	}
       else
 	{
 	  token = FMT_D;
@@ -652,6 +659,54 @@ format_item_1:
 	return FAILURE;
       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:
Index: match.c
===================================================================
--- match.c	(revision 176360)
+++ match.c	(working copy)
@@ -100,6 +100,12 @@ gfc_op2string (gfc_intrinsic_op op)
     case INTRINSIC_PARENTHESES:
       return "parens";
 
+    /* DTIO  */
+    case INTRINSIC_FORMATTED:
+      return "formatted";
+    case INTRINSIC_UNFORMATTED:
+      return "unformatted";
+
     default:
       break;
     }
Index: trans-io.c
===================================================================
--- trans-io.c	(revision 176360)
+++ trans-io.c	(working copy)
@@ -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,
@@ -390,6 +391,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,12 +473,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];
@@ -484,7 +485,21 @@ gfc_build_io_library_fndecls (void)
 			   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;
 }
 
@@ -497,7 +512,6 @@ set_parameter_value (stmtblock_t *block, tree var,
 		     gfc_expr *e)
 {
   gfc_se se;
-  tree tmp;
   gfc_st_parameter_field *p = &st_parameter_field[type];
   tree dest_type = TREE_TYPE (p->field);
 
@@ -537,14 +551,7 @@ set_parameter_value (stmtblock_t *block, tree var,
   se.expr = convert (dest_type, se.expr);
   gfc_add_block_to_block (block, &se.pre);
 
-  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, dest_type, var,
-			 p->field, NULL_TREE);
-  gfc_add_modify (block, tmp, se.expr);
+  set_parameter_tree (block, var, type, se.expr);
   return p->mask;
 }
 
@@ -597,13 +604,7 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t
       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;
 }
 
@@ -1928,6 +1929,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tre
    recursive.  */
 
 static tree
+__attribute__((unused))
 transfer_array_component (tree expr, gfc_component * cm, locus * where)
 {
   tree tmp;
@@ -2013,8 +2015,10 @@ transfer_array_component (tree expr, gfc_component
 static void
 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
 {
-  tree tmp, function, arg2, arg3, field, expr;
+  tree tmp, function, arg2, arg3/* , field, expr */;
+#if 0
   gfc_component *c;
+#endif
   int kind;
 
   /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
@@ -2151,6 +2155,34 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tre
       break;
 
     case BT_DERIVED:
+      {
+	gfc_symbol *derived, *dtio_sub;
+	gfc_try t = SUCCESS;
+	gfc_symtree *tb_io_st;
+	gfc_typebound_proc *tb_io_proc, *specific_proc;
+
+	derived = ts->u.derived;
+	tb_io_st = gfc_find_typebound_proc (derived, &t,
+					    "dtio_write_unformatted",
+					    true, &derived->declared_at);
+	gcc_assert (tb_io_st != NULL);
+	gcc_assert (t == SUCCESS);
+
+	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;
+	arg2 = gfc_build_addr_expr (NULL, gfc_get_symbol_decl (dtio_sub));
+
+	function = iocall[IOCALL_X_DERIVED];
+      }
+      break;
+#if 0
       /* Recurse into the elements of the derived type.  */
       expr = gfc_evaluate_now (addr_expr, &se->pre);
       expr = build_fold_indirect_ref_loc (input_location,
@@ -2178,6 +2210,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tre
             }
 	}
       return;
+#endif
 
     default:
       internal_error ("Bad IO basetype (%d)", ts->type);