procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR libfortran/34670 (bounds checking for array intrinsics)

Browse source 
2009-08-25  Thomas Koenig  <tkoenig@gcc.gnu.org>

	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  <tkoenig@gcc.gnu.org>

	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.

From-SVN: r151085
This commit is contained in:
Thomas Koenig 2009-08-25 17:05:10 +00:00
parent f76d6e6f37
commit 8c39b98796
8 changed files with 200 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,10 @@
2009-08-25 Thomas Koenig <tkoenig@gcc.gnu.org>
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 <ebotcazou@adacore.com>
* gnat.dg/slice7.adb: New test.

18
gcc/testsuite/gfortran.dg/unpack_bounds_1.f90 Executable file
View file

@ -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" }

18
gcc/testsuite/gfortran.dg/unpack_bounds_2.f90 Executable file
View file

@ -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" }

21
gcc/testsuite/gfortran.dg/unpack_bounds_3.f90 Executable file
View file

@ -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" }

13
libgfortran/ChangeLog
View file

@ -1,3 +1,16 @@
2009-08-25 Thomas Koenig <tkoenig@gcc.gnu.org>
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 <kargl@gcc.gnu.org>
PR fortran/41157

55
libgfortran/intrinsics/unpack_generic.c
View file

@ -28,6 +28,32 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include <assert.h>
#include <string.h>
/* 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;

4
libgfortran/libgfortran.h
View file

@ -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);

73
libgfortran/runtime/bounds.c
View file

@ -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;
}