+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>
PR fortran/42051
}
+/* 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;
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 ();
}
/* 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();
}
}
+
+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"
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 *);
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;
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;
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;
/* 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 *,
+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>
PR tree-optimization/45121
* c-c++-common/uninit-17.c: Fix expected output.
--- /dev/null
+! { 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
projects / gcc.git / commitdiff