mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-02 05:40:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Tobias Burnus 2014-03-19 22:03:14 +01:00 committed by Tobias Burnus
parent 7d092805ba
commit ccd7751b34
12 changed files with 123 additions and 58 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-19 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 Janus Weil <janus@gcc.gnu.org>
PR fortran/55207

13
gcc/fortran/decl.c
View File

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

3
gcc/fortran/expr.c
View File

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

1
gcc/fortran/gfortran.h
View File

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

5
gcc/fortran/intrinsic.c
View File

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

28
gcc/fortran/io.c
View File

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

27
gcc/fortran/match.c
View File

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

3
gcc/fortran/parse.c
View File

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

48
gcc/fortran/resolve.c
View File

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

4
gcc/fortran/symbol.c
View File

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

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2014-03-19 Tobias Burnus <burnus@net-b.de>
PR fortran/60543
PR fortran/60283
* gfortran.dg/implicit_pure_4.f90: New.
2014-03-19 Paolo Carlini <paolo.carlini@oracle.com>
PR c++/51474

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