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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_7-branch@208733
138bc75d-0d04-0410-961f-
82ee72b054a4
+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-09 Janus Weil <janus@gcc.gnu.org>
Backport from 4.8
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)
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;
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);
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;
}
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);
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;
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);
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;
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;
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;
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;
"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)
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;
}
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;
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)
{
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;
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)
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)
{
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)
{
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)
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)
{
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)
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;
}
/* 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 "
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;
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
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);
}
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
&& 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. */
}
+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
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)
{
+2014-03-20 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/60543
+ PR fortran/60283
+ * gfortran.dg/implicit_pure_4.f90: New.
+
2014-03-18 Richard Biener <rguenther@suse.de>
Backport from mainline
* gcc.dg/torture/pr58941.c: New testcase.
2014-03-18 Richard Biener <rguenther@suse.de>
-
+
Backport from mainline
2013-08-27 Richard Biener <rguenther@suse.de>
--- /dev/null
+! { 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" } }