This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
Other format: | [Raw text] |
:ADDPATCH fortran: This patch is described by the ChangeLogs and the comments in the text. The problem is that default initializers at present force the variable to be TREE_STATIC or SAVED. Thus they are only initialized once during the execution of a program. The standard requires that they be initialized every time they come into scope. This is accomplished by building an lvalue expression from the symbol and deploying gfc_trans_assignment with the 'value' expression as the lvalue. The testcase contains, more or less, the two provided by the reporter. Bootstrapped and regtested on x86_ia64/FC5 - OK for trunk? Paul -- The knack of flying is learning how to throw yourself at the ground and miss. --Hitchhikers Guide to the Galaxy
Attachment:
commit.msg
Description: Binary data
Index: gcc/fortran/trans-decl.c =================================================================== *** gcc/fortran/trans-decl.c (revision 130987) --- gcc/fortran/trans-decl.c (working copy) *************** gfc_finish_var_decl (tree decl, gfc_symb *** 517,524 **** TREE_STATIC (decl) = 1; } ! if ((sym->attr.save || sym->attr.data || sym->value) ! && !sym->attr.use_assoc) TREE_STATIC (decl) = 1; if (sym->attr.volatile_) --- 517,531 ---- TREE_STATIC (decl) = 1; } ! /* 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_) *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 995,1000 **** --- 1002,1015 ---- 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); *************** gfc_trans_vla_type_sizes (gfc_symbol *sy *** 2572,2615 **** } /* 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_expr *tmpe; - tree tmp; - tree present; 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) ! { ! 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); ! } ! } 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: Allocation and initialization of array variables. --- 2587,2633 ---- } + /* Initialize a derived type by building an lvalue from the symbol + and using trans_assignment to do the work. */ + static tree + init_default_dt (gfc_symbol * sym, tree body) + { + stmtblock_t fnblock; + gfc_expr *e; + tree tmp; + + gfc_init_block (&fnblock); + 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); + 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: Allocation and initialization of array variables. *************** gfc_trans_deferred_vars (gfc_symbol * pr *** 2698,2703 **** --- 2716,2726 ---- 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); *************** gfc_trans_deferred_vars (gfc_symbol * pr *** 2753,2758 **** --- 2776,2786 ---- 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 (); } Index: /svn/trunk/gcc/testsuite/gfortran.dg/default_initialization_3.f90 =================================================================== *** /svn/trunk/gcc/testsuite/gfortran.dg/default_initialization_3.f90 (revision 0) --- /svn/trunk/gcc/testsuite/gfortran.dg/default_initialization_3.f90 (revision 0) *************** *** 0 **** --- 1,76 ---- + ! { 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 <sven.buijssen@math.uni-dortmund.de> + ! + 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 + + ! Run both tests. + call original + call other + end
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |