From: janus Date: Tue, 6 Nov 2012 10:15:42 +0000 (+0000) Subject: 2012-11-06 Janus Weil X-Git-Tag: upstream/4.9.2~9407 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=50a0a4ff35114569fdf745888f9a2df3e85073bf;p=platform%2Fupstream%2Flinaro-gcc.git 2012-11-06 Janus Weil PR fortran/54917 * target-memory.c (gfc_target_expr_size,gfc_target_interpret_expr): Handle BT_CLASS. * trans-intrinsic.c (gfc_conv_intrinsic_transfer): Add support for polymorphic arguments. 2012-11-06 Janus Weil PR fortran/54917 * gfortran.dg/transfer_class_1.f90: New. * gfortran.dg/transfer_class_2.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@193226 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 084f1f8..f33dffb 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2012-11-06 Janus Weil + + PR fortran/54917 + * target-memory.c (gfc_target_expr_size,gfc_target_interpret_expr): + Handle BT_CLASS. + * trans-intrinsic.c (gfc_conv_intrinsic_transfer): Add support for + polymorphic arguments. + 2012-11-04 Janus Weil PR fortran/55199 diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index aec7fa2..437a3df 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -121,6 +121,7 @@ gfc_target_expr_size (gfc_expr *e) case BT_HOLLERITH: return e->representation.length; case BT_DERIVED: + case BT_CLASS: { /* Determine type size without clobbering the typespec for ISO C binding types. */ @@ -572,6 +573,9 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, gfc_interpret_character (buffer, buffer_size, result); break; + case BT_CLASS: + result->ts = CLASS_DATA (result)->ts; + /* Fall through. */ case BT_DERIVED: result->representation.length = gfc_interpret_derived (buffer, buffer_size, result); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 4b268b3..b101cb4 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -5348,6 +5348,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) stmtblock_t block; int n; bool scalar_mold; + gfc_expr *source_expr, *mold_expr; info = NULL; if (se->loop) @@ -5357,6 +5358,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) source_bytes = length of the source in bytes source = pointer to the source data. */ arg = expr->value.function.actual; + source_expr = arg->expr; /* Ensure double transfer through LOGICAL preserves all the needed bits. */ @@ -5376,18 +5378,28 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) if (arg->expr->rank == 0) { gfc_conv_expr_reference (&argse, arg->expr); - source = argse.expr; - - source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, - argse.expr)); + if (arg->expr->ts.type == BT_CLASS) + source = gfc_class_data_get (argse.expr); + else + source = argse.expr; /* Obtain the source word length. */ - if (arg->expr->ts.type == BT_CHARACTER) - tmp = size_of_string_in_bytes (arg->expr->ts.kind, - argse.string_length); - else - tmp = fold_convert (gfc_array_index_type, - size_in_bytes (source_type)); + switch (arg->expr->ts.type) + { + case BT_CHARACTER: + tmp = size_of_string_in_bytes (arg->expr->ts.kind, + argse.string_length); + break; + case BT_CLASS: + tmp = gfc_vtable_size_get (argse.expr); + break; + default: + source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + source)); + tmp = fold_convert (gfc_array_index_type, + size_in_bytes (source_type)); + break; + } } else { @@ -5464,6 +5476,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) mold_type = the TREE type of MOLD dest_word_len = destination word length in bytes. */ arg = arg->next; + mold_expr = arg->expr; gfc_init_se (&argse, NULL); @@ -5473,7 +5486,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) { gfc_conv_expr_reference (&argse, arg->expr); mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, - argse.expr)); + argse.expr)); } else { @@ -5494,15 +5507,20 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) mold_type = gfc_get_int_type (arg->expr->ts.kind); } - if (arg->expr->ts.type == BT_CHARACTER) + /* Obtain the destination word length. */ + switch (arg->expr->ts.type) { + case BT_CHARACTER: tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length); mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp); + break; + case BT_CLASS: + tmp = gfc_vtable_size_get (argse.expr); + break; + default: + tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type)); + break; } - else - tmp = fold_convert (gfc_array_index_type, - size_in_bytes (mold_type)); - dest_word_len = gfc_create_var (gfc_array_index_type, NULL); gfc_add_modify (&se->pre, dest_word_len, tmp); @@ -5650,8 +5668,21 @@ scalar_transfer: ptr = convert (build_pointer_type (mold_type), source); + /* For CLASS results, allocate the needed memory first. */ + if (mold_expr->ts.type == BT_CLASS) + { + tree cdata; + cdata = gfc_class_data_get (tmpdecl); + tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len); + gfc_add_modify (&se->pre, cdata, tmp); + } + /* Use memcpy to do the transfer. */ - tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl); + if (mold_expr->ts.type == BT_CLASS) + tmp = gfc_class_data_get (tmpdecl); + else + tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl); + tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_MEMCPY), 3, fold_convert (pvoid_type_node, tmp), @@ -5659,6 +5690,18 @@ scalar_transfer: extent); gfc_add_expr_to_block (&se->pre, tmp); + /* For CLASS results, set the _vptr. */ + if (mold_expr->ts.type == BT_CLASS) + { + tree vptr; + gfc_symbol *vtab; + vptr = gfc_class_vptr_get (tmpdecl); + vtab = gfc_find_derived_vtab (source_expr->ts.u.derived); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp)); + } + se->expr = tmpdecl; } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e44a637..c4d388d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2012-11-06 Janus Weil + + PR fortran/54917 + * gfortran.dg/transfer_class_1.f90: New. + * gfortran.dg/transfer_class_2.f90: New. + 2012-11-05 Sriraman Tallam * testsuite/g++.dg/mv1.C: New test. diff --git a/gcc/testsuite/gfortran.dg/transfer_class_1.f90 b/gcc/testsuite/gfortran.dg/transfer_class_1.f90 new file mode 100644 index 0000000..00b3a24 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_class_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-Wsurprising" } +! +! PR 54917: [4.7/4.8 Regression] [OOP] TRANSFER on polymorphic variable causes ICE +! +! Contributed by Sean Santos + +subroutine test_routine1(arg) + implicit none + type test_type + integer :: test_comp + end type + class(test_type) :: arg + integer :: i + i = transfer(arg, 1) +end subroutine diff --git a/gcc/testsuite/gfortran.dg/transfer_class_2.f90 b/gcc/testsuite/gfortran.dg/transfer_class_2.f90 new file mode 100644 index 0000000..d75b640 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_class_2.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! PR 54917: [OOP] TRANSFER on polymorphic variable causes ICE +! +! Contributed by Janus Weil + +module m + implicit none + type test_type + integer :: i = 0 + contains + procedure :: ass + generic :: assignment(=) => ass + end type +contains + subroutine ass (a, b) + class(test_type), intent(out) :: a + class(test_type), intent(in) :: b + a%i = b%i + end subroutine +end module + + +program p + use m + implicit none + + class(test_type), allocatable :: c + type(test_type) :: t + + allocate(c) + + ! (1) check CLASS-to-TYPE transfer + c%i=3 + t = transfer(c, t) + if (t%i /= 3) call abort() + + ! (2) check TYPE-to-CLASS transfer + t%i=4 + c = transfer(t, c) + if (c%i /= 4) call abort() + +end + +! { dg-final { cleanup-modules "m" } }