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

2014-03-18  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): 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): 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-18  Tobias Burnus  <burnus@net-b.de>

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

From-SVN: r208687

1 files changed, 35 insertions, 13 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index bcdfcad..ac58167 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1328,9 +1328,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 = false;
 	  gfc_error ("Invalid expression in the structure constructor for "
@@ -1338,12 +1339,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;
@@ -3006,8 +3003,7 @@ resolve_function (gfc_expr *expr)
 	  t = false;
 	}
 
-      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
@@ -3072,8 +3068,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);
 }
 
 
@@ -13927,6 +13922,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