diff options
Diffstat (limited to 'libgfortran/generated')
19 files changed, 1217 insertions, 976 deletions
diff --git a/libgfortran/generated/all_l1.c b/libgfortran/generated/all_l1.c new file mode 100644 index 00000000000..47cf2220d33 --- /dev/null +++ b/libgfortran/generated/all_l1.c @@ -0,0 +1,222 @@ +/* Implementation of the ALL intrinsic + Copyright 2002, 2007 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +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 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +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. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <assert.h> + + +#if defined (HAVE_GFC_LOGICAL_1) + + +extern void all_l1 (gfc_array_l1 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(all_l1); + +void +all_l1 (gfc_array_l1 * const restrict retarray, + gfc_array_l1 * 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_LOGICAL_1 * restrict base; + GFC_LOGICAL_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride * src_kind; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride * src_kind; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride * src_kind; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_1) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -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" + " ALL intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + + dest = retarray->data; + + while (base) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_1 result; + src = base; + { + + /* Return true only if all the elements are set. */ + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (! *src) + { + result = 0; + break; + } + } + *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. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/all_l16.c b/libgfortran/generated/all_l16.c index 9c53707ae76..ca147e7d39f 100644 --- a/libgfortran/generated/all_l16.c +++ b/libgfortran/generated/all_l16.c @@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> -#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_LOGICAL_16) +#if defined (HAVE_GFC_LOGICAL_16) extern void all_l16 (gfc_array_l16 * const restrict, - gfc_array_l16 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(all_l16); void all_l16 (gfc_array_l16 * const restrict retarray, - gfc_array_l16 * const restrict array, + gfc_array_l1 * 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_LOGICAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_16 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -74,7 +77,7 @@ all_l16 (gfc_array_l16 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,9 +119,8 @@ all_l16 (gfc_array_l16 * const restrict retarray, { if (rank != GFC_DESCRIPTOR_RANK (retarray)) runtime_error ("rank of return array incorrect in" - " ALL intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); + " ALL intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); if (compile_options.bounds_check) { @@ -130,8 +132,8 @@ all_l16 (gfc_array_l16 * const restrict retarray, - retarray->dim[n].lbound; if (extent[n] != ret_extent) runtime_error ("Incorrect extent in return value of" - " ALL intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, (long int) ret_extent, (long int) extent[n]); } } @@ -146,11 +148,24 @@ all_l16 (gfc_array_l16 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_16 result; src = base; { diff --git a/libgfortran/generated/all_l2.c b/libgfortran/generated/all_l2.c new file mode 100644 index 00000000000..9e4ab72b30c --- /dev/null +++ b/libgfortran/generated/all_l2.c @@ -0,0 +1,222 @@ +/* Implementation of the ALL intrinsic + Copyright 2002, 2007 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +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 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +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. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <assert.h> + + +#if defined (HAVE_GFC_LOGICAL_2) + + +extern void all_l2 (gfc_array_l2 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(all_l2); + +void +all_l2 (gfc_array_l2 * const restrict retarray, + gfc_array_l1 * 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_LOGICAL_1 * restrict base; + GFC_LOGICAL_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride * src_kind; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride * src_kind; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride * src_kind; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_2) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -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" + " ALL intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + + dest = retarray->data; + + while (base) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_2 result; + src = base; + { + + /* Return true only if all the elements are set. */ + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (! *src) + { + result = 0; + break; + } + } + *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. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/all_l4.c b/libgfortran/generated/all_l4.c index 6eb798619b6..255881b9112 100644 --- a/libgfortran/generated/all_l4.c +++ b/libgfortran/generated/all_l4.c @@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> -#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_LOGICAL_4) +#if defined (HAVE_GFC_LOGICAL_4) extern void all_l4 (gfc_array_l4 * const restrict, - gfc_array_l4 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(all_l4); void all_l4 (gfc_array_l4 * const restrict retarray, - gfc_array_l4 * const restrict array, + gfc_array_l1 * 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_LOGICAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_4 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -74,7 +77,7 @@ all_l4 (gfc_array_l4 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,9 +119,8 @@ all_l4 (gfc_array_l4 * const restrict retarray, { if (rank != GFC_DESCRIPTOR_RANK (retarray)) runtime_error ("rank of return array incorrect in" - " ALL intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); + " ALL intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); if (compile_options.bounds_check) { @@ -130,8 +132,8 @@ all_l4 (gfc_array_l4 * const restrict retarray, - retarray->dim[n].lbound; if (extent[n] != ret_extent) runtime_error ("Incorrect extent in return value of" - " ALL intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, (long int) ret_extent, (long int) extent[n]); } } @@ -146,11 +148,24 @@ all_l4 (gfc_array_l4 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_4 result; src = base; { diff --git a/libgfortran/generated/all_l8.c b/libgfortran/generated/all_l8.c index 7b98652bce5..00ba59f1034 100644 --- a/libgfortran/generated/all_l8.c +++ b/libgfortran/generated/all_l8.c @@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> -#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_LOGICAL_8) +#if defined (HAVE_GFC_LOGICAL_8) extern void all_l8 (gfc_array_l8 * const restrict, - gfc_array_l8 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(all_l8); void all_l8 (gfc_array_l8 * const restrict retarray, - gfc_array_l8 * const restrict array, + gfc_array_l1 * 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_LOGICAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_8 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -74,7 +77,7 @@ all_l8 (gfc_array_l8 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,9 +119,8 @@ all_l8 (gfc_array_l8 * const restrict retarray, { if (rank != GFC_DESCRIPTOR_RANK (retarray)) runtime_error ("rank of return array incorrect in" - " ALL intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); + " ALL intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); if (compile_options.bounds_check) { @@ -130,8 +132,8 @@ all_l8 (gfc_array_l8 * const restrict retarray, - retarray->dim[n].lbound; if (extent[n] != ret_extent) runtime_error ("Incorrect extent in return value of" - " ALL intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, (long int) ret_extent, (long int) extent[n]); } } @@ -146,11 +148,24 @@ all_l8 (gfc_array_l8 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_8 result; src = base; { diff --git a/libgfortran/generated/any_l1.c b/libgfortran/generated/any_l1.c new file mode 100644 index 00000000000..9781a43c2cb --- /dev/null +++ b/libgfortran/generated/any_l1.c @@ -0,0 +1,222 @@ +/* Implementation of the ANY intrinsic + Copyright 2002, 2007 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +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 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +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. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <assert.h> + + +#if defined (HAVE_GFC_LOGICAL_1) + + +extern void any_l1 (gfc_array_l1 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(any_l1); + +void +any_l1 (gfc_array_l1 * const restrict retarray, + gfc_array_l1 * 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_LOGICAL_1 * restrict base; + GFC_LOGICAL_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride * src_kind; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride * src_kind; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride * src_kind; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_1) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -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" + " ANY intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + + dest = retarray->data; + + while (base) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_1 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + /* Return true if any of the elements are set. */ + if (*src) + { + result = 1; + break; + } + } + *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. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/any_l16.c b/libgfortran/generated/any_l16.c index bffd620f02b..b0e95a6dad6 100644 --- a/libgfortran/generated/any_l16.c +++ b/libgfortran/generated/any_l16.c @@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> -#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_LOGICAL_16) +#if defined (HAVE_GFC_LOGICAL_16) extern void any_l16 (gfc_array_l16 * const restrict, - gfc_array_l16 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(any_l16); void any_l16 (gfc_array_l16 * const restrict retarray, - gfc_array_l16 * const restrict array, + gfc_array_l1 * 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_LOGICAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_16 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -74,7 +77,7 @@ any_l16 (gfc_array_l16 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,9 +119,8 @@ any_l16 (gfc_array_l16 * const restrict retarray, { if (rank != GFC_DESCRIPTOR_RANK (retarray)) runtime_error ("rank of return array incorrect in" - " ANY intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); + " ANY intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); if (compile_options.bounds_check) { @@ -130,8 +132,8 @@ any_l16 (gfc_array_l16 * const restrict retarray, - retarray->dim[n].lbound; if (extent[n] != ret_extent) runtime_error ("Incorrect extent in return value of" - " ANY intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, (long int) ret_extent, (long int) extent[n]); } } @@ -146,11 +148,24 @@ any_l16 (gfc_array_l16 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_16 result; src = base; { diff --git a/libgfortran/generated/any_l2.c b/libgfortran/generated/any_l2.c new file mode 100644 index 00000000000..6a42be0fcbc --- /dev/null +++ b/libgfortran/generated/any_l2.c @@ -0,0 +1,222 @@ +/* Implementation of the ANY intrinsic + Copyright 2002, 2007 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +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 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +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. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <assert.h> + + +#if defined (HAVE_GFC_LOGICAL_2) + + +extern void any_l2 (gfc_array_l2 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(any_l2); + +void +any_l2 (gfc_array_l2 * const restrict retarray, + gfc_array_l1 * 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_LOGICAL_1 * restrict base; + GFC_LOGICAL_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride * src_kind; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride * src_kind; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride * src_kind; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_2) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -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" + " ANY intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + + dest = retarray->data; + + while (base) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_2 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + /* Return true if any of the elements are set. */ + if (*src) + { + result = 1; + break; + } + } + *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. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/any_l4.c b/libgfortran/generated/any_l4.c index f86445e69e1..eb372969030 100644 --- a/libgfortran/generated/any_l4.c +++ b/libgfortran/generated/any_l4.c @@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> -#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_LOGICAL_4) +#if defined (HAVE_GFC_LOGICAL_4) extern void any_l4 (gfc_array_l4 * const restrict, - gfc_array_l4 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(any_l4); void any_l4 (gfc_array_l4 * const restrict retarray, - gfc_array_l4 * const restrict array, + gfc_array_l1 * 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_LOGICAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_4 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -74,7 +77,7 @@ any_l4 (gfc_array_l4 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,9 +119,8 @@ any_l4 (gfc_array_l4 * const restrict retarray, { if (rank != GFC_DESCRIPTOR_RANK (retarray)) runtime_error ("rank of return array incorrect in" - " ANY intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); + " ANY intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); if (compile_options.bounds_check) { @@ -130,8 +132,8 @@ any_l4 (gfc_array_l4 * const restrict retarray, - retarray->dim[n].lbound; if (extent[n] != ret_extent) runtime_error ("Incorrect extent in return value of" - " ANY intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, (long int) ret_extent, (long int) extent[n]); } } @@ -146,11 +148,24 @@ any_l4 (gfc_array_l4 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_4 result; src = base; { diff --git a/libgfortran/generated/any_l8.c b/libgfortran/generated/any_l8.c index f155abbed36..b5b52a0b81b 100644 --- a/libgfortran/generated/any_l8.c +++ b/libgfortran/generated/any_l8.c @@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> -#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_LOGICAL_8) +#if defined (HAVE_GFC_LOGICAL_8) extern void any_l8 (gfc_array_l8 * const restrict, - gfc_array_l8 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(any_l8); void any_l8 (gfc_array_l8 * const restrict retarray, - gfc_array_l8 * const restrict array, + gfc_array_l1 * 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_LOGICAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_8 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -74,7 +77,7 @@ any_l8 (gfc_array_l8 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,9 +119,8 @@ any_l8 (gfc_array_l8 * const restrict retarray, { if (rank != GFC_DESCRIPTOR_RANK (retarray)) runtime_error ("rank of return array incorrect in" - " ANY intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); + " ANY intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); if (compile_options.bounds_check) { @@ -130,8 +132,8 @@ any_l8 (gfc_array_l8 * const restrict retarray, - retarray->dim[n].lbound; if (extent[n] != ret_extent) runtime_error ("Incorrect extent in return value of" - " ANY intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, (long int) ret_extent, (long int) extent[n]); } } @@ -146,11 +148,24 @@ any_l8 (gfc_array_l8 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_8 result; src = base; { diff --git a/libgfortran/generated/count_16_l4.c b/libgfortran/generated/count_16_l.c index 9b853699b9d..d3f15d7119d 100644 --- a/libgfortran/generated/count_16_l4.c +++ b/libgfortran/generated/count_16_l.c @@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> -#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_16) +#if defined (HAVE_GFC_INTEGER_16) -extern void count_16_l4 (gfc_array_i16 * const restrict, - gfc_array_l4 * const restrict, const index_type * const restrict); -export_proto(count_16_l4); +extern void count_16_l (gfc_array_i16 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_16_l); void -count_16_l4 (gfc_array_i16 * const restrict retarray, - gfc_array_l4 * const restrict array, +count_16_l (gfc_array_i16 * const restrict retarray, + gfc_array_l1 * 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_LOGICAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -74,7 +77,7 @@ count_16_l4 (gfc_array_i16 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,9 +119,8 @@ count_16_l4 (gfc_array_i16 * const restrict retarray, { if (rank != GFC_DESCRIPTOR_RANK (retarray)) runtime_error ("rank of return array incorrect in" - " COUNT intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); + " COUNT intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); if (compile_options.bounds_check) { @@ -130,8 +132,8 @@ count_16_l4 (gfc_array_i16 * const restrict retarray, - retarray->dim[n].lbound; if (extent[n] != ret_extent) runtime_error ("Incorrect extent in return value of" - " COUNT intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, (long int) ret_extent, (long int) extent[n]); } } @@ -146,11 +148,24 @@ count_16_l4 (gfc_array_i16 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_INTEGER_16 result; src = base; { diff --git a/libgfortran/generated/count_16_l16.c b/libgfortran/generated/count_16_l16.c deleted file mode 100644 index 4f3418bd73a..00000000000 --- a/libgfortran/generated/count_16_l16.c +++ /dev/null @@ -1,203 +0,0 @@ -/* Implementation of the COUNT intrinsic - Copyright 2002, 2007 Free Software Foundation, Inc. - Contributed by Paul Brook <paul@nowt.org> - -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 2 of the License, or (at your option) any later version. - -In addition to the permissions in the GNU General Public License, the -Free Software Foundation gives you unlimited permission to link the -compiled version of this file into combinations with other programs, -and to distribute those combinations without any restriction coming -from the use of this file. (The General Public License restrictions -do apply in other respects; for example, they cover modification of -the file, and distribution when not linked into a combine -executable.) - -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. - -You should have received a copy of the GNU General Public -License along with libgfortran; see the file COPYING. If not, -write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -Boston, MA 02110-1301, USA. */ - -#include "libgfortran.h" -#include <stdlib.h> -#include <assert.h> - - -#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_16) - - -extern void count_16_l16 (gfc_array_i16 * const restrict, - gfc_array_l16 * const restrict, const index_type * const restrict); -export_proto(count_16_l16); - -void -count_16_l16 (gfc_array_i16 * const restrict retarray, - gfc_array_l16 * 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_LOGICAL_16 * restrict base; - GFC_INTEGER_16 * restrict dest; - index_type rank; - index_type n; - index_type len; - index_type delta; - index_type dim; - - /* Make dim zero based to avoid confusion. */ - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride - * extent[rank-1]; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -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" - " COUNT intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); - - if (compile_options.bounds_check) - { - for (n=0; n < rank; n++) - { - index_type ret_extent; - - ret_extent = retarray->dim[n].ubound + 1 - - retarray->dim[n].lbound; - if (extent[n] != ret_extent) - runtime_error ("Incorrect extent in return value of" - " COUNT 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] = retarray->dim[n].stride; - if (extent[n] <= 0) - len = 0; - } - - base = array->data; - dest = retarray->data; - - while (base) - { - const GFC_LOGICAL_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) - { - - if (*src) - result++; - } - *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. */ - base = NULL; - break; - } - else - { - count[n]++; - base += sstride[n]; - dest += dstride[n]; - } - } - } -} - -#endif diff --git a/libgfortran/generated/count_16_l8.c b/libgfortran/generated/count_16_l8.c deleted file mode 100644 index 7a6a31adf0c..00000000000 --- a/libgfortran/generated/count_16_l8.c +++ /dev/null @@ -1,203 +0,0 @@ -/* Implementation of the COUNT intrinsic - Copyright 2002, 2007 Free Software Foundation, Inc. - Contributed by Paul Brook <paul@nowt.org> - -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 2 of the License, or (at your option) any later version. - -In addition to the permissions in the GNU General Public License, the -Free Software Foundation gives you unlimited permission to link the -compiled version of this file into combinations with other programs, -and to distribute those combinations without any restriction coming -from the use of this file. (The General Public License restrictions -do apply in other respects; for example, they cover modification of -the file, and distribution when not linked into a combine -executable.) - -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. - -You should have received a copy of the GNU General Public -License along with libgfortran; see the file COPYING. If not, -write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -Boston, MA 02110-1301, USA. */ - -#include "libgfortran.h" -#include <stdlib.h> -#include <assert.h> - - -#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_16) - - -extern void count_16_l8 (gfc_array_i16 * const restrict, - gfc_array_l8 * const restrict, const index_type * const restrict); -export_proto(count_16_l8); - -void -count_16_l8 (gfc_array_i16 * const restrict retarray, - gfc_array_l8 * 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_LOGICAL_8 * restrict base; - GFC_INTEGER_16 * restrict dest; - index_type rank; - index_type n; - index_type len; - index_type delta; - index_type dim; - - /* Make dim zero based to avoid confusion. */ - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride - * extent[rank-1]; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -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" - " COUNT intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); - - if (compile_options.bounds_check) - { - for (n=0; n < rank; n++) - { - index_type ret_extent; - - ret_extent = retarray->dim[n].ubound + 1 - - retarray->dim[n].lbound; - if (extent[n] != ret_extent) - runtime_error ("Incorrect extent in return value of" - " COUNT 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] = retarray->dim[n].stride; - if (extent[n] <= 0) - len = 0; - } - - base = array->data; - dest = retarray->data; - - while (base) - { - const GFC_LOGICAL_8 * restrict src; - GFC_INTEGER_16 result; - src = base; - { - - result = 0; - if (len <= 0) - *dest = 0; - else - { - for (n = 0; n < len; n++, src += delta) - { - - if (*src) - result++; - } - *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. */ - base = NULL; - break; - } - else - { - count[n]++; - base += sstride[n]; - dest += dstride[n]; - } - } - } -} - -#endif diff --git a/libgfortran/generated/count_4_l8.c b/libgfortran/generated/count_1_l.c index 0e2f9bbb543..78d82c0ea36 100644 --- a/libgfortran/generated/count_4_l8.c +++ b/libgfortran/generated/count_1_l.c @@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> -#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_4) +#if defined (HAVE_GFC_INTEGER_1) -extern void count_4_l8 (gfc_array_i4 * const restrict, - gfc_array_l8 * const restrict, const index_type * const restrict); -export_proto(count_4_l8); +extern void count_1_l (gfc_array_i1 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_1_l); void -count_4_l8 (gfc_array_i4 * const restrict retarray, - gfc_array_l8 * const restrict array, +count_1_l (gfc_array_i1 * const restrict retarray, + gfc_array_l1 * 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_LOGICAL_8 * restrict base; - GFC_INTEGER_4 * restrict dest; + const GFC_LOGICAL_1 * restrict base; + GFC_INTEGER_1 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -74,7 +77,7 @@ count_4_l8 (gfc_array_i4 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -99,7 +102,7 @@ count_4_l8 (gfc_array_i4 * const restrict retarray, retarray->offset = 0; retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + alloc_size = sizeof (GFC_INTEGER_1) * retarray->dim[rank-1].stride * extent[rank-1]; if (alloc_size == 0) @@ -116,9 +119,8 @@ count_4_l8 (gfc_array_i4 * const restrict retarray, { if (rank != GFC_DESCRIPTOR_RANK (retarray)) runtime_error ("rank of return array incorrect in" - " COUNT intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); + " COUNT intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); if (compile_options.bounds_check) { @@ -130,8 +132,8 @@ count_4_l8 (gfc_array_i4 * const restrict retarray, - retarray->dim[n].lbound; if (extent[n] != ret_extent) runtime_error ("Incorrect extent in return value of" - " COUNT intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, (long int) ret_extent, (long int) extent[n]); } } @@ -146,12 +148,25 @@ count_4_l8 (gfc_array_i4 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_8 * restrict src; - GFC_INTEGER_4 result; + const GFC_LOGICAL_1 * restrict src; + GFC_INTEGER_1 result; src = base; { diff --git a/libgfortran/generated/count_8_l4.c b/libgfortran/generated/count_2_l.c index e6a386e8a8d..eb03c2d5c5f 100644 --- a/libgfortran/generated/count_8_l4.c +++ b/libgfortran/generated/count_2_l.c @@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> -#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_8) +#if defined (HAVE_GFC_INTEGER_2) -extern void count_8_l4 (gfc_array_i8 * const restrict, - gfc_array_l4 * const restrict, const index_type * const restrict); -export_proto(count_8_l4); +extern void count_2_l (gfc_array_i2 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_2_l); void -count_8_l4 (gfc_array_i8 * const restrict retarray, - gfc_array_l4 * const restrict array, +count_2_l (gfc_array_i2 * const restrict retarray, + gfc_array_l1 * 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_LOGICAL_4 * restrict base; - GFC_INTEGER_8 * restrict dest; + const GFC_LOGICAL_1 * restrict base; + GFC_INTEGER_2 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -74,7 +77,7 @@ count_8_l4 (gfc_array_i8 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -99,7 +102,7 @@ count_8_l4 (gfc_array_i8 * const restrict retarray, retarray->offset = 0; retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + alloc_size = sizeof (GFC_INTEGER_2) * retarray->dim[rank-1].stride * extent[rank-1]; if (alloc_size == 0) @@ -116,9 +119,8 @@ count_8_l4 (gfc_array_i8 * const restrict retarray, { if (rank != GFC_DESCRIPTOR_RANK (retarray)) runtime_error ("rank of return array incorrect in" - " COUNT intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); + " COUNT intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); if (compile_options.bounds_check) { @@ -130,8 +132,8 @@ count_8_l4 (gfc_array_i8 * const restrict retarray, - retarray->dim[n].lbound; if (extent[n] != ret_extent) runtime_error ("Incorrect extent in return value of" - " COUNT intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, (long int) ret_extent, (long int) extent[n]); } } @@ -146,12 +148,25 @@ count_8_l4 (gfc_array_i8 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_4 * restrict src; - GFC_INTEGER_8 result; + const GFC_LOGICAL_1 * restrict src; + GFC_INTEGER_2 result; src = base; { diff --git a/libgfortran/generated/count_4_l4.c b/libgfortran/generated/count_4_l.c index 04493b2f4b4..58dcd77c731 100644 --- a/libgfortran/generated/count_4_l4.c +++ b/libgfortran/generated/count_4_l.c @@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> -#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_4) +#if defined (HAVE_GFC_INTEGER_4) -extern void count_4_l4 (gfc_array_i4 * const restrict, - gfc_array_l4 * const restrict, const index_type * const restrict); -export_proto(count_4_l4); +extern void count_4_l (gfc_array_i4 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_4_l); void -count_4_l4 (gfc_array_i4 * const restrict retarray, - gfc_array_l4 * const restrict array, +count_4_l (gfc_array_i4 * const restrict retarray, + gfc_array_l1 * 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_LOGICAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -74,7 +77,7 @@ count_4_l4 (gfc_array_i4 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,9 +119,8 @@ count_4_l4 (gfc_array_i4 * const restrict retarray, { if (rank != GFC_DESCRIPTOR_RANK (retarray)) runtime_error ("rank of return array incorrect in" - " COUNT intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); + " COUNT intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); if (compile_options.bounds_check) { @@ -130,8 +132,8 @@ count_4_l4 (gfc_array_i4 * const restrict retarray, - retarray->dim[n].lbound; if (extent[n] != ret_extent) runtime_error ("Incorrect extent in return value of" - " COUNT intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, (long int) ret_extent, (long int) extent[n]); } } @@ -146,11 +148,24 @@ count_4_l4 (gfc_array_i4 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_INTEGER_4 result; src = base; { diff --git a/libgfortran/generated/count_4_l16.c b/libgfortran/generated/count_4_l16.c deleted file mode 100644 index 5dee5468c64..00000000000 --- a/libgfortran/generated/count_4_l16.c +++ /dev/null @@ -1,203 +0,0 @@ -/* Implementation of the COUNT intrinsic - Copyright 2002, 2007 Free Software Foundation, Inc. - Contributed by Paul Brook <paul@nowt.org> - -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 2 of the License, or (at your option) any later version. - -In addition to the permissions in the GNU General Public License, the -Free Software Foundation gives you unlimited permission to link the -compiled version of this file into combinations with other programs, -and to distribute those combinations without any restriction coming -from the use of this file. (The General Public License restrictions -do apply in other respects; for example, they cover modification of -the file, and distribution when not linked into a combine -executable.) - -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. - -You should have received a copy of the GNU General Public -License along with libgfortran; see the file COPYING. If not, -write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -Boston, MA 02110-1301, USA. */ - -#include "libgfortran.h" -#include <stdlib.h> -#include <assert.h> - - -#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_4) - - -extern void count_4_l16 (gfc_array_i4 * const restrict, - gfc_array_l16 * const restrict, const index_type * const restrict); -export_proto(count_4_l16); - -void -count_4_l16 (gfc_array_i4 * const restrict retarray, - gfc_array_l16 * 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_LOGICAL_16 * restrict base; - GFC_INTEGER_4 * restrict dest; - index_type rank; - index_type n; - index_type len; - index_type delta; - index_type dim; - - /* Make dim zero based to avoid confusion. */ - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride - * extent[rank-1]; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -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" - " COUNT intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); - - if (compile_options.bounds_check) - { - for (n=0; n < rank; n++) - { - index_type ret_extent; - - ret_extent = retarray->dim[n].ubound + 1 - - retarray->dim[n].lbound; - if (extent[n] != ret_extent) - runtime_error ("Incorrect extent in return value of" - " COUNT 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] = retarray->dim[n].stride; - if (extent[n] <= 0) - len = 0; - } - - base = array->data; - dest = retarray->data; - - while (base) - { - const GFC_LOGICAL_16 * restrict src; - GFC_INTEGER_4 result; - src = base; - { - - result = 0; - if (len <= 0) - *dest = 0; - else - { - for (n = 0; n < len; n++, src += delta) - { - - if (*src) - result++; - } - *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. */ - base = NULL; - break; - } - else - { - count[n]++; - base += sstride[n]; - dest += dstride[n]; - } - } - } -} - -#endif diff --git a/libgfortran/generated/count_8_l8.c b/libgfortran/generated/count_8_l.c index 2a1b2a570de..b7db60e00b0 100644 --- a/libgfortran/generated/count_8_l8.c +++ b/libgfortran/generated/count_8_l.c @@ -33,40 +33,43 @@ Boston, MA 02110-1301, USA. */ #include <assert.h> -#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_8) +#if defined (HAVE_GFC_INTEGER_8) -extern void count_8_l8 (gfc_array_i8 * const restrict, - gfc_array_l8 * const restrict, const index_type * const restrict); -export_proto(count_8_l8); +extern void count_8_l (gfc_array_i8 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_8_l); void -count_8_l8 (gfc_array_i8 * const restrict retarray, - gfc_array_l8 * const restrict array, +count_8_l (gfc_array_i8 * const restrict retarray, + gfc_array_l1 * 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_LOGICAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -74,7 +77,7 @@ count_8_l8 (gfc_array_i8 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,9 +119,8 @@ count_8_l8 (gfc_array_i8 * const restrict retarray, { if (rank != GFC_DESCRIPTOR_RANK (retarray)) runtime_error ("rank of return array incorrect in" - " COUNT intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); + " COUNT intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); if (compile_options.bounds_check) { @@ -130,8 +132,8 @@ count_8_l8 (gfc_array_i8 * const restrict retarray, - retarray->dim[n].lbound; if (extent[n] != ret_extent) runtime_error ("Incorrect extent in return value of" - " COUNT intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, (long int) ret_extent, (long int) extent[n]); } } @@ -146,11 +148,24 @@ count_8_l8 (gfc_array_i8 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_INTEGER_8 result; src = base; { diff --git a/libgfortran/generated/count_8_l16.c b/libgfortran/generated/count_8_l16.c deleted file mode 100644 index b0d11164fc5..00000000000 --- a/libgfortran/generated/count_8_l16.c +++ /dev/null @@ -1,203 +0,0 @@ -/* Implementation of the COUNT intrinsic - Copyright 2002, 2007 Free Software Foundation, Inc. - Contributed by Paul Brook <paul@nowt.org> - -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 2 of the License, or (at your option) any later version. - -In addition to the permissions in the GNU General Public License, the -Free Software Foundation gives you unlimited permission to link the -compiled version of this file into combinations with other programs, -and to distribute those combinations without any restriction coming -from the use of this file. (The General Public License restrictions -do apply in other respects; for example, they cover modification of -the file, and distribution when not linked into a combine -executable.) - -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. - -You should have received a copy of the GNU General Public -License along with libgfortran; see the file COPYING. If not, -write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -Boston, MA 02110-1301, USA. */ - -#include "libgfortran.h" -#include <stdlib.h> -#include <assert.h> - - -#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_8) - - -extern void count_8_l16 (gfc_array_i8 * const restrict, - gfc_array_l16 * const restrict, const index_type * const restrict); -export_proto(count_8_l16); - -void -count_8_l16 (gfc_array_i8 * const restrict retarray, - gfc_array_l16 * 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_LOGICAL_16 * restrict base; - GFC_INTEGER_8 * restrict dest; - index_type rank; - index_type n; - index_type len; - index_type delta; - index_type dim; - - /* Make dim zero based to avoid confusion. */ - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride - * extent[rank-1]; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -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" - " COUNT intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); - - if (compile_options.bounds_check) - { - for (n=0; n < rank; n++) - { - index_type ret_extent; - - ret_extent = retarray->dim[n].ubound + 1 - - retarray->dim[n].lbound; - if (extent[n] != ret_extent) - runtime_error ("Incorrect extent in return value of" - " COUNT 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] = retarray->dim[n].stride; - if (extent[n] <= 0) - len = 0; - } - - base = array->data; - dest = retarray->data; - - while (base) - { - const GFC_LOGICAL_16 * restrict src; - GFC_INTEGER_8 result; - src = base; - { - - result = 0; - if (len <= 0) - *dest = 0; - else - { - for (n = 0; n < len; n++, src += delta) - { - - if (*src) - result++; - } - *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. */ - base = NULL; - break; - } - else - { - count[n]++; - base += sstride[n]; - dest += dstride[n]; - } - } - } -} - -#endif |
