re PR fortran/60543 (Function with side effect removed by the optimizer.)

2014-03-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/60543
        PR fortran/60283
        * gfortran.h (gfc_unset_implicit_pure): New prototype.
        * resolve.c (gfc_unset_implicit_pure): New.
        (resolve_structure_cons, resolve_function,
        pure_subroutine, resolve_ordinary_assign): Use it.
        * decl.c (match_old_style_init, gfc_match_data,
        match_pointer_init, variable_decl): Ditto.
        * expr.c (gfc_check_pointer_assign): Ditto.
        * intrinsic.c (gfc_intrinsic_sub_interface): Ditto.
        * io.c (match_vtag, gfc_match_open, gfc_match_close,
        match_filepos, gfc_match_inquire, gfc_match_print,
        gfc_match_wait, check_io_constraints): Ditto.
        * match.c (gfc_match_critical, gfc_match_stopcode,
        lock_unlock_statement, sync_statement, gfc_match_allocate,
        gfc_match_deallocate): Ditto.
        * parse.c (decode_omp_directive): Ditto.
        * symbol.c (gfc_add_save): Ditto.

2014-03-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/60543
        PR fortran/60283
        * gfortran.dg/implicit_pure_4.f90: New.

From-SVN: r208732

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index db89c5ff9b4f2684f79338d3d7836e4dd5dd4e4d..2108402a783bbb8bb23efcdf78d173a5ea813ad1 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,24 @@
+2014-03-20  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/60543
+       PR fortran/60283
+       * gfortran.h (gfc_unset_implicit_pure): New prototype.
+       * resolve.c (gfc_unset_implicit_pure): New.
+       (resolve_structure_cons, resolve_function,
+       pure_subroutine, resolve_ordinary_assign): Use it.
+       * decl.c (match_old_style_init, gfc_match_data,
+       match_pointer_init, variable_decl): Ditto.
+       * expr.c (gfc_check_pointer_assign): Ditto.
+       * intrinsic.c (gfc_intrinsic_sub_interface): Ditto.
+       * io.c (match_vtag, gfc_match_open, gfc_match_close,
+       match_filepos, gfc_match_inquire, gfc_match_print,
+       gfc_match_wait, check_io_constraints): Ditto.
+       * match.c (gfc_match_critical, gfc_match_stopcode,
+       lock_unlock_statement, sync_statement, gfc_match_allocate,
+       gfc_match_deallocate): Ditto.
+       * parse.c (decode_omp_directive): Ditto.
+       * symbol.c (gfc_add_save): Ditto.
+
 2014-03-08  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/60450

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index c6e16c7e366a3e4a348a113936e1b07b2e9a7379..7dec803a36d5f89b894131aeb5a583e496ae2928 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -510,9 +510,7 @@ match_old_style_init (const char *name)
       free (newdata);
       return MATCH_ERROR;
     }
-
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (gfc_current_ns->proc_name);
 
   /* Mark the variable as having appeared in a data statement.  */
   if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
@@ -571,9 +569,7 @@ gfc_match_data (void)
       gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
       return MATCH_ERROR;
     }
-
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (gfc_current_ns->proc_name);
 
   return MATCH_YES;
 
@@ -1737,6 +1733,7 @@ match_pointer_init (gfc_expr **init, int procptr)
                 "a PURE procedure");
       return MATCH_ERROR;
     }
+  gfc_unset_implicit_pure (gfc_current_ns->proc_name);
 
   /* Match NULL() initialization.  */
   m = gfc_match_null (init);
@@ -2045,6 +2042,10 @@ variable_decl (int elem)
              m = MATCH_ERROR;
            }
 
+         if (current_attr.flavor != FL_PARAMETER
+             && gfc_state_stack->state != COMP_DERIVED)
+           gfc_unset_implicit_pure (gfc_current_ns->proc_name);
+
          if (m != MATCH_YES)
            goto cleanup;
        }

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index c3dbd01684c0f19ec309416ec245b84c99c7a470..0e89a4ce98a0033be6916b4bcc9e8b67e962b25e 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3681,8 +3681,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
     }
 
   if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
+    gfc_unset_implicit_pure (gfc_current_ns->proc_name);
 
   if (gfc_has_vector_index (rvalue))
     {

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 18bbf7954c381ef3c39a4dfac42e89d7a82c020d..bd1aeb9ffab80439447cd83a427c38dab8398028 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2830,6 +2830,7 @@ void gfc_resolve_blocks (gfc_code *, gfc_namespace *);
 int gfc_impure_variable (gfc_symbol *);
 int gfc_pure (gfc_symbol *);
 int gfc_implicit_pure (gfc_symbol *);
+void gfc_unset_implicit_pure (gfc_symbol *);
 int gfc_elemental (gfc_symbol *);
 gfc_try gfc_resolve_iterator (gfc_iterator *, bool, bool);
 gfc_try find_forall_index (gfc_expr *, gfc_symbol *, int);

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index c571533ef8f89debc92bfd668d3c7527766c9988..7d78419a76dfd53507863e1d749508163bb88052 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -4229,13 +4229,16 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
       c->resolved_sym->attr.elemental = isym->elemental;
     }
 
-  if (gfc_pure (NULL) && !isym->pure)
+  if (!isym->pure && gfc_pure (NULL))
     {
       gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
                 &c->loc);
       return MATCH_ERROR;
     }
 
+  if (!isym->pure)
+    gfc_unset_implicit_pure (NULL);
+
   c->resolved_sym->attr.noreturn = isym->noreturn;
 
   return MATCH_YES;

diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 748a4f2fbedc5aa0d2fe828622aea9eb3eb3b896..1d464742f5b071292d7b7175a226ade957250b28 100644 (file)
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -1309,7 +1309,8 @@ match_vtag (const io_tag *tag, gfc_expr **v)
       return MATCH_ERROR;
     }
 
-  if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
+  bool impure = gfc_impure_variable (result->symtree->n.sym);
+  if (impure && gfc_pure (NULL))
     {
       gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
                 tag->name);
@@ -1317,8 +1318,8 @@ match_vtag (const io_tag *tag, gfc_expr **v)
       return MATCH_ERROR;
     }
 
-  if (gfc_implicit_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  if (impure)
+    gfc_unset_implicit_pure (NULL);
 
   *v = result;
   return MATCH_YES;
@@ -1838,8 +1839,7 @@ gfc_match_open (void)
       goto cleanup;
     }
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
 
   warn = (open->err || open->iostat) ? true : false;
 
@@ -2251,8 +2251,7 @@ gfc_match_close (void)
       goto cleanup;
     }
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
 
   warn = (close->iostat || close->err) ? true : false;
 
@@ -2419,8 +2418,7 @@ done:
       goto cleanup;
     }
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
 
   new_st.op = op;
   new_st.ext.filepos = fp;
@@ -3276,9 +3274,8 @@ if (condition) \
                     "an internal file in a PURE procedure",
                     io_kind_name (k));
 
-      if (gfc_implicit_pure (NULL) && (k == M_READ || k == M_WRITE))
-       gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
+      if (k == M_READ || k == M_WRITE)
+       gfc_unset_implicit_pure (NULL);
     }
 
   if (k != M_READ)
@@ -3809,8 +3806,7 @@ gfc_match_print (void)
       return MATCH_ERROR;
     }
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
 
   return MATCH_YES;
 }
@@ -3969,8 +3965,7 @@ gfc_match_inquire (void)
          return MATCH_ERROR;
        }
 
-      if (gfc_implicit_pure (NULL))
-       gfc_current_ns->proc_name->attr.implicit_pure = 0;
+      gfc_unset_implicit_pure (NULL);
 
       new_st.block = gfc_get_code ();
       new_st.block->op = EXEC_IOLENGTH;
@@ -4023,8 +4018,7 @@ gfc_match_inquire (void)
       goto cleanup;
     }
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
   
   if (inquire->id != NULL && inquire->pending == NULL)
     {
@@ -4212,8 +4206,7 @@ gfc_match_wait (void)
       goto cleanup;
     }
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
 
   new_st.op = EXEC_WAIT;
   new_st.ext.wait = wait;

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index a320248fe3e8935324dff3a446adcccf2666f266..9827b6c4860531599fac3148dfb25f9276f7832f 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1753,8 +1753,7 @@ gfc_match_critical (void)
       return MATCH_ERROR;
     }
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
 
   if (gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C")
       == FAILURE)
@@ -2683,8 +2682,7 @@ gfc_match_stopcode (gfc_statement st)
       goto cleanup;
     }
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
 
   if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
     {
@@ -2824,8 +2822,7 @@ lock_unlock_statement (gfc_statement st)
       return MATCH_ERROR;
     }
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
 
   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
     {
@@ -3020,8 +3017,7 @@ sync_statement (gfc_statement st)
       return MATCH_ERROR;
     }
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
 
   if (gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C")
       == FAILURE)
@@ -3500,15 +3496,15 @@ gfc_match_allocate (void)
       if (gfc_check_do_variable (tail->expr->symtree))
        goto cleanup;
 
-      if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
+      bool impure = gfc_impure_variable (tail->expr->symtree->n.sym);
+      if (impure && gfc_pure (NULL))
        {
          gfc_error ("Bad allocate-object at %C for a PURE procedure");
          goto cleanup;
        }
 
-      if (gfc_implicit_pure (NULL)
-           && gfc_impure_variable (tail->expr->symtree->n.sym))
-       gfc_current_ns->proc_name->attr.implicit_pure = 0;
+      if (impure)
+       gfc_unset_implicit_pure (NULL);
 
       if (tail->expr->ts.deferred)
        {
@@ -3890,14 +3886,15 @@ gfc_match_deallocate (void)
 
       sym = tail->expr->symtree->n.sym;
 
-      if (gfc_pure (NULL) && gfc_impure_variable (sym))
+      bool impure = gfc_impure_variable (sym);
+      if (impure && gfc_pure (NULL))
        {
          gfc_error ("Illegal allocate-object at %C for a PURE procedure");
          goto cleanup;
        }
 
-      if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
-       gfc_current_ns->proc_name->attr.implicit_pure = 0;
+      if (impure)
+       gfc_unset_implicit_pure (NULL);
 
       if (gfc_is_coarray (tail->expr)
          && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 33d325d8df952bcb656f261e84e0be28de3332fc..f748fe3262e7e7f4ecd721feaf84c0a7fb1bff5f 100644 (file)
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -550,8 +550,7 @@ decode_omp_directive (void)
       return ST_NONE;
     }
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
 
   old_locus = gfc_current_locus;
 

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index eab98ad95d7a2a630f956a1ce92a2b5efb885438..43eb240245e11cc535bef3ac670e7debe2d99f1b 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1259,9 +1259,10 @@ resolve_structure_cons (gfc_expr *expr, int init)
        }
 
       /* F2003, C1272 (3).  */
-      if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
-         && (gfc_impure_variable (cons->expr->symtree->n.sym)
-             || gfc_is_coindexed (cons->expr)))
+      bool impure = cons->expr->expr_type == EXPR_VARIABLE
+                   && (gfc_impure_variable (cons->expr->symtree->n.sym)
+                       || gfc_is_coindexed (cons->expr));
+      if (impure && gfc_pure (NULL))
        {
          t = FAILURE;
          gfc_error ("Invalid expression in the structure constructor for "
@@ -1269,12 +1270,8 @@ resolve_structure_cons (gfc_expr *expr, int init)
                     comp->name, &cons->expr->where);
        }
 
-      if (gfc_implicit_pure (NULL)
-           && cons->expr->expr_type == EXPR_VARIABLE
-           && (gfc_impure_variable (cons->expr->symtree->n.sym)
-               || gfc_is_coindexed (cons->expr)))
-       gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
+      if (impure)
+       gfc_unset_implicit_pure (NULL);
     }
 
   return t;
@@ -3295,8 +3292,7 @@ resolve_function (gfc_expr *expr)
          t = FAILURE;
        }
 
-      if (gfc_implicit_pure (NULL))
-       gfc_current_ns->proc_name->attr.implicit_pure = 0;
+      gfc_unset_implicit_pure (NULL);
     }
 
   /* Functions without the RECURSIVE attribution are not allowed to
@@ -3361,8 +3357,7 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym)
     gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
               &c->loc);
 
-  if (gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  gfc_unset_implicit_pure (NULL);
 }
 
 
@@ -9613,7 +9608,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
       if (lhs->expr_type == EXPR_VARIABLE
            && lhs->symtree->n.sym != gfc_current_ns->proc_name
            && lhs->symtree->n.sym->ns != gfc_current_ns)
-       gfc_current_ns->proc_name->attr.implicit_pure = 0;
+       gfc_unset_implicit_pure (NULL);
 
       if (lhs->ts.type == BT_DERIVED
            && lhs->expr_type == EXPR_VARIABLE
@@ -9621,11 +9616,11 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
            && rhs->expr_type == EXPR_VARIABLE
            && (gfc_impure_variable (rhs->symtree->n.sym)
                || gfc_is_coindexed (rhs)))
-       gfc_current_ns->proc_name->attr.implicit_pure = 0;
+       gfc_unset_implicit_pure (NULL);
 
       /* Fortran 2008, C1283.  */
       if (gfc_is_coindexed (lhs))
-       gfc_current_ns->proc_name->attr.implicit_pure = 0;
+       gfc_unset_implicit_pure (NULL);
     }
 
   /* F03:7.4.1.2.  */
@@ -14390,6 +14385,33 @@ gfc_implicit_pure (gfc_symbol *sym)
 }
 
 
+void
+gfc_unset_implicit_pure (gfc_symbol *sym)
+{
+  gfc_namespace *ns;
+
+  if (sym == NULL)
+    {
+      /* Check if the current procedure is implicit_pure.  Walk up
+        the procedure list until we find a procedure.  */
+      for (ns = gfc_current_ns; ns; ns = ns->parent)
+       {
+         sym = ns->proc_name;
+         if (sym == NULL)
+           return;
+
+         if (sym->attr.flavor == FL_PROCEDURE)
+           break;
+       }
+    }
+
+  if (sym->attr.flavor == FL_PROCEDURE)
+    sym->attr.implicit_pure = 0;
+  else
+    sym->attr.pure = 0;
+}
+
+
 /* Test whether the current procedure is elemental or not.  */
 
 int

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ef4076df3fbcd1818fd45e0fa3fdbde162b31b7c..1b3702f821f52ae840445f8f17ced1d52d439956 100644 (file)
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -1110,8 +1110,8 @@ gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
       return FAILURE;
     }
 
-  if (s == SAVE_EXPLICIT && gfc_implicit_pure (NULL))
-    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+  if (s == SAVE_EXPLICIT)
+    gfc_unset_implicit_pure (NULL);
 
   if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
     {

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c02befd7646759f197cb2da065864ad3c7056f23..c697e439727b2308f9ab832357cba35d1eca3db7 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2014-03-20  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/60543
+       PR fortran/60283
+       * gfortran.dg/implicit_pure_4.f90: New.
+
 2014-03-17  Mikael Pettersson  <mikpelinux@gmail.com>
            Committed by Bill Schmidt  <wschmidt@linux.vnet.ibm.com>
 

diff --git a/gcc/testsuite/gfortran.dg/implicit_pure_4.f90 b/gcc/testsuite/gfortran.dg/implicit_pure_4.f90
new file mode 100644 (file)
index 0000000..8563dd7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/implicit_pure_4.f90
@@ -0,0 +1,22 @@
+! { dg-do compile }
+!
+! PR fortran/60543
+! PR fortran/60283
+!
+module m
+contains
+  REAL(8) FUNCTION random()
+    CALL RANDOM_NUMBER(random)
+  END FUNCTION random
+  REAL(8) FUNCTION random2()
+    block
+      block
+        block
+          CALL RANDOM_NUMBER(random2)
+        end block
+      end block
+    end block
+  END FUNCTION random2
+end module m
+
+! { dg-final { scan-module-absence "m" "IMPLICIT_PURE" } }