class_assign_1.f08: New test.
gcc/testsuite/ChangeLog: 2016-12-23 Andre Vehreschild <vehre@gcc.gnu.org> * gfortran.dg/class_assign_1.f08: New test. gcc/fortran/ChangeLog: 2016-12-23 Andre Vehreschild <vehre@gcc.gnu.org> * trans-expr.c (trans_class_assignment): Allocate memory of _vptr->size before assigning an allocatable class object. (gfc_trans_assignment_1): Flag that (re-)alloc of the class object shall be done. From-SVN: r243909
This commit is contained in:
parent
cca8d0b265
commit
f19dd7b634
|
@ -1,3 +1,10 @@
|
|||
2016-12-23 Andre Vehreschild <vehre@gcc.gnu.org>
|
||||
|
||||
* trans-expr.c (trans_class_assignment): Allocate memory of _vptr->size
|
||||
before assigning an allocatable class object.
|
||||
(gfc_trans_assignment_1): Flag that (re-)alloc of the class object
|
||||
shall be done.
|
||||
|
||||
2016-12-21 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
PR fortran/78866
|
||||
|
|
|
@ -9625,17 +9625,38 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
|
|||
|
||||
static tree
|
||||
trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
|
||||
gfc_se *lse, gfc_se *rse, bool use_vptr_copy)
|
||||
gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
|
||||
bool class_realloc)
|
||||
{
|
||||
tree tmp;
|
||||
tree fcn;
|
||||
tree stdcopy, to_len, from_len;
|
||||
tree tmp, fcn, stdcopy, to_len, from_len, vptr;
|
||||
vec<tree, va_gc> *args = NULL;
|
||||
|
||||
tmp = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
|
||||
vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
|
||||
&from_len);
|
||||
|
||||
fcn = gfc_vptr_copy_get (tmp);
|
||||
/* Generate allocation of the lhs. */
|
||||
if (class_realloc)
|
||||
{
|
||||
stmtblock_t alloc;
|
||||
tree class_han;
|
||||
|
||||
tmp = gfc_vptr_size_get (vptr);
|
||||
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
|
||||
? gfc_class_data_get (lse->expr) : lse->expr;
|
||||
gfc_init_block (&alloc);
|
||||
gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
|
||||
tmp = fold_build2_loc (input_location, EQ_EXPR,
|
||||
boolean_type_node, class_han,
|
||||
build_int_cst (prvoid_type_node, 0));
|
||||
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
||||
gfc_unlikely (tmp,
|
||||
PRED_FORTRAN_FAIL_ALLOC),
|
||||
gfc_finish_block (&alloc),
|
||||
build_empty_stmt (input_location));
|
||||
gfc_add_expr_to_block (&lse->pre, tmp);
|
||||
}
|
||||
|
||||
fcn = gfc_vptr_copy_get (vptr);
|
||||
|
||||
tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
|
||||
? gfc_class_data_get (rse->expr) : rse->expr;
|
||||
|
@ -9961,15 +9982,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|
|||
}
|
||||
|
||||
if (is_poly_assign)
|
||||
{
|
||||
tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
|
||||
use_vptr_copy || (lhs_attr.allocatable
|
||||
&& !lhs_attr.dimension));
|
||||
/* Modify the expr1 after the assignment, to allow the realloc below.
|
||||
Therefore only needed, when realloc_lhs is enabled. */
|
||||
if (flag_realloc_lhs && !lhs_attr.pointer)
|
||||
gfc_add_data_component (expr1);
|
||||
}
|
||||
&& !lhs_attr.dimension),
|
||||
flag_realloc_lhs && !lhs_attr.pointer);
|
||||
else if (flag_coarray == GFC_FCOARRAY_LIB
|
||||
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
|
||||
&& ((lhs_caf_attr.allocatable && lhs_refs_comp)
|
||||
|
@ -10011,7 +10027,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|
|||
if (lss == gfc_ss_terminator)
|
||||
{
|
||||
/* F2003: Add the code for reallocation on assignment. */
|
||||
if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1))
|
||||
if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
|
||||
&& !is_poly_assign)
|
||||
alloc_scalar_allocatable_for_assignment (&block, string_length,
|
||||
expr1, expr2);
|
||||
|
||||
|
|
|
@ -1,3 +1,7 @@
|
|||
2016-12-23 Andre Vehreschild <vehre@gcc.gnu.org>
|
||||
|
||||
* gfortran.dg/class_assign_1.f08: New test.
|
||||
|
||||
2016-12-23 Toma Tabacu <toma.tabacu@imgtec.com>
|
||||
|
||||
* gcc.target/mips/oddspreg-2.c (dg-options): Remove dg-skip-if for
|
||||
|
|
|
@ -0,0 +1,71 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Check that reallocation of the lhs is done with the correct memory size.
|
||||
|
||||
|
||||
module base_mod
|
||||
|
||||
type, abstract :: base
|
||||
contains
|
||||
procedure(base_add), deferred :: add
|
||||
generic :: operator(+) => add
|
||||
end type base
|
||||
|
||||
abstract interface
|
||||
module function base_add(l, r) result(res)
|
||||
class(base), intent(in) :: l
|
||||
integer, intent(in) :: r
|
||||
class(base), allocatable :: res
|
||||
end function base_add
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine foo(x)
|
||||
class(base), intent(inout), allocatable :: x
|
||||
class(base), allocatable :: t
|
||||
|
||||
t = x + 2
|
||||
x = t + 40
|
||||
end subroutine foo
|
||||
|
||||
end module base_mod
|
||||
|
||||
module extend_mod
|
||||
use base_mod
|
||||
|
||||
type, extends(base) :: extend
|
||||
integer :: i
|
||||
contains
|
||||
procedure :: add
|
||||
end type extend
|
||||
|
||||
contains
|
||||
module function add(l, r) result(res)
|
||||
class(extend), intent(in) :: l
|
||||
integer, intent(in) :: r
|
||||
class(base), allocatable :: res
|
||||
select type (l)
|
||||
class is (extend)
|
||||
res = extend(l%i + r)
|
||||
class default
|
||||
error stop "Unkown class to add to."
|
||||
end select
|
||||
end function
|
||||
end module extend_mod
|
||||
|
||||
program test_poly_ass
|
||||
use extend_mod
|
||||
use base_mod
|
||||
|
||||
class(base), allocatable :: obj
|
||||
obj = extend(0)
|
||||
call foo(obj)
|
||||
select type (obj)
|
||||
class is (extend)
|
||||
if (obj%i /= 42) error stop
|
||||
class default
|
||||
error stop "Result's type wrong."
|
||||
end select
|
||||
end program test_poly_ass
|
||||
|
Loading…
Reference in New Issue