Commit b2a5eb75 by Janus Weil

re PR fortran/45004 ([OOP] Segfault with allocatable scalars and move_alloc)

2010-07-29  Janus Weil  <janus@gcc.gnu.org>

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

	PR fortran/45004
	* gfortran.dg/move_alloc_2.f90: New.

From-SVN: r162688
parent a3378cea
2010-07-29 Janus Weil <janus@gcc.gnu.org>
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 <mikael@gcc.gnu.org> 2010-07-29 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/42051 PR fortran/42051
......
...@@ -5671,11 +5671,38 @@ void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt, ...@@ -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 /* Translate an assignment to a CLASS object
(pointer or ordinary assignment). */ (pointer or ordinary assignment). */
tree 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; stmtblock_t block;
tree tmp; tree tmp;
...@@ -5683,45 +5710,26 @@ gfc_trans_class_assign (gfc_code *code) ...@@ -5683,45 +5710,26 @@ gfc_trans_class_assign (gfc_code *code)
gfc_expr *rhs; gfc_expr *rhs;
gfc_start_block (&block); 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. */ /* 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"); gfc_add_component_ref (lhs, "$vptr");
if (code->expr2->ts.type == BT_DERIVED) if (expr2->ts.type == BT_DERIVED)
{ {
gfc_symbol *vtab; gfc_symbol *vtab;
gfc_symtree *st; 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); 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 = gfc_get_expr ();
rhs->expr_type = EXPR_VARIABLE; rhs->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (vtab->name, NULL, 1, &st); gfc_find_sym_tree (vtab->name, NULL, 1, &st);
rhs->symtree = st; rhs->symtree = st;
rhs->ts = vtab->ts; 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); rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
else else
gcc_unreachable (); gcc_unreachable ();
...@@ -5734,15 +5742,15 @@ gfc_trans_class_assign (gfc_code *code) ...@@ -5734,15 +5742,15 @@ gfc_trans_class_assign (gfc_code *code)
} }
/* Do the actual CLASS assignment. */ /* Do the actual CLASS assignment. */
if (code->expr2->ts.type == BT_CLASS) if (expr2->ts.type == BT_CLASS)
code->op = EXEC_ASSIGN; op = EXEC_ASSIGN;
else else
gfc_add_component_ref (code->expr1, "$data"); gfc_add_component_ref (expr1, "$data");
if (code->op == EXEC_ASSIGN) if (op == EXEC_ASSIGN)
tmp = gfc_trans_assign (code); tmp = gfc_trans_assignment (expr1, expr2, false, true);
else if (code->op == EXEC_POINTER_ASSIGN) else if (op == EXEC_POINTER_ASSIGN)
tmp = gfc_trans_pointer_assign (code); tmp = gfc_trans_pointer_assignment (expr1, expr2);
else else
gcc_unreachable(); gcc_unreachable();
......
...@@ -5559,4 +5559,42 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, ...@@ -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" #include "gt-fortran-trans-intrinsic.h"
...@@ -32,7 +32,8 @@ tree gfc_trans_code_cond (gfc_code *, tree); ...@@ -32,7 +32,8 @@ tree gfc_trans_code_cond (gfc_code *, tree);
tree gfc_trans_assign (gfc_code *); tree gfc_trans_assign (gfc_code *);
tree gfc_trans_pointer_assign (gfc_code *); tree gfc_trans_pointer_assign (gfc_code *);
tree gfc_trans_init_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 */ /* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *); tree gfc_trans_cycle (gfc_code *);
......
...@@ -1093,7 +1093,7 @@ trans_code (gfc_code * code, tree cond) ...@@ -1093,7 +1093,7 @@ trans_code (gfc_code * code, tree cond)
case EXEC_ASSIGN: case EXEC_ASSIGN:
if (code->expr1->ts.type == BT_CLASS) 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 else
res = gfc_trans_assign (code); res = gfc_trans_assign (code);
break; break;
...@@ -1104,14 +1104,14 @@ trans_code (gfc_code * code, tree cond) ...@@ -1104,14 +1104,14 @@ trans_code (gfc_code * code, tree cond)
case EXEC_POINTER_ASSIGN: case EXEC_POINTER_ASSIGN:
if (code->expr1->ts.type == BT_CLASS) 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 else
res = gfc_trans_pointer_assign (code); res = gfc_trans_pointer_assign (code);
break; break;
case EXEC_INIT_ASSIGN: case EXEC_INIT_ASSIGN:
if (code->expr1->ts.type == BT_CLASS) if (code->expr1->ts.type == BT_CLASS)
res = gfc_trans_class_assign (code); res = gfc_trans_class_init_assign (code);
else else
res = gfc_trans_init_assign (code); res = gfc_trans_init_assign (code);
break; break;
...@@ -1157,8 +1157,12 @@ trans_code (gfc_code * code, tree cond) ...@@ -1157,8 +1157,12 @@ trans_code (gfc_code * code, tree cond)
if (code->resolved_isym if (code->resolved_isym
&& code->resolved_isym->id == GFC_ISYM_MVBITS) && code->resolved_isym->id == GFC_ISYM_MVBITS)
is_mvbits = true; is_mvbits = true;
res = gfc_trans_call (code, is_mvbits, NULL_TREE, if (code->resolved_isym
NULL_TREE, false); && 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; break;
......
...@@ -338,6 +338,8 @@ void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *); ...@@ -338,6 +338,8 @@ void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
/* Does an intrinsic map directly to an external library call. */ /* Does an intrinsic map directly to an external library call. */
int gfc_is_intrinsic_libcall (gfc_expr *); int gfc_is_intrinsic_libcall (gfc_expr *);
tree gfc_conv_intrinsic_move_alloc (gfc_code *);
/* Used to call ordinary functions/subroutines /* Used to call ordinary functions/subroutines
and procedure pointer components. */ and procedure pointer components. */
int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *, int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
......
2010-07-29 Janus Weil <janus@gcc.gnu.org>
PR fortran/45004
* gfortran.dg/move_alloc_2.f90: New.
2010-07-29 Xinliang David Li <davidxl@google.com> 2010-07-29 Xinliang David Li <davidxl@google.com>
PR tree-optimization/45121 PR tree-optimization/45121
* c-c++-common/uninit-17.c: Fix expected output. * c-c++-common/uninit-17.c: Fix expected output.
......
! { dg-do run }
!
! PR 45004: [OOP] Segfault with allocatable scalars and move_alloc
!
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
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
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