+2012-10-28 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/54958
+ * gfortran.h (gfc_resolve_iterator_expr,
+ gfc_check_vardef_context): Update prototype.
+ * expr.c (gfc_check_vardef_context): Add own_scope
+ argument and honour it.
+ * resolve.c (gfc_resolve_iterator_expr): Add own_scope
+ argument and honour it.
+ (resolve_deallocate_expr, resolve_allocate_expr,
+ resolve_data_variables, resolve_transfer
+ resolve_lock_unlock, resolve_code): Update calls.
+ * array.c (resolve_array_list): Ditto.
+ * check.c (gfc_check_atomic_def, gfc_check_atomic_ref): Ditto.
+ * interface.c (compare_actual_formal): Ditto.
+ * intrinsic.c (check_arglist): Ditto.
+ * io.c (resolve_tag, gfc_resolve_dt, gfc_resolve_inquire): Ditto.
+
2012-10-27 Thomas Koenig <tkoenig@gcc.gnu.org>
* trans.c (gfc_allocate_allocatable): Revert accidental
gfc_symbol *iter_var;
locus iter_var_loc;
- if (gfc_resolve_iterator (iter, false) == FAILURE)
+ if (gfc_resolve_iterator (iter, false, true) == FAILURE)
t = FAILURE;
/* Check for bounds referencing the iterator variable. */
if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (atom, false, false, NULL) == FAILURE)
+ if (gfc_check_vardef_context (atom, false, false, false, NULL) == FAILURE)
{
gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
"definable", gfc_current_intrinsic, &atom->where);
if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (value, false, false, NULL) == FAILURE)
+ if (gfc_check_vardef_context (value, false, false, false, NULL) == FAILURE)
{
gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
"definable", gfc_current_intrinsic, &value->where);
(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.
+ If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
+ variables), some checks are not performed.
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, bool alloc_obj,
- const char* context)
+ bool own_scope, const char* context)
{
gfc_symbol* sym = NULL;
bool is_pointer;
assignment to a pointer component from pointer-assignment to a pointer
component. Note that (normal) assignment to procedure pointers is not
possible. */
- check_intentin = true;
+ check_intentin = !own_scope;
ptr_component = (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
for (ref = e->ref; ref && check_intentin; ref = ref->next)
}
/* PROTECTED and use-associated. */
- if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
+ if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
{
if (pointer && is_pointer)
{
/* Variable not assignable from a PURE procedure but appears in
variable definition context. */
- if (!pointer && gfc_pure (NULL) && gfc_impure_variable (sym))
+ if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym))
{
if (context)
gfc_error ("Variable '%s' can not appear in a variable definition"
}
/* Target must be allowed to appear in a variable definition context. */
- if (gfc_check_vardef_context (assoc->target, pointer, false, NULL)
+ if (gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)
== FAILURE)
{
if (context)
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, bool, const char*);
+gfc_try gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*);
/* st.c */
int gfc_pure (gfc_symbol *);
int gfc_implicit_pure (gfc_symbol *);
int gfc_elemental (gfc_symbol *);
-gfc_try gfc_resolve_iterator (gfc_iterator *, bool);
+gfc_try gfc_resolve_iterator (gfc_iterator *, bool, bool);
gfc_try find_forall_index (gfc_expr *, gfc_symbol *, int);
gfc_try gfc_resolve_index (gfc_expr *, int);
gfc_try gfc_resolve_dim_arg (gfc_expr *);
if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
&& CLASS_DATA (f->sym)->attr.class_pointer)
|| (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
- && gfc_check_vardef_context (a->expr, true, false, context)
+ && gfc_check_vardef_context (a->expr, true, false, false, context)
== FAILURE)
return 0;
- if (gfc_check_vardef_context (a->expr, false, false, context)
+ if (gfc_check_vardef_context (a->expr, false, false, false, context)
== FAILURE)
return 0;
}
: NULL);
/* No pointer arguments for intrinsics. */
- if (gfc_check_vardef_context (actual->expr, false, false, context)
- == FAILURE)
+ if (gfc_check_vardef_context (actual->expr, false, false, false,
+ context) == FAILURE)
return FAILURE;
}
}
char context[64];
sprintf (context, _("%s tag"), tag->name);
- if (gfc_check_vardef_context (e, false, false, context) == FAILURE)
+ if (gfc_check_vardef_context (e, false, false, false, context) == FAILURE)
return FAILURE;
}
/* If we are writing, make sure the internal unit can be changed. */
gcc_assert (k != M_PRINT);
if (k == M_WRITE
- && gfc_check_vardef_context (e, false, false,
+ && gfc_check_vardef_context (e, false, false, false,
_("internal unit in WRITE")) == FAILURE)
return FAILURE;
}
gfc_try t;
e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
- t = gfc_check_vardef_context (e, false, false, NULL);
+ t = gfc_check_vardef_context (e, false, false, false, NULL);
gfc_free_expr (e);
if (t == FAILURE)
{ \
char context[64]; \
sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
- if (gfc_check_vardef_context ((expr), false, false, context) == FAILURE) \
+ if (gfc_check_vardef_context ((expr), false, false, false, \
+ context) == FAILURE) \
return FAILURE; \
}
INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
/* Resolve the expressions in an iterator structure. If REAL_OK is
- false allow only INTEGER type iterators, otherwise allow REAL types. */
+ false allow only INTEGER type iterators, otherwise allow REAL types.
+ Set own_scope to true for ac-implied-do and data-implied-do as those
+ have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
gfc_try
-gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
+gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
{
if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
== FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable"))
+ if (gfc_check_vardef_context (iter->var, false, false, own_scope,
+ _("iterator variable"))
== FAILURE)
return FAILURE;
}
if (pointer
- && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object"))
+ && gfc_check_vardef_context (e, true, true, false, _("DEALLOCATE object"))
== FAILURE)
return FAILURE;
- if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object"))
+ if (gfc_check_vardef_context (e, false, true, false, _("DEALLOCATE object"))
== FAILURE)
return FAILURE;
e2 = remove_last_array_ref (e);
t = SUCCESS;
if (t == SUCCESS && pointer)
- t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object"));
+ t = gfc_check_vardef_context (e2, true, true, false, _("ALLOCATE object"));
if (t == SUCCESS)
- t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object"));
+ t = gfc_check_vardef_context (e2, false, true, false, _("ALLOCATE object"));
gfc_free_expr (e2);
if (t == FAILURE)
goto failure;
/* Check the stat variable. */
if (stat)
{
- gfc_check_vardef_context (stat, false, false, _("STAT variable"));
+ gfc_check_vardef_context (stat, false, false, false, _("STAT variable"));
if ((stat->ts.type != BT_INTEGER
&& !(stat->ref && (stat->ref->type == REF_ARRAY
gfc_warning ("ERRMSG at %L is useless without a STAT tag",
&errmsg->where);
- gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable"));
+ gfc_check_vardef_context (errmsg, false, false, false,
+ _("ERRMSG variable"));
if ((errmsg->ts.type != BT_CHARACTER
&& !(errmsg->ref
code->ext.dt may be NULL if the TRANSFER is related to
an INQUIRE statement -- but in this case, we are not reading, either. */
if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
- && gfc_check_vardef_context (exp, false, false, _("item in READ"))
+ && gfc_check_vardef_context (exp, false, false, false, _("item in READ"))
== FAILURE)
return;
&code->expr2->where);
if (code->expr2
- && gfc_check_vardef_context (code->expr2, false, false,
+ && gfc_check_vardef_context (code->expr2, false, false, false,
_("STAT variable")) == FAILURE)
return;
&code->expr3->where);
if (code->expr3
- && gfc_check_vardef_context (code->expr3, false, false,
+ && gfc_check_vardef_context (code->expr3, false, false, false,
_("ERRMSG variable")) == FAILURE)
return;
"variable", &code->expr4->where);
if (code->expr4
- && gfc_check_vardef_context (code->expr4, false, false,
+ && gfc_check_vardef_context (code->expr4, false, false, false,
_("ACQUIRED_LOCK variable")) == FAILURE)
return;
}
if (t == FAILURE)
break;
- if (gfc_check_vardef_context (code->expr1, false, false,
+ if (gfc_check_vardef_context (code->expr1, false, false, false,
_("assignment")) == FAILURE)
break;
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, false,
+ t = gfc_check_vardef_context (e, true, false, false,
_("pointer assignment"));
if (t == SUCCESS)
- t = gfc_check_vardef_context (e, false, false,
+ t = gfc_check_vardef_context (e, false, false, false,
_("pointer assignment"));
gfc_free_expr (e);
if (t == FAILURE)
if (code->ext.iterator != NULL)
{
gfc_iterator *iter = code->ext.iterator;
- if (gfc_resolve_iterator (iter, true) != FAILURE)
+ if (gfc_resolve_iterator (iter, true, false) != FAILURE)
gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
}
break;
}
else
{
- if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
+ if (gfc_resolve_iterator (&d->iter, false, true) == FAILURE)
return FAILURE;
if (resolve_data_variables (d->list) == FAILURE)
+2012-10-28 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/54958
+ * gfortran.dg/do_check_6.f90: New.
+
2012-10-27 Dominique Dhumieres <dominiq@lps.ens.fr>
Jack Howarth <howarth@bromo.med.uc.edu>
--- /dev/null
+! { dg-do compile }
+!
+! PR fortran/54958
+!
+module m
+ integer, protected :: i
+ integer :: j
+end module m
+
+subroutine test1()
+ use m
+ implicit none
+ integer :: A(5)
+ ! Valid: data-implied-do (has a scope of the statement or construct)
+ DATA (A(i), i=1,5)/5*42/ ! OK
+
+ ! Valid: ac-implied-do (has a scope of the statement or construct)
+ print *, [(i, i=1,5 )] ! OK
+
+ ! Valid: index-name (has a scope of the statement or construct)
+ forall (i = 1:5) ! OK
+ end forall
+
+ ! Valid: index-name (has a scope of the statement or construct)
+ do concurrent (i = 1:5) ! OK
+ end do
+
+ ! Invalid: io-implied-do
+ print *, (i, i=1,5 ) ! { dg-error "PROTECTED and can not appear in a variable definition context .iterator variable." }
+
+ ! Invalid: do-variable in a do-stmt
+ do i = 1, 5 ! { dg-error "PROTECTED and can not appear in a variable definition context .iterator variable." }
+ end do
+end subroutine test1
+
+subroutine test2(i)
+ implicit none
+ integer, intent(in) :: i
+ integer :: A(5)
+ ! Valid: data-implied-do (has a scope of the statement or construct)
+ DATA (A(i), i=1,5)/5*42/ ! OK
+
+ ! Valid: ac-implied-do (has a scope of the statement or construct)
+ print *, [(i, i=1,5 )] ! OK
+
+ ! Valid: index-name (has a scope of the statement or construct)
+ forall (i = 1:5) ! OK
+ end forall
+
+ ! Valid: index-name (has a scope of the statement or construct)
+ do concurrent (i = 1:5) ! OK
+ end do
+
+ ! Invalid: io-implied-do
+ print *, (i, i=1,5 ) ! { dg-error "INTENT.IN. in variable definition context .iterator variable." }
+
+ ! Invalid: do-variable in a do-stmt
+ do i = 1, 5 ! { dg-error "INTENT.IN. in variable definition context .iterator variable." }
+ end do
+end subroutine test2
+
+pure subroutine test3()
+ use m
+ implicit none
+ integer :: A(5)
+ !DATA (A(j), j=1,5)/5*42/ ! Not allowed in pure
+
+ ! Valid: ac-implied-do (has a scope of the statement or construct)
+ A = [(j, j=1,5 )] ! OK
+
+ ! Valid: index-name (has a scope of the statement or construct)
+ forall (j = 1:5) ! OK
+ end forall
+
+ ! Valid: index-name (has a scope of the statement or construct)
+ do concurrent (j = 1:5) ! OK
+ end do
+
+ ! print *, (j, j=1,5 ) ! I/O not allowed in PURE
+
+ ! Invalid: do-variable in a do-stmt
+ do j = 1, 5 ! { dg-error "variable definition context .iterator variable. at .1. in PURE procedure" }
+ end do
+end subroutine test3