diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f313736ffcb..0271eb9408b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2010-01-31 Janus Weil + + PR fortran/42888 + * resolve.c (resolve_allocate_expr): Move default initialization code + here from gfc_trans_allocate. + * trans.c (gfc_trans_code): Call gfc_trans_class_assign also for + EXEC_INIT_ASSIGN. + * trans-expr.c (gfc_trans_class_assign): Handle default initialization + of CLASS variables via memcpy. + * trans-stmt.c (gfc_trans_allocate): Move default initialization code + to resolve_allocate_expr. + 2010-01-31 Paul Thomas PR fortran/38324 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fe98b7e0a54..d0aa6adf9c3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6099,6 +6099,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_symbol *sym; gfc_alloc *a; gfc_component *c; + gfc_expr *init_e; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; @@ -6223,6 +6224,36 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) sym->name, &e->where); return FAILURE; } + + if (!code->expr3) + { + /* Add default initializer for those derived types that need them. */ + if (e->ts.type == BT_DERIVED + && (init_e = gfc_default_initializer (&e->ts))) + { + gfc_code *init_st = gfc_get_code (); + init_st->loc = code->loc; + init_st->op = EXEC_INIT_ASSIGN; + init_st->expr1 = gfc_expr_to_initialize (e); + init_st->expr2 = init_e; + init_st->next = code->next; + code->next = init_st; + } + else if (e->ts.type == BT_CLASS + && ((code->ext.alloc.ts.type == BT_UNKNOWN + && (init_e = gfc_default_initializer (&e->ts.u.derived->components->ts))) + || (code->ext.alloc.ts.type == BT_DERIVED + && (init_e = gfc_default_initializer (&code->ext.alloc.ts))))) + { + gfc_code *init_st = gfc_get_code (); + init_st->loc = code->loc; + init_st->op = EXEC_INIT_ASSIGN; + init_st->expr1 = gfc_expr_to_initialize (e); + init_st->expr2 = init_e; + init_st->next = code->next; + code->next = init_st; + } + } if (pointer || dimension == 0) return SUCCESS; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 95ae8138867..b5091a9e4d5 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5519,6 +5519,25 @@ 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) { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 010d86f2acb..dd3d10db5d6 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4018,7 +4018,7 @@ tree gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; - gfc_expr *expr, *init_e; + gfc_expr *expr; gfc_se se; tree tmp; tree parm; @@ -4162,28 +4162,6 @@ gfc_trans_allocate (gfc_code * code) gfc_free_expr (rhs); gfc_add_expr_to_block (&block, tmp); } - /* Default initializer for CLASS variables. */ - else if (al->expr->ts.type == BT_CLASS - && code->ext.alloc.ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&code->ext.alloc.ts))) - { - gfc_se dst,src; - gfc_init_se (&dst, NULL); - gfc_init_se (&src, NULL); - gfc_conv_expr (&dst, expr); - gfc_conv_expr (&src, init_e); - gfc_add_block_to_block (&block, &src.pre); - tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); - gfc_add_expr_to_block (&block, tmp); - } - /* Add default initializer for those derived types that need them. */ - else if (expr->ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&expr->ts))) - { - tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), - init_e, true); - gfc_add_expr_to_block (&block, tmp); - } /* Allocation of CLASS entities. */ gfc_free_expr (expr); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index a107392e094..a5bb6418780 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1098,7 +1098,10 @@ gfc_trans_code (gfc_code * code) break; case EXEC_INIT_ASSIGN: - res = gfc_trans_init_assign (code); + if (code->expr1->ts.type == BT_CLASS) + res = gfc_trans_class_assign (code); + else + res = gfc_trans_init_assign (code); break; case EXEC_CONTINUE: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 482f1962b45..a2d83441672 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-01-31 Janus Weil + + PR fortran/42888 + * gfortran.dg/allocate_derived_2.f90: New test. + 2010-01-31 Eric Botcazou PR middle-end/42898 diff --git a/gcc/testsuite/gfortran.dg/allocate_derived_2.f90 b/gcc/testsuite/gfortran.dg/allocate_derived_2.f90 new file mode 100644 index 00000000000..8d01224f15e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_derived_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR 42888: [4.5 Regression] ICE in fold_convert_loc, at fold-const.c:2670 +! +! Contributed by Harald Anlauf + + implicit none + + type t + integer :: X = -999.0 ! Real initializer! + end type t + + type(t), allocatable :: x + class(t), allocatable :: y,z + + allocate (x) + allocate (y) + allocate (t::z) + +end