diff options
Diffstat (limited to 'gcc-4.6/gcc/fortran/expr.c')
| -rw-r--r-- | gcc-4.6/gcc/fortran/expr.c | 80 |
1 files changed, 59 insertions, 21 deletions
diff --git a/gcc-4.6/gcc/fortran/expr.c b/gcc-4.6/gcc/fortran/expr.c index d9fb465..d5784c5 100644 --- a/gcc-4.6/gcc/fortran/expr.c +++ b/gcc-4.6/gcc/fortran/expr.c @@ -396,6 +396,28 @@ gfc_copy_expr (gfc_expr *p) } +void +gfc_clear_shape (mpz_t *shape, int rank) +{ + int i; + + for (i = 0; i < rank; i++) + mpz_clear (shape[i]); +} + + +void +gfc_free_shape (mpz_t **shape, int rank) +{ + if (*shape == NULL) + return; + + gfc_clear_shape (*shape, rank); + gfc_free (*shape); + *shape = NULL; +} + + /* Workhorse function for gfc_free_expr() that frees everything beneath an expression node, but not the node itself. This is useful when we want to simplify a node and replace it with @@ -404,8 +426,6 @@ gfc_copy_expr (gfc_expr *p) static void free_expr0 (gfc_expr *e) { - int n; - switch (e->expr_type) { case EXPR_CONSTANT: @@ -474,13 +494,7 @@ free_expr0 (gfc_expr *e) } /* Free a shape array. */ - if (e->shape != NULL) - { - for (n = 0; n < e->rank; n++) - mpz_clear (e->shape[n]); - - gfc_free (e->shape); - } + gfc_free_shape (&e->shape, e->rank); gfc_free_ref_list (e->ref); @@ -1840,6 +1854,9 @@ gfc_simplify_expr (gfc_expr *p, int type) if (p->ref && p->ref->u.ss.end) gfc_extract_int (p->ref->u.ss.end, &end); + if (end < 0) + end = 0; + s = gfc_get_wide_string (end - start + 2); memcpy (s, p->value.character.string + start, (end - start) * sizeof (gfc_char_t)); @@ -2467,6 +2484,9 @@ check_init_expr (gfc_expr *e) m = MATCH_ERROR; } + if (m == MATCH_ERROR) + return FAILURE; + /* Try to scalarize an elemental intrinsic function that has an array argument. */ isym = gfc_find_function (e->symtree->n.sym->name); @@ -3659,6 +3679,8 @@ gfc_has_default_initializer (gfc_symbol *der) if (!c->attr.pointer && gfc_has_default_initializer (c->ts.u.derived)) return true; + if (c->attr.pointer && c->initializer) + return true; } else { @@ -3669,6 +3691,7 @@ gfc_has_default_initializer (gfc_symbol *der) return false; } + /* Get an expression for a default initializer. */ gfc_expr * @@ -4059,8 +4082,9 @@ gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) return error_found ? FAILURE : SUCCESS; } -/* Walk an expression tree and replace all symbols with a corresponding symbol - in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE + +/* Walk an expression tree and replace all dummy symbols by the corresponding + symbol in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE statements. The boolean return value is required by gfc_traverse_expr. */ static bool @@ -4069,14 +4093,12 @@ replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED) if ((expr->expr_type == EXPR_VARIABLE || (expr->expr_type == EXPR_FUNCTION && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where))) - && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns) + && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns + && expr->symtree->n.sym->attr.dummy) { - gfc_symtree *stree; - gfc_namespace *ns = sym->formal_ns; - /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find - the symtree rather than create a new one (and probably fail later). */ - stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root, - expr->symtree->n.sym->name); + gfc_symtree *root = sym->formal_ns ? sym->formal_ns->sym_root + : gfc_current_ns->sym_root; + gfc_symtree *stree = gfc_find_symtree (root, expr->symtree->n.sym->name); gcc_assert (stree); stree->n.sym->attr = expr->symtree->n.sym->attr; expr->symtree = stree; @@ -4090,6 +4112,7 @@ gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest) gfc_traverse_expr (expr, dest, &replace_symbol, 0); } + /* The following is analogous to 'replace_symbol', and needed for copying interfaces for procedure pointer components. The argument 'sym' must formally be a gfc_symbol, so that the function can be passed to gfc_traverse_expr. @@ -4458,7 +4481,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context) sym->name, context, &e->where); return FAILURE; } - if (!pointer && !is_pointer) + if (!pointer && !is_pointer && !sym->attr.pointer) { if (context) gfc_error ("Dummy argument '%s' with INTENT(IN) in variable" @@ -4500,9 +4523,24 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context) return FAILURE; } - if (!pointer && gfc_implicit_pure (NULL) && gfc_impure_variable (sym)) - gfc_current_ns->proc_name->attr.implicit_pure = 0; + if (!pointer && context && gfc_implicit_pure (NULL) + && gfc_impure_variable (sym)) + { + gfc_namespace *ns; + gfc_symbol *sym; + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + sym = ns->proc_name; + if (sym == NULL) + break; + if (sym->attr.flavor == FL_PROCEDURE) + { + sym->attr.implicit_pure = 0; + break; + } + } + } /* Check variable definition context for associate-names. */ if (!pointer && sym->assoc) { |