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

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

1 files changed, 94 insertions, 6 deletions

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 2679e92..7d935c3 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;