/* Simplify intrinsic functions at compile-time.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
#include "intrinsic.h"
#include "target-memory.h"
+/* Savely advance an array constructor by 'n' elements.
+ Mainly used by simplifiers of transformational intrinsics. */
+#define ADVANCE(ctor, n) do { int i; for (i = 0; i < n && ctor; ++i) ctor = ctor->next; } while (0)
+
gfc_expr gfc_bad_expr;
}
}
+/* Test that the expression is an constant array. */
+
+static bool
+is_constant_array_expr (gfc_expr *e)
+{
+ gfc_constructor *c;
+
+ if (e == NULL)
+ return true;
+
+ if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
+ return false;
+
+ for (c = e->value.constructor; c; c = c->next)
+ if (c->expr->expr_type != EXPR_CONSTANT)
+ return false;
+
+ return true;
+}
+
+
+/* Initialize a transformational result expression with a given value. */
+
+static void
+init_result_expr (gfc_expr *e, int init, gfc_expr *array)
+{
+ if (e && e->expr_type == EXPR_ARRAY)
+ {
+ gfc_constructor *ctor = e->value.constructor;
+ while (ctor)
+ {
+ init_result_expr (ctor->expr, init, array);
+ ctor = ctor->next;
+ }
+ }
+ else if (e && e->expr_type == EXPR_CONSTANT)
+ {
+ int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ int length;
+ gfc_char_t *string;
+
+ switch (e->ts.type)
+ {
+ case BT_LOGICAL:
+ e->value.logical = (init ? 1 : 0);
+ break;
+
+ case BT_INTEGER:
+ if (init == INT_MIN)
+ mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
+ else if (init == INT_MAX)
+ mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
+ else
+ mpz_set_si (e->value.integer, init);
+ break;
+
+ case BT_REAL:
+ if (init == INT_MIN)
+ {
+ mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+ mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
+ }
+ else if (init == INT_MAX)
+ mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+ else
+ mpfr_set_si (e->value.real, init, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+#ifdef HAVE_mpc
+ mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
+#else
+ mpfr_set_si (e->value.complex.r, init, GFC_RND_MODE);
+ mpfr_set_si (e->value.complex.i, 0, GFC_RND_MODE);
+#endif
+ break;
+
+ case BT_CHARACTER:
+ if (init == INT_MIN)
+ {
+ gfc_expr *len = gfc_simplify_len (array, NULL);
+ gfc_extract_int (len, &length);
+ string = gfc_get_wide_string (length + 1);
+ gfc_wide_memset (string, 0, length);
+ }
+ else if (init == INT_MAX)
+ {
+ gfc_expr *len = gfc_simplify_len (array, NULL);
+ gfc_extract_int (len, &length);
+ string = gfc_get_wide_string (length + 1);
+ gfc_wide_memset (string, 255, length);
+ }
+ else
+ {
+ length = 0;
+ string = gfc_get_wide_string (1);
+ }
+
+ string[length] = '\0';
+ e->value.character.length = length;
+ e->value.character.string = string;
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+ }
+ else
+ gcc_unreachable();
+}
+
+
+/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */
+
+static gfc_expr *
+compute_dot_product (gfc_constructor *ctor_a, int stride_a,
+ gfc_constructor *ctor_b, int stride_b)
+{
+ gfc_expr *result;
+ gfc_expr *a = ctor_a->expr, *b = ctor_b->expr;
+
+ gcc_assert (gfc_compare_types (&a->ts, &b->ts));
+
+ result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
+ init_result_expr (result, 0, NULL);
+
+ while (ctor_a && ctor_b)
+ {
+ /* Copying of expressions is required as operands are free'd
+ by the gfc_arith routines. */
+ switch (result->ts.type)
+ {
+ case BT_LOGICAL:
+ result = gfc_or (result,
+ gfc_and (gfc_copy_expr (ctor_a->expr),
+ gfc_copy_expr (ctor_b->expr)));
+ break;
+
+ case BT_INTEGER:
+ case BT_REAL:
+ case BT_COMPLEX:
+ result = gfc_add (result,
+ gfc_multiply (gfc_copy_expr (ctor_a->expr),
+ gfc_copy_expr (ctor_b->expr)));
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+
+ ADVANCE (ctor_a, stride_a);
+ ADVANCE (ctor_b, stride_b);
+ }
+
+ return result;
+}
+
+
+/* Build a result expression for transformational intrinsics,
+ depending on DIM. */
+
+static gfc_expr *
+transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
+ int kind, locus* where)
+{
+ gfc_expr *result;
+ int i, nelem;
+
+ if (!dim || array->rank == 1)
+ return gfc_constant_result (type, kind, where);
+
+ result = gfc_start_constructor (type, kind, where);
+ result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
+ result->rank = array->rank - 1;
+
+ /* gfc_array_size() would count the number of elements in the constructor,
+ we have not built those yet. */
+ nelem = 1;
+ for (i = 0; i < result->rank; ++i)
+ nelem *= mpz_get_ui (result->shape[i]);
+
+ for (i = 0; i < nelem; ++i)
+ {
+ gfc_expr *e = gfc_constant_result (type, kind, where);
+ gfc_append_constructor (result, e);
+ }
+
+ return result;
+}
+
+
+typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
+
+/* Wrapper function, implements 'op1 += 1'. Only called if MASK
+ of COUNT intrinsic is .TRUE..
+
+ Interface and implimentation mimics arith functions as
+ gfc_add, gfc_multiply, etc. */
+
+static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2)
+{
+ gfc_expr *result;
+
+ gcc_assert (op1->ts.type == BT_INTEGER);
+ gcc_assert (op2->ts.type == BT_LOGICAL);
+ gcc_assert (op2->value.logical);
+
+ result = gfc_copy_expr (op1);
+ mpz_add_ui (result->value.integer, result->value.integer, 1);
+
+ gfc_free_expr (op1);
+ gfc_free_expr (op2);
+ return result;
+}
+
+
+/* Transforms an ARRAY with operation OP, according to MASK, to a
+ scalar RESULT. E.g. called if
+
+ REAL, PARAMETER :: array(n, m) = ...
+ REAL, PARAMETER :: s = SUM(array)
+
+ where OP == gfc_add(). */
+
+static gfc_expr *
+simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
+ transformational_op op)
+{
+ gfc_expr *a, *m;
+ gfc_constructor *array_ctor, *mask_ctor;
+
+ /* Shortcut for constant .FALSE. MASK. */
+ if (mask
+ && mask->expr_type == EXPR_CONSTANT
+ && !mask->value.logical)
+ return result;
+
+ array_ctor = array->value.constructor;
+ mask_ctor = NULL;
+ if (mask && mask->expr_type == EXPR_ARRAY)
+ mask_ctor = mask->value.constructor;
+
+ while (array_ctor)
+ {
+ a = array_ctor->expr;
+ array_ctor = array_ctor->next;
+
+ /* A constant MASK equals .TRUE. here and can be ignored. */
+ if (mask_ctor)
+ {
+ m = mask_ctor->expr;
+ mask_ctor = mask_ctor->next;
+ if (!m->value.logical)
+ continue;
+ }
+
+ result = op (result, gfc_copy_expr (a));
+ }
+
+ return result;
+}
+
+/* Transforms an ARRAY with operation OP, according to MASK, to an
+ array RESULT. E.g. called if
+
+ REAL, PARAMETER :: array(n, m) = ...
+ REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
+
+ where OP == gfc_multiply(). */
+
+static gfc_expr *
+simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
+ gfc_expr *mask, transformational_op op)
+{
+ mpz_t size;
+ int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
+ gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
+ gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
+
+ int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
+ sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
+ tmpstride[GFC_MAX_DIMENSIONS];
+
+ /* Shortcut for constant .FALSE. MASK. */
+ if (mask
+ && mask->expr_type == EXPR_CONSTANT
+ && !mask->value.logical)
+ return result;
+
+ /* Build an indexed table for array element expressions to minimize
+ linked-list traversal. Masked elements are set to NULL. */
+ gfc_array_size (array, &size);
+ arraysize = mpz_get_ui (size);
+
+ arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
+
+ array_ctor = array->value.constructor;
+ mask_ctor = NULL;
+ if (mask && mask->expr_type == EXPR_ARRAY)
+ mask_ctor = mask->value.constructor;
+
+ for (i = 0; i < arraysize; ++i)
+ {
+ arrayvec[i] = array_ctor->expr;
+ array_ctor = array_ctor->next;
+
+ if (mask_ctor)
+ {
+ if (!mask_ctor->expr->value.logical)
+ arrayvec[i] = NULL;
+
+ mask_ctor = mask_ctor->next;
+ }
+ }
+
+ /* Same for the result expression. */
+ gfc_array_size (result, &size);
+ resultsize = mpz_get_ui (size);
+ mpz_clear (size);
+
+ resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
+ result_ctor = result->value.constructor;
+ for (i = 0; i < resultsize; ++i)
+ {
+ resultvec[i] = result_ctor->expr;
+ result_ctor = result_ctor->next;
+ }
+
+ gfc_extract_int (dim, &dim_index);
+ dim_index -= 1; /* zero-base index */
+ dim_extent = 0;
+ dim_stride = 0;
+
+ for (i = 0, n = 0; i < array->rank; ++i)
+ {
+ count[i] = 0;
+ tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
+ if (i == dim_index)
+ {
+ dim_extent = mpz_get_si (array->shape[i]);
+ dim_stride = tmpstride[i];
+ continue;
+ }
+
+ extent[n] = mpz_get_si (array->shape[i]);
+ sstride[n] = tmpstride[i];
+ dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
+ n += 1;
+ }
+
+ done = false;
+ base = arrayvec;
+ dest = resultvec;
+ while (!done)
+ {
+ for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
+ if (*src)
+ *dest = op (*dest, gfc_copy_expr (*src));
+
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+
+ n = 0;
+ while (!done && count[n] == extent[n])
+ {
+ count[n] = 0;
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+
+ n++;
+ if (n < result->rank)
+ {
+ count [n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ else
+ done = true;
+ }
+ }
+
+ /* Place updated expression in result constructor. */
+ result_ctor = result->value.constructor;
+ for (i = 0; i < resultsize; ++i)
+ {
+ result_ctor->expr = resultvec[i];
+ result_ctor = result_ctor->next;
+ }
+
+ gfc_free (arrayvec);
+ gfc_free (resultvec);
+ return result;
+}
+
+
/********************** Simplification functions *****************************/
gfc_set_model_kind (e->ts.kind);
+#ifdef HAVE_mpc
+ mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
+#else
mpfr_hypot (result->value.real, e->value.complex.r,
e->value.complex.i, GFC_RND_MODE);
+#endif
result = range_check (result, "CABS");
break;
return result;
}
-/* We use the processor's collating sequence, because all
- systems that gfortran currently works on are ASCII. */
-gfc_expr *
-gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
+static gfc_expr *
+simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
{
gfc_expr *result;
- int c, kind;
- const char *ch;
+ int kind;
+ bool too_large = false;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind);
+ kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
if (kind == -1)
return &gfc_bad_expr;
- ch = gfc_extract_int (e, &c);
-
- if (ch != NULL)
- gfc_internal_error ("gfc_simplify_achar: %s", ch);
-
- if (gfc_option.warn_surprising && (c < 0 || c > 127))
- gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
+ if (mpz_cmp_si (e->value.integer, 0) < 0)
+ {
+ gfc_error ("Argument of %s function at %L is negative", name,
&e->where);
+ return &gfc_bad_expr;
+ }
- result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+ if (ascii && gfc_option.warn_surprising
+ && mpz_cmp_si (e->value.integer, 127) > 0)
+ gfc_warning ("Argument of %s function at %L outside of range [0,127]",
+ name, &e->where);
- result->value.character.string = gfc_getmem (2);
+ if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
+ too_large = true;
+ else if (kind == 4)
+ {
+ mpz_t t;
+ mpz_init_set_ui (t, 2);
+ mpz_pow_ui (t, t, 32);
+ mpz_sub_ui (t, t, 1);
+ if (mpz_cmp (e->value.integer, t) > 0)
+ too_large = true;
+ mpz_clear (t);
+ }
+
+ if (too_large)
+ {
+ gfc_error ("Argument of %s function at %L is too large for the "
+ "collating sequence of kind %d", name, &e->where, kind);
+ return &gfc_bad_expr;
+ }
+ result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+ result->value.character.string = gfc_get_wide_string (2);
result->value.character.length = 1;
- result->value.character.string[0] = c;
+ result->value.character.string[0] = mpz_get_ui (e->value.integer);
result->value.character.string[1] = '\0'; /* For debugger */
return result;
}
+
+/* We use the processor's collating sequence, because all
+ systems that gfortran currently works on are ASCII. */
+
+gfc_expr *
+gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
+{
+ return simplify_achar_char (e, k, "ACHAR", true);
+}
+
+
gfc_expr *
gfc_simplify_acos (gfc_expr *x)
{
{
gfc_expr *result;
int count, i, len;
- char ch;
+ gfc_char_t ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
result->value.character.length = len;
- result->value.character.string = gfc_getmem (len + 1);
+ result->value.character.string = gfc_get_wide_string (len + 1);
for (count = 0, i = 0; i < len; ++i)
{
{
gfc_expr *result;
int count, i, len;
- char ch;
+ gfc_char_t ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
result->value.character.length = len;
- result->value.character.string = gfc_getmem (len + 1);
+ result->value.character.string = gfc_get_wide_string (len + 1);
for (count = 0, i = len - 1; i >= 0; --i)
{
return NULL;
result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
- mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
+ mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
return range_check (result, "AIMAG");
}
gfc_expr *
+gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
+{
+ gfc_expr *result;
+
+ if (!is_constant_array_expr (mask)
+ || !gfc_is_constant_expr (dim))
+ return NULL;
+
+ result = transformational_result (mask, dim, mask->ts.type,
+ mask->ts.kind, &mask->where);
+ init_result_expr (result, true, NULL);
+
+ return !dim || mask->rank == 1 ?
+ simplify_transformation_to_scalar (result, mask, NULL, gfc_and) :
+ simplify_transformation_to_array (result, mask, dim, NULL, gfc_and);
+}
+
+
+gfc_expr *
gfc_simplify_dint (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
{
result = gfc_constant_result (BT_INTEGER, kind, &x->where);
mpz_and (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "AND");
}
else /* BT_LOGICAL */
{
result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
result->value.logical = x->value.logical && y->value.logical;
+ return result;
}
+}
- return range_check (result, "AND");
+
+gfc_expr *
+gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
+{
+ gfc_expr *result;
+
+ if (!is_constant_array_expr (mask)
+ || !gfc_is_constant_expr (dim))
+ return NULL;
+
+ result = transformational_result (mask, dim, mask->ts.type,
+ mask->ts.kind, &mask->where);
+ init_result_expr (result, false, NULL);
+
+ return !dim || mask->rank == 1 ?
+ simplify_transformation_to_scalar (result, mask, NULL, gfc_or) :
+ simplify_transformation_to_array (result, mask, dim, NULL, gfc_or);
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
{
gfc_error ("If first argument of ATAN2 %L is zero, then the "
"second argument must not be zero", &x->where);
- gfc_free_expr (result);
return &gfc_bad_expr;
}
- mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ATAN2");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_J0");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_J1");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
+ gfc_expr *x ATTRIBUTE_UNUSED)
+{
+ gfc_expr *result;
+ long n;
+
+ if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ n = mpz_get_si (order->value.integer);
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_JN");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_Y0");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_Y1");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
+ gfc_expr *x ATTRIBUTE_UNUSED)
+{
+ gfc_expr *result;
+ long n;
+
+ if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ n = mpz_get_si (order->value.integer);
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
- return range_check (result, "ATAN2");
+ return range_check (result, "BESSEL_YN");
}
ceil = gfc_copy_expr (e);
mpfr_ceil (ceil->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
gfc_free_expr (ceil);
gfc_expr *
gfc_simplify_char (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *result;
- int c, kind;
- const char *ch;
-
- kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
- if (kind == -1)
- return &gfc_bad_expr;
-
- if (e->expr_type != EXPR_CONSTANT)
- return NULL;
-
- ch = gfc_extract_int (e, &c);
-
- if (ch != NULL)
- gfc_internal_error ("gfc_simplify_char: %s", ch);
-
- if (c < 0 || c > UCHAR_MAX)
- gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
- &e->where);
-
- result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
-
- result->value.character.length = 1;
- result->value.character.string = gfc_getmem (2);
-
- result->value.character.string[0] = c;
- result->value.character.string[1] = '\0'; /* For debugger */
-
- return result;
+ return simplify_achar_char (e, k, "CHAR", false);
}
result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
+#ifndef HAVE_mpc
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
+#endif
switch (x->ts.type)
{
case BT_INTEGER:
if (!x->is_boz)
+#ifdef HAVE_mpc
+ mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
+#else
mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
+#endif
break;
case BT_REAL:
+#ifdef HAVE_mpc
+ mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
+#else
mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
+#endif
break;
case BT_COMPLEX:
+#ifdef HAVE_mpc
+ mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+#else
mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
+#endif
break;
default:
{
case BT_INTEGER:
if (!y->is_boz)
- mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
+ mpfr_set_z (mpc_imagref (result->value.complex),
+ y->value.integer, GFC_RND_MODE);
break;
case BT_REAL:
- mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
+ mpfr_set (mpc_imagref (result->value.complex),
+ y->value.real, GFC_RND_MODE);
break;
default:
if (x->is_boz)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.kind = result->ts.kind;
ts.type = BT_REAL;
if (!gfc_convert_boz (x, &ts))
return &gfc_bad_expr;
- mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
+ mpfr_set (mpc_realref (result->value.complex),
+ x->value.real, GFC_RND_MODE);
}
if (y && y->is_boz)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.kind = result->ts.kind;
ts.type = BT_REAL;
if (!gfc_convert_boz (y, &ts))
return &gfc_bad_expr;
- mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
+ mpfr_set (mpc_imagref (result->value.complex),
+ y->value.real, GFC_RND_MODE);
}
return range_check (result, name);
}
+/* Function called when we won't simplify an expression like CMPLX (or
+ COMPLEX or DCMPLX) but still want to convert BOZ arguments. */
+
+static gfc_expr *
+only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
+{
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_REAL;
+ ts.kind = kind;
+
+ if (x->is_boz && !gfc_convert_boz (x, &ts))
+ return &gfc_bad_expr;
+
+ if (y && y->is_boz && !gfc_convert_boz (y, &ts))
+ return &gfc_bad_expr;
+
+ return NULL;
+}
+
+
gfc_expr *
gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
{
int kind;
- if (x->expr_type != EXPR_CONSTANT
- || (y != NULL && y->expr_type != EXPR_CONSTANT))
- return NULL;
-
kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
if (kind == -1)
return &gfc_bad_expr;
+ if (x->expr_type != EXPR_CONSTANT
+ || (y != NULL && y->expr_type != EXPR_CONSTANT))
+ return only_convert_cmplx_boz (x, y, kind);
+
return simplify_cmplx ("CMPLX", x, y, kind);
}
{
int kind;
- if (x->expr_type != EXPR_CONSTANT
- || (y != NULL && y->expr_type != EXPR_CONSTANT))
- return NULL;
-
if (x->ts.type == BT_INTEGER)
{
if (y->ts.type == BT_INTEGER)
kind = x->ts.kind;
}
+ if (x->expr_type != EXPR_CONSTANT
+ || (y != NULL && y->expr_type != EXPR_CONSTANT))
+ return only_convert_cmplx_boz (x, y, kind);
+
return simplify_cmplx ("COMPLEX", x, y, kind);
}
return NULL;
result = gfc_copy_expr (e);
+#ifdef HAVE_mpc
+ mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
+#else
mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
+#endif
return range_check (result, "CONJG");
}
gfc_simplify_cos (gfc_expr *x)
{
gfc_expr *result;
- mpfr_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
break;
case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind);
+#ifdef HAVE_mpc
+ mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+#else
+ {
+ mpfr_t xp, xq;
mpfr_init (xp);
mpfr_init (xq);
mpfr_mul (xp, xp, xq, GFC_RND_MODE);
mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
- mpfr_clear (xp);
- mpfr_clear (xq);
+ mpfr_clears (xp, xq, NULL);
+ }
+#endif
break;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
gfc_expr *
+gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
+{
+ gfc_expr *result;
+
+ if (!is_constant_array_expr (mask)
+ || !gfc_is_constant_expr (dim)
+ || !gfc_is_constant_expr (kind))
+ return NULL;
+
+ result = transformational_result (mask, dim,
+ BT_INTEGER,
+ get_kind (BT_INTEGER, kind, "COUNT",
+ gfc_default_integer_kind),
+ &mask->where);
+
+ init_result_expr (result, 0, NULL);
+
+ /* Passing MASK twice, once as data array, once as mask.
+ Whenever gfc_count is called, '1' is added to the result. */
+ return !dim || mask->rank == 1 ?
+ simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
+ simplify_transformation_to_array (result, mask, dim, mask, gfc_count);
+}
+
+
+gfc_expr *
gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
{
if (x->expr_type != EXPR_CONSTANT
|| (y != NULL && y->expr_type != EXPR_CONSTANT))
- return NULL;
+ return only_convert_cmplx_boz (x, y, gfc_default_double_kind);
return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
}
gfc_expr *
gfc_simplify_dble (gfc_expr *e)
{
- gfc_expr *result;
+ gfc_expr *result = NULL;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
if (e->ts.type == BT_INTEGER && e->is_boz)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.type = BT_REAL;
ts.kind = gfc_default_double_kind;
result = gfc_copy_expr (e);
if (!gfc_convert_boz (result, &ts))
- return &gfc_bad_expr;
+ {
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
}
return range_check (result, "DBLE");
}
+gfc_expr*
+gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
+{
+ gfc_expr *result;
+
+ if (!is_constant_array_expr (vector_a)
+ || !is_constant_array_expr (vector_b))
+ return NULL;
+
+ gcc_assert (vector_a->rank == 1);
+ gcc_assert (vector_b->rank == 1);
+ gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
+
+ if (vector_a->value.constructor && vector_b->value.constructor)
+ return compute_dot_product (vector_a->value.constructor, 1,
+ vector_b->value.constructor, 1);
+
+ /* Zero sized array ... */
+ result = gfc_constant_result (vector_a->ts.type,
+ vector_a->ts.kind,
+ &vector_a->where);
+ init_result_expr (result, 0, NULL);
+ return result;
+}
+
+
gfc_expr *
gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
{
gfc_expr *
+gfc_simplify_erf (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ERF");
+}
+
+
+gfc_expr *
+gfc_simplify_erfc (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ERFC");
+}
+
+
+/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
+
+#define MAX_ITER 200
+#define ARG_LIMIT 12
+
+/* Calculate ERFC_SCALED directly by its definition:
+
+ ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
+
+ using a large precision for intermediate results. This is used for all
+ but large values of the argument. */
+static void
+fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
+{
+ mp_prec_t prec;
+ mpfr_t a, b;
+
+ prec = mpfr_get_default_prec ();
+ mpfr_set_default_prec (10 * prec);
+
+ mpfr_init (a);
+ mpfr_init (b);
+
+ mpfr_set (a, arg, GFC_RND_MODE);
+ mpfr_sqr (b, a, GFC_RND_MODE);
+ mpfr_exp (b, b, GFC_RND_MODE);
+ mpfr_erfc (a, a, GFC_RND_MODE);
+ mpfr_mul (a, a, b, GFC_RND_MODE);
+
+ mpfr_set (res, a, GFC_RND_MODE);
+ mpfr_set_default_prec (prec);
+
+ mpfr_clear (a);
+ mpfr_clear (b);
+}
+
+/* Calculate ERFC_SCALED using a power series expansion in 1/arg:
+
+ ERFC_SCALED(x) = 1 / (x * sqrt(pi))
+ * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
+ / (2 * x**2)**n)
+
+ This is used for large values of the argument. Intermediate calculations
+ are performed with twice the precision. We don't do a fixed number of
+ iterations of the sum, but stop when it has converged to the required
+ precision. */
+static void
+asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
+{
+ mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
+ mpz_t num;
+ mp_prec_t prec;
+ unsigned i;
+
+ prec = mpfr_get_default_prec ();
+ mpfr_set_default_prec (2 * prec);
+
+ mpfr_init (sum);
+ mpfr_init (x);
+ mpfr_init (u);
+ mpfr_init (v);
+ mpfr_init (w);
+ mpz_init (num);
+
+ mpfr_init (oldsum);
+ mpfr_init (sumtrunc);
+ mpfr_set_prec (oldsum, prec);
+ mpfr_set_prec (sumtrunc, prec);
+
+ mpfr_set (x, arg, GFC_RND_MODE);
+ mpfr_set_ui (sum, 1, GFC_RND_MODE);
+ mpz_set_ui (num, 1);
+
+ mpfr_set (u, x, GFC_RND_MODE);
+ mpfr_sqr (u, u, GFC_RND_MODE);
+ mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
+ mpfr_pow_si (u, u, -1, GFC_RND_MODE);
+
+ for (i = 1; i < MAX_ITER; i++)
+ {
+ mpfr_set (oldsum, sum, GFC_RND_MODE);
+
+ mpz_mul_ui (num, num, 2 * i - 1);
+ mpz_neg (num, num);
+
+ mpfr_set (w, u, GFC_RND_MODE);
+ mpfr_pow_ui (w, w, i, GFC_RND_MODE);
+
+ mpfr_set_z (v, num, GFC_RND_MODE);
+ mpfr_mul (v, v, w, GFC_RND_MODE);
+
+ mpfr_add (sum, sum, v, GFC_RND_MODE);
+
+ mpfr_set (sumtrunc, sum, GFC_RND_MODE);
+ if (mpfr_cmp (sumtrunc, oldsum) == 0)
+ break;
+ }
+
+ /* We should have converged by now; otherwise, ARG_LIMIT is probably
+ set too low. */
+ gcc_assert (i < MAX_ITER);
+
+ /* Divide by x * sqrt(Pi). */
+ mpfr_const_pi (u, GFC_RND_MODE);
+ mpfr_sqrt (u, u, GFC_RND_MODE);
+ mpfr_mul (u, u, x, GFC_RND_MODE);
+ mpfr_div (sum, sum, u, GFC_RND_MODE);
+
+ mpfr_set (res, sum, GFC_RND_MODE);
+ mpfr_set_default_prec (prec);
+
+ mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
+ mpz_clear (num);
+}
+
+
+gfc_expr *
+gfc_simplify_erfc_scaled (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
+ asympt_erfc_scaled (result->value.real, x->value.real);
+ else
+ fullprec_erfc_scaled (result->value.real, x->value.real);
+
+ return range_check (result, "ERFC_SCALED");
+}
+
+#undef MAX_ITER
+#undef ARG_LIMIT
+
+
+gfc_expr *
gfc_simplify_epsilon (gfc_expr *e)
{
gfc_expr *result;
gfc_simplify_exp (gfc_expr *x)
{
gfc_expr *result;
- mpfr_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind);
+#ifdef HAVE_mpc
+ mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+#else
+ {
+ mpfr_t xp, xq;
mpfr_init (xp);
mpfr_init (xq);
mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
- mpfr_clear (xp);
- mpfr_clear (xq);
+ mpfr_clears (xp, xq, NULL);
+ }
+#endif
break;
default:
if (a->is_boz)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.type = BT_REAL;
ts.kind = gfc_default_real_kind;
result = gfc_copy_expr (a);
if (!gfc_convert_boz (result, &ts))
- return &gfc_bad_expr;
+ {
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
}
else
result = gfc_int2real (a, gfc_default_real_kind);
mpfr_init (floor);
mpfr_floor (floor, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, floor);
+ gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
mpfr_clear (floor);
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
-
if (mpfr_sgn (x->value.real) == 0)
{
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
return result;
}
+ gfc_set_model_kind (x->ts.kind);
mpfr_init (exp);
mpfr_init (absv);
mpfr_init (pow2);
mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
- mpfr_clear (exp);
- mpfr_clear (absv);
- mpfr_clear (pow2);
+ mpfr_clears (exp, absv, pow2, NULL);
return range_check (result, "FRACTION");
}
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
-
mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "GAMMA");
return result;
}
+
+gfc_expr *
+gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
+ return range_check (result, "HYPOT");
+}
+
+
/* We use the processor's collating sequence, because all
systems that gfortran currently works on are ASCII. */
gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
- int index;
+ gfc_char_t index;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
return &gfc_bad_expr;
}
- index = (unsigned char) e->value.character.string[0];
+ index = e->value.character.string[0];
if (gfc_option.warn_surprising && index > 127)
gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
- return range_check (result, "IBCLR");
+ return result;
}
}
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ convert_mpz_to_unsigned (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
- bits = gfc_getmem (bitsize * sizeof (int));
+ bits = XCNEWVEC (int, bitsize);
for (i = 0; i < bitsize; i++)
bits[i] = 0;
gfc_free (bits);
- return range_check (result, "IBITS");
+ convert_mpz_to_signed (result->value.integer,
+ gfc_integer_kinds[k].bit_size);
+
+ return result;
}
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
- return range_check (result, "IBSET");
+ return result;
}
gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
- int index;
+ gfc_char_t index;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
return &gfc_bad_expr;
}
- index = (unsigned char) e->value.character.string[0];
-
- if (index < 0 || index > UCHAR_MAX)
- gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
+ index = e->value.character.string[0];
if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
return &gfc_bad_expr;
int back, len, lensub;
int i, j, k, count, index = 0, start;
- if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
+ || ( b != NULL && b->expr_type != EXPR_CONSTANT))
return NULL;
if (b != NULL && b->value.logical != 0)
gfc_expr *
gfc_simplify_int (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *rpart, *rtrunc, *result;
+ gfc_expr *result = NULL;
int kind;
kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
switch (e->ts.type)
{
case BT_INTEGER:
- mpz_set (result->value.integer, e->value.integer);
+ result = gfc_int2int (e, kind);
break;
case BT_REAL:
- rtrunc = gfc_copy_expr (e);
- mpfr_trunc (rtrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
- gfc_free_expr (rtrunc);
+ result = gfc_real2int (e, kind);
break;
case BT_COMPLEX:
- rpart = gfc_complex2real (e, kind);
- rtrunc = gfc_copy_expr (rpart);
- mpfr_trunc (rtrunc->value.real, rpart->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
- gfc_free_expr (rpart);
- gfc_free_expr (rtrunc);
+ result = gfc_complex2int (e, kind);
break;
default:
gfc_error ("Argument of INT at %L is not a valid type", &e->where);
- gfc_free_expr (result);
return &gfc_bad_expr;
}
static gfc_expr *
-gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
+simplify_intconv (gfc_expr *e, int kind, const char *name)
{
- gfc_expr *rpart, *rtrunc, *result;
+ gfc_expr *result = NULL;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
switch (e->ts.type)
{
case BT_INTEGER:
- mpz_set (result->value.integer, e->value.integer);
+ result = gfc_int2int (e, kind);
break;
case BT_REAL:
- rtrunc = gfc_copy_expr (e);
- mpfr_trunc (rtrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
- gfc_free_expr (rtrunc);
+ result = gfc_real2int (e, kind);
break;
case BT_COMPLEX:
- rpart = gfc_complex2real (e, kind);
- rtrunc = gfc_copy_expr (rpart);
- mpfr_trunc (rtrunc->value.real, rpart->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
- gfc_free_expr (rpart);
- gfc_free_expr (rtrunc);
+ result = gfc_complex2int (e, kind);
break;
default:
gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
- gfc_free_expr (result);
return &gfc_bad_expr;
}
gfc_expr *
gfc_simplify_int2 (gfc_expr *e)
{
- return gfc_simplify_intconv (e, 2, "INT2");
+ return simplify_intconv (e, 2, "INT2");
}
gfc_expr *
gfc_simplify_int8 (gfc_expr *e)
{
- return gfc_simplify_intconv (e, 8, "INT8");
+ return simplify_intconv (e, 8, "INT8");
}
gfc_expr *
gfc_simplify_long (gfc_expr *e)
{
- return gfc_simplify_intconv (e, 4, "LONG");
+ return simplify_intconv (e, 4, "LONG");
}
rtrunc = gfc_copy_expr (e);
mpfr_trunc (rtrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
gfc_free_expr (rtrunc);
return range_check (result, "IFIX");
rtrunc = gfc_copy_expr (e);
mpfr_trunc (rtrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
gfc_free_expr (rtrunc);
return range_check (result, "IDINT");
gfc_expr *
+gfc_simplify_is_iostat_end (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
+ &x->where);
+ result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_END) == 0);
+
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_is_iostat_eor (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
+ &x->where);
+ result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_EOR) == 0);
+
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_isnan (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
+ &x->where);
+ result->value.logical = mpfr_nan_p (x->value.real);
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
{
gfc_expr *result;
return range_check (result, "ISHFT");
}
- bits = gfc_getmem (isize * sizeof (int));
+ bits = XCNEWVEC (int, isize);
for (i = 0; i < isize; i++)
bits[i] = mpz_tstbit (e->value.integer, i);
convert_mpz_to_unsigned (result->value.integer, isize);
- bits = gfc_getmem (ssize * sizeof (int));
+ bits = XCNEWVEC (int, ssize);
for (i = 0; i < ssize; i++)
bits[i] = mpz_tstbit (e->value.integer, i);
static gfc_expr *
simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
- gfc_array_spec *as)
+ gfc_array_spec *as, gfc_ref *ref)
{
gfc_expr *l, *u, *result;
int k;
{
if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
return gfc_copy_expr (as->lower[d-1]);
- else
- return NULL;
- }
-
- /* Then, we need to know the extent of the given dimension. */
- l = as->lower[d-1];
- u = as->upper[d-1];
-
- if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
- return NULL;
+ else
+ return NULL;
+ }
k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
gfc_default_integer_kind);
result = gfc_constant_result (BT_INTEGER, k, &array->where);
- if (mpz_cmp (l->value.integer, u->value.integer) > 0)
+
+ /* Then, we need to know the extent of the given dimension. */
+ if (ref->u.ar.type == AR_FULL)
{
- /* Zero extent. */
- if (upper)
- mpz_set_si (result->value.integer, 0);
+ l = as->lower[d-1];
+ u = as->upper[d-1];
+
+ if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpz_cmp (l->value.integer, u->value.integer) > 0)
+ {
+ /* Zero extent. */
+ if (upper)
+ mpz_set_si (result->value.integer, 0);
+ else
+ mpz_set_si (result->value.integer, 1);
+ }
else
- mpz_set_si (result->value.integer, 1);
+ {
+ /* Nonzero extent. */
+ if (upper)
+ mpz_set (result->value.integer, u->value.integer);
+ else
+ mpz_set (result->value.integer, l->value.integer);
+ }
}
else
{
- /* Nonzero extent. */
if (upper)
- mpz_set (result->value.integer, u->value.integer);
+ {
+ if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer)
+ != SUCCESS)
+ return NULL;
+ }
else
- mpz_set (result->value.integer, l->value.integer);
+ mpz_set_si (result->value.integer, (long int) 1);
}
return range_check (result, upper ? "UBOUND" : "LBOUND");
case AR_FULL:
/* We're done because 'as' has already been set in the
previous iteration. */
- goto done;
+ if (!ref->next)
+ goto done;
+
+ /* Fall through. */
- case AR_SECTION:
case AR_UNKNOWN:
return NULL;
+
+ case AR_SECTION:
+ as = ref->u.ar.as;
+ goto done;
}
gcc_unreachable ();
/* Simplify the bounds for each dimension. */
for (d = 0; d < array->rank; d++)
{
- bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
+ bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref);
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
{
int j;
k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
gfc_default_integer_kind);
if (k == -1)
- return &gfc_bad_expr;
+ {
+ gfc_free_expr (e);
+ return &gfc_bad_expr;
+ }
e->ts.kind = k;
/* The result is a rank 1 array; its size is the rank of the first
return &gfc_bad_expr;
}
- return simplify_bound_dim (array, kind, d, upper, as);
+ return simplify_bound_dim (array, kind, d, upper, as, ref);
}
}
gfc_expr *
+gfc_simplify_leadz (gfc_expr *e)
+{
+ gfc_expr *result;
+ unsigned long lz, bs;
+ int i;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ bs = gfc_integer_kinds[i].bit_size;
+ if (mpz_cmp_si (e->value.integer, 0) == 0)
+ lz = bs;
+ else if (mpz_cmp_si (e->value.integer, 0) < 0)
+ lz = 0;
+ else
+ lz = bs - mpz_sizeinbase (e->value.integer, 2);
+
+ result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
+ &e->where);
+ mpz_set_ui (result->value.integer, lz);
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
{
result = gfc_constant_result (BT_INTEGER, k, &e->where);
mpz_set_si (result->value.integer, e->value.character.length);
- return range_check (result, "LEN");
+ if (gfc_range_check (result) == ARITH_OK)
+ return result;
+ else
+ {
+ gfc_free_expr (result);
+ return NULL;
+ }
}
if (e->ts.cl != NULL && e->ts.cl->length != NULL
{
result = gfc_constant_result (BT_INTEGER, k, &e->where);
mpz_set (result->value.integer, e->ts.cl->length->value.integer);
- return range_check (result, "LEN");
+ if (gfc_range_check (result) == ARITH_OK)
+ return result;
+ else
+ {
+ gfc_free_expr (result);
+ return NULL;
+ }
}
return NULL;
}
gfc_expr *
-gfc_simplify_lgamma (gfc_expr *x __attribute__((unused)))
+gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED)
{
-#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
gfc_expr *result;
int sg;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
-
mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
return range_check (result, "LGAMMA");
-#else
- return NULL;
-#endif
}
gfc_simplify_log (gfc_expr *x)
{
gfc_expr *result;
- mpfr_t xr, xi;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
switch (x->ts.type)
{
break;
case BT_COMPLEX:
- if ((mpfr_sgn (x->value.complex.r) == 0)
- && (mpfr_sgn (x->value.complex.i) == 0))
+ if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
+ && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
{
gfc_error ("Complex argument of LOG at %L cannot be zero",
&x->where);
return &gfc_bad_expr;
}
+ gfc_set_model_kind (x->ts.kind);
+#ifdef HAVE_mpc
+ mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+#else
+ {
+ mpfr_t xr, xi;
mpfr_init (xr);
mpfr_init (xi);
mpfr_sqrt (xr, xr, GFC_RND_MODE);
mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
- mpfr_clear (xr);
- mpfr_clear (xi);
-
+ mpfr_clears (xr, xi, NULL);
+ }
+#endif
break;
default:
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- gfc_set_model_kind (x->ts.kind);
-
if (mpfr_sgn (x->value.real) <= 0)
{
gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
}
+gfc_expr*
+gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
+{
+ gfc_expr *result;
+ gfc_constructor *ma_ctor, *mb_ctor;
+ int row, result_rows, col, result_columns, stride_a, stride_b;
+
+ if (!is_constant_array_expr (matrix_a)
+ || !is_constant_array_expr (matrix_b))
+ return NULL;
+
+ gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
+ result = gfc_start_constructor (matrix_a->ts.type,
+ matrix_a->ts.kind,
+ &matrix_a->where);
+
+ if (matrix_a->rank == 1 && matrix_b->rank == 2)
+ {
+ result_rows = 1;
+ result_columns = mpz_get_si (matrix_b->shape[0]);
+ stride_a = 1;
+ stride_b = mpz_get_si (matrix_b->shape[0]);
+
+ result->rank = 1;
+ result->shape = gfc_get_shape (result->rank);
+ mpz_init_set_si (result->shape[0], result_columns);
+ }
+ else if (matrix_a->rank == 2 && matrix_b->rank == 1)
+ {
+ result_rows = mpz_get_si (matrix_b->shape[0]);
+ result_columns = 1;
+ stride_a = mpz_get_si (matrix_a->shape[0]);
+ stride_b = 1;
+
+ result->rank = 1;
+ result->shape = gfc_get_shape (result->rank);
+ mpz_init_set_si (result->shape[0], result_rows);
+ }
+ else if (matrix_a->rank == 2 && matrix_b->rank == 2)
+ {
+ result_rows = mpz_get_si (matrix_a->shape[0]);
+ result_columns = mpz_get_si (matrix_b->shape[1]);
+ stride_a = mpz_get_si (matrix_a->shape[1]);
+ stride_b = mpz_get_si (matrix_b->shape[0]);
+
+ result->rank = 2;
+ result->shape = gfc_get_shape (result->rank);
+ mpz_init_set_si (result->shape[0], result_rows);
+ mpz_init_set_si (result->shape[1], result_columns);
+ }
+ else
+ gcc_unreachable();
+
+ ma_ctor = matrix_a->value.constructor;
+ mb_ctor = matrix_b->value.constructor;
+
+ for (col = 0; col < result_columns; ++col)
+ {
+ ma_ctor = matrix_a->value.constructor;
+
+ for (row = 0; row < result_rows; ++row)
+ {
+ gfc_expr *e;
+ e = compute_dot_product (ma_ctor, stride_a,
+ mb_ctor, 1);
+
+ gfc_append_constructor (result, e);
+
+ ADVANCE (ma_ctor, 1);
+ }
+
+ ADVANCE (mb_ctor, stride_b);
+ }
+
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
+{
+ if (tsource->expr_type != EXPR_CONSTANT
+ || fsource->expr_type != EXPR_CONSTANT
+ || mask->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return gfc_copy_expr (mask->value.logical ? tsource : fsource);
+}
+
+
+/* Selects bewteen current value and extremum for simplify_min_max
+ and simplify_minval_maxval. */
+static void
+min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
+{
+ switch (arg->ts.type)
+ {
+ case BT_INTEGER:
+ if (mpz_cmp (arg->value.integer,
+ extremum->value.integer) * sign > 0)
+ mpz_set (extremum->value.integer, arg->value.integer);
+ break;
+
+ case BT_REAL:
+ /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
+ if (sign > 0)
+ mpfr_max (extremum->value.real, extremum->value.real,
+ arg->value.real, GFC_RND_MODE);
+ else
+ mpfr_min (extremum->value.real, extremum->value.real,
+ arg->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_CHARACTER:
+#define LENGTH(x) ((x)->value.character.length)
+#define STRING(x) ((x)->value.character.string)
+ if (LENGTH(extremum) < LENGTH(arg))
+ {
+ gfc_char_t *tmp = STRING(extremum);
+
+ STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
+ memcpy (STRING(extremum), tmp,
+ LENGTH(extremum) * sizeof (gfc_char_t));
+ gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
+ LENGTH(arg) - LENGTH(extremum));
+ STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
+ LENGTH(extremum) = LENGTH(arg);
+ gfc_free (tmp);
+ }
+
+ if (gfc_compare_string (arg, extremum) * sign > 0)
+ {
+ gfc_free (STRING(extremum));
+ STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
+ memcpy (STRING(extremum), STRING(arg),
+ LENGTH(arg) * sizeof (gfc_char_t));
+ gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
+ LENGTH(extremum) - LENGTH(arg));
+ STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
+ }
+#undef LENGTH
+#undef STRING
+ break;
+
+ default:
+ gfc_internal_error ("simplify_min_max(): Bad type in arglist");
+ }
+}
+
+
/* This function is special since MAX() can take any number of
arguments. The simplified expression is a rewritten version of the
argument list containing at most one constant element. Other
continue;
}
- switch (arg->expr->ts.type)
- {
- case BT_INTEGER:
- if (mpz_cmp (arg->expr->value.integer,
- extremum->expr->value.integer) * sign > 0)
- mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
- break;
-
- case BT_REAL:
- /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
- if (sign > 0)
- mpfr_max (extremum->expr->value.real, extremum->expr->value.real,
- arg->expr->value.real, GFC_RND_MODE);
- else
- mpfr_min (extremum->expr->value.real, extremum->expr->value.real,
- arg->expr->value.real, GFC_RND_MODE);
- break;
-
- case BT_CHARACTER:
-#define LENGTH(x) ((x)->expr->value.character.length)
-#define STRING(x) ((x)->expr->value.character.string)
- if (LENGTH(extremum) < LENGTH(arg))
- {
- char * tmp = STRING(extremum);
-
- STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
- memcpy (STRING(extremum), tmp, LENGTH(extremum));
- memset (&STRING(extremum)[LENGTH(extremum)], ' ',
- LENGTH(arg) - LENGTH(extremum));
- STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
- LENGTH(extremum) = LENGTH(arg);
- gfc_free (tmp);
- }
-
- if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
- {
- gfc_free (STRING(extremum));
- STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
- memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
- memset (&STRING(extremum)[LENGTH(arg)], ' ',
- LENGTH(extremum) - LENGTH(arg));
- STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
- }
-#undef LENGTH
-#undef STRING
- break;
-
-
- default:
- gfc_internal_error ("simplify_min_max(): Bad type in arglist");
- }
+ min_max_choose (arg->expr, extremum->expr, sign);
/* Delete the extra constant argument. */
if (last == NULL)
}
+/* This is a simplified version of simplify_min_max to provide
+ simplification of minval and maxval for a vector. */
+
+static gfc_expr *
+simplify_minval_maxval (gfc_expr *expr, int sign)
+{
+ gfc_constructor *ctr, *extremum;
+ gfc_intrinsic_sym * specific;
+
+ extremum = NULL;
+ specific = expr->value.function.isym;
+
+ ctr = expr->value.constructor;
+
+ for (; ctr; ctr = ctr->next)
+ {
+ if (ctr->expr->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (extremum == NULL)
+ {
+ extremum = ctr;
+ continue;
+ }
+
+ min_max_choose (ctr->expr, extremum->expr, sign);
+ }
+
+ if (extremum == NULL)
+ return NULL;
+
+ /* Convert to the correct type and kind. */
+ if (expr->ts.type != BT_UNKNOWN)
+ return gfc_convert_constant (extremum->expr,
+ expr->ts.type, expr->ts.kind);
+
+ if (specific->ts.type != BT_UNKNOWN)
+ return gfc_convert_constant (extremum->expr,
+ specific->ts.type, specific->ts.kind);
+
+ return gfc_copy_expr (extremum->expr);
+}
+
+
+gfc_expr *
+gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
+{
+ if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
+ return NULL;
+
+ return simplify_minval_maxval (array, -1);
+}
+
+
+gfc_expr *
+gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
+{
+ if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
+ return NULL;
+ return simplify_minval_maxval (array, 1);
+}
+
+
gfc_expr *
gfc_simplify_maxexponent (gfc_expr *x)
{
gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
- mpfr_t quot, iquot, term;
+ mpfr_t tmp;
int kind;
if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
}
gfc_set_model_kind (kind);
- mpfr_init (quot);
- mpfr_init (iquot);
- mpfr_init (term);
-
- mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
- mpfr_trunc (iquot, quot);
- mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
- mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
-
- mpfr_clear (quot);
- mpfr_clear (iquot);
- mpfr_clear (term);
+ mpfr_init (tmp);
+ mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_trunc (tmp, tmp);
+ mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+ mpfr_clear (tmp);
break;
default:
gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
{
gfc_expr *result;
- mpfr_t quot, iquot, term;
+ mpfr_t tmp;
int kind;
if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
}
gfc_set_model_kind (kind);
- mpfr_init (quot);
- mpfr_init (iquot);
- mpfr_init (term);
-
- mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
- mpfr_floor (iquot, quot);
- mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
- mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
-
- mpfr_clear (quot);
- mpfr_clear (iquot);
- mpfr_clear (term);
+ mpfr_init (tmp);
+ mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_floor (tmp, tmp);
+ mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+ mpfr_clear (tmp);
break;
default:
return &gfc_bad_expr;
}
- gfc_set_model_kind (x->ts.kind);
result = gfc_copy_expr (x);
/* Save current values of emin and emax. */
mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
mpfr_get_prec(result->value.real) + 1);
mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
+ mpfr_check_range (result->value.real, 0, GMP_RNDU);
if (mpfr_sgn (s->value.real) > 0)
{
if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
{
gfc_error ("Result of NEAREST is NaN at %L", &result->where);
+ gfc_free_expr (result);
return &gfc_bad_expr;
}
mpfr_round (itrunc->value.real, e->value.real);
- gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
+ gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
gfc_free_expr (itrunc);
gfc_expr *result;
result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
- result->value.character.string = gfc_getmem (2);
+ result->value.character.string = gfc_get_wide_string (2);
result->value.character.length = 1;
result->value.character.string[0] = '\n';
result->value.character.string[1] = '\0'; /* For debugger */
{
result = gfc_constant_result (BT_INTEGER, kind, &x->where);
mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "OR");
}
else /* BT_LOGICAL */
{
result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
result->value.logical = x->value.logical || y->value.logical;
+ return result;
}
+}
+
+
+gfc_expr *
+gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
+{
+ gfc_expr *result;
+ gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
+
+ if (!is_constant_array_expr(array)
+ || !is_constant_array_expr(vector)
+ || (!gfc_is_constant_expr (mask)
+ && !is_constant_array_expr(mask)))
+ return NULL;
+
+ result = gfc_start_constructor (array->ts.type,
+ array->ts.kind,
+ &array->where);
+
+ array_ctor = array->value.constructor;
+ vector_ctor = vector ? vector->value.constructor : NULL;
+
+ if (mask->expr_type == EXPR_CONSTANT
+ && mask->value.logical)
+ {
+ /* Copy all elements of ARRAY to RESULT. */
+ while (array_ctor)
+ {
+ gfc_append_constructor (result,
+ gfc_copy_expr (array_ctor->expr));
+
+ ADVANCE (array_ctor, 1);
+ ADVANCE (vector_ctor, 1);
+ }
+ }
+ else if (mask->expr_type == EXPR_ARRAY)
+ {
+ /* Copy only those elements of ARRAY to RESULT whose
+ MASK equals .TRUE.. */
+ mask_ctor = mask->value.constructor;
+ while (mask_ctor)
+ {
+ if (mask_ctor->expr->value.logical)
+ {
+ gfc_append_constructor (result,
+ gfc_copy_expr (array_ctor->expr));
+ ADVANCE (vector_ctor, 1);
+ }
+
+ ADVANCE (array_ctor, 1);
+ ADVANCE (mask_ctor, 1);
+ }
+ }
+
+ /* Append any left-over elements from VECTOR to RESULT. */
+ while (vector_ctor)
+ {
+ gfc_append_constructor (result,
+ gfc_copy_expr (vector_ctor->expr));
+ ADVANCE (vector_ctor, 1);
+ }
+
+ result->shape = gfc_get_shape (1);
+ gfc_array_size (result, &result->shape[0]);
+
+ if (array->ts.type == BT_CHARACTER)
+ result->ts.cl = array->ts.cl;
- return range_check (result, "OR");
+ return result;
}
gfc_expr *
+gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ gfc_expr *result;
+
+ if (!is_constant_array_expr (array)
+ || !gfc_is_constant_expr (dim))
+ return NULL;
+
+ if (mask
+ && !is_constant_array_expr (mask)
+ && mask->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = transformational_result (array, dim, array->ts.type,
+ array->ts.kind, &array->where);
+ init_result_expr (result, 1, NULL);
+
+ return !dim || array->rank == 1 ?
+ simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
+ simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
+}
+
+
+gfc_expr *
gfc_simplify_radix (gfc_expr *e)
{
gfc_expr *result;
gfc_expr *
gfc_simplify_real (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *result;
+ gfc_expr *result = NULL;
int kind;
if (e->ts.type == BT_COMPLEX)
if (e->ts.type == BT_INTEGER && e->is_boz)
{
gfc_typespec ts;
+ gfc_clear_ts (&ts);
ts.type = BT_REAL;
ts.kind = kind;
result = gfc_copy_expr (e);
if (!gfc_convert_boz (result, &ts))
- return &gfc_bad_expr;
+ {
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
}
+
return range_check (result, "REAL");
}
return NULL;
result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+#ifdef HAVE_mpc
+ mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
+#else
mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
+#endif
return range_check (result, "REALPART");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- if (len || mpz_sgn (e->ts.cl->length->value.integer) != 0)
+ if (len ||
+ (e->ts.cl->length &&
+ mpz_sgn (e->ts.cl->length->value.integer)) != 0)
{
const char *res = gfc_extract_int (n, &ncop);
gcc_assert (res == NULL);
if (ncop == 0)
{
- result->value.character.string = gfc_getmem (1);
+ result->value.character.string = gfc_get_wide_string (1);
result->value.character.length = 0;
result->value.character.string[0] = '\0';
return result;
}
result->value.character.length = nlen;
- result->value.character.string = gfc_getmem (nlen + 1);
+ result->value.character.string = gfc_get_wide_string (nlen + 1);
for (i = 0; i < ncop; i++)
for (j = 0; j < len; j++)
- result->value.character.string[j + i * len]
- = e->value.character.string[j];
+ result->value.character.string[j+i*len]= e->value.character.string[j];
result->value.character.string[nlen] = '\0'; /* For debugger */
return result;
size_t nsource;
gfc_expr *e;
- /* Unpack the shape array. */
- if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
- return NULL;
-
- if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
+ /* Check that argument expression types are OK. */
+ if (!is_constant_array_expr (source)
+ || !is_constant_array_expr (shape_exp)
+ || !is_constant_array_expr (pad)
+ || !is_constant_array_expr (order_exp))
return NULL;
- if (pad != NULL
- && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
- return NULL;
-
- if (order_exp != NULL
- && (order_exp->expr_type != EXPR_ARRAY
- || !gfc_is_constant_expr (order_exp)))
- return NULL;
+ /* Proceed with simplification, unpacking the array. */
mpz_init (index);
rank = 0;
if (e == NULL)
break;
- if (gfc_extract_int (e, &shape[rank]) != NULL)
- {
- gfc_error ("Integer too large in shape specification at %L",
- &e->where);
- gfc_free_expr (e);
- goto bad_reshape;
- }
-
- gfc_free_expr (e);
-
- if (rank >= GFC_MAX_DIMENSIONS)
- {
- gfc_error ("Too many dimensions in shape specification for RESHAPE "
- "at %L", &e->where);
-
- goto bad_reshape;
- }
+ gfc_extract_int (e, &shape[rank]);
- if (shape[rank] < 0)
- {
- gfc_error ("Shape specification at %L cannot be negative",
- &e->where);
- goto bad_reshape;
- }
+ gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
+ gcc_assert (shape[rank] >= 0);
+ gfc_free_expr (e);
rank++;
}
- if (rank == 0)
- {
- gfc_error ("Shape specification at %L cannot be the null array",
- &shape_exp->where);
- goto bad_reshape;
- }
+ gcc_assert (rank > 0);
/* Now unpack the order array if present. */
if (order_exp == NULL)
for (i = 0; i < rank; i++)
{
e = gfc_get_array_element (order_exp, i);
- if (e == NULL)
- {
- gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
- "size as SHAPE parameter", &order_exp->where);
- goto bad_reshape;
- }
-
- if (gfc_extract_int (e, &order[i]) != NULL)
- {
- gfc_error ("Error in ORDER parameter of RESHAPE at %L",
- &e->where);
- gfc_free_expr (e);
- goto bad_reshape;
- }
+ gcc_assert (e);
+ gfc_extract_int (e, &order[i]);
gfc_free_expr (e);
- if (order[i] < 1 || order[i] > rank)
- {
- gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
- &e->where);
- goto bad_reshape;
- }
-
+ gcc_assert (order[i] >= 1 && order[i] <= rank);
order[i]--;
-
- if (x[order[i]])
- {
- gfc_error ("Invalid permutation in ORDER parameter at %L",
- &e->where);
- goto bad_reshape;
- }
-
+ gcc_assert (x[order[i]] == 0);
x[order[i]] = 1;
}
}
for (i = 0; i < rank; i++)
x[i] = 0;
- for (;;)
+ while (nsource > 0 || npad > 0)
{
/* Figure out which element to extract. */
mpz_set_ui (index, 0);
}
if (mpz_cmp_ui (index, INT_MAX) > 0)
- gfc_internal_error ("Reshaped array too large at %L", &e->where);
+ gfc_internal_error ("Reshaped array too large at %C");
j = mpz_get_ui (index);
e = gfc_get_array_element (source, j);
else
{
- j = j - nsource;
-
- if (npad == 0)
- {
- gfc_error ("PAD parameter required for short SOURCE parameter "
- "at %L", &source->where);
- goto bad_reshape;
- }
+ gcc_assert (npad > 0);
+ j = j - nsource;
j = j % npad;
e = gfc_get_array_element (pad, j);
}
+ gcc_assert (e);
if (head == NULL)
head = tail = gfc_get_constructor ();
tail = tail->next;
}
- if (e == NULL)
- goto bad_reshape;
-
tail->where = e->where;
tail->expr = e;
e->rank = rank;
return e;
-
-bad_reshape:
- gfc_free_constructor (head);
- mpz_clear (index);
- return &gfc_bad_expr;
}
|| mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
{
gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
+ gfc_free_expr (result);
return &gfc_bad_expr;
}
else
mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
- mpfr_clear (scale);
- mpfr_clear (radix);
+ mpfr_clears (scale, radix, NULL);
return range_check (result, "SCALE");
}
+/* Variants of strspn and strcspn that operate on wide characters. */
+
+static size_t
+wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
+{
+ size_t i = 0;
+ const gfc_char_t *c;
+
+ while (s1[i])
+ {
+ for (c = s2; *c; c++)
+ {
+ if (s1[i] == *c)
+ break;
+ }
+ if (*c == '\0')
+ break;
+ i++;
+ }
+
+ return i;
+}
+
+static size_t
+wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
+{
+ size_t i = 0;
+ const gfc_char_t *c;
+
+ while (s1[i])
+ {
+ for (c = s2; *c; c++)
+ {
+ if (s1[i] == *c)
+ break;
+ }
+ if (*c)
+ break;
+ i++;
+ }
+
+ return i;
+}
+
+
gfc_expr *
gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
{
{
if (back == 0)
{
- indx = strcspn (e->value.character.string, c->value.character.string)
- + 1;
+ indx = wide_strcspn (e->value.character.string,
+ c->value.character.string) + 1;
if (indx > len)
indx = 0;
}
gfc_expr *
+gfc_simplify_selected_char_kind (gfc_expr *e)
+{
+ int kind;
+ gfc_expr *result;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (gfc_compare_with_Cstring (e, "ascii", false) == 0
+ || gfc_compare_with_Cstring (e, "default", false) == 0)
+ kind = 1;
+ else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
+ kind = 4;
+ else
+ kind = -1;
+
+ result = gfc_int_expr (kind);
+ result->where = e->where;
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_selected_int_kind (gfc_expr *e)
{
int i, kind, range;
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
- gfc_set_model_kind (x->ts.kind);
-
if (mpfr_sgn (x->value.real) == 0)
{
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
return result;
}
+ gfc_set_model_kind (x->ts.kind);
mpfr_init (absv);
mpfr_init (log2);
mpfr_init (exp);
exp2 = (unsigned long) mpz_get_d (i->value.integer);
mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
- mpfr_clear (absv);
- mpfr_clear (log2);
- mpfr_clear (pow2);
- mpfr_clear (frac);
+ mpfr_clears (absv, log2, pow2, frac, NULL);
return range_check (result, "SET_EXPONENT");
}
gfc_expr *result, *e, *f;
gfc_array_ref *ar;
int n;
- try t;
+ gfc_try t;
+
+ if (source->rank == 0)
+ return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
- if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
+ if (source->expr_type != EXPR_VARIABLE)
return NULL;
result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
gfc_simplify_sin (gfc_expr *x)
{
gfc_expr *result;
- mpfr_t xp, xq;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
case BT_COMPLEX:
gfc_set_model (x->value.real);
+#ifdef HAVE_mpc
+ mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+#else
+ {
+ mpfr_t xp, xq;
mpfr_init (xp);
mpfr_init (xq);
mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
- mpfr_clear (xp);
- mpfr_clear (xq);
+ mpfr_clears (xp, xq, NULL);
+ }
+#endif
break;
default:
gfc_expr *
+gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
+{
+ gfc_expr *result = 0L;
+ int i, j, dim, ncopies;
+ mpz_t size;
+
+ if ((!gfc_is_constant_expr (source)
+ && !is_constant_array_expr (source))
+ || !gfc_is_constant_expr (dim_expr)
+ || !gfc_is_constant_expr (ncopies_expr))
+ return NULL;
+
+ gcc_assert (dim_expr->ts.type == BT_INTEGER);
+ gfc_extract_int (dim_expr, &dim);
+ dim -= 1; /* zero-base DIM */
+
+ gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
+ gfc_extract_int (ncopies_expr, &ncopies);
+ ncopies = MAX (ncopies, 0);
+
+ /* Do not allow the array size to exceed the limit for an array
+ constructor. */
+ if (source->expr_type == EXPR_ARRAY)
+ {
+ if (gfc_array_size (source, &size) == FAILURE)
+ gfc_internal_error ("Failure getting length of a constant array.");
+ }
+ else
+ mpz_init_set_ui (size, 1);
+
+ if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
+ return NULL;
+
+ if (source->expr_type == EXPR_CONSTANT)
+ {
+ gcc_assert (dim == 0);
+
+ result = gfc_start_constructor (source->ts.type,
+ source->ts.kind,
+ &source->where);
+ result->rank = 1;
+ result->shape = gfc_get_shape (result->rank);
+ mpz_init_set_si (result->shape[0], ncopies);
+
+ for (i = 0; i < ncopies; ++i)
+ gfc_append_constructor (result, gfc_copy_expr (source));
+ }
+ else if (source->expr_type == EXPR_ARRAY)
+ {
+ int result_size, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
+ gfc_constructor *ctor, *source_ctor, *result_ctor;
+
+ gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
+ gcc_assert (dim >= 0 && dim <= source->rank);
+
+ result = gfc_start_constructor (source->ts.type,
+ source->ts.kind,
+ &source->where);
+ result->rank = source->rank + 1;
+ result->shape = gfc_get_shape (result->rank);
+
+ result_size = 1;
+ for (i = 0, j = 0; i < result->rank; ++i)
+ {
+ if (i != dim)
+ mpz_init_set (result->shape[i], source->shape[j++]);
+ else
+ mpz_init_set_si (result->shape[i], ncopies);
+
+ extent[i] = mpz_get_si (result->shape[i]);
+ rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
+ result_size *= extent[i];
+ }
+
+ for (i = 0; i < result_size; ++i)
+ gfc_append_constructor (result, NULL);
+
+ source_ctor = source->value.constructor;
+ result_ctor = result->value.constructor;
+ while (source_ctor)
+ {
+ ctor = result_ctor;
+
+ for (i = 0; i < ncopies; ++i)
+ {
+ ctor->expr = gfc_copy_expr (source_ctor->expr);
+ ADVANCE (ctor, rstride[dim]);
+ }
+
+ ADVANCE (result_ctor, (dim == 0 ? ncopies : 1));
+ ADVANCE (source_ctor, 1);
+ }
+ }
+ else
+ /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
+ Replace NULL with gcc_unreachable() after implementing
+ gfc_simplify_cshift(). */
+ return NULL;
+
+ if (source->ts.type == BT_CHARACTER)
+ result->ts.cl = source->ts.cl;
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_sqrt (gfc_expr *e)
{
gfc_expr *result;
- mpfr_t ac, ad, s, t, w;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
break;
case BT_COMPLEX:
+ gfc_set_model (e->value.real);
+#ifdef HAVE_mpc
+ mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
+#else
+ {
/* Formula taken from Numerical Recipes to avoid over- and
underflow. */
- gfc_set_model (e->value.real);
+ mpfr_t ac, ad, s, t, w;
mpfr_init (ac);
mpfr_init (ad);
mpfr_init (s);
gfc_internal_error ("invalid complex argument of SQRT at %L",
&e->where);
- mpfr_clear (s);
- mpfr_clear (t);
- mpfr_clear (ac);
- mpfr_clear (ad);
- mpfr_clear (w);
-
+ mpfr_clears (s, t, ac, ad, w, NULL);
+ }
+#endif
break;
default:
gfc_expr *
+gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ gfc_expr *result;
+
+ if (!is_constant_array_expr (array)
+ || !gfc_is_constant_expr (dim))
+ return NULL;
+
+ if (mask
+ && !is_constant_array_expr (mask)
+ && mask->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = transformational_result (array, dim, array->ts.type,
+ array->ts.kind, &array->where);
+ init_result_expr (result, 0, NULL);
+
+ return !dim || array->rank == 1 ?
+ simplify_transformation_to_scalar (result, array, mask, gfc_add) :
+ simplify_transformation_to_array (result, array, dim, mask, gfc_add);
+}
+
+
+gfc_expr *
gfc_simplify_tan (gfc_expr *x)
{
int i;
gfc_expr *
+gfc_simplify_trailz (gfc_expr *e)
+{
+ gfc_expr *result;
+ unsigned long tz, bs;
+ int i;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ bs = gfc_integer_kinds[i].bit_size;
+ tz = mpz_scan1 (e->value.integer, 0);
+
+ result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
+ mpz_set_ui (result->value.integer, MIN (tz, bs));
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
{
gfc_expr *result;
/* Set result character length, if needed. Note that this needs to be
set even for array expressions, in order to pass this information into
gfc_target_interpret_expr. */
- if (result->ts.type == BT_CHARACTER)
+ if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
result->value.character.length = mold_element->value.character.length;
/* Set the number of elements in the result, and determine its size. */
result_elt_size = gfc_target_expr_size (mold_element);
+ if (result_elt_size == 0)
+ {
+ gfc_free_expr (result);
+ return NULL;
+ }
+
if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
{
int result_length;
/* Allocate the buffer to store the binary version of the source. */
buffer_size = MAX (source_size, result_size);
buffer = (unsigned char*)alloca (buffer_size);
+ memset (buffer, 0, buffer_size);
/* Now write source to the buffer. */
gfc_target_encode_expr (source, buffer, buffer_size);
gfc_expr *
+gfc_simplify_transpose (gfc_expr *matrix)
+{
+ int i, matrix_rows;
+ gfc_expr *result;
+ gfc_constructor *matrix_ctor;
+
+ if (!is_constant_array_expr (matrix))
+ return NULL;
+
+ gcc_assert (matrix->rank == 2);
+
+ result = gfc_start_constructor (matrix->ts.type, matrix->ts.kind, &matrix->where);
+ result->rank = 2;
+ result->shape = gfc_get_shape (result->rank);
+ mpz_set (result->shape[0], matrix->shape[1]);
+ mpz_set (result->shape[1], matrix->shape[0]);
+
+ if (matrix->ts.type == BT_CHARACTER)
+ result->ts.cl = matrix->ts.cl;
+
+ matrix_rows = mpz_get_si (matrix->shape[0]);
+ matrix_ctor = matrix->value.constructor;
+ for (i = 0; i < matrix_rows; ++i)
+ {
+ gfc_constructor *column_ctor = matrix_ctor;
+ while (column_ctor)
+ {
+ gfc_append_constructor (result,
+ gfc_copy_expr (column_ctor->expr));
+
+ ADVANCE (column_ctor, matrix_rows);
+ }
+
+ ADVANCE (matrix_ctor, 1);
+ }
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_trim (gfc_expr *e)
{
gfc_expr *result;
lentrim = len - count;
result->value.character.length = lentrim;
- result->value.character.string = gfc_getmem (lentrim + 1);
+ result->value.character.string = gfc_get_wide_string (lentrim + 1);
for (i = 0; i < lentrim; i++)
result->value.character.string[i] = e->value.character.string[i];
gfc_expr *
+gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
+{
+ gfc_expr *result, *e;
+ gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
+
+ if (!is_constant_array_expr (vector)
+ || !is_constant_array_expr (mask)
+ || (!gfc_is_constant_expr (field)
+ && !is_constant_array_expr(field)))
+ return NULL;
+
+ result = gfc_start_constructor (vector->ts.type,
+ vector->ts.kind,
+ &vector->where);
+ result->rank = mask->rank;
+ result->shape = gfc_copy_shape (mask->shape, mask->rank);
+
+ if (vector->ts.type == BT_CHARACTER)
+ result->ts.cl = vector->ts.cl;
+
+ vector_ctor = vector->value.constructor;
+ mask_ctor = mask->value.constructor;
+ field_ctor = field->expr_type == EXPR_ARRAY ? field->value.constructor : NULL;
+
+ while (mask_ctor)
+ {
+ if (mask_ctor->expr->value.logical)
+ {
+ gcc_assert (vector_ctor);
+ e = gfc_copy_expr (vector_ctor->expr);
+ ADVANCE (vector_ctor, 1);
+ }
+ else if (field->expr_type == EXPR_ARRAY)
+ e = gfc_copy_expr (field_ctor->expr);
+ else
+ e = gfc_copy_expr (field);
+
+ gfc_append_constructor (result, e);
+
+ ADVANCE (mask_ctor, 1);
+ ADVANCE (field_ctor, 1);
+ }
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
{
gfc_expr *result;
return result;
}
- index = strspn (s->value.character.string, set->value.character.string)
- + 1;
+ index = wide_strspn (s->value.character.string,
+ set->value.character.string) + 1;
if (index > len)
index = 0;
{
result = gfc_constant_result (BT_INTEGER, kind, &x->where);
mpz_xor (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "XOR");
}
else /* BT_LOGICAL */
{
result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
result->value.logical = (x->value.logical && !y->value.logical)
|| (!x->value.logical && y->value.logical);
+ return result;
}
- return range_check (result, "XOR");
}
return result;
}
+
+
+/* Function for converting character constants. */
+gfc_expr *
+gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
+{
+ gfc_expr *result;
+ int i;
+
+ if (!gfc_is_constant_expr (e))
+ return NULL;
+
+ if (e->expr_type == EXPR_CONSTANT)
+ {
+ /* Simple case of a scalar. */
+ result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+ if (result == NULL)
+ return &gfc_bad_expr;
+
+ result->value.character.length = e->value.character.length;
+ result->value.character.string
+ = gfc_get_wide_string (e->value.character.length + 1);
+ memcpy (result->value.character.string, e->value.character.string,
+ (e->value.character.length + 1) * sizeof (gfc_char_t));
+
+ /* Check we only have values representable in the destination kind. */
+ for (i = 0; i < result->value.character.length; i++)
+ if (!gfc_check_character_range (result->value.character.string[i],
+ kind))
+ {
+ gfc_error ("Character '%s' in string at %L cannot be converted "
+ "into character kind %d",
+ gfc_print_wide_char (result->value.character.string[i]),
+ &e->where, kind);
+ return &gfc_bad_expr;
+ }
+
+ return result;
+ }
+ else if (e->expr_type == EXPR_ARRAY)
+ {
+ /* For an array constructor, we convert each constructor element. */
+ gfc_constructor *head = NULL, *tail = NULL, *c;
+
+ for (c = e->value.constructor; c; c = c->next)
+ {
+ if (head == NULL)
+ head = tail = gfc_get_constructor ();
+ else
+ {
+ tail->next = gfc_get_constructor ();
+ tail = tail->next;
+ }
+
+ tail->where = c->where;
+ tail->expr = gfc_convert_char_constant (c->expr, type, kind);
+ if (tail->expr == &gfc_bad_expr)
+ {
+ tail->expr = NULL;
+ return &gfc_bad_expr;
+ }
+
+ if (tail->expr == NULL)
+ {
+ gfc_free_constructor (head);
+ return NULL;
+ }
+ }
+
+ result = gfc_get_expr ();
+ result->ts.type = type;
+ result->ts.kind = kind;
+ result->expr_type = EXPR_ARRAY;
+ result->value.constructor = head;
+ result->shape = gfc_copy_shape (e->shape, e->rank);
+ result->where = e->where;
+ result->rank = e->rank;
+ result->ts.cl = e->ts.cl;
+
+ return result;
+ }
+ else
+ return NULL;
+}