2013-09-02 Thomas Koenig <tkoenig@gcc.gnu.org>

	PR fortran/PR56519
	* gfortran.h:  Declare gfc_do_concurrent_flag as extern.
	* resolve.c:  Rename do_concurrent_flag to gfc_do_concurrent_flag
	and make non-static.
	(resolve_function):  Use gfc_do_concurrent_flag instead of
	do_concurrent_flag.
	(pure_subroutine):  Likewise.
	(resolve_code):  Likewise.
	(resolve_types):  Likewise.
	* intrinsic.c (gfc_intrinsic_sub_interface):  Raise error for
	non-pure intrinsic subroutines within DO CONCURRENT.

2013-09-02  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/PR56519
	* gfortran.dg/do_concurrent_3.f90:  New test case.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5fbe331..2b34517 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2013-09-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/PR56519
+       * gfortran.h:  Declare gfc_do_concurrent_flag as extern.
+       * resolve.c:  Rename do_concurrent_flag to gfc_do_concurrent_flag
+       and make non-static.
+       (resolve_function):  Use gfc_do_concurrent_flag instead of
+       do_concurrent_flag.
+       (pure_subroutine):  Likewise.
+       (resolve_code):  Likewise.
+       (resolve_types):  Likewise.
+       * intrinsic.c (gfc_intrinsic_sub_interface):  Raise error for
+       non-pure intrinsic subroutines within DO CONCURRENT.
+
 2013-08-29  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR fortran/52243

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 691aa8c..b28edd8 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2846,6 +2846,7 @@ gfc_expr *gfc_expr_to_initialize (gfc_expr *);
 bool gfc_type_is_extensible (gfc_symbol *);
 bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
 bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
+extern int gfc_do_concurrent_flag;
 
 
 /* array.c */

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index c2e1525..3da3c53 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -4397,6 +4397,13 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
       c->resolved_sym->attr.elemental = isym->elemental;
     }
 
+  if (gfc_do_concurrent_flag && !isym->pure)
+    {
+      gfc_error ("Subroutine call to intrinsic '%s' in DO CONCURRENT "
+                "block at %L is not PURE", name, &c->loc);
+      return MATCH_ERROR;
+    }
+
   if (gfc_pure (NULL) && !isym->pure)
     {
       gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 067288d..2929679 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -60,7 +60,7 @@ static code_stack *cs_base = NULL;
 /* Nonzero if we're inside a FORALL or DO CONCURRENT block.  */
 
 static int forall_flag;
-static int do_concurrent_flag;
+int gfc_do_concurrent_flag;
 
 /* True when we are resolving an expression that is an actual argument to
    a procedure.  */
@@ -2986,11 +2986,11 @@ resolve_function (gfc_expr *expr)
                     forall_flag == 2 ? "mask" : "block");
          t = false;
        }
-      else if (do_concurrent_flag)
+      else if (gfc_do_concurrent_flag)
        {
          gfc_error ("Reference to non-PURE function '%s' at %L inside a "
                     "DO CONCURRENT %s", name, &expr->where,
-                    do_concurrent_flag == 2 ? "mask" : "block");
+                    gfc_do_concurrent_flag == 2 ? "mask" : "block");
          t = false;
        }
       else if (gfc_pure (NULL))
@@ -3059,7 +3059,7 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym)
   if (forall_flag)
     gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
               sym->name, &c->loc);
-  else if (do_concurrent_flag)
+  else if (gfc_do_concurrent_flag)
     gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
               "PURE", sym->name, &c->loc);
   else if (gfc_pure (NULL))
@@ -9629,7 +9629,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
     {
       frame.current = code;
       forall_save = forall_flag;
-      do_concurrent_save = do_concurrent_flag;
+      do_concurrent_save = gfc_do_concurrent_flag;
 
       if (code->op == EXEC_FORALL)
        {
@@ -9663,9 +9663,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
                 to transform the SELECT TYPE into ASSOCIATE first.  */
              break;
             case EXEC_DO_CONCURRENT:
-             do_concurrent_flag = 1;
+             gfc_do_concurrent_flag = 1;
              gfc_resolve_blocks (code->block, ns);
-             do_concurrent_flag = 2;
+             gfc_do_concurrent_flag = 2;
              break;
            case EXEC_OMP_WORKSHARE:
              omp_workshare_save = omp_workshare_flag;
@@ -9684,7 +9684,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
       if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
        t = gfc_resolve_expr (code->expr1);
       forall_flag = forall_save;
-      do_concurrent_flag = do_concurrent_save;
+      gfc_do_concurrent_flag = do_concurrent_save;
 
       if (!gfc_resolve_expr (code->expr2))
        t = false;
@@ -14404,7 +14404,7 @@ resolve_types (gfc_namespace *ns)
     }
 
   forall_flag = 0;
-  do_concurrent_flag = 0;
+  gfc_do_concurrent_flag = 0;
   gfc_check_interfaces (ns);
 
   gfc_traverse_ns (ns, resolve_values);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c01c48c..db785f7 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2013-09-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/PR56519
+       * gfortran.dg/do_concurrent_3.f90:  New test case.
+
 2013-09-02  Jan Hubicka  <jh@suse.cz>
 
        * gcc.dg/tree-ssa/fnsplit-1.c: New testcase.

diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_3.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_3.f90
new file mode 100644 (file)
index 0000000..09bb0cc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_concurrent_3.f90
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! PR 56519 - flag impure intrinsic subroutine calls
+! within DO CONCURRENT
+program main
+  implicit none
+  integer :: i
+  real :: array(123), val
+
+  do concurrent (i = 1:123)
+     call random_number (val) ! { dg-error "is not PURE" }
+     array(i) = val
+  end do
+end program main