From: Paul Thomas Date: Fri, 21 Dec 2007 21:20:38 +0000 (+0000) Subject: re PR fortran/34438 (gfortran not compliant w.r.t default initialization of derived... X-Git-Tag: releases/gcc-4.3.0~849 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=b7b184a86b471a0cdcdd69062cc2e5827bede7b2;p=thirdparty%2Fgcc.git re PR fortran/34438 (gfortran not compliant w.r.t default initialization of derived type component and implicit SAVE attribute) 2007-12-21 Paul Thomas PR fortran/34438 * trans-decl.c (gfc_finish_var_decl): Do not mark derived types with default initializers as TREE_STATIC unless they are in the main program scope. (gfc_get_symbol_decl): Pass derived types with a default initializer to gfc_defer_symbol_init. (init_default_dt): Apply default initializer to a derived type. (init_intent_out_dt): Call init_default_dt. (gfc_trans_deferred_vars): Ditto. * module.c (read_module): Check sym->module is there before using it in a string comparison. 2007-12-21 Paul Thomas PR fortran/34438 * gfortran.dg/default_initialization_3.f90: New test. From-SVN: r131124 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4701a2f00c8c..f90a07788121 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2007-12-21 Paul Thomas + + PR fortran/34438 + * trans-decl.c (gfc_finish_var_decl): Do not mark derived types + with default initializers as TREE_STATIC unless they are in the + main program scope. + (gfc_get_symbol_decl): Pass derived types with a default + initializer to gfc_defer_symbol_init. + (init_default_dt): Apply default initializer to a derived type. + (init_intent_out_dt): Call init_default_dt. + (gfc_trans_deferred_vars): Ditto. + + * module.c (read_module): Check sym->module is there before + using it in a string comparison. + 2007-12-20 Tobias Burnus PR fortran/34482 diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 9cb082a4f782..f3c54b7d0a61 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -3732,6 +3732,7 @@ read_module (void) if (st && only_flag && !st->n.sym->attr.use_only && !st->n.sym->attr.use_rename + && st->n.sym->module && strcmp (st->n.sym->module, module_name) == 0) st->name = gfc_get_string ("hidden.%s", name); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 876219fed660..f97870cf7c94 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -517,8 +517,15 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) TREE_STATIC (decl) = 1; } - if ((sym->attr.save || sym->attr.data || sym->value) - && !sym->attr.use_assoc) + /* Derived types are a bit peculiar because of the possibility of + a default initializer; this must be applied each time the variable + comes into scope it therefore need not be static. These variables + are SAVE_NONE but have an initializer. Otherwise explicitly + intitialized variables are SAVE_IMPLICIT and explicitly saved are + SAVE_EXPLICIT. */ + if (!sym->attr.use_assoc + && (sym->attr.save != SAVE_NONE || sym->attr.data + || (sym->value && sym->ns->proc_name->attr.is_main_program))) TREE_STATIC (decl) = 1; if (sym->attr.volatile_) @@ -995,6 +1002,14 @@ gfc_get_symbol_decl (gfc_symbol * sym) if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp) gfc_defer_symbol_init (sym); + /* This applies a derived type default initializer. */ + else if (sym->ts.type == BT_DERIVED + && sym->attr.save == SAVE_NONE + && !sym->attr.data + && !sym->attr.allocatable + && (sym->value && !sym->ns->proc_name->attr.is_main_program) + && !sym->attr.use_assoc) + gfc_defer_symbol_init (sym); gfc_finish_var_decl (decl, sym); @@ -2572,43 +2587,53 @@ gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body) } -/* Initialize INTENT(OUT) derived type dummies. */ +/* Initialize a derived type by building an lvalue from the symbol + and using trans_assignment to do the work. */ static tree -init_intent_out_dt (gfc_symbol * proc_sym, tree body) +init_default_dt (gfc_symbol * sym, tree body) { stmtblock_t fnblock; - gfc_formal_arglist *f; - gfc_expr *tmpe; + gfc_expr *e; tree tmp; tree present; gfc_init_block (&fnblock); - - for (f = proc_sym->formal; f; f = f->next) + gcc_assert (!sym->attr.allocatable); + gfc_set_sym_referenced (sym); + e = gfc_lval_expr_from_sym (sym); + tmp = gfc_trans_assignment (e, sym->value, false); + if (sym->attr.dummy) { - if (f->sym && f->sym->attr.intent == INTENT_OUT - && f->sym->ts.type == BT_DERIVED - && !f->sym->ts.derived->attr.alloc_comp - && f->sym->value) - { - gcc_assert (!f->sym->attr.allocatable); - gfc_set_sym_referenced (f->sym); - tmpe = gfc_lval_expr_from_sym (f->sym); - tmp = gfc_trans_assignment (tmpe, f->sym->value, false); - - present = gfc_conv_expr_present (f->sym); - tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, - tmp, build_empty_stmt ()); - gfc_add_expr_to_block (&fnblock, tmp); - gfc_free_expr (tmpe); - } + present = gfc_conv_expr_present (sym); + tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, + tmp, build_empty_stmt ()); } - + gfc_add_expr_to_block (&fnblock, tmp); + gfc_free_expr (e); gfc_add_expr_to_block (&fnblock, body); return gfc_finish_block (&fnblock); } +/* Initialize INTENT(OUT) derived type dummies. */ +static tree +init_intent_out_dt (gfc_symbol * proc_sym, tree body) +{ + stmtblock_t fnblock; + gfc_formal_arglist *f; + + gfc_init_block (&fnblock); + for (f = proc_sym->formal; f; f = f->next) + if (f->sym && f->sym->attr.intent == INTENT_OUT + && f->sym->ts.type == BT_DERIVED + && !f->sym->ts.derived->attr.alloc_comp + && f->sym->value) + body = init_default_dt (f->sym, body); + + gfc_add_expr_to_block (&fnblock, body); + return gfc_finish_block (&fnblock); +} + /* Generate function entry and exit code, and add it to the function body. This includes: @@ -2698,6 +2723,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) seen_trans_deferred_array = true; fnbody = gfc_trans_deferred_array (sym, fnbody); } + else if (sym->ts.type == BT_DERIVED + && sym->value + && !sym->attr.data + && sym->attr.save == SAVE_NONE) + fnbody = init_default_dt (sym, fnbody); gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); @@ -2753,6 +2783,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) fnbody = gfc_trans_assign_aux_var (sym, fnbody); gfc_set_backend_locus (&loc); } + else if (sym->ts.type == BT_DERIVED + && sym->value + && !sym->attr.data + && sym->attr.save == SAVE_NONE) + fnbody = init_default_dt (sym, fnbody); else gcc_unreachable (); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a70318841ae2..3e4d2db0c48a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-12-21 Paul Thomas + + PR fortran/34438 + * gfortran.dg/default_initialization_3.f90: New test. + 2007-12-21 Richard Sandiford * gcc.target/mips/mips.exp (setup_mips_tests): Fix _MIPS_SIM diff --git a/gcc/testsuite/gfortran.dg/default_initialization_3.f90 b/gcc/testsuite/gfortran.dg/default_initialization_3.f90 new file mode 100644 index 000000000000..43651985dcd3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/default_initialization_3.f90 @@ -0,0 +1,108 @@ +! { dg-do run } +! Test the fix for PR34438, in which default initializers +! forced the derived type to be static; ie. initialized once +! during the lifetime of the programme. Instead, they should +! be initialized each time they come into scope. +! +! Contributed by Sven Buijssen +! Third test is from Dominique Dhumieres +! +module demo + type myint + integer :: bar = 42 + end type myint +end module demo + +! As the name implies, this was the original testcase +! provided by the contributor.... +subroutine original + use demo + integer val1 (6) + integer val2 (6) + call recfunc (1) + if (any (val1 .ne. (/1, 2, 3, 1, 2, 3/))) call abort () + if (any (val2 .ne. (/1, 2, 3, 4, 4, 4/))) call abort () +contains + + recursive subroutine recfunc (ivalue) + integer, intent(in) :: ivalue + type(myint) :: foo1 + type(myint) :: foo2 = myint (99) + foo1%bar = ivalue + foo2%bar = ivalue + if (ivalue .le. 3) then + val1(ivalue) = foo1%bar + val2(ivalue) = foo2%bar + call recfunc (ivalue + 1) + val1(ivalue + 3) = foo1%bar + val2(ivalue + 3) = foo2%bar + endif + end subroutine recfunc +end subroutine original + +! ...who came up with this one too. +subroutine func (ivalue, retval1, retval2) + use demo + integer, intent(in) :: ivalue + type(myint) :: foo1 + type(myint) :: foo2 = myint (77) + type(myint) :: retval1 + type(myint) :: retval2 + retval1 = foo1 + retval2 = foo2 + foo1%bar = 999 + foo2%bar = 999 +end subroutine func + +subroutine other + use demo + interface + subroutine func(ivalue, rv1, rv2) + use demo + integer, intent(in) :: ivalue + type(myint) :: foo, rv1, rv2 + end subroutine func + end interface + type(myint) :: val1, val2 + call func (1, val1, val2) + if ((val1%bar .ne. 42) .or. (val2%bar .ne. 77)) call abort () + call func (2, val1, val2) + if ((val1%bar .ne. 42) .or. (val2%bar .ne. 999)) call abort () + +end subroutine other + +MODULE M1 + TYPE T1 + INTEGER :: i=7 + END TYPE T1 +CONTAINS + FUNCTION F1(d1) RESULT(res) + INTEGER :: res + TYPE(T1), INTENT(OUT) :: d1 + TYPE(T1), INTENT(INOUT) :: d2 + res=d1%i + d1%i=0 + RETURN + ENTRY E1(d2) RESULT(res) + res=d2%i + d2%i=0 + END FUNCTION F1 +END MODULE M1 + +! This tests the fix of a regression caused by the first version +! of the patch. +subroutine dominique () + USE M1 + TYPE(T1) :: D1 + D1=T1(3) + if (F1(D1) .ne. 7) call abort () + D1=T1(3) + if (E1(D1) .ne. 3) call abort () +END + +! Run both tests. + call original + call other + call dominique +end +! { dg-final { cleanup-modules "demo M1" } }