From b2a5eb7501657692da7d9d294758753e122b3691 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Thu, 29 Jul 2010 20:14:16 +0200 Subject: [PATCH] re PR fortran/45004 ([OOP] Segfault with allocatable scalars and move_alloc) 2010-07-29 Janus Weil PR fortran/45004 * trans-stmt.h (gfc_trans_class_init_assign): New prototype. (gfc_trans_class_assign): Modified prototype. * trans.h (gfc_conv_intrinsic_move_alloc): New prototype. * trans-expr.c (gfc_trans_class_init_assign): Split off from ... (gfc_trans_class_assign): ... here. Modified actual arguments. * trans-intrinsic.c (gfc_conv_intrinsic_move_alloc): New function to handle the MOVE_ALLOC intrinsic with scalar and class arguments. * trans.c (trans_code): Call 'gfc_conv_intrinsic_move_alloc'. 2010-07-29 Janus Weil PR fortran/45004 * gfortran.dg/move_alloc_2.f90: New. From-SVN: r162688 --- gcc/fortran/ChangeLog | 12 +++++ gcc/fortran/trans-expr.c | 74 +++++++++++++++++------------- gcc/fortran/trans-intrinsic.c | 38 +++++++++++++++ gcc/fortran/trans-stmt.h | 3 +- gcc/fortran/trans.c | 14 ++++-- gcc/fortran/trans.h | 2 + gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/move_alloc_2.f90 | 27 +++++++++++ 8 files changed, 136 insertions(+), 39 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/move_alloc_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 02263af..f22ed11 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2010-07-29 Janus Weil + + PR fortran/45004 + * trans-stmt.h (gfc_trans_class_init_assign): New prototype. + (gfc_trans_class_assign): Modified prototype. + * trans.h (gfc_conv_intrinsic_move_alloc): New prototype. + * trans-expr.c (gfc_trans_class_init_assign): Split off from ... + (gfc_trans_class_assign): ... here. Modified actual arguments. + * trans-intrinsic.c (gfc_conv_intrinsic_move_alloc): New function to + handle the MOVE_ALLOC intrinsic with scalar and class arguments. + * trans.c (trans_code): Call 'gfc_conv_intrinsic_move_alloc'. + 2010-07-29 Mikael Morin PR fortran/42051 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index a83d4b3..53df2ae 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5671,11 +5671,38 @@ void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt, } +/* Special case for initializing a CLASS variable on allocation. + A MEMCPY is needed to copy the full data of the dynamic type, + which may be different from the declared type. */ + +tree +gfc_trans_class_init_assign (gfc_code *code) +{ + stmtblock_t block; + tree tmp, memsz; + gfc_se dst,src; + + gfc_start_block (&block); + + gfc_init_se (&dst, NULL); + gfc_init_se (&src, NULL); + gfc_add_component_ref (code->expr1, "$data"); + gfc_conv_expr (&dst, code->expr1); + gfc_conv_expr (&src, code->expr2); + gfc_add_block_to_block (&block, &src.pre); + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts)); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + /* Translate an assignment to a CLASS object (pointer or ordinary assignment). */ tree -gfc_trans_class_assign (gfc_code *code) +gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) { stmtblock_t block; tree tmp; @@ -5683,45 +5710,26 @@ gfc_trans_class_assign (gfc_code *code) gfc_expr *rhs; gfc_start_block (&block); - - if (code->op == EXEC_INIT_ASSIGN) - { - /* Special case for initializing a CLASS variable on allocation. - A MEMCPY is needed to copy the full data of the dynamic type, - which may be different from the declared type. */ - gfc_se dst,src; - tree memsz; - gfc_init_se (&dst, NULL); - gfc_init_se (&src, NULL); - gfc_add_component_ref (code->expr1, "$data"); - gfc_conv_expr (&dst, code->expr1); - gfc_conv_expr (&src, code->expr2); - gfc_add_block_to_block (&block, &src.pre); - memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts)); - tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); - gfc_add_expr_to_block (&block, tmp); - return gfc_finish_block (&block); - } - if (code->expr2->ts.type != BT_CLASS) + if (expr2->ts.type != BT_CLASS) { /* Insert an additional assignment which sets the '$vptr' field. */ - lhs = gfc_copy_expr (code->expr1); + lhs = gfc_copy_expr (expr1); gfc_add_component_ref (lhs, "$vptr"); - if (code->expr2->ts.type == BT_DERIVED) + if (expr2->ts.type == BT_DERIVED) { gfc_symbol *vtab; gfc_symtree *st; - vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived); + vtab = gfc_find_derived_vtab (expr2->ts.u.derived); gcc_assert (vtab); - gfc_trans_assign_vtab_procs (&block, code->expr2->ts.u.derived, vtab); + gfc_trans_assign_vtab_procs (&block, expr2->ts.u.derived, vtab); rhs = gfc_get_expr (); rhs->expr_type = EXPR_VARIABLE; gfc_find_sym_tree (vtab->name, NULL, 1, &st); rhs->symtree = st; rhs->ts = vtab->ts; } - else if (code->expr2->expr_type == EXPR_NULL) + else if (expr2->expr_type == EXPR_NULL) rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); else gcc_unreachable (); @@ -5734,15 +5742,15 @@ gfc_trans_class_assign (gfc_code *code) } /* Do the actual CLASS assignment. */ - if (code->expr2->ts.type == BT_CLASS) - code->op = EXEC_ASSIGN; + if (expr2->ts.type == BT_CLASS) + op = EXEC_ASSIGN; else - gfc_add_component_ref (code->expr1, "$data"); + gfc_add_component_ref (expr1, "$data"); - if (code->op == EXEC_ASSIGN) - tmp = gfc_trans_assign (code); - else if (code->op == EXEC_POINTER_ASSIGN) - tmp = gfc_trans_pointer_assign (code); + if (op == EXEC_ASSIGN) + tmp = gfc_trans_assignment (expr1, expr2, false, true); + else if (op == EXEC_POINTER_ASSIGN) + tmp = gfc_trans_pointer_assignment (expr1, expr2); else gcc_unreachable(); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index c277e8e..a576076 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -5559,4 +5559,42 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, } } + +tree +gfc_conv_intrinsic_move_alloc (gfc_code *code) +{ + if (code->ext.actual->expr->rank == 0) + { + /* Scalar arguments: Generate pointer assignments. */ + gfc_expr *from, *to; + stmtblock_t block; + tree tmp; + + from = code->ext.actual->expr; + to = code->ext.actual->next->expr; + + gfc_start_block (&block); + + if (to->ts.type == BT_CLASS) + tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN); + else + tmp = gfc_trans_pointer_assignment (to, from); + gfc_add_expr_to_block (&block, tmp); + + if (from->ts.type == BT_CLASS) + tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL), + EXEC_POINTER_ASSIGN); + else + tmp = gfc_trans_pointer_assignment (from, + gfc_get_null_expr (NULL)); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); + } + else + /* Array arguments: Generate library code. */ + return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false); +} + + #include "gt-fortran-trans-intrinsic.h" diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index b349545..8b77750 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -32,7 +32,8 @@ tree gfc_trans_code_cond (gfc_code *, tree); tree gfc_trans_assign (gfc_code *); tree gfc_trans_pointer_assign (gfc_code *); tree gfc_trans_init_assign (gfc_code *); -tree gfc_trans_class_assign (gfc_code *code); +tree gfc_trans_class_init_assign (gfc_code *); +tree gfc_trans_class_assign (gfc_expr *, gfc_expr *, gfc_exec_op); /* trans-stmt.c */ tree gfc_trans_cycle (gfc_code *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 4bd4f3b..e266be8 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1093,7 +1093,7 @@ trans_code (gfc_code * code, tree cond) case EXEC_ASSIGN: if (code->expr1->ts.type == BT_CLASS) - res = gfc_trans_class_assign (code); + res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); else res = gfc_trans_assign (code); break; @@ -1104,14 +1104,14 @@ trans_code (gfc_code * code, tree cond) case EXEC_POINTER_ASSIGN: if (code->expr1->ts.type == BT_CLASS) - res = gfc_trans_class_assign (code); + res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); else res = gfc_trans_pointer_assign (code); break; case EXEC_INIT_ASSIGN: if (code->expr1->ts.type == BT_CLASS) - res = gfc_trans_class_assign (code); + res = gfc_trans_class_init_assign (code); else res = gfc_trans_init_assign (code); break; @@ -1157,8 +1157,12 @@ trans_code (gfc_code * code, tree cond) if (code->resolved_isym && code->resolved_isym->id == GFC_ISYM_MVBITS) is_mvbits = true; - res = gfc_trans_call (code, is_mvbits, NULL_TREE, - NULL_TREE, false); + if (code->resolved_isym + && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC) + res = gfc_conv_intrinsic_move_alloc (code); + else + res = gfc_trans_call (code, is_mvbits, NULL_TREE, + NULL_TREE, false); } break; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 99f0dc0..3c80ce7 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -338,6 +338,8 @@ void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *); /* Does an intrinsic map directly to an external library call. */ int gfc_is_intrinsic_libcall (gfc_expr *); +tree gfc_conv_intrinsic_move_alloc (gfc_code *); + /* Used to call ordinary functions/subroutines and procedure pointer components. */ int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 88092cf..060b879 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-07-29 Janus Weil + + PR fortran/45004 + * gfortran.dg/move_alloc_2.f90: New. + 2010-07-29 Xinliang David Li PR tree-optimization/45121 * c-c++-common/uninit-17.c: Fix expected output. diff --git a/gcc/testsuite/gfortran.dg/move_alloc_2.f90 b/gcc/testsuite/gfortran.dg/move_alloc_2.f90 new file mode 100644 index 0000000..5dabca8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_2.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR 45004: [OOP] Segfault with allocatable scalars and move_alloc +! +! Contributed by Salvatore Filippone + +program bug18 + + type foo + integer :: i + end type foo + + type bar + class(foo), allocatable :: bf + end type bar + + class(foo), allocatable :: afab + type(bar) :: bb + + allocate(foo :: afab) + afab%i = 8 + call move_alloc(afab, bb%bf) + if (.not. allocated(bb%bf)) call abort() + if (allocated(afab)) call abort() + if (bb%bf%i/=8) call abort() + +end program bug18 -- 2.7.4