re PR fortran/38282 (Bit intrinsics: ILEN and IBCHNG)

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.

From-SVN: r163898

12 files changed, 525 insertions, 196 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0d8a590..e661b44 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,30 @@
+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-05  Tobias Burnus <burnus@net-b.de>
 
 	PR fortran/45186
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 0ff6b6e..308895d 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2353,6 +2353,26 @@ gfc_check_product_sum (gfc_actual_arglist *ap)
 }
 
 
+/* For IANY, IALL and IPARITY.  */
+
+gfc_try
+gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
+{
+  if (ap->expr->ts.type != BT_INTEGER)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
+                 gfc_current_intrinsic_arg[0]->name,
+                 gfc_current_intrinsic, &ap->expr->where);
+      return FAILURE;
+    }
+
+  if (array_check (ap->expr, 0) == FAILURE)
+    return FAILURE;
+
+  return check_reduction (ap);
+}
+
+
 gfc_try
 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
 {
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 3c15521..06ef0c5 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -397,7 +397,9 @@ enum gfc_isym_id
   GFC_ISYM_HUGE,
   GFC_ISYM_HYPOT,
   GFC_ISYM_IACHAR,
+  GFC_ISYM_IALL,
   GFC_ISYM_IAND,
+  GFC_ISYM_IANY,
   GFC_ISYM_IARGC,
   GFC_ISYM_IBCLR,
   GFC_ISYM_IBITS,
@@ -412,6 +414,7 @@ enum gfc_isym_id
   GFC_ISYM_INT2,
   GFC_ISYM_INT8,
   GFC_ISYM_IOR,
+  GFC_ISYM_IPARITY,
   GFC_ISYM_IRAND,
   GFC_ISYM_ISATTY,
   GFC_ISYM_IS_IOSTAT_END,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 8176035..f36484a 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1777,6 +1777,20 @@ add_functions (void)
 
   make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU);
 
+  add_sym_3red ("iall", GFC_ISYM_IALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
+		gfc_check_transf_bit_intrins, gfc_simplify_iall, gfc_resolve_iall,
+		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+		msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("iall", GFC_ISYM_IALL, GFC_STD_F2008);
+
+  add_sym_3red ("iany", GFC_ISYM_IANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
+		gfc_check_transf_bit_intrins, gfc_simplify_iany, gfc_resolve_iany,
+		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+		msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("iany", GFC_ISYM_IANY, GFC_STD_F2008);
+
   add_sym_0 ("iargc", GFC_ISYM_IARGC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
 	     di, GFC_STD_GNU, NULL, NULL, NULL);
 
@@ -1885,6 +1899,13 @@ add_functions (void)
 
   make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU);
 
+  add_sym_3red ("iparity", GFC_ISYM_IPARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
+		gfc_check_transf_bit_intrins, gfc_simplify_iparity, gfc_resolve_iparity,
+		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+		msk, BT_LOGICAL, dl, OPTIONAL);
+
+  make_generic ("iparity", GFC_ISYM_IPARITY, GFC_STD_F2008);
+
   /* The following function is for G77 compatibility.  */
   add_sym_1 ("irand", GFC_ISYM_IRAND, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
 	     4, GFC_STD_GNU, gfc_check_irand, NULL, NULL,
@@ -3737,6 +3758,9 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
     /* Same here. The difference to the previous case is that we allow a
        general numeric type.  */
     t = gfc_check_product_sum (*ap);
+  else if (specific->check.f3red == gfc_check_transf_bit_intrins)
+    /* Same as for PRODUCT and SUM, but different checks.  */
+    t = gfc_check_transf_bit_intrins (*ap);
   else
      {
        if (specific->check.f1 == NULL)
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index b06c65b..178dbf7 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -144,6 +144,7 @@ gfc_try gfc_check_stat (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_storage_size (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_symlnk (gfc_expr *, gfc_expr *);
+gfc_try gfc_check_transf_bit_intrins (gfc_actual_arglist *);
 gfc_try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_transpose (gfc_expr *);
 gfc_try gfc_check_trim (gfc_expr *);
@@ -260,7 +261,9 @@ gfc_expr *gfc_simplify_gamma (gfc_expr *);
 gfc_expr *gfc_simplify_huge (gfc_expr *);
 gfc_expr *gfc_simplify_hypot (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_iachar (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_iall (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_iand (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_iany (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_ibclr (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *);
@@ -275,6 +278,7 @@ gfc_expr *gfc_simplify_long (gfc_expr *);
 gfc_expr *gfc_simplify_ifix (gfc_expr *);
 gfc_expr *gfc_simplify_idint (gfc_expr *);
 gfc_expr *gfc_simplify_ior (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_iparity (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_is_iostat_end (gfc_expr *);
 gfc_expr *gfc_simplify_is_iostat_eor (gfc_expr *);
 gfc_expr *gfc_simplify_isnan (gfc_expr *);
@@ -441,12 +445,15 @@ void gfc_resolve_ierrno (gfc_expr *);
 void gfc_resolve_ieor (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_ichar (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_iachar (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_iall (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_iany (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_idnint (gfc_expr *, gfc_expr *);
 void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_int2 (gfc_expr *, gfc_expr *);
 void gfc_resolve_int8 (gfc_expr *, gfc_expr *);
 void gfc_resolve_long (gfc_expr *, gfc_expr *);
 void gfc_resolve_ior (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_iparity (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_isatty (gfc_expr *, gfc_expr *);
 void gfc_resolve_rshift (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_lshift (gfc_expr *, gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index e78bb0d..bea3b36 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -139,7 +139,9 @@ Some basic guidelines for editing this document:
 * @code{HUGE}:          HUGE,      Largest number of a kind
 * @code{HYPOT}:         HYPOT,     Euclidian distance function
 * @code{IACHAR}:        IACHAR,    Code in @acronym{ASCII} collating sequence
+* @code{IALL}:          IALL,      Bitwise AND of array elements
 * @code{IAND}:          IAND,      Bitwise logical and
+* @code{IANY}:          IANY,      Bitwise OR of array elements
 * @code{IARGC}:         IARGC,     Get the number of command line arguments
 * @code{IBCLR}:         IBCLR,     Clear bit
 * @code{IBITS}:         IBITS,     Bit extraction
@@ -148,13 +150,14 @@ Some basic guidelines for editing this document:
 * @code{IDATE}:         IDATE,     Current local time (day/month/year)
 * @code{IEOR}:          IEOR,      Bitwise logical exclusive or
 * @code{IERRNO}:        IERRNO,    Function to get the last system error number
+* @code{IMAGE_INDEX}:   IMAGE_INDEX, Cosubscript to image index convertion
 * @code{INDEX}:         INDEX intrinsic, Position of a substring within a string
 * @code{INT}:           INT,       Convert to integer type
 * @code{INT2}:          INT2,      Convert to 16-bit integer type
 * @code{INT8}:          INT8,      Convert to 64-bit integer type
 * @code{IOR}:           IOR,       Bitwise logical or
+* @code{IPARITY}:       IPARITY,   Bitwise XOR of array elements
 * @code{IRAND}:         IRAND,     Integer pseudo-random number
-* @code{IMAGE_INDEX}:   IMAGE_INDEX, Cosubscript to image index convertion
 * @code{IS_IOSTAT_END}:  IS_IOSTAT_END, Test for end-of-file value
 * @code{IS_IOSTAT_EOR}:  IS_IOSTAT_EOR, Test for end-of-record value
 * @code{ISATTY}:        ISATTY,    Whether a unit is a terminal device
@@ -5580,6 +5583,66 @@ and formatted string representations.
 
 
 
+@node IALL
+@section @code{IALL} --- Bitwise AND of array elements
+@fnindex IALL
+@cindex array, AND
+@cindex bits, AND of array elements
+
+@table @asis
+@item @emph{Description}:
+Reduces with bitwise AND the elements of @var{ARRAY} along dimension @var{DIM}
+if the corresponding element in @var{MASK} is @code{TRUE}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = IALL(ARRAY[, MASK])}
+@item @code{RESULT = IALL(ARRAY, DIM[, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{ARRAY}.
+@item @var{MASK}  @tab (Optional) shall be of type @code{LOGICAL} 
+and either be a scalar or an array of the same shape as @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{ARRAY}.
+
+If @var{DIM} is absent, a scalar with the bitwise ALL of all elements in
+@var{ARRAY} is returned. Otherwise, an array of rank n-1, where n equals
+the rank of @var{ARRAY}, and a shape similar to that of @var{ARRAY} with
+dimension @var{DIM} dropped is returned.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_iall
+  INTEGER(1) :: a(2)
+
+  a(1) = b'00100100'
+  a(1) = b'01101010'
+
+  ! prints 00100000
+  PRINT '(b8.8)', IALL(a)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{IANY}, @ref{IPARITY}, @ref{IAND}
+@end table
+
+
+
 @node IAND
 @section @code{IAND} --- Bitwise logical and
 @fnindex IAND
@@ -5628,6 +5691,66 @@ END PROGRAM
 
 
 
+@node IANY
+@section @code{IANY} --- Bitwise XOR of array elements
+@fnindex IANY
+@cindex array, OR
+@cindex bits, OR of array elements
+
+@table @asis
+@item @emph{Description}:
+Reduces with bitwise OR (inclusive or) the elements of @var{ARRAY} along
+dimension @var{DIM} if the corresponding element in @var{MASK} is @code{TRUE}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = IANY(ARRAY[, MASK])}
+@item @code{RESULT = IANY(ARRAY, DIM[, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{ARRAY}.
+@item @var{MASK}  @tab (Optional) shall be of type @code{LOGICAL} 
+and either be a scalar or an array of the same shape as @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{ARRAY}.
+
+If @var{DIM} is absent, a scalar with the bitwise OR of all elements in
+@var{ARRAY} is returned. Otherwise, an array of rank n-1, where n equals
+the rank of @var{ARRAY}, and a shape similar to that of @var{ARRAY} with
+dimension @var{DIM} dropped is returned.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_iany
+  INTEGER(1) :: a(2)
+
+  a(1) = b'00100100'
+  a(1) = b'01101010'
+
+  ! prints 01111011
+  PRINT '(b8.8)', IANY(a)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{IPARITY}, @ref{IALL}, @ref{IOR}
+@end table
+
+
+
 @node IARGC
 @section @code{IARGC} --- Get the number of command line arguments
 @fnindex IARGC
@@ -5977,6 +6100,50 @@ kind.
 
 
 
+@node IMAGE_INDEX
+@section @code{IMAGE_INDEX} --- Function that converts a cosubscript to an image index
+@fnindex IMAGE_INDEX
+@cindex coarray, IMAGE_INDEX
+@cindex images, cosubscript to image index conversion
+
+@table @asis
+@item @emph{Description}:
+Returns the image index belonging to a cosubscript.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Inquiry function.
+
+@item @emph{Syntax}:
+@code{RESULT = IMAGE_INDEX(COARRAY, SUB)}
+
+@item @emph{Arguments}: None.
+@multitable @columnfractions .15 .70
+@item @var{COARRAY} @tab Coarray of any type.
+@item @var{SUB}     @tab default integer rank-1 array of a size equal to
+the corank of @var{COARRAY}.
+@end multitable
+
+
+@item @emph{Return value}:
+Scalar default integer with the value of the image index which corresponds
+to the cosubscripts. For invalid cosubscripts the result is zero.
+
+@item @emph{Example}:
+@smallexample
+INTEGER :: array[2,-1:4,8,*]
+! Writes  28 (or 0 if there are fewer than 28 images)
+WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1])
+@end smallexample
+
+@item @emph{See also}:
+@ref{THIS_IMAGE}, @ref{NUM_IMAGES}
+@end table
+
+
+
 @node INDEX intrinsic
 @section @code{INDEX} --- Position of a substring within a string
 @fnindex INDEX
@@ -6204,6 +6371,67 @@ the larger argument.)
 
 
 
+@node IPARITY
+@section @code{IPARITY} --- Bitwise XOR of array elements
+@fnindex IPARITY
+@cindex array, parity
+@cindex array, XOR
+@cindex bits, XOR of array elements
+
+@table @asis
+@item @emph{Description}:
+Reduces with bitwise XOR (exclusive or) the elements of @var{ARRAY} along
+dimension @var{DIM} if the corresponding element in @var{MASK} is @code{TRUE}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = IPARITY(ARRAY[, MASK])}
+@item @code{RESULT = IPARITY(ARRAY, DIM[, MASK])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER}
+@item @var{DIM}   @tab (Optional) shall be a scalar of type 
+@code{INTEGER} with a value in the range from 1 to n, where n 
+equals the rank of @var{ARRAY}.
+@item @var{MASK}  @tab (Optional) shall be of type @code{LOGICAL} 
+and either be a scalar or an array of the same shape as @var{ARRAY}.
+@end multitable
+
+@item @emph{Return value}:
+The result is of the same type as @var{ARRAY}.
+
+If @var{DIM} is absent, a scalar with the bitwise XOR of all elements in
+@var{ARRAY} is returned. Otherwise, an array of rank n-1, where n equals
+the rank of @var{ARRAY}, and a shape similar to that of @var{ARRAY} with
+dimension @var{DIM} dropped is returned.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_iparity
+  INTEGER(1) :: a(2)
+
+  a(1) = b'00100100'
+  a(1) = b'01101010'
+
+  ! prints 10111011
+  PRINT '(b8.8)', IPARITY(a)
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{IANY}, @ref{IALL}, @ref{IEOR}, @ref{PARITY}
+@end table
+
+
+
 @node IRAND
 @section @code{IRAND} --- Integer pseudo-random number
 @fnindex IRAND
@@ -6255,50 +6483,6 @@ end program test_irand
 
 
 
-@node IMAGE_INDEX
-@section @code{IMAGE_INDEX} --- Function that converts a cosubscript to an image index
-@fnindex IMAGE_INDEX
-@cindex coarray, IMAGE_INDEX
-@cindex images, cosubscript to image index conversion
-
-@table @asis
-@item @emph{Description}:
-Returns the image index belonging to a cosubscript.
-
-@item @emph{Standard}:
-Fortran 2008 and later
-
-@item @emph{Class}:
-Inquiry function.
-
-@item @emph{Syntax}:
-@code{RESULT = IMAGE_INDEX(COARRAY, SUB)}
-
-@item @emph{Arguments}: None.
-@multitable @columnfractions .15 .70
-@item @var{COARRAY} @tab Coarray of any type.
-@item @var{SUB}     @tab default integer rank-1 array of a size equal to
-the corank of @var{COARRAY}.
-@end multitable
-
-
-@item @emph{Return value}:
-Scalar default integer with the value of the image index which corresponds
-to the cosubscripts. For invalid cosubscripts the result is zero.
-
-@item @emph{Example}:
-@smallexample
-INTEGER :: array[2,-1:4,8,*]
-! Writes  28 (or 0 if there are fewer than 28 images)
-WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1])
-@end smallexample
-
-@item @emph{See also}:
-@ref{THIS_IMAGE}, @ref{NUM_IMAGES}
-@end table
-
-
-
 @node IS_IOSTAT_END
 @section @code{IS_IOSTAT_END} --- Test for end-of-file value
 @fnindex IS_IOSTAT_END
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 66df99e..9aab499 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);
 }
 
 
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 8649597..248df6c 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -620,6 +620,30 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d
 }
 
 
+static gfc_expr *
+simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
+			 int init_val, transformational_op op)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (array)
+      || !gfc_is_constant_expr (dim))
+    return NULL;
+
+  if (mask
+      && !is_constant_array_expr (mask)
+      && mask->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = transformational_result (array, dim, array->ts.type,
+				    array->ts.kind, &array->where);
+  init_result_expr (result, init_val, NULL);
+
+  return !dim || array->rank == 1 ?
+    simplify_transformation_to_scalar (result, array, mask, op) :
+    simplify_transformation_to_array (result, array, dim, mask, op, NULL);
+}
+
 
 /********************** Simplification functions *****************************/
 
@@ -888,19 +912,7 @@ gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
 gfc_expr *
 gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
 {
-  gfc_expr *result;
-
-  if (!is_constant_array_expr (mask)
-      || !gfc_is_constant_expr (dim))
-    return NULL;
-
-  result = transformational_result (mask, dim, mask->ts.type,
-				    mask->ts.kind, &mask->where);
-  init_result_expr (result, true, NULL);
-
-  return !dim || mask->rank == 1 ?
-    simplify_transformation_to_scalar (result, mask, NULL, gfc_and) :
-    simplify_transformation_to_array (result, mask, dim, NULL, gfc_and, NULL);
+  return simplify_transformation (mask, dim, NULL, true, gfc_and);
 }
 
 
@@ -974,19 +986,7 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y)
 gfc_expr *
 gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
 {
-  gfc_expr *result;
-
-  if (!is_constant_array_expr (mask)
-      || !gfc_is_constant_expr (dim))
-    return NULL;
-
-  result = transformational_result (mask, dim, mask->ts.type,
-				    mask->ts.kind, &mask->where);
-  init_result_expr (result, false, NULL);
-
-  return !dim || mask->rank == 1 ?
-    simplify_transformation_to_scalar (result, mask, NULL, gfc_or) :
-    simplify_transformation_to_array (result, mask, dim, NULL, gfc_or, NULL);
+  return simplify_transformation (mask, dim, NULL, false, gfc_or);
 }
 
 
@@ -2231,6 +2231,44 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
 }
 
 
+static gfc_expr *
+do_bit_and (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_INTEGER
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpz_and (result->value.integer, result->value.integer, e->value.integer);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, -1, do_bit_and);
+}
+
+
+static gfc_expr *
+do_bit_ior (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_INTEGER
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpz_ior (result->value.integer, result->value.integer, e->value.integer);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, 0, do_bit_ior);
+}
+
+
 gfc_expr *
 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
 {
@@ -2683,6 +2721,26 @@ gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
 }
 
 
+static gfc_expr *
+do_bit_xor (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_INTEGER
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpz_xor (result->value.integer, result->value.integer, e->value.integer);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, 0, do_bit_xor);
+}
+
+
+
 gfc_expr *
 gfc_simplify_is_iostat_end (gfc_expr *x)
 {
@@ -4277,18 +4335,7 @@ do_xor (gfc_expr *result, gfc_expr *e)
 gfc_expr *
 gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
 {
-  gfc_expr *result;
-
-  if (!is_constant_array_expr (e)
-      || (dim != NULL && !gfc_is_constant_expr (dim)))
-    return NULL;
-
-  result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
-  init_result_expr (result, 0, NULL);
-
-  return (!dim || e->rank == 1)
-    ? simplify_transformation_to_scalar (result, e, NULL, do_xor)
-    : simplify_transformation_to_array (result, e, dim, NULL, do_xor, NULL);
+  return simplify_transformation (e, dim, NULL, 0, do_xor);
 }
 
 
@@ -4345,24 +4392,7 @@ gfc_simplify_precision (gfc_expr *e)
 gfc_expr *
 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 {
-  gfc_expr *result;
-
-  if (!is_constant_array_expr (array)
-      || !gfc_is_constant_expr (dim))
-    return NULL;
-
-  if (mask
-      && !is_constant_array_expr (mask)
-      && mask->expr_type != EXPR_CONSTANT)
-    return NULL;
-
-  result = transformational_result (array, dim, array->ts.type,
-				    array->ts.kind, &array->where);
-  init_result_expr (result, 1, NULL);
-
-  return !dim || array->rank == 1 ?
-    simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
-    simplify_transformation_to_array (result, array, dim, mask, gfc_multiply, NULL);
+  return simplify_transformation (array, dim, mask, 1, gfc_multiply);
 }
 
 
@@ -5508,24 +5538,7 @@ gfc_simplify_sqrt (gfc_expr *e)
 gfc_expr *
 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 {
-  gfc_expr *result;
-
-  if (!is_constant_array_expr (array)
-      || !gfc_is_constant_expr (dim))
-    return NULL;
-
-  if (mask
-      && !is_constant_array_expr (mask)
-      && mask->expr_type != EXPR_CONSTANT)
-    return NULL;
-
-  result = transformational_result (array, dim, array->ts.type,
-				    array->ts.kind, &array->where);
-  init_result_expr (result, 0, NULL);
-
-  return !dim || array->rank == 1 ?
-    simplify_transformation_to_scalar (result, array, mask, gfc_add) :
-    simplify_transformation_to_array (result, array, dim, mask, gfc_add, NULL);
+  return simplify_transformation (array, dim, mask, 0, gfc_add);
 }
 
 
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 38b7ecc..c49908b 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2004,11 +2004,14 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
 		      gfc_build_const (type, integer_one_node));
       tmp = gfc_build_const (type, integer_zero_node);
     }
-  else if (op == PLUS_EXPR)
+  else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
     tmp = gfc_build_const (type, integer_zero_node);
   else if (op == NE_EXPR)
     /* PARITY.  */
     tmp = convert (type, boolean_false_node);
+  else if (op == BIT_AND_EXPR)
+    tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
+						  type, integer_one_node));
   else
     tmp = gfc_build_const (type, integer_one_node);
 
@@ -5530,10 +5533,18 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_fraction (se, expr);
       break;
 
+    case GFC_ISYM_IALL:
+      gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
+      break;
+
     case GFC_ISYM_IAND:
       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
       break;
 
+    case GFC_ISYM_IANY:
+      gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
+      break;
+
     case GFC_ISYM_IBCLR:
       gfc_conv_intrinsic_singlebitop (se, expr, 0);
       break;
@@ -5576,6 +5587,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
       break;
 
+    case GFC_ISYM_IPARITY:
+      gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
+      break;
+
     case GFC_ISYM_IS_IOSTAT_END:
       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
       break;
@@ -5919,6 +5934,9 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
     case GFC_ISYM_ANY:
     case GFC_ISYM_COUNT:
     case GFC_ISYM_JN2:
+    case GFC_ISYM_IANY:
+    case GFC_ISYM_IALL:
+    case GFC_ISYM_IPARITY:
     case GFC_ISYM_MATMUL:
     case GFC_ISYM_MAXLOC:
     case GFC_ISYM_MAXVAL:
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index da06cd3..ac57935 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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  Jason Merrill  <jason@redhat.com>
 
 	* g++.dg/cpp0x/initlist42.C: New.
diff --git a/gcc/testsuite/gfortran.dg/iall_iany_iparity_1.f90 b/gcc/testsuite/gfortran.dg/iall_iany_iparity_1.f90
new file mode 100644
index 0000000..35b4e16
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/iall_iany_iparity_1.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+!
+! PR fortran/38282
+!
+implicit none
+integer :: a(2,1)
+
+a(1,1) = 35
+a(2,1) = -74
+
+if (iand(a(1,1),a(2,1)) /= iall(a)) call abort ()
+if (iand(a(1,1),a(2,1)) /= iall(array=[35, -74])) call abort ()
+if (any (iand(a(1,1),a(2,1)) /= iall(a,dim=1))) call abort ()
+if (iand(a(1,1),a(2,1)) /= iall(dim=1,mask=[.true.,.true.],array=[35, -74])) call abort ()
+
+if (ior(a(1,1),a(2,1)) /= iany(a)) call abort ()
+if (ior(a(1,1),a(2,1)) /= iany(array=[35, -74])) call abort ()
+if (any (ior(a(1,1),a(2,1)) /= iany(a,dim=1))) call abort ()
+if (ior(a(1,1),a(2,1)) /= iany(dim=1,mask=[.true.,.true.],array=[35, -74])) call abort ()
+
+if (ieor(a(1,1),a(2,1)) /= iparity(a)) call abort ()
+if (ieor(a(1,1),a(2,1)) /= iparity(array=[35, -74])) call abort ()
+if (any (ieor(a(1,1),a(2,1)) /= iparity(a,dim=1))) call abort ()
+if (ieor(a(1,1),a(2,1)) /= iparity(dim=1,mask=[.true.,.true.],array=[35, -74])) call abort ()
+
+end
diff --git a/gcc/testsuite/gfortran.dg/iall_iany_iparity_2.f90 b/gcc/testsuite/gfortran.dg/iall_iany_iparity_2.f90
new file mode 100644
index 0000000..4872ddf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/iall_iany_iparity_2.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! PR fortran/38282
+!
+implicit none
+integer :: a(2,1)
+
+a(1,1) = 35
+a(2,1) = -74
+
+if (iand(a(1,1),a(2,1)) /= iall(a)) stop 1 ! { dg-error " .iall. at .1. has no IMPLICIT type" }
+
+if (ior(a(1,1),a(2,1)) /= iany(a)) stop 1 ! { dg-error " .iany. at .1. has no IMPLICIT type" }
+
+if (ieor(a(1,1),a(2,1)) /= iparity(a)) stop 1 ! { dg-error " .iparity. at .1. has no IMPLICIT type" }
+
+end