From: tkoenig Date: Tue, 25 Aug 2009 17:05:10 +0000 (+0000) Subject: 2009-08-25 Thomas Koenig X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=0d8ca6ab8ff5ac1f4839aa42f05fd366ad100b86 2009-08-25 Thomas Koenig PR libfortran/34670 * runtime/bounds.c (count_0): New function. * intrinsics/unpack_generic (unpack_bounds): New function. (unpack_internal): Remove zero stride checks. (unpack1): Use unpack_bounds. (unpack1_char): Likeweise. (unpack1_char4): Likewise (unpack0): Likewise. (unpack0_char): Likewise. (unpack0_char4): Likewise. 2009-08-25 Thomas Koenig PR libfortran/34670 * gfortran.dg/unpack_bounds_1.f90: New test. * gfortran.dg/unpack_bounds_2.f90: New test. * gfortran.dg/unpack_bounds_3.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151085 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7cfcccd1752..702fb685ceb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2009-08-25 Thomas Koenig + + PR libfortran/34670 + * gfortran.dg/unpack_bounds_1.f90: New test. + * gfortran.dg/unpack_bounds_2.f90: New test. + * gfortran.dg/unpack_bounds_3.f90: New test. + 2009-08-25 Eric Botcazou * gnat.dg/slice7.adb: New test. diff --git a/gcc/testsuite/gfortran.dg/unpack_bounds_1.f90 b/gcc/testsuite/gfortran.dg/unpack_bounds_1.f90 new file mode 100755 index 00000000000..360790b5705 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unpack_bounds_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" } +program main + integer, allocatable, dimension(:) :: vector + integer, allocatable, dimension(:,:) :: res + logical, allocatable, dimension(:,:) :: mask + + allocate (vector(2)) + allocate (mask(2,2)) + allocate (res(2,1)) + + vector = 1 + mask = reshape((/ .TRUE., .FALSE., .FALSE., .TRUE. /),(/2,2/)) + res = unpack(vector, mask, 0) + print *,res +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" } diff --git a/gcc/testsuite/gfortran.dg/unpack_bounds_2.f90 b/gcc/testsuite/gfortran.dg/unpack_bounds_2.f90 new file mode 100755 index 00000000000..fd049f5abbb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unpack_bounds_2.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect size of return value in UNPACK intrinsic: should be at least 3, is 2" } +program main + integer, allocatable, dimension(:) :: vector + integer, allocatable, dimension(:,:) :: res + logical, allocatable, dimension(:,:) :: mask + + allocate (vector(2)) + allocate (mask(2,2)) + allocate (res(2,2)) + + vector = 1 + mask = reshape((/ .TRUE., .TRUE., .FALSE., .TRUE. /),(/2,2/)) + res = unpack(vector, mask, 0) + print *,res +end program main +! { dg-output "Fortran runtime error: Incorrect size of return value in UNPACK intrinsic: should be at least 3, is 2" } diff --git a/gcc/testsuite/gfortran.dg/unpack_bounds_3.f90 b/gcc/testsuite/gfortran.dg/unpack_bounds_3.f90 new file mode 100755 index 00000000000..c6734b14c1f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unpack_bounds_3.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect size of return value in UNPACK intrinsic: should be at least 3, is 2" } +program main + integer, allocatable, dimension(:) :: vector + integer, allocatable, dimension(:,:) :: res + integer, allocatable, dimension(:,:) :: field + logical, allocatable, dimension(:,:) :: mask + + allocate (vector(3)) + allocate (mask(2,2)) + allocate (res(2,2)) + allocate (field(3,2)) + + vector = 1 + field = 0 + mask = reshape((/ .TRUE., .TRUE., .FALSE., .TRUE. /),(/2,2/)) + res = unpack(vector, mask, field) + print *,res +end program main +! { dg-output "Fortran runtime error: Incorrect extent in FIELD of UNPACK intrinsic in dimension 1: is 3, should be 2" } diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index b1494ca0c50..8ef88c0d025 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,16 @@ +2009-08-25 Thomas Koenig + + PR libfortran/34670 + * runtime/bounds.c (count_0): New function. + * intrinsics/unpack_generic (unpack_bounds): New function. + (unpack_internal): Remove zero stride checks. + (unpack1): Use unpack_bounds. + (unpack1_char): Likeweise. + (unpack1_char4): Likewise + (unpack0): Likewise. + (unpack0_char): Likewise. + (unpack0_char4): Likewise. + 2009-08-24 Steven G. Kargl PR fortran/41157 diff --git a/libgfortran/intrinsics/unpack_generic.c b/libgfortran/intrinsics/unpack_generic.c index 47d4a6dddef..4a4c2192e9d 100644 --- a/libgfortran/intrinsics/unpack_generic.c +++ b/libgfortran/intrinsics/unpack_generic.c @@ -28,6 +28,32 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include #include +/* All the bounds checking for unpack in one function. If field is NULL, + we don't check it, for the unpack0 functions. */ + +static void +unpack_bounds (gfc_array_char *ret, const gfc_array_char *vector, + const gfc_array_l1 *mask, const gfc_array_char *field) +{ + index_type vec_size, mask_count; + vec_size = size0 ((array_t *) vector); + mask_count = count_0 (mask); + if (vec_size < mask_count) + runtime_error ("Incorrect size of return value in UNPACK" + " intrinsic: should be at least %ld, is" + " %ld", (long int) mask_count, + (long int) vec_size); + + if (field != NULL) + bounds_equal_extents ((array_t *) field, (array_t *) mask, + "FIELD", "UNPACK"); + + if (ret->data != NULL) + bounds_equal_extents ((array_t *) ret, (array_t *) mask, + "return value", "UNPACK"); + +} + static void unpack_internal (gfc_array_char *ret, const gfc_array_char *vector, const gfc_array_l1 *mask, const gfc_array_char *field, @@ -113,21 +139,12 @@ unpack_internal (gfc_array_char *ret, const gfc_array_char *vector, fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n); mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n); } - if (rstride[0] == 0) - rstride[0] = size; } if (empty) return; - if (fstride[0] == 0) - fstride[0] = fsize; - if (mstride[0] == 0) - mstride[0] = 1; - vstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0); - if (vstride0 == 0) - vstride0 = size; rstride0 = rstride[0]; fstride0 = fstride[0]; mstride0 = mstride[0]; @@ -193,6 +210,9 @@ unpack1 (gfc_array_char *ret, const gfc_array_char *vector, index_type type_size; index_type size; + if (unlikely(compile_options.bounds_check)) + unpack_bounds (ret, vector, mask, field); + type_size = GFC_DTYPE_TYPE_SIZE (vector); size = GFC_DESCRIPTOR_SIZE (vector); @@ -343,6 +363,10 @@ unpack1_char (gfc_array_char *ret, const gfc_array_char *field, GFC_INTEGER_4 vector_length, GFC_INTEGER_4 field_length) { + + if (unlikely(compile_options.bounds_check)) + unpack_bounds (ret, vector, mask, field); + unpack_internal (ret, vector, mask, field, vector_length, field_length); } @@ -360,6 +384,10 @@ unpack1_char4 (gfc_array_char *ret, const gfc_array_char *field, GFC_INTEGER_4 vector_length, GFC_INTEGER_4 field_length) { + + if (unlikely(compile_options.bounds_check)) + unpack_bounds (ret, vector, mask, field); + unpack_internal (ret, vector, mask, field, vector_length * sizeof (gfc_char4_t), field_length * sizeof (gfc_char4_t)); @@ -379,6 +407,9 @@ unpack0 (gfc_array_char *ret, const gfc_array_char *vector, index_type type_size; index_type size; + if (unlikely(compile_options.bounds_check)) + unpack_bounds (ret, vector, mask, NULL); + type_size = GFC_DTYPE_TYPE_SIZE (vector); size = GFC_DESCRIPTOR_SIZE (vector); @@ -530,6 +561,9 @@ unpack0_char (gfc_array_char *ret, { gfc_array_char tmp; + if (unlikely(compile_options.bounds_check)) + unpack_bounds (ret, vector, mask, NULL); + memset (&tmp, 0, sizeof (tmp)); tmp.dtype = 0; tmp.data = field; @@ -551,6 +585,9 @@ unpack0_char4 (gfc_array_char *ret, { gfc_array_char tmp; + if (unlikely(compile_options.bounds_check)) + unpack_bounds (ret, vector, mask, NULL); + memset (&tmp, 0, sizeof (tmp)); tmp.dtype = 0; tmp.data = field; diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 439c791fca2..40cb080a78c 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -1282,6 +1282,10 @@ extern void bounds_ifunction_return (array_t *, const index_type *, const char *, const char *); internal_proto(bounds_ifunction_return); +extern index_type count_0 (const gfc_array_l1 *); + +internal_proto(count_0); + /* Internal auxiliary functions for cshift */ void cshift0_i1 (gfc_array_i1 *, const gfc_array_i1 *, ssize_t, int); diff --git a/libgfortran/runtime/bounds.c b/libgfortran/runtime/bounds.c index 8a7affd2e18..2d2ed76e6b8 100644 --- a/libgfortran/runtime/bounds.c +++ b/libgfortran/runtime/bounds.c @@ -197,3 +197,76 @@ bounds_reduced_extents (array_t *a, array_t *b, int which, const char *a_name, } } } + +/* count_0 - count all the true elements in an array. The front + end usually inlines this, we need this for bounds checking + for unpack. */ + +index_type count_0 (const gfc_array_l1 * array) +{ + const GFC_LOGICAL_1 * restrict base; + index_type rank; + int kind; + int continue_loop; + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type result; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + kind = GFC_DESCRIPTOR_SIZE (array); + + base = array->data; + + if (kind == 1 || kind == 2 || kind == 4 || kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, kind); + } + else + internal_error (NULL, "Funny sized logical array in count_0"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + + if (extent[n] < 0) + return 0; + } + + result = 0; + continue_loop = 1; + while (continue_loop) + { + if (*base) + result ++; + + count[0]++; + base += sstride[0]; + n = 0; + while (count[n] == extent[n]) + { + count[n] = 0; + base -= sstride[n] * extent[n]; + n++; + if (n == rank) + { + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + } + return result; +}