+2006-06-07 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/23091
+ * resolve.c (resolve_fl_variable): Error if an automatic
+ object has the SAVE attribute.
+
+ PR fortran/24168
+ * expr.c (simplify_intrinsic_op): Transfer the rank and
+ the locus to the simplified expression.
+
+ PR fortran/25090
+ PR fortran/25058
+ * gfortran.h : Add int entry_id to gfc_symbol.
+ * resolve.c : Add static variables current_entry_id and
+ specification_expr.
+ (resolve_variable): During code resolution, check if a
+ reference to a dummy variable in an executable expression
+ is preceded by its appearance as a parameter in an entry.
+ Likewise check its specification expressions.
+ (resolve_code): Update current_entry_id on EXEC_ENTRY.
+ (resolve_charlen, resolve_fl_variable): Set and reset
+ specifiaction_expr.
+ (is_non_constant_shape_array): Do not return on detection
+ of a variable but continue to resolve all the expressions.
+ (resolve_codes): set current_entry_id to an out of range
+ value.
+
2006-06-06 Mike Stump <mrs@apple.com>
* Make-lang.in: Rename to htmldir to build_htmldir to avoid
resets the flag each time that it is read. */
static int formal_arg_flag = 0;
+/* True if we are resolving a specification expression. */
+static int specification_expr = 0;
+
+/* The id of the last entry seen. */
+static int current_entry_id;
+
int
gfc_is_formal_arg (void)
{
resolve_variable (gfc_expr * e)
{
gfc_symbol *sym;
+ try t;
+
+ t = SUCCESS;
if (e->ref && resolve_ref (e) == FAILURE)
return FAILURE;
if (check_assumed_size_reference (sym, e))
return FAILURE;
- return SUCCESS;
+ /* Deal with forward references to entries during resolve_code, to
+ satisfy, at least partially, 12.5.2.5. */
+ if (gfc_current_ns->entries
+ && current_entry_id == sym->entry_id
+ && cs_base
+ && cs_base->current
+ && cs_base->current->op != EXEC_ENTRY)
+ {
+ gfc_entry_list *entry;
+ gfc_formal_arglist *formal;
+ int n;
+ bool seen;
+
+ /* If the symbol is a dummy... */
+ if (sym->attr.dummy)
+ {
+ entry = gfc_current_ns->entries;
+ seen = false;
+
+ /* ...test if the symbol is a parameter of previous entries. */
+ for (; entry && entry->id <= current_entry_id; entry = entry->next)
+ for (formal = entry->sym->formal; formal; formal = formal->next)
+ {
+ if (formal->sym && sym->name == formal->sym->name)
+ seen = true;
+ }
+
+ /* If it has not been seen as a dummy, this is an error. */
+ if (!seen)
+ {
+ if (specification_expr)
+ gfc_error ("Variable '%s',used in a specification expression, "
+ "is referenced at %L before the ENTRY statement "
+ "in which it is a parameter",
+ sym->name, &cs_base->current->loc);
+ else
+ gfc_error ("Variable '%s' is used at %L before the ENTRY "
+ "statement in which it is a parameter",
+ sym->name, &cs_base->current->loc);
+ t = FAILURE;
+ }
+ }
+
+ /* Now do the same check on the specification expressions. */
+ specification_expr = 1;
+ if (sym->ts.type == BT_CHARACTER
+ && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
+ t = FAILURE;
+
+ if (sym->as)
+ for (n = 0; n < sym->as->rank; n++)
+ {
+ specification_expr = 1;
+ if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
+ t = FAILURE;
+ specification_expr = 1;
+ if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
+ t = FAILURE;
+ }
+ specification_expr = 0;
+
+ if (t == SUCCESS)
+ /* Update the symbol's entry level. */
+ sym->entry_id = current_entry_id + 1;
+ }
+
+ return t;
}
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
+ break;
+
case EXEC_ENTRY:
+ /* Keep track of which entry we are up to. */
+ current_entry_id = code->ext.entry->id;
break;
case EXEC_WHERE:
static try
resolve_index_expr (gfc_expr * e)
{
-
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
cl->resolved = 1;
+ specification_expr = 1;
+
if (resolve_index_expr (cl->length) == FAILURE)
- return FAILURE;
+ {
+ specification_expr = 0;
+ return FAILURE;
+ }
return SUCCESS;
}
{
gfc_expr *e;
int i;
+ bool not_constant;
+ not_constant = false;
if (sym->as != NULL)
{
/* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
e = sym->as->lower[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
- return true;
+ not_constant = true;
e = sym->as->upper[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
- return true;
+ not_constant = true;
}
}
- return false;
+ return not_constant;
}
/* Resolution of common features of flavors variable and procedure. */
int i;
gfc_expr *e;
gfc_expr *constructor_expr;
+ const char * auto_save_msg;
+
+ auto_save_msg = "automatic object '%s' at %L cannot have the "
+ "SAVE attribute";
if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
- /* The shape of a main program or module array needs to be constant. */
- if (sym->ns->proc_name
- && (sym->ns->proc_name->attr.flavor == FL_MODULE
- || sym->ns->proc_name->attr.is_main_program)
- && !sym->attr.use_assoc
+ /* Set this flag to check that variables are parameters of all entries.
+ This check is effected by the call to gfc_resolve_expr through
+ is_non_constant_shape_array. */
+ specification_expr = 1;
+
+ if (!sym->attr.use_assoc
&& !sym->attr.allocatable
&& !sym->attr.pointer
&& is_non_constant_shape_array (sym))
{
- gfc_error ("The module or main program array '%s' at %L must "
- "have constant shape", sym->name, &sym->declared_at);
- return FAILURE;
+ /* The shape of a main program or module array needs to be constant. */
+ if (sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program))
+ {
+ gfc_error ("The module or main program array '%s' at %L must "
+ "have constant shape", sym->name, &sym->declared_at);
+ specification_expr = 0;
+ return FAILURE;
+ }
}
if (sym->ts.type == BT_CHARACTER)
return FAILURE;
}
+ if (e && sym->attr.save && !gfc_is_constant_expr (e))
+ {
+ gfc_error (auto_save_msg, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
if (!gfc_is_constant_expr (e)
&& !(e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.flavor == FL_PARAMETER)
break;
}
}
+
+ /* Also, they must not have the SAVE attribute. */
+ if (flag && sym->attr.save)
+ {
+ gfc_error (auto_save_msg, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
}
/* Reject illegal initializers. */
gfc_current_ns = ns;
cs_base = NULL;
+ /* Set to an out of range value. */
+ current_entry_id = -1;
resolve_code (ns->code, ns);
}
projects / platform / upstream / gcc.git / commitdiff