2010-09-06 Tobias Burnus <burnus@net-b.de>

        PR fortran/38282
        * intrinsic.c (add_functions): Support IALL, IANY, IPARITY.
        (check_specific): Special case for those intrinsics.
        * gfortran.h (gfc_isym_id): Add new intrinsics
        * intrinsic.h (gfc_check_transf_bit_intrins,
        gfc_simplify_iall, gfc_simplify_iany, gfc_simplify_iparity,
        gfc_resolve_iall, gfc_resolve_iany, gfc_resolve_iparity):
        New prototypes.
        * iresolve.c (gfc_resolve_iall, gfc_resolve_iany,
        gfc_resolve_iparity, resolve_transformational): New functions.
        (gfc_resolve_product, gfc_resolve_sum,
        gfc_resolve_parity): Use resolve_transformational.
        * check.c (gfc_check_transf_bit_intrins): New function.
        * simplify.c (gfc_simplify_iall, gfc_simplify_iany,
        gfc_simplify_iparity, do_bit_any, do_bit_ior,
        do_bit_xor, simplify_transformation): New functions.
        (gfc_simplify_all, gfc_simplify_any, gfc_simplify_parity,
        gfc_simplify_sum, gfc_simplify_product): Use simplify_transformation.
        * trans-intrinsic.c (gfc_conv_intrinsic_arith,
        gfc_conv_intrinsic_function, gfc_is_intrinsic_libcall):
        Handle IALL, IANY and IPARITY intrinsics.       
        * intrinsic.texi (IMAGE_INDEX): Move up to fix alphabetic
        order.
        (IALL, IANY, IPARITY): Document new intrinsics.

2010-09-06  Tobias Burnus  <burnus@net-b.de>

        PR fortran/38282
        * gfortran.dg/iall_iany_iparity_1.f90: New.
        * gfortran.dg/iall_iany_iparity_2.f90: New.

2010-09-06  Tobias Burnus  <burnus@net-b.de>

        PR fortran/38282
        * gfortran.map: Add new iany, iall and iparity intrinsics.
        * Makefile.am: Ditto.
        * m4/iany.m4: New.
        * m4/iall.m4: New.
        * m4/iparity.m4: New.
        * Makefile.in: Regenerate.
        * generated/iall_i1.c: Generate.
        * generated/iall_i2.c: Generate.
        * generated/iall_i4.c: Generate.
        * generated/iall_i8.c: Generate.
        * generated/iall_i16.c: Generate.
        * generated/iany_i1.c: Generate.
        * generated/iany_i2.c: Generate.
        * generated/iany_i4.c: Generate.
        * generated/iany_i8.c: Generate.
        * generated/iany_i16.c: Generate.
        * generated/iparity_i1.c: Generate.
        * generated/iparity_i2.c: Generate.
        * generated/iparity_i4.c: Generate.
        * generated/iparity_i8.c: Generate.
        * generated/iparity_i16.c: Generate.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@163898 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 59 insertions, 76 deletions

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 66df99e3bf5..9aab4995f7c 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -141,6 +141,40 @@ resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
   f->value.function.name = xstrdup (name);
 }
 
+
+static void
+resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
+			  gfc_expr *dim, gfc_expr *mask)
+{
+  const char *prefix;
+
+  f->ts = array->ts;
+
+  if (mask)
+    {
+      if (mask->rank == 0)
+	prefix = "s";
+      else
+	prefix = "m";
+
+      resolve_mask_arg (mask);
+    }
+  else
+    prefix = "";
+
+  if (dim != NULL)
+    {
+      f->rank = array->rank - 1;
+      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+      gfc_resolve_dim_arg (dim);
+    }
+
+  f->value.function.name
+    = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
+		    gfc_type_letter (array->ts.type), array->ts.kind);
+}
+
+
 /********************** Resolution functions **********************/
 
 
@@ -1044,6 +1078,13 @@ gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
 
 
 void
+gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  resolve_transformational ("iall", f, array, dim, mask);
+}
+
+
+void
 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 {
   /* If the kind of i and j are different, then g77 cross-promoted the
@@ -1063,6 +1104,13 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 
 
 void
+gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  resolve_transformational ("iany", f, array, dim, mask);
+}
+
+
+void
 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
 {
   f->ts = i->ts;
@@ -1239,6 +1287,13 @@ gfc_resolve_long (gfc_expr *f, gfc_expr *a)
 
 
 void
+gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  resolve_transformational ("iparity", f, array, dim, mask);
+}
+
+
+void
 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
 {
   gfc_typespec ts;
@@ -1827,17 +1882,7 @@ gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 void
 gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
 {
-  f->ts = array->ts;
-
-  if (dim != NULL)
-    {
-      f->rank = array->rank - 1;
-      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
-      gfc_resolve_dim_arg (dim);
-    }
-
-  f->value.function.name
-    = gfc_get_string (PREFIX ("norm2_r%d"), array->ts.kind);
+  resolve_transformational ("norm2", f, array, dim, NULL);
 }
 
 
@@ -1908,19 +1953,7 @@ gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
 void
 gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
 {
-  f->ts = array->ts;
-
-  if (dim != NULL)
-    {
-      f->rank = array->rank - 1;
-      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
-      gfc_resolve_dim_arg (dim);
-    }
-
-  resolve_mask_arg (array);
-
-  f->value.function.name
-    = gfc_get_string (PREFIX ("parity_l%d"), array->ts.kind);
+  resolve_transformational ("parity", f, array, dim, NULL);
 }
 
 
@@ -1928,32 +1961,7 @@ void
 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
 		     gfc_expr *mask)
 {
-  const char *name;
-
-  f->ts = array->ts;
-
-  if (dim != NULL)
-    {
-      f->rank = array->rank - 1;
-      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
-      gfc_resolve_dim_arg (dim);
-    }
-
-  if (mask)
-    {
-      if (mask->rank == 0)
-	name = "sproduct";
-      else
-	name = "mproduct";
-
-      resolve_mask_arg (mask);
-    }
-  else
-    name = "product";
-
-  f->value.function.name
-    = gfc_get_string (PREFIX ("%s_%c%d"), name,
-		      gfc_type_letter (array->ts.type), array->ts.kind);
+  resolve_transformational ("product", f, array, dim, mask);
 }
 
 
@@ -2412,32 +2420,7 @@ gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
 void
 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 {
-  const char *name;
-
-  f->ts = array->ts;
-
-  if (mask)
-    {
-      if (mask->rank == 0)
-	name = "ssum";
-      else
-	name = "msum";
-
-      resolve_mask_arg (mask);
-    }
-  else
-    name = "sum";
-
-  if (dim != NULL)
-    {
-      f->rank = array->rank - 1;
-      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
-      gfc_resolve_dim_arg (dim);
-    }
-
-  f->value.function.name
-    = gfc_get_string (PREFIX ("%s_%c%d"), name,
-		    gfc_type_letter (array->ts.type), array->ts.kind);
+  resolve_transformational ("sum", f, array, dim, mask);
 }