From d2ccf6aa09c93ba71973e8c93ef90c6f4d688ccd Mon Sep 17 00:00:00 2001 From: Victor Leikehman Date: Thu, 16 Sep 2004 13:29:56 +0000 Subject: [PATCH] trans-io.c (transfer_array_component): New function. 2004-09-16 Victor Leikehman PR/15364 * trans-io.c (transfer_array_component): New function. (transfer_expr): For array fields, call transfer_array_component. testsuite/ * gfortran.dg/der_array_io_1.f90: New test. * gfortran.dg/der_array_io_2.f90: New test. * gfortran.dg/der_array_io_3.f90: New test. From-SVN: r87596 --- gcc/fortran/ChangeLog | 6 + gcc/fortran/trans-io.c | 124 +++++++++++++++++-- gcc/testsuite/ChangeLog | 7 ++ gcc/testsuite/gfortran.dg/der_array_io_1.f90 | 24 ++++ gcc/testsuite/gfortran.dg/der_array_io_2.f90 | 29 +++++ gcc/testsuite/gfortran.dg/der_array_io_3.f90 | 13 ++ 6 files changed, 190 insertions(+), 13 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/der_array_io_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/der_array_io_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/der_array_io_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8d180e3f7c8..abdaa1d4166 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2004-09-16 Victor Leikehman + + PR/15364 + * trans-io.c (transfer_array_component): New function. + (transfer_expr): For array fields, call transfer_array_component. + 2004-09-16 Kazu Hirata * gfortran.texi: Fix a typo. diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 66d25b22db3..c67422876de 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -1140,6 +1140,96 @@ gfc_trans_dt_end (gfc_code * code) return gfc_finish_block (&block); } +static void +transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr); + +/* Given an array field in a derived type variable, generate the code + for the loop that iterates over array elements, and the code that + accesses those array elements. Use transfer_expr to generate code + for transferring that element. Because elements may also be + derived types, transfer_expr and transfer_array_component are mutually + recursive. */ + +static tree +transfer_array_component (tree expr, gfc_component * cm) +{ + tree tmp; + stmtblock_t body; + stmtblock_t block; + gfc_loopinfo loop; + int n; + gfc_ss *ss; + gfc_se se; + + gfc_start_block (&block); + gfc_init_se (&se, NULL); + + /* Create and initialize Scalarization Status. Unlike in + gfc_trans_transfer, we can't simply use gfc_walk_expr to take + care of this task, because we don't have a gfc_expr at hand. + Build one manually, as in gfc_trans_subarray_assign. */ + + ss = gfc_get_ss (); + ss->type = GFC_SS_COMPONENT; + ss->expr = NULL; + ss->shape = gfc_get_shape (cm->as->rank); + ss->next = gfc_ss_terminator; + ss->data.info.dimen = cm->as->rank; + ss->data.info.descriptor = expr; + ss->data.info.data = gfc_conv_array_data (expr); + ss->data.info.offset = gfc_conv_array_offset (expr); + for (n = 0; n < cm->as->rank; n++) + { + ss->data.info.dim[n] = n; + ss->data.info.start[n] = gfc_conv_array_lbound (expr, n); + ss->data.info.stride[n] = gfc_index_one_node; + + mpz_init (ss->shape[n]); + mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer, + cm->as->lower[n]->value.integer); + mpz_add_ui (ss->shape[n], ss->shape[n], 1); + } + + /* Once we got ss, we use scalarizer to create the loop. */ + + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, ss); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + gfc_mark_ss_chain_used (ss, 1); + gfc_start_scalarized_body (&loop, &body); + + gfc_copy_loopinfo_to_se (&se, &loop); + se.ss = ss; + + /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */ + se.expr = expr; + gfc_conv_tmp_array_ref (&se); + + /* 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, se.expr); + transfer_expr (&se, &cm->ts, tmp); + + /* We are done now with the loop body. Wrap up the scalarizer and + return. */ + + gfc_add_block_to_block (&body, &se.pre); + gfc_add_block_to_block (&body, &se.post); + + gfc_trans_scalarizing_loops (&loop, &body); + + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + + gfc_cleanup_loop (&loop); + + for (n = 0; n < cm->as->rank; n++) + mpz_clear (ss->shape[n]); + gfc_free (ss->shape); + + return gfc_finish_block (&block); +} /* Generate the call for a scalar transfer node. */ @@ -1177,11 +1267,19 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) break; case BT_CHARACTER: - arg2 = se->string_length; + if (se->string_length) + arg2 = se->string_length; + else + { + tmp = gfc_build_indirect_ref (addr_expr); + gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); + arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); + } function = iocall_x_character; break; case BT_DERIVED: + /* Recurse into the elements of the derived type. */ expr = gfc_evaluate_now (addr_expr, &se->pre); expr = gfc_build_indirect_ref (expr); @@ -1193,17 +1291,17 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field, NULL_TREE); - if (c->ts.type == BT_CHARACTER) - { - gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); - se->string_length = - TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); - } - if (c->dimension) - gfc_todo_error ("IO of arrays in derived types"); - if (!c->pointer) - tmp = gfc_build_addr_expr (NULL, tmp); - transfer_expr (se, &c->ts, tmp); + if (c->dimension) + { + tmp = transfer_array_component (tmp, c); + gfc_add_expr_to_block (&se->pre, tmp); + } + else + { + if (!c->pointer) + tmp = gfc_build_addr_expr (NULL, tmp); + transfer_expr (se, &c->ts, tmp); + } } return; @@ -1281,7 +1379,7 @@ gfc_trans_transfer (gfc_code * code) gfc_add_expr_to_block (&block, tmp); - return gfc_finish_block (&block);; + return gfc_finish_block (&block); } #include "gt-fortran-trans-io.h" diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 357fe77e9b0..e36b90e4878 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2004-09-16 Victor Leikehman + + PR/15364 + * gfortran.dg/der_array_io_1.f90: New test. + * gfortran.dg/der_array_io_2.f90: New test. + * gfortran.dg/der_array_io_3.f90: New test. + 2004-09-15 Mark Mitchell * testsuite/g++.old-deja/g++.abi/cxa_vec.C: Adjust for ARM diff --git a/gcc/testsuite/gfortran.dg/der_array_io_1.f90 b/gcc/testsuite/gfortran.dg/der_array_io_1.f90 new file mode 100644 index 00000000000..5bfd0c64547 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/der_array_io_1.f90 @@ -0,0 +1,24 @@ +! Test IO of arrays of integers in derived types +! { dg-do run } +program main + + character* 10000 :: buf1, buf2 + type xyz + integer :: x, y(3), z + end type xyz + + type (xyz) :: foo(4) + + do i=1,ubound(foo,1) + foo(i)%x = 100*i + do j=1,3 + foo(i)%y(j) = 100*i + 10*j + enddo + foo(i)%z = 100*i+40 + enddo + + print (buf1, '(20i4)'), foo + print (buf2, '(20i4)'), (foo(i)%x, (foo(i)%y(j), j=1,3), foo(i)%z, i=1,4) + + if (buf1.ne.buf2) call abort +end program main diff --git a/gcc/testsuite/gfortran.dg/der_array_io_2.f90 b/gcc/testsuite/gfortran.dg/der_array_io_2.f90 new file mode 100644 index 00000000000..5d4a7ce01e3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/der_array_io_2.f90 @@ -0,0 +1,29 @@ +! Test IO of arrays in derived type arrays +! { dg-do run } +program main + + character *1000 buf1, buf2 + + type :: foo_type + integer x(3) + integer y(4) + integer z(5) + character*11 a(3) + end type foo_type + + type (foo_type) :: foo(2) + + foo(1)%x = 3 + foo(1)%y = 4 + foo(1)%z = 5 + foo(1)%a = "hello world" + + foo(2)%x = 30 + foo(2)%y = 40 + foo(2)%z = 50 + foo(2)%a = "HELLO WORLD" + + print (buf1,*), foo + print (buf2,*), ((foo(i)%x(j),j=1,3), (foo(i)%y(j),j=1,4), (foo(i)%z(j),j=1,5), (foo(i)%a(j),j=1,3), i=1,2) + if (buf1.ne.buf2) call abort +end program main diff --git a/gcc/testsuite/gfortran.dg/der_array_io_3.f90 b/gcc/testsuite/gfortran.dg/der_array_io_3.f90 new file mode 100644 index 00000000000..7898a1e8c5c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/der_array_io_3.f90 @@ -0,0 +1,13 @@ +! Test IO of character arrays in derived types. +! { dg-do run } +program main + character*1000 buf1, buf2 + type :: foo_type + character(12), dimension(13) :: name = "hello world " + end type foo_type + type (foo_type) :: foo +! foo = foo_type("hello world ") + print (buf1,*), foo + print (buf2,*), (foo%name(i), i=1,13) + if (buf1.ne.buf2) call abort +end program main -- 2.30.2