/* Make sure an expression is a variable. */
static gfc_try
-variable_check (gfc_expr *e, int n)
+variable_check (gfc_expr *e, int n, bool allow_proc)
{
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.intent == INTENT_IN
return FAILURE;
}
- if ((e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
- || (e->expr_type == EXPR_FUNCTION
- && e->symtree->n.sym->result == e->symtree->n.sym))
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.flavor != FL_PARAMETER
+ && (allow_proc
+ || !e->symtree->n.sym->attr.function
+ || (e->symtree->n.sym == e->symtree->n.sym->result
+ && (e->symtree->n.sym == gfc_current_ns->proc_name
+ || (gfc_current_ns->parent
+ && e->symtree->n.sym
+ == gfc_current_ns->parent->proc_name)))))
return SUCCESS;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
gfc_try
gfc_check_allocated (gfc_expr *array)
{
- if (variable_check (array, 0) == FAILURE)
+ if (variable_check (array, 0, false) == FAILURE)
return FAILURE;
if (allocatable_check (array, 0) == FAILURE)
return FAILURE;
gfc_try
gfc_check_loc (gfc_expr *expr)
{
- return variable_check (expr, 0);
+ return variable_check (expr, 0, true);
}
gfc_try
gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
{
- if (variable_check (from, 0) == FAILURE)
+ if (variable_check (from, 0, false) == FAILURE)
return FAILURE;
if (allocatable_check (from, 0) == FAILURE)
return FAILURE;
- if (variable_check (to, 1) == FAILURE)
+ if (variable_check (to, 1, false) == FAILURE)
return FAILURE;
if (allocatable_check (to, 1) == FAILURE)
return FAILURE;
if (mold == NULL)
return SUCCESS;
- if (variable_check (mold, 0) == FAILURE)
+ if (variable_check (mold, 0, true) == FAILURE)
return FAILURE;
attr = gfc_variable_attr (mold, NULL);
{
gfc_symbol *sym;
- if (variable_check (a, 0) == FAILURE)
+ if (variable_check (a, 0, true) == FAILURE)
return FAILURE;
sym = a->symtree->n.sym;
if (type_check (time, 0, BT_REAL) == FAILURE)
return FAILURE;
- if (variable_check (time, 0) == FAILURE)
+ if (variable_check (time, 0, false) == FAILURE)
return FAILURE;
return SUCCESS;
return FAILURE;
if (scalar_check (date, 0) == FAILURE)
return FAILURE;
- if (variable_check (date, 0) == FAILURE)
+ if (variable_check (date, 0, false) == FAILURE)
return FAILURE;
}
return FAILURE;
if (scalar_check (time, 1) == FAILURE)
return FAILURE;
- if (variable_check (time, 1) == FAILURE)
+ if (variable_check (time, 1, false) == FAILURE)
return FAILURE;
}
return FAILURE;
if (scalar_check (zone, 2) == FAILURE)
return FAILURE;
- if (variable_check (zone, 2) == FAILURE)
+ if (variable_check (zone, 2, false) == FAILURE)
return FAILURE;
}
return FAILURE;
if (rank_check (values, 3, 1) == FAILURE)
return FAILURE;
- if (variable_check (values, 3) == FAILURE)
+ if (variable_check (values, 3, false) == FAILURE)
return FAILURE;
}
if (same_type_check (from, 0, to, 3) == FAILURE)
return FAILURE;
- if (variable_check (to, 3) == FAILURE)
+ if (variable_check (to, 3, false) == FAILURE)
return FAILURE;
if (type_check (topos, 4, BT_INTEGER) == FAILURE)
if (type_check (harvest, 0, BT_REAL) == FAILURE)
return FAILURE;
- if (variable_check (harvest, 0) == FAILURE)
+ if (variable_check (harvest, 0, false) == FAILURE)
return FAILURE;
return SUCCESS;
if (type_check (size, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (size, 0) == FAILURE)
+ if (variable_check (size, 0, false) == FAILURE)
return FAILURE;
if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
if (type_check (get, 2, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (get, 2) == FAILURE)
+ if (variable_check (get, 2, false) == FAILURE)
return FAILURE;
if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
if (type_check (count, 0, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (count, 0) == FAILURE)
+ if (variable_check (count, 0, false) == FAILURE)
return FAILURE;
}
if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (count_rate, 1) == FAILURE)
+ if (variable_check (count_rate, 1, false) == FAILURE)
return FAILURE;
if (count != NULL
if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
return FAILURE;
- if (variable_check (count_max, 2) == FAILURE)
+ if (variable_check (count_max, 2, false) == FAILURE)
return FAILURE;
if (count != NULL
if (rank_check (x, 0, 1) == FAILURE)
return FAILURE;
- if (variable_check (x, 0) == FAILURE)
+ if (variable_check (x, 0, false) == FAILURE)
return FAILURE;
if (type_check (x, 0, BT_REAL) == FAILURE)
if (rank_check (values, 0, 1) == FAILURE)
return FAILURE;
- if (variable_check (values, 0) == FAILURE)
+ if (variable_check (values, 0, false) == FAILURE)
return FAILURE;
if (type_check (values, 0, BT_REAL) == FAILURE)
if (rank_check (values, 0, 1) == FAILURE)
return FAILURE;
- if (variable_check (values, 0) == FAILURE)
+ if (variable_check (values, 0, false) == FAILURE)
return FAILURE;
if (type_check (values, 0, BT_INTEGER) == FAILURE)
if (rank_check (values, 1, 1) == FAILURE)
return FAILURE;
- if (variable_check (values, 1) == FAILURE)
+ if (variable_check (values, 1, false) == FAILURE)
return FAILURE;
if (type_check (values, 1, BT_INTEGER) == FAILURE)