From: burnus Date: Tue, 6 Apr 2010 16:26:02 +0000 (+0000) Subject: 2010-04-06 Tobias Burnus X-Git-Url: http://git.sourceforge.jp/view?a=commitdiff_plain;h=c6cd3066bcb72a59fecce6bfa99cb4e169a4a751;p=pf3gnuchains%2Fgcc-fork.git 2010-04-06 Tobias Burnus 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 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 PR fortran/39997 * runtime/stop.c (error_stop_string): New function. * gfortran.map (_gfortran_error_stop_string): Add. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158008 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 97a2fcac792..8af36683afa 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,47 @@ 2010-04-06 Tobias Burnus + 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 + PR fortran/43178 * trans-array.c (gfc_conv_expr_descriptor): Update gfc_trans_scalar_assign call. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 692078a11d4..923750388af 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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) diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index f3638167dfb..6c67e7dedf3 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -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); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index af1f1c69409..1f98824de75 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 684b2cf1742..fbfc47af12c 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index cf436db37fd..b675de25091 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -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 *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index b9b1c254e9c..52992ba0c41 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -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 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index c67427cbf14..48bb733b940 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 20250058c5f..b03ee541819 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -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); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 2679e92a831..7d935c33655 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -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; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index e0a2969c2a3..649e54dac82 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 24ec7a8a1de..8ef347d1ac8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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: diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 8768cb64de2..50cd6da7591 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -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) { @@ -3935,6 +3936,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) { gfc_expr *result; diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index f1765e6ed7c..ffef22d1140 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -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: diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index b2078640669..53c4b475add 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 7ebb1e9268b..0b215f2395d 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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. */ diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 56221f50bec..b3495456462 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -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 *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 17241ac266c..c1993f90ddd 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -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; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 33769319ef3..fe34f691127 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 66018c5a4f3..a65ba45835b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2010-04-06 Tobias Burnus + + 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 PR c++/43648 diff --git a/gcc/testsuite/gfortran.dg/coarray_1.f90 b/gcc/testsuite/gfortran.dg/coarray_1.f90 new file mode 100644 index 00000000000..ba10d64a3ef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_2.f90 b/gcc/testsuite/gfortran.dg/coarray_2.f90 new file mode 100644 index 00000000000..1fcb9b8b714 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_2.f90 @@ -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" } diff --git a/gcc/testsuite/gfortran.dg/coarray_3.f90 b/gcc/testsuite/gfortran.dg/coarray_3.f90 new file mode 100644 index 00000000000..648f2fa9b39 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_3.f90 @@ -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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 70700a303a0..78c6b04e9c9 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,9 @@ +2010-04-06 Tobias Burnus + + PR fortran/39997 + * runtime/stop.c (error_stop_string): New function. + * gfortran.map (_gfortran_error_stop_string): Add. + 2010-04-02 Ralf Wildenhues * 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 diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 3541d142a7b..bcca95788f3 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -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; diff --git a/libgfortran/runtime/stop.c b/libgfortran/runtime/stop.c index 8c4247d1b4e..14a88c418cd 100644 --- a/libgfortran/runtime/stop.c +++ b/libgfortran/runtime/stop.c @@ -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 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); +}