Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (révision 117821) --- gcc/fortran/trans-expr.c (copie de travail) *************** gfc_conv_function_call (gfc_se * se, gfc *** 2031,2037 **** && fsym->value) { gcc_assert (!fsym->attr.allocatable); ! tmp = gfc_trans_assignment (e, fsym->value); gfc_add_expr_to_block (&se->pre, tmp); } --- 2031,2037 ---- && fsym->value) { gcc_assert (!fsym->attr.allocatable); ! tmp = gfc_trans_assignment (e, fsym->value, false); gfc_add_expr_to_block (&se->pre, tmp); } *************** gfc_trans_arrayfunc_assign (gfc_expr * e *** 3363,3369 **** setting up the scalarizer. */ tree ! gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) { gfc_se lse; gfc_se rse; --- 3363,3369 ---- setting up the scalarizer. */ tree ! gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) { gfc_se lse; gfc_se rse; *************** gfc_trans_assignment (gfc_expr * expr1, *** 3466,3472 **** else gfc_conv_expr (&lse, expr1); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp, expr2->expr_type == EXPR_VARIABLE); gfc_add_expr_to_block (&body, tmp); --- 3466,3473 ---- else gfc_conv_expr (&lse, expr1); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, ! l_is_temp || init_flag, expr2->expr_type == EXPR_VARIABLE); gfc_add_expr_to_block (&body, tmp); *************** gfc_trans_assignment (gfc_expr * expr1, *** 3500,3506 **** gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false); gfc_add_expr_to_block (&body, tmp); } --- 3501,3508 ---- gcc_assert (lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, ! false, false); gfc_add_expr_to_block (&body, tmp); } *************** gfc_trans_assignment (gfc_expr * expr1, *** 3518,3524 **** } tree gfc_trans_assign (gfc_code * code) { ! return gfc_trans_assignment (code->expr, code->expr2); } --- 3520,3532 ---- } tree + gfc_trans_init_assign (gfc_code * code) + { + return gfc_trans_assignment (code->expr, code->expr2, true); + } + + tree gfc_trans_assign (gfc_code * code) { ! return gfc_trans_assignment (code->expr, code->expr2, false); } Index: gcc/fortran/dump-parse-tree.c =================================================================== *** gcc/fortran/dump-parse-tree.c (révision 117821) --- gcc/fortran/dump-parse-tree.c (copie de travail) *************** gfc_show_code_node (int level, gfc_code *** 1021,1026 **** --- 1021,1027 ---- gfc_status ("ENTRY %s", c->ext.entry->sym->name); break; + case EXEC_INIT_ASSIGN: case EXEC_ASSIGN: gfc_status ("ASSIGN "); gfc_show_expr (c->expr); Index: gcc/fortran/trans-openmp.c =================================================================== *** gcc/fortran/trans-openmp.c (révision 117821) --- gcc/fortran/trans-openmp.c (copie de travail) *************** gfc_trans_omp_array_reduction (tree c, g *** 424,430 **** /* Create the init statement list. */ pushlevel (0); ! stmt = gfc_trans_assignment (e1, e2); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else --- 424,430 ---- /* Create the init statement list. */ pushlevel (0); ! stmt = gfc_trans_assignment (e1, e2, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else *************** gfc_trans_omp_array_reduction (tree c, g *** 433,439 **** /* Create the merge statement list. */ pushlevel (0); ! stmt = gfc_trans_assignment (e3, e4); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else --- 433,439 ---- /* Create the merge statement list. */ pushlevel (0); ! stmt = gfc_trans_assignment (e3, e4, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else Index: gcc/fortran/gfortran.h =================================================================== *** gcc/fortran/gfortran.h (révision 117821) --- gcc/fortran/gfortran.h (copie de travail) *************** typedef enum *** 1507,1513 **** { EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_GOTO, EXEC_CALL, EXEC_ASSIGN_CALL, EXEC_RETURN, EXEC_ENTRY, ! EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_ALLOCATE, EXEC_DEALLOCATE, --- 1507,1513 ---- { EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_GOTO, EXEC_CALL, EXEC_ASSIGN_CALL, EXEC_RETURN, EXEC_ENTRY, ! EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN, EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_ALLOCATE, EXEC_DEALLOCATE, Index: gcc/fortran/trans-stmt.c =================================================================== *** gcc/fortran/trans-stmt.c (révision 117821) --- gcc/fortran/trans-stmt.c (copie de travail) *************** gfc_trans_forall_1 (gfc_code * code, for *** 2638,2644 **** else { /* Use the normal assignment copying routines. */ ! assign = gfc_trans_assignment (c->expr, c->expr2); /* Generate body and loops. */ tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); --- 2638,2644 ---- else { /* Use the normal assignment copying routines. */ ! assign = gfc_trans_assignment (c->expr, c->expr2, false); /* Generate body and loops. */ tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); Index: gcc/fortran/trans-stmt.h =================================================================== *** gcc/fortran/trans-stmt.h (révision 117821) --- gcc/fortran/trans-stmt.h (copie de travail) *************** tree gfc_trans_code (gfc_code *); *** 28,33 **** --- 28,34 ---- /* trans-expr.c */ tree gfc_trans_assign (gfc_code *); tree gfc_trans_pointer_assign (gfc_code *); + tree gfc_trans_init_assign (gfc_code *); /* trans-stmt.c */ tree gfc_trans_cycle (gfc_code *); Index: gcc/fortran/trans.c =================================================================== *** gcc/fortran/trans.c (révision 117821) --- gcc/fortran/trans.c (copie de travail) *************** gfc_trans_code (gfc_code * code) *** 477,482 **** --- 477,486 ---- res = gfc_trans_pointer_assign (code); break; + case EXEC_INIT_ASSIGN: + res = gfc_trans_init_assign (code); + break; + case EXEC_CONTINUE: res = NULL_TREE; break; Index: gcc/fortran/trans.h =================================================================== *** gcc/fortran/trans.h (révision 117821) --- gcc/fortran/trans.h (copie de travail) *************** bool get_array_ctor_strlen (gfc_construc *** 426,432 **** void gfc_trans_runtime_check (tree, const char *, stmtblock_t *, locus *); /* Generate code for an assignment, includes scalarization. */ ! tree gfc_trans_assignment (gfc_expr *, gfc_expr *); /* Generate code for a pointer assignment. */ tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *); --- 426,432 ---- void gfc_trans_runtime_check (tree, const char *, stmtblock_t *, locus *); /* Generate code for an assignment, includes scalarization. */ ! tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool); /* Generate code for a pointer assignment. */ tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *); Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (révision 117821) --- gcc/fortran/resolve.c (copie de travail) *************** resolve_allocate_expr (gfc_expr * e, gfc *** 3556,3562 **** { init_st = gfc_get_code (); init_st->loc = code->loc; ! init_st->op = EXEC_ASSIGN; init_st->expr = expr_to_initialize (e); init_st->expr2 = init_e; init_st->next = code->next; --- 3556,3562 ---- { init_st = gfc_get_code (); init_st->loc = code->loc; ! init_st->op = EXEC_INIT_ASSIGN; init_st->expr = expr_to_initialize (e); init_st->expr2 = init_e; init_st->next = code->next; *************** resolve_code (gfc_code * code, gfc_names *** 4907,4912 **** --- 4907,4915 ---- "INTEGER return specifier", &code->expr->where); break; + case EXEC_INIT_ASSIGN: + break; + case EXEC_ASSIGN: if (t == FAILURE) break; *************** is_non_constant_shape_array (gfc_symbol *** 5222,5227 **** --- 5225,5299 ---- return not_constant; } + + /* Assign the default initializer to a derived type variable or result. */ + + static void + apply_default_init (gfc_symbol *sym) + { + gfc_expr *lval; + gfc_expr *init = NULL; + gfc_code *init_st; + gfc_namespace *ns = sym->ns; + + if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function) + return; + + if (sym->ts.type == BT_DERIVED && sym->ts.derived) + init = gfc_default_initializer (&sym->ts); + + if (init == NULL) + return; + + /* Search for the function namespace if this is a contained + function without an explicit result. */ + if (sym->attr.function && sym == sym->result + && sym->name != sym->ns->proc_name->name) + { + ns = ns->contained; + for (;ns; ns = ns->sibling) + if (strcmp (ns->proc_name->name, sym->name) == 0) + break; + } + + if (ns == NULL) + { + gfc_free_expr (init); + return; + } + + /* Build an l-value expression for the result. */ + lval = gfc_get_expr (); + lval->expr_type = EXPR_VARIABLE; + lval->where = sym->declared_at; + lval->ts = sym->ts; + lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); + + /* It will always be a full array. */ + lval->rank = sym->as ? sym->as->rank : 0; + if (lval->rank) + { + lval->ref = gfc_get_ref (); + lval->ref->type = REF_ARRAY; + lval->ref->u.ar.type = AR_FULL; + lval->ref->u.ar.dimen = lval->rank; + lval->ref->u.ar.where = sym->declared_at; + lval->ref->u.ar.as = sym->as; + } + + /* Add the code at scope entry. */ + init_st = gfc_get_code (); + init_st->next = ns->code; + ns->code = init_st; + + /* Assign the default initializer to the l-value. */ + init_st->loc = sym->declared_at; + init_st->op = EXEC_INIT_ASSIGN; + init_st->expr = lval; + init_st->expr2 = init; + } + + /* Resolution of common features of flavors variable and procedure. */ static try *************** resolve_symbol (gfc_symbol * sym) *** 5960,5965 **** --- 6032,6053 ---- && (sym->ns->proc_name == NULL || sym->ns->proc_name->attr.flavor != FL_MODULE))) gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + + /* If we have come this far we can apply default-initializers, as + described in 14.7.5, to those variables that have not already + been assigned one. */ + if (sym->ts.type == BT_DERIVED && sym->ns == gfc_current_ns && !sym->value + && !sym->attr.allocatable && !sym->attr.alloc_comp) + { + symbol_attribute *a = &sym->attr; + + if ((!a->save && !a->dummy && !a->pointer + && !a->in_common && !a->use_assoc + && !(a->function && sym != sym->result)) + || + (a->dummy && a->intent == INTENT_OUT)) + apply_default_init (sym); + } } Index: gcc/fortran/st.c =================================================================== *** gcc/fortran/st.c (révision 117821) --- gcc/fortran/st.c (copie de travail) *************** gfc_free_statement (gfc_code * p) *** 93,98 **** --- 93,99 ---- { case EXEC_NOP: case EXEC_ASSIGN: + case EXEC_INIT_ASSIGN: case EXEC_GOTO: case EXEC_CYCLE: case EXEC_RETURN: Index: gcc/testsuite/gfortran.dg/automatic_default_init_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/automatic_default_init_1.f90 (révision 0) --- gcc/testsuite/gfortran.dg/automatic_default_init_1.f90 (révision 0) *************** *** 0 **** --- 1,21 ---- + ! { dg-do run } + ! { dg-options "-O" } + ! Test the fix for PR29394 in which automatic arrays did not + ! get default initialization. + ! Contributed by Francois-Xavier Coudert + ! + MODULE M1 + TYPE T1 + INTEGER :: I=7 + END TYPE T1 + CONTAINS + SUBROUTINE S1(I) + INTEGER, INTENT(IN) :: I + TYPE(T1) :: D(1:I) + IF (any (D(:)%I.NE.7)) CALL ABORT() + END SUBROUTINE S1 + END MODULE M1 + USE M1 + CALL S1(2) + END + ! { dg-final { cleanup-modules "m1" } } Index: gcc/testsuite/gfortran.dg/result_default_init_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/result_default_init_1.f90 (révision 0) --- gcc/testsuite/gfortran.dg/result_default_init_1.f90 (révision 0) *************** *** 0 **** --- 1,26 ---- + ! { dg-do run } + ! { dg-options "-O" } + ! Test the fix for PR29216 in which function results did not + ! get default initialization. + ! Contributed by Stephan Kramer + ! + type A + integer, pointer:: p => null () + integer:: i=3 + end type A + type(A):: x,y + if (associated(x%p) .or. x%i /= 3) call abort () + x=f() + if (associated(x%p) .or. x%i /= 3) call abort () + x=g() + if (associated(x%p) .or. x%i /= 3) call abort () + contains + function f() result (fr) + type(A):: fr + if (associated(fr%p) .or. fr%i /= 3) call abort () + end function f + function g() + type(A):: g + if (associated(g%p) .or. g%i /= 3) call abort () + end function g + end Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 (révision 117821) --- gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 (copie de travail) *************** contains *** 139,143 **** end subroutine check_alloc2 end program alloc ! ! { dg-final { scan-tree-dump-times "deallocate" 38 "original" } } ! { dg-final { cleanup-tree-dump "original" } } --- 139,143 ---- end subroutine check_alloc2 end program alloc ! ! { dg-final { scan-tree-dump-times "deallocate" 33 "original" } } ! { dg-final { cleanup-tree-dump "original" } }