diff options
Diffstat (limited to 'libgfortran/generated/minloc0_4_i2.c')
-rw-r--r-- | libgfortran/generated/minloc0_4_i2.c | 116 |
1 files changed, 84 insertions, 32 deletions
diff --git a/libgfortran/generated/minloc0_4_i2.c b/libgfortran/generated/minloc0_4_i2.c index c57d5e72643..c33e99cfedb 100644 --- a/libgfortran/generated/minloc0_4_i2.c +++ b/libgfortran/generated/minloc0_4_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + 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). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ minloc0_4_i2 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_4_i2 (gfc_array_i4 * const restrict retarray, extern void mminloc0_4_i2 (gfc_array_i4 * const restrict, - gfc_array_i2 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_4_i2); void mminloc0_4_i2 (gfc_array_i4 * const restrict retarray, gfc_array_i2 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_4_i2 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_INTEGER_2 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_4_i2 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + 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"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_4_i2 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_4_i2 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; |