From 50f308010c3fabfd87f32576b44220469196de1d Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Wed, 1 Sep 2010 22:50:46 +0200 Subject: [PATCH] re PR fortran/44541 ([OOP] wrong code for polymorphic variable with INTENT(OUT)/Alloc w/ MOLD) 2010-09-01 Janus Weil PR fortran/44541 * class.c (gfc_find_derived_vtab): Add component '$def_init'. * resolve.c (resolve_allocate_expr): Defer handling of default initialization to 'gfc_trans_allocate'. (apply_default_init,resolve_symbol): Handle polymorphic dummies. (resolve_fl_derived): Suppress error messages for vtypes. * trans-stmt.c (gfc_trans_allocate): Handle initialization via polymorphic MOLD expression. * trans-expr.c (gfc_trans_class_init_assign): Now only used for dummy initialization. 2010-09-01 Janus Weil PR fortran/44541 * gfortran.dg/allocate_alloc_opt_10.f90: Extended. * gfortran.dg/class_dummy_1.f03: New. From-SVN: r163744 --- gcc/fortran/ChangeLog | 13 +++++ gcc/fortran/class.c | 31 +++++++++++- gcc/fortran/resolve.c | 47 +++++------------- gcc/fortran/trans-expr.c | 36 +++++++++----- gcc/fortran/trans-stmt.c | 48 +++++++++++++++++++ gcc/testsuite/ChangeLog | 6 +++ .../gfortran.dg/allocate_alloc_opt_10.f90 | 24 +++++----- gcc/testsuite/gfortran.dg/class_dummy_1.f03 | 43 +++++++++++++++++ 8 files changed, 188 insertions(+), 60 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_dummy_1.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0078863ebff0..7169de88001e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2010-09-01 Janus Weil + + PR fortran/44541 + * class.c (gfc_find_derived_vtab): Add component '$def_init'. + * resolve.c (resolve_allocate_expr): Defer handling of default + initialization to 'gfc_trans_allocate'. + (apply_default_init,resolve_symbol): Handle polymorphic dummies. + (resolve_fl_derived): Suppress error messages for vtypes. + * trans-stmt.c (gfc_trans_allocate): Handle initialization via + polymorphic MOLD expression. + * trans-expr.c (gfc_trans_class_init_assign): Now only used for + dummy initialization. + 2010-09-01 Tobias Burnus * gfortran.texi (preprocessing): Update URL to COCO. diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index df3a314c980c..218247dbfaa7 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -319,7 +319,7 @@ gfc_symbol * gfc_find_derived_vtab (gfc_symbol *derived) { gfc_namespace *ns; - gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL; + gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; char name[2 * GFC_MAX_SYMBOL_LEN + 8]; /* Find the top-level namespace (MODULE or PROGRAM). */ @@ -408,6 +408,33 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->initializer = gfc_get_null_expr (NULL); } + /* Add component $def_init. */ + if (gfc_add_component (vtype, "$def_init", &c) == FAILURE) + goto cleanup; + c->attr.pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->ts.type = BT_DERIVED; + c->ts.u.derived = derived; + if (derived->attr.abstract) + c->initializer = NULL; + else + { + /* Construct default initialization variable. */ + sprintf (name, "def_init$%s", derived->name); + gfc_get_symbol (name, ns, &def_init); + def_init->attr.target = 1; + def_init->attr.save = SAVE_EXPLICIT; + def_init->attr.access = ACCESS_PUBLIC; + def_init->attr.flavor = FL_VARIABLE; + gfc_set_sym_referenced (def_init); + def_init->ts.type = BT_DERIVED; + def_init->ts.u.derived = derived; + def_init->value = gfc_default_initializer (&def_init->ts); + + c->initializer = gfc_lval_expr_from_sym (def_init); + } + + /* Add procedure pointers for type-bound procedures. */ add_procs_to_declared_vtab (derived, vtype); vtype->attr.vtype = 1; } @@ -427,6 +454,8 @@ cleanup: gfc_commit_symbol (vtab); if (vtype) gfc_commit_symbol (vtype); + if (def_init) + gfc_commit_symbol (def_init); } else gfc_undo_symbols (); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 45696abab3d0..b6980a69eaa7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6710,37 +6710,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) sym->name, &e->where); goto failure; } - - if (!code->expr3 || code->expr3->mold) - { - /* Add default initializer for those derived types that need them. */ - gfc_expr *init_e = NULL; - gfc_typespec ts; - - if (code->ext.alloc.ts.type == BT_DERIVED) - ts = code->ext.alloc.ts; - else if (code->expr3) - ts = code->expr3->ts; - else - ts = e->ts; - - if (ts.type == BT_DERIVED) - init_e = gfc_default_initializer (&ts); - /* FIXME: Use default init of dynamic type (cf. PR 44541). */ - else if (e->ts.type == BT_CLASS) - init_e = gfc_default_initializer (&ts.u.derived->components->ts); - - if (init_e) - { - 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 (e->ts.type == BT_CLASS) { @@ -9503,7 +9472,7 @@ apply_default_init (gfc_symbol *sym) if (sym->ts.type == BT_DERIVED && sym->ts.u.derived) init = gfc_default_initializer (&sym->ts); - if (init == NULL) + if (init == NULL && sym->ts.type != BT_CLASS) return; build_init_assign (sym, init); @@ -11429,7 +11398,7 @@ resolve_fl_derived (gfc_symbol *sym) } /* Check type-spec if this is not the parent-type component. */ - if ((!sym->attr.extension || c != sym->components) + if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE) return FAILURE; @@ -11488,8 +11457,8 @@ resolve_fl_derived (gfc_symbol *sym) } } - if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer - && c->ts.u.derived->components == NULL + if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype + && c->attr.pointer && c->ts.u.derived->components == NULL && !c->ts.u.derived->attr.zero_comp) { gfc_error ("The pointer component '%s' of '%s' at %L is a type " @@ -12194,6 +12163,14 @@ resolve_symbol (gfc_symbol *sym) apply_default_init (sym); } + if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns + && sym->attr.dummy && sym->attr.intent == INTENT_OUT + && !sym->attr.pointer && !sym->attr.allocatable) + { + apply_default_init (sym); + gfc_set_sym_referenced (sym); + } + /* If this symbol has a type-spec, check it. */ if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b4bc8caa6961..937a8324df8b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5760,27 +5760,39 @@ gfc_trans_assign (gfc_code * code) } -/* 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. */ +/* Special case for initializing a polymorphic dummy with INTENT(OUT). + A MEMCPY is needed to copy the full data from the default initializer + of the dynamic type. */ tree gfc_trans_class_init_assign (gfc_code *code) { stmtblock_t block; - tree tmp, memsz; - gfc_se dst,src; - + tree tmp; + gfc_se dst,src,memsz; + gfc_expr *lhs,*rhs,*sz; + gfc_start_block (&block); - + + lhs = gfc_copy_expr (code->expr1); + gfc_add_component_ref (lhs, "$data"); + + rhs = gfc_copy_expr (code->expr1); + gfc_add_component_ref (rhs, "$vptr"); + gfc_add_component_ref (rhs, "$def_init"); + + sz = gfc_copy_expr (code->expr1); + gfc_add_component_ref (sz, "$vptr"); + gfc_add_component_ref (sz, "$size"); + 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_init_se (&memsz, NULL); + gfc_conv_expr (&dst, lhs); + gfc_conv_expr (&src, rhs); + gfc_conv_expr (&memsz, sz); 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); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 747f08a20b06..d9b60a60b492 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4399,6 +4399,54 @@ gfc_trans_allocate (gfc_code * code) gfc_free_expr (rhs); gfc_add_expr_to_block (&block, tmp); } + else + { + /* Add default initializer for those derived types that need them. */ + gfc_expr *rhs = NULL; + gfc_typespec ts; + + if (code->ext.alloc.ts.type == BT_DERIVED) + ts = code->ext.alloc.ts; + else if (code->expr3) + ts = code->expr3->ts; + else + ts = expr->ts; + + if (ts.type == BT_DERIVED) + { + rhs = gfc_default_initializer (&ts); + gfc_resolve_expr (rhs); + } + else if (ts.type == BT_CLASS) + { + rhs = gfc_copy_expr (code->expr3); + gfc_add_component_ref (rhs, "$vptr"); + gfc_add_component_ref (rhs, "$def_init"); + } + + if (rhs) + { + gfc_expr *lhs = gfc_expr_to_initialize (expr); + if (al->expr->ts.type == BT_DERIVED) + { + tmp = gfc_trans_assignment (lhs, rhs, true, false); + gfc_add_expr_to_block (&block, tmp); + } + else if (al->expr->ts.type == BT_CLASS) + { + gfc_se dst,src; + gfc_init_se (&dst, NULL); + gfc_init_se (&src, NULL); + gfc_conv_expr (&dst, lhs); + gfc_conv_expr (&src, rhs); + 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); + } + gfc_free_expr (lhs); + gfc_free_expr (rhs); + } + } /* Allocation of CLASS entities. */ gfc_free_expr (expr); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index fbe877c6de79..1fd07c787356 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2010-09-01 Janus Weil + + PR fortran/44541 + * gfortran.dg/allocate_alloc_opt_10.f90: Extended. + * gfortran.dg/class_dummy_1.f03: New. + 2010-09-01 Jakub Jelinek PR middle-end/45458 diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_10.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_10.f90 index 5bccefaaf151..f5dae1ac6e81 100644 --- a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_10.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_10.f90 @@ -16,7 +16,7 @@ class(t1),allocatable :: x,y type(t2) :: z -!!! first example (works) +!!! first example (static) z%j = 5 allocate(x,MOLD=z) @@ -25,22 +25,22 @@ select type (x) type is (t2) print *,x%j if (x%j/=4) call abort + x%j = 5 class default call abort() end select -!!! second example (fails) -!!! FIXME: uncomment once implemented (cf. PR 44541) +!!! second example (dynamic, PR 44541) -! allocate(y,MOLD=x) -! -! select type (y) -! type is (t2) -! print *,y%j -! if (y%j/=4) call abort -! class default -! call abort() -! end select +allocate(y,MOLD=x) + +select type (y) +type is (t2) + print *,y%j + if (y%j/=4) call abort +class default + call abort() +end select end diff --git a/gcc/testsuite/gfortran.dg/class_dummy_1.f03 b/gcc/testsuite/gfortran.dg/class_dummy_1.f03 new file mode 100644 index 000000000000..950379027fd6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_dummy_1.f03 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! PR 44541: [OOP] wrong code for polymorphic variable with INTENT(OUT)/Alloc w/ MOLD +! +! Contributed by Tobias Burnus + + implicit none + + type t + integer :: a = 1 + end type t + + type, extends(t) :: t2 + integer :: b = 3 + end type t2 + + type(t2) :: y + + y%a = 44 + y%b = 55 + call intent_out (y) + if (y%a/=1 .or. y%b/=3) call abort() + + y%a = 66 + y%b = 77 + call intent_out_unused (y) + if (y%a/=1 .or. y%b/=3) call abort() + +contains + + subroutine intent_out(x) + class(t), intent(out) :: x + select type (x) + type is (t2) + if (x%a/=1 .or. x%b/=3) call abort() + end select + end subroutine + + subroutine intent_out_unused(x) + class(t), intent(out) :: x + end subroutine + +end