This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, Fortran] PRs 60283/60543: Fix two wrong-code bugs related for implicit pure
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc-patches <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>
- Date: Sun, 16 Mar 2014 20:21:31 +0100
- Subject: [Patch, Fortran] PRs 60283/60543: Fix two wrong-code bugs related for implicit pure
- Authentication-results: sourceware.org; auth=none
This patch fixes two issues, where gfortran claims that a function is
implicit pure, but it is not. That will cause a wrong-code optimization
in the middle end.
First problem, cf. PR60543, is that implicit pure was not set to 0 for
calls to impure intrinsic subroutines. (BTW: There are no impure
intrinsic functions.) Example:
module m
contains
REAL(8) FUNCTION random()
CALL RANDOM_NUMBER(random)
END FUNCTION random
end module m
The second problem pops up if one adds a BLOCK ... END BLOCK around the
random_number call after applying the patch of the PR, which just does:
gfc_current_ns->proc_name->attr.implicit_pure = 0.
The problem is that one sets only the implicit_pure of the block to 0
and not of the function. That's the reason that the patch became much
longer and that I added gfc_unset_implicit_pure as new function.
Thus, the suspicion I had when reviewing the OpenACC patches turned out
to be founded. Cf. PR60283.
Build and regtested on x86-64-gnu-linux.
OK for the trunk and for the 4.7 and 4.8 branches?
Note: I failed to create a test case.
Tobias
2014-03-16 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-16 Tobias Burnus <burnus@net-b.de>
PR fortran/60543
PR fortran/60283
* gfortran.dg/implicit_pure_4.f90: New.
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index c7f5eed..11cded1 100644
--- 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))
@@ -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;
@@ -1739,6 +1735,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);
@@ -2046,6 +2043,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 fe92c53..f677204 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3704,8 +3704,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 cd2a913..14c202d 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2837,6 +2837,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 *);
bool gfc_resolve_iterator (gfc_iterator *, bool, bool);
bool find_forall_index (gfc_expr *, gfc_symbol *, int);
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 3db000b..19d4620 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -4404,13 +4404,16 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
return MATCH_ERROR;
}
- 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 f2593b0..8d3dc46 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -1305,7 +1305,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);
@@ -1313,8 +1314,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;
@@ -1829,8 +1830,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;
@@ -2242,8 +2242,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;
@@ -2410,8 +2409,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;
@@ -3793,8 +3791,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;
}
@@ -3953,8 +3950,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 (EXEC_IOLENGTH);
terminate_io (code);
@@ -4006,8 +4002,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)
{
@@ -4195,8 +4190,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 171774c..4c46094 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1751,8 +1751,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"))
return MATCH_ERROR;
@@ -2676,8 +2675,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))
{
@@ -2814,8 +2812,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)
{
@@ -3008,8 +3005,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"))
return MATCH_ERROR;
@@ -3479,15 +3475,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)
{
@@ -3868,14 +3864,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))
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index d9af60e..0faf47a 100644
--- 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 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
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 6666872..19d792e 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -1114,8 +1114,8 @@ gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
return false;
}
- 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/gfortran.dg/implicit_pure_4.f90 b/gcc/testsuite/gfortran.dg/implicit_pure_4.f90
new file mode 100644
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" } }