From: Tobias Burnus Date: Thu, 20 Mar 2014 19:42:15 +0000 (+0100) Subject: re PR fortran/60543 (Function with side effect removed by the optimizer.) X-Git-Tag: releases/gcc-4.7.4~184 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=6d846524992f938ac9c3746350b86c22e1d69185;p=thirdparty%2Fgcc.git re PR fortran/60543 (Function with side effect removed by the optimizer.) 2014-03-20 Tobias Burnus 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 PR fortran/60543 PR fortran/60283 * gfortran.dg/implicit_pure_4.f90: New. From-SVN: r208733 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 928e0397d93e..a56f12043b78 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,24 @@ +2014-03-20 Tobias Burnus + + 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-09 Janus Weil Backport from 4.8 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 3e7c6e618aa9..e86f107d9692 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -509,9 +509,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) @@ -570,9 +568,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; @@ -1730,6 +1726,7 @@ match_pointer_init (gfc_expr **init, int procptr) gfc_error ("Error in pointer initialization at %C"); return MATCH_ERROR; } + gfc_unset_implicit_pure (gfc_current_ns->proc_name); if (!procptr) gfc_resolve_expr (*init); @@ -2015,6 +2012,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/gfortran.h b/gcc/fortran/gfortran.h index 6e1fc780d663..54310dfbea15 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2795,6 +2795,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); gfc_try find_forall_index (gfc_expr *, gfc_symbol *, int); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 38bcb273fdd1..a2666f90e65c 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -4217,13 +4217,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 7caadc5056cd..86f158fdbc95 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -1307,7 +1307,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); @@ -1315,8 +1316,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; @@ -1836,8 +1837,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; @@ -2249,8 +2249,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; @@ -2417,8 +2416,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; @@ -3274,9 +3272,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) @@ -3807,8 +3804,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; } @@ -3966,8 +3962,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; @@ -4020,8 +4015,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) { @@ -4206,8 +4200,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 cb750cf67d21..194fafcb6d35 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1754,8 +1754,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, "Fortran 2008: CRITICAL statement at %C") == FAILURE) @@ -2684,8 +2683,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) { @@ -2825,8 +2823,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) { @@ -3017,8 +3014,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, "Fortran 2008: SYNC statement at %C") == FAILURE) @@ -3493,15 +3489,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) == SUCCESS) diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 5fbddd0e4b6a..7132a937cb3a 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -545,8 +545,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 7a15e9e42d88..514060882d65 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1193,9 +1193,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 " @@ -1203,12 +1204,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; @@ -3203,8 +3200,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 @@ -3269,8 +3265,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); } @@ -9224,7 +9219,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 @@ -9232,11 +9227,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. */ @@ -13288,6 +13283,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 dcf40d9a47f1..52dfb166e48e 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1121,8 +1121,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 451a078c1046..7e77479ca2ff 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2014-03-20 Tobias Burnus + + PR fortran/60543 + PR fortran/60283 + * gfortran.dg/implicit_pure_4.f90: New. + 2014-03-18 Richard Biener Backport from mainline @@ -7,7 +13,7 @@ * gcc.dg/torture/pr58941.c: New testcase. 2014-03-18 Richard Biener - + Backport from mainline 2013-08-27 Richard Biener 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 000000000000..8563dd721087 --- /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" } }