Commit ce96d372 by Thomas Koenig

PR fortran/PR56519

2013-09-02  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/PR56519
	* gfortran.h:  Declare gfc_do_concurrent_flag as extern.
	* resolve.c:  Rename do_concurrent_flag to gfc_do_concurrent_flag
	and make non-static.
	(resolve_function):  Use gfc_do_concurrent_flag instead of
	do_concurrent_flag.
	(pure_subroutine):  Likewise.
	(resolve_code):  Likewise.
	(resolve_types):  Likewise.
	* intrinsic.c (gfc_intrinsic_sub_interface):  Raise error for
	non-pure intrinsic subroutines within DO CONCURRENT.

2013-09-02  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/PR56519
	* gfortran.dg/do_concurrent_3.f90:  New test case.

From-SVN: r202188
parent 07d6cd64
2013-09-02 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/PR56519
* gfortran.h: Declare gfc_do_concurrent_flag as extern.
* resolve.c: Rename do_concurrent_flag to gfc_do_concurrent_flag
and make non-static.
(resolve_function): Use gfc_do_concurrent_flag instead of
do_concurrent_flag.
(pure_subroutine): Likewise.
(resolve_code): Likewise.
(resolve_types): Likewise.
* intrinsic.c (gfc_intrinsic_sub_interface): Raise error for
non-pure intrinsic subroutines within DO CONCURRENT.
2013-08-29 Thomas Koenig <tkoenig@gcc.gnu.org> 2013-08-29 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/52243 PR fortran/52243
......
...@@ -2846,6 +2846,7 @@ gfc_expr *gfc_expr_to_initialize (gfc_expr *); ...@@ -2846,6 +2846,7 @@ gfc_expr *gfc_expr_to_initialize (gfc_expr *);
bool gfc_type_is_extensible (gfc_symbol *); bool gfc_type_is_extensible (gfc_symbol *);
bool gfc_resolve_intrinsic (gfc_symbol *, locus *); bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
bool gfc_explicit_interface_required (gfc_symbol *, char *, int); bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
extern int gfc_do_concurrent_flag;
/* array.c */ /* array.c */
......
...@@ -4397,6 +4397,13 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag) ...@@ -4397,6 +4397,13 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
c->resolved_sym->attr.elemental = isym->elemental; c->resolved_sym->attr.elemental = isym->elemental;
} }
if (gfc_do_concurrent_flag && !isym->pure)
{
gfc_error ("Subroutine call to intrinsic '%s' in DO CONCURRENT "
"block at %L is not PURE", name, &c->loc);
return MATCH_ERROR;
}
if (gfc_pure (NULL) && !isym->pure) if (gfc_pure (NULL) && !isym->pure)
{ {
gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name, gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
......
...@@ -60,7 +60,7 @@ static code_stack *cs_base = NULL; ...@@ -60,7 +60,7 @@ static code_stack *cs_base = NULL;
/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */ /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
static int forall_flag; static int forall_flag;
static int do_concurrent_flag; int gfc_do_concurrent_flag;
/* True when we are resolving an expression that is an actual argument to /* True when we are resolving an expression that is an actual argument to
a procedure. */ a procedure. */
...@@ -2986,11 +2986,11 @@ resolve_function (gfc_expr *expr) ...@@ -2986,11 +2986,11 @@ resolve_function (gfc_expr *expr)
forall_flag == 2 ? "mask" : "block"); forall_flag == 2 ? "mask" : "block");
t = false; t = false;
} }
else if (do_concurrent_flag) else if (gfc_do_concurrent_flag)
{ {
gfc_error ("Reference to non-PURE function '%s' at %L inside a " gfc_error ("Reference to non-PURE function '%s' at %L inside a "
"DO CONCURRENT %s", name, &expr->where, "DO CONCURRENT %s", name, &expr->where,
do_concurrent_flag == 2 ? "mask" : "block"); gfc_do_concurrent_flag == 2 ? "mask" : "block");
t = false; t = false;
} }
else if (gfc_pure (NULL)) else if (gfc_pure (NULL))
...@@ -3059,7 +3059,7 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym) ...@@ -3059,7 +3059,7 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym)
if (forall_flag) if (forall_flag)
gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE", gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
sym->name, &c->loc); sym->name, &c->loc);
else if (do_concurrent_flag) else if (gfc_do_concurrent_flag)
gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not " gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
"PURE", sym->name, &c->loc); "PURE", sym->name, &c->loc);
else if (gfc_pure (NULL)) else if (gfc_pure (NULL))
...@@ -9629,7 +9629,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) ...@@ -9629,7 +9629,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
{ {
frame.current = code; frame.current = code;
forall_save = forall_flag; forall_save = forall_flag;
do_concurrent_save = do_concurrent_flag; do_concurrent_save = gfc_do_concurrent_flag;
if (code->op == EXEC_FORALL) if (code->op == EXEC_FORALL)
{ {
...@@ -9663,9 +9663,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns) ...@@ -9663,9 +9663,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
to transform the SELECT TYPE into ASSOCIATE first. */ to transform the SELECT TYPE into ASSOCIATE first. */
break; break;
case EXEC_DO_CONCURRENT: case EXEC_DO_CONCURRENT:
do_concurrent_flag = 1; gfc_do_concurrent_flag = 1;
gfc_resolve_blocks (code->block, ns); gfc_resolve_blocks (code->block, ns);
do_concurrent_flag = 2; gfc_do_concurrent_flag = 2;
break; break;
case EXEC_OMP_WORKSHARE: case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag; omp_workshare_save = omp_workshare_flag;
...@@ -9684,7 +9684,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) ...@@ -9684,7 +9684,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC) if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
t = gfc_resolve_expr (code->expr1); t = gfc_resolve_expr (code->expr1);
forall_flag = forall_save; forall_flag = forall_save;
do_concurrent_flag = do_concurrent_save; gfc_do_concurrent_flag = do_concurrent_save;
if (!gfc_resolve_expr (code->expr2)) if (!gfc_resolve_expr (code->expr2))
t = false; t = false;
...@@ -14404,7 +14404,7 @@ resolve_types (gfc_namespace *ns) ...@@ -14404,7 +14404,7 @@ resolve_types (gfc_namespace *ns)
} }
forall_flag = 0; forall_flag = 0;
do_concurrent_flag = 0; gfc_do_concurrent_flag = 0;
gfc_check_interfaces (ns); gfc_check_interfaces (ns);
gfc_traverse_ns (ns, resolve_values); gfc_traverse_ns (ns, resolve_values);
......
2013-09-02 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/PR56519
* gfortran.dg/do_concurrent_3.f90: New test case.
2013-09-02 Jan Hubicka <jh@suse.cz> 2013-09-02 Jan Hubicka <jh@suse.cz>
* gcc.dg/tree-ssa/fnsplit-1.c: New testcase. * gcc.dg/tree-ssa/fnsplit-1.c: New testcase.
......
! { dg-do compile }
! PR 56519 - flag impure intrinsic subroutine calls
! within DO CONCURRENT
program main
implicit none
integer :: i
real :: array(123), val
do concurrent (i = 1:123)
call random_number (val) ! { dg-error "is not PURE" }
array(i) = val
end do
end program main
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment