diff options
author | Paul Thomas <pault@gcc.gnu.org> | 2006-03-22 05:13:13 +0000 |
---|---|---|
committer | Paul Thomas <pault@gcc.gnu.org> | 2006-03-22 05:13:13 +0000 |
commit | 0c5a42a660c636a39d6cfb73e0b2a1bc6552509b (patch) | |
tree | 160547b8a0cbfdbccc504f41d26d8910f3255691 /gcc | |
parent | ac382b62f1e24481216e7cd58aa57633f99154dd (diff) | |
download | gcc-0c5a42a660c636a39d6cfb73e0b2a1bc6552509b.zip gcc-0c5a42a660c636a39d6cfb73e0b2a1bc6552509b.tar.gz gcc-0c5a42a660c636a39d6cfb73e0b2a1bc6552509b.tar.bz2 |
re PR fortran/17298 (gfortran ICE: Not Implemented: Scalarization of non-elemental intrinsic: __transfer1)
2006-03-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/17298
*trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): New
function to implement array valued TRANSFER intrinsic.
(gfc_conv_intrinsic_function): Call the new function if TRANSFER
and non-null se->ss.
(gfc_walk_intrinsic_function): Treat TRANSFER as one of the
special cases by calling gfc_walk_intrinsic_libfunc directly.
2006-03-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/17298
* gfortran.dg/transfer_array_intrinsic_1.f90: New test.
* gfortran.dg/transfer_array_intrinsic_2.f90: New test.
From-SVN: r112278
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/fortran/ChangeLog | 10 | ||||
-rw-r--r-- | gcc/fortran/trans-intrinsic.c | 235 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 6 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 | 118 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 | 23 |
5 files changed, 389 insertions, 3 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3cae704..7e36bff 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2006-03-22 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/17298 + *trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): New + function to implement array valued TRANSFER intrinsic. + (gfc_conv_intrinsic_function): Call the new function if TRANSFER + and non-null se->ss. + (gfc_walk_intrinsic_function): Treat TRANSFER as one of the + special cases by calling gfc_walk_intrinsic_libfunc directly. + 2006-03-21 Toon Moene <toon@moene.indiv.nluug.nl> * options.c (gfc_init_options): Initialize diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 33350cbfa..87d3a74 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -2461,6 +2461,221 @@ gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl) } +/* Array transfer statement. + DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE]) + where: + typeof<DEST> = typeof<MOLD> + and: + N = min (sizeof (SOURCE(:)), sizeof (DEST(:)), + sizeof (DEST(0) * SIZE). */ + +static void +gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) +{ + tree tmp; + tree extent; + tree source; + tree source_bytes; + tree dest_word_len; + tree size_words; + tree size_bytes; + tree upper; + tree lower; + tree stride; + tree stmt; + gfc_actual_arglist *arg; + gfc_se argse; + gfc_ss *ss; + gfc_ss_info *info; + stmtblock_t block; + int n; + + gcc_assert (se->loop); + info = &se->ss->data.info; + + /* Convert SOURCE. The output from this stage is:- + source_bytes = length of the source in bytes + source = pointer to the source data. */ + arg = expr->value.function.actual; + gfc_init_se (&argse, NULL); + ss = gfc_walk_expr (arg->expr); + + source_bytes = gfc_create_var (gfc_array_index_type, NULL); + + /* Obtain the pointer to source and the length of source in bytes. */ + if (ss == gfc_ss_terminator) + { + gfc_conv_expr_reference (&argse, arg->expr); + source = argse.expr; + + /* Obtain the source word length. */ + tmp = size_in_bytes(TREE_TYPE(TREE_TYPE (source))); + tmp = fold_convert (gfc_array_index_type, tmp); + } + else + { + gfc_init_se (&argse, NULL); + argse.want_pointer = 0; + gfc_conv_expr_descriptor (&argse, arg->expr, ss); + source = gfc_conv_descriptor_data_get (argse.expr); + + /* Repack the source if not a full variable array. */ + if (!(arg->expr->expr_type == EXPR_VARIABLE + && arg->expr->ref->u.ar.type == AR_FULL)) + { + tmp = build_fold_addr_expr (argse.expr); + tmp = gfc_chainon_list (NULL_TREE, tmp); + source = build_function_call_expr (gfor_fndecl_in_pack, tmp); + source = gfc_evaluate_now (source, &argse.pre); + + /* Free the temporary. */ + gfc_start_block (&block); + tmp = convert (pvoid_type_node, source); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp); + gfc_add_expr_to_block (&block, tmp); + stmt = gfc_finish_block (&block); + + /* Clean up if it was repacked. */ + gfc_init_block (&block); + tmp = gfc_conv_array_data (argse.expr); + tmp = build2 (NE_EXPR, boolean_type_node, source, tmp); + tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se->post); + gfc_init_block (&se->post); + gfc_add_block_to_block (&se->post, &block); + } + + /* Obtain the source word length. */ + tmp = gfc_get_element_type (TREE_TYPE(argse.expr)); + tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); + + /* Obtain the size of the array in bytes. */ + extent = gfc_create_var (gfc_array_index_type, NULL); + for (n = 0; n < arg->expr->rank; n++) + { + tree idx; + idx = gfc_rank_cst[n]; + gfc_add_modify_expr (&argse.pre, source_bytes, tmp); + stride = gfc_conv_descriptor_stride (argse.expr, idx); + lower = gfc_conv_descriptor_lbound (argse.expr, idx); + upper = gfc_conv_descriptor_ubound (argse.expr, idx); + tmp = build2 (MINUS_EXPR, gfc_array_index_type, + upper, lower); + gfc_add_modify_expr (&argse.pre, extent, tmp); + tmp = build2 (PLUS_EXPR, gfc_array_index_type, + extent, gfc_index_one_node); + tmp = build2 (MULT_EXPR, gfc_array_index_type, + tmp, source_bytes); + } + } + + gfc_add_modify_expr (&argse.pre, source_bytes, tmp); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + + /* Now convert MOLD. The sole output is: + dest_word_len = destination word length in bytes. */ + arg = arg->next; + + gfc_init_se (&argse, NULL); + ss = gfc_walk_expr (arg->expr); + + if (ss == gfc_ss_terminator) + { + gfc_conv_expr_reference (&argse, arg->expr); + tmp = TREE_TYPE(TREE_TYPE (argse.expr)); + tmp = fold_convert (gfc_array_index_type, size_in_bytes(tmp)); + } + else + { + gfc_init_se (&argse, NULL); + argse.want_pointer = 0; + gfc_conv_expr_descriptor (&argse, arg->expr, ss); + tmp = gfc_get_element_type (TREE_TYPE(argse.expr)); + tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); + } + + dest_word_len = gfc_create_var (gfc_array_index_type, NULL); + gfc_add_modify_expr (&se->pre, dest_word_len, tmp); + + /* Finally convert SIZE, if it is present. */ + arg = arg->next; + size_words = gfc_create_var (gfc_array_index_type, NULL); + + if (arg->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_reference (&argse, arg->expr); + tmp = convert (gfc_array_index_type, + build_fold_indirect_ref (argse.expr)); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + } + else + tmp = NULL_TREE; + + size_bytes = gfc_create_var (gfc_array_index_type, NULL); + if (tmp != NULL_TREE) + { + tmp = build2 (MULT_EXPR, gfc_array_index_type, + tmp, dest_word_len); + tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes); + } + else + tmp = source_bytes; + + gfc_add_modify_expr (&se->pre, size_bytes, tmp); + gfc_add_modify_expr (&se->pre, size_words, + build2 (CEIL_DIV_EXPR, gfc_array_index_type, + size_bytes, dest_word_len)); + + /* Evaluate the bounds of the result. If the loop range exists, we have + to check if it is too large. If so, we modify loop->to be consistent + with min(size, size(source)). Otherwise, size is made consistent with + the loop range, so that the right number of bytes is transferred.*/ + n = se->loop->order[0]; + if (se->loop->to[n] != NULL_TREE) + { + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + se->loop->to[n], se->loop->from[n]); + tmp = build2 (PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + tmp = build2 (MIN_EXPR, gfc_array_index_type, + tmp, size_words); + gfc_add_modify_expr (&se->pre, size_words, tmp); + gfc_add_modify_expr (&se->pre, size_bytes, + build2 (MULT_EXPR, gfc_array_index_type, + size_words, dest_word_len)); + upper = build2 (PLUS_EXPR, gfc_array_index_type, + size_words, se->loop->from[n]); + upper = build2 (MINUS_EXPR, gfc_array_index_type, + upper, gfc_index_one_node); + } + else + { + upper = build2 (MINUS_EXPR, gfc_array_index_type, + size_words, gfc_index_one_node); + se->loop->from[n] = gfc_index_zero_node; + } + + se->loop->to[n] = upper; + + /* Build a destination descriptor, using the pointer, source, as the + data field. This is already allocated so set callee_alloc. */ + tmp = gfc_typenode_for_spec (&expr->ts); + gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, + info, tmp, false, false, true); + + tmp = fold_convert (pvoid_type_node, source); + gfc_conv_descriptor_data_set (&se->pre, info->descriptor, tmp); + se->expr = info->descriptor; + if (expr->ts.type == BT_CHARACTER) + se->string_length = dest_word_len; +} + + /* Scalar transfer statement. TRANSFER (source, mold) = *(typeof<mold> *)&source. */ @@ -2473,8 +2688,6 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) tree ptr; gfc_ss *ss; - gcc_assert (!se->ss); - /* Get a pointer to the source. */ arg = expr->value.function.actual; ss = gfc_walk_expr (arg->expr); @@ -3374,7 +3587,20 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_TRANSFER: - gfc_conv_intrinsic_transfer (se, expr); + if (se->ss) + { + if (se->ss->useflags) + { + /* Access the previously obtained result. */ + gfc_conv_tmp_array_ref (se); + gfc_advance_se_ss_chain (se); + break; + } + else + gfc_conv_intrinsic_array_transfer (se, expr); + } + else + gfc_conv_intrinsic_transfer (se, expr); break; case GFC_ISYM_TTYNAM: @@ -3558,6 +3784,9 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, case GFC_ISYM_UBOUND: return gfc_walk_intrinsic_bound (ss, expr); + case GFC_ISYM_TRANSFER: + return gfc_walk_intrinsic_libfunc (ss, expr); + default: /* This probably meant someone forgot to add an intrinsic to the above list(s) when they implemented it, or something's gone horribly wrong. diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6f3eef0..20bb9c6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2006-03-22 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/17298 + * gfortran.dg/transfer_array_intrinsic_1.f90: New test. + * gfortran.dg/transfer_array_intrinsic_2.f90: New test. + 2006-03-21 Janis Johnson <janis187@us.ibm.com> * lib/gcc-dg.exp (cleanup-modules): New proc. diff --git a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 new file mode 100644 index 0000000..c3d334d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 @@ -0,0 +1,118 @@ +! { dg-do run } +! Tests the patch to implement the array version of the TRANSFER +! intrinsic (PR17298). +! Contributed by Paul Thomas <pault@gcc.gnu.org> + + character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/) + +! tests numeric transfers(including PR testcase). + + call test1 () + +! tests numeric/character transfers. + + call test2 () + +! Test dummies, automatic objects and assumed character length. + + call test3 (ch, ch, ch, 8) + +contains + + subroutine test1 () + complex(4) :: z = (1.0, 2.0) + real(4) :: cmp(2), a(4, 4) + integer(2) :: it(4, 2, 4), jt(32) + +! The PR testcase. + + cmp = transfer (z, cmp) * 2.0 + if (any (cmp .ne. (/2.0, 4.0/))) call abort () + +! Check that size smaller than the source word length is OK. + + z = (-1.0, -2.0) + cmp = transfer (z, cmp, 1) * 8.0 + if (any (cmp .ne. (/-8.0, 4.0/))) call abort () + +! Check multi-dimensional sources and that transfer works as an actual +! argument of reshape. + + a = reshape ((/(rand (), i = 1, 16)/), (/4,4/)) + jt = transfer (a, it) + it = reshape (jt, (/4, 2, 4/)) + if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort () + + end subroutine test1 + + subroutine test2 () + integer(4) :: y(4), z(2) + character(4) :: ch(4) + y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) & + + ishft (i + 3, 24), i = 65, 80 , 4)/) + +! Check source array sections in both directions. + + ch = "wxyz" + ch = transfer (y(2:4:2), ch) + if (any (ch .ne. (/"EFGH","MNOP","wxyz","wxyz"/))) call abort () + ch = "wxyz" + ch = transfer (y(4:2:-2), ch) + if (any (ch .ne. (/"MNOP","EFGH","wxyz","wxyz"/))) call abort () + +! Check that a complete array transfers with size absent. + + ch = transfer (y, ch) + if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort () + +! Check that a character array section is OK + + z = transfer (ch(2:3), y) + if (any (z .ne. y(2:3))) call abort () + +! Check dest array sections in both directions. + + ch = "wxyz" + ch(3:4) = transfer (y, ch, 2) + if (any (ch .ne. (/"wxyz","wxyz","ABCD","EFGH"/))) call abort () + ch = "wxyz" + ch(3:2:-1) = transfer (y, ch, 3) + if (any (ch .ne. (/"wxyz","EFGH","ABCD","wxyz"/))) call abort () + +! Check that too large a value of size is cut off. + + ch = "wxyz" + ch(1:2) = transfer (y, ch, 3) + if (any (ch .ne. (/"ABCD","EFGH","wxyz","wxyz"/))) call abort () + +! Make sure that character to numeric is OK. + + z = transfer (ch, y) + if (any (y(1:2) .ne. z)) call abort () + + end subroutine test2 + + subroutine test3 (ch1, ch2, ch3, clen) + integer clen + character(8) :: ch1(:) + character(*) :: ch2(2) + character(clen) :: ch3(2) + character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/) + integer(8) :: ic(2) + ic = transfer (cntrl, ic) + +! Check assumed shape. + + if (any (ic .ne. transfer (ch1, ic))) call abort () + +! Check assumed character length. + + if (any (ic .ne. transfer (ch2, ic))) call abort () + +! Check automatic character length. + + if (any (ic .ne. transfer (ch3, ic))) call abort () + + end subroutine test3 + +end diff --git a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 new file mode 100644 index 0000000..7c35b61 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-fpack-derived" } + call test3() +contains + subroutine test3 () + type mytype + sequence + real(8) :: x = 3.14159 + character(4) :: ch = "wxyz" + integer(2) :: i = 77 + end type mytype + type(mytype) :: z(2) + character(1) :: c(32) + character(4) :: chr + real(8) :: a + integer(2) :: l + equivalence (a, c(15)), (chr, c(23)), (l, c(27)) + c = transfer(z, c) + if (a .ne. z(1)%x) call abort () + if (chr .ne. z(1)%ch) call abort () + if (l .ne. z(1)%i) call abort () + end subroutine test3 +end |