re PR fortran/44646 ([F08] Implement DO CONCURRENT)

gcc/fortran/
2011-09-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/44646
        * decl.c (gfc_match_entry, gfc_match_end): Handle
        * COMP_DO_CONCURRENT.
        * dump-parse-tree.c (show_code_node): Handle EXEC_DO_CONCURRENT.
        * gfortran.h (gfc_exec_op): Add EXEC_DO_CONCURRENT.
        * match.c (gfc_match_critical, match_exit_cycle,
        * gfc_match_stopcode,
        lock_unlock_statement, sync_statement, gfc_match_allocate,
        gfc_match_deallocate, gfc_match_return): Add DO CONCURRENT diagnostic.
        (gfc_match_do): Match DO CONCURRENT.
        (match_derived_type_spec, match_type_spec, gfc_free_forall_iterator,
        match_forall_iterator, match_forall_header, match_simple_forall,
        gfc_match_forall): Move up in the file.
        * parse.c (check_do_closure, parse_do_block): Handle do
        * concurrent.
        * parse.h (gfc_compile_state): Add COMP_DO_CONCURRENT.
        * resolve.c (do_concurrent_flag): New global variable.
        (resolve_function, pure_subroutine, resolve_branch,
        gfc_resolve_blocks, resolve_code, resolve_types): Add do concurrent
        diagnostic.
        * st.c (gfc_free_statement): Handle EXEC_DO_CONCURRENT.
        * trans-stmt.c (gfc_trans_do_concurrent): New function.
        (gfc_trans_forall_1): Handle do concurrent.
        * trans-stmt.h (gfc_trans_do_concurrent): New function
        * prototype.
        * trans.c (trans_code): Call it.
        * frontend-passes.c (gfc_code_walker): Handle
        * EXEC_DO_CONCURRENT.

gcc/testsuite/
2011-09-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/44646
        * gfortran.dg/do_concurrent_1.f90: New.
        * gfortran.dg/do_concurrent_2.f90: New.

From-SVN: r178677

1 files changed, 40 insertions, 7 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a12e6e7..b038402 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -58,9 +58,10 @@ code_stack;
 static code_stack *cs_base = NULL;
 
 
-/* Nonzero if we're inside a FORALL block.  */
+/* Nonzero if we're inside a FORALL or DO CONCURRENT block.  */
 
 static int forall_flag;
+static int do_concurrent_flag;
 
 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */
 
@@ -3159,11 +3160,18 @@ resolve_function (gfc_expr *expr)
     {
       if (forall_flag)
 	{
-	  gfc_error ("reference to non-PURE function '%s' at %L inside a "
+	  gfc_error ("Reference to non-PURE function '%s' at %L inside a "
 		     "FORALL %s", name, &expr->where,
 		     forall_flag == 2 ? "mask" : "block");
 	  t = FAILURE;
 	}
+      else if (do_concurrent_flag)
+	{
+	  gfc_error ("Reference to non-PURE function '%s' at %L inside a "
+		     "DO CONCURRENT %s", name, &expr->where,
+		     do_concurrent_flag == 2 ? "mask" : "block");
+	  t = FAILURE;
+	}
       else if (gfc_pure (NULL))
 	{
 	  gfc_error ("Function reference to '%s' at %L is to a non-PURE "
@@ -3230,6 +3238,9 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym)
   if (forall_flag)
     gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
 	       sym->name, &c->loc);
+  else if (do_concurrent_flag)
+    gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
+	       "PURE", sym->name, &c->loc);
   else if (gfc_pure (NULL))
     gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
 	       &c->loc);
@@ -8385,10 +8396,16 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
 	 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);
+	{
+	  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);
+	  else if (stack->current->op == EXEC_DO_CONCURRENT
+		   && bitmap_bit_p (stack->reachable_labels, label->value))
+	    gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
+		      "for label at %L", &code->loc, &label->where);
+	}
 
       return;
     }
@@ -8409,6 +8426,12 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
 		      " at %L", &code->loc, &label->where);
 	  return;
 	}
+      else if (stack->current->op == EXEC_DO_CONCURRENT)
+	{
+	  gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
+		     "label at %L", &code->loc, &label->where);
+	  return;
+	}
     }
 
   if (stack)
@@ -8832,6 +8855,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
 	case EXEC_FORALL:
 	case EXEC_DO:
 	case EXEC_DO_WHILE:
+	case EXEC_DO_CONCURRENT:
 	case EXEC_CRITICAL:
 	case EXEC_READ:
 	case EXEC_WRITE:
@@ -9071,7 +9095,7 @@ static void
 resolve_code (gfc_code *code, gfc_namespace *ns)
 {
   int omp_workshare_save;
-  int forall_save;
+  int forall_save, do_concurrent_save;
   code_stack frame;
   gfc_try t;
 
@@ -9085,6 +9109,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
     {
       frame.current = code;
       forall_save = forall_flag;
+      do_concurrent_save = do_concurrent_flag;
 
       if (code->op == EXEC_FORALL)
 	{
@@ -9117,6 +9142,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	      /* Blocks are handled in resolve_select_type because we have
 		 to transform the SELECT TYPE into ASSOCIATE first.  */
 	      break;
+            case EXEC_DO_CONCURRENT:
+	      do_concurrent_flag = 1;
+	      gfc_resolve_blocks (code->block, ns);
+	      do_concurrent_flag = 2;
+	      break;
 	    case EXEC_OMP_WORKSHARE:
 	      omp_workshare_save = omp_workshare_flag;
 	      omp_workshare_flag = 1;
@@ -9134,6 +9164,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
       if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
 	t = gfc_resolve_expr (code->expr1);
       forall_flag = forall_save;
+      do_concurrent_flag = do_concurrent_save;
 
       if (gfc_resolve_expr (code->expr2) == FAILURE)
 	t = FAILURE;
@@ -9401,6 +9432,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  resolve_transfer (code);
 	  break;
 
+	case EXEC_DO_CONCURRENT:
 	case EXEC_FORALL:
 	  resolve_forall_iterators (code->ext.forall_iterator);
 
@@ -13570,6 +13602,7 @@ resolve_types (gfc_namespace *ns)
     }
 
   forall_flag = 0;
+  do_concurrent_flag = 0;
   gfc_check_interfaces (ns);
 
   gfc_traverse_ns (ns, resolve_values);