+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
}
+/* 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)
{
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,
GFC_ISYM_INT2,
GFC_ISYM_INT8,
GFC_ISYM_IOR,
+ GFC_ISYM_IPARITY,
GFC_ISYM_IRAND,
GFC_ISYM_ISATTY,
GFC_ISYM_IS_IOSTAT_END,
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);
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,
/* 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)
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 *);
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 *);
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 *);
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 *);
* @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
* @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
+@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
+@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
+@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
+@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
-@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
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 **********************/
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
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;
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;
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);
}
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);
}
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);
}
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);
}
}
+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 *****************************/
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);
}
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);
}
}
+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)
{
}
+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)
{
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);
}
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);
}
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);
}
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);
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;
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;
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:
+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.
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+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.
+
2010-09-05 Tobias Burnus <burnus@net-b.de>
* m4/bessel.m4: Fix printf warning by casting to (long int).
$(srcdir)/generated/count_8_l.c \
$(srcdir)/generated/count_16_l.c
+i_iall_c= \
+$(srcdir)/generated/iall_i1.c \
+$(srcdir)/generated/iall_i2.c \
+$(srcdir)/generated/iall_i4.c \
+$(srcdir)/generated/iall_i8.c \
+$(srcdir)/generated/iall_i16.c
+
+i_iany_c= \
+$(srcdir)/generated/iany_i1.c \
+$(srcdir)/generated/iany_i2.c \
+$(srcdir)/generated/iany_i4.c \
+$(srcdir)/generated/iany_i8.c \
+$(srcdir)/generated/iany_i16.c
+
+i_iparity_c= \
+$(srcdir)/generated/iparity_i1.c \
+$(srcdir)/generated/iparity_i2.c \
+$(srcdir)/generated/iparity_i4.c \
+$(srcdir)/generated/iparity_i8.c \
+$(srcdir)/generated/iparity_i16.c
+
i_maxloc0_c= \
$(srcdir)/generated/maxloc0_4_i1.c \
$(srcdir)/generated/maxloc0_8_i1.c \
m4/transpose.m4 m4/eoshift1.m4 m4/eoshift3.m4 m4/exponent.m4 \
m4/fraction.m4 m4/nearest.m4 m4/set_exponent.m4 m4/pow.m4 \
m4/misc_specifics.m4 m4/rrspacing.m4 m4/spacing.m4 m4/pack.m4 \
- m4/unpack.m4 m4/spread.m4 m4/bessel.m4 m4/norm2.m4 m4/parity.m4
+ m4/unpack.m4 m4/spread.m4 m4/bessel.m4 m4/norm2.m4 m4/parity.m4 \
+ m4/iall.m4 m4/iany.m4 m4/iparity.m4
gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
$(i_maxloc1_c) $(i_maxval_c) $(i_minloc0_c) $(i_minloc1_c) $(i_minval_c) \
- $(i_product_c) $(i_sum_c) $(i_bessel_c) $(i_norm2_c) $(i_parity_c) \
+ $(i_product_c) $(i_sum_c) $(i_bessel_c) $(i_iall_c) $(i_iany_c) \
+ $(i_iparity_c) $(i_norm2_c) $(i_parity_c) \
$(i_matmul_c) $(i_matmull_c) $(i_transpose_c) $(i_shape_c) $(i_eoshift1_c) \
$(i_eoshift3_c) $(i_cshift1_c) $(i_reshape_c) $(in_pack_c) $(in_unpack_c) \
$(i_exponent_c) $(i_fraction_c) $(i_nearest_c) $(i_set_exponent_c) \
$(i_count_c): m4/count.m4 $(I_M4_DEPS2)
$(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@
+$(i_iall_c): m4/iall.m4 $(I_M4_DEPS)
+ $(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@
+
+$(i_iany_c): m4/iany.m4 $(I_M4_DEPS)
+ $(M4) -Dfile=$@ -I$(srcdir)/m4 iany.m4 > $@
+
+$(i_iparity_c): m4/iparity.m4 $(I_M4_DEPS)
+ $(M4) -Dfile=$@ -I$(srcdir)/m4 iparity.m4 > $@
+
$(i_maxloc0_c): m4/maxloc0.m4 $(I_M4_DEPS0)
$(M4) -Dfile=$@ -I$(srcdir)/m4 maxloc0.m4 > $@
sum_r4.lo sum_r8.lo sum_r10.lo sum_r16.lo sum_c4.lo sum_c8.lo \
sum_c10.lo sum_c16.lo
am__objects_13 = bessel_r4.lo bessel_r8.lo bessel_r10.lo bessel_r16.lo
-am__objects_14 = norm2_r4.lo norm2_r8.lo norm2_r10.lo norm2_r16.lo
-am__objects_15 = parity_l1.lo parity_l2.lo parity_l4.lo parity_l8.lo \
+am__objects_14 = iall_i1.lo iall_i2.lo iall_i4.lo iall_i8.lo \
+ iall_i16.lo
+am__objects_15 = iany_i1.lo iany_i2.lo iany_i4.lo iany_i8.lo \
+ iany_i16.lo
+am__objects_16 = iparity_i1.lo iparity_i2.lo iparity_i4.lo \
+ iparity_i8.lo iparity_i16.lo
+am__objects_17 = norm2_r4.lo norm2_r8.lo norm2_r10.lo norm2_r16.lo
+am__objects_18 = parity_l1.lo parity_l2.lo parity_l4.lo parity_l8.lo \
parity_l16.lo
-am__objects_16 = matmul_i1.lo matmul_i2.lo matmul_i4.lo matmul_i8.lo \
+am__objects_19 = matmul_i1.lo matmul_i2.lo matmul_i4.lo matmul_i8.lo \
matmul_i16.lo matmul_r4.lo matmul_r8.lo matmul_r10.lo \
matmul_r16.lo matmul_c4.lo matmul_c8.lo matmul_c10.lo \
matmul_c16.lo
-am__objects_17 = matmul_l4.lo matmul_l8.lo matmul_l16.lo
-am__objects_18 = transpose_i4.lo transpose_i8.lo transpose_i16.lo \
+am__objects_20 = matmul_l4.lo matmul_l8.lo matmul_l16.lo
+am__objects_21 = transpose_i4.lo transpose_i8.lo transpose_i16.lo \
transpose_r4.lo transpose_r8.lo transpose_r10.lo \
transpose_r16.lo transpose_c4.lo transpose_c8.lo \
transpose_c10.lo transpose_c16.lo
-am__objects_19 = shape_i4.lo shape_i8.lo shape_i16.lo
-am__objects_20 = eoshift1_4.lo eoshift1_8.lo eoshift1_16.lo
-am__objects_21 = eoshift3_4.lo eoshift3_8.lo eoshift3_16.lo
-am__objects_22 = cshift1_4.lo cshift1_8.lo cshift1_16.lo
-am__objects_23 = reshape_i4.lo reshape_i8.lo reshape_i16.lo \
+am__objects_22 = shape_i4.lo shape_i8.lo shape_i16.lo
+am__objects_23 = eoshift1_4.lo eoshift1_8.lo eoshift1_16.lo
+am__objects_24 = eoshift3_4.lo eoshift3_8.lo eoshift3_16.lo
+am__objects_25 = cshift1_4.lo cshift1_8.lo cshift1_16.lo
+am__objects_26 = reshape_i4.lo reshape_i8.lo reshape_i16.lo \
reshape_r4.lo reshape_r8.lo reshape_r10.lo reshape_r16.lo \
reshape_c4.lo reshape_c8.lo reshape_c10.lo reshape_c16.lo
-am__objects_24 = in_pack_i1.lo in_pack_i2.lo in_pack_i4.lo \
+am__objects_27 = in_pack_i1.lo in_pack_i2.lo in_pack_i4.lo \
in_pack_i8.lo in_pack_i16.lo in_pack_r4.lo in_pack_r8.lo \
in_pack_r10.lo in_pack_r16.lo in_pack_c4.lo in_pack_c8.lo \
in_pack_c10.lo in_pack_c16.lo
-am__objects_25 = in_unpack_i1.lo in_unpack_i2.lo in_unpack_i4.lo \
+am__objects_28 = in_unpack_i1.lo in_unpack_i2.lo in_unpack_i4.lo \
in_unpack_i8.lo in_unpack_i16.lo in_unpack_r4.lo \
in_unpack_r8.lo in_unpack_r10.lo in_unpack_r16.lo \
in_unpack_c4.lo in_unpack_c8.lo in_unpack_c10.lo \
in_unpack_c16.lo
-am__objects_26 = exponent_r4.lo exponent_r8.lo exponent_r10.lo \
+am__objects_29 = exponent_r4.lo exponent_r8.lo exponent_r10.lo \
exponent_r16.lo
-am__objects_27 = fraction_r4.lo fraction_r8.lo fraction_r10.lo \
+am__objects_30 = fraction_r4.lo fraction_r8.lo fraction_r10.lo \
fraction_r16.lo
-am__objects_28 = nearest_r4.lo nearest_r8.lo nearest_r10.lo \
+am__objects_31 = nearest_r4.lo nearest_r8.lo nearest_r10.lo \
nearest_r16.lo
-am__objects_29 = set_exponent_r4.lo set_exponent_r8.lo \
+am__objects_32 = set_exponent_r4.lo set_exponent_r8.lo \
set_exponent_r10.lo set_exponent_r16.lo
-am__objects_30 = pow_i4_i4.lo pow_i8_i4.lo pow_i16_i4.lo pow_c4_i4.lo \
+am__objects_33 = pow_i4_i4.lo pow_i8_i4.lo pow_i16_i4.lo pow_c4_i4.lo \
pow_c8_i4.lo pow_c10_i4.lo pow_c16_i4.lo pow_i4_i8.lo \
pow_i8_i8.lo pow_i16_i8.lo pow_r4_i8.lo pow_r8_i8.lo \
pow_r10_i8.lo pow_r16_i8.lo pow_c4_i8.lo pow_c8_i8.lo \
pow_i16_i16.lo pow_r4_i16.lo pow_r8_i16.lo pow_r10_i16.lo \
pow_r16_i16.lo pow_c4_i16.lo pow_c8_i16.lo pow_c10_i16.lo \
pow_c16_i16.lo
-am__objects_31 = rrspacing_r4.lo rrspacing_r8.lo rrspacing_r10.lo \
+am__objects_34 = rrspacing_r4.lo rrspacing_r8.lo rrspacing_r10.lo \
rrspacing_r16.lo
-am__objects_32 = spacing_r4.lo spacing_r8.lo spacing_r10.lo \
+am__objects_35 = spacing_r4.lo spacing_r8.lo spacing_r10.lo \
spacing_r16.lo
-am__objects_33 = pack_i1.lo pack_i2.lo pack_i4.lo pack_i8.lo \
+am__objects_36 = pack_i1.lo pack_i2.lo pack_i4.lo pack_i8.lo \
pack_i16.lo pack_r4.lo pack_r8.lo pack_r10.lo pack_r16.lo \
pack_c4.lo pack_c8.lo pack_c10.lo pack_c16.lo
-am__objects_34 = unpack_i1.lo unpack_i2.lo unpack_i4.lo unpack_i8.lo \
+am__objects_37 = unpack_i1.lo unpack_i2.lo unpack_i4.lo unpack_i8.lo \
unpack_i16.lo unpack_r4.lo unpack_r8.lo unpack_r10.lo \
unpack_r16.lo unpack_c4.lo unpack_c8.lo unpack_c10.lo \
unpack_c16.lo
-am__objects_35 = spread_i1.lo spread_i2.lo spread_i4.lo spread_i8.lo \
+am__objects_38 = spread_i1.lo spread_i2.lo spread_i4.lo spread_i8.lo \
spread_i16.lo spread_r4.lo spread_r8.lo spread_r10.lo \
spread_r16.lo spread_c4.lo spread_c8.lo spread_c10.lo \
spread_c16.lo
-am__objects_36 = cshift0_i1.lo cshift0_i2.lo cshift0_i4.lo \
+am__objects_39 = cshift0_i1.lo cshift0_i2.lo cshift0_i4.lo \
cshift0_i8.lo cshift0_i16.lo cshift0_r4.lo cshift0_r8.lo \
cshift0_r10.lo cshift0_r16.lo cshift0_c4.lo cshift0_c8.lo \
cshift0_c10.lo cshift0_c16.lo
-am__objects_37 = $(am__objects_2) $(am__objects_3) $(am__objects_4) \
+am__objects_40 = $(am__objects_2) $(am__objects_3) $(am__objects_4) \
$(am__objects_5) $(am__objects_6) $(am__objects_7) \
$(am__objects_8) $(am__objects_9) $(am__objects_10) \
$(am__objects_11) $(am__objects_12) $(am__objects_13) \
$(am__objects_26) $(am__objects_27) $(am__objects_28) \
$(am__objects_29) $(am__objects_30) $(am__objects_31) \
$(am__objects_32) $(am__objects_33) $(am__objects_34) \
- $(am__objects_35) $(am__objects_36)
-am__objects_38 = close.lo file_pos.lo format.lo inquire.lo \
+ $(am__objects_35) $(am__objects_36) $(am__objects_37) \
+ $(am__objects_38) $(am__objects_39)
+am__objects_41 = close.lo file_pos.lo format.lo inquire.lo \
intrinsics.lo list_read.lo lock.lo open.lo read.lo \
size_from_kind.lo transfer.lo unit.lo unix.lo write.lo fbuf.lo
-am__objects_39 = associated.lo abort.lo access.lo args.lo \
+am__objects_42 = associated.lo abort.lo access.lo args.lo \
bit_intrinsics.lo c99_functions.lo chdir.lo chmod.lo clock.lo \
cpu_time.lo cshift0.lo ctime.lo date_and_time.lo dtime.lo \
env.lo eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo \
system_clock.lo time.lo transpose_generic.lo umask.lo \
unlink.lo unpack_generic.lo in_pack_generic.lo \
in_unpack_generic.lo
-am__objects_40 =
-am__objects_41 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
+am__objects_43 =
+am__objects_44 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
_abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \
_abs_r10.lo _abs_r16.lo _aimag_c4.lo _aimag_c8.lo \
_aimag_c10.lo _aimag_c16.lo _exp_r4.lo _exp_r8.lo _exp_r10.lo \
_conjg_c4.lo _conjg_c8.lo _conjg_c10.lo _conjg_c16.lo \
_aint_r4.lo _aint_r8.lo _aint_r10.lo _aint_r16.lo _anint_r4.lo \
_anint_r8.lo _anint_r10.lo _anint_r16.lo
-am__objects_42 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
+am__objects_45 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
_sign_r8.lo _sign_r10.lo _sign_r16.lo _dim_i4.lo _dim_i8.lo \
_dim_i16.lo _dim_r4.lo _dim_r8.lo _dim_r10.lo _dim_r16.lo \
_atan2_r4.lo _atan2_r8.lo _atan2_r10.lo _atan2_r16.lo \
_mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo \
_mod_r10.lo _mod_r16.lo
-am__objects_43 = misc_specifics.lo
-am__objects_44 = $(am__objects_41) $(am__objects_42) $(am__objects_43) \
+am__objects_46 = misc_specifics.lo
+am__objects_47 = $(am__objects_44) $(am__objects_45) $(am__objects_46) \
dprod_r8.lo f2c_specifics.lo
-am__objects_45 = $(am__objects_1) $(am__objects_37) $(am__objects_38) \
- $(am__objects_39) $(am__objects_40) $(am__objects_44)
-@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_45)
+am__objects_48 = $(am__objects_1) $(am__objects_40) $(am__objects_41) \
+ $(am__objects_42) $(am__objects_43) $(am__objects_47)
+@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_48)
@onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo
libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
libgfortranbegin_la_LIBADD =
$(srcdir)/generated/count_8_l.c \
$(srcdir)/generated/count_16_l.c
+i_iall_c = \
+$(srcdir)/generated/iall_i1.c \
+$(srcdir)/generated/iall_i2.c \
+$(srcdir)/generated/iall_i4.c \
+$(srcdir)/generated/iall_i8.c \
+$(srcdir)/generated/iall_i16.c
+
+i_iany_c = \
+$(srcdir)/generated/iany_i1.c \
+$(srcdir)/generated/iany_i2.c \
+$(srcdir)/generated/iany_i4.c \
+$(srcdir)/generated/iany_i8.c \
+$(srcdir)/generated/iany_i16.c
+
+i_iparity_c = \
+$(srcdir)/generated/iparity_i1.c \
+$(srcdir)/generated/iparity_i2.c \
+$(srcdir)/generated/iparity_i4.c \
+$(srcdir)/generated/iparity_i8.c \
+$(srcdir)/generated/iparity_i16.c
+
i_maxloc0_c = \
$(srcdir)/generated/maxloc0_4_i1.c \
$(srcdir)/generated/maxloc0_8_i1.c \
m4/transpose.m4 m4/eoshift1.m4 m4/eoshift3.m4 m4/exponent.m4 \
m4/fraction.m4 m4/nearest.m4 m4/set_exponent.m4 m4/pow.m4 \
m4/misc_specifics.m4 m4/rrspacing.m4 m4/spacing.m4 m4/pack.m4 \
- m4/unpack.m4 m4/spread.m4 m4/bessel.m4 m4/norm2.m4 m4/parity.m4
+ m4/unpack.m4 m4/spread.m4 m4/bessel.m4 m4/norm2.m4 m4/parity.m4 \
+ m4/iall.m4 m4/iany.m4 m4/iparity.m4
gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
$(i_maxloc1_c) $(i_maxval_c) $(i_minloc0_c) $(i_minloc1_c) $(i_minval_c) \
- $(i_product_c) $(i_sum_c) $(i_bessel_c) $(i_norm2_c) $(i_parity_c) \
+ $(i_product_c) $(i_sum_c) $(i_bessel_c) $(i_iall_c) $(i_iany_c) \
+ $(i_iparity_c) $(i_norm2_c) $(i_parity_c) \
$(i_matmul_c) $(i_matmull_c) $(i_transpose_c) $(i_shape_c) $(i_eoshift1_c) \
$(i_eoshift3_c) $(i_cshift1_c) $(i_reshape_c) $(in_pack_c) $(in_unpack_c) \
$(i_exponent_c) $(i_fraction_c) $(i_nearest_c) $(i_set_exponent_c) \
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/getcwd.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/getlog.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/hostnm.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iall_i1.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iall_i16.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iall_i2.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iall_i4.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iall_i8.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iany_i1.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iany_i16.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iany_i2.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iany_i4.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iany_i8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ierrno.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/in_pack_c10.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/in_pack_c16.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/in_unpack_r8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/inquire.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/intrinsics.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iparity_i1.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iparity_i16.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iparity_i2.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iparity_i4.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iparity_i8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ishftc.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iso_c_binding.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iso_c_generated_procs.Plo@am__quote@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o bessel_r16.lo `test -f '$(srcdir)/generated/bessel_r16.c' || echo '$(srcdir)/'`$(srcdir)/generated/bessel_r16.c
+iall_i1.lo: $(srcdir)/generated/iall_i1.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iall_i1.lo -MD -MP -MF $(DEPDIR)/iall_i1.Tpo -c -o iall_i1.lo `test -f '$(srcdir)/generated/iall_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/iall_i1.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iall_i1.Tpo $(DEPDIR)/iall_i1.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iall_i1.c' object='iall_i1.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iall_i1.lo `test -f '$(srcdir)/generated/iall_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/iall_i1.c
+
+iall_i2.lo: $(srcdir)/generated/iall_i2.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iall_i2.lo -MD -MP -MF $(DEPDIR)/iall_i2.Tpo -c -o iall_i2.lo `test -f '$(srcdir)/generated/iall_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/iall_i2.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iall_i2.Tpo $(DEPDIR)/iall_i2.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iall_i2.c' object='iall_i2.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iall_i2.lo `test -f '$(srcdir)/generated/iall_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/iall_i2.c
+
+iall_i4.lo: $(srcdir)/generated/iall_i4.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iall_i4.lo -MD -MP -MF $(DEPDIR)/iall_i4.Tpo -c -o iall_i4.lo `test -f '$(srcdir)/generated/iall_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/iall_i4.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iall_i4.Tpo $(DEPDIR)/iall_i4.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iall_i4.c' object='iall_i4.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iall_i4.lo `test -f '$(srcdir)/generated/iall_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/iall_i4.c
+
+iall_i8.lo: $(srcdir)/generated/iall_i8.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iall_i8.lo -MD -MP -MF $(DEPDIR)/iall_i8.Tpo -c -o iall_i8.lo `test -f '$(srcdir)/generated/iall_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/iall_i8.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iall_i8.Tpo $(DEPDIR)/iall_i8.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iall_i8.c' object='iall_i8.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iall_i8.lo `test -f '$(srcdir)/generated/iall_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/iall_i8.c
+
+iall_i16.lo: $(srcdir)/generated/iall_i16.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iall_i16.lo -MD -MP -MF $(DEPDIR)/iall_i16.Tpo -c -o iall_i16.lo `test -f '$(srcdir)/generated/iall_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/iall_i16.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iall_i16.Tpo $(DEPDIR)/iall_i16.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iall_i16.c' object='iall_i16.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iall_i16.lo `test -f '$(srcdir)/generated/iall_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/iall_i16.c
+
+iany_i1.lo: $(srcdir)/generated/iany_i1.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iany_i1.lo -MD -MP -MF $(DEPDIR)/iany_i1.Tpo -c -o iany_i1.lo `test -f '$(srcdir)/generated/iany_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/iany_i1.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iany_i1.Tpo $(DEPDIR)/iany_i1.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iany_i1.c' object='iany_i1.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iany_i1.lo `test -f '$(srcdir)/generated/iany_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/iany_i1.c
+
+iany_i2.lo: $(srcdir)/generated/iany_i2.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iany_i2.lo -MD -MP -MF $(DEPDIR)/iany_i2.Tpo -c -o iany_i2.lo `test -f '$(srcdir)/generated/iany_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/iany_i2.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iany_i2.Tpo $(DEPDIR)/iany_i2.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iany_i2.c' object='iany_i2.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iany_i2.lo `test -f '$(srcdir)/generated/iany_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/iany_i2.c
+
+iany_i4.lo: $(srcdir)/generated/iany_i4.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iany_i4.lo -MD -MP -MF $(DEPDIR)/iany_i4.Tpo -c -o iany_i4.lo `test -f '$(srcdir)/generated/iany_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/iany_i4.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iany_i4.Tpo $(DEPDIR)/iany_i4.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iany_i4.c' object='iany_i4.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iany_i4.lo `test -f '$(srcdir)/generated/iany_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/iany_i4.c
+
+iany_i8.lo: $(srcdir)/generated/iany_i8.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iany_i8.lo -MD -MP -MF $(DEPDIR)/iany_i8.Tpo -c -o iany_i8.lo `test -f '$(srcdir)/generated/iany_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/iany_i8.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iany_i8.Tpo $(DEPDIR)/iany_i8.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iany_i8.c' object='iany_i8.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iany_i8.lo `test -f '$(srcdir)/generated/iany_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/iany_i8.c
+
+iany_i16.lo: $(srcdir)/generated/iany_i16.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iany_i16.lo -MD -MP -MF $(DEPDIR)/iany_i16.Tpo -c -o iany_i16.lo `test -f '$(srcdir)/generated/iany_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/iany_i16.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iany_i16.Tpo $(DEPDIR)/iany_i16.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iany_i16.c' object='iany_i16.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iany_i16.lo `test -f '$(srcdir)/generated/iany_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/iany_i16.c
+
+iparity_i1.lo: $(srcdir)/generated/iparity_i1.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iparity_i1.lo -MD -MP -MF $(DEPDIR)/iparity_i1.Tpo -c -o iparity_i1.lo `test -f '$(srcdir)/generated/iparity_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/iparity_i1.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iparity_i1.Tpo $(DEPDIR)/iparity_i1.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iparity_i1.c' object='iparity_i1.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iparity_i1.lo `test -f '$(srcdir)/generated/iparity_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/iparity_i1.c
+
+iparity_i2.lo: $(srcdir)/generated/iparity_i2.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iparity_i2.lo -MD -MP -MF $(DEPDIR)/iparity_i2.Tpo -c -o iparity_i2.lo `test -f '$(srcdir)/generated/iparity_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/iparity_i2.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iparity_i2.Tpo $(DEPDIR)/iparity_i2.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iparity_i2.c' object='iparity_i2.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iparity_i2.lo `test -f '$(srcdir)/generated/iparity_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/iparity_i2.c
+
+iparity_i4.lo: $(srcdir)/generated/iparity_i4.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iparity_i4.lo -MD -MP -MF $(DEPDIR)/iparity_i4.Tpo -c -o iparity_i4.lo `test -f '$(srcdir)/generated/iparity_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/iparity_i4.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iparity_i4.Tpo $(DEPDIR)/iparity_i4.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iparity_i4.c' object='iparity_i4.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iparity_i4.lo `test -f '$(srcdir)/generated/iparity_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/iparity_i4.c
+
+iparity_i8.lo: $(srcdir)/generated/iparity_i8.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iparity_i8.lo -MD -MP -MF $(DEPDIR)/iparity_i8.Tpo -c -o iparity_i8.lo `test -f '$(srcdir)/generated/iparity_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/iparity_i8.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iparity_i8.Tpo $(DEPDIR)/iparity_i8.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iparity_i8.c' object='iparity_i8.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iparity_i8.lo `test -f '$(srcdir)/generated/iparity_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/iparity_i8.c
+
+iparity_i16.lo: $(srcdir)/generated/iparity_i16.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT iparity_i16.lo -MD -MP -MF $(DEPDIR)/iparity_i16.Tpo -c -o iparity_i16.lo `test -f '$(srcdir)/generated/iparity_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/iparity_i16.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/iparity_i16.Tpo $(DEPDIR)/iparity_i16.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/iparity_i16.c' object='iparity_i16.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iparity_i16.lo `test -f '$(srcdir)/generated/iparity_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/iparity_i16.c
+
norm2_r4.lo: $(srcdir)/generated/norm2_r4.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT norm2_r4.lo -MD -MP -MF $(DEPDIR)/norm2_r4.Tpo -c -o norm2_r4.lo `test -f '$(srcdir)/generated/norm2_r4.c' || echo '$(srcdir)/'`$(srcdir)/generated/norm2_r4.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/norm2_r4.Tpo $(DEPDIR)/norm2_r4.Plo
@MAINTAINER_MODE_TRUE@$(i_count_c): m4/count.m4 $(I_M4_DEPS2)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@
+@MAINTAINER_MODE_TRUE@$(i_iall_c): m4/iall.m4 $(I_M4_DEPS)
+@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@
+
+@MAINTAINER_MODE_TRUE@$(i_iany_c): m4/iany.m4 $(I_M4_DEPS)
+@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 iany.m4 > $@
+
+@MAINTAINER_MODE_TRUE@$(i_iparity_c): m4/iparity.m4 $(I_M4_DEPS)
+@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 iparity.m4 > $@
+
@MAINTAINER_MODE_TRUE@$(i_maxloc0_c): m4/maxloc0.m4 $(I_M4_DEPS0)
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 maxloc0.m4 > $@
--- /dev/null
+/* Implementation of the IALL intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
+
+
+extern void iall_i1 (gfc_array_i1 * const restrict,
+ gfc_array_i1 * const restrict, const index_type * const restrict);
+export_proto(iall_i1);
+
+void
+iall_i1 (gfc_array_i1 * const restrict retarray,
+ gfc_array_i1 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_1 * restrict base;
+ GFC_INTEGER_1 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IALL intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IALL");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_1 * restrict src;
+ GFC_INTEGER_1 result;
+ src = base;
+ {
+
+ result = (GFC_INTEGER_1) -1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result &= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miall_i1 (gfc_array_i1 * const restrict,
+ gfc_array_i1 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miall_i1);
+
+void
+miall_i1 (gfc_array_i1 * const restrict retarray,
+ gfc_array_i1 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_1 * restrict dest;
+ const GFC_INTEGER_1 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IALL intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IALL");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IALL");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_1 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_1 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result &= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siall_i1 (gfc_array_i1 * const restrict,
+ gfc_array_i1 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siall_i1);
+
+void
+siall_i1 (gfc_array_i1 * const restrict retarray,
+ gfc_array_i1 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_1 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iall_i1 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IALL intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IALL intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IALL intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16)
+
+
+extern void iall_i16 (gfc_array_i16 * const restrict,
+ gfc_array_i16 * const restrict, const index_type * const restrict);
+export_proto(iall_i16);
+
+void
+iall_i16 (gfc_array_i16 * const restrict retarray,
+ gfc_array_i16 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_16 * restrict base;
+ GFC_INTEGER_16 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IALL intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IALL");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_16 * restrict src;
+ GFC_INTEGER_16 result;
+ src = base;
+ {
+
+ result = (GFC_INTEGER_16) -1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result &= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miall_i16 (gfc_array_i16 * const restrict,
+ gfc_array_i16 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miall_i16);
+
+void
+miall_i16 (gfc_array_i16 * const restrict retarray,
+ gfc_array_i16 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_16 * restrict dest;
+ const GFC_INTEGER_16 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IALL intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IALL");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IALL");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_16 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_16 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result &= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siall_i16 (gfc_array_i16 * const restrict,
+ gfc_array_i16 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siall_i16);
+
+void
+siall_i16 (gfc_array_i16 * const restrict retarray,
+ gfc_array_i16 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_16 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iall_i16 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IALL intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IALL intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IALL intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2)
+
+
+extern void iall_i2 (gfc_array_i2 * const restrict,
+ gfc_array_i2 * const restrict, const index_type * const restrict);
+export_proto(iall_i2);
+
+void
+iall_i2 (gfc_array_i2 * const restrict retarray,
+ gfc_array_i2 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_2 * restrict base;
+ GFC_INTEGER_2 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IALL intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IALL");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_2 * restrict src;
+ GFC_INTEGER_2 result;
+ src = base;
+ {
+
+ result = (GFC_INTEGER_2) -1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result &= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miall_i2 (gfc_array_i2 * const restrict,
+ gfc_array_i2 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miall_i2);
+
+void
+miall_i2 (gfc_array_i2 * const restrict retarray,
+ gfc_array_i2 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_2 * restrict dest;
+ const GFC_INTEGER_2 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IALL intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IALL");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IALL");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_2 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_2 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result &= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siall_i2 (gfc_array_i2 * const restrict,
+ gfc_array_i2 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siall_i2);
+
+void
+siall_i2 (gfc_array_i2 * const restrict retarray,
+ gfc_array_i2 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_2 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iall_i2 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IALL intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IALL intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IALL intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
+
+
+extern void iall_i4 (gfc_array_i4 * const restrict,
+ gfc_array_i4 * const restrict, const index_type * const restrict);
+export_proto(iall_i4);
+
+void
+iall_i4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_i4 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_4 * restrict base;
+ GFC_INTEGER_4 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IALL intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IALL");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_4 * restrict src;
+ GFC_INTEGER_4 result;
+ src = base;
+ {
+
+ result = (GFC_INTEGER_4) -1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result &= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miall_i4 (gfc_array_i4 * const restrict,
+ gfc_array_i4 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miall_i4);
+
+void
+miall_i4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_i4 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_4 * restrict dest;
+ const GFC_INTEGER_4 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IALL intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IALL");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IALL");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_4 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_4 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result &= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siall_i4 (gfc_array_i4 * const restrict,
+ gfc_array_i4 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siall_i4);
+
+void
+siall_i4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_i4 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_4 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iall_i4 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IALL intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IALL intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IALL intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8)
+
+
+extern void iall_i8 (gfc_array_i8 * const restrict,
+ gfc_array_i8 * const restrict, const index_type * const restrict);
+export_proto(iall_i8);
+
+void
+iall_i8 (gfc_array_i8 * const restrict retarray,
+ gfc_array_i8 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_8 * restrict base;
+ GFC_INTEGER_8 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IALL intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IALL");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_8 * restrict src;
+ GFC_INTEGER_8 result;
+ src = base;
+ {
+
+ result = (GFC_INTEGER_8) -1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result &= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miall_i8 (gfc_array_i8 * const restrict,
+ gfc_array_i8 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miall_i8);
+
+void
+miall_i8 (gfc_array_i8 * const restrict retarray,
+ gfc_array_i8 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_8 * restrict dest;
+ const GFC_INTEGER_8 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IALL intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IALL");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IALL");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_8 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_8 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result &= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siall_i8 (gfc_array_i8 * const restrict,
+ gfc_array_i8 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siall_i8);
+
+void
+siall_i8 (gfc_array_i8 * const restrict retarray,
+ gfc_array_i8 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_8 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iall_i8 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IALL intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IALL intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IANY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
+
+
+extern void iany_i1 (gfc_array_i1 * const restrict,
+ gfc_array_i1 * const restrict, const index_type * const restrict);
+export_proto(iany_i1);
+
+void
+iany_i1 (gfc_array_i1 * const restrict retarray,
+ gfc_array_i1 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_1 * restrict base;
+ GFC_INTEGER_1 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IANY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IANY");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_1 * restrict src;
+ GFC_INTEGER_1 result;
+ src = base;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result |= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miany_i1 (gfc_array_i1 * const restrict,
+ gfc_array_i1 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miany_i1);
+
+void
+miany_i1 (gfc_array_i1 * const restrict retarray,
+ gfc_array_i1 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_1 * restrict dest;
+ const GFC_INTEGER_1 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IANY intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IANY");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IANY");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_1 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_1 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result |= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siany_i1 (gfc_array_i1 * const restrict,
+ gfc_array_i1 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siany_i1);
+
+void
+siany_i1 (gfc_array_i1 * const restrict retarray,
+ gfc_array_i1 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_1 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iany_i1 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IANY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IANY intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IANY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16)
+
+
+extern void iany_i16 (gfc_array_i16 * const restrict,
+ gfc_array_i16 * const restrict, const index_type * const restrict);
+export_proto(iany_i16);
+
+void
+iany_i16 (gfc_array_i16 * const restrict retarray,
+ gfc_array_i16 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_16 * restrict base;
+ GFC_INTEGER_16 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IANY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IANY");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_16 * restrict src;
+ GFC_INTEGER_16 result;
+ src = base;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result |= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miany_i16 (gfc_array_i16 * const restrict,
+ gfc_array_i16 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miany_i16);
+
+void
+miany_i16 (gfc_array_i16 * const restrict retarray,
+ gfc_array_i16 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_16 * restrict dest;
+ const GFC_INTEGER_16 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IANY intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IANY");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IANY");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_16 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_16 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result |= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siany_i16 (gfc_array_i16 * const restrict,
+ gfc_array_i16 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siany_i16);
+
+void
+siany_i16 (gfc_array_i16 * const restrict retarray,
+ gfc_array_i16 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_16 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iany_i16 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IANY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IANY intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IANY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2)
+
+
+extern void iany_i2 (gfc_array_i2 * const restrict,
+ gfc_array_i2 * const restrict, const index_type * const restrict);
+export_proto(iany_i2);
+
+void
+iany_i2 (gfc_array_i2 * const restrict retarray,
+ gfc_array_i2 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_2 * restrict base;
+ GFC_INTEGER_2 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IANY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IANY");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_2 * restrict src;
+ GFC_INTEGER_2 result;
+ src = base;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result |= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miany_i2 (gfc_array_i2 * const restrict,
+ gfc_array_i2 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miany_i2);
+
+void
+miany_i2 (gfc_array_i2 * const restrict retarray,
+ gfc_array_i2 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_2 * restrict dest;
+ const GFC_INTEGER_2 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IANY intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IANY");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IANY");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_2 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_2 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result |= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siany_i2 (gfc_array_i2 * const restrict,
+ gfc_array_i2 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siany_i2);
+
+void
+siany_i2 (gfc_array_i2 * const restrict retarray,
+ gfc_array_i2 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_2 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iany_i2 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IANY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IANY intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IANY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
+
+
+extern void iany_i4 (gfc_array_i4 * const restrict,
+ gfc_array_i4 * const restrict, const index_type * const restrict);
+export_proto(iany_i4);
+
+void
+iany_i4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_i4 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_4 * restrict base;
+ GFC_INTEGER_4 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IANY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IANY");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_4 * restrict src;
+ GFC_INTEGER_4 result;
+ src = base;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result |= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miany_i4 (gfc_array_i4 * const restrict,
+ gfc_array_i4 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miany_i4);
+
+void
+miany_i4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_i4 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_4 * restrict dest;
+ const GFC_INTEGER_4 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IANY intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IANY");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IANY");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_4 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_4 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result |= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siany_i4 (gfc_array_i4 * const restrict,
+ gfc_array_i4 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siany_i4);
+
+void
+siany_i4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_i4 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_4 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iany_i4 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IANY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IANY intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IANY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8)
+
+
+extern void iany_i8 (gfc_array_i8 * const restrict,
+ gfc_array_i8 * const restrict, const index_type * const restrict);
+export_proto(iany_i8);
+
+void
+iany_i8 (gfc_array_i8 * const restrict retarray,
+ gfc_array_i8 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_8 * restrict base;
+ GFC_INTEGER_8 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IANY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IANY");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_8 * restrict src;
+ GFC_INTEGER_8 result;
+ src = base;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result |= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miany_i8 (gfc_array_i8 * const restrict,
+ gfc_array_i8 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miany_i8);
+
+void
+miany_i8 (gfc_array_i8 * const restrict retarray,
+ gfc_array_i8 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_8 * restrict dest;
+ const GFC_INTEGER_8 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IANY intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IANY");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IANY");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_8 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_8 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result |= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siany_i8 (gfc_array_i8 * const restrict,
+ gfc_array_i8 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siany_i8);
+
+void
+siany_i8 (gfc_array_i8 * const restrict retarray,
+ gfc_array_i8 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_8 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iany_i8 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IANY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IANY intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IPARITY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
+
+
+extern void iparity_i1 (gfc_array_i1 * const restrict,
+ gfc_array_i1 * const restrict, const index_type * const restrict);
+export_proto(iparity_i1);
+
+void
+iparity_i1 (gfc_array_i1 * const restrict retarray,
+ gfc_array_i1 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_1 * restrict base;
+ GFC_INTEGER_1 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IPARITY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IPARITY");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_1 * restrict src;
+ GFC_INTEGER_1 result;
+ src = base;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result ^= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miparity_i1 (gfc_array_i1 * const restrict,
+ gfc_array_i1 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miparity_i1);
+
+void
+miparity_i1 (gfc_array_i1 * const restrict retarray,
+ gfc_array_i1 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_1 * restrict dest;
+ const GFC_INTEGER_1 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IPARITY intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IPARITY");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IPARITY");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_1 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_1 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result ^= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siparity_i1 (gfc_array_i1 * const restrict,
+ gfc_array_i1 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siparity_i1);
+
+void
+siparity_i1 (gfc_array_i1 * const restrict retarray,
+ gfc_array_i1 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_1 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iparity_i1 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IPARITY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IPARITY intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IPARITY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16)
+
+
+extern void iparity_i16 (gfc_array_i16 * const restrict,
+ gfc_array_i16 * const restrict, const index_type * const restrict);
+export_proto(iparity_i16);
+
+void
+iparity_i16 (gfc_array_i16 * const restrict retarray,
+ gfc_array_i16 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_16 * restrict base;
+ GFC_INTEGER_16 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IPARITY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IPARITY");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_16 * restrict src;
+ GFC_INTEGER_16 result;
+ src = base;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result ^= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miparity_i16 (gfc_array_i16 * const restrict,
+ gfc_array_i16 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miparity_i16);
+
+void
+miparity_i16 (gfc_array_i16 * const restrict retarray,
+ gfc_array_i16 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_16 * restrict dest;
+ const GFC_INTEGER_16 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IPARITY intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IPARITY");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IPARITY");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_16 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_16 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result ^= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siparity_i16 (gfc_array_i16 * const restrict,
+ gfc_array_i16 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siparity_i16);
+
+void
+siparity_i16 (gfc_array_i16 * const restrict retarray,
+ gfc_array_i16 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_16 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iparity_i16 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IPARITY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IPARITY intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IPARITY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2)
+
+
+extern void iparity_i2 (gfc_array_i2 * const restrict,
+ gfc_array_i2 * const restrict, const index_type * const restrict);
+export_proto(iparity_i2);
+
+void
+iparity_i2 (gfc_array_i2 * const restrict retarray,
+ gfc_array_i2 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_2 * restrict base;
+ GFC_INTEGER_2 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IPARITY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IPARITY");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_2 * restrict src;
+ GFC_INTEGER_2 result;
+ src = base;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result ^= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miparity_i2 (gfc_array_i2 * const restrict,
+ gfc_array_i2 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miparity_i2);
+
+void
+miparity_i2 (gfc_array_i2 * const restrict retarray,
+ gfc_array_i2 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_2 * restrict dest;
+ const GFC_INTEGER_2 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IPARITY intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IPARITY");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IPARITY");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_2 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_2 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result ^= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siparity_i2 (gfc_array_i2 * const restrict,
+ gfc_array_i2 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siparity_i2);
+
+void
+siparity_i2 (gfc_array_i2 * const restrict retarray,
+ gfc_array_i2 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_2 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iparity_i2 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IPARITY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IPARITY intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IPARITY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
+
+
+extern void iparity_i4 (gfc_array_i4 * const restrict,
+ gfc_array_i4 * const restrict, const index_type * const restrict);
+export_proto(iparity_i4);
+
+void
+iparity_i4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_i4 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_4 * restrict base;
+ GFC_INTEGER_4 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IPARITY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IPARITY");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_4 * restrict src;
+ GFC_INTEGER_4 result;
+ src = base;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result ^= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miparity_i4 (gfc_array_i4 * const restrict,
+ gfc_array_i4 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miparity_i4);
+
+void
+miparity_i4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_i4 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_4 * restrict dest;
+ const GFC_INTEGER_4 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IPARITY intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IPARITY");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IPARITY");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_4 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_4 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result ^= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siparity_i4 (gfc_array_i4 * const restrict,
+ gfc_array_i4 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siparity_i4);
+
+void
+siparity_i4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_i4 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_4 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iparity_i4 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IPARITY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IPARITY intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
--- /dev/null
+/* Implementation of the IPARITY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+
+
+#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8)
+
+
+extern void iparity_i8 (gfc_array_i8 * const restrict,
+ gfc_array_i8 * const restrict, const index_type * const restrict);
+export_proto(iparity_i8);
+
+void
+iparity_i8 (gfc_array_i8 * const restrict retarray,
+ gfc_array_i8 * const restrict array,
+ const index_type * const restrict pdim)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ const GFC_INTEGER_8 * restrict base;
+ GFC_INTEGER_8 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type dim;
+ int continue_loop;
+
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len < 0)
+ len = 0;
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IPARITY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IPARITY");
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ len = 0;
+ }
+
+ base = array->data;
+ dest = retarray->data;
+
+ continue_loop = 1;
+ while (continue_loop)
+ {
+ const GFC_INTEGER_8 * restrict src;
+ GFC_INTEGER_8 result;
+ src = base;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ result ^= *src;
+ }
+
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ continue_loop = 0;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void miparity_i8 (gfc_array_i8 * const restrict,
+ gfc_array_i8 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict);
+export_proto(miparity_i8);
+
+void
+miparity_i8 (gfc_array_i8 * const restrict retarray,
+ gfc_array_i8 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ index_type mstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_8 * restrict dest;
+ const GFC_INTEGER_8 * restrict base;
+ const GFC_LOGICAL_1 * restrict mbase;
+ int rank;
+ int dim;
+ index_type n;
+ index_type len;
+ index_type delta;
+ index_type mdelta;
+ int mask_kind;
+
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ len = GFC_DESCRIPTOR_EXTENT(array,dim);
+ if (len <= 0)
+ return;
+
+ mbase = mask->data;
+
+ mask_kind = GFC_DESCRIPTOR_SIZE (mask);
+
+ if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
+#ifdef HAVE_GFC_LOGICAL_16
+ || mask_kind == 16
+#endif
+ )
+ mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
+ else
+ runtime_error ("Funny sized logical array");
+
+ delta = GFC_DESCRIPTOR_STRIDE(array,dim);
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+
+ }
+ for (n = dim; n < rank; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
+ mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
+
+ if (extent[n] < 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in IPARITY intrinsic");
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ bounds_ifunction_return ((array_t *) retarray, extent,
+ "return value", "IPARITY");
+ bounds_equal_extents ((array_t *) mask, (array_t *) array,
+ "MASK argument", "IPARITY");
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ if (extent[n] <= 0)
+ return;
+ }
+
+ dest = retarray->data;
+ base = array->data;
+
+ while (base)
+ {
+ const GFC_INTEGER_8 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_8 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ result = 0;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ result ^= *src;
+ }
+ *dest = result;
+ }
+ }
+ /* Advance to the next element. */
+ count[0]++;
+ base += sstride[0];
+ mbase += mstride[0];
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+
+extern void siparity_i8 (gfc_array_i8 * const restrict,
+ gfc_array_i8 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *);
+export_proto(siparity_i8);
+
+void
+siparity_i8 (gfc_array_i8 * const restrict retarray,
+ gfc_array_i8 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type dstride[GFC_MAX_DIMENSIONS];
+ GFC_INTEGER_8 * restrict dest;
+ index_type rank;
+ index_type n;
+ index_type dim;
+
+
+ if (*mask)
+ {
+ iparity_i8 (retarray, array, pdim);
+ return;
+ }
+ /* Make dim zero based to avoid confusion. */
+ dim = (*pdim) - 1;
+ rank = GFC_DESCRIPTOR_RANK (array) - 1;
+
+ for (n = 0; n < dim; n++)
+ {
+ extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ if (retarray->data == NULL)
+ {
+ size_t alloc_size, str;
+
+ for (n = 0; n < rank; n++)
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+
+ GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
+
+ }
+
+ retarray->offset = 0;
+ retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
+ * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->data = internal_malloc_size (alloc_size);
+ }
+ else
+ {
+ if (rank != GFC_DESCRIPTOR_RANK (retarray))
+ runtime_error ("rank of return array incorrect in"
+ " IPARITY intrinsic: is %ld, should be %ld",
+ (long int) (GFC_DESCRIPTOR_RANK (retarray)),
+ (long int) rank);
+
+ if (unlikely (compile_options.bounds_check))
+ {
+ for (n=0; n < rank; n++)
+ {
+ index_type ret_extent;
+
+ ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
+ if (extent[n] != ret_extent)
+ runtime_error ("Incorrect extent in return value of"
+ " IPARITY intrinsic in dimension %ld:"
+ " is %ld, should be %ld", (long int) n + 1,
+ (long int) ret_extent, (long int) extent[n]);
+ }
+ }
+ }
+
+ for (n = 0; n < rank; n++)
+ {
+ count[n] = 0;
+ dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
+ }
+
+ dest = retarray->data;
+
+ while(1)
+ {
+ *dest = 0;
+ count[0]++;
+ dest += dstride[0];
+ n = 0;
+ while (count[n] == extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ return;
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
+ }
+ }
+}
+
+#endif
GFORTRAN_1.4 {
global:
- _gfortran_error_stop_numeric;
- _gfortran_selected_real_kind2008;
_gfortran_bessel_jn_r4;
_gfortran_bessel_jn_r8;
_gfortran_bessel_jn_r10;
_gfortran_bessel_yn_r8;
_gfortran_bessel_yn_r10;
_gfortran_bessel_yn_r16;
+ _gfortran_error_stop_numeric;
+ _gfortran_iall_i1;
+ _gfortran_iall_i2;
+ _gfortran_iall_i4;
+ _gfortran_iall_i8;
+ _gfortran_iall_i16;
+ _gfortran_iany_i1;
+ _gfortran_iany_i2;
+ _gfortran_iany_i4;
+ _gfortran_iany_i8;
+ _gfortran_iany_i16;
+ _gfortran_iparity_i1;
+ _gfortran_iparity_i2;
+ _gfortran_iparity_i4;
+ _gfortran_iparity_i8;
+ _gfortran_iparity_i16;
_gfortran_norm2_r4;
_gfortran_norm2_r8;
_gfortran_norm2_r10;
_gfortran_parity_l4;
_gfortran_parity_l8;
_gfortran_parity_l16;
+ _gfortran_selected_real_kind2008;
} GFORTRAN_1.3;
F2C_1.0 {
--- /dev/null
+`/* Implementation of the IALL intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>'
+
+include(iparm.m4)dnl
+include(ifunction.m4)dnl
+
+`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
+
+ARRAY_FUNCTION(0,
+` result = ('rtype_name`) -1;',
+` result &= *src;')
+
+MASKED_ARRAY_FUNCTION(0,
+` result = 0;',
+` if (*msrc)
+ result &= *src;')
+
+SCALAR_ARRAY_FUNCTION(0)
+
+#endif
--- /dev/null
+`/* Implementation of the IANY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>'
+
+include(iparm.m4)dnl
+include(ifunction.m4)dnl
+
+`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
+
+ARRAY_FUNCTION(0,
+` result = 0;',
+` result |= *src;')
+
+MASKED_ARRAY_FUNCTION(0,
+` result = 0;',
+` if (*msrc)
+ result |= *src;')
+
+SCALAR_ARRAY_FUNCTION(0)
+
+#endif
--- /dev/null
+`/* Implementation of the IPARITY intrinsic
+ Copyright 2010 Free Software Foundation, Inc.
+ Contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>'
+
+include(iparm.m4)dnl
+include(ifunction.m4)dnl
+
+`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
+
+ARRAY_FUNCTION(0,
+` result = 0;',
+` result ^= *src;')
+
+MASKED_ARRAY_FUNCTION(0,
+` result = 0;',
+` if (*msrc)
+ result ^= *src;')
+
+SCALAR_ARRAY_FUNCTION(0)
+
+#endif
projects / platform / upstream / linaro-gcc.git / commitdiff