From patchwork Sat Sep 4 10:44:21 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 63768 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 78FFCB714C for ; Sat, 4 Sep 2010 20:46:17 +1000 (EST) Received: (qmail 28068 invoked by alias); 4 Sep 2010 10:46:09 -0000 Received: (qmail 27821 invoked by uid 22791); 4 Sep 2010 10:45:06 -0000 X-SWARE-Spam-Status: No, hits=-1.1 required=5.0 tests=AWL, BAYES_05, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 04 Sep 2010 10:44:28 +0000 Received: from [192.168.178.22] (port-92-204-40-202.dynamic.qsc.de [92.204.40.202]) by mx02.qsc.de (Postfix) with ESMTP id 2EAAF1E104; Sat, 4 Sep 2010 12:44:21 +0200 (CEST) Message-ID: <4C822305.9080601@net-b.de> Date: Sat, 04 Sep 2010 12:44:21 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.2.7) Gecko/20100714 SUSE/3.1.1 Thunderbird/3.1.1 MIME-Version: 1.0 To: gfortran , gcc patches Subject: [Patch, Fortran] PR 38282 - Add F2008's transformational bit intrinsics Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Dear all, this patch adds the transformational bit intrinsics IALL (bitwise and), IANY (bitwise inclusive or), and IPARITY (bitwise exclusive or); the syntax is the same as SUM or PRODUCT. (François-Xavier is working on the other Fortran 2008 bit intrinsics, which should be ready soon.) Build and regtested on x86-64-linux. OK for the trunk? Tobias 2010-09-04 Tobias Burnus 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): New functions. * 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): New functions. * 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-04 Tobias Burnus PR fortran/38282 * gfortran.dg/iall_iany_iparity_1.f90: New. * gfortran.dg/iall_iany_iparity_2.f90: New. 2010-09-04 Tobias Burnus 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. Index: gcc/fortran/intrinsic.c =================================================================== --- gcc/fortran/intrinsic.c (Revision 163853) +++ gcc/fortran/intrinsic.c (Arbeitskopie) @@ -1777,6 +1777,20 @@ add_functions (void) make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU); + add_sym_3red ("iall", GFC_ISYM_IALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_transf_bit_intrins, gfc_simplify_iall, gfc_resolve_iall, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("iall", GFC_ISYM_IALL, GFC_STD_F2008); + + add_sym_3red ("iany", GFC_ISYM_IANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_transf_bit_intrins, gfc_simplify_iany, gfc_resolve_iany, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("iany", GFC_ISYM_IANY, GFC_STD_F2008); + add_sym_0 ("iargc", GFC_ISYM_IARGC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, NULL); @@ -1885,6 +1899,13 @@ add_functions (void) make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU); + add_sym_3red ("iparity", GFC_ISYM_IPARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_transf_bit_intrins, gfc_simplify_iparity, gfc_resolve_iparity, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("iparity", GFC_ISYM_IPARITY, GFC_STD_F2008); + /* The following function is for G77 compatibility. */ add_sym_1 ("irand", GFC_ISYM_IRAND, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 4, GFC_STD_GNU, gfc_check_irand, NULL, NULL, @@ -3737,6 +3758,9 @@ check_specific (gfc_intrinsic_sym *speci /* 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) Index: gcc/fortran/intrinsic.h =================================================================== --- gcc/fortran/intrinsic.h (Revision 163853) +++ gcc/fortran/intrinsic.h (Arbeitskopie) @@ -144,6 +144,7 @@ gfc_try gfc_check_stat (gfc_expr *, gfc_ gfc_try gfc_check_storage_size (gfc_expr *, gfc_expr *); gfc_try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_symlnk (gfc_expr *, gfc_expr *); +gfc_try gfc_check_transf_bit_intrins (gfc_actual_arglist *); gfc_try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_transpose (gfc_expr *); gfc_try gfc_check_trim (gfc_expr *); @@ -260,7 +261,9 @@ gfc_expr *gfc_simplify_gamma (gfc_expr * gfc_expr *gfc_simplify_huge (gfc_expr *); gfc_expr *gfc_simplify_hypot (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_iachar (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_iall (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_iand (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_iany (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ibclr (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *); @@ -275,6 +278,7 @@ gfc_expr *gfc_simplify_long (gfc_expr *) gfc_expr *gfc_simplify_ifix (gfc_expr *); gfc_expr *gfc_simplify_idint (gfc_expr *); gfc_expr *gfc_simplify_ior (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_iparity (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_is_iostat_end (gfc_expr *); gfc_expr *gfc_simplify_is_iostat_eor (gfc_expr *); gfc_expr *gfc_simplify_isnan (gfc_expr *); @@ -441,12 +445,15 @@ void gfc_resolve_ierrno (gfc_expr *); void gfc_resolve_ieor (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ichar (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_iachar (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_iall (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_iany (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_idnint (gfc_expr *, gfc_expr *); void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_int2 (gfc_expr *, gfc_expr *); void gfc_resolve_int8 (gfc_expr *, gfc_expr *); void gfc_resolve_long (gfc_expr *, gfc_expr *); void gfc_resolve_ior (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_iparity (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_isatty (gfc_expr *, gfc_expr *); void gfc_resolve_rshift (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_lshift (gfc_expr *, gfc_expr *, gfc_expr *); Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (Revision 163853) +++ gcc/fortran/gfortran.h (Arbeitskopie) @@ -397,7 +397,9 @@ enum gfc_isym_id GFC_ISYM_HUGE, GFC_ISYM_HYPOT, GFC_ISYM_IACHAR, + GFC_ISYM_IALL, GFC_ISYM_IAND, + GFC_ISYM_IANY, GFC_ISYM_IARGC, GFC_ISYM_IBCLR, GFC_ISYM_IBITS, @@ -412,6 +414,7 @@ enum gfc_isym_id GFC_ISYM_INT2, GFC_ISYM_INT8, GFC_ISYM_IOR, + GFC_ISYM_IPARITY, GFC_ISYM_IRAND, GFC_ISYM_ISATTY, GFC_ISYM_IS_IOSTAT_END, Index: gcc/fortran/iresolve.c =================================================================== --- gcc/fortran/iresolve.c (Revision 163853) +++ gcc/fortran/iresolve.c (Arbeitskopie) @@ -1044,6 +1044,38 @@ gfc_resolve_hypot (gfc_expr *f, gfc_expr void +gfc_resolve_iall (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 = "siall"; + else + name = "miall"; + + resolve_mask_arg (mask); + } + else + name = "iall"; + + 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); +} + + +void gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j) { /* If the kind of i and j are different, then g77 cross-promoted the @@ -1063,6 +1095,38 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr void +gfc_resolve_iany (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 = "siany"; + else + name = "miany"; + + resolve_mask_arg (mask); + } + else + name = "iany"; + + 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); +} + + +void gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED) { f->ts = i->ts; @@ -1238,6 +1302,38 @@ gfc_resolve_long (gfc_expr *f, gfc_expr } +void +gfc_resolve_iparity (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 = "siparity"; + else + name = "miparity"; + + resolve_mask_arg (mask); + } + else + name = "iparity"; + + 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); +} + + void gfc_resolve_isatty (gfc_expr *f, gfc_expr *u) { Index: gcc/fortran/check.c =================================================================== --- gcc/fortran/check.c (Revision 163853) +++ gcc/fortran/check.c (Arbeitskopie) @@ -2353,6 +2353,26 @@ gfc_check_product_sum (gfc_actual_arglis } +/* 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) { Index: gcc/fortran/trans-intrinsic.c =================================================================== --- gcc/fortran/trans-intrinsic.c (Revision 163853) +++ gcc/fortran/trans-intrinsic.c (Arbeitskopie) @@ -1964,11 +1964,14 @@ gfc_conv_intrinsic_arith (gfc_se * se, g 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); @@ -5432,10 +5435,18 @@ gfc_conv_intrinsic_function (gfc_se * se 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; @@ -5478,6 +5489,10 @@ gfc_conv_intrinsic_function (gfc_se * se 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; @@ -5821,6 +5836,9 @@ gfc_is_intrinsic_libcall (gfc_expr * exp 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: Index: gcc/fortran/intrinsic.texi =================================================================== --- gcc/fortran/intrinsic.texi (Revision 163853) +++ gcc/fortran/intrinsic.texi (Arbeitskopie) @@ -139,7 +139,9 @@ Some basic guidelines for editing this d * @code{HUGE}: HUGE, Largest number of a kind * @code{HYPOT}: HYPOT, Euclidian distance function * @code{IACHAR}: IACHAR, Code in @acronym{ASCII} collating sequence +* @code{IALL}: IALL, Bitwise AND of array elements * @code{IAND}: IAND, Bitwise logical and +* @code{IANY}: IANY, Bitwise OR of array elements * @code{IARGC}: IARGC, Get the number of command line arguments * @code{IBCLR}: IBCLR, Clear bit * @code{IBITS}: IBITS, Bit extraction @@ -148,13 +150,14 @@ Some basic guidelines for editing this d * @code{IDATE}: IDATE, Current local time (day/month/year) * @code{IEOR}: IEOR, Bitwise logical exclusive or * @code{IERRNO}: IERRNO, Function to get the last system error number +* @code{IMAGE_INDEX}: IMAGE_INDEX, Cosubscript to image index convertion * @code{INDEX}: INDEX intrinsic, Position of a substring within a string * @code{INT}: INT, Convert to integer type * @code{INT2}: INT2, Convert to 16-bit integer type * @code{INT8}: INT8, Convert to 64-bit integer type * @code{IOR}: IOR, Bitwise logical or +* @code{IPARITY}: IPARITY, Bitwise XOR of array elements * @code{IRAND}: IRAND, Integer pseudo-random number -* @code{IMAGE_INDEX}: IMAGE_INDEX, Cosubscript to image index convertion * @code{IS_IOSTAT_END}: IS_IOSTAT_END, Test for end-of-file value * @code{IS_IOSTAT_EOR}: IS_IOSTAT_EOR, Test for end-of-record value * @code{ISATTY}: ISATTY, Whether a unit is a terminal device @@ -5580,6 +5583,66 @@ and formatted string representations. +@node IALL +@section @code{IALL} --- Bitwise AND of array elements +@fnindex ILL +@cindex array, AND +@cindex bits, AND of array elements + +@table @asis +@item @emph{Description}: +Reduces with bitwise AND the elements of @var{ARRAY} along dimension @var{DIM} +if the corresponding element in @var{MASK} is @code{TRUE}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = IALL(ARRAY[, MASK])} +@item @code{RESULT = IALL(ARRAY, DIM[, MASK])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER} +@item @var{DIM} @tab (Optional) shall be a scalar of type +@code{INTEGER} with a value in the range from 1 to n, where n +equals the rank of @var{ARRAY}. +@item @var{MASK} @tab (Optional) shall be of type @code{LOGICAL} +and either be a scalar or an array of the same shape as @var{ARRAY}. +@end multitable + +@item @emph{Return value}: +The result is of the same type as @var{ARRAY}. + +If @var{DIM} is absent, a scalar with the bitwise ALL of all elements in +@var{ARRAY} is returned. Otherwise, an array of rank n-1, where n equals +the rank of @var{ARRAY}, and a shape similar to that of @var{ARRAY} with +dimension @var{DIM} dropped is returned. + +@item @emph{Example}: +@smallexample +PROGRAM test_iall + INTEGER(1) :: a(2) + + a(1) = b'00100100' + a(1) = b'01101010' + + ! prints 00100000 + PRINT '(b8.8)', IALL(a) +END PROGRAM +@end smallexample + +@item @emph{See also}: +@ref{IANY}, @ref{IPARITY}, @ref{IAND} +@end table + + + @node IAND @section @code{IAND} --- Bitwise logical and @fnindex IAND @@ -5628,6 +5691,66 @@ END PROGRAM +@node IANY +@section @code{IANY} --- Bitwise XOR of array elements +@fnindex IANY +@cindex array, OR +@cindex bits, OR of array elements + +@table @asis +@item @emph{Description}: +Reduces with bitwise OR (inclusive or) the elements of @var{ARRAY} along +dimension @var{DIM} if the corresponding element in @var{MASK} is @code{TRUE}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = IANY(ARRAY[, MASK])} +@item @code{RESULT = IANY(ARRAY, DIM[, MASK])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER} +@item @var{DIM} @tab (Optional) shall be a scalar of type +@code{INTEGER} with a value in the range from 1 to n, where n +equals the rank of @var{ARRAY}. +@item @var{MASK} @tab (Optional) shall be of type @code{LOGICAL} +and either be a scalar or an array of the same shape as @var{ARRAY}. +@end multitable + +@item @emph{Return value}: +The result is of the same type as @var{ARRAY}. + +If @var{DIM} is absent, a scalar with the bitwise OR of all elements in +@var{ARRAY} is returned. Otherwise, an array of rank n-1, where n equals +the rank of @var{ARRAY}, and a shape similar to that of @var{ARRAY} with +dimension @var{DIM} dropped is returned. + +@item @emph{Example}: +@smallexample +PROGRAM test_iany + INTEGER(1) :: a(2) + + a(1) = b'00100100' + a(1) = b'01101010' + + ! prints 01111011 + PRINT '(b8.8)', IANY(a) +END PROGRAM +@end smallexample + +@item @emph{See also}: +@ref{IPARITY}, @ref{IALL}, @ref{IOR} +@end table + + + @node IARGC @section @code{IARGC} --- Get the number of command line arguments @fnindex IARGC @@ -5977,6 +6100,50 @@ kind. +@node IMAGE_INDEX +@section @code{IMAGE_INDEX} --- Function that converts a cosubscript to an image index +@fnindex IMAGE_INDEX +@cindex coarray, IMAGE_INDEX +@cindex images, cosubscript to image index conversion + +@table @asis +@item @emph{Description}: +Returns the image index belonging to a cosubscript. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Inquiry function. + +@item @emph{Syntax}: +@code{RESULT = IMAGE_INDEX(COARRAY, SUB)} + +@item @emph{Arguments}: None. +@multitable @columnfractions .15 .70 +@item @var{COARRAY} @tab Coarray of any type. +@item @var{SUB} @tab default integer rank-1 array of a size equal to +the corank of @var{COARRAY}. +@end multitable + + +@item @emph{Return value}: +Scalar default integer with the value of the image index which corresponds +to the cosubscripts. For invalid cosubscripts the result is zero. + +@item @emph{Example}: +@smallexample +INTEGER :: array[2,-1:4,8,*] +! Writes 28 (or 0 if there are fewer than 28 images) +WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1]) +@end smallexample + +@item @emph{See also}: +@ref{THIS_IMAGE}, @ref{NUM_IMAGES} +@end table + + + @node INDEX intrinsic @section @code{INDEX} --- Position of a substring within a string @fnindex INDEX @@ -6204,6 +6371,67 @@ the larger argument.) +@node IPARITY +@section @code{IPARITY} --- Bitwise XOR of array elements +@fnindex IPARITY +@cindex array, parity +@cindex array, XOR +@cindex bits, XOR of array elements + +@table @asis +@item @emph{Description}: +Reduces with bitwise XOR (exclusive or) the elements of @var{ARRAY} along +dimension @var{DIM} if the corresponding element in @var{MASK} is @code{TRUE}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = IPARITY(ARRAY[, MASK])} +@item @code{RESULT = IPARITY(ARRAY, DIM[, MASK])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER} +@item @var{DIM} @tab (Optional) shall be a scalar of type +@code{INTEGER} with a value in the range from 1 to n, where n +equals the rank of @var{ARRAY}. +@item @var{MASK} @tab (Optional) shall be of type @code{LOGICAL} +and either be a scalar or an array of the same shape as @var{ARRAY}. +@end multitable + +@item @emph{Return value}: +The result is of the same type as @var{ARRAY}. + +If @var{DIM} is absent, a scalar with the bitwise XOR of all elements in +@var{ARRAY} is returned. Otherwise, an array of rank n-1, where n equals +the rank of @var{ARRAY}, and a shape similar to that of @var{ARRAY} with +dimension @var{DIM} dropped is returned. + +@item @emph{Example}: +@smallexample +PROGRAM test_iparity + INTEGER(1) :: a(2) + + a(1) = b'00100100' + a(1) = b'01101010' + + ! prints 10111011 + PRINT '(b8.8)', IPARITY(a) +END PROGRAM +@end smallexample + +@item @emph{See also}: +@ref{IANY}, @ref{IALL}, @ref{IEOR}, @ref{PARITY} +@end table + + + @node IRAND @section @code{IRAND} --- Integer pseudo-random number @fnindex IRAND @@ -6254,50 +6482,6 @@ end program test_irand @end table - -@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 Index: gcc/fortran/simplify.c =================================================================== --- gcc/fortran/simplify.c (Revision 163853) +++ gcc/fortran/simplify.c (Arbeitskopie) @@ -2231,6 +2231,78 @@ gfc_simplify_iachar (gfc_expr *e, gfc_ex } +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) +{ + 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, do_bit_and) : + simplify_transformation_to_array (result, array, dim, mask, do_bit_and, NULL); +} + + +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) +{ + 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, do_bit_ior) : + simplify_transformation_to_array (result, array, dim, mask, do_bit_ior, NULL); +} + + gfc_expr * gfc_simplify_iand (gfc_expr *x, gfc_expr *y) { @@ -2683,6 +2755,43 @@ gfc_simplify_ior (gfc_expr *x, gfc_expr } +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) +{ + 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, do_bit_xor) : + simplify_transformation_to_array (result, array, dim, mask, do_bit_xor, NULL); +} + + + gfc_expr * gfc_simplify_is_iostat_end (gfc_expr *x) { Index: gcc/testsuite/gfortran.dg/iall_iany_iparity_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/iall_iany_iparity_1.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/iall_iany_iparity_1.f90 (Revision 0) @@ -0,0 +1,26 @@ +! { dg-do run } +! +! PR fortran/38282 +! +implicit none +integer :: a(2,1) + +a(1,1) = 35 +a(2,1) = -74 + +if (iand(a(1,1),a(2,1)) /= iall(a)) call abort () +if (iand(a(1,1),a(2,1)) /= iall(array=[35, -74])) call abort () +if (any (iand(a(1,1),a(2,1)) /= iall(a,dim=1))) call abort () +if (iand(a(1,1),a(2,1)) /= iall(dim=1,mask=[.true.,.true.],array=[35, -74])) call abort () + +if (ior(a(1,1),a(2,1)) /= iany(a)) call abort () +if (ior(a(1,1),a(2,1)) /= iany(array=[35, -74])) call abort () +if (any (ior(a(1,1),a(2,1)) /= iany(a,dim=1))) call abort () +if (ior(a(1,1),a(2,1)) /= iany(dim=1,mask=[.true.,.true.],array=[35, -74])) call abort () + +if (ieor(a(1,1),a(2,1)) /= iparity(a)) call abort () +if (ieor(a(1,1),a(2,1)) /= iparity(array=[35, -74])) call abort () +if (any (ieor(a(1,1),a(2,1)) /= iparity(a,dim=1))) call abort () +if (ieor(a(1,1),a(2,1)) /= iparity(dim=1,mask=[.true.,.true.],array=[35, -74])) call abort () + +end Index: gcc/testsuite/gfortran.dg/iall_iany_iparity_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/iall_iany_iparity_2.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/iall_iany_iparity_2.f90 (Revision 0) @@ -0,0 +1,18 @@ +! { dg-do run } +! { 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 Index: libgfortran/gfortran.map =================================================================== --- libgfortran/gfortran.map (Revision 163853) +++ libgfortran/gfortran.map (Arbeitskopie) @@ -1107,8 +1107,6 @@ GFORTRAN_1.3 { GFORTRAN_1.4 { global: - _gfortran_error_stop_numeric; - _gfortran_selected_real_kind2008; _gfortran_bessel_jn_r4; _gfortran_bessel_jn_r8; _gfortran_bessel_jn_r10; @@ -1117,6 +1115,22 @@ GFORTRAN_1.4 { _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; @@ -1126,6 +1140,7 @@ GFORTRAN_1.4 { _gfortran_parity_l4; _gfortran_parity_l8; _gfortran_parity_l16; + _gfortran_selected_real_kind2008; } GFORTRAN_1.3; F2C_1.0 { Index: libgfortran/Makefile.am =================================================================== --- libgfortran/Makefile.am (Revision 163853) +++ libgfortran/Makefile.am (Arbeitskopie) @@ -189,6 +189,27 @@ $(srcdir)/generated/count_4_l.c \ $(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 \ @@ -603,11 +624,13 @@ m4_files= m4/iparm.m4 m4/ifunction.m4 m4 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) \ @@ -850,6 +873,15 @@ $(i_any_c): m4/any.m4 $(I_M4_DEPS2) $(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 > $@ Index: libgfortran/m4/iany.m4 =================================================================== --- libgfortran/m4/iany.m4 (Revision 0) +++ libgfortran/m4/iany.m4 (Revision 0) @@ -0,0 +1,46 @@ +`/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include ' + +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 Index: libgfortran/m4/iall.m4 =================================================================== --- libgfortran/m4/iall.m4 (Revision 0) +++ libgfortran/m4/iall.m4 (Revision 0) @@ -0,0 +1,46 @@ +`/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include ' + +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 Index: libgfortran/m4/iparity.m4 =================================================================== --- libgfortran/m4/iparity.m4 (Revision 0) +++ libgfortran/m4/iparity.m4 (Revision 0) @@ -0,0 +1,46 @@ +`/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include ' + +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 Index: libgfortran/Makefile.in =================================================================== --- libgfortran/Makefile.in (Revision 163853) +++ libgfortran/Makefile.in (Arbeitskopie) @@ -144,43 +144,49 @@ am__objects_12 = sum_i1.lo sum_i2.lo sum 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 \ @@ -188,26 +194,26 @@ am__objects_30 = pow_i4_i4.lo pow_i8_i4. 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) \ @@ -218,11 +224,12 @@ am__objects_37 = $(am__objects_2) $(am__ $(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 \ @@ -237,8 +244,8 @@ am__objects_39 = associated.lo abort.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 \ @@ -262,18 +269,18 @@ am__objects_41 = _abs_c4.lo _abs_c8.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 = @@ -609,6 +616,27 @@ $(srcdir)/generated/count_4_l.c \ $(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 \ @@ -1022,11 +1050,13 @@ m4_files = m4/iparm.m4 m4/ifunction.m4 m 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) \ @@ -1427,6 +1457,16 @@ distclean-compile: @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@ @@ -1458,6 +1498,11 @@ distclean-compile: @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@ @@ -3523,6 +3568,111 @@ bessel_r16.lo: $(srcdir)/generated/besse @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 @@ -5671,6 +5821,15 @@ fpu-target.h: $(srcdir)/$(FPU_HOST_HEADE @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 > $@ Index: libgfortran/generated/iany_i1.c =================================================================== --- libgfortran/generated/iany_i1.c (Revision 0) +++ libgfortran/generated/iany_i1.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iparity_i4.c =================================================================== --- libgfortran/generated/iparity_i4.c (Revision 0) +++ libgfortran/generated/iparity_i4.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iall_i8.c =================================================================== --- libgfortran/generated/iall_i8.c (Revision 0) +++ libgfortran/generated/iall_i8.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iany_i2.c =================================================================== --- libgfortran/generated/iany_i2.c (Revision 0) +++ libgfortran/generated/iany_i2.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iparity_i16.c =================================================================== --- libgfortran/generated/iparity_i16.c (Revision 0) +++ libgfortran/generated/iparity_i16.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iany_i4.c =================================================================== --- libgfortran/generated/iany_i4.c (Revision 0) +++ libgfortran/generated/iany_i4.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iparity_i8.c =================================================================== --- libgfortran/generated/iparity_i8.c (Revision 0) +++ libgfortran/generated/iparity_i8.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iany_i8.c =================================================================== --- libgfortran/generated/iany_i8.c (Revision 0) +++ libgfortran/generated/iany_i8.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iall_i1.c =================================================================== --- libgfortran/generated/iall_i1.c (Revision 0) +++ libgfortran/generated/iall_i1.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iall_i2.c =================================================================== --- libgfortran/generated/iall_i2.c (Revision 0) +++ libgfortran/generated/iall_i2.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iany_i16.c =================================================================== --- libgfortran/generated/iany_i16.c (Revision 0) +++ libgfortran/generated/iany_i16.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iall_i4.c =================================================================== --- libgfortran/generated/iall_i4.c (Revision 0) +++ libgfortran/generated/iall_i4.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iparity_i1.c =================================================================== --- libgfortran/generated/iparity_i1.c (Revision 0) +++ libgfortran/generated/iparity_i1.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iall_i16.c =================================================================== --- libgfortran/generated/iall_i16.c (Revision 0) +++ libgfortran/generated/iall_i16.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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 Index: libgfortran/generated/iparity_i2.c =================================================================== --- libgfortran/generated/iparity_i2.c (Revision 0) +++ libgfortran/generated/iparity_i2.c (Revision 0) @@ -0,0 +1,509 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 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 +. */ + +#include "libgfortran.h" +#include +#include + + +#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