Patchwork [fortran] PR 56519: Reject impure intrinsic subroutines in DO CONCURRENT

login
register
mail settings
Submitter Thomas Koenig
Date Aug. 29, 2013, 10:38 p.m.
Message ID <521FCD72.8020409@netcologne.de>
Download mbox | patch
Permalink /patch/270990/
State New
Headers show

Comments

Thomas Koenig - Aug. 29, 2013, 10:38 p.m.
Hello world,

the attached patch rejects impure subroutines, such as RANDOM_NUMBER,
within DO CONCURRENT.

Regression-tested.  OK for trunk?

Regards

	Thomas

2013-08-29  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/PR56519
        * gfortran.dg/do_concurrent_3.f90:  New test case.
Thomas Koenig - Sept. 2, 2013, 6:34 p.m.
Ping**0.5714 ?


> the attached patch rejects impure subroutines, such as RANDOM_NUMBER,
> within DO CONCURRENT.
> 
> Regression-tested.  OK for trunk?
Tobias Burnus - Sept. 2, 2013, 7:16 p.m.
Thomas Koenig wrote:
> the attached patch rejects impure subroutines, such as RANDOM_NUMBER,
> within DO CONCURRENT.
> Regression-tested.  OK for trunk?

Okay - and thanks for the patch. Unrelated to changes in your patch, I 
am a bit unhappy about:

* Proliferation of global variables
* Magic values (0, 1, 2)
* Badly translatable strings: "… inside a DO CONCURRENT %s", 
…gfc_do_concurrent_flag == 2 ? "mask" : "block"

But as those are unchanged by your patch …

Tobias

> 2013-08-29  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/PR56519
>          * gfortran.dg/do_concurrent_3.f90:  New test case.

Patch

Index: gfortran.h
===================================================================
--- gfortran.h	(Revision 201996)
+++ gfortran.h	(Arbeitskopie)
@@ -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 */
Index: intrinsic.c
===================================================================
--- intrinsic.c	(Revision 201996)
+++ intrinsic.c	(Arbeitskopie)
@@ -4397,6 +4397,13 @@  gfc_intrinsic_sub_interface (gfc_code *c, int erro
       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,
Index: resolve.c
===================================================================
--- resolve.c	(Revision 201996)
+++ resolve.c	(Arbeitskopie)
@@ -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);