re PR fortran/45689 ([F03] Missing transformational intrinsic in the trans_func_f2003 list)
2018-01-02 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/45689 PR fortran/83650 * simplify.c (gfc_simplify_cshift): Re-implement to allow full range of arguments. 2018-01-02 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/45689 PR fortran/83650 * gfortran.dg/simplify_cshift_1.f90: Correct erroneous case. * gfortran.dg/simplify_cshift_4.f90: New test. From-SVN: r256084
This commit is contained in:
Thomas Koenig
parent
7616c40b3f
commit
a9ec0cfc36
@ -1,3 +1,10 @@
|
||||
2018-01-02 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
PR fortran/45689
|
||||
PR fortran/83650
|
||||
* simplify.c (gfc_simplify_cshift): Re-implement to allow full
|
||||
range of arguments.
|
||||
|
||||
2018-01-01 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/83076
|
||||
|
||||
@ -1950,92 +1950,212 @@ gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
|
||||
simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
|
||||
}
|
||||
|
||||
/* Simplification routine for cshift. This works by copying the array
|
||||
expressions into a one-dimensional array, shuffling the values into another
|
||||
one-dimensional array and creating the new array expression from this. The
|
||||
shuffling part is basically taken from the library routine. */
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
|
||||
{
|
||||
gfc_expr *a, *result;
|
||||
int dm;
|
||||
gfc_expr *result;
|
||||
int which;
|
||||
gfc_expr **arrayvec, **resultvec;
|
||||
gfc_expr **rptr, **sptr;
|
||||
mpz_t size;
|
||||
size_t arraysize, shiftsize, i;
|
||||
gfc_constructor *array_ctor, *shift_ctor;
|
||||
ssize_t *shiftvec, *hptr;
|
||||
ssize_t shift_val, len;
|
||||
ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
|
||||
hs_ex[GFC_MAX_DIMENSIONS],
|
||||
hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS],
|
||||
a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS],
|
||||
h_extent[GFC_MAX_DIMENSIONS],
|
||||
ss_ex[GFC_MAX_DIMENSIONS];
|
||||
ssize_t rsoffset;
|
||||
int d, n;
|
||||
bool continue_loop;
|
||||
gfc_expr **src, **dest;
|
||||
|
||||
/* DIM is only useful for rank > 1, but deal with it here as one can
|
||||
set DIM = 1 for rank = 1. */
|
||||
if (!is_constant_array_expr (array))
|
||||
return NULL;
|
||||
|
||||
if (shift->rank > 0)
|
||||
gfc_simplify_expr (shift, 1);
|
||||
|
||||
if (!gfc_is_constant_expr (shift))
|
||||
return NULL;
|
||||
|
||||
/* Make dim zero-based. */
|
||||
if (dim)
|
||||
{
|
||||
if (!gfc_is_constant_expr (dim))
|
||||
return NULL;
|
||||
dm = mpz_get_si (dim->value.integer);
|
||||
which = mpz_get_si (dim->value.integer) - 1;
|
||||
}
|
||||
else
|
||||
dm = 1;
|
||||
which = 0;
|
||||
|
||||
/* Copy array into 'a', simplify it, and then test for a constant array. */
|
||||
a = gfc_copy_expr (array);
|
||||
gfc_simplify_expr (a, 0);
|
||||
if (!is_constant_array_expr (a))
|
||||
gfc_array_size (array, &size);
|
||||
arraysize = mpz_get_ui (size);
|
||||
mpz_clear (size);
|
||||
|
||||
result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
|
||||
result->shape = gfc_copy_shape (array->shape, array->rank);
|
||||
result->rank = array->rank;
|
||||
result->ts.u.derived = array->ts.u.derived;
|
||||
|
||||
if (arraysize == 0)
|
||||
return result;
|
||||
|
||||
arrayvec = XCNEWVEC (gfc_expr *, arraysize);
|
||||
array_ctor = gfc_constructor_first (array->value.constructor);
|
||||
for (i = 0; i < arraysize; i++)
|
||||
{
|
||||
gfc_free_expr (a);
|
||||
return NULL;
|
||||
arrayvec[i] = array_ctor->expr;
|
||||
array_ctor = gfc_constructor_next (array_ctor);
|
||||
}
|
||||
|
||||
if (a->rank == 1)
|
||||
resultvec = XCNEWVEC (gfc_expr *, arraysize);
|
||||
|
||||
extent[0] = 1;
|
||||
count[0] = 0;
|
||||
|
||||
for (d=0; d < array->rank; d++)
|
||||
{
|
||||
gfc_constructor *ca, *cr;
|
||||
mpz_t size;
|
||||
int i, j, shft, sz;
|
||||
a_extent[d] = mpz_get_si (array->shape[d]);
|
||||
a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
|
||||
}
|
||||
|
||||
if (!gfc_is_constant_expr (shift))
|
||||
{
|
||||
gfc_free_expr (a);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
shft = mpz_get_si (shift->value.integer);
|
||||
|
||||
/* Case (i): If ARRAY has rank one, element i of the result is
|
||||
ARRAY (1 + MODULO (i + SHIFT - 1, SIZE (ARRAY))). */
|
||||
|
||||
mpz_init (size);
|
||||
gfc_array_size (a, &size);
|
||||
sz = mpz_get_si (size);
|
||||
if (shift->rank > 0)
|
||||
{
|
||||
gfc_array_size (shift, &size);
|
||||
shiftsize = mpz_get_ui (size);
|
||||
mpz_clear (size);
|
||||
|
||||
/* Adjust shft to deal with right or left shifts. */
|
||||
shft = shft < 0 ? 1 - shft : shft;
|
||||
|
||||
/* Special case: Shift to the original order! */
|
||||
if (sz == 0 || shft % sz == 0)
|
||||
return a;
|
||||
|
||||
result = gfc_copy_expr (a);
|
||||
cr = gfc_constructor_first (result->value.constructor);
|
||||
for (i = 0; i < sz; i++, cr = gfc_constructor_next (cr))
|
||||
shiftvec = XCNEWVEC (ssize_t, shiftsize);
|
||||
shift_ctor = gfc_constructor_first (shift->value.constructor);
|
||||
for (d = 0; d < shift->rank; d++)
|
||||
{
|
||||
j = (i + shft) % sz;
|
||||
ca = gfc_constructor_first (a->value.constructor);
|
||||
while (j-- > 0)
|
||||
ca = gfc_constructor_next (ca);
|
||||
cr->expr = gfc_copy_expr (ca->expr);
|
||||
h_extent[d] = mpz_get_si (shift->shape[d]);
|
||||
hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1];
|
||||
}
|
||||
}
|
||||
else
|
||||
shiftvec = NULL;
|
||||
|
||||
/* Shut up compiler */
|
||||
len = 1;
|
||||
rsoffset = 1;
|
||||
|
||||
gfc_free_expr (a);
|
||||
return result;
|
||||
n = 0;
|
||||
for (d=0; d < array->rank; d++)
|
||||
{
|
||||
if (d == which)
|
||||
{
|
||||
rsoffset = a_stride[d];
|
||||
len = a_extent[d];
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n] = 0;
|
||||
extent[n] = a_extent[d];
|
||||
sstride[n] = a_stride[d];
|
||||
ss_ex[n] = sstride[n] * extent[n];
|
||||
if (shiftvec)
|
||||
hs_ex[n] = hstride[n] * extent[n];
|
||||
n++;
|
||||
}
|
||||
}
|
||||
|
||||
if (shiftvec)
|
||||
{
|
||||
for (i = 0; i < shiftsize; i++)
|
||||
{
|
||||
ssize_t val;
|
||||
val = mpz_get_si (shift_ctor->expr->value.integer);
|
||||
val = val % len;
|
||||
if (val < 0)
|
||||
val += len;
|
||||
shiftvec[i] = val;
|
||||
shift_ctor = gfc_constructor_next (shift_ctor);
|
||||
}
|
||||
shift_val = 0;
|
||||
}
|
||||
else
|
||||
{
|
||||
/* FIXME: Deal with rank > 1 arrays. For now, don't leak memory. */
|
||||
|
||||
/* GCC bootstrap is too stupid to realize that the above code for dm
|
||||
is correct. First, dim can be specified for a rank 1 array. It is
|
||||
not needed in this nor used here. Second, the code is simply waiting
|
||||
for someone to implement rank > 1 simplification. For now, add a
|
||||
pessimization to the code that has a zero valid reason to be here. */
|
||||
if (dm > array->rank)
|
||||
gcc_unreachable ();
|
||||
|
||||
gfc_free_expr (a);
|
||||
shift_val = mpz_get_si (shift->value.integer);
|
||||
shift_val = shift_val % len;
|
||||
if (shift_val < 0)
|
||||
shift_val += len;
|
||||
}
|
||||
|
||||
return NULL;
|
||||
continue_loop = true;
|
||||
d = array->rank;
|
||||
rptr = resultvec;
|
||||
sptr = arrayvec;
|
||||
hptr = shiftvec;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
ssize_t sh;
|
||||
if (shiftvec)
|
||||
sh = *hptr;
|
||||
else
|
||||
sh = shift_val;
|
||||
|
||||
src = &sptr[sh * rsoffset];
|
||||
dest = rptr;
|
||||
for (n = 0; n < len - sh; n++)
|
||||
{
|
||||
*dest = *src;
|
||||
dest += rsoffset;
|
||||
src += rsoffset;
|
||||
}
|
||||
src = sptr;
|
||||
for ( n = 0; n < sh; n++)
|
||||
{
|
||||
*dest = *src;
|
||||
dest += rsoffset;
|
||||
src += rsoffset;
|
||||
}
|
||||
rptr += sstride[0];
|
||||
sptr += sstride[0];
|
||||
if (shiftvec)
|
||||
hptr += hstride[0];
|
||||
count[0]++;
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
rptr -= ss_ex[n];
|
||||
sptr -= ss_ex[n];
|
||||
if (shiftvec)
|
||||
hptr -= hs_ex[n];
|
||||
n++;
|
||||
if (n >= d - 1)
|
||||
{
|
||||
continue_loop = false;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
rptr += sstride[n];
|
||||
sptr += sstride[n];
|
||||
if (shiftvec)
|
||||
hptr += hstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
for (i = 0; i < arraysize; i++)
|
||||
{
|
||||
gfc_constructor_append_expr (&result->value.constructor,
|
||||
gfc_copy_expr (resultvec[i]),
|
||||
NULL);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -1,3 +1,10 @@
|
||||
2018-01-02 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
PR fortran/45689
|
||||
PR fortran/83650
|
||||
* gfortran.dg/simplify_cshift_1.f90: Correct erroneous case.
|
||||
* gfortran.dg/simplify_cshift_4.f90: New test.
|
||||
|
||||
2018-01-02 Marek Polacek <polacek@redhat.com>
|
||||
|
||||
PR c++/81860
|
||||
|
||||
@ -23,12 +23,12 @@ program foo
|
||||
v = cshift(c, 2)
|
||||
if (any(b /= v)) call abort
|
||||
|
||||
! Special cases shift = 0, size(a), 1-size(a)
|
||||
! Special cases shift = 0, size(a), -size(a)
|
||||
b = cshift([1, 2, 3, 4, 5], 0)
|
||||
if (any(b /= a)) call abort
|
||||
b = cshift([1, 2, 3, 4, 5], size(a))
|
||||
if (any(b /= a)) call abort
|
||||
b = cshift([1, 2, 3, 4, 5], 1-size(a))
|
||||
b = cshift([1, 2, 3, 4, 5], -size(a))
|
||||
if (any(b /= a)) call abort
|
||||
|
||||
! simplification of array arg.
|
||||
|
||||
37
gcc/testsuite/gfortran.dg/simplify_cshift_4.f90
Normal file
37
gcc/testsuite/gfortran.dg/simplify_cshift_4.f90
Normal file
@ -0,0 +1,37 @@
|
||||
! { dg-do run }
|
||||
program main
|
||||
implicit none
|
||||
integer :: i
|
||||
integer, parameter, dimension(3,3) :: a = &
|
||||
reshape([1,2,3,4,5,6,7,8,9], shape(a))
|
||||
integer, dimension(3,3) :: b
|
||||
integer, parameter, dimension(3,4,5) :: c = &
|
||||
reshape([(i**2,i=1,3*4*5)],shape(c))
|
||||
integer, dimension(3,4,5) :: d
|
||||
integer, dimension(4,5), parameter :: sh1 =&
|
||||
reshape([(i**3-12*i**2,i=1,4*5)],shape(sh1))
|
||||
integer, dimension(3,5), parameter :: sh2 = &
|
||||
reshape([(i**3-7*i**2,i=1,3*5)], shape(sh2))
|
||||
integer, dimension(3,4), parameter :: sh3 = &
|
||||
reshape([(i**3-3*i**2,i=1,3*4)], shape(sh3))
|
||||
integer, parameter, dimension(3,4,5) :: c1 = cshift(c,shift=sh1,dim=1)
|
||||
integer, parameter, dimension(3,4,5) :: c2 = cshift(c,shift=sh2,dim=2)
|
||||
integer, parameter, dimension(3,4,5) :: c3 = cshift(c,shift=sh3,dim=3)
|
||||
|
||||
b = a
|
||||
if (any(cshift(a,1) /= cshift(b,1))) call abort
|
||||
if (any(cshift(a,2) /= cshift(b,2))) call abort
|
||||
if (any(cshift(a,1,dim=2) /= cshift(b,1,dim=2))) call abort
|
||||
d = c
|
||||
if (any(cshift(c,1) /= cshift(d,1))) call abort
|
||||
if (any(cshift(c,2) /= cshift(d,2))) call abort
|
||||
if (any(cshift(c,3) /= cshift(d,3))) call abort
|
||||
|
||||
if (any(cshift(c,1,dim=2) /= cshift(d,1,dim=2))) call abort
|
||||
if (any(cshift(c,2,dim=2) /= cshift(d,2,dim=2))) call abort
|
||||
if (any(cshift(c,3,dim=3) /= cshift(d,3,dim=3))) call abort
|
||||
|
||||
if (any(cshift(d,shift=sh1,dim=1) /= c1)) call abort
|
||||
if (any(cshift(d,shift=sh2,dim=2) /= c2)) call abort
|
||||
if (any(cshift(d,shift=sh3,dim=3) /= c3)) call abort
|
||||
end program main
|
||||
Loading…
x
Reference in New Issue
Block a user