mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-11-29 06:44:27 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

re PR fortran/39997 (Procedure(), pointer & implicit typing: rejects-valid / accepts-invalid?)

Browse Source 
2010-04-06  Tobias Burnus  <burnus@net-b.de>

        PR fortran/39997
        * intrinsic.c (add_functions): Add num_images.
        * decl.c (gfc_match_end): Handle END CRITICAL.
        * intrinsic.h (gfc_simplify_num_images): Add prototype.
        * dump-parse-tree.c (show_code_node): Dump CRITICAL, ERROR STOP,
        and SYNC.
        * gfortran.h (gfc_statement): Add enum items for those.
        (gfc_exec_op) Ditto.
        (gfc_isym_id): Add num_images.
        * trans-stmt.c (gfc_trans_stop): Handle ERROR STOP.
        (gfc_trans_sync,gfc_trans_critical): New functions.
        * trans-stmt.h (gfc_trans_stop,gfc_trans_sync,
        gfc_trans_critical): Add/update prototypes.
        * trans.c (gfc_trans_code): Handle CRITICAL, ERROR STOP,
        and SYNC statements.
        * trans.h (gfor_fndecl_error_stop_string) Add variable.
        * resolve.c (resolve_sync): Add function.
        (gfc_resolve_blocks): Handle CRITICAL.
        (resolve_code): Handle CRITICAL, ERROR STOP,
        (resolve_branch): Add CRITICAL constraint check.
        and SYNC statements.
        * st.c (gfc_free_statement): Add new statements.
        * trans-decl.c (gfor_fndecl_error_stop_string): Global variable.
        (gfc_build_builtin_function_decls): Initialize it.
        * match.c (gfc_match_if): Handle ERROR STOP and SYNC.
        (gfc_match_critical, gfc_match_error_stop, sync_statement,
        gfc_match_sync_all, gfc_match_sync_images,
gfc_match_sync_memory):
        New functions.
        (match_exit_cycle): Handle CRITICAL constraint.
        (gfc_match_stopcode): Handle ERROR STOP.
        * match.h (gfc_match_critical, gfc_match_error_stop,
        gfc_match_sync_all, gfc_match_sync_images,
        gfc_match_sync_memory): Add prototype.
        * parse.c (decode_statement, gfc_ascii_statement,
        parse_executable): Handle new statements.
        (parse_critical_block): New function.
        * parse.h (gfc_compile_state): Add COMP_CRITICAL.
        * intrinsic.texi (num_images): Document new function.
        * simplify.c (gfc_simplify_num_images): Add function.

2010-04-06  Tobias Burnus  <burnus@net-b.de>

        PR fortran/39997
        * gfortran.dg/coarray_1.f90: New test.
        * gfortran.dg/coarray_2.f90: New test.
        * gfortran.dg/coarray_3.f90: New test.

2010-04-06  Tobias Burnus  <burnus@net-b.de>

        PR fortran/39997
        * runtime/stop.c (error_stop_string): New function.
        * gfortran.map (_gfortran_error_stop_string): Add.

From-SVN: r158008
This commit is contained in:
Tobias Burnus 2010-04-06 18:26:02 +02:00
parent 62daa13984
commit d0a4a61c3d
26 changed files with 922 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
gcc/fortran/ChangeLog
View File

@ -1,3 +1,45 @@
2010-04-06 Tobias Burnus <burnus@net-b.de>
PR fortran/39997
* intrinsic.c (add_functions): Add num_images.
* decl.c (gfc_match_end): Handle END CRITICAL.
* intrinsic.h (gfc_simplify_num_images): Add prototype.
* dump-parse-tree.c (show_code_node): Dump CRITICAL, ERROR STOP,
and SYNC.
* gfortran.h (gfc_statement): Add enum items for those.
(gfc_exec_op) Ditto.
(gfc_isym_id): Add num_images.
* trans-stmt.c (gfc_trans_stop): Handle ERROR STOP.
(gfc_trans_sync,gfc_trans_critical): New functions.
* trans-stmt.h (gfc_trans_stop,gfc_trans_sync,
gfc_trans_critical): Add/update prototypes.
* trans.c (gfc_trans_code): Handle CRITICAL, ERROR STOP,
and SYNC statements.
* trans.h (gfor_fndecl_error_stop_string) Add variable.
* resolve.c (resolve_sync): Add function.
(gfc_resolve_blocks): Handle CRITICAL.
(resolve_code): Handle CRITICAL, ERROR STOP,
(resolve_branch): Add CRITICAL constraint check.
and SYNC statements.
* st.c (gfc_free_statement): Add new statements.
* trans-decl.c (gfor_fndecl_error_stop_string): Global variable.
(gfc_build_builtin_function_decls): Initialize it.
* match.c (gfc_match_if): Handle ERROR STOP and SYNC.
(gfc_match_critical, gfc_match_error_stop, sync_statement,
gfc_match_sync_all, gfc_match_sync_images, gfc_match_sync_memory):
New functions.
(match_exit_cycle): Handle CRITICAL constraint.
(gfc_match_stopcode): Handle ERROR STOP.
* match.h (gfc_match_critical, gfc_match_error_stop,
gfc_match_sync_all, gfc_match_sync_images,
gfc_match_sync_memory): Add prototype.
* parse.c (decode_statement, gfc_ascii_statement,
parse_executable): Handle new statements.
(parse_critical_block): New function.
* parse.h (gfc_compile_state): Add COMP_CRITICAL.
* intrinsic.texi (num_images): Document new function.
* simplify.c (gfc_simplify_num_images): Add function.
2010-04-06 Tobias Burnus <burnus@net-b.de>
PR fortran/43178

9
gcc/fortran/decl.c
View File

@ -5476,6 +5476,12 @@ gfc_match_end (gfc_statement *st)
eos_ok = 0;
break;
case COMP_CRITICAL:
*st = ST_END_CRITICAL;
target = " critical";
eos_ok = 0;
break;
case COMP_SELECT:
case COMP_SELECT_TYPE:
*st = ST_END_SELECT;
@ -5534,7 +5540,8 @@ gfc_match_end (gfc_statement *st)
{
if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
&& *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK)
&& *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
&& *st != ST_END_CRITICAL)
return MATCH_YES;
if (!block_name)

59
gcc/fortran/dump-parse-tree.c
View File

@ -1,5 +1,5 @@
/* Parse tree dumper
Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009
Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Steven Bosscher
@ -1273,6 +1273,10 @@ show_code_node (int level, gfc_code *c)
break;
case EXEC_ERROR_STOP:
fputs ("ERROR ", dumpfile);
/* Fall through. */
case EXEC_STOP:
fputs ("STOP ", dumpfile);
@ -1283,6 +1287,52 @@ show_code_node (int level, gfc_code *c)
break;
case EXEC_SYNC_ALL:
fputs ("SYNC ALL ", dumpfile);
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_SYNC_MEMORY:
fputs ("SYNC MEMORY ", dumpfile);
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_SYNC_IMAGES:
fputs ("SYNC IMAGES image-set=", dumpfile);
if (c->expr1 != NULL)
show_expr (c->expr1);
else
fputs ("* ", dumpfile);
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);
@ -1400,6 +1450,13 @@ show_code_node (int level, gfc_code *c)
fputs ("END FORALL", dumpfile);
break;
case EXEC_CRITICAL:
fputs ("CRITICAL\n", dumpfile);
show_code (level + 1, c->block->next);
code_indent (level, 0);
fputs ("END CRITICAL", dumpfile);
break;
case EXEC_DO:
fputs ("DO ", dumpfile);

12
gcc/fortran/gfortran.h
View File

@ -214,9 +214,9 @@ typedef enum
ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF,
ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT,
ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE,
ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO,
ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT,
ST_INQUIRE, ST_INTERFACE,
ST_ERROR_STOP, ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION,
ST_GOTO, ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT,
ST_INQUIRE, ST_INTERFACE, ST_SYNC_ALL, ST_SYNC_MEMORY, ST_SYNC_IMAGES,
ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN,
ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND,
ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT,
@ -231,7 +231,7 @@ typedef enum
ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
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_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
ST_GET_FCN_CHARACTERISTICS, ST_NONE
}
gfc_statement;
@ -462,6 +462,7 @@ enum gfc_isym_id
GFC_ISYM_NINT,
GFC_ISYM_NOT,
GFC_ISYM_NULL,
GFC_ISYM_NUMIMAGES,
GFC_ISYM_OR,
GFC_ISYM_PACK,
GFC_ISYM_PERROR,
@ -1976,12 +1977,13 @@ gfc_forall_iterator;
typedef enum
{
EXEC_NOP = 1, EXEC_END_BLOCK, EXEC_ASSIGN, EXEC_LABEL_ASSIGN,
EXEC_POINTER_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_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,

3
gcc/fortran/intrinsic.c
View File

@ -2221,6 +2221,9 @@ add_functions (void)
make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
add_sym_0 ("num_images", GFC_ISYM_NUMIMAGES, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
NULL, gfc_simplify_num_images, NULL);
add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack,
ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,

5
gcc/fortran/intrinsic.h
View File

@ -1,7 +1,7 @@
/* Header file for intrinsics check, resolve and simplify function
prototypes.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
2010 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
@ -297,6 +297,7 @@ gfc_expr *gfc_simplify_nearest (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_new_line (gfc_expr *);
gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_null (gfc_expr *);
gfc_expr *gfc_simplify_num_images (void);
gfc_expr *gfc_simplify_idnint (gfc_expr *);
gfc_expr *gfc_simplify_not (gfc_expr *);
gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *);

44
gcc/fortran/intrinsic.texi
View File

@ -204,6 +204,7 @@ Some basic guidelines for editing this document:
* @code{NINT}: NINT, Nearest whole number
* @code{NOT}: NOT, Logical negation
* @code{NULL}: NULL, Function that returns an disassociated pointer
* @code{NUM_IMAGES}: NUM_IMAGES, Number of images
* @code{OR}: OR, Bitwise logical OR
* @code{PACK}: PACK, Pack an array into an array of rank one
* @code{PERROR}: PERROR, Print system error message
@ -8375,6 +8376,49 @@ REAL, POINTER, DIMENSION(:) :: VEC => NULL ()
@node NUM_IMAGES
@section @code{NUM_IMAGES} --- Function that returns the number of images
@fnindex NUM_IMAGES
@cindex coarray, NUM_IMAGES
@cindex images, number of
@table @asis
@item @emph{Description}:
Returns the number of images.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Transformational function
@item @emph{Syntax}:
@code{RESULT = NUM_IMAGES()}
@item @emph{Arguments}: None.
@item @emph{Return value}:
Scalar default-kind integer.
@item @emph{Example}:
@smallexample
INTEGER :: value[*]
INTEGER :: i
value = THIS_IMAGE()
SYNC ALL
IF (THIS_IMAGE() == 1) THEN
DO i = 1, NUM_IMAGES()
WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
END DO
END IF
@end smallexample
@item @emph{See also}:
@c FIXME: ref{THIS_IMAGE}
@end table
@node OR
@section @code{OR} --- Bitwise logical OR
@fnindex OR

279
gcc/fortran/match.c
View File

@ -1,6 +1,6 @@
/* Matching subroutines in all sizes, shapes and colors.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
2010 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
@ -1547,6 +1547,7 @@ gfc_match_if (gfc_statement *if_type)
match ("cycle", gfc_match_cycle, ST_CYCLE)
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
match ("end file", gfc_match_endfile, ST_END_FILE)
match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
match ("exit", gfc_match_exit, ST_EXIT)
match ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
@ -1562,6 +1563,9 @@ gfc_match_if (gfc_statement *if_type)
match ("rewind", gfc_match_rewind, ST_REWIND)
match ("stop", gfc_match_stop, ST_STOP)
match ("wait", gfc_match_wait, ST_WAIT)
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 ("where", match_simple_where, ST_WHERE)
match ("write", gfc_match_write, ST_WRITE)
@ -1708,6 +1712,53 @@ gfc_free_iterator (gfc_iterator *iter, int flag)
}
/* Match a CRITICAL statement. */
match
gfc_match_critical (void)
{
gfc_st_label *label = NULL;
if (gfc_match_label () == MATCH_ERROR)
return MATCH_ERROR;
if (gfc_match (" critical") != MATCH_YES)
return MATCH_NO;
if (gfc_match_st_label (&label) == MATCH_ERROR)
return MATCH_ERROR;
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_CRITICAL);
return MATCH_ERROR;
}
if (gfc_pure (NULL))
{
gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
== FAILURE)
return MATCH_ERROR;
if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
{
gfc_error ("Nested CRITICAL block at %C");
return MATCH_ERROR;
}
new_st.op = EXEC_CRITICAL;
if (label != NULL
&& gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
}
/* Match a BLOCK statement. */
match
@ -1871,6 +1922,12 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
break;
else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
o = p;
else if (p->state == COMP_CRITICAL)
{
gfc_error("%s statement at %C leaves CRITICAL construct",
gfc_ascii_statement (st));
return MATCH_ERROR;
}
if (p == NULL)
{
@ -1930,7 +1987,7 @@ gfc_match_cycle (void)
}
/* Match a number or character constant after a STOP or PAUSE statement. */
/* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
static match
gfc_match_stopcode (gfc_statement st)
@ -1978,7 +2035,27 @@ gfc_match_stopcode (gfc_statement st)
goto cleanup;
}
new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
{
gfc_error ("Image control statement STOP at %C in CRITICAL block");
return MATCH_ERROR;
}
switch (st)
{
case ST_STOP:
new_st.op = EXEC_STOP;
break;
case ST_ERROR_STOP:
new_st.op = EXEC_ERROR_STOP;
break;
case ST_PAUSE:
new_st.op = EXEC_PAUSE;
break;
default:
gcc_unreachable ();
}
new_st.expr1 = e;
new_st.ext.stop_code = stop_code;
@ -2022,6 +2099,193 @@ gfc_match_stop (void)
}
/* Match the ERROR STOP statement. */
match
gfc_match_error_stop (void)
{
if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C")
== FAILURE)
return MATCH_ERROR;
return gfc_match_stopcode (ST_ERROR_STOP);
}
/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
SYNC ALL [(sync-stat-list)]
SYNC MEMORY [(sync-stat-list)]
SYNC IMAGES (image-set [, sync-stat-list] )
with sync-stat is int-expr or *. */
static match
sync_statement (gfc_statement st)
{
match m;
gfc_expr *tmp, *imageset, *stat, *errmsg;
bool saw_stat, saw_errmsg;
tmp = imageset = stat = errmsg = NULL;
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_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
== FAILURE)
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_eos () == MATCH_YES)
{
if (st == ST_SYNC_IMAGES)
goto syntax;
goto done;
}
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
if (st == ST_SYNC_IMAGES)
{
/* Denote '*' as imageset == NULL. */
m = gfc_match_char ('*');
if (m == MATCH_ERROR)
goto syntax;
if (m == MATCH_NO)
{
if (gfc_match ("%e", &imageset) != 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;
if (gfc_match_char (',') == MATCH_YES)
continue;
}
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;
if (gfc_match_char (',') == MATCH_YES)
continue;
}
gfc_gobble_whitespace ();
if (gfc_peek_char () == ')')
break;
goto syntax;
}
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
done:
switch (st)
{
case ST_SYNC_ALL:
new_st.op = EXEC_SYNC_ALL;
break;
case ST_SYNC_IMAGES:
new_st.op = EXEC_SYNC_IMAGES;
break;
case ST_SYNC_MEMORY:
new_st.op = EXEC_SYNC_MEMORY;
break;
default:
gcc_unreachable ();
}
new_st.expr1 = imageset;
new_st.expr2 = stat;
new_st.expr3 = errmsg;
return MATCH_YES;
syntax:
gfc_syntax_error (st);
cleanup:
gfc_free_expr (tmp);
gfc_free_expr (imageset);
gfc_free_expr (stat);
gfc_free_expr (errmsg);
return MATCH_ERROR;
}
/* Match SYNC ALL statement. */
match
gfc_match_sync_all (void)
{
return sync_statement (ST_SYNC_ALL);
}
/* Match SYNC IMAGES statement. */
match
gfc_match_sync_images (void)
{
return sync_statement (ST_SYNC_IMAGES);
}
/* Match SYNC MEMORY statement. */
match
gfc_match_sync_memory (void)
{
return sync_statement (ST_SYNC_MEMORY);
}
/* Match a CONTINUE statement. */
match
@ -2850,6 +3114,13 @@ gfc_match_return (void)
gfc_compile_state s;
e = NULL;
if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
{
gfc_error ("Image control statement RETURN at %C in CRITICAL block");
return MATCH_ERROR;
}
if (gfc_match_eos () == MATCH_YES)
goto done;

5
gcc/fortran/match.h
View File

@ -69,15 +69,20 @@ match gfc_match_assignment (void);
match gfc_match_if (gfc_statement *);
match gfc_match_else (void);
match gfc_match_elseif (void);
match gfc_match_critical (void);
match gfc_match_block (void);
match gfc_match_do (void);
match gfc_match_cycle (void);
match gfc_match_exit (void);
match gfc_match_pause (void);
match gfc_match_stop (void);
match gfc_match_error_stop (void);
match gfc_match_continue (void);
match gfc_match_assign (void);
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_allocate (void);
match gfc_match_nullify (void);

100
gcc/fortran/parse.c
View File

@ -291,9 +291,9 @@ decode_statement (void)
gfc_undo_symbols ();
gfc_current_locus = old_locus;
/* Check for the IF, DO, SELECT, WHERE, FORALL and BLOCK statements, which
might begin with a block label. The match functions for these
statements are unusual in that their keyword is not seen before
/* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, and BLOCK
statements, which might begin with a block label. The match functions for
these statements are unusual in that their keyword is not seen before
the matcher is called. */
if (gfc_match_if (&st) == MATCH_YES)
@ -311,8 +311,9 @@ decode_statement (void)
gfc_undo_symbols ();
gfc_current_locus = old_locus;
match (NULL, gfc_match_block, ST_BLOCK);
match (NULL, gfc_match_do, ST_DO);
match (NULL, gfc_match_block, ST_BLOCK);
match (NULL, gfc_match_critical, ST_CRITICAL);
match (NULL, gfc_match_select, ST_SELECT_CASE);
match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
@ -362,6 +363,7 @@ decode_statement (void)
match ("else", gfc_match_else, ST_ELSE);
match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
match ("else if", gfc_match_elseif, ST_ELSEIF);
match ("error stop", gfc_match_error_stop, ST_ERROR_STOP);
match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
if (gfc_match_end (&st) == MATCH_YES)
@ -432,6 +434,9 @@ decode_statement (void)
match ("sequence", gfc_match_eos, ST_SEQUENCE);
match ("stop", gfc_match_stop, ST_STOP);
match ("save", gfc_match_save, ST_ATTR_DECL);
match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
break;
case 't':
@ -936,7 +941,8 @@ next_statement (void)
case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
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_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_ERROR_STOP: \
case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY
/* Statements that mark other executable statements. */
@ -948,7 +954,7 @@ next_statement (void)
case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
case ST_OMP_TASK
case ST_OMP_TASK: case ST_CRITICAL
/* Declaration statements */
@ -1082,6 +1088,7 @@ check_statement_label (gfc_statement st)
case ST_ENDDO:
case ST_ENDIF:
case ST_END_SELECT:
case ST_END_CRITICAL:
case_executable:
case_exec_markers:
type = ST_LABEL_TARGET;
@ -1176,6 +1183,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_CONTAINS:
p = "CONTAINS";
break;
case ST_CRITICAL:
p = "CRITICAL";
break;
case ST_CYCLE:
p = "CYCLE";
break;
@ -1209,6 +1219,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_END_BLOCK_DATA:
p = "END BLOCK DATA";
break;
case ST_END_CRITICAL:
p = "END CRITICAL";
break;
case ST_ENDDO:
p = "END DO";
break;
@ -1251,6 +1264,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_EQUIVALENCE:
p = "EQUIVALENCE";
break;
case ST_ERROR_STOP:
p = "ERROR STOP";
break;
case ST_EXIT:
p = "EXIT";
break;
@ -1339,6 +1355,15 @@ gfc_ascii_statement (gfc_statement st)
case ST_STOP:
p = "STOP";
break;
case ST_SYNC_ALL:
p = "SYNC ALL";
break;
case ST_SYNC_IMAGES:
p = "SYNC IMAGES";
break;
case ST_SYNC_MEMORY:
p = "SYNC MEMORY";
break;
case ST_SUBROUTINE:
p = "SUBROUTINE";
break;
@ -1555,6 +1580,7 @@ accept_statement (gfc_statement st)
case ST_ENDIF:
case ST_END_SELECT:
case ST_END_CRITICAL:
if (gfc_statement_label != NULL)
{
new_st.op = EXEC_END_BLOCK;
@ -3047,6 +3073,61 @@ check_do_closure (void)
static void parse_progunit (gfc_statement);
/* Parse a CRITICAL block. */
static void
parse_critical_block (void)
{
gfc_code *top, *d;
gfc_state_data s;
gfc_statement st;
s.ext.end_do_label = new_st.label1;
accept_statement (ST_CRITICAL);
top = gfc_state_stack->tail;
push_state (&s, COMP_CRITICAL, gfc_new_block);
d = add_statement ();
d->op = EXEC_CRITICAL;
top->block = d;
do
{
st = parse_executable (ST_NONE);
switch (st)
{
case ST_NONE:
unexpected_eof ();
break;
case ST_END_CRITICAL:
if (s.ext.end_do_label != NULL
&& s.ext.end_do_label != gfc_statement_label)
gfc_error_now ("Statement label in END CRITICAL at %C does not "
"match CRITIAL label");
if (gfc_statement_label != NULL)
{
new_st.op = EXEC_NOP;
add_statement ();
}
break;
default:
unexpected_statement (st);
break;
}
}
while (st != ST_END_CRITICAL);
pop_state ();
accept_statement (st);
}
/* Set up the local namespace for a BLOCK construct. */
gfc_namespace*
@ -3472,9 +3553,12 @@ parse_executable (gfc_statement st)
case ST_CYCLE:
case ST_PAUSE:
case ST_STOP:
case ST_ERROR_STOP:
case ST_END_SUBROUTINE:
case ST_DO:
case ST_CRITICAL:
case ST_BLOCK:
case ST_FORALL:
case ST_WHERE:
case ST_SELECT_CASE:
@ -3522,6 +3606,10 @@ parse_executable (gfc_statement st)
return ST_IMPLIED_ENDDO;
break;
case ST_CRITICAL:
parse_critical_block ();
break;
case ST_WHERE_BLOCK:
parse_where_block ();
break;

4
gcc/fortran/parse.h
View File

@ -1,5 +1,5 @@
/* Parser header
Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008
Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Steven Bosscher
@ -32,7 +32,7 @@ typedef enum
COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
COMP_BLOCK, COMP_IF,
COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK
COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL
}
gfc_compile_state;

78
gcc/fortran/resolve.c
View File

@ -7315,6 +7315,48 @@ find_reachable_labels (gfc_code *block)
}
}
static void
resolve_sync (gfc_code *code)
{
/* Check imageset. The * case matches expr1 == NULL. */
if (code->expr1)
{
if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
"INTEGER expression", &code->expr1->where);
if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
&& mpz_cmp_si (code->expr1->value.integer, 1) < 0)
gfc_error ("Imageset argument at %L must between 1 and num_images()",
&code->expr1->where);
else if (code->expr1->expr_type == EXPR_ARRAY
&& gfc_simplify_expr (code->expr1, 0) == SUCCESS)
{
gfc_constructor *cons;
for (cons = code->expr1->value.constructor; cons; cons = cons->next)
if (cons->expr->expr_type == EXPR_CONSTANT
&& mpz_cmp_si (cons->expr->value.integer, 1) < 0)
gfc_error ("Imageset argument at %L must between 1 and "
"num_images()", &cons->expr->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);
}
/* Given a branch to a label, see if the branch is conforming.
The code node describes where the branch is located. */
@ -7355,15 +7397,36 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
the bitmap reachable_labels. */
if (bitmap_bit_p (cs_base->reachable_labels, label->value))
return;
{
/* Check now whether there is a CRITICAL construct; if so, check
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);
return;
}
/* Step four: If we haven't found the label in the bitmap, it may
still be the label of the END of the enclosing block, in which
case we find it by going up the code_stack. */
for (stack = cs_base; stack; stack = stack->prev)
if (stack->current->next && stack->current->next->here == label)
break;
{
if (stack->current->next && stack->current->next->here == label)
break;
if (stack->current->op == EXEC_CRITICAL)
{
/* Note: A label at END CRITICAL does not leave the CRITICAL
construct as END CRITICAL is still part of it. */
gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
" at %L", &code->loc, &label->where);
return;
}
}
if (stack)
{
@ -7788,6 +7851,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
case EXEC_CRITICAL:
case EXEC_READ:
case EXEC_WRITE:
case EXEC_IOLENGTH:
@ -8068,10 +8132,18 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
case EXEC_CYCLE:
case EXEC_PAUSE:
case EXEC_STOP:
case EXEC_ERROR_STOP:
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
case EXEC_ASSIGN_CALL:
case EXEC_CRITICAL:
break;
case EXEC_SYNC_ALL:
case EXEC_SYNC_IMAGES:
case EXEC_SYNC_MEMORY:
resolve_sync (code);
break;
case EXEC_ENTRY:

16
gcc/fortran/simplify.c
View File

@ -1,6 +1,6 @@
/* Simplify intrinsic functions at compile-time.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
2010 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
@ -1928,6 +1928,7 @@ gfc_simplify_exp (gfc_expr *x)
return range_check (result, "EXP");
}
gfc_expr *
gfc_simplify_exponent (gfc_expr *x)
{
@ -3934,6 +3935,17 @@ gfc_simplify_null (gfc_expr *mold)
}
gfc_expr *
gfc_simplify_num_images (void)
{
gfc_expr *result;
/* FIXME: gfc_current_locus is wrong. */
result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
mpz_set_si (result->value.integer, 1);
return result;
}
gfc_expr *
gfc_simplify_or (gfc_expr *x, gfc_expr *y)
{

7
gcc/fortran/st.c
View File

@ -1,5 +1,5 @@
/* Build executable statement trees.
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
@ -98,6 +98,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_IF:
case EXEC_PAUSE:
case EXEC_STOP:
case EXEC_ERROR_STOP:
case EXEC_EXIT:
case EXEC_WHERE:
case EXEC_IOLENGTH:
@ -108,6 +109,10 @@ gfc_free_statement (gfc_code *p)
case EXEC_LABEL_ASSIGN:
case EXEC_ENTRY:
case EXEC_ARITHMETIC_IF:
case EXEC_CRITICAL:
case EXEC_SYNC_ALL:
case EXEC_SYNC_IMAGES:
case EXEC_SYNC_MEMORY:
break;
case EXEC_BLOCK:

8
gcc/fortran/trans-decl.c
View File

@ -85,6 +85,7 @@ tree gfor_fndecl_pause_numeric;
tree gfor_fndecl_pause_string;
tree gfor_fndecl_stop_numeric;
tree gfor_fndecl_stop_string;
tree gfor_fndecl_error_stop_string;
tree gfor_fndecl_runtime_error;
tree gfor_fndecl_runtime_error_at;
tree gfor_fndecl_runtime_warning_at;
@ -2725,6 +2726,13 @@ gfc_build_builtin_function_decls (void)
/* Stop doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
gfor_fndecl_error_stop_string =
gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
void_type_node, 2, pchar_type_node,
gfc_int4_type_node);
/* ERROR STOP doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
gfor_fndecl_pause_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
void_type_node, 1, gfc_int4_type_node);

64
gcc/fortran/trans-stmt.c
View File

@ -576,7 +576,7 @@ gfc_trans_pause (gfc_code * code)
to a runtime library call. */
tree
gfc_trans_stop (gfc_code * code)
gfc_trans_stop (gfc_code *code, bool error_stop)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
gfc_se se;
@ -586,7 +586,6 @@ gfc_trans_stop (gfc_code * code)
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
if (code->expr1 == NULL)
{
tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
@ -597,8 +596,9 @@ gfc_trans_stop (gfc_code * code)
{
gfc_conv_expr_reference (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_stop_string, 2,
se.expr, se.string_length);
error_stop ? gfor_fndecl_error_stop_string
: gfor_fndecl_stop_string,
2, se.expr, se.string_length);
}
gfc_add_expr_to_block (&se.pre, tmp);
@ -609,6 +609,47 @@ gfc_trans_stop (gfc_code * code)
}
tree
gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused)))
{
gfc_se se;
if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2)
{
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
}
/* Check SYNC IMAGES(imageset) for valid image index.
FIXME: Add a check for image-set arrays. */
if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& code->expr1->rank == 0)
{
tree cond;
gfc_conv_expr (&se, code->expr1);
cond = fold_build2 (NE_EXPR, boolean_type_node, se.expr,
build_int_cst (TREE_TYPE (se.expr), 1));
gfc_trans_runtime_check (true, false, cond, &se.pre,
&code->expr1->where, "Invalid image number "
"%d in SYNC IMAGES",
fold_convert (integer_type_node, se.expr));
}
/* If STAT is present, set it to zero. */
if (code->expr2)
{
gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
gfc_conv_expr (&se, code->expr2);
gfc_add_modify (&se.pre, se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
}
if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2)
return gfc_finish_block (&se.pre);
return NULL_TREE;
}
/* Generate GENERIC for the IF construct. This function also deals with
the simple IF statement, because the front end translates the IF
statement into an IF construct.
@ -769,6 +810,21 @@ gfc_trans_arithmetic_if (gfc_code * code)
}
/* Translate a CRITICAL block. */
tree
gfc_trans_critical (gfc_code *code)
{
stmtblock_t block;
tree tmp;
gfc_start_block (&block);
tmp = gfc_trans_code (code->block->next);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
/* Translate a BLOCK construct. This is basically what we would do for a
procedure body. */

4
gcc/fortran/trans-stmt.h
View File

@ -36,13 +36,14 @@ tree gfc_trans_class_assign (gfc_code *code);
/* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *);
tree gfc_trans_critical (gfc_code *);
tree gfc_trans_exit (gfc_code *);
tree gfc_trans_label_assign (gfc_code *);
tree gfc_trans_label_here (gfc_code *);
tree gfc_trans_goto (gfc_code *);
tree gfc_trans_entry (gfc_code *);
tree gfc_trans_pause (gfc_code *);
tree gfc_trans_stop (gfc_code *);
tree gfc_trans_stop (gfc_code *, bool);
tree gfc_trans_call (gfc_code *, bool, tree, tree, bool);
tree gfc_trans_return (gfc_code *);
tree gfc_trans_if (gfc_code *);
@ -51,6 +52,7 @@ tree gfc_trans_block_construct (gfc_code *);
tree gfc_trans_do (gfc_code *, tree);
tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (gfc_code *);
tree gfc_trans_sync (gfc_code *, gfc_exec_op);
tree gfc_trans_forall (gfc_code *);
tree gfc_trans_where (gfc_code *);
tree gfc_trans_allocate (gfc_code *);

13
gcc/fortran/trans.c
View File

@ -1105,6 +1105,10 @@ trans_code (gfc_code * code, tree cond)
res = NULL_TREE;
break;
case EXEC_CRITICAL:
res = gfc_trans_critical (code);
break;
case EXEC_CYCLE:
res = gfc_trans_cycle (code);
break;
@ -1126,7 +1130,8 @@ trans_code (gfc_code * code, tree cond)
break;
case EXEC_STOP:
res = gfc_trans_stop (code);
case EXEC_ERROR_STOP:
res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
break;
case EXEC_CALL:
@ -1191,6 +1196,12 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_flush (code);
break;
case EXEC_SYNC_ALL:
case EXEC_SYNC_IMAGES:
case EXEC_SYNC_MEMORY:
res = gfc_trans_sync (code, code->op);
break;
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;

1
gcc/fortran/trans.h
View File

@ -534,6 +534,7 @@ extern GTY(()) tree gfor_fndecl_pause_numeric;
extern GTY(()) tree gfor_fndecl_pause_string;
extern GTY(()) tree gfor_fndecl_stop_numeric;
extern GTY(()) tree gfor_fndecl_stop_string;
extern GTY(()) tree gfor_fndecl_error_stop_string;
extern GTY(()) tree gfor_fndecl_runtime_error;
extern GTY(()) tree gfor_fndecl_runtime_error_at;
extern GTY(()) tree gfor_fndecl_runtime_warning_at;

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
2010-04-06 Tobias Burnus <burnus@net-b.de>
PR fortran/39997
* gfortran.dg/coarray_1.f90: New test.
* gfortran.dg/coarray_2.f90: New test.
* gfortran.dg/coarray_3.f90: New test.
2010-04-06 Jason Merrill <jason@redhat.com>
PR c++/43648

18
gcc/testsuite/gfortran.dg/coarray_1.f90 Normal file
View File

@ -0,0 +1,18 @@
! { dg-do compile }
! { dg-options "-std=f2003" }
!
! Coarray support
! PR fortran/18918
!
implicit none
integer :: n
critical ! { dg-error "Fortran 2008:" }
sync all() ! { dg-error "Fortran 2008:" }
end critical ! { dg-error "Expecting END PROGRAM" }
sync memory ! { dg-error "Fortran 2008:" }
sync images(*) ! { dg-error "Fortran 2008:" }
! num_images is implicitly defined:
n = num_images() ! { dg-error "convert UNKNOWN to INTEGER" }
error stop 'stop' ! { dg-error "Fortran 2008:" }
end

46
gcc/testsuite/gfortran.dg/coarray_2.f90 Normal file
View File

@ -0,0 +1,46 @@
! { dg-do run }
! { dg-shouldfail "error stop" }
!
! Coarray support
! PR fortran/18918
implicit none
integer :: n
character(len=30) :: str
critical
end critical
myCr: critical
end critical myCr
sync all
sync all ( )
n = 5
sync all (stat=n)
if (n /= 0) call abort()
n = 5
sync all (stat=n,errmsg=str)
if (n /= 0) call abort()
sync all (errmsg=str)
sync memory
sync memory ( )
n = 5
sync memory (stat=n)
if (n /= 0) call abort()
n = 5
sync memory (errmsg=str,stat=n)
if (n /= 0) call abort()
sync memory (errmsg=str)
sync images (*, stat=n)
sync images (1, errmsg=str)
sync images ([1],errmsg=str,stat=n)
sync images (*)
sync images (1)
sync images ([1])
if (num_images() /= 1) call abort()
error stop 'stop'
end
! { dg-output "ERROR STOP stop" }

99
gcc/testsuite/gfortran.dg/coarray_3.f90 Normal file
View File

@ -0,0 +1,99 @@
! { dg-do compile }
!
! Coarray support
! PR fortran/18918
implicit none
integer :: n, m(1), k
character(len=30) :: str(2)
critical fkl ! { dg-error "Syntax error in CRITICAL" }
end critical fkl ! { dg-error "Expecting END PROGRAM" }
sync all (stat=1) ! { dg-error "Syntax error in SYNC ALL" }
sync all ( stat = n,stat=k) ! { dg-error "Redundant STAT" }
sync memory (errmsg=str)
sync memory (errmsg=n) ! { dg-error "must be a scalar CHARACTER variable" }
sync images (*, stat=1.0) ! { dg-error "Syntax error in SYNC IMAGES" }
sync images (-1) ! { dg-error "must between 1 and num_images" }
sync images (1)
sync images ( [ 1 ])
sync images ( m(1:0) )
sync images ( reshape([1],[1,1])) ! { dg-error "must be a scalar or rank-1" }
end
subroutine foo
critical
stop 'error' ! { dg-error "Image control statement STOP" }
sync all ! { dg-error "Image control statement SYNC" }
return 1 ! { dg-error "Image control statement RETURN" }
critical ! { dg-error "Nested CRITICAL block" }
end critical
end critical ! { dg-error "Expecting END SUBROUTINE" }
end
subroutine bar()
do
critical
cycle ! { dg-error "leaves CRITICAL construct" }
end critical
end do
outer: do
critical
do
exit
exit outer ! { dg-error "leaves CRITICAL construct" }
end do
end critical
end do outer
end subroutine bar
subroutine sub()
333 continue ! { dg-error "leaves CRITICAL construct" }
do
critical
if (.false.) then
goto 333 ! { dg-error "leaves CRITICAL construct" }
goto 777
777 end if
end critical
end do
if (.true.) then
outer: do
critical
do
goto 444
goto 555 ! { dg-error "leaves CRITICAL construct" }
end do
444 continue
end critical
end do outer
555 end if ! { dg-error "leaves CRITICAL construct" }
end subroutine sub
pure subroutine pureSub()
critical ! { dg-error "Image control statement CRITICAL" }
end critical ! { dg-error "Expecting END SUBROUTINE statement" }
sync all ! { dg-error "Image control statement SYNC" }
error stop ! { dg-error "not allowed in PURE procedure" }
end subroutine pureSub
SUBROUTINE TEST
goto 10 ! { dg-warning "is not in the same block" }
CRITICAL
goto 5 ! OK
5 continue ! { dg-warning "is not in the same block" }
goto 10 ! OK
goto 20 ! { dg-error "leaves CRITICAL construct" }
goto 30 ! { dg-error "leaves CRITICAL construct" }
10 END CRITICAL ! { dg-warning "is not in the same block" }
goto 5 ! { dg-warning "is not in the same block" }
20 continue ! { dg-error "leaves CRITICAL construct" }
BLOCK
30 continue ! { dg-error "leaves CRITICAL construct" }
END BLOCK
end SUBROUTINE TEST

8
libgfortran/ChangeLog
View File

@ -1,3 +1,9 @@
2010-04-06 Tobias Burnus <burnus@net-b.de>
PR fortran/39997
* runtime/stop.c (error_stop_string): New function.
* gfortran.map (_gfortran_error_stop_string): Add.
2010-04-02 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
* Makefile.in: Regenerate.
@ -7,7 +13,7 @@
PR libfortran/43605
* io/intrinsics.c (gf_ftell): New function, seek to correct offset.
(ftell): Call gf_ftell.
(ftell): Call gf_ftell.
(FTELL_SUB): Likewise.
2010-04-01 Paul Thomas <pault@gcc.gnu.org>

5
libgfortran/gfortran.map
View File

@ -1098,6 +1098,11 @@ GFORTRAN_1.2 {
_gfortran_is_extension_of;
} GFORTRAN_1.1;
GFORTRAN_1.3 {
global:
_gfortran_error_stop_string;
} GFORTRAN_1.2;
F2C_1.0 {
global:
_gfortran_f2c_specific__abs_c4;

21
libgfortran/runtime/stop.c
View File

@ -1,5 +1,5 @@
/* Implementation of the STOP statement.
Copyright 2002, 2005, 2007, 2009 Free Software Foundation, Inc.
Copyright 2002, 2005, 2007, 2009, 2010 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -53,3 +53,22 @@ stop_string (const char *string, GFC_INTEGER_4 len)
sys_exit (0);
}
extern void error_stop_string (const char *, GFC_INTEGER_4);
export_proto(error_stop_string);
/* Per Fortran 2008, section 8.4: "Execution of a STOP statement initiates
normal termination of execution. Execution of an ERROR STOP statement
initiates error termination of execution." Thus, error_stop_string returns
a nonzero exit status code. */
void
error_stop_string (const char *string, GFC_INTEGER_4 len)
{
st_printf ("ERROR STOP ");
while (len--)
st_printf ("%c", *(string++));
st_printf ("\n");
sys_exit (1);
}