Commit 8c6a85e3 by Tobias Burnus Committed by Tobias Burnus

re PR fortran/44646 ([F08] Implement DO CONCURRENT)

gcc/fortran/
2011-09-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/44646
        * decl.c (gfc_match_entry, gfc_match_end): Handle
        * COMP_DO_CONCURRENT.
        * dump-parse-tree.c (show_code_node): Handle EXEC_DO_CONCURRENT.
        * gfortran.h (gfc_exec_op): Add EXEC_DO_CONCURRENT.
        * match.c (gfc_match_critical, match_exit_cycle,
        * gfc_match_stopcode,
        lock_unlock_statement, sync_statement, gfc_match_allocate,
        gfc_match_deallocate, gfc_match_return): Add DO CONCURRENT diagnostic.
        (gfc_match_do): Match DO CONCURRENT.
        (match_derived_type_spec, match_type_spec, gfc_free_forall_iterator,
        match_forall_iterator, match_forall_header, match_simple_forall,
        gfc_match_forall): Move up in the file.
        * parse.c (check_do_closure, parse_do_block): Handle do
        * concurrent.
        * parse.h (gfc_compile_state): Add COMP_DO_CONCURRENT.
        * resolve.c (do_concurrent_flag): New global variable.
        (resolve_function, pure_subroutine, resolve_branch,
        gfc_resolve_blocks, resolve_code, resolve_types): Add do concurrent
        diagnostic.
        * st.c (gfc_free_statement): Handle EXEC_DO_CONCURRENT.
        * trans-stmt.c (gfc_trans_do_concurrent): New function.
        (gfc_trans_forall_1): Handle do concurrent.
        * trans-stmt.h (gfc_trans_do_concurrent): New function
        * prototype.
        * trans.c (trans_code): Call it.
        * frontend-passes.c (gfc_code_walker): Handle
        * EXEC_DO_CONCURRENT.

gcc/testsuite/
2011-09-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/44646
        * gfortran.dg/do_concurrent_1.f90: New.
        * gfortran.dg/do_concurrent_2.f90: New.

From-SVN: r178677
parent 1542d97a
2011-09-08 Tobias Burnus <burnus@net-b.de>
PR fortran/44646
* decl.c (gfc_match_entry, gfc_match_end): Handle COMP_DO_CONCURRENT.
* dump-parse-tree.c (show_code_node): Handle EXEC_DO_CONCURRENT.
* gfortran.h (gfc_exec_op): Add EXEC_DO_CONCURRENT.
* match.c (gfc_match_critical, match_exit_cycle, gfc_match_stopcode,
lock_unlock_statement, sync_statement, gfc_match_allocate,
gfc_match_deallocate, gfc_match_return): Add DO CONCURRENT diagnostic.
(gfc_match_do): Match DO CONCURRENT.
(match_derived_type_spec, match_type_spec, gfc_free_forall_iterator,
match_forall_iterator, match_forall_header, match_simple_forall,
gfc_match_forall): Move up in the file.
* parse.c (check_do_closure, parse_do_block): Handle do concurrent.
* parse.h (gfc_compile_state): Add COMP_DO_CONCURRENT.
* resolve.c (do_concurrent_flag): New global variable.
(resolve_function, pure_subroutine, resolve_branch,
gfc_resolve_blocks, resolve_code, resolve_types): Add do concurrent
diagnostic.
* st.c (gfc_free_statement): Handle EXEC_DO_CONCURRENT.
* trans-stmt.c (gfc_trans_do_concurrent): New function.
(gfc_trans_forall_1): Handle do concurrent.
* trans-stmt.h (gfc_trans_do_concurrent): New function prototype.
* trans.c (trans_code): Call it.
* frontend-passes.c (gfc_code_walker): Handle EXEC_DO_CONCURRENT.
2011-09-07 Janus Weil <janus@gcc.gnu.org> 2011-09-07 Janus Weil <janus@gcc.gnu.org>
PR fortran/48095 PR fortran/48095
......
...@@ -5248,6 +5248,7 @@ gfc_match_entry (void) ...@@ -5248,6 +5248,7 @@ gfc_match_entry (void)
"an IF-THEN block"); "an IF-THEN block");
break; break;
case COMP_DO: case COMP_DO:
case COMP_DO_CONCURRENT:
gfc_error ("ENTRY statement at %C cannot appear within " gfc_error ("ENTRY statement at %C cannot appear within "
"a DO block"); "a DO block");
break; break;
...@@ -5853,6 +5854,7 @@ gfc_match_end (gfc_statement *st) ...@@ -5853,6 +5854,7 @@ gfc_match_end (gfc_statement *st)
break; break;
case COMP_DO: case COMP_DO:
case COMP_DO_CONCURRENT:
*st = ST_ENDDO; *st = ST_ENDDO;
target = " do"; target = " do";
eos_ok = 0; eos_ok = 0;
......
...@@ -1611,6 +1611,28 @@ show_code_node (int level, gfc_code *c) ...@@ -1611,6 +1611,28 @@ show_code_node (int level, gfc_code *c)
fputs ("END DO", dumpfile); fputs ("END DO", dumpfile);
break; break;
case EXEC_DO_CONCURRENT:
fputs ("DO CONCURRENT ", dumpfile);
for (fa = c->ext.forall_iterator; fa; fa = fa->next)
{
show_expr (fa->var);
fputc (' ', dumpfile);
show_expr (fa->start);
fputc (':', dumpfile);
show_expr (fa->end);
fputc (':', dumpfile);
show_expr (fa->stride);
if (fa->next != NULL)
fputc (',', dumpfile);
}
show_expr (c->expr1);
show_code (level + 1, c->block->next);
code_indent (level, c->label1);
fputs ("END DO", dumpfile);
break;
case EXEC_DO_WHILE: case EXEC_DO_WHILE:
fputs ("DO WHILE ", dumpfile); fputs ("DO WHILE ", dumpfile);
show_expr (c->expr1); show_expr (c->expr1);
......
...@@ -1103,6 +1103,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, ...@@ -1103,6 +1103,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
} }
case EXEC_FORALL: case EXEC_FORALL:
case EXEC_DO_CONCURRENT:
{ {
gfc_forall_iterator *fa; gfc_forall_iterator *fa;
for (fa = co->ext.forall_iterator; fa; fa = fa->next) for (fa = co->ext.forall_iterator; fa; fa = fa->next)
......
...@@ -2052,10 +2052,10 @@ typedef enum ...@@ -2052,10 +2052,10 @@ typedef enum
EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_CRITICAL, EXEC_ERROR_STOP, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_CRITICAL, EXEC_ERROR_STOP,
EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN, EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN, EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK, EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_CONCURRENT, EXEC_DO_WHILE,
EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC, EXEC_SELECT, EXEC_BLOCK, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE, EXEC_SELECT_TYPE, EXEC_CALL_PPC, EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE,
EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES, EXEC_SELECT_TYPE, EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES,
EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT, EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
......
This source diff could not be displayed because it is too large. You can view the blob instead.
...@@ -3154,7 +3154,7 @@ check_do_closure (void) ...@@ -3154,7 +3154,7 @@ check_do_closure (void)
return 0; return 0;
for (p = gfc_state_stack; p; p = p->previous) for (p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_DO) if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
break; break;
if (p == NULL) if (p == NULL)
...@@ -3172,7 +3172,8 @@ check_do_closure (void) ...@@ -3172,7 +3172,8 @@ check_do_closure (void)
/* At this point, the label doesn't terminate the innermost loop. /* At this point, the label doesn't terminate the innermost loop.
Make sure it doesn't terminate another one. */ Make sure it doesn't terminate another one. */
for (; p; p = p->previous) for (; p; p = p->previous)
if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label) if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
&& p->ext.end_do_label == gfc_statement_label)
{ {
gfc_error ("End of nonblock DO statement at %C is interwoven " gfc_error ("End of nonblock DO statement at %C is interwoven "
"with another DO loop"); "with another DO loop");
...@@ -3387,7 +3388,9 @@ parse_do_block (void) ...@@ -3387,7 +3388,9 @@ parse_do_block (void)
gfc_code *top; gfc_code *top;
gfc_state_data s; gfc_state_data s;
gfc_symtree *stree; gfc_symtree *stree;
gfc_exec_op do_op;
do_op = new_st.op;
s.ext.end_do_label = new_st.label1; s.ext.end_do_label = new_st.label1;
if (new_st.ext.iterator != NULL) if (new_st.ext.iterator != NULL)
...@@ -3398,7 +3401,8 @@ parse_do_block (void) ...@@ -3398,7 +3401,8 @@ parse_do_block (void)
accept_statement (ST_DO); accept_statement (ST_DO);
top = gfc_state_stack->tail; top = gfc_state_stack->tail;
push_state (&s, COMP_DO, gfc_new_block); push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
gfc_new_block);
s.do_variable = stree; s.do_variable = stree;
......
...@@ -30,7 +30,7 @@ typedef enum ...@@ -30,7 +30,7 @@ typedef enum
COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
COMP_BLOCK, COMP_ASSOCIATE, COMP_IF, COMP_BLOCK, COMP_ASSOCIATE, COMP_IF,
COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT
} }
gfc_compile_state; gfc_compile_state;
......
...@@ -58,9 +58,10 @@ code_stack; ...@@ -58,9 +58,10 @@ code_stack;
static code_stack *cs_base = NULL; static code_stack *cs_base = NULL;
/* Nonzero if we're inside a FORALL 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;
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
...@@ -3159,11 +3160,18 @@ resolve_function (gfc_expr *expr) ...@@ -3159,11 +3160,18 @@ resolve_function (gfc_expr *expr)
{ {
if (forall_flag) if (forall_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 "
"FORALL %s", name, &expr->where, "FORALL %s", name, &expr->where,
forall_flag == 2 ? "mask" : "block"); forall_flag == 2 ? "mask" : "block");
t = FAILURE; t = FAILURE;
} }
else if (do_concurrent_flag)
{
gfc_error ("Reference to non-PURE function '%s' at %L inside a "
"DO CONCURRENT %s", name, &expr->where,
do_concurrent_flag == 2 ? "mask" : "block");
t = FAILURE;
}
else if (gfc_pure (NULL)) else if (gfc_pure (NULL))
{ {
gfc_error ("Function reference to '%s' at %L is to a non-PURE " gfc_error ("Function reference to '%s' at %L is to a non-PURE "
...@@ -3230,6 +3238,9 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym) ...@@ -3230,6 +3238,9 @@ 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)
gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
"PURE", sym->name, &c->loc);
else if (gfc_pure (NULL)) else if (gfc_pure (NULL))
gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name, gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
&c->loc); &c->loc);
...@@ -8385,10 +8396,16 @@ resolve_branch (gfc_st_label *label, gfc_code *code) ...@@ -8385,10 +8396,16 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
whether the label is still visible outside of the CRITICAL block, whether the label is still visible outside of the CRITICAL block,
which is invalid. */ which is invalid. */
for (stack = cs_base; stack; stack = stack->prev) for (stack = cs_base; stack; stack = stack->prev)
if (stack->current->op == EXEC_CRITICAL {
&& bitmap_bit_p (stack->reachable_labels, label->value)) if (stack->current->op == EXEC_CRITICAL
gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" && bitmap_bit_p (stack->reachable_labels, label->value))
" at %L", &code->loc, &label->where); gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
"label at %L", &code->loc, &label->where);
else if (stack->current->op == EXEC_DO_CONCURRENT
&& bitmap_bit_p (stack->reachable_labels, label->value))
gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
"for label at %L", &code->loc, &label->where);
}
return; return;
} }
...@@ -8409,6 +8426,12 @@ resolve_branch (gfc_st_label *label, gfc_code *code) ...@@ -8409,6 +8426,12 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
" at %L", &code->loc, &label->where); " at %L", &code->loc, &label->where);
return; return;
} }
else if (stack->current->op == EXEC_DO_CONCURRENT)
{
gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
"label at %L", &code->loc, &label->where);
return;
}
} }
if (stack) if (stack)
...@@ -8832,6 +8855,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) ...@@ -8832,6 +8855,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_FORALL: case EXEC_FORALL:
case EXEC_DO: case EXEC_DO:
case EXEC_DO_WHILE: case EXEC_DO_WHILE:
case EXEC_DO_CONCURRENT:
case EXEC_CRITICAL: case EXEC_CRITICAL:
case EXEC_READ: case EXEC_READ:
case EXEC_WRITE: case EXEC_WRITE:
...@@ -9071,7 +9095,7 @@ static void ...@@ -9071,7 +9095,7 @@ static void
resolve_code (gfc_code *code, gfc_namespace *ns) resolve_code (gfc_code *code, gfc_namespace *ns)
{ {
int omp_workshare_save; int omp_workshare_save;
int forall_save; int forall_save, do_concurrent_save;
code_stack frame; code_stack frame;
gfc_try t; gfc_try t;
...@@ -9085,6 +9109,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) ...@@ -9085,6 +9109,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;
if (code->op == EXEC_FORALL) if (code->op == EXEC_FORALL)
{ {
...@@ -9117,6 +9142,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) ...@@ -9117,6 +9142,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
/* Blocks are handled in resolve_select_type because we have /* Blocks are handled in resolve_select_type because we have
to transform the SELECT TYPE into ASSOCIATE first. */ to transform the SELECT TYPE into ASSOCIATE first. */
break; break;
case EXEC_DO_CONCURRENT:
do_concurrent_flag = 1;
gfc_resolve_blocks (code->block, ns);
do_concurrent_flag = 2;
break;
case EXEC_OMP_WORKSHARE: case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag; omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 1; omp_workshare_flag = 1;
...@@ -9134,6 +9164,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) ...@@ -9134,6 +9164,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;
if (gfc_resolve_expr (code->expr2) == FAILURE) if (gfc_resolve_expr (code->expr2) == FAILURE)
t = FAILURE; t = FAILURE;
...@@ -9401,6 +9432,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) ...@@ -9401,6 +9432,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
resolve_transfer (code); resolve_transfer (code);
break; break;
case EXEC_DO_CONCURRENT:
case EXEC_FORALL: case EXEC_FORALL:
resolve_forall_iterators (code->ext.forall_iterator); resolve_forall_iterators (code->ext.forall_iterator);
...@@ -13570,6 +13602,7 @@ resolve_types (gfc_namespace *ns) ...@@ -13570,6 +13602,7 @@ resolve_types (gfc_namespace *ns)
} }
forall_flag = 0; forall_flag = 0;
do_concurrent_flag = 0;
gfc_check_interfaces (ns); gfc_check_interfaces (ns);
gfc_traverse_ns (ns, resolve_values); gfc_traverse_ns (ns, resolve_values);
......
...@@ -178,6 +178,7 @@ gfc_free_statement (gfc_code *p) ...@@ -178,6 +178,7 @@ gfc_free_statement (gfc_code *p)
be freed. */ be freed. */
break; break;
case EXEC_DO_CONCURRENT:
case EXEC_FORALL: case EXEC_FORALL:
gfc_free_forall_iterator (p->ext.forall_iterator); gfc_free_forall_iterator (p->ext.forall_iterator);
break; break;
......
...@@ -3514,6 +3514,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) ...@@ -3514,6 +3514,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
tree maskindex; tree maskindex;
tree mask; tree mask;
tree pmask; tree pmask;
tree cycle_label = NULL_TREE;
int n; int n;
int nvar; int nvar;
int need_temp; int need_temp;
...@@ -3703,6 +3704,26 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) ...@@ -3703,6 +3704,26 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
} }
if (code->op == EXEC_DO_CONCURRENT)
{
gfc_init_block (&body);
cycle_label = gfc_build_label_decl (NULL_TREE);
code->cycle_label = cycle_label;
tmp = gfc_trans_code (code->block->next);
gfc_add_expr_to_block (&body, tmp);
if (TREE_USED (cycle_label))
{
tmp = build1_v (LABEL_EXPR, cycle_label);
gfc_add_expr_to_block (&body, tmp);
}
tmp = gfc_finish_block (&body);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
gfc_add_expr_to_block (&block, tmp);
goto done;
}
c = code->block->next; c = code->block->next;
/* TODO: loop merging in FORALL statements. */ /* TODO: loop merging in FORALL statements. */
...@@ -3783,6 +3804,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) ...@@ -3783,6 +3804,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
c = c->next; c = c->next;
} }
done:
/* Restore the original index variables. */ /* Restore the original index variables. */
for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
...@@ -3829,6 +3851,14 @@ tree gfc_trans_forall (gfc_code * code) ...@@ -3829,6 +3851,14 @@ tree gfc_trans_forall (gfc_code * code)
} }
/* Translate the DO CONCURRENT construct. */
tree gfc_trans_do_concurrent (gfc_code * code)
{
return gfc_trans_forall_1 (code, NULL);
}
/* Evaluate the WHERE mask expression, copy its value to a temporary. /* Evaluate the WHERE mask expression, copy its value to a temporary.
If the WHERE construct is nested in FORALL, compute the overall temporary If the WHERE construct is nested in FORALL, compute the overall temporary
needed by the WHERE mask expression multiplied by the iterator number of needed by the WHERE mask expression multiplied by the iterator number of
......
...@@ -51,6 +51,7 @@ tree gfc_trans_if (gfc_code *); ...@@ -51,6 +51,7 @@ tree gfc_trans_if (gfc_code *);
tree gfc_trans_arithmetic_if (gfc_code *); tree gfc_trans_arithmetic_if (gfc_code *);
tree gfc_trans_block_construct (gfc_code *); tree gfc_trans_block_construct (gfc_code *);
tree gfc_trans_do (gfc_code *, tree); tree gfc_trans_do (gfc_code *, tree);
tree gfc_trans_do_concurrent (gfc_code *);
tree gfc_trans_do_while (gfc_code *); tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (gfc_code *); tree gfc_trans_select (gfc_code *);
tree gfc_trans_sync (gfc_code *, gfc_exec_op); tree gfc_trans_sync (gfc_code *, gfc_exec_op);
......
...@@ -1303,6 +1303,10 @@ trans_code (gfc_code * code, tree cond) ...@@ -1303,6 +1303,10 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_do (code, cond); res = gfc_trans_do (code, cond);
break; break;
case EXEC_DO_CONCURRENT:
res = gfc_trans_do_concurrent (code);
break;
case EXEC_DO_WHILE: case EXEC_DO_WHILE:
res = gfc_trans_do_while (code); res = gfc_trans_do_while (code);
break; break;
......
2011-09-08 Tobias Burnus <burnus@net-b.de>
PR fortran/44646
* gfortran.dg/do_concurrent_1.f90: New.
* gfortran.dg/do_concurrent_2.f90: New.
2011-09-08 Jakub Jelinek <jakub@redhat.com> 2011-09-08 Jakub Jelinek <jakub@redhat.com>
PR target/50310 PR target/50310
......
! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
! PR fortran/44646
!
! DO CONCURRENT
!
implicit none
integer :: i, j
outer: do, concurrent ( i = 1 : 4)
do j = 1, 5
if (j == 1) cycle ! OK
cycle outer ! OK: C821 FIXME
exit outer ! { dg-error "EXIT statement at .1. leaves DO CONCURRENT construct" }
end do
end do outer
do concurrent (j = 1:5)
cycle ! OK
end do
outer2: do j = 1, 7
do concurrent (j=1:5:2) ! cycle outer2 - bad: C821
cycle outer2 ! { dg-error "leaves DO CONCURRENT construct" }
end do
end do outer2
do concurrent ( i = 1 : 4)
exit ! { dg-error "EXIT statement at .1. leaves DO CONCURRENT construct" }
end do
end
subroutine foo()
do concurrent ( i = 1 : 4)
return ! { dg-error "Image control statement RETURN" }
sync all ! { dg-error "Image control statement SYNC" }
call test () ! { dg-error "Subroutine call to .test. in DO CONCURRENT block at .1. is not PURE" }
stop ! { dg-error "Image control statement STOP" }
end do
do concurrent ( i = 1 : 4)
critical ! { dg-error "Image control statement CRITICAL at .1. in DO CONCURRENT block" }
print *, i
! end critical
end do
critical
do concurrent ( i = 1 : 4) ! OK
end do
end critical
end
subroutine caf()
use iso_fortran_env
implicit none
type(lock_type), allocatable :: lock[:]
integer :: i
do, concurrent (i = 1:3)
allocate (lock[*]) ! { dg-error "ALLOCATE of coarray at .1. in DO CONCURRENT block" }
lock(lock) ! { dg-error "Image control statement LOCK" }
unlock(lock) ! { dg-error "Image control statement UNLOCK" }
deallocate (lock) ! { dg-error "DEALLOCATE of coarray at .1. in DO CONCURRENT block" }
end do
critical
allocate (lock[*]) ! { dg-error "ALLOCATE of coarray at .1. in CRITICAL block" }
lock(lock) ! { dg-error "Image control statement LOCK" }
unlock(lock) ! { dg-error "Image control statement UNLOCK" }
deallocate (lock) ! { dg-error "DEALLOCATE of coarray at .1. in CRITICAL block" }
end critical
end subroutine caf
! { dg-do run }
!
! PR fortran/44646
!
! DO CONCURRENT
!
implicit none
integer :: i, j
integer :: A(5,5)
A = 0.0
do concurrent (i=1:5, j=1:5, (i/=j))
if (i == 5) cycle
A(i,j) = i*j
end do
if (any (A(:,1) /= [0, 2, 3, 4, 0])) call abort()
if (any (A(:,2) /= [2, 0, 6, 8, 0])) call abort()
if (any (A(:,3) /= [3, 6, 0, 12, 0])) call abort()
if (any (A(:,4) /= [4, 8, 12, 0, 0])) call abort()
if (any (A(:,5) /= [5, 10, 15, 20, 0])) call abort()
A = -99
do concurrent (i = 1 : 5)
forall (j=1:4, i/=j)
A(i,j) = i*j
end forall
if (i == 5) then
A(i,i) = -i
end if
end do
if (any (A(:,1) /= [-99, 2, 3, 4, 5])) call abort ()
if (any (A(:,2) /= [ 2, -99, 6, 8, 10])) call abort ()
if (any (A(:,3) /= [ 3, 6, -99, 12, 15])) call abort ()
if (any (A(:,4) /= [ 4, 8, 12, -99, 20])) call abort ()
if (any (A(:,5) /= [-99, -99, -99, -99, -5])) call abort ()
end
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