Second review of STAT= patch + tests

From-SVN: r238007

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0947d6dce733b54cebc8f8f84a48c8a4e6def536..ed6b40b1408209fdd508b80e31b0a137116d3096 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2016-07-05  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
+
+       * array.c (gfc_match_array_ref): Add parsing support for
+       STAT= attribute in CAF reference.
+       * expr.c (gfc_find_stat_co): New function that returns
+       the STAT= assignment.
+       * gfortran.h (gfc_array_ref): New member.
+       * trans-decl.c (gfc_build_builtin_function_decls):
+       new attribute for caf_get and caf_send functions.
+       * trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Passing
+       the stat attribute to external function.
+       (gfc_conv_intrinsic_caf_send): Ditto.
+
 2016-07-05  Andre Vehreschild  <vehre@gcc.gnu.org>
 
        PR fortran/71623

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 1430e80251d66368dabadefec905279710ad0c9e..03c8b17178c014339647da62a7b2170b2e18e6c0 100644 (file)
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -156,6 +156,8 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
 {
   match m;
   bool matched_bracket = false;
+  gfc_expr *tmp;
+  bool stat_just_seen = false;
 
   memset (ar, '\0', sizeof (*ar));
 
@@ -220,12 +222,27 @@ coarray:
        return MATCH_ERROR;
     }
 
+  ar->stat = NULL;
+
   for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
     {
       m = match_subscript (ar, init, true);
       if (m == MATCH_ERROR)
        return MATCH_ERROR;
 
+      stat_just_seen = false;
+      if (gfc_match(" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL)
+       {
+         ar->stat = tmp;
+         stat_just_seen = true;
+       }
+
+      if (ar->stat && !stat_just_seen)
+       {
+         gfc_error ("STAT= attribute in %C misplaced");
+         return MATCH_ERROR;
+       }
+
       if (gfc_match_char (']') == MATCH_YES)
        {
          ar->codimen++;

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index d1258cdf380f5e5b1967c75bddaf388a4119c9ea..7328898f2b6479cd3d8d501f492a9b3e87b50f82 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4428,6 +4428,23 @@ gfc_ref_this_image (gfc_ref *ref)
   return true;
 }
 
+gfc_expr *
+gfc_find_stat_co(gfc_expr *e)
+{
+  gfc_ref *ref;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+      return ref->u.ar.stat;
+
+  if(e->value.function.actual->expr)
+    for(ref = e->value.function.actual->expr->ref; ref;
+       ref = ref->next)
+      if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+       return ref->u.ar.stat;
+
+  return NULL;
+}
 
 bool
 gfc_is_coindexed (gfc_expr *e)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 0bb71cb184d195842ebcc12a8cd5358e56f28423..77831ab31e936561c05c407aa85848b1f9465b4c 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1814,6 +1814,7 @@ typedef struct gfc_array_ref
   int dimen;                   /* # of components in the reference */
   int codimen;
   bool in_allocate;            /* For coarray checks. */
+  gfc_expr *stat;
   locus where;
   gfc_array_spec *as;
 
@@ -3065,7 +3066,7 @@ bool gfc_is_coarray (gfc_expr *);
 int gfc_get_corank (gfc_expr *);
 bool gfc_has_ultimate_allocatable (gfc_expr *);
 bool gfc_has_ultimate_pointer (gfc_expr *);
-
+gfc_expr* gfc_find_stat_co (gfc_expr *);
 gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*,
                                    locus, unsigned, ...);
 bool gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*);

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 5626753c5d59f041db8b1beaab5a216ba961c448..f026bea5d866ee45fbd8b2849dccfd50d08f17b6 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3526,16 +3526,16 @@ gfc_build_builtin_function_decls (void)
         ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
 
       gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
-       get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node, 9,
+       get_identifier (PREFIX("caf_get")), ".R.RRRWW", void_type_node, 10,
         pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
        pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
-       boolean_type_node);
+       boolean_type_node, pint_type);
 
       gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
-       get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node, 9,
+       get_identifier (PREFIX("caf_send")), ".R.RRRRW", void_type_node, 10,
         pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
        pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
-       boolean_type_node);
+       boolean_type_node, pint_type);
 
       gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
        get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRR", void_type_node,

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 574300eabb53caa5a9c7424ab31fd4ab65cdf96b..c6555400a497523494b6c0f1e5e9ac5912b3f61a 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1100,10 +1100,10 @@ static void
 gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
                            tree may_require_tmp)
 {
-  gfc_expr *array_expr;
+  gfc_expr *array_expr, *tmp_stat;
   gfc_se argse;
   tree caf_decl, token, offset, image_index, tmp;
-  tree res_var, dst_var, type, kind, vec;
+  tree res_var, dst_var, type, kind, vec, stat;
 
   gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
 
@@ -1122,6 +1122,19 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
   dst_var = lhs;
 
   vec = null_pointer_node;
+  tmp_stat = gfc_find_stat_co(expr);
+
+  if (tmp_stat)
+    {
+      gfc_se stat_se;
+      gfc_init_se(&stat_se, NULL);
+      gfc_conv_expr_reference (&stat_se, tmp_stat);
+      stat = stat_se.expr;
+      gfc_add_block_to_block (&se->pre, &stat_se.pre);
+      gfc_add_block_to_block (&se->post, &stat_se.post);
+    }
+  else
+    stat = null_pointer_node;
 
   gfc_init_se (&argse, NULL);
   if (array_expr->rank == 0)
@@ -1219,9 +1232,9 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
   ASM_VOLATILE_P (tmp) = 1;
   gfc_add_expr_to_block (&se->pre, tmp);
 
-  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 9,
+  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10,
                             token, offset, image_index, argse.expr, vec,
-                            dst_var, kind, lhs_kind, may_require_tmp);
+                            dst_var, kind, lhs_kind, may_require_tmp, stat);
   gfc_add_expr_to_block (&se->pre, tmp);
 
   if (se->ss)
@@ -1237,11 +1250,11 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
 
 static tree
 conv_caf_send (gfc_code *code) {
-  gfc_expr *lhs_expr, *rhs_expr;
+  gfc_expr *lhs_expr, *rhs_expr, *tmp_stat;
   gfc_se lhs_se, rhs_se;
   stmtblock_t block;
   tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
-  tree may_require_tmp;
+  tree may_require_tmp, stat;
   tree lhs_type = NULL_TREE;
   tree vec = null_pointer_node, rhs_vec = null_pointer_node;
 
@@ -1253,6 +1266,8 @@ conv_caf_send (gfc_code *code) {
                    ? boolean_false_node : boolean_true_node;
   gfc_init_block (&block);
 
+  stat = null_pointer_node;
+
   /* LHS.  */
   gfc_init_se (&lhs_se, NULL);
   if (lhs_expr->rank == 0)
@@ -1375,10 +1390,25 @@ conv_caf_send (gfc_code *code) {
 
   rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
 
+  tmp_stat = gfc_find_stat_co(lhs_expr);
+
+  if (tmp_stat)
+    {
+      gfc_se stat_se;
+      gfc_init_se (&stat_se, NULL);
+      gfc_conv_expr_reference (&stat_se, tmp_stat);
+      stat = stat_se.expr;
+      gfc_add_block_to_block (&block, &stat_se.pre);
+      gfc_add_block_to_block (&block, &stat_se.post);
+    }
+  else
+    stat = null_pointer_node;
+
   if (!gfc_is_coindexed (rhs_expr))
-    tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 9, token,
-                            offset, image_index, lhs_se.expr, vec,
-                            rhs_se.expr, lhs_kind, rhs_kind, may_require_tmp);
+    tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 10, token,
+                              offset, image_index, lhs_se.expr, vec,
+                              rhs_se.expr, lhs_kind, rhs_kind, may_require_tmp,
+                              stat);
   else
     {
       tree rhs_token, rhs_offset, rhs_image_index;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2db9b450df9fc90c89aa766eb32b652a82aa9a76..944dbb66160fd2eb089a7ee1ea229b25a53b3b2d 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2016-07-05  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
+
+       * gfortran.dg/coarray_stat_function.f90: New test.
+       * gfortran.dg/coarray_stat_whitespace.f90: New test.
+       * gfortran.dg/coarray_lib_comm_1: Adapting old test
+       to new interfaces.
+
 2016-07-05  Andre Vehreschild  <vehre@gcc.gnu.org>
 
        PR fortran/71623

diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90
index d23c9d18a7a817e381e81f44fba3096ab603f73d..7b4d9375de586f0e3244c4a7c67bfacbf2320b0c 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90
@@ -38,9 +38,8 @@ B(1:5) = B(3:7)
 if (any (A-B /= 0)) call abort
 end
 
-! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0\\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 1\\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 1\\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.1, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) b, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 0\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0, 0B\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 1, 0B\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 1, 0B\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.1, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) b, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 0, 0B\\\);" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 0\\\);" 1 "original" } }
-

diff --git a/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 b/gcc/testsuite/gfortran.dg/coarray_stat_function.f90
new file mode 100644 (file)
index 0000000..c29687e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_stat_function.f90
@@ -0,0 +1,45 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=lib" }
+!
+program function_stat
+  implicit none
+
+  integer :: me[*],tmp,stat,stat2,next
+
+  me = this_image()
+  next = me + 1
+  if(me == num_images()) next = 1
+  stat = 0
+
+  sync all(stat=stat)
+
+  if(stat /= 0) write(*,*) 'Image failed during sync'
+
+  stat = 0
+  if(me == 1) then
+     tmp = func(me[4,stat=stat])
+     if(stat /= 0) write(*,*) me,'failure in func arg'
+   else if(me == 2) then
+      tmp = func2(me[1,stat=stat2],me[3,stat=stat])
+      if(stat2 /= 0 .or. stat /= 0) write(*,*) me,'failure in func2 args'
+  endif
+
+contains
+
+  function func(remote_me)
+    integer func
+    integer remote_me
+    func = remote_me
+  end function func
+
+  function func2(remote_me,remote_neighbor)
+    integer func2
+    integer remote_me,remote_neighbor
+    func2 = remote_me + remote_neighbor
+  end function func2
+  
+end program function_stat
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 4, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 1, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat2\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 3, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } }

diff --git a/gcc/testsuite/gfortran.dg/coarray_stat_whitespace.f90 b/gcc/testsuite/gfortran.dg/coarray_stat_whitespace.f90
new file mode 100644 (file)
index 0000000..aa790b9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_stat_whitespace.f90
@@ -0,0 +1,29 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib" }
+!
+! Support for stat= in caf reference
+!
+program whitespace
+  implicit none
+
+  integer :: me[*],tmp,stat,i
+
+  me = this_image()
+  stat = 0
+  i = 1
+
+  sync all(stat = stat)
+
+  if(stat /= 0) write(*,*) 'failure during sync'
+
+  stat = 0
+
+  if(me == 1) then
+     tmp = me[num_images(),stat = stat]
+     if(stat /= 0) write(*,*) 'failure in img:',me
+  else if(me == 2) then
+     tmp = me[i,stat=stat]
+     if(stat /= 0) write(*,*) 'failure in img:',me
+  endif
+
+end program whitespace