diff options
Diffstat (limited to 'gcc/fortran/resolve.c')
| -rw-r--r-- | gcc/fortran/resolve.c | 90 |
1 files changed, 89 insertions, 1 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2639cab..d3722e6 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); + } } |