aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8/gcc/fortran/resolve.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8/gcc/fortran/resolve.c')
-rw-r--r--gcc-4.8/gcc/fortran/resolve.c90
1 files changed, 63 insertions, 27 deletions
diff --git a/gcc-4.8/gcc/fortran/resolve.c b/gcc-4.8/gcc/fortran/resolve.c
index 486a22c2d..755ea90bd 100644
--- a/gcc-4.8/gcc/fortran/resolve.c
+++ b/gcc-4.8/gcc/fortran/resolve.c
@@ -1,5 +1,5 @@
/* Perform type resolution on the various structures.
- Copyright (C) 2001-2013 Free Software Foundation, Inc.
+ Copyright (C) 2001-2014 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
@@ -1259,9 +1259,10 @@ resolve_structure_cons (gfc_expr *expr, int init)
}
/* F2003, C1272 (3). */
- if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
+ bool impure = cons->expr->expr_type == EXPR_VARIABLE
&& (gfc_impure_variable (cons->expr->symtree->n.sym)
- || gfc_is_coindexed (cons->expr)))
+ || gfc_is_coindexed (cons->expr));
+ if (impure && gfc_pure (NULL))
{
t = FAILURE;
gfc_error ("Invalid expression in the structure constructor for "
@@ -1269,12 +1270,8 @@ resolve_structure_cons (gfc_expr *expr, int init)
comp->name, &cons->expr->where);
}
- if (gfc_implicit_pure (NULL)
- && cons->expr->expr_type == EXPR_VARIABLE
- && (gfc_impure_variable (cons->expr->symtree->n.sym)
- || gfc_is_coindexed (cons->expr)))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
+ if (impure)
+ gfc_unset_implicit_pure (NULL);
}
return t;
@@ -3295,8 +3292,7 @@ resolve_function (gfc_expr *expr)
t = FAILURE;
}
- if (gfc_implicit_pure (NULL))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ gfc_unset_implicit_pure (NULL);
}
/* Functions without the RECURSIVE attribution are not allowed to
@@ -3361,8 +3357,7 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym)
gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
&c->loc);
- if (gfc_implicit_pure (NULL))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ gfc_unset_implicit_pure (NULL);
}
@@ -8705,10 +8700,11 @@ resolve_transfer (gfc_code *code)
&& exp->value.op.op == INTRINSIC_PARENTHESES)
exp = exp->value.op.op1;
- if (exp && exp->expr_type == EXPR_NULL && exp->ts.type == BT_UNKNOWN)
+ if (exp && exp->expr_type == EXPR_NULL
+ && code->ext.dt)
{
- gfc_error ("NULL intrinsic at %L in data transfer statement requires "
- "MOLD=", &exp->where);
+ gfc_error ("Invalid context for NULL () intrinsic at %L",
+ &exp->where);
return;
}
@@ -9612,7 +9608,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
if (lhs->expr_type == EXPR_VARIABLE
&& lhs->symtree->n.sym != gfc_current_ns->proc_name
&& lhs->symtree->n.sym->ns != gfc_current_ns)
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ gfc_unset_implicit_pure (NULL);
if (lhs->ts.type == BT_DERIVED
&& lhs->expr_type == EXPR_VARIABLE
@@ -9620,11 +9616,11 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
&& rhs->expr_type == EXPR_VARIABLE
&& (gfc_impure_variable (rhs->symtree->n.sym)
|| gfc_is_coindexed (rhs)))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ gfc_unset_implicit_pure (NULL);
/* Fortran 2008, C1283. */
if (gfc_is_coindexed (lhs))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ gfc_unset_implicit_pure (NULL);
}
/* F03:7.4.1.2. */
@@ -11057,7 +11053,7 @@ build_default_init_expr (gfc_symbol *sym)
init_expr = NULL;
}
if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
- && sym->ts.u.cl->length)
+ && sym->ts.u.cl->length && gfc_option.flag_max_stack_var_size != 0)
{
gfc_actual_arglist *arg;
init_expr = gfc_get_expr ();
@@ -11877,6 +11873,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
{
gfc_symbol *sym1, *sym2;
const char *pass1, *pass2;
+ gfc_formal_arglist *dummy_args;
gcc_assert (t1->specific && t2->specific);
gcc_assert (!t1->specific->is_generic);
@@ -11899,19 +11896,33 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
return FAILURE;
}
- /* Compare the interfaces. */
+ /* Determine PASS arguments. */
if (t1->specific->nopass)
pass1 = NULL;
else if (t1->specific->pass_arg)
pass1 = t1->specific->pass_arg;
else
- pass1 = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym)->sym->name;
+ {
+ dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
+ if (dummy_args)
+ pass1 = dummy_args->sym->name;
+ else
+ pass1 = NULL;
+ }
if (t2->specific->nopass)
pass2 = NULL;
else if (t2->specific->pass_arg)
pass2 = t2->specific->pass_arg;
else
- pass2 = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym)->sym->name;
+ {
+ dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
+ if (dummy_args)
+ pass2 = dummy_args->sym->name;
+ else
+ pass2 = NULL;
+ }
+
+ /* Compare the interfaces. */
if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
NULL, 0, pass1, pass2))
{
@@ -12425,9 +12436,6 @@ resolve_typebound_procedures (gfc_symbol* derived)
resolve_bindings_derived = derived;
resolve_bindings_result = SUCCESS;
- /* Make sure the vtab has been generated. */
- gfc_find_derived_vtab (derived);
-
if (derived->f2k_derived->tb_sym_root)
gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
&resolve_typebound_procedure);
@@ -13256,7 +13264,8 @@ resolve_symbol (gfc_symbol *sym)
if (sym->attr.flavor == FL_UNKNOWN
|| (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
&& !sym->attr.generic && !sym->attr.external
- && sym->attr.if_source == IFSRC_UNKNOWN))
+ && sym->attr.if_source == IFSRC_UNKNOWN
+ && sym->ts.type == BT_UNKNOWN))
{
/* If we find that a flavorless symbol is an interface in one of the
@@ -14376,6 +14385,33 @@ gfc_implicit_pure (gfc_symbol *sym)
}
+void
+gfc_unset_implicit_pure (gfc_symbol *sym)
+{
+ gfc_namespace *ns;
+
+ if (sym == NULL)
+ {
+ /* Check if the current procedure is implicit_pure. Walk up
+ the procedure list until we find a procedure. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ {
+ sym = ns->proc_name;
+ if (sym == NULL)
+ return;
+
+ if (sym->attr.flavor == FL_PROCEDURE)
+ break;
+ }
+ }
+
+ if (sym->attr.flavor == FL_PROCEDURE)
+ sym->attr.implicit_pure = 0;
+ else
+ sym->attr.pure = 0;
+}
+
+
/* Test whether the current procedure is elemental or not. */
int
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-04 08:36:37 +0000