This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, Fortran] (Coarray) Add parse support for LOCK/UNLOCK (part 1 of 2)
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc patches <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>
- Date: Mon, 06 Jun 2011 23:40:15 +0200
- Subject: [Patch, Fortran] (Coarray) Add parse support for LOCK/UNLOCK (part 1 of 2)
This patch adds incomplete parsing support for the LOCK and UNLOCK
statement. Missing part 2 is the addition of the LOCK_TYPE of the
ISO_FORTRAN_ENV.
Build and tested on x86-64-linux.
OK for the trunk?
Tobias
b/gcc/fortran/dump-parse-tree.c | 27 +++
b/gcc/fortran/frontend-passes.c | 1
b/gcc/fortran/gfortran.h | 5
b/gcc/fortran/match.c | 202 ++++++++++++++++++++++-
b/gcc/fortran/match.h | 2
b/gcc/fortran/parse.c | 14 +
b/gcc/fortran/resolve.c | 39 ++++
b/gcc/fortran/st.c | 2
2011-06-06 Tobias Burnus <burnus@net-b.de>
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-06 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* gfortran.dg/coarray_lock_1.f90: New.
* gfortran.dg/coarray_lock_2.f90: New.
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index c807062..87b8b68 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 0137a9d..f100e1f 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 ff82424..f23fbbd 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 f275239..11dee41 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 69f1d9e..5a40d7a 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 a47b457..6013931 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 6ca98f2..b2c3189 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8199,6 +8199,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)
{
/* Check imageset. The * case matches expr1 == NULL. */
@@ -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 6f8a234..cedb97c 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:
--- /dev/null 2011-06-06 07:23:08.586867510 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_lock_1.f90 2011-06-06 23:24:56.000000000 +0200
@@ -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
--- /dev/null 2011-06-06 07:23:08.586867510 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_lock_2.f90 2011-06-06 23:24:33.000000000 +0200
@@ -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