From b9cd8c56e3d647692ed17c6d3ad6a49c47592d50 Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 19 Oct 2006 04:51:14 +0000 Subject: 2006-10-19 Paul Thomas PR fortran/29216 PR fortran/29314 * gfortran.h : Add EXEC_INIT_ASSIGN. * dump-parse-tree.c (gfc_show_code_node): The same. * trans-openmp.c (gfc_trans_omp_array_reduction): Set new argument for gfc_trans_assignment to false. * trans-stmt.c (gfc_trans_forall_1): The same. * trans-expr.c (gfc_conv_function_call, gfc_trans_assign, gfc_trans_arrayfunc_assign, gfc_trans_assignment): The same. In the latter function, use the new flag to stop the checking of the lhs for deallocation. (gfc_trans_init_assign): New function. * trans-stmt.h : Add prototype for gfc_trans_init_assign. * trans.c (gfc_trans_code): Implement EXEC_INIT_ASSIGN. * trans.h : Add new boolean argument to the prototype of gfc_trans_assignment. * resolve.c (resolve_allocate_exp): Replace EXEC_ASSIGN by EXEC_INIT_ASSIGN. (resolve_code): EXEC_INIT_ASSIGN does not need resolution. (apply_default_init): New function. (resolve_symbol): Call it for derived types that become defined but which do not already have an initialization expression.. * st.c (gfc_free_statement): Include EXEC_INIT_ASSIGN. 2006-10-19 Paul Thomas PR fortran/29216 * gfortran.dg/result_default_init_1.f90: New test. PR fortran/29314 * gfortran.dg/automatic_default_init_1.f90: New test. * gfortran.dg/alloc_comp_basics_1.f90: Reduce deallocate count from 38 to 33. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@117879 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/resolve.c | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 89 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2639cabae36..d3722e61f75 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3556,7 +3556,7 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code) { init_st = gfc_get_code (); init_st->loc = code->loc; - init_st->op = EXEC_ASSIGN; + init_st->op = EXEC_INIT_ASSIGN; init_st->expr = expr_to_initialize (e); init_st->expr2 = init_e; init_st->next = code->next; @@ -4907,6 +4907,9 @@ resolve_code (gfc_code * code, gfc_namespace * ns) "INTEGER return specifier", &code->expr->where); break; + case EXEC_INIT_ASSIGN: + break; + case EXEC_ASSIGN: if (t == FAILURE) break; @@ -5222,6 +5225,75 @@ is_non_constant_shape_array (gfc_symbol *sym) 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 @@ -5960,6 +6032,22 @@ resolve_symbol (gfc_symbol * sym) && (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); + } } -- cgit v1.2.3