From: Tobias Burnus Date: Wed, 8 Jun 2011 06:28:41 +0000 (+0200) Subject: re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays]) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=5493aa17a2da3923ee306b413ada64cc09549e74;p=gcc.git re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays]) 2011-06-08 Tobias Burnus PR fortran/18918 * gfortran.h (gfc_statement): Add ST_LOCK and ST_UNLOCK. (gfc_exec_op): Add EXEC_LOCK and EXEC_UNLOCK. (gfc_code): Add expr4. * match.h (gfc_match_lock, gfc_match_unlock): New prototypes. * match.c (gfc_match_lock, gfc_match_unlock, lock_unlock_statement): New functions. (sync_statement): Bug fix, avoiding double freeing. (gfc_match_if): Handle LOCK/UNLOCK statement. * parse.c (decode_statement, next_statement, gfc_ascii_statement): Ditto. * st.c (gfc_free_statement): Handle LOCK and UNLOCK. * resolve.c (resolve_lock_unlock): New function. (resolve_code): Call it. * dump-parse-tree.c (show_code_node): Handle LOCK/UNLOCK. * frontend-passes.c (gfc_code_walker): Optimize gfc_code's expr4. 2011-06-08 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_lock_1.f90: New. * gfortran.dg/coarray_lock_2.f90: New. From-SVN: r174796 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 33199109cc7..c77c6edfdb6 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2011-06-08 Tobias Burnus + + PR fortran/18918 + * gfortran.h (gfc_statement): Add ST_LOCK and ST_UNLOCK. + (gfc_exec_op): Add EXEC_LOCK and EXEC_UNLOCK. + (gfc_code): Add expr4. + * match.h (gfc_match_lock, gfc_match_unlock): New prototypes. + * match.c (gfc_match_lock, gfc_match_unlock, + lock_unlock_statement): New functions. + (sync_statement): Bug fix, avoiding double freeing. + (gfc_match_if): Handle LOCK/UNLOCK statement. + * parse.c (decode_statement, next_statement, + gfc_ascii_statement): Ditto. + * st.c (gfc_free_statement): Handle LOCK and UNLOCK. + * resolve.c (resolve_lock_unlock): New function. + (resolve_code): Call it. + * dump-parse-tree.c (show_code_node): Handle LOCK/UNLOCK. + 2011-06-07 Richard Guenther * f95-lang.c (gfc_init_decl_processing): Do not set diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index c80706272ad..87b8b68408f 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1396,6 +1396,33 @@ show_code_node (int level, gfc_code *c) } break; + case EXEC_LOCK: + case EXEC_UNLOCK: + if (c->op == EXEC_LOCK) + fputs ("LOCK ", dumpfile); + else + fputs ("UNLOCK ", dumpfile); + + fputs ("lock-variable=", dumpfile); + if (c->expr1 != NULL) + show_expr (c->expr1); + if (c->expr4 != NULL) + { + fputs (" acquired_lock=", dumpfile); + show_expr (c->expr4); + } + if (c->expr2 != NULL) + { + fputs (" stat=", dumpfile); + show_expr (c->expr2); + } + if (c->expr3 != NULL) + { + fputs (" errmsg=", dumpfile); + show_expr (c->expr3); + } + break; + case EXEC_ARITHMETIC_IF: fputs ("IF ", dumpfile); show_expr (c->expr1); diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 0137a9ddbf2..f100e1fb811 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -1190,6 +1190,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, WALK_SUBEXPR (co->expr1); WALK_SUBEXPR (co->expr2); WALK_SUBEXPR (co->expr3); + WALK_SUBEXPR (co->expr4); for (b = co->block; b; b = b->block) { WALK_SUBEXPR (b->expr1); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ff824244d86..f23fbbd4d12 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -208,7 +208,7 @@ typedef enum ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE, ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK, ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL, - ST_GET_FCN_CHARACTERISTICS, ST_NONE + ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE } gfc_statement; @@ -2056,6 +2056,7 @@ typedef enum 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, + EXEC_LOCK, EXEC_UNLOCK, EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO, EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE, @@ -2074,7 +2075,7 @@ typedef struct gfc_code gfc_st_label *here, *label1, *label2, *label3; gfc_symtree *symtree; - gfc_expr *expr1, *expr2, *expr3; + gfc_expr *expr1, *expr2, *expr3, *expr4; /* A name isn't sufficient to identify a subroutine, we need the actual symbol for the interface definition. const char *sub_name; */ diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index f275239bfe5..43aeb19f939 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1561,6 +1561,7 @@ gfc_match_if (gfc_statement *if_type) match ("go to", gfc_match_goto, ST_GOTO) match ("if", match_arithmetic_if, ST_ARITHMETIC_IF) match ("inquire", gfc_match_inquire, ST_INQUIRE) + match ("lock", gfc_match_lock, ST_LOCK) match ("nullify", gfc_match_nullify, ST_NULLIFY) match ("open", gfc_match_open, ST_OPEN) match ("pause", gfc_match_pause, ST_NONE) @@ -1573,6 +1574,7 @@ gfc_match_if (gfc_statement *if_type) match ("sync all", gfc_match_sync_all, ST_SYNC_CALL); match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); + match ("unlock", gfc_match_unlock, ST_UNLOCK) match ("where", match_simple_where, ST_WHERE) match ("write", gfc_match_write, ST_WRITE) @@ -2305,6 +2307,190 @@ gfc_match_error_stop (void) } +/* Match LOCK/UNLOCK statement. Syntax: + LOCK ( lock-variable [ , lock-stat-list ] ) + UNLOCK ( lock-variable [ , sync-stat-list ] ) + where lock-stat is ACQUIRED_LOCK or sync-stat + and sync-stat is STAT= or ERRMSG=. */ + +static match +lock_unlock_statement (gfc_statement st) +{ + match m; + gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg; + bool saw_acq_lock, saw_stat, saw_errmsg; + + tmp = lockvar = acq_lock = stat = errmsg = NULL; + saw_acq_lock = saw_stat = saw_errmsg = false; + + if (gfc_pure (NULL)) + { + gfc_error ("Image control statement SYNC at %C in PURE procedure"); + return MATCH_ERROR; + } + + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Image control statement SYNC at %C in CRITICAL block"); + return MATCH_ERROR; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + if (gfc_match ("%e", &lockvar) != MATCH_YES) + goto syntax; + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = gfc_match (" stat = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L ", &tmp->where); + goto cleanup; + } + stat = tmp; + saw_stat = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); + goto cleanup; + } + errmsg = tmp; + saw_errmsg = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + m = gfc_match (" acquired_lock = %v", &tmp); + if (m == MATCH_ERROR || st == ST_UNLOCK) + goto syntax; + if (m == MATCH_YES) + { + if (saw_acq_lock) + { + gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ", + &tmp->where); + goto cleanup; + } + acq_lock = tmp; + saw_acq_lock = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + break; + } + + if (m == MATCH_ERROR) + goto syntax; + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + switch (st) + { + case ST_LOCK: + new_st.op = EXEC_LOCK; + break; + case ST_UNLOCK: + new_st.op = EXEC_UNLOCK; + break; + default: + gcc_unreachable (); + } + + new_st.expr1 = lockvar; + new_st.expr2 = stat; + new_st.expr3 = errmsg; + new_st.expr4 = acq_lock; + + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +cleanup: + gfc_free_expr (tmp); + gfc_free_expr (lockvar); + gfc_free_expr (acq_lock); + gfc_free_expr (stat); + gfc_free_expr (errmsg); + + return MATCH_ERROR; +} + + +match +gfc_match_lock (void) +{ + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: LOCK statement at %C") + == FAILURE) + return MATCH_ERROR; + + return lock_unlock_statement (ST_LOCK); +} + + +match +gfc_match_unlock (void) +{ + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: UNLOCK statement at %C") + == FAILURE) + return MATCH_ERROR; + + return lock_unlock_statement (ST_UNLOCK); +} + + /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax: SYNC ALL [(sync-stat-list)] SYNC MEMORY [(sync-stat-list)] @@ -2345,7 +2531,7 @@ sync_statement (gfc_statement st) gfc_error ("Image control statement SYNC at %C in CRITICAL block"); return MATCH_ERROR; } - + if (gfc_match_eos () == MATCH_YES) { if (st == ST_SYNC_IMAGES) @@ -2396,6 +2582,9 @@ sync_statement (gfc_statement st) if (gfc_match_char (',') == MATCH_YES) continue; + + tmp = NULL; + break; } m = gfc_match (" errmsg = %v", &tmp); @@ -2413,16 +2602,17 @@ sync_statement (gfc_statement st) if (gfc_match_char (',') == MATCH_YES) continue; - } - gfc_gobble_whitespace (); + tmp = NULL; + break; + } - if (gfc_peek_char () == ')') break; - - goto syntax; } + if (m == MATCH_ERROR) + goto syntax; + if (gfc_match (" )%t") != MATCH_YES) goto syntax; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 69f1d9e607b..5a40d7a173a 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -74,6 +74,7 @@ match gfc_match_associate (void); match gfc_match_do (void); match gfc_match_cycle (void); match gfc_match_exit (void); +match gfc_match_lock (void); match gfc_match_pause (void); match gfc_match_stop (void); match gfc_match_error_stop (void); @@ -83,6 +84,7 @@ match gfc_match_goto (void); match gfc_match_sync_all (void); match gfc_match_sync_images (void); match gfc_match_sync_memory (void); +match gfc_match_unlock (void); match gfc_match_allocate (void); match gfc_match_nullify (void); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index a47b4578169..6013931d355 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -398,6 +398,10 @@ decode_statement (void) match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); break; + case 'l': + match ("lock", gfc_match_lock, ST_LOCK); + break; + case 'm': match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC); match ("module", gfc_match_module, ST_MODULE); @@ -449,6 +453,7 @@ decode_statement (void) break; case 'u': + match ("unlock", gfc_match_unlock, ST_UNLOCK); match ("use", gfc_match_use, ST_USE); break; @@ -953,7 +958,8 @@ next_statement (void) case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_ERROR_STOP: \ - case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY + case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: \ + case ST_LOCK: case ST_UNLOCK /* Statements that mark other executable statements. */ @@ -1334,6 +1340,9 @@ gfc_ascii_statement (gfc_statement st) case ST_INTERFACE: p = "INTERFACE"; break; + case ST_LOCK: + p = "LOCK"; + break; case ST_PARAMETER: p = "PARAMETER"; break; @@ -1394,6 +1403,9 @@ gfc_ascii_statement (gfc_statement st) case ST_TYPE: p = "TYPE"; break; + case ST_UNLOCK: + p = "UNLOCK"; + break; case ST_USE: p = "USE"; break; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6ca98f2e721..b2c31892eb4 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8198,6 +8198,40 @@ find_reachable_labels (gfc_code *block) } +static void +resolve_lock_unlock (gfc_code *code) +{ + /* FIXME: Add more lock-variable checks. For now, always reject it. + Note that ISO_FORTRAN_ENV's LOCK_TYPE is not yet available. */ + /* if (code->expr2->ts.type != BT_DERIVED + || code->expr2->rank != 0 + || code->expr2->expr_type != EXPR_VARIABLE) */ + gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE", + &code->expr1->where); + + /* Check STAT. */ + if (code->expr2 + && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 + || code->expr2->expr_type != EXPR_VARIABLE)) + gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", + &code->expr2->where); + + /* Check ERRMSG. */ + if (code->expr3 + && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 + || code->expr3->expr_type != EXPR_VARIABLE)) + gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", + &code->expr3->where); + + /* Check ACQUIRED_LOCK. */ + if (code->expr4 + && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0 + || code->expr4->expr_type != EXPR_VARIABLE)) + gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL " + "variable", &code->expr4->where); +} + + static void resolve_sync (gfc_code *code) { @@ -9065,6 +9099,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) resolve_sync (code); break; + case EXEC_LOCK: + case EXEC_UNLOCK: + resolve_lock_unlock (code); + break; + case EXEC_ENTRY: /* Keep track of which entry we are up to. */ current_entry_id = code->ext.entry->id; diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 6f8a234c50d..cedb97c7d55 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -113,6 +113,8 @@ gfc_free_statement (gfc_code *p) case EXEC_SYNC_ALL: case EXEC_SYNC_IMAGES: case EXEC_SYNC_MEMORY: + case EXEC_LOCK: + case EXEC_UNLOCK: break; case EXEC_BLOCK: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b9f3aa3313b..184dcdd9348 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2011-06-08 Tobias Burnus + + PR fortran/18918 + * gfortran.dg/coarray_lock_1.f90: New. + * gfortran.dg/coarray_lock_2.f90: New. + 2011-06-07 Jason Merrill * lib/prune.exp: Look for "required" rather than "instantiated". diff --git a/gcc/testsuite/gfortran.dg/coarray_lock_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lock_1.f90 new file mode 100644 index 00000000000..419ba47bab1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_lock_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! +! LOCK/UNLOCK intrinsics +! +! PR fortran/18918 +! +integer :: a[*] +integer :: s +character(len=3) :: c +logical :: bool + +LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" } +UNLOCK (a, stat=s, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" } +end diff --git a/gcc/testsuite/gfortran.dg/coarray_lock_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lock_2.f90 new file mode 100644 index 00000000000..243024084a1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_lock_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2003" } +! +! LOCK/UNLOCK intrinsics +! +! PR fortran/18918 +! +integer :: a[*] ! { dg-error "Fortran 2008: Coarray declaration" } +integer :: s +character(len=3) :: c +logical :: bool + +LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "Fortran 2008: LOCK statement" } +UNLOCK (a, stat=s, errmsg=c) ! { dg-error "Fortran 2008: UNLOCK statement" } +end