From patchwork Mon Sep 5 16:11:47 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 113389 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id D0D36B6F77 for ; Tue, 6 Sep 2011 02:12:38 +1000 (EST) Received: (qmail 12982 invoked by alias); 5 Sep 2011 16:12:25 -0000 Received: (qmail 12962 invoked by uid 22791); 5 Sep 2011 16:12:19 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 05 Sep 2011 16:11:50 +0000 Received: from [192.168.178.22] (port-92-204-66-235.dynamic.qsc.de [92.204.66.235]) by mx01.qsc.de (Postfix) with ESMTP id 29AE43CBB2; Mon, 5 Sep 2011 18:11:47 +0200 (CEST) Message-ID: <4E64F4C3.6030406@net-b.de> Date: Mon, 05 Sep 2011 18:11:47 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:6.0) Gecko/20110812 Thunderbird/6.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: Re: [Patch, Fortran] PR44646 - Add parser support for DO CONCURRENT References: <4E62226E.7080502@net-b.de> In-Reply-To: <4E62226E.7080502@net-b.de> Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org On 09/03/2011 02:49 PM, Tobias Burnus wrote: > This patch implements the parsing/diagnostic for "DO[,] CONCURRENT > for-all-header", e.g. > do concurrent (i = 1:5) > A(i) = B(i) > end do (Side remark: do concurrent also supports a logical mask expression as FORALL does.) I have attached an updated version, which actually implements do concurrent in trans-stmt.c. Additionally, "CYCLE" without a label did not work. > Build and regtested on x86-64-linux. > OK for the trunk? Tobias 2011-09-06 Tobias Burnus 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. 2011-09-06 Tobias Burnus PR fortran/44646 * gfortran.dg/do_concurrent_1.f90: New. * gfortran.dg/do_concurrent_2.f90: New. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 18e2651..0ee2575 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -5248,6 +5248,7 @@ gfc_match_entry (void) "an IF-THEN block"); break; case COMP_DO: + case COMP_DO_CONCURRENT: gfc_error ("ENTRY statement at %C cannot appear within " "a DO block"); break; @@ -5853,6 +5854,7 @@ gfc_match_end (gfc_statement *st) break; case COMP_DO: + case COMP_DO_CONCURRENT: *st = ST_ENDDO; target = " do"; eos_ok = 0; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index ad8b554..af2cd85 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1611,6 +1611,28 @@ show_code_node (int level, gfc_code *c) fputs ("END DO", dumpfile); 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: fputs ("DO WHILE ", dumpfile); show_expr (c->expr1); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ac36d24..54e0b20 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2052,10 +2052,10 @@ typedef enum EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_CRITICAL, EXEC_ERROR_STOP, EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN, 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_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC, - EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE, EXEC_SELECT_TYPE, - EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES, + EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_CONCURRENT, EXEC_DO_WHILE, + EXEC_SELECT, EXEC_BLOCK, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, + EXEC_CALL_PPC, EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE, + EXEC_SELECT_TYPE, EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES, EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT, EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 43aeb19..4ea98b6 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1748,6 +1748,13 @@ gfc_match_critical (void) return MATCH_ERROR; } + if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) + { + gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT " + "block"); + return MATCH_ERROR; + } + if (gfc_implicit_pure (NULL)) gfc_current_ns->proc_name->attr.implicit_pure = 0; @@ -1893,6 +1900,436 @@ error: } +/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of + an accessible derived type. */ + +static match +match_derived_type_spec (gfc_typespec *ts) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus old_locus; + gfc_symbol *derived; + + old_locus = gfc_current_locus; + + if (gfc_match ("%n", name) != MATCH_YES) + { + gfc_current_locus = old_locus; + return MATCH_NO; + } + + gfc_find_symbol (name, NULL, 1, &derived); + + if (derived && derived->attr.flavor == FL_DERIVED) + { + ts->type = BT_DERIVED; + ts->u.derived = derived; + return MATCH_YES; + } + + gfc_current_locus = old_locus; + return MATCH_NO; +} + + +/* Match a Fortran 2003 type-spec (F03:R401). This is similar to + gfc_match_decl_type_spec() from decl.c, with the following exceptions: + It only includes the intrinsic types from the Fortran 2003 standard + (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally, + the implicit_flag is not needed, so it was removed. Derived types are + identified by their name alone. */ + +static match +match_type_spec (gfc_typespec *ts) +{ + match m; + locus old_locus; + + gfc_clear_ts (ts); + gfc_gobble_whitespace (); + old_locus = gfc_current_locus; + + if (match_derived_type_spec (ts) == MATCH_YES) + { + /* Enforce F03:C401. */ + if (ts->u.derived->attr.abstract) + { + gfc_error ("Derived type '%s' at %L may not be ABSTRACT", + ts->u.derived->name, &old_locus); + return MATCH_ERROR; + } + return MATCH_YES; + } + + if (gfc_match ("integer") == MATCH_YES) + { + ts->type = BT_INTEGER; + ts->kind = gfc_default_integer_kind; + goto kind_selector; + } + + if (gfc_match ("real") == MATCH_YES) + { + ts->type = BT_REAL; + ts->kind = gfc_default_real_kind; + goto kind_selector; + } + + if (gfc_match ("double precision") == MATCH_YES) + { + ts->type = BT_REAL; + ts->kind = gfc_default_double_kind; + return MATCH_YES; + } + + if (gfc_match ("complex") == MATCH_YES) + { + ts->type = BT_COMPLEX; + ts->kind = gfc_default_complex_kind; + goto kind_selector; + } + + if (gfc_match ("character") == MATCH_YES) + { + ts->type = BT_CHARACTER; + + m = gfc_match_char_spec (ts); + + if (m == MATCH_NO) + m = MATCH_YES; + + return m; + } + + if (gfc_match ("logical") == MATCH_YES) + { + ts->type = BT_LOGICAL; + ts->kind = gfc_default_logical_kind; + goto kind_selector; + } + + /* If a type is not matched, simply return MATCH_NO. */ + gfc_current_locus = old_locus; + return MATCH_NO; + +kind_selector: + + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () == '*') + { + gfc_error ("Invalid type-spec at %C"); + return MATCH_ERROR; + } + + m = gfc_match_kind_spec (ts, false); + + if (m == MATCH_NO) + m = MATCH_YES; /* No kind specifier found. */ + + return m; +} + + +/******************** FORALL subroutines ********************/ + +/* Free a list of FORALL iterators. */ + +void +gfc_free_forall_iterator (gfc_forall_iterator *iter) +{ + gfc_forall_iterator *next; + + while (iter) + { + next = iter->next; + gfc_free_expr (iter->var); + gfc_free_expr (iter->start); + gfc_free_expr (iter->end); + gfc_free_expr (iter->stride); + free (iter); + iter = next; + } +} + + +/* Match an iterator as part of a FORALL statement. The format is: + + = :[:] + + On MATCH_NO, the caller tests for the possibility that there is a + scalar mask expression. */ + +static match +match_forall_iterator (gfc_forall_iterator **result) +{ + gfc_forall_iterator *iter; + locus where; + match m; + + where = gfc_current_locus; + iter = XCNEW (gfc_forall_iterator); + + m = gfc_match_expr (&iter->var); + if (m != MATCH_YES) + goto cleanup; + + if (gfc_match_char ('=') != MATCH_YES + || iter->var->expr_type != EXPR_VARIABLE) + { + m = MATCH_NO; + goto cleanup; + } + + m = gfc_match_expr (&iter->start); + if (m != MATCH_YES) + goto cleanup; + + if (gfc_match_char (':') != MATCH_YES) + goto syntax; + + m = gfc_match_expr (&iter->end); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (':') == MATCH_NO) + iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + else + { + m = gfc_match_expr (&iter->stride); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + + /* Mark the iteration variable's symbol as used as a FORALL index. */ + iter->var->symtree->n.sym->forall_index = true; + + *result = iter; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in FORALL iterator at %C"); + m = MATCH_ERROR; + +cleanup: + + gfc_current_locus = where; + gfc_free_forall_iterator (iter); + return m; +} + + +/* Match the header of a FORALL statement. */ + +static match +match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) +{ + gfc_forall_iterator *head, *tail, *new_iter; + gfc_expr *msk; + match m; + + gfc_gobble_whitespace (); + + head = tail = NULL; + msk = NULL; + + if (gfc_match_char ('(') != MATCH_YES) + return MATCH_NO; + + m = match_forall_iterator (&new_iter); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + head = tail = new_iter; + + for (;;) + { + if (gfc_match_char (',') != MATCH_YES) + break; + + m = match_forall_iterator (&new_iter); + if (m == MATCH_ERROR) + goto cleanup; + + if (m == MATCH_YES) + { + tail->next = new_iter; + tail = new_iter; + continue; + } + + /* Have to have a mask expression. */ + + m = gfc_match_expr (&msk); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + break; + } + + if (gfc_match_char (')') == MATCH_NO) + goto syntax; + + *phead = head; + *mask = msk; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_FORALL); + +cleanup: + gfc_free_expr (msk); + gfc_free_forall_iterator (head); + + return MATCH_ERROR; +} + +/* Match the rest of a simple FORALL statement that follows an + IF statement. */ + +static match +match_simple_forall (void) +{ + gfc_forall_iterator *head; + gfc_expr *mask; + gfc_code *c; + match m; + + mask = NULL; + head = NULL; + c = NULL; + + m = match_forall_header (&head, &mask); + + if (m == MATCH_NO) + goto syntax; + if (m != MATCH_YES) + goto cleanup; + + m = gfc_match_assignment (); + + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_pointer_assignment (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + c = gfc_get_code (); + *c = new_st; + c->loc = gfc_current_locus; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + gfc_clear_new_st (); + new_st.op = EXEC_FORALL; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; + new_st.block = gfc_get_code (); + + new_st.block->op = EXEC_FORALL; + new_st.block->next = c; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_FORALL); + +cleanup: + gfc_free_forall_iterator (head); + gfc_free_expr (mask); + + return MATCH_ERROR; +} + + +/* Match a FORALL statement. */ + +match +gfc_match_forall (gfc_statement *st) +{ + gfc_forall_iterator *head; + gfc_expr *mask; + gfc_code *c; + match m0, m; + + head = NULL; + mask = NULL; + c = NULL; + + m0 = gfc_match_label (); + if (m0 == MATCH_ERROR) + return MATCH_ERROR; + + m = gfc_match (" forall"); + if (m != MATCH_YES) + return m; + + m = match_forall_header (&head, &mask); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (gfc_match_eos () == MATCH_YES) + { + *st = ST_FORALL_BLOCK; + new_st.op = EXEC_FORALL; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; + return MATCH_YES; + } + + m = gfc_match_assignment (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_pointer_assignment (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + c = gfc_get_code (); + *c = new_st; + c->loc = gfc_current_locus; + + gfc_clear_new_st (); + new_st.op = EXEC_FORALL; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; + new_st.block = gfc_get_code (); + new_st.block->op = EXEC_FORALL; + new_st.block->next = c; + + *st = ST_FORALL; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_FORALL); + +cleanup: + gfc_free_forall_iterator (head); + gfc_free_expr (mask); + gfc_free_statements (c); + return MATCH_NO; +} + + /* Match a DO statement. */ match @@ -1937,6 +2374,46 @@ gfc_match_do (void) if (gfc_match_parens () == MATCH_ERROR) return MATCH_ERROR; + if (gfc_match (" concurrent") == MATCH_YES) + { + gfc_forall_iterator *head; + gfc_expr *mask; + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: DO CONCURRENT " + "construct at %C") == FAILURE) + return MATCH_ERROR; + + + mask = NULL; + head = NULL; + m = match_forall_header (&head, &mask); + + if (m == MATCH_NO) + return m; + if (m == MATCH_ERROR) + goto concurr_cleanup; + + if (gfc_match_eos () != MATCH_YES) + goto concurr_cleanup; + + if (label != NULL + && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + goto concurr_cleanup; + + new_st.label1 = label; + new_st.op = EXEC_DO_CONCURRENT; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; + + return MATCH_YES; + +concurr_cleanup: + gfc_syntax_error (ST_DO); + gfc_free_expr (mask); + gfc_free_forall_iterator (head); + return MATCH_ERROR; + } + /* See if we have a DO WHILE. */ if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) { @@ -2052,7 +2529,17 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) gfc_ascii_statement (st)); return MATCH_ERROR; } - else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO)) + else if (p->state == COMP_DO_CONCURRENT + && (op == EXEC_EXIT || (sym && sym != p->sym))) + { + /* F2008, C821 & C845. */ + gfc_error("%s statement at %C leaves DO CONCURRENT construct", + gfc_ascii_statement (st)); + return MATCH_ERROR; + } + else if ((sym && sym == p->sym) + || (!sym && (p->state == COMP_DO + || p->state == COMP_DO_CONCURRENT))) break; if (p == NULL) @@ -2071,6 +2558,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) switch (p->state) { case COMP_DO: + case COMP_DO_CONCURRENT: break; case COMP_CRITICAL: @@ -2202,6 +2690,11 @@ gfc_match_stopcode (gfc_statement st) gfc_error ("Image control statement STOP at %C in CRITICAL block"); goto cleanup; } + if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) + { + gfc_error ("Image control statement STOP at %C in DO CONCURRENT block"); + goto cleanup; + } if (e != NULL) { @@ -2325,7 +2818,8 @@ lock_unlock_statement (gfc_statement st) if (gfc_pure (NULL)) { - gfc_error ("Image control statement SYNC at %C in PURE procedure"); + gfc_error ("Image control statement %s at %C in PURE procedure", + st == ST_LOCK ? "LOCK" : "UNLOCK"); return MATCH_ERROR; } @@ -2340,7 +2834,15 @@ lock_unlock_statement (gfc_statement st) if (gfc_find_state (COMP_CRITICAL) == SUCCESS) { - gfc_error ("Image control statement SYNC at %C in CRITICAL block"); + gfc_error ("Image control statement %s at %C in CRITICAL block", + st == ST_LOCK ? "LOCK" : "UNLOCK"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) + { + gfc_error ("Image control statement %s at %C in DO CONCURRENT block", + st == ST_LOCK ? "LOCK" : "UNLOCK"); return MATCH_ERROR; } @@ -2532,6 +3034,12 @@ sync_statement (gfc_statement st) return MATCH_ERROR; } + if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) + { + gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block"); + return MATCH_ERROR; + } + if (gfc_match_eos () == MATCH_YES) { if (st == ST_SYNC_IMAGES) @@ -2905,136 +3413,6 @@ gfc_free_alloc_list (gfc_alloc *p) } -/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of - an accessible derived type. */ - -static match -match_derived_type_spec (gfc_typespec *ts) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - locus old_locus; - gfc_symbol *derived; - - old_locus = gfc_current_locus; - - if (gfc_match ("%n", name) != MATCH_YES) - { - gfc_current_locus = old_locus; - return MATCH_NO; - } - - gfc_find_symbol (name, NULL, 1, &derived); - - if (derived && derived->attr.flavor == FL_DERIVED) - { - ts->type = BT_DERIVED; - ts->u.derived = derived; - return MATCH_YES; - } - - gfc_current_locus = old_locus; - return MATCH_NO; -} - - -/* Match a Fortran 2003 type-spec (F03:R401). This is similar to - gfc_match_decl_type_spec() from decl.c, with the following exceptions: - It only includes the intrinsic types from the Fortran 2003 standard - (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally, - the implicit_flag is not needed, so it was removed. Derived types are - identified by their name alone. */ - -static match -match_type_spec (gfc_typespec *ts) -{ - match m; - locus old_locus; - - gfc_clear_ts (ts); - gfc_gobble_whitespace (); - old_locus = gfc_current_locus; - - if (match_derived_type_spec (ts) == MATCH_YES) - { - /* Enforce F03:C401. */ - if (ts->u.derived->attr.abstract) - { - gfc_error ("Derived type '%s' at %L may not be ABSTRACT", - ts->u.derived->name, &old_locus); - return MATCH_ERROR; - } - return MATCH_YES; - } - - if (gfc_match ("integer") == MATCH_YES) - { - ts->type = BT_INTEGER; - ts->kind = gfc_default_integer_kind; - goto kind_selector; - } - - if (gfc_match ("real") == MATCH_YES) - { - ts->type = BT_REAL; - ts->kind = gfc_default_real_kind; - goto kind_selector; - } - - if (gfc_match ("double precision") == MATCH_YES) - { - ts->type = BT_REAL; - ts->kind = gfc_default_double_kind; - return MATCH_YES; - } - - if (gfc_match ("complex") == MATCH_YES) - { - ts->type = BT_COMPLEX; - ts->kind = gfc_default_complex_kind; - goto kind_selector; - } - - if (gfc_match ("character") == MATCH_YES) - { - ts->type = BT_CHARACTER; - - m = gfc_match_char_spec (ts); - - if (m == MATCH_NO) - m = MATCH_YES; - - return m; - } - - if (gfc_match ("logical") == MATCH_YES) - { - ts->type = BT_LOGICAL; - ts->kind = gfc_default_logical_kind; - goto kind_selector; - } - - /* If a type is not matched, simply return MATCH_NO. */ - gfc_current_locus = old_locus; - return MATCH_NO; - -kind_selector: - - gfc_gobble_whitespace (); - if (gfc_peek_ascii_char () == '*') - { - gfc_error ("Invalid type-spec at %C"); - return MATCH_ERROR; - } - - m = gfc_match_kind_spec (ts, false); - - if (m == MATCH_NO) - m = MATCH_YES; /* No kind specifier found. */ - - return m; -} - - /* Match an ALLOCATE statement. */ match @@ -3129,6 +3507,27 @@ gfc_match_allocate (void) deferred_locus = tail->expr->where; } + if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS + || gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_ref *ref; + bool coarray = tail->expr->symtree->n.sym->attr.codimension; + for (ref = tail->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + coarray = ref->u.c.component->attr.codimension; + + if (coarray && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) + { + gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block"); + goto cleanup; + } + if (coarray && gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("ALLOCATE of coarray at %C in CRITICAL block"); + goto cleanup; + } + } + /* The ALLOCATE statement had an optional typespec. Check the constraints. */ if (ts.type != BT_UNKNOWN) @@ -3477,6 +3876,20 @@ gfc_match_deallocate (void) if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym)) gfc_current_ns->proc_name->attr.implicit_pure = 0; + if (gfc_is_coarray (tail->expr) + && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) + { + gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block"); + goto cleanup; + } + + if (gfc_is_coarray (tail->expr) + && gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block"); + goto cleanup; + } + /* FIXME: disable the checking on derived types. */ b1 = !(tail->expr->ref && (tail->expr->ref->type == REF_COMPONENT @@ -3588,6 +4001,12 @@ gfc_match_return (void) return MATCH_ERROR; } + if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) + { + gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block"); + return MATCH_ERROR; + } + if (gfc_match_eos () == MATCH_YES) goto done; @@ -5188,303 +5607,3 @@ cleanup: gfc_free_expr (expr); return MATCH_ERROR; } - - -/******************** FORALL subroutines ********************/ - -/* Free a list of FORALL iterators. */ - -void -gfc_free_forall_iterator (gfc_forall_iterator *iter) -{ - gfc_forall_iterator *next; - - while (iter) - { - next = iter->next; - gfc_free_expr (iter->var); - gfc_free_expr (iter->start); - gfc_free_expr (iter->end); - gfc_free_expr (iter->stride); - free (iter); - iter = next; - } -} - - -/* Match an iterator as part of a FORALL statement. The format is: - - = :[:] - - On MATCH_NO, the caller tests for the possibility that there is a - scalar mask expression. */ - -static match -match_forall_iterator (gfc_forall_iterator **result) -{ - gfc_forall_iterator *iter; - locus where; - match m; - - where = gfc_current_locus; - iter = XCNEW (gfc_forall_iterator); - - m = gfc_match_expr (&iter->var); - if (m != MATCH_YES) - goto cleanup; - - if (gfc_match_char ('=') != MATCH_YES - || iter->var->expr_type != EXPR_VARIABLE) - { - m = MATCH_NO; - goto cleanup; - } - - m = gfc_match_expr (&iter->start); - if (m != MATCH_YES) - goto cleanup; - - if (gfc_match_char (':') != MATCH_YES) - goto syntax; - - m = gfc_match_expr (&iter->end); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (gfc_match_char (':') == MATCH_NO) - iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - else - { - m = gfc_match_expr (&iter->stride); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - } - - /* Mark the iteration variable's symbol as used as a FORALL index. */ - iter->var->symtree->n.sym->forall_index = true; - - *result = iter; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in FORALL iterator at %C"); - m = MATCH_ERROR; - -cleanup: - - gfc_current_locus = where; - gfc_free_forall_iterator (iter); - return m; -} - - -/* Match the header of a FORALL statement. */ - -static match -match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) -{ - gfc_forall_iterator *head, *tail, *new_iter; - gfc_expr *msk; - match m; - - gfc_gobble_whitespace (); - - head = tail = NULL; - msk = NULL; - - if (gfc_match_char ('(') != MATCH_YES) - return MATCH_NO; - - m = match_forall_iterator (&new_iter); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - head = tail = new_iter; - - for (;;) - { - if (gfc_match_char (',') != MATCH_YES) - break; - - m = match_forall_iterator (&new_iter); - if (m == MATCH_ERROR) - goto cleanup; - - if (m == MATCH_YES) - { - tail->next = new_iter; - tail = new_iter; - continue; - } - - /* Have to have a mask expression. */ - - m = gfc_match_expr (&msk); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - break; - } - - if (gfc_match_char (')') == MATCH_NO) - goto syntax; - - *phead = head; - *mask = msk; - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_FORALL); - -cleanup: - gfc_free_expr (msk); - gfc_free_forall_iterator (head); - - return MATCH_ERROR; -} - -/* Match the rest of a simple FORALL statement that follows an - IF statement. */ - -static match -match_simple_forall (void) -{ - gfc_forall_iterator *head; - gfc_expr *mask; - gfc_code *c; - match m; - - mask = NULL; - head = NULL; - c = NULL; - - m = match_forall_header (&head, &mask); - - if (m == MATCH_NO) - goto syntax; - if (m != MATCH_YES) - goto cleanup; - - m = gfc_match_assignment (); - - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - m = gfc_match_pointer_assignment (); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - c = gfc_get_code (); - *c = new_st; - c->loc = gfc_current_locus; - - if (gfc_match_eos () != MATCH_YES) - goto syntax; - - gfc_clear_new_st (); - new_st.op = EXEC_FORALL; - new_st.expr1 = mask; - new_st.ext.forall_iterator = head; - new_st.block = gfc_get_code (); - - new_st.block->op = EXEC_FORALL; - new_st.block->next = c; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_FORALL); - -cleanup: - gfc_free_forall_iterator (head); - gfc_free_expr (mask); - - return MATCH_ERROR; -} - - -/* Match a FORALL statement. */ - -match -gfc_match_forall (gfc_statement *st) -{ - gfc_forall_iterator *head; - gfc_expr *mask; - gfc_code *c; - match m0, m; - - head = NULL; - mask = NULL; - c = NULL; - - m0 = gfc_match_label (); - if (m0 == MATCH_ERROR) - return MATCH_ERROR; - - m = gfc_match (" forall"); - if (m != MATCH_YES) - return m; - - m = match_forall_header (&head, &mask); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - if (gfc_match_eos () == MATCH_YES) - { - *st = ST_FORALL_BLOCK; - new_st.op = EXEC_FORALL; - new_st.expr1 = mask; - new_st.ext.forall_iterator = head; - return MATCH_YES; - } - - m = gfc_match_assignment (); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - m = gfc_match_pointer_assignment (); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - c = gfc_get_code (); - *c = new_st; - c->loc = gfc_current_locus; - - gfc_clear_new_st (); - new_st.op = EXEC_FORALL; - new_st.expr1 = mask; - new_st.ext.forall_iterator = head; - new_st.block = gfc_get_code (); - new_st.block->op = EXEC_FORALL; - new_st.block->next = c; - - *st = ST_FORALL; - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_FORALL); - -cleanup: - gfc_free_forall_iterator (head); - gfc_free_expr (mask); - gfc_free_statements (c); - return MATCH_NO; -} diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 9b11086..24d8960 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -3154,7 +3154,7 @@ check_do_closure (void) return 0; 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; if (p == NULL) @@ -3172,7 +3172,8 @@ check_do_closure (void) /* At this point, the label doesn't terminate the innermost loop. Make sure it doesn't terminate another one. */ 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 " "with another DO loop"); @@ -3387,7 +3388,9 @@ parse_do_block (void) gfc_code *top; gfc_state_data s; gfc_symtree *stree; + gfc_exec_op do_op; + do_op = new_st.op; s.ext.end_do_label = new_st.label1; if (new_st.ext.iterator != NULL) @@ -3398,7 +3401,8 @@ parse_do_block (void) accept_statement (ST_DO); 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; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index b18056c..9e56b81 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -30,7 +30,7 @@ typedef enum COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_BLOCK, COMP_ASSOCIATE, COMP_IF, 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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 436c160..3877711 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -58,9 +58,10 @@ code_stack; 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 do_concurrent_flag; /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ @@ -3125,11 +3126,17 @@ resolve_function (gfc_expr *expr) { 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_flag == 2 ? "mask" : "block"); t = FAILURE; } + else if (do_concurrent_flag) + { + gfc_error ("Reference to non-PURE function '%s' at %L inside a " + "DO CONCURRENT block", name, &expr->where); + t = FAILURE; + } else if (gfc_pure (NULL)) { gfc_error ("Function reference to '%s' at %L is to a non-PURE " @@ -3196,6 +3203,9 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym) if (forall_flag) gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE", 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)) gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name, &c->loc); @@ -8351,10 +8361,16 @@ resolve_branch (gfc_st_label *label, gfc_code *code) whether the label is still visible outside of the CRITICAL block, which is invalid. */ for (stack = cs_base; stack; stack = stack->prev) - if (stack->current->op == EXEC_CRITICAL - && bitmap_bit_p (stack->reachable_labels, label->value)) - gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" - " at %L", &code->loc, &label->where); + { + if (stack->current->op == EXEC_CRITICAL + && bitmap_bit_p (stack->reachable_labels, label->value)) + 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; } @@ -8375,6 +8391,12 @@ resolve_branch (gfc_st_label *label, gfc_code *code) " at %L", &code->loc, &label->where); 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) @@ -8798,6 +8820,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_FORALL: case EXEC_DO: case EXEC_DO_WHILE: + case EXEC_DO_CONCURRENT: case EXEC_CRITICAL: case EXEC_READ: case EXEC_WRITE: @@ -9037,7 +9060,7 @@ static void resolve_code (gfc_code *code, gfc_namespace *ns) { int omp_workshare_save; - int forall_save; + int forall_save, do_concurrent_save; code_stack frame; gfc_try t; @@ -9051,6 +9074,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) { frame.current = code; forall_save = forall_flag; + do_concurrent_save = do_concurrent_flag; if (code->op == EXEC_FORALL) { @@ -9083,6 +9107,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) /* Blocks are handled in resolve_select_type because we have to transform the SELECT TYPE into ASSOCIATE first. */ break; + case EXEC_DO_CONCURRENT: + do_concurrent_flag = 1; + gfc_resolve_blocks (code->block, ns); + do_concurrent_flag = 2; + break; case EXEC_OMP_WORKSHARE: omp_workshare_save = omp_workshare_flag; omp_workshare_flag = 1; @@ -9100,6 +9129,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC) t = gfc_resolve_expr (code->expr1); forall_flag = forall_save; + do_concurrent_flag = do_concurrent_save; if (gfc_resolve_expr (code->expr2) == FAILURE) t = FAILURE; @@ -9367,6 +9397,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) resolve_transfer (code); break; + case EXEC_DO_CONCURRENT: case EXEC_FORALL: resolve_forall_iterators (code->ext.forall_iterator); @@ -13536,6 +13567,7 @@ resolve_types (gfc_namespace *ns) } forall_flag = 0; + do_concurrent_flag = 0; gfc_check_interfaces (ns); gfc_traverse_ns (ns, resolve_values); diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 572baaf..932c942 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -178,6 +178,7 @@ gfc_free_statement (gfc_code *p) be freed. */ break; + case EXEC_DO_CONCURRENT: case EXEC_FORALL: gfc_free_forall_iterator (p->ext.forall_iterator); break; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 7d8b4e0..1fdb059 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -3514,6 +3514,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) tree maskindex; tree mask; tree pmask; + tree cycle_label = NULL_TREE; int n; int nvar; int need_temp; @@ -3703,6 +3704,26 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) 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; /* TODO: loop merging in FORALL statements. */ @@ -3783,6 +3804,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) c = c->next; } +done: /* Restore the original index variables. */ for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); @@ -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. If the WHERE construct is nested in FORALL, compute the overall temporary needed by the WHERE mask expression multiplied by the iterator number of diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 2d0faf1..caa4c98 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -51,6 +51,7 @@ tree gfc_trans_if (gfc_code *); tree gfc_trans_arithmetic_if (gfc_code *); tree gfc_trans_block_construct (gfc_code *); tree gfc_trans_do (gfc_code *, tree); +tree gfc_trans_do_concurrent (gfc_code *); tree gfc_trans_do_while (gfc_code *); tree gfc_trans_select (gfc_code *); tree gfc_trans_sync (gfc_code *, gfc_exec_op); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 4a71c43..764bdf4 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1303,6 +1303,10 @@ trans_code (gfc_code * code, tree cond) res = gfc_trans_do (code, cond); break; + case EXEC_DO_CONCURRENT: + res = gfc_trans_do_concurrent (code); + break; + case EXEC_DO_WHILE: res = gfc_trans_do_while (code); break; --- /dev/null 2011-09-05 08:32:03.622741340 +0200 +++ gcc/gcc/testsuite/gfortran.dg/do_concurrent_1.f90 2011-09-05 16:44:56.000000000 +0200 @@ -0,0 +1,71 @@ +! { 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 --- /dev/null 2011-09-05 08:32:03.622741340 +0200 +++ gcc/gcc/testsuite/gfortran.dg/do_concurrent_2.f90 2011-09-05 17:07:18.000000000 +0200 @@ -0,0 +1,40 @@ +! { 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