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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@192896 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 25e5f0b..08cac6c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 066ac1e..3491517 100644 (file)
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -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.  */

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 58c5856..a490238 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -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);

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 9ac0fc6..211f304 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -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)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b3224aa..fabc16a 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -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 *);

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 2bdabfe..d90fc73 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -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;
        }

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 6da131d..95a0f50 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -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;
        }
     }

diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 447d03f..bd84f1f 100644 (file)
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -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);

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index ac3021e..e39a137 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 5320b4a..1bd66fa 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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>
 

diff --git a/gcc/testsuite/gfortran.dg/do_check_6.f90 b/gcc/testsuite/gfortran.dg/do_check_6.f90
new file mode 100644 (file)
index 0000000..2e18f21
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_check_6.f90
@@ -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