check.c (check_co_collective): Reject coindexed A args.

2014-10-24  Tobias Burnus  <burnus@net-b.de>

gcc/fortran
        * check.c (check_co_collective): Reject coindexed A args.
        (gfc_check_co_reduce): Add OPERATOR checks.
        * gfortran.texi (_gfortran_caf_co_broadcast,
        * _gfortran_caf_co_max,
        _gfortran_caf_co_min, _gfortran_caf_co_sum,
        _gfortran_caf_co_reduce): Add ABI documentation.
        * intrinsic.texi (CO_REDUCE): Document intrinsic.
        (DPROD): Returns double not single precision.
        * trans-decl.c (gfor_fndecl_co_reduce): New global var.
        (gfc_build_builtin_function_decls): Init it.
        * trans.h (gfor_fndecl_co_reduce): Declare it.
        * trans-intrinsic.c (conv_co_collective,
        gfc_conv_intrinsic_subroutine): Handle CO_REDUCE.

gcc/testsuite/
        * gfortran.dg/coarray_collectives_9.f90: Remove dg-error.
        * gfortran.dg/coarray_collectives_13.f90: New.
        * gfortran.dg/coarray_collectives_14.f90: New.
        * gfortran.dg/coarray_collectives_15.f90: New.
        * gfortran.dg/coarray_collectives_16.f90: New.

From-SVN: r216678

1 files changed, 153 insertions, 20 deletions

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 0a08c73..6f1fe3f 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1433,6 +1433,13 @@ check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
       return false;
     }
 
+  if (gfc_is_coindexed (a))
+    {
+      gfc_error ("The A argument at %L to the intrinsic %s shall not be "
+		 "coindexed", &a->where, gfc_current_intrinsic);
+      return false;
+    }
+
   if (image_idx != NULL)
     {
       if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER))
@@ -1490,10 +1497,10 @@ gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat,
 {
   if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp)
     {
-       gfc_error ("Support for the A argument at %L which is polymorphic A "
-                  "argument or has allocatable components is not yet "
-		  "implemented", &a->where);
-       return false;
+      gfc_error ("Support for the A argument at %L which is polymorphic A "
+		 "argument or has allocatable components is not yet "
+		 "implemented", &a->where);
+      return false;
     }
   return check_co_collective (a, source_image, stat, errmsg, false);
 }
@@ -1504,38 +1511,164 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
 		     gfc_expr *stat, gfc_expr *errmsg)
 {
   symbol_attribute attr;
+  gfc_formal_arglist *formal;
+  gfc_symbol *sym;
 
   if (a->ts.type == BT_CLASS)
     {
-       gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
-		  &a->where);
-       return false;
+      gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
+		 &a->where);
+      return false;
     }
 
   if (gfc_expr_attr (a).alloc_comp)
     {
-       gfc_error ("Support for the A argument at %L with allocatable components"
-                  " is not yet implemented", &a->where);
-       return false;
+      gfc_error ("Support for the A argument at %L with allocatable components"
+                 " is not yet implemented", &a->where);
+      return false;
     }
 
+  if (!check_co_collective (a, result_image, stat, errmsg, true))
+    return false;
+
+  if (!gfc_resolve_expr (op))
+    return false;
+
   attr = gfc_expr_attr (op);
   if (!attr.pure || !attr.function)
     {
-       gfc_error ("OPERATOR argument at %L must be a PURE function",
-		  &op->where);
-       return false;
+      gfc_error ("OPERATOR argument at %L must be a PURE function",
+		 &op->where);
+      return false;
     }
 
-  if (!check_co_collective (a, result_image, stat, errmsg, true))
-    return false;
+  if (attr.intrinsic)
+    {
+      /* None of the intrinsics fulfills the criteria of taking two arguments,
+	 returning the same type and kind as the arguments and being permitted
+	 as actual argument.  */
+      gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
+		 op->symtree->n.sym->name, &op->where);
+      return false;
+    }
 
-  /* FIXME: After J3/WG5 has decided what they actually exactly want, more
-     checks such as same-argument checks have to be added, implemented and
-     intrinsic.texi upated.  */
+  if (gfc_is_proc_ptr_comp (op))
+    {
+      gfc_component *comp = gfc_get_proc_ptr_comp (op);
+      sym = comp->ts.interface;
+    }
+  else
+    sym = op->symtree->n.sym;
 
-  gfc_error("CO_REDUCE at %L is not yet implemented", &a->where);
-  return false;
+  formal = sym->formal;
+
+  if (!formal || !formal->next || formal->next->next)
+    {
+      gfc_error ("The function passed as OPERATOR at %L shall have two "
+		 "arguments", &op->where);
+      return false;
+    }
+
+  if (sym->result->ts.type == BT_UNKNOWN)
+    gfc_set_default_type (sym->result, 0, NULL);
+
+  if (!gfc_compare_types (&a->ts, &sym->result->ts))
+    {
+      gfc_error ("A argument at %L has type %s but the function passed as "
+		 "OPERATOR at %L returns %s",
+		 &a->where, gfc_typename (&a->ts), &op->where,
+		 gfc_typename (&sym->result->ts));
+      return false;
+    }
+  if (!gfc_compare_types (&a->ts, &formal->sym->ts)
+      || !gfc_compare_types (&a->ts, &formal->next->sym->ts))
+    {
+      gfc_error ("The function passed as OPERATOR at %L has arguments of type "
+		 "%s and %s but shall have type %s", &op->where,
+		 gfc_typename (&formal->sym->ts),
+		 gfc_typename (&formal->next->sym->ts), gfc_typename (&a->ts));
+      return false;
+    }
+  if (op->rank || attr.allocatable || attr.pointer || formal->sym->as
+      || formal->next->sym->as || formal->sym->attr.allocatable
+      || formal->next->sym->attr.allocatable || formal->sym->attr.pointer
+      || formal->next->sym->attr.pointer)
+    {
+      gfc_error ("The function passed as OPERATOR at %L shall have scalar "
+		 "nonallocatable nonpointer arguments and return a "
+		 "nonallocatable nonpointer scalar", &op->where);
+      return false;
+    }
+
+  if (formal->sym->attr.value != formal->next->sym->attr.value)
+    {
+      gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
+		 "attribute either for none or both arguments", &op->where);
+      return false;
+    }
+
+  if (formal->sym->attr.target != formal->next->sym->attr.target)
+    {
+      gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
+		 "attribute either for none or both arguments", &op->where);
+      return false;
+    }
+
+  if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous)
+    {
+      gfc_error ("The function passed as OPERATOR at %L shall have the "
+		 "ASYNCHRONOUS attribute either for none or both arguments",
+		 &op->where);
+      return false;
+    }
+
+  if (formal->sym->attr.optional || formal->next->sym->attr.optional)
+    {
+      gfc_error ("The function passed as OPERATOR at %L shall not have the "
+		 "OPTIONAL attribute for either of the arguments", &op->where);
+      return false;
+    }
+
+  if (a->ts.type == BT_CHARACTER)
+    {
+      gfc_charlen *cl;
+      unsigned long actual_size, formal_size1, formal_size2, result_size;
+
+      cl = a->ts.u.cl;
+      actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
+		     ? mpz_get_ui (cl->length->value.integer) : 0;
+
+      cl = formal->sym->ts.u.cl;
+      formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
+		     ? mpz_get_ui (cl->length->value.integer) : 0;
+
+      cl = formal->next->sym->ts.u.cl;
+      formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
+		     ? mpz_get_ui (cl->length->value.integer) : 0;
+
+      cl = sym->ts.u.cl;
+      result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
+		    ? mpz_get_ui (cl->length->value.integer) : 0;
+
+      if (actual_size
+	  && ((formal_size1 && actual_size != formal_size1)
+	       || (formal_size2 && actual_size != formal_size2)))
+	{
+	  gfc_error ("The character length of the A argument at %L and of the "
+		     "arguments of the OPERATOR at %L shall be the same",
+		     &a->where, &op->where);
+	  return false;
+	}
+      if (actual_size && result_size && actual_size != result_size)
+	{
+	  gfc_error ("The character length of the A argument at %L and of the "
+		     "function result of the OPERATOR at %L shall be the same",
+		     &a->where, &op->where);
+	  return false;
+	}
+    }
+
+  return true;
 }