procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])

Browse source 
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.
        * frontend-passes.c (gfc_code_walker): Optimize gfc_code's expr4.

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.

From-SVN: r174796
This commit is contained in:
Tobias Burnus 2011-06-08 08:28:41 +02:00 • committed by Tobias Burnus
parent c2bbcb0db1
commit 5493aa17a2
12 changed files with 337 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
gcc/fortran/ChangeLog
View file

@ -1,3 +1,21 @@
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

27
gcc/fortran/dump-parse-tree.c
View file

@ -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);

1
gcc/fortran/frontend-passes.c
View file

@ -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);

5
gcc/fortran/gfortran.h
View file

@ -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; */

202
gcc/fortran/match.c
View file

@ -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;
tmp = NULL;
break;
}
gfc_gobble_whitespace ();
if (gfc_peek_char () == ')')
break;
goto syntax;
}
if (m == MATCH_ERROR)
goto syntax;
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;

2
gcc/fortran/match.h
View file

@ -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);

14
gcc/fortran/parse.c
View file

@ -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;

39
gcc/fortran/resolve.c
View file

@ -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;

2
gcc/fortran/st.c
View file

@ -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:

6
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,9 @@
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".

15
gcc/testsuite/gfortran.dg/coarray_lock_1.f90 Normal file
View file

@ -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

15
gcc/testsuite/gfortran.dg/coarray_lock_2.f90 Normal file
View file

@ -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