diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/fortran/check.c | 14 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 81 |
3 files changed, 69 insertions, 33 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3fee56d..72a7f74 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2011-12-03 Tobias Burnus <burnus@net-b.de> + + * check.c (gfc_check_move_alloc): Allow nonpolymorphic + FROM with polymorphic TO. + * trans-intrinsic.c (conv_intrinsic_move_alloc): Handle + nonpolymorphic FROM with polymorphic TO. + 2011-12-01 Janne Blomqvist <jb@gcc.gnu.org> * module.c (dt_lower_string): Make static. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 832eb64..605c77d 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2688,17 +2688,17 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) if (allocatable_check (to, 1) == FAILURE) return FAILURE; - if (same_type_check (to, 1, from, 0) == FAILURE) - return FAILURE; - - if (to->ts.type != from->ts.type) + if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED) { - gfc_error ("The FROM and TO arguments in MOVE_ALLOC call at %L must be " - "either both polymorphic or both nonpolymorphic", + gfc_error ("The TO arguments in MOVE_ALLOC at %L must be " + "polymorphic if FROM is polymorphic", &from->where); return FAILURE; } + if (same_type_check (to, 1, from, 0) == FAILURE) + return FAILURE; + if (to->rank != from->rank) { gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must " @@ -2718,7 +2718,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) return FAILURE; } - /* CLASS arguments: Make sure the vtab is present. */ + /* CLASS arguments: Make sure the vtab of from is present. */ if (to->ts.type == BT_CLASS) gfc_find_derived_vtab (from->ts.u.derived); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index d055275..855db30 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7184,7 +7184,7 @@ conv_intrinsic_move_alloc (gfc_code *code) { stmtblock_t block; gfc_expr *from_expr, *to_expr; - gfc_expr *to_expr2, *from_expr2; + gfc_expr *to_expr2, *from_expr2 = NULL; gfc_se from_se, to_se; gfc_ss *from_ss, *to_ss; tree tmp; @@ -7199,16 +7199,21 @@ conv_intrinsic_move_alloc (gfc_code *code) if (from_expr->rank == 0) { + gcc_assert (from_expr->ts.type != BT_CLASS + || to_expr->ts.type == BT_CLASS); if (from_expr->ts.type != BT_CLASS) + from_expr2 = from_expr; + else { - from_expr2 = to_expr; - to_expr2 = to_expr; + from_expr2 = gfc_copy_expr (from_expr); + gfc_add_data_component (from_expr2); } + + if (to_expr->ts.type != BT_CLASS) + to_expr2 = to_expr; else { to_expr2 = gfc_copy_expr (to_expr); - from_expr2 = gfc_copy_expr (from_expr); - gfc_add_data_component (from_expr2); gfc_add_data_component (to_expr2); } @@ -7236,48 +7241,72 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_block_to_block (&block, &to_se.post); /* Set _vptr. */ - if (from_expr->ts.type == BT_CLASS) + if (to_expr->ts.type == BT_CLASS) { - gfc_free_expr (from_expr2); - gfc_free_expr (to_expr2); - - gfc_init_se (&from_se, NULL); + gfc_free_expr (to_expr2); gfc_init_se (&to_se, NULL); - from_se.want_pointer = 1; to_se.want_pointer = 1; - gfc_add_vptr_component (from_expr); gfc_add_vptr_component (to_expr); - - gfc_conv_expr (&from_se, from_expr); gfc_conv_expr (&to_se, to_expr); + + if (from_expr->ts.type == BT_CLASS) + { + gfc_free_expr (from_expr2); + gfc_init_se (&from_se, NULL); + from_se.want_pointer = 1; + gfc_add_vptr_component (from_expr); + gfc_conv_expr (&from_se, from_expr); + tmp = from_se.expr; + } + else + { + gfc_symbol *vtab; + vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + } + gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), from_se.expr)); + fold_convert (TREE_TYPE (to_se.expr), tmp)); } return gfc_finish_block (&block); } /* Update _vptr component. */ - if (from_expr->ts.type == BT_CLASS) + if (to_expr->ts.type == BT_CLASS) { - from_se.want_pointer = 1; to_se.want_pointer = 1; - - from_expr2 = gfc_copy_expr (from_expr); to_expr2 = gfc_copy_expr (to_expr); - gfc_add_vptr_component (from_expr2); gfc_add_vptr_component (to_expr2); - - gfc_conv_expr (&from_se, from_expr2); gfc_conv_expr (&to_se, to_expr2); + if (from_expr->ts.type == BT_CLASS) + { + from_se.want_pointer = 1; + from_expr2 = gfc_copy_expr (from_expr); + gfc_add_vptr_component (from_expr2); + gfc_conv_expr (&from_se, from_expr2); + tmp = from_se.expr; + } + else + { + gfc_symbol *vtab; + vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + } + gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), from_se.expr)); + fold_convert (TREE_TYPE (to_se.expr), tmp)); gfc_free_expr (to_expr2); - gfc_free_expr (from_expr2); - - gfc_init_se (&from_se, NULL); gfc_init_se (&to_se, NULL); + + if (from_expr->ts.type == BT_CLASS) + { + gfc_free_expr (from_expr2); + gfc_init_se (&from_se, NULL); + } } /* Deallocate "to". */ |