diff options
Diffstat (limited to 'gcc/fortran/trans-decl.c')
| -rw-r--r-- | gcc/fortran/trans-decl.c | 71 |
1 files changed, 52 insertions, 19 deletions
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index ee38efbe27c..200c3f5654c 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1187,22 +1187,23 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Create variables to hold the non-constant bits of array info. */ gfc_build_qualified_array (decl, sym); - /* Remember this variable for allocation/cleanup. */ - gfc_defer_symbol_init (sym); - if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer) GFC_DECL_PACKED_ARRAY (decl) = 1; } - if (sym->ts.type == BT_DERIVED && sym->ts.u.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) + /* Remember this variable for allocation/cleanup. */ + if (sym->attr.dimension || sym->attr.allocatable + || (sym->ts.type == BT_CLASS && + (sym->ts.u.derived->components->attr.dimension + || sym->ts.u.derived->components->attr.allocatable)) + || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp) + /* This applies a derived type default initializer. */ + || (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); @@ -3054,7 +3055,8 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body) Allocation and initialization of array variables. Allocation of character string variables. Initialization and possibly repacking of dummy arrays. - Initialization of ASSIGN statement auxiliary variable. */ + Initialization of ASSIGN statement auxiliary variable. + Automatic deallocation. */ tree gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) @@ -3182,6 +3184,33 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) } else if (sym_has_alloc_comp) fnbody = gfc_trans_deferred_array (sym, fnbody); + else if (sym->attr.allocatable + || (sym->ts.type == BT_CLASS + && sym->ts.u.derived->components->attr.allocatable)) + { + /* Automatic deallocatation of allocatable scalars. */ + tree tmp; + gfc_expr *e; + gfc_se se; + stmtblock_t block; + + e = gfc_lval_expr_from_sym (sym); + if (sym->ts.type == BT_CLASS) + gfc_add_component_ref (e, "$data"); + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, e); + gfc_free_expr (e); + + gfc_start_block (&block); + gfc_add_expr_to_block (&block, fnbody); + + /* Note: Nullifying is not needed. */ + tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true, NULL); + gfc_add_expr_to_block (&block, tmp); + fnbody = gfc_finish_block (&block); + } else if (sym->ts.type == BT_CHARACTER) { gfc_get_backend_locus (&loc); @@ -3747,8 +3776,12 @@ generate_local_decl (gfc_symbol * sym) else if (warn_unused_variable && sym->attr.dummy && sym->attr.intent == INTENT_OUT) - gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set", - sym->name, &sym->declared_at); + { + if (!(sym->ts.type == BT_DERIVED + && sym->ts.u.derived->components->initializer)) + gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) " + "but was not set", sym->name, &sym->declared_at); + } /* Specific warning for unused dummy arguments. */ else if (warn_unused_variable && sym->attr.dummy) gfc_warning ("Unused dummy argument '%s' at %L", sym->name, @@ -4363,10 +4396,10 @@ gfc_generate_function_code (gfc_namespace * ns) /* Reset recursion-check variable. */ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive) - { - gfc_add_modify (&block, recurcheckvar, boolean_false_node); - recurcheckvar = NULL; - } + { + gfc_add_modify (&block, recurcheckvar, boolean_false_node); + recurcheckvar = NULL; + } if (result == NULL_TREE) { |