mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-26 09:50:40 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/54958 (Wrongly rejects ac-implied-DO variables which also occur with INTENT(IN))

Browse Source 
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-28  Tobias Burnus  <burnus@net-b.de>

        PR fortran/54958
        * gfortran.dg/do_check_6.f90: New.

From-SVN: r192896
This commit is contained in:
Tobias Burnus 2012-10-28 17:57:12 +01:00 committed by Tobias Burnus
parent 036e177573
commit 57bf28eab7
11 changed files with 150 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/fortran/ChangeLog
View File

@ -1,3 +1,21 @@
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

2
gcc/fortran/array.c
View File

@ -1816,7 +1816,7 @@ resolve_array_list (gfc_constructor_base base)
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. */

4
gcc/fortran/check.c
View File

@ -1046,7 +1046,7 @@ gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
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);
@ -1063,7 +1063,7 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
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);

12
gcc/fortran/expr.c
View File

@ -4634,13 +4634,15 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
(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;
@ -4725,7 +4727,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
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)
@ -4760,7 +4762,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
}
/* 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)
{
@ -4782,7 +4784,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
/* 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"
@ -4856,7 +4858,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
}
/* 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)

4
gcc/fortran/gfortran.h
View File

@ -2784,7 +2784,7 @@ bool gfc_has_ultimate_allocatable (gfc_expr *);
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 */
@ -2805,7 +2805,7 @@ int gfc_impure_variable (gfc_symbol *);
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 *);

4
gcc/fortran/interface.c
View File

@ -2713,10 +2713,10 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
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;
}

4
gcc/fortran/intrinsic.c
View File

@ -3646,8 +3646,8 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
: 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;
}
}

9
gcc/fortran/io.c
View File

@ -1534,7 +1534,7 @@ resolve_tag (const io_tag *tag, gfc_expr *e)
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;
}
@ -2867,7 +2867,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
/* 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;
}
@ -2897,7 +2897,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
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)
@ -4063,7 +4063,8 @@ gfc_resolve_inquire (gfc_inquire *inquire)
{ \
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);

40
gcc/fortran/resolve.c
View File

@ -6683,16 +6683,19 @@ gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
/* 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;
@ -6961,10 +6964,10 @@ resolve_deallocate_expr (gfc_expr *e)
}
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;
@ -7307,9 +7310,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
@ -7489,7 +7492,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
/* 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
@ -7532,7 +7535,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
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
@ -8618,7 +8622,7 @@ resolve_transfer (gfc_code *code)
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;
@ -8739,7 +8743,7 @@ resolve_lock_unlock (gfc_code *code)
&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;
@ -8751,7 +8755,7 @@ resolve_lock_unlock (gfc_code *code)
&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;
@ -8763,7 +8767,7 @@ resolve_lock_unlock (gfc_code *code)
"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;
}
@ -9700,7 +9704,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
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;
@ -9739,10 +9743,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
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)
@ -9804,7 +9808,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
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;
@ -13563,7 +13567,7 @@ resolve_data_variables (gfc_data_variable *d)
}
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)

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
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>

84
gcc/testsuite/gfortran.dg/do_check_6.f90 Normal file
View File

@ -0,0 +1,84 @@
! { 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