Skip to content

R
riscv-gcc-1
Commit fa1ed658 by Janus Weil
Options

re PR fortran/54917 ([OOP] TRANSFER on polymorphic variable causes ICE) 

2012-11-06  Janus Weil  <janus@gcc.gnu.org>

	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  <janus@gcc.gnu.org>

	PR fortran/54917
	* gfortran.dg/transfer_class_1.f90: New.
	* gfortran.dg/transfer_class_2.f90: New.

From-SVN: r193226
parent b887f1a0
Showing with 139 additions and 17 deletions
gcc/fortran/ChangeLog
2012-11-06 Janus Weil <janus@gcc.gnu.org>
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 <janus@gcc.gnu.org>
PR fortran/55199
......
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);
......
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;
}
}
......
gcc/testsuite/ChangeLog
2012-11-06 Janus Weil <janus@gcc.gnu.org>
PR fortran/54917
* gfortran.dg/transfer_class_1.f90: New.
* gfortran.dg/transfer_class_2.f90: New.
2012-11-05 Sriraman Tallam <tmsriram@google.com>
* testsuite/g++.dg/mv1.C: New test.
......
gcc/testsuite/gfortran.dg/transfer_class_1.f90 0 → 100644
! { dg-do compile }
! { dg-options "-Wsurprising" }
!
! PR 54917: [4.7/4.8 Regression] [OOP] TRANSFER on polymorphic variable causes ICE
!
! Contributed by Sean Santos <quantheory@gmail.com>
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
gcc/testsuite/gfortran.dg/transfer_class_2.f90 0 → 100644
! { dg-do run }
!
! PR 54917: [OOP] TRANSFER on polymorphic variable causes ICE
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment