+2011-06-08 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.
+
2011-06-07 Richard Guenther <rguenther@suse.de>
* f95-lang.c (gfc_init_decl_processing): Do not set
}
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);
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);
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;
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,
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; */
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)
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)
}
+/* 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)]
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)
if (gfc_match_char (',') == MATCH_YES)
continue;
+
+ tmp = NULL;
+ break;
}
m = gfc_match (" errmsg = %v", &tmp);
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;
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);
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);
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);
break;
case 'u':
+ match ("unlock", gfc_match_unlock, ST_UNLOCK);
match ("use", gfc_match_use, ST_USE);
break;
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. */
case ST_INTERFACE:
p = "INTERFACE";
break;
+ case ST_LOCK:
+ p = "LOCK";
+ break;
case ST_PARAMETER:
p = "PARAMETER";
break;
case ST_TYPE:
p = "TYPE";
break;
+ case ST_UNLOCK:
+ p = "UNLOCK";
+ break;
case ST_USE:
p = "USE";
break;
}
+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)
{
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;
case EXEC_SYNC_ALL:
case EXEC_SYNC_IMAGES:
case EXEC_SYNC_MEMORY:
+ case EXEC_LOCK:
+ case EXEC_UNLOCK:
break;
case EXEC_BLOCK:
+2011-06-08 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/18918
+ * gfortran.dg/coarray_lock_1.f90: New.
+ * gfortran.dg/coarray_lock_2.f90: New.
+
2011-06-07 Jason Merrill <jason@redhat.com>
* lib/prune.exp: Look for "required" rather than "instantiated".
--- /dev/null
+! { 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
+! { 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
projects / gcc.git / commitdiff