Hi Janus, hi all,
thanks for the review. Committed as r243909.
Regards,
Andre
On Thu, 22 Dec 2016 23:26:19 +0100
Janus Weil <ja...@gcc.gnu.org> wrote:
> 2016-12-20 17:07 GMT+01:00 Andre Vehreschild <ve...@gmx.de>:
> > Hi Janus,
> >
> >> 1) After adding that code block in gfc_trans_assignment_1, it seems
> >> like the comment above is outdated, right?
> >
> > Thanks for noting.
> >
> >> 2) Wouldn't it be better to move this block, which does the correct
> >> allocation for CLASS variables, into
> >> "alloc_scalar_allocatable_for_assignment", where the allocation for
> >> all other cases is done?
> >
> > I tried to, but that would have meant to extend the interface of
> > alloc_scalar_allocatable_for_assignment significantly, while at the location
> > where I finally added the code, I could use the data available. Secondly
> > putting the malloc at the correct location is not possible at
> > alloc_scalar_... because the pre-blocks have already been joined to the
> > body. That way the malloc was always placed either before even the vptr was
> > set, or after the data was copied. Both options were quite hazardous.
> >
> > I now went to add the allocation into trans_class_assignment (). This allows
> > even more reuse of already present and needed data, e.g., the vptr.
> >
> > Bootstrapped and regtested ok on x86_64-linux/f23. Ok for trunk?
>
> Thanks for the explanations. The patch is ok with me in this form.
>
> Cheers,
> Janus
--
Andre Vehreschild * Email: vehre ad gmx dot de
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (Revision 243908)
+++ gcc/fortran/trans-expr.c (Arbeitskopie)
@@ -9625,18 +9625,39 @@
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;
if (use_vptr_copy)
@@ -9961,15 +9982,10 @@
}
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);
- }
+ tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
+ use_vptr_copy || (lhs_attr.allocatable
+ && !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 @@
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);
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog (Revision 243908)
+++ gcc/fortran/ChangeLog (Arbeitskopie)
@@ -1,3 +1,10 @@
+2016-12-23 Andre Vehreschild <ve...@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 <ja...@redhat.com>
PR fortran/78866
Index: gcc/testsuite/gfortran.dg/class_assign_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/class_assign_1.f08 (nicht existent)
+++ gcc/testsuite/gfortran.dg/class_assign_1.f08 (Revision 243909)
@@ -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
+
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 243908)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,3 +1,7 @@
+2016-12-23 Andre Vehreschild <ve...@gcc.gnu.org>
+
+ * gfortran.dg/class_assign_1.f08: New test.
+
2016-12-23 Toma Tabacu <toma.tab...@imgtec.com>
* gcc.target/mips/oddspreg-2.c (dg-options): Remove dg-skip-if for
