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

2011-06-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.h (gfc_statement): Add ST_LOCK and ST_UNLOCK.
        (gfc_exec_op): Add EXEC_LOCK and EXEC_UNLOCK.
        (gfc_code): Add expr4.
        * match.h (gfc_match_lock, gfc_match_unlock): New prototypes.
        * match.c (gfc_match_lock, gfc_match_unlock,
        lock_unlock_statement): New functions.
        (sync_statement): Bug fix, avoiding double freeing.
        (gfc_match_if): Handle LOCK/UNLOCK statement.
        * parse.c (decode_statement, next_statement,
        gfc_ascii_statement): Ditto.
        * st.c (gfc_free_statement): Handle LOCK and UNLOCK.
        * resolve.c (resolve_lock_unlock): New function.
        (resolve_code): Call it.
        * dump-parse-tree.c (show_code_node): Handle LOCK/UNLOCK.
        * frontend-passes.c (gfc_code_walker): Optimize gfc_code's expr4.

2011-06-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray_lock_1.f90: New.
        * gfortran.dg/coarray_lock_2.f90: New.

From-SVN: r174796

gcc/fortran/ChangeLog

@@ -1,3 +1,21 @@
+2011-06-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.h (gfc_statement): Add ST_LOCK and ST_UNLOCK.
+	(gfc_exec_op): Add EXEC_LOCK and EXEC_UNLOCK.
+	(gfc_code): Add expr4.
+	* match.h (gfc_match_lock, gfc_match_unlock): New prototypes.
+	* match.c (gfc_match_lock, gfc_match_unlock,
+	lock_unlock_statement): New functions.
+	(sync_statement): Bug fix, avoiding double freeing.
+	(gfc_match_if): Handle LOCK/UNLOCK statement.
+	* parse.c (decode_statement, next_statement,
+	gfc_ascii_statement): Ditto.
+	* st.c (gfc_free_statement): Handle LOCK and UNLOCK.
+	* resolve.c (resolve_lock_unlock): New function.
+	(resolve_code): Call it.
+	* dump-parse-tree.c (show_code_node): Handle LOCK/UNLOCK.
+
 2011-06-07  Richard Guenther  <rguenther@suse.de>
 
 	* f95-lang.c (gfc_init_decl_processing): Do not set

gcc/fortran/dump-parse-tree.c

@@ -1396,6 +1396,33 @@ show_code_node (int level, gfc_code *c)
 	}
       break;
 
+    case EXEC_LOCK:
+    case EXEC_UNLOCK:
+      if (c->op == EXEC_LOCK)
+	fputs ("LOCK ", dumpfile);
+      else
+	fputs ("UNLOCK ", dumpfile);
+
+      fputs ("lock-variable=", dumpfile);
+      if (c->expr1 != NULL)
+	show_expr (c->expr1);
+      if (c->expr4 != NULL)
+	{
+	  fputs (" acquired_lock=", dumpfile);
+	  show_expr (c->expr4);
+	}
+      if (c->expr2 != NULL)
+	{
+	  fputs (" stat=", dumpfile);
+	  show_expr (c->expr2);
+	}
+      if (c->expr3 != NULL)
+	{
+	  fputs (" errmsg=", dumpfile);
+	  show_expr (c->expr3);
+	}
+      break;
+
     case EXEC_ARITHMETIC_IF:
       fputs ("IF ", dumpfile);
       show_expr (c->expr1);

gcc/fortran/frontend-passes.c

@@ -1190,6 +1190,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
 	  WALK_SUBEXPR (co->expr1);
 	  WALK_SUBEXPR (co->expr2);
 	  WALK_SUBEXPR (co->expr3);
+	  WALK_SUBEXPR (co->expr4);
 	  for (b = co->block; b; b = b->block)
 	    {
 	      WALK_SUBEXPR (b->expr1);

gcc/fortran/gfortran.h

@@ -208,7 +208,7 @@ typedef enum
   ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
   ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK,
   ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
-  ST_GET_FCN_CHARACTERISTICS, ST_NONE
+  ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE
 }
 gfc_statement;
 
@@ -2056,6 +2056,7 @@ typedef enum
   EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
   EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
   EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
+  EXEC_LOCK, EXEC_UNLOCK,
   EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER,
   EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
   EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
@@ -2074,7 +2075,7 @@ typedef struct gfc_code
 
   gfc_st_label *here, *label1, *label2, *label3;
   gfc_symtree *symtree;
-  gfc_expr *expr1, *expr2, *expr3;
+  gfc_expr *expr1, *expr2, *expr3, *expr4;
   /* A name isn't sufficient to identify a subroutine, we need the actual
      symbol for the interface definition.
   const char *sub_name;  */

gcc/fortran/match.c

@@ -1561,6 +1561,7 @@ gfc_match_if (gfc_statement *if_type)
   match ("go to", gfc_match_goto, ST_GOTO)
   match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
   match ("inquire", gfc_match_inquire, ST_INQUIRE)
+  match ("lock", gfc_match_lock, ST_LOCK)
   match ("nullify", gfc_match_nullify, ST_NULLIFY)
   match ("open", gfc_match_open, ST_OPEN)
   match ("pause", gfc_match_pause, ST_NONE)
@@ -1573,6 +1574,7 @@ gfc_match_if (gfc_statement *if_type)
   match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
   match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
   match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
+  match ("unlock", gfc_match_unlock, ST_UNLOCK)
   match ("where", match_simple_where, ST_WHERE)
   match ("write", gfc_match_write, ST_WRITE)
 
@@ -2305,6 +2307,190 @@ gfc_match_error_stop (void)
 }
 
 
+/* Match LOCK/UNLOCK statement. Syntax:
+     LOCK ( lock-variable [ , lock-stat-list ] )
+     UNLOCK ( lock-variable [ , sync-stat-list ] )
+   where lock-stat is ACQUIRED_LOCK or sync-stat
+   and sync-stat is STAT= or ERRMSG=.  */
+
+static match
+lock_unlock_statement (gfc_statement st)
+{
+  match m;
+  gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
+  bool saw_acq_lock, saw_stat, saw_errmsg;
+
+  tmp = lockvar = acq_lock = stat = errmsg = NULL;
+  saw_acq_lock = saw_stat = saw_errmsg = false;
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("Image control statement SYNC at %C in PURE procedure");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_implicit_pure (NULL))
+    gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+       return MATCH_ERROR;
+    }
+
+  if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
+    {
+      gfc_error ("Image control statement SYNC at %C in CRITICAL block");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  if (gfc_match ("%e", &lockvar) != MATCH_YES)
+    goto syntax;
+  m = gfc_match_char (',');
+  if (m == MATCH_ERROR)
+    goto syntax;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_char (')');
+      if (m == MATCH_YES)
+	goto done;
+      goto syntax;
+    }
+
+  for (;;)
+    {
+      m = gfc_match (" stat = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto syntax;
+      if (m == MATCH_YES)
+	{
+	  if (saw_stat)
+	    {
+	      gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+	      goto cleanup;
+	    }
+	  stat = tmp;
+	  saw_stat = true;
+
+	  m = gfc_match_char (',');
+	  if (m == MATCH_YES)
+	    continue;
+
+	  tmp = NULL;
+	  break;
+	}
+
+      m = gfc_match (" errmsg = %v", &tmp);
+      if (m == MATCH_ERROR)
+	goto syntax;
+      if (m == MATCH_YES)
+	{
+	  if (saw_errmsg)
+	    {
+	      gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+	      goto cleanup;
+	    }
+	  errmsg = tmp;
+	  saw_errmsg = true;
+
+	  m = gfc_match_char (',');
+	  if (m == MATCH_YES)
+	    continue;
+
+	  tmp = NULL;
+	  break;
+	}
+
+      m = gfc_match (" acquired_lock = %v", &tmp);
+      if (m == MATCH_ERROR || st == ST_UNLOCK)
+	goto syntax;
+      if (m == MATCH_YES)
+	{
+	  if (saw_acq_lock)
+	    {
+	      gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
+			 &tmp->where);
+	      goto cleanup;
+	    }
+	  acq_lock = tmp;
+	  saw_acq_lock = true;
+
+	  m = gfc_match_char (',');
+	  if (m == MATCH_YES)
+	    continue;
+
+	  tmp = NULL;
+	  break;
+	}
+
+      break;
+    }
+
+  if (m == MATCH_ERROR)
+    goto syntax;
+
+  if (gfc_match (" )%t") != MATCH_YES)
+    goto syntax;
+
+done:
+  switch (st)
+    {
+    case ST_LOCK:
+      new_st.op = EXEC_LOCK;
+      break;
+    case ST_UNLOCK:
+      new_st.op = EXEC_UNLOCK;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
+  new_st.expr1 = lockvar;
+  new_st.expr2 = stat;
+  new_st.expr3 = errmsg;
+  new_st.expr4 = acq_lock;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (st);
+
+cleanup:
+  gfc_free_expr (tmp);
+  gfc_free_expr (lockvar);
+  gfc_free_expr (acq_lock);
+  gfc_free_expr (stat);
+  gfc_free_expr (errmsg);
+
+  return MATCH_ERROR;
+}
+
+
+match
+gfc_match_lock (void)
+{
+  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: LOCK statement at %C")
+      == FAILURE)
+    return MATCH_ERROR;
+
+  return lock_unlock_statement (ST_LOCK);
+}
+
+
+match
+gfc_match_unlock (void)
+{
+  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: UNLOCK statement at %C")
+      == FAILURE)
+    return MATCH_ERROR;
+
+  return lock_unlock_statement (ST_UNLOCK);
+}
+
+
 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
      SYNC ALL [(sync-stat-list)]
      SYNC MEMORY [(sync-stat-list)]
@@ -2396,6 +2582,9 @@ sync_statement (gfc_statement st)
 
 	  if (gfc_match_char (',') == MATCH_YES)
 	    continue;
+
+	  tmp = NULL;
+	  break;
 	}
 
       m = gfc_match (" errmsg = %v", &tmp);
@@ -2413,16 +2602,17 @@ sync_statement (gfc_statement st)
 
 	  if (gfc_match_char (',') == MATCH_YES)
 	    continue;
-	}
 
-      gfc_gobble_whitespace ();
+	  tmp = NULL;
-
-      if (gfc_peek_char () == ')')
 	  break;
-
-      goto syntax;
 	}
 
+	break;
+    }
+
+  if (m == MATCH_ERROR)
+    goto syntax;
+
   if (gfc_match (" )%t") != MATCH_YES)
     goto syntax;
 

gcc/fortran/match.h

@@ -74,6 +74,7 @@ match gfc_match_associate (void);
 match gfc_match_do (void);
 match gfc_match_cycle (void);
 match gfc_match_exit (void);
+match gfc_match_lock (void);
 match gfc_match_pause (void);
 match gfc_match_stop (void);
 match gfc_match_error_stop (void);
@@ -83,6 +84,7 @@ match gfc_match_goto (void);
 match gfc_match_sync_all (void);
 match gfc_match_sync_images (void);
 match gfc_match_sync_memory (void);
+match gfc_match_unlock (void);
 
 match gfc_match_allocate (void);
 match gfc_match_nullify (void);

gcc/fortran/parse.c

@@ -398,6 +398,10 @@ decode_statement (void)
       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
       break;
 
+    case 'l':
+      match ("lock", gfc_match_lock, ST_LOCK);
+      break;
+
     case 'm':
       match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
       match ("module", gfc_match_module, ST_MODULE);
@@ -449,6 +453,7 @@ decode_statement (void)
       break;
 
     case 'u':
+      match ("unlock", gfc_match_unlock, ST_UNLOCK);
       match ("use", gfc_match_use, ST_USE);
       break;
 
@@ -953,7 +958,8 @@ next_statement (void)
   case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
   case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
   case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_ERROR_STOP: \
-  case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY
+  case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: \
+  case ST_LOCK: case ST_UNLOCK
 
 /* Statements that mark other executable statements.  */
 
@@ -1334,6 +1340,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_INTERFACE:
       p = "INTERFACE";
       break;
+    case ST_LOCK:
+      p = "LOCK";
+      break;
     case ST_PARAMETER:
       p = "PARAMETER";
       break;
@@ -1394,6 +1403,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_TYPE:
       p = "TYPE";
       break;
+    case ST_UNLOCK:
+      p = "UNLOCK";
+      break;
     case ST_USE:
       p = "USE";
       break;

gcc/fortran/resolve.c

@@ -8198,6 +8198,40 @@ find_reachable_labels (gfc_code *block)
 }
 
 
+static void
+resolve_lock_unlock (gfc_code *code)
+{
+  /* FIXME: Add more lock-variable checks. For now, always reject it.
+     Note that ISO_FORTRAN_ENV's LOCK_TYPE is not yet available.  */
+  /* if (code->expr2->ts.type != BT_DERIVED
+	 || code->expr2->rank != 0
+	 || code->expr2->expr_type != EXPR_VARIABLE)  */
+  gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
+	     &code->expr1->where);
+
+  /* Check STAT.  */
+  if (code->expr2
+      && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
+	  || code->expr2->expr_type != EXPR_VARIABLE))
+    gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
+	       &code->expr2->where);
+
+  /* Check ERRMSG.  */
+  if (code->expr3
+      && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
+	  || code->expr3->expr_type != EXPR_VARIABLE))
+    gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
+	       &code->expr3->where);
+
+  /* Check ACQUIRED_LOCK.  */
+  if (code->expr4
+      && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
+	  || code->expr4->expr_type != EXPR_VARIABLE))
+    gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
+	       "variable", &code->expr4->where);
+}
+
+
 static void
 resolve_sync (gfc_code *code)
 {
@@ -9065,6 +9099,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  resolve_sync (code);
 	  break;
 
+	case EXEC_LOCK:
+	case EXEC_UNLOCK:
+	  resolve_lock_unlock (code);
+	  break;
+
 	case EXEC_ENTRY:
 	  /* Keep track of which entry we are up to.  */
 	  current_entry_id = code->ext.entry->id;

gcc/fortran/st.c

@@ -113,6 +113,8 @@ gfc_free_statement (gfc_code *p)
     case EXEC_SYNC_ALL:
     case EXEC_SYNC_IMAGES:
     case EXEC_SYNC_MEMORY:
+    case EXEC_LOCK:
+    case EXEC_UNLOCK:
       break;
 
     case EXEC_BLOCK:

gcc/testsuite/ChangeLog

@@ -1,3 +1,9 @@
+2011-06-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.dg/coarray_lock_1.f90: New.
+	* gfortran.dg/coarray_lock_2.f90: New.
+
 2011-06-07  Jason Merrill  <jason@redhat.com>
 
 	* lib/prune.exp: Look for "required" rather than "instantiated".

gcc/testsuite/gfortran.dg/coarray_lock_1.f90

@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single -std=f2008" }
+!
+! LOCK/UNLOCK intrinsics
+!
+! PR fortran/18918
+!
+integer :: a[*]
+integer :: s
+character(len=3) :: c
+logical :: bool
+
+LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" }
+UNLOCK (a, stat=s, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" }
+end

gcc/testsuite/gfortran.dg/coarray_lock_2.f90

@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single -std=f2003" }
+!
+! LOCK/UNLOCK intrinsics
+!
+! PR fortran/18918
+!
+integer :: a[*] ! { dg-error "Fortran 2008: Coarray declaration" }
+integer :: s
+character(len=3) :: c
+logical :: bool
+
+LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "Fortran 2008: LOCK statement" }
+UNLOCK (a, stat=s, errmsg=c) ! { dg-error "Fortran 2008: UNLOCK statement" }
+end