Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (revision 162480) +++ gcc/fortran/trans-expr.c (working copy) @@ -5671,11 +5671,38 @@ void gfc_trans_assign_vtab_procs (stmtblock_t *blo } +/* 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_intrinsic_op op) { stmtblock_t block; tree tmp; @@ -5683,45 +5710,26 @@ tree 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 @@ tree } /* 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(); Index: gcc/fortran/trans-stmt.h =================================================================== --- gcc/fortran/trans-stmt.h (revision 162480) +++ gcc/fortran/trans-stmt.h (working copy) @@ -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_intrinsic_op); /* trans-stmt.c */ tree gfc_trans_cycle (gfc_code *); Index: gcc/fortran/trans.c =================================================================== --- gcc/fortran/trans.c (revision 162480) +++ gcc/fortran/trans.c (working copy) @@ -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; Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (revision 162480) +++ gcc/fortran/trans.h (working copy) @@ -338,6 +338,8 @@ void gfc_conv_intrinsic_function (gfc_se *, gfc_ex /* 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 *, Index: gcc/fortran/trans-intrinsic.c =================================================================== --- gcc/fortran/trans-intrinsic.c (revision 162480) +++ gcc/fortran/trans-intrinsic.c (working copy) @@ -5559,4 +5559,42 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_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"