OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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: r208733
This commit is contained in:
Tobias Burnus 2014-03-20 20:42:15 +01:00 committed by Tobias Burnus
parent 0aae659fe2
commit 6d84652499
11 changed files with 128 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
gcc/fortran/ChangeLog
View File

@ -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-09 Janus Weil <janus@gcc.gnu.org>
Backport from 4.8

13
gcc/fortran/decl.c
View File

@ -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;
}

1
gcc/fortran/gfortran.h
View File

@ -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);

5
gcc/fortran/intrinsic.c
View File

@ -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;

33
gcc/fortran/io.c
View File

@ -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;

27
gcc/fortran/match.c
View File

@ -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)

3
gcc/fortran/parse.c
View File

@ -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;

54
gcc/fortran/resolve.c
View File

@ -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

4
gcc/fortran/symbol.c
View File

@ -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)
{

8
gcc/testsuite/ChangeLog
View File

@ -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-18 Richard Biener <rguenther@suse.de>
Backport from mainline
@ -7,7 +13,7 @@
* 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>

22
gcc/testsuite/gfortran.dg/implicit_pure_4.f90 Normal file
View File

@ -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" } }