aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorSteven G. Kargl <kargl@gcc.gnu.org>2015-11-21 16:25:23 +0000
committerSteven G. Kargl <kargl@gcc.gnu.org>2015-11-21 16:25:23 +0000
commitb1c1d761c1db41d94e6791c0b4f8a476e91fa671 (patch)
tree6c2e1fd6488ddc49dce31cef0d3fa88c4d1e95f5 /gcc
parentd43e15a4243b9e3436fcfa9f38e4d0df9af63074 (diff)
downloadgcc-b1c1d761c1db41d94e6791c0b4f8a476e91fa671.zip
gcc-b1c1d761c1db41d94e6791c0b4f8a476e91fa671.tar.gz
gcc-b1c1d761c1db41d94e6791c0b4f8a476e91fa671.tar.bz2
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
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog8
-rw-r--r--gcc/fortran/intrinsic.c8
-rw-r--r--gcc/fortran/intrinsic.h1
-rw-r--r--gcc/fortran/simplify.c97
-rw-r--r--gcc/testsuite/ChangeLog4
-rw-r--r--gcc/testsuite/gfortran.dg/simplify_cshift_1.f9046
6 files changed, 157 insertions, 7 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e576570..1d11ae7 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 1741092..4e6a0d0 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -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);
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 971cf7c..ca2ad30 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -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 *);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 4df3fe6..9886d9e 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -1789,6 +1789,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)
{
return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
@@ -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;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8607e99..10ef5c2 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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>.
diff --git a/gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 b/gcc/testsuite/gfortran.dg/simplify_cshift_1.f90
new file mode 100644
index 0000000..dbe67f4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/simplify_cshift_1.f90
@@ -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