OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

simplify.c (gfc_simplify_cshift): Implement simplification of CSHIFT. 

2015-11-21  Steven G. Kargl  <kargl@gcc.gnu.org>

	* simplify.c (gfc_simplify_cshift): Implement simplification of CSHIFT.
	(gfc_simplify_spread): Remove a FIXME and add error condition.
	* intrinsic.h: Prototype for gfc_simplify_cshift
	* intrinsic.c (add_functions): Use gfc_simplify_cshift.
 
2015-11-21  Steven G. Kargl  <kargl@gcc.gnu.org>

	* gfortran.dg/simplify_cshift_1.f90: New test.

From-SVN: r230709
This commit is contained in:
Steven G. Kargl 2015-11-21 16:25:23 +00:00
parent d43e15a424
commit b1c1d761c1
6 changed files with 157 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2015-11-21 Steven G. Kargl <kargl@gcc.gnu.org>
* simplify.c (gfc_simplify_cshift): Implement simplification of
CSHIFT for rank=1 arrays.
(gfc_simplify_spread): Remove a FIXME and add error condition.
* intrinsic.h: Prototype for gfc_simplify_cshift
* intrinsic.c (add_functions): Use gfc_simplify_cshift.
2015-11-20 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/68237

8
gcc/fortran/intrinsic.c
View File

@ -1659,9 +1659,11 @@ add_functions (void)
make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);
add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_cshift, NULL, gfc_resolve_cshift,
ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
BT_REAL, dr, GFC_STD_F95,
gfc_check_cshift, gfc_simplify_cshift, gfc_resolve_cshift,
ar, BT_REAL, dr, REQUIRED,
sh, BT_INTEGER, di, REQUIRED,
dm, BT_INTEGER, ii, OPTIONAL);
make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);

1
gcc/fortran/intrinsic.h
View File

@ -271,6 +271,7 @@ gfc_expr *gfc_simplify_conjg (gfc_expr *);
gfc_expr *gfc_simplify_cos (gfc_expr *);
gfc_expr *gfc_simplify_cosh (gfc_expr *);
gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_dcmplx (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_dble (gfc_expr *);
gfc_expr *gfc_simplify_digits (gfc_expr *);

97
gcc/fortran/simplify.c
View File

@ -1788,6 +1788,94 @@ gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
}
gfc_expr *
gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
{
gfc_expr *a, *result;
int dm;
/* DIM is only useful for rank > 1, but deal with it here as one can
set DIM = 1 for rank = 1. */
if (dim)
{
if (!gfc_is_constant_expr (dim))
return NULL;
dm = mpz_get_si (dim->value.integer);
}
else
dm = 1;
/* Copy array into 'a', simplify it, and then test for a constant array.
An unexpected expr_type causes an ICE. */
switch (array->expr_type)
{
case EXPR_VARIABLE:
case EXPR_ARRAY:
a = gfc_copy_expr (array);
gfc_simplify_expr (a, 0);
if (!is_constant_array_expr (a))
{
gfc_free_expr (a);
return NULL;
}
break;
default:
gcc_unreachable ();
}
if (a->rank == 1)
{
gfc_constructor *ca, *cr;
mpz_t size;
int i, j, shft, sz;
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);
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 (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))
{
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);
}
gfc_free_expr (a);
return result;
}
else
{
/* FIXME: Deal with rank > 1 arrays. For now, don't leak memory. */
gfc_free_expr (a);
}
return NULL;
}
gfc_expr *
gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
{
@ -6089,10 +6177,11 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp
}
}
else
/* FIXME: Returning here avoids a regression in array_simplify_1.f90.
Replace NULL with gcc_unreachable() after implementing
gfc_simplify_cshift(). */
return NULL;
{
gfc_error ("Simplification of SPREAD at %L not yet implemented",
&source->where);
return &gfc_bad_expr;
}
if (source->ts.type == BT_CHARACTER)
result->ts.u.cl = source->ts.u.cl;

4
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,7 @@
2015-11-21 Steven G. Kargl <kargl@gcc.gnu.org>
* gfortran.dg/simplify_cshift_1.f90: New test.
2015-11-21 Nathan Sidwell <nathan@acm.org>
* gcc.dg/atomic-generic.c: Include <string.h>.

46
gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 Normal file
View File

@ -0,0 +1,46 @@
! { dg-do run }
program foo
implicit none
type t
integer i
end type t
type(t), parameter :: d(5) = [t(1), t(2), t(3), t(4), t(5)]
type(t) e(5), q(5)
integer, parameter :: a(5) = [1, 2, 3, 4, 5]
integer i, b(5), c(5), v(5)
c = [1, 2, 3, 4, 5]
b = cshift(a, -2)
v = cshift(c, -2)
if (any(b /= v)) call abort
b = cshift(a, 2)
v = cshift(c, 2)
if (any(b /= v)) call abort
! Special cases shift = 0, size(a), 1-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))
if (any(b /= a)) call abort
! simplification of array arg.
b = cshift(2 * a, 0)
if (any(b /= 2 * a)) call abort
! An array of derived types works too.
e = [t(1), t(2), t(3), t(4), t(5)]
e = cshift(e, 3)
q = cshift(d, 3)
do i = 1, 5
if (e(i)%i /= q(i)%i) call abort
end do
end program foo