===================================================================
@@ -1655,36 +1655,6 @@ compare_parameter (gfc_symbol *formal, g
}
-/* Given a symbol of a formal argument list and an expression, see if
- the two are compatible as arguments. Returns nonzero if
- compatible, zero if not compatible. */
-
-static int
-compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
-{
- if (actual->expr_type != EXPR_VARIABLE)
- return 1;
-
- if (!actual->symtree->n.sym->attr.is_protected)
- return 1;
-
- if (!actual->symtree->n.sym->attr.use_assoc)
- return 1;
-
- if (formal->attr.intent == INTENT_IN
- || formal->attr.intent == INTENT_UNKNOWN)
- return 1;
-
- if (!actual->symtree->n.sym->attr.pointer)
- return 0;
-
- if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
- return 0;
-
- return 1;
-}
-
-
/* Returns the storage size of a symbol (formal argument) or
zero if it cannot be determined. */
@@ -2205,27 +2175,20 @@ compare_actual_formal (gfc_actual_arglis
}
/* Check intent = OUT/INOUT for definable actual argument. */
- if ((a->expr->expr_type != EXPR_VARIABLE
- || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
- && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
- && (f->sym->attr.intent == INTENT_OUT
- || f->sym->attr.intent == INTENT_INOUT))
- {
- if (where)
- gfc_error ("Actual argument at %L must be definable as "
- "the dummy argument '%s' is INTENT = OUT/INOUT",
- &a->expr->where, f->sym->name);
- return 0;
- }
-
- if (!compare_parameter_protected(f->sym, a->expr))
+ if ((f->sym->attr.intent == INTENT_OUT
+ || f->sym->attr.intent == INTENT_INOUT))
{
- if (where)
- gfc_error ("Actual argument at %L is use-associated with "
- "PROTECTED attribute and dummy argument '%s' is "
- "INTENT = OUT/INOUT",
- &a->expr->where,f->sym->name);
- return 0;
+ const char* context = (where
+ ? _("actual argument to INTENT = OUT/INOUT")
+ : NULL);
+
+ if (f->sym->attr.pointer
+ && gfc_check_vardef_context (a->expr, true, context)
+ == FAILURE)
+ return 0;
+ if (gfc_check_vardef_context (a->expr, false, context)
+ == FAILURE)
+ return 0;
}
if ((f->sym->attr.intent == INTENT_OUT
===================================================================
@@ -3585,6 +3585,19 @@ check_arglist (gfc_actual_arglist **ap,
gfc_typename (&actual->expr->ts));
return FAILURE;
}
+
+ /* If the formal argument is INTENT([IN]OUT), check for definability. */
+ if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT)
+ {
+ const char* context = (error_flag
+ ? _("actual argument to INTENT = OUT/INOUT")
+ : NULL);
+
+ /* No pointer arguments for intrinsics. */
+ if (gfc_check_vardef_context (actual->expr, false, context)
+ == FAILURE)
+ return FAILURE;
+ }
}
return SUCCESS;
===================================================================
@@ -784,6 +784,9 @@ typedef struct
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1;
+ /* This is a temporary selector for SELECT TYPE. */
+ unsigned select_type_temporary:1;
+
/* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */
unsigned ext_attr:EXT_ATTR_NUM;
@@ -2726,6 +2729,7 @@ bool gfc_has_ultimate_allocatable (gfc_e
bool gfc_has_ultimate_pointer (gfc_expr *);
gfc_expr* gfc_build_intrinsic_call (const char*, locus, unsigned, ...);
+gfc_try gfc_check_vardef_context (gfc_expr*, bool, const char*);
/* st.c */
===================================================================
@@ -3043,10 +3043,8 @@ gfc_check_assign (gfc_expr *lvalue, gfc_
sym = lvalue->symtree->n.sym;
- /* Check INTENT(IN), unless the object itself is the component or
- sub-component of a pointer. */
+ /* See if this is the component or subcomponent of a pointer. */
has_pointer = sym->attr.pointer;
-
for (ref = lvalue->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
{
@@ -3054,13 +3052,6 @@ gfc_check_assign (gfc_expr *lvalue, gfc_
break;
}
- if (!has_pointer && sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
- sym->name, &lvalue->where);
- return FAILURE;
- }
-
/* 12.5.2.2, Note 12.26: The result variable is very similar to any other
variable local to a function subprogram. Its existence begins when
execution of the function is initiated and ends when execution of the
@@ -3239,7 +3230,7 @@ gfc_check_pointer_assign (gfc_expr *lval
symbol_attribute attr;
gfc_ref *ref;
bool is_pure, rank_remap;
- int pointer, check_intent_in, proc_pointer;
+ int proc_pointer;
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
&& !lvalue->symtree->n.sym->attr.proc_pointer)
@@ -3259,24 +3250,13 @@ gfc_check_pointer_assign (gfc_expr *lval
return FAILURE;
}
-
- /* Check INTENT(IN), unless the object itself is the component or
- sub-component of a pointer. */
- check_intent_in = 1;
- pointer = lvalue->symtree->n.sym->attr.pointer;
proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
rank_remap = false;
for (ref = lvalue->ref; ref; ref = ref->next)
{
- if (pointer)
- check_intent_in = 0;
-
if (ref->type == REF_COMPONENT)
- {
- pointer = ref->u.c.component->attr.pointer;
- proc_pointer = ref->u.c.component->attr.proc_pointer;
- }
+ proc_pointer = ref->u.c.component->attr.proc_pointer;
if (ref->type == REF_ARRAY && ref->next == NULL)
{
@@ -3332,30 +3312,8 @@ gfc_check_pointer_assign (gfc_expr *lval
}
}
- if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
- lvalue->symtree->n.sym->name, &lvalue->where);
- return FAILURE;
- }
-
- if (!pointer && !proc_pointer
- && !(lvalue->ts.type == BT_CLASS
- && CLASS_DATA (lvalue)->attr.class_pointer))
- {
- gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
- return FAILURE;
- }
-
is_pure = gfc_pure (NULL);
- if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
- && lvalue->symtree->n.sym->value != rvalue)
- {
- gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
- return FAILURE;
- }
-
/* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
kind, etc for lvalue and rvalue must match, and rvalue must be a
pure variable if we're in a pure function. */
@@ -4338,3 +4296,188 @@ gfc_build_intrinsic_call (const char* na
return result;
}
+
+
+/* Check if an expression may appear in a variable definition context
+ (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
+ This is called from the various places when resolving
+ the pieces that make up such a context.
+
+ Optionally, a possible error message can be suppressed if context is NULL
+ and just the return status (SUCCESS / FAILURE) be requested. */
+
+gfc_try
+gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
+{
+ gfc_symbol* sym;
+ bool is_pointer;
+ bool check_intentin;
+ bool ptr_component;
+ symbol_attribute attr;
+ gfc_ref* ref;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ {
+ if (context)
+ gfc_error ("Non-variable expression in variable definition context (%s)"
+ " at %L", context, &e->where);
+ return FAILURE;
+ }
+
+ gcc_assert (e->symtree);
+ sym = e->symtree->n.sym;
+
+ if (!pointer && sym->attr.flavor == FL_PARAMETER)
+ {
+ if (context)
+ gfc_error ("Named constant '%s' in variable definition context (%s)"
+ " at %L", sym->name, context, &e->where);
+ return FAILURE;
+ }
+ if (!pointer && sym->attr.flavor != FL_VARIABLE
+ && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
+ && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
+ {
+ if (context)
+ gfc_error ("'%s' in variable definition context (%s) at %L is not"
+ " a variable", sym->name, context, &e->where);
+ return FAILURE;
+ }
+
+ /* Find out whether the expr is a pointer; this also means following
+ component references to the last one. */
+ attr = gfc_expr_attr (e);
+ is_pointer = (attr.pointer || attr.proc_pointer);
+ if (pointer && !is_pointer)
+ {
+ if (context)
+ gfc_error ("Non-POINTER in pointer association context (%s)"
+ " at %L", context, &e->where);
+ return FAILURE;
+ }
+
+ /* INTENT(IN) dummy argument. Check this, unless the object itself is
+ the component of sub-component of a pointer. Obviously,
+ procedure pointers are of no interest here. */
+ check_intentin = true;
+ ptr_component = sym->attr.pointer;
+ for (ref = e->ref; ref && check_intentin; ref = ref->next)
+ {
+ if (ptr_component && ref->type == REF_COMPONENT)
+ check_intentin = false;
+ if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
+ ptr_component = true;
+ }
+ if (check_intentin && sym->attr.intent == INTENT_IN)
+ {
+ if (pointer && is_pointer)
+ {
+ if (context)
+ gfc_error ("Dummy-argument '%s' with INTENT(IN) in pointer"
+ " association context (%s) at %L",
+ sym->name, context, &e->where);
+ return FAILURE;
+ }
+ if (!pointer && !is_pointer)
+ {
+ if (context)
+ gfc_error ("Dummy-argument '%s' with INTENT(IN) in variable"
+ " definition context (%s) at %L",
+ sym->name, context, &e->where);
+ return FAILURE;
+ }
+ }
+
+ /* PROTECTED and use-associated. */
+ if (sym->attr.is_protected && sym->attr.use_assoc)
+ {
+ if (pointer && is_pointer)
+ {
+ if (context)
+ gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
+ " pointer association context (%s) at %L",
+ sym->name, context, &e->where);
+ return FAILURE;
+ }
+ if (!pointer && !is_pointer)
+ {
+ if (context)
+ gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
+ " variable definition context (%s) at %L",
+ sym->name, context, &e->where);
+ return FAILURE;
+ }
+ }
+
+ /* Variable not assignable from a PURE procedure but appears in
+ variable definition context. */
+ if (!pointer && gfc_pure (NULL) && gfc_impure_variable (sym))
+ {
+ if (context)
+ gfc_error ("Variable '%s' can not appear in a variable definition"
+ " context (%s) at %L in PURE procedure",
+ sym->name, context, &e->where);
+ return FAILURE;
+ }
+
+ /* Check variable definition context for associate-names. */
+ if (!pointer && sym->assoc)
+ {
+ const char* name;
+ gfc_association_list* assoc;
+
+ gcc_assert (sym->assoc->target);
+
+ /* If this is a SELECT TYPE temporary (the association is used internally
+ for SELECT TYPE), silently go over to the target. */
+ if (sym->attr.select_type_temporary)
+ {
+ gfc_expr* t = sym->assoc->target;
+
+ gcc_assert (t->expr_type == EXPR_VARIABLE);
+ name = t->symtree->name;
+
+ if (t->symtree->n.sym->assoc)
+ assoc = t->symtree->n.sym->assoc;
+ else
+ assoc = sym->assoc;
+ }
+ else
+ {
+ name = sym->name;
+ assoc = sym->assoc;
+ }
+ gcc_assert (name && assoc);
+
+ /* Is association to a valid variable? */
+ if (!assoc->variable)
+ {
+ if (context)
+ {
+ if (assoc->target->expr_type == EXPR_VARIABLE)
+ gfc_error ("'%s' at %L associated to vector-indexed target can"
+ " not be used in a variable definition context (%s)",
+ name, &e->where, context);
+ else
+ gfc_error ("'%s' at %L associated to expression can"
+ " not be used in a variable definition context (%s)",
+ name, &e->where, context);
+ }
+ return FAILURE;
+ }
+
+ /* Target must be allowed to appear in a variable definition context. */
+ if (gfc_check_vardef_context (assoc->target, pointer, NULL) == FAILURE)
+ {
+ if (context)
+ gfc_error ("Associate-name '%s' can not appear in a variable"
+ " definition context (%s) at %L because it's target"
+ " at %L can not, either",
+ name, context, &e->where,
+ &assoc->target->where);
+ return FAILURE;
+ }
+ }
+
+ return SUCCESS;
+}
===================================================================
@@ -2859,8 +2859,6 @@ gfc_iso_c_func_interface (gfc_symbol *sy
/* Resolve a function call, which means resolving the arguments, then figuring
out which entity the name refers to. */
-/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
- to INTENT(OUT) or INTENT(INOUT). */
static gfc_try
resolve_function (gfc_expr *expr)
@@ -6131,12 +6129,9 @@ gfc_resolve_iterator (gfc_iterator *iter
== FAILURE)
return FAILURE;
- if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
- {
- gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
- &iter->var->where);
- return FAILURE;
- }
+ if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
+ == FAILURE)
+ return FAILURE;
if (gfc_resolve_iterator_expr (iter->start, real_ok,
"Start expression in DO loop") == FAILURE)
@@ -6331,14 +6326,11 @@ static gfc_try
resolve_deallocate_expr (gfc_expr *e)
{
symbol_attribute attr;
- int allocatable, pointer, check_intent_in;
+ int allocatable, pointer;
gfc_ref *ref;
gfc_symbol *sym;
gfc_component *c;
- /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
- check_intent_in = 1;
-
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
@@ -6359,9 +6351,6 @@ resolve_deallocate_expr (gfc_expr *e)
}
for (ref = e->ref; ref; ref = ref->next)
{
- if (pointer)
- check_intent_in = 0;
-
switch (ref->type)
{
case REF_ARRAY:
@@ -6399,12 +6388,11 @@ resolve_deallocate_expr (gfc_expr *e)
return FAILURE;
}
- if (check_intent_in && sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
- sym->name, &e->where);
- return FAILURE;
- }
+ if (pointer
+ && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
+ return FAILURE;
+ if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
+ return FAILURE;
if (e->ts.type == BT_CLASS)
{
@@ -6464,6 +6452,31 @@ gfc_expr_to_initialize (gfc_expr *e)
}
+/* If the last ref of an expression is an array ref, return a copy of the
+ expression with that one removed. Otherwise, a copy of the original
+ expression. This is used for allocate-expressions and pointer assignment
+ LHS, where there may be an array specification that needs to be stripped
+ off when using gfc_check_vardef_context. */
+
+static gfc_expr*
+remove_last_array_ref (gfc_expr* e)
+{
+ gfc_expr* e2;
+ gfc_ref** r;
+
+ e2 = gfc_copy_expr (e);
+ for (r = &e2->ref; *r; r = &(*r)->next)
+ if ((*r)->type == REF_ARRAY && !(*r)->next)
+ {
+ gfc_free_ref_list (*r);
+ *r = NULL;
+ break;
+ }
+
+ return e2;
+}
+
+
/* Used in resolve_allocate_expr to check that a allocation-object and
a source-expr are conformable. This does not catch all possible
cases; in particular a runtime checking is needed. */
@@ -6526,17 +6539,16 @@ conformable_arrays (gfc_expr *e1, gfc_ex
static gfc_try
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
- int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
+ int i, pointer, allocatable, dimension, is_abstract;
int codimension;
symbol_attribute attr;
gfc_ref *ref, *ref2;
+ gfc_expr *e2;
gfc_array_ref *ar;
gfc_symbol *sym = NULL;
gfc_alloc *a;
gfc_component *c;
-
- /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
- check_intent_in = 1;
+ gfc_try t;
/* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
checking of coarrays. */
@@ -6588,9 +6600,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
- if (pointer)
- check_intent_in = 0;
-
switch (ref->type)
{
case REF_ARRAY:
@@ -6677,12 +6686,18 @@ resolve_allocate_expr (gfc_expr *e, gfc_
goto failure;
}
- if (check_intent_in && sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
- sym->name, &e->where);
- goto failure;
- }
+ /* In the variable definition context checks, gfc_expr_attr is used
+ on the expression. This is fooled by the array specification
+ present in e, thus we have to eliminate that one temporarily. */
+ e2 = remove_last_array_ref (e);
+ t = SUCCESS;
+ if (t == SUCCESS && pointer)
+ t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
+ if (t == SUCCESS)
+ t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
+ gfc_free_expr (e2);
+ if (t == FAILURE)
+ goto failure;
if (!code->expr3)
{
@@ -6733,9 +6748,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_
if (pointer || (dimension == 0 && codimension == 0))
goto success;
- /* Make sure the next-to-last reference node is an array specification. */
+ /* Make sure the last reference node is an array specifiction. */
- if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
+ if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
gfc_error ("Array specification required in ALLOCATE statement "
@@ -6846,20 +6861,13 @@ resolve_allocate_deallocate (gfc_code *c
gfc_expr *stat, *errmsg, *pe, *qe;
gfc_alloc *a, *p, *q;
- stat = code->expr1 ? code->expr1 : NULL;
-
- errmsg = code->expr2 ? code->expr2 : NULL;
+ stat = code->expr1;
+ errmsg = code->expr2;
/* Check the stat variable. */
if (stat)
{
- if (stat->symtree->n.sym->attr.intent == INTENT_IN)
- gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
- stat->symtree->n.sym->name, &stat->where);
-
- if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
- gfc_error ("Illegal stat-variable at %L for a PURE procedure",
- &stat->where);
+ gfc_check_vardef_context (stat, false, _("STAT variable"));
if ((stat->ts.type != BT_INTEGER
&& !(stat->ref && (stat->ref->type == REF_ARRAY
@@ -6902,13 +6910,7 @@ resolve_allocate_deallocate (gfc_code *c
gfc_warning ("ERRMSG at %L is useless without a STAT tag",
&errmsg->where);
- if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
- gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
- errmsg->symtree->n.sym->name, &errmsg->where);
-
- if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
- gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
- &errmsg->where);
+ gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
if ((errmsg->ts.type != BT_CHARACTER
&& !(errmsg->ref
@@ -7539,7 +7541,6 @@ static void
resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
{
gfc_expr* target;
- bool to_var;
gcc_assert (sym->assoc);
gcc_assert (sym->attr.flavor == FL_VARIABLE);
@@ -7573,22 +7574,8 @@ resolve_assoc_var (gfc_symbol* sym, bool
gcc_assert (sym->ts.type != BT_UNKNOWN);
/* See if this is a valid association-to-variable. */
- to_var = (target->expr_type == EXPR_VARIABLE
- && !gfc_has_vector_subscript (target));
- if (sym->assoc->variable && !to_var)
- {
- if (target->expr_type == EXPR_VARIABLE)
- gfc_error ("'%s' at %L associated to vector-indexed target can not"
- " be used in a variable definition context",
- sym->name, &sym->declared_at);
- else
- gfc_error ("'%s' at %L associated to expression can not"
- " be used in a variable definition context",
- sym->name, &sym->declared_at);
-
- return;
- }
- sym->assoc->variable = to_var;
+ sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
+ && !gfc_has_vector_subscript (target));
/* Finally resolve if this is an array or not. */
if (sym->attr.dimension && target->rank == 0)
@@ -7617,7 +7604,7 @@ resolve_assoc_var (gfc_symbol* sym, bool
/* Resolve a SELECT TYPE statement. */
static void
-resolve_select_type (gfc_code *code)
+resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
{
gfc_symbol *selector_type;
gfc_code *body, *new_st, *if_st, *tail;
@@ -7895,8 +7882,13 @@ resolve_select_type (gfc_code *code)
default_case->next = if_st;
}
- resolve_select (code);
+ /* Resolve the internal code. This can not be done earlier because
+ it requires that the sym->assoc of selectors is set already. */
+ gfc_current_ns = ns;
+ gfc_resolve_blocks (code->block, gfc_current_ns);
+ gfc_current_ns = old_ns;
+ resolve_select (code);
}
@@ -8657,7 +8649,6 @@ resolve_ordinary_assign (gfc_code *code,
}
}
-
if (lhs->ts.type == BT_CHARACTER
&& gfc_option.warn_character_truncation)
{
@@ -8698,15 +8689,6 @@ resolve_ordinary_assign (gfc_code *code,
if (gfc_pure (NULL))
{
- if (gfc_impure_variable (lhs->symtree->n.sym))
- {
- gfc_error ("Cannot assign to variable '%s' in PURE "
- "procedure at %L",
- lhs->symtree->n.sym->name,
- &lhs->where);
- return rval;
- }
-
if (lhs->ts.type == BT_DERIVED
&& lhs->expr_type == EXPR_VARIABLE
&& lhs->ts.u.derived->attr.pointer_comp
@@ -8810,9 +8792,8 @@ resolve_code (gfc_code *code, gfc_namesp
gfc_resolve_omp_do_blocks (code, ns);
break;
case EXEC_SELECT_TYPE:
- gfc_current_ns = code->ext.block.ns;
- gfc_resolve_blocks (code->block, gfc_current_ns);
- gfc_current_ns = ns;
+ /* Blocks are handled in resolve_select_type because we have
+ to transform the SELECT TYPE into ASSOCIATE first. */
break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
@@ -8899,6 +8880,10 @@ resolve_code (gfc_code *code, gfc_namesp
if (t == FAILURE)
break;
+ if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
+ == FAILURE)
+ break;
+
if (resolve_ordinary_assign (code, ns))
{
if (code->op == EXEC_COMPCALL)
@@ -8923,11 +8908,27 @@ resolve_code (gfc_code *code, gfc_namesp
break;
case EXEC_POINTER_ASSIGN:
- if (t == FAILURE)
- break;
+ {
+ gfc_expr* e;
- gfc_check_pointer_assign (code->expr1, code->expr2);
- break;
+ if (t == FAILURE)
+ break;
+
+ /* This is both a variable definition and pointer assignment
+ context, so check both of them. For rank remapping, a final
+ array ref may be present on the LHS and fool gfc_expr_attr
+ used in gfc_check_vardef_context. Remove it. */
+ e = remove_last_array_ref (code->expr1);
+ t = gfc_check_vardef_context (e, true, _("pointer assignment"));
+ if (t == SUCCESS)
+ t = gfc_check_vardef_context (e, false, _("pointer assignment"));
+ gfc_free_expr (e);
+ if (t == FAILURE)
+ break;
+
+ gfc_check_pointer_assign (code->expr1, code->expr2);
+ break;
+ }
case EXEC_ARITHMETIC_IF:
if (t == SUCCESS
@@ -8970,7 +8971,7 @@ resolve_code (gfc_code *code, gfc_namesp
break;
case EXEC_SELECT_TYPE:
- resolve_select_type (code);
+ resolve_select_type (code, ns);
break;
case EXEC_BLOCK:
===================================================================
@@ -978,13 +978,6 @@ gfc_match_iterator (gfc_iterator *iter,
goto cleanup;
}
- if (var->symtree->n.sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
- var->symtree->n.sym->name);
- goto cleanup;
- }
-
gfc_match_char ('=');
var->symtree->n.sym->attr.implied_index = 1;
@@ -1847,9 +1840,7 @@ gfc_match_associate (void)
/* The `variable' field is left blank for now; because the target is not
yet resolved, we can't use gfc_has_vector_subscript to determine it
- for now. Instead, if the symbol is matched as variable, this field
- is set -- and during resolution we check that. */
- newAssoc->variable = 0;
+ for now. This is set during resolution. */
/* Put it into the list. */
newAssoc->next = new_st.ext.block.assoc;
@@ -3166,12 +3157,6 @@ gfc_match_nullify (void)
if (gfc_check_do_variable (p->symtree))
goto cleanup;
- if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
- {
- gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
- goto cleanup;
- }
-
/* build ' => NULL() '. */
e = gfc_get_null_expr (&gfc_current_locus);
@@ -4523,6 +4508,7 @@ select_type_set_tmp (gfc_typespec *ts)
&tmp->n.sym->as, false);
tmp->n.sym->attr.class_ok = 1;
}
+ tmp->n.sym->attr.select_type_temporary = 1;
/* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */
===================================================================
@@ -2007,7 +2007,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_t
if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
- ref = expr->ref;
sym = expr->symtree->n.sym;
attr = sym->attr;
@@ -2031,7 +2030,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_t
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
*ts = sym->ts;
- for (; ref; ref = ref->next)
+ for (ref = expr->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
@@ -2986,13 +2985,7 @@ match_variable (gfc_expr **result, int e
switch (sym->attr.flavor)
{
case FL_VARIABLE:
- if (sym->attr.is_protected && sym->attr.use_assoc)
- {
- gfc_error ("Assigning to PROTECTED variable at %C");
- return MATCH_ERROR;
- }
- if (sym->assoc)
- sym->assoc->variable = 1;
+ /* Everything is alright. */
break;
case FL_UNKNOWN:
@@ -3024,22 +3017,24 @@ match_variable (gfc_expr **result, int e
case FL_PARAMETER:
if (equiv_flag)
- gfc_error ("Named constant at %C in an EQUIVALENCE");
- else
- gfc_error ("Cannot assign to a named constant at %C");
- return MATCH_ERROR;
+ {
+ gfc_error ("Named constant at %C in an EQUIVALENCE");
+ return MATCH_ERROR;
+ }
+ /* Otherwise this is checked for and an error given in the
+ variable definition context checks. */
break;
case FL_PROCEDURE:
/* Check for a nonrecursive function result variable. */
if (sym->attr.function
- && !sym->attr.external
- && sym->result == sym
- && (gfc_is_function_return_value (sym, gfc_current_ns)
- || (sym->attr.entry
- && sym->ns == gfc_current_ns)
- || (sym->attr.entry
- && sym->ns == gfc_current_ns->parent)))
+ && !sym->attr.external
+ && sym->result == sym
+ && (gfc_is_function_return_value (sym, gfc_current_ns)
+ || (sym->attr.entry
+ && sym->ns == gfc_current_ns)
+ || (sym->attr.entry
+ && sym->ns == gfc_current_ns->parent)))
{
/* If a function result is a derived type, then the derived
type may still have to be resolved. */
===================================================================
@@ -18,9 +18,26 @@ PROGRAM main
ptr => a ! { dg-error "neither TARGET nor POINTER" }
END ASSOCIATE
- ASSOCIATE (a => 5, & ! { dg-error "variable definition context" }
- b => arr((/ 1, 3 /))) ! { dg-error "variable definition context" }
- a = 4
- b = 7
+ ASSOCIATE (a => 5, b => arr((/ 1, 3 /)))
+ a = 4 ! { dg-error "variable definition context" }
+ b = 7 ! { dg-error "variable definition context" }
+ CALL test2 (a) ! { dg-error "variable definition context" }
+ CALL test2 (b) ! { dg-error "variable definition context" }
END ASSOCIATE
+
+CONTAINS
+
+ SUBROUTINE test (x)
+ INTEGER, INTENT(IN) :: x
+ ASSOCIATE (y => x) ! { dg-error "variable definition context" }
+ y = 5 ! { dg-error "variable definition context" }
+ CALL test2 (x) ! { dg-error "variable definition context" }
+ END ASSOCIATE
+ END SUBROUTINE test
+
+ ELEMENTAL SUBROUTINE test2 (x)
+ INTEGER, INTENT(OUT) :: x
+ x = 5
+ END SUBROUTINE test2
+
END PROGRAM main
===================================================================
@@ -23,7 +23,7 @@ CONTAINS
TYPE(node_type), POINTER :: node
TYPE(node_type), POINTER :: give_next
give_next => node%next ! { dg-error "Bad target" }
- node%next => give_next ! { dg-error "Bad pointer object" }
+ node%next => give_next ! { dg-error "variable definition context" }
END FUNCTION
! Comment #2
PURE integer FUNCTION give_next2(i)
@@ -55,14 +55,14 @@ CONTAINS
TYPE(T1), POINTER :: RES
RES => A ! { dg-error "Bad target" }
RES => B ! { dg-error "Bad target" }
- B => RES ! { dg-error "Bad pointer object" }
+ B => RES ! { dg-error "variable definition context" }
END FUNCTION
PURE FUNCTION TST2(A) RESULT(RES)
TYPE(T1), INTENT(IN), TARGET :: A
TYPE(T1), POINTER :: RES
allocate (RES)
RES = A
- B = RES ! { dg-error "Cannot assign" }
+ B = RES ! { dg-error "variable definition context" }
RES = B
END FUNCTION
END MODULE pr20882
===================================================================
@@ -10,7 +10,7 @@ program main
enumerator :: blue = 1
end enum junk ! { dg-error "Syntax error" }
- blue = 10 ! { dg-error " assign to a named constant" }
+ blue = 10 ! { dg-error "Unexpected assignment" }
end program main ! { dg-error "Expecting END ENUM" }
! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 }
===================================================================
@@ -19,11 +19,11 @@ program test
contains
subroutine a(p)
integer, pointer,intent(in) :: p
- p => null(p)! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
- nullify(p) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
- allocate(p) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
- call c(p) ! { dg-error "is INTENT\\(IN\\) while interface specifies INTENT\\(INOUT\\)" }
- deallocate(p) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
+ p => null(p)! { dg-error "pointer association context" }
+ nullify(p) ! { dg-error "pointer association context" }
+ allocate(p) ! { dg-error "pointer association context" }
+ call c(p) ! { dg-error "pointer association context" }
+ deallocate(p) ! { dg-error "pointer association context" }
end subroutine
subroutine c(p)
integer, pointer, intent(inout) :: p
@@ -32,10 +32,10 @@ contains
subroutine b(t)
type(myT),intent(in) :: t
t%jp = 5
- t%jp => null(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
- nullify(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
- t%j = 7 ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
- allocate(t%jp) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
- deallocate(t%jp) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
+ t%jp => null(t%jp) ! { dg-error "pointer association context" }
+ nullify(t%jp) ! { dg-error "pointer association context" }
+ t%j = 7 ! { dg-error "variable definition context" }
+ allocate(t%jp) ! { dg-error "pointer association context" }
+ deallocate(t%jp) ! { dg-error "pointer association context" }
end subroutine b
end program
===================================================================
@@ -3,10 +3,10 @@
! Contributed by Paul Thomas <pault@gcc@gnu.org>
real, parameter :: a =42.0
real :: b
- call foo(b + 2.0) ! { dg-error "must be definable" }
- call foo(a) ! { dg-error "must be definable" }
- call bar(b + 2.0) ! { dg-error "must be definable" }
- call bar(a) ! { dg-error "must be definable" }
+ call foo(b + 2.0) ! { dg-error "variable definition context" }
+ call foo(a) ! { dg-error "variable definition context" }
+ call bar(b + 2.0) ! { dg-error "variable definition context" }
+ call bar(a) ! { dg-error "variable definition context" }
contains
subroutine foo(a)
real, intent(out) :: a
===================================================================
@@ -0,0 +1,44 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+
+! PR fortran/44044
+! Definability check for select type to expression.
+! This is "bonus feature #2" from comment #3 of the PR.
+
+! Contributed by Janus Weil, janus@gcc.gnu.org.
+
+implicit none
+
+type :: t1
+ integer :: i
+end type
+
+type, extends(t1) :: t2
+end type
+
+type(t1),target :: x1
+type(t2),target :: x2
+
+select type ( y => fun(1) )
+type is (t1)
+ y%i = 1 ! { dg-error "variable definition context" }
+type is (t2)
+ y%i = 2 ! { dg-error "variable definition context" }
+end select
+
+contains
+
+ function fun(i)
+ class(t1),pointer :: fun
+ integer :: i
+ if (i>0) then
+ fun => x1
+ else if (i<0) then
+ fun => x2
+ else
+ fun => NULL()
+ end if
+ end function
+
+end
+
===================================================================
@@ -49,9 +49,9 @@ end module good2
program main
use good2
implicit none
- t%j = 15 ! { dg-error "Assigning to PROTECTED variable" }
- nullify(t%p) ! { dg-error "Assigning to PROTECTED variable" }
- allocate(t%array(15))! { dg-error "Assigning to PROTECTED variable" }
+ t%j = 15 ! { dg-error "variable definition context" }
+ nullify(t%p) ! { dg-error "pointer association context" }
+ allocate(t%array(15))! { dg-error "variable definition context" }
end program main
! { dg-final { cleanup-modules "good1 good2 bad1 bad2" } }
===================================================================
@@ -15,6 +15,6 @@ CONTAINS
END SUBROUTINE S1
END MODULE M1
USE M1
-CALL S1(D1%I(3)) ! { dg-error "must be definable" }
+CALL S1(D1%I(3)) ! { dg-error "variable definition context" }
END
! { dg-final { cleanup-modules "m1" } }
===================================================================
@@ -13,8 +13,8 @@ program p
integer, pointer :: unprotected_pointer
! The next two lines should be rejected; see PR 37513 why
! we get such a strange error message.
- protected_pointer => unprotected_pointer ! { dg-error "only allowed in specification part" }
- protected_pointer = unprotected_pointer ! { dg-error "only allowed in specification part" }
+ protected_pointer => unprotected_pointer ! { dg-error "pointer association context" }
+ protected_pointer = unprotected_pointer ! OK
unprotected_pointer => protected_target ! { dg-error "target has PROTECTED attribute" }
unprotected_pointer => protected_pointer ! OK
end program p
===================================================================
@@ -9,7 +9,7 @@ pure integer function test(j)
common /z/ i
integer :: k
equivalence(i,k) ! { dg-error "EQUIVALENCE object in the pure" }
- k=1 ! { dg-error "in PURE procedure at" }
+ k=1 ! { dg-error "variable definition context" }
test=i*j
end function test
end
===================================================================
@@ -6,7 +6,7 @@ subroutine sub(i, j, err)
integer, intent(in), allocatable :: i(:)
integer, allocatable :: m(:)
integer n
- deallocate(i) ! { dg-error "Cannot deallocate" "" }
- deallocate(m, stat=j) ! { dg-error "cannot be" "" }
- deallocate(m,stat=n,errmsg=err) ! { dg-error "cannot be" "" }
+ deallocate(i) ! { dg-error "variable definition context" }
+ deallocate(m, stat=j) ! { dg-error "variable definition context" }
+ deallocate(m,stat=n,errmsg=err) ! { dg-error "variable definition context" }
end subroutine sub
===================================================================
@@ -11,5 +11,5 @@ interface
end subroutine foo
end interface
character :: n(5)
-call foo( (n) ) ! { dg-error "must be definable" }
+call foo( (n) ) ! { dg-error "Non-variable expression" }
end
===================================================================
@@ -18,7 +18,7 @@ type(face_t), pointer :: face
allocate(face)
allocate(blu)
-face%bla => blu ! { dg-error "Pointer assignment to non-POINTER" }
+face%bla => blu ! { dg-error "Non-POINTER in pointer association context" }
end program
===================================================================
@@ -9,5 +9,7 @@ program main
enumerator blue = 1 ! { dg-error "Syntax error in ENUMERATOR definition" }
end enum
+ red = 42 ! { dg-error "variable definition context" }
+
enumerator :: sun ! { dg-error "ENUM" }
end program main
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
program pr19936_1
integer, parameter :: i=4
- print *,(/(i,i=1,4)/) ! { dg-error "assign to a named constant" }
+ print *,(/(i,i=1,4)/) ! { dg-error "variable definition context" }
end program pr19936_1
===================================================================
@@ -20,7 +20,7 @@ contains
class is (myType)
x%a = 42.
r3 = 43.
- g = 44. ! { dg-error "Cannot assign to variable" }
+ g = 44. ! { dg-error "variable definition context" }
end select
end subroutine
@@ -30,7 +30,7 @@ contains
real :: r2
r1 = 45.
r2 = 46.
- g = 47. ! { dg-error "Cannot assign to variable" }
+ g = 47. ! { dg-error "variable definition context" }
end block
end subroutine
===================================================================
@@ -38,7 +38,7 @@ type(t) :: x
x%ptr2 => x ! { dg-error "Invalid procedure pointer assignment" }
-x => x%ptr2 ! { dg-error "Pointer assignment to non-POINTER" }
+x => x%ptr2 ! { dg-error "Non-POINTER in pointer association context" }
print *, x%ptr1() ! { dg-error "attribute conflicts with" }
call x%ptr2() ! { dg-error "attribute conflicts with" }
===================================================================
@@ -10,6 +10,6 @@ module read
subroutine a
integer, parameter :: n = 2
if (i .eq. 0) read(j,*) k
- if (i .eq. 0) n = j ! { dg-error "assign to a named constant" "" }
+ if (i .eq. 0) n = j ! { dg-error "Named constant 'n' in variable definition context" }
end subroutine a
end module read
===================================================================
@@ -23,15 +23,15 @@ program main
integer :: j
logical :: asgnd
protected :: j ! { dg-error "only allowed in specification part of a module" }
- a = 43 ! { dg-error "Assigning to PROTECTED variable" }
- ap => null() ! { dg-error "Assigning to PROTECTED variable" }
- nullify(ap) ! { dg-error "Assigning to PROTECTED variable" }
- ap => at ! { dg-error "Assigning to PROTECTED variable" }
- ap = 3 ! { dg-error "Assigning to PROTECTED variable" }
- allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
- ap = 73 ! { dg-error "Assigning to PROTECTED variable" }
- call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
- call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
+ a = 43 ! { dg-error "variable definition context" }
+ ap => null() ! { dg-error "pointer association context" }
+ nullify(ap) ! { dg-error "pointer association context" }
+ ap => at ! { dg-error "pointer association context" }
+ ap = 3 ! OK
+ allocate(ap) ! { dg-error "pointer association context" }
+ ap = 73 ! OK
+ call increment(a,at) ! { dg-error "variable definition context" }
+ call pointer_assignments(ap) ! { dg-error "pointer association context" }
asgnd = pointer_check(ap)
contains
subroutine increment(a1,a3)
===================================================================
@@ -19,15 +19,15 @@ end module protmod
program main
use protmod
implicit none
- a = 43 ! { dg-error "Assigning to PROTECTED variable" }
- ap => null() ! { dg-error "Assigning to PROTECTED variable" }
- nullify(ap) ! { dg-error "Assigning to PROTECTED variable" }
- ap => at ! { dg-error "Assigning to PROTECTED variable" }
- ap = 3 ! { dg-error "Assigning to PROTECTED variable" }
- allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
- ap = 73 ! { dg-error "Assigning to PROTECTED variable" }
- call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
- call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
+ a = 43 ! { dg-error "variable definition context" }
+ ap => null() ! { dg-error "pointer association context" }
+ nullify(ap) ! { dg-error "pointer association context" }
+ ap => at ! { dg-error "pointer association context" }
+ ap = 3 ! OK
+ allocate(ap) ! { dg-error "pointer association context" }
+ ap = 73 ! OK
+ call increment(a,at) ! { dg-error "variable definition context" }
+ call pointer_assignments(ap) ! { dg-error "pointer association context" }
contains
subroutine increment(a1,a3)
integer, intent(inout) :: a1, a3
===================================================================
@@ -0,0 +1,11 @@
+! { dg-do compile }
+
+! PR fortran/45474
+! Definability checks for INTENT([IN]OUT) and intrinsics.
+
+! Contributed by Tobias Burnus, burnus@gcc.gnu.org.
+
+call execute_command_line("date", .true.,(1),1,'aa') ! { dg-error "variable definition context" }
+call execute_command_line("date", .true.,1,(1),'aa') ! { dg-error "variable definition context" }
+call execute_command_line("date", .true.,1,1,('aa')) ! { dg-error "variable definition context" }
+end
===================================================================
@@ -16,13 +16,13 @@ contains
subroutine init2(x)
integer, allocatable, intent(in) :: x(:)
- allocate(x(3)) ! { dg-error "Cannot allocate" }
+ allocate(x(3)) ! { dg-error "variable definition context" }
end subroutine init2
subroutine kill(x)
integer, allocatable, intent(in) :: x(:)
- deallocate(x) ! { dg-error "Cannot deallocate" }
+ deallocate(x) ! { dg-error "variable definition context" }
end subroutine kill
end program alloc_dummy
===================================================================
@@ -6,7 +6,7 @@ subroutine sub(i, j, err)
integer, intent(in), allocatable :: i(:)
integer, allocatable :: m(:)
integer n
- allocate(i(2)) ! { dg-error "Cannot allocate" "" }
- allocate(m(2), stat=j) ! { dg-error "cannot be" "" }
- allocate(m(2),stat=n,errmsg=err) ! { dg-error "cannot be" "" }
+ allocate(i(2)) ! { dg-error "variable definition context" }
+ allocate(m(2), stat=j) ! { dg-error "variable definition context" }
+ allocate(m(2),stat=n,errmsg=err) ! { dg-error "variable definition context" }
end subroutine sub