patch to gfortran: Unimplemented IO of derived types

[Victor Leikehman <LEI at il dot ibm dot com>]

This patch fixes "Unimplemented IO of derived types" error
message.

      Victor
--
  Victor Leikehman <lei@il.ibm.com>
  IBM Research Lab in Haifa, Israel
=========================================================
program derived_io
  character(100) :: buf1, buf2, buf3

  type xyz_type
     integer :: x
     character(11) :: y
     logical :: z
  end type xyz_type

  type abcdef_type
     integer :: a
     logical :: b
     type (xyz_type) :: c
     integer :: d
     real(4) :: e
     character(11) :: f
  end type abcdef_type

  type (xyz_type) xyz
  type (abcdef_type) abcdef

  xyz%x = 11111
  xyz%y = "hello world"
  xyz%z = .true.

  abcdef%a = 0
  abcdef%b = .true.
  abcdef%c%x = 111
  abcdef%c%y = "bzz booo"
  abcdef%c%z = .false.
  abcdef%d = 3
  abcdef%e = 4.0
  abcdef%f = "kawabanga"

  write (buf1, *), xyz%x, xyz%y, xyz%z
  write (buf2, *), xyz
  if (buf1.ne.buf2) call abort

  write (buf1, *), abcdef
  write (buf2, *), abcdef%a, abcdef%b, abcdef%c, abcdef%d, abcdef%e,
abcdef%f
  write (buf3, *), abcdef%a, abcdef%b, abcdef%c%x, abcdef%c%y, &
                   abcdef%c%z, abcdef%d, abcdef%e, abcdef%f
  if (buf1.ne.buf2) call abort
  if (buf1.ne.buf3) call abort

  call foo(xyz)

  contains

    subroutine foo(t)
      type (xyz_type) t
      write (buf1, *), t%x, t%y, t%z
      write (buf2, *), t
      if (buf1.ne.buf2) call abort
    end subroutine foo
end
=========================================================
2004-04-18  lei  <lei@il.ibm.com>
      * trans-io.c (transfer_expr): Implemented recursive printing
      of derived types.
=========================================================
--- trans-io.c.orig     2004-04-14 12:40:37.000000000 +0300
+++ trans-io.c    2004-04-18 10:16:48.000000000 +0300
@@ -1019,9 +1019,10 @@ gfc_trans_dt_end (gfc_code * code)
 /* Generate the call for a scalar transfer node.  */

 static void
-transfer_expr (gfc_se * se, gfc_typespec * ts)
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
 {
-  tree args, tmp, function, arg2;
+  tree args, tmp, function, arg2, field, expr;
+  gfc_component *c;
   int kind;

   kind = ts->kind;
@@ -1056,18 +1057,30 @@ transfer_expr (gfc_se * se, gfc_typespec
       break;

     case BT_DERIVED:
-      gfc_todo_error ("IO of derived types");
-
-      /* Store the address to a temporary, then recurse for each
-      element the type.  */
-
+      expr = gfc_build_indirect_ref (addr_expr);
+
+      for (c = ts->derived->components; c; c = c->next)
+     {
+       field = c->backend_decl;
+       assert (field && TREE_CODE (field) == FIELD_DECL);
+
+       tmp = build (COMPONENT_REF, TREE_TYPE (field), expr, field);
+
+       if (c->ts.type == BT_CHARACTER)
+         {
+           assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+           se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE
(tmp)));
+         }
+       transfer_expr (se, &c->ts, gfc_build_addr_expr (NULL,tmp));
+     }
+      return; /* sic */
       break;

     default:
       internal_error ("Bad IO basetype (%d)", ts->type);
     }

-  args = gfc_chainon_list (NULL_TREE, se->expr);
+  args = gfc_chainon_list (NULL_TREE, addr_expr);
   args = gfc_chainon_list (args, arg2);

   tmp = gfc_build_function_call (function, args);
@@ -1117,7 +1130,7 @@ gfc_trans_transfer (gfc_code * code)

   gfc_conv_expr_reference (&se, expr);

-  transfer_expr (&se, &expr->ts);
+  transfer_expr (&se, &expr->ts, se.expr);

   gfc_add_block_to_block (&body, &se.pre);
   gfc_add_block_to_block (&body, &se.post);
=========================================================