X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fsimplify.c;h=f57f68e3e68ee78604e56fcf17ec5b92803f661e;hb=3011e448c9496ea3a197f0230e2cc74f041d7b2b;hp=be0b18f89ff89f73ce98a65e1acf9b528687704f;hpb=cb989427b3d6fb67e4182b701af7e0a18c2e20d2;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index be0b18f89ff..f57f68e3e68 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -1,5 +1,5 @@ /* 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 @@ -27,6 +27,10 @@ along with GCC; see the file COPYING3. If not see #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; @@ -210,6 +214,402 @@ convert_mpz_to_signed (mpz_t x, int bitsize) } } +/* 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 *****************************/ @@ -244,8 +644,12 @@ gfc_simplify_abs (gfc_expr *e) 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; @@ -256,43 +660,73 @@ gfc_simplify_abs (gfc_expr *e) 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) { @@ -343,7 +777,7 @@ gfc_simplify_adjustl (gfc_expr *e) { gfc_expr *result; int count, i, len; - char ch; + gfc_char_t ch; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -353,7 +787,7 @@ gfc_simplify_adjustl (gfc_expr *e) 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) { @@ -380,7 +814,7 @@ gfc_simplify_adjustr (gfc_expr *e) { gfc_expr *result; int count, i, len; - char ch; + gfc_char_t ch; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -390,7 +824,7 @@ gfc_simplify_adjustr (gfc_expr *e) 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) { @@ -421,7 +855,7 @@ gfc_simplify_aimag (gfc_expr *e) 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"); } @@ -452,6 +886,25 @@ gfc_simplify_aint (gfc_expr *e, gfc_expr *k) 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; @@ -505,14 +958,33 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y) { 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); } @@ -620,19 +1092,114 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) 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"); } @@ -683,7 +1250,7 @@ gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) 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); @@ -694,35 +1261,7 @@ gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) 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); } @@ -735,22 +1274,36 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) 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: @@ -763,11 +1316,13 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) { 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: @@ -779,40 +1334,65 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) 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); } @@ -822,10 +1402,6 @@ gfc_simplify_complex (gfc_expr *x, gfc_expr *y) { 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) @@ -841,6 +1417,10 @@ gfc_simplify_complex (gfc_expr *x, gfc_expr *y) 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); } @@ -854,7 +1434,11 @@ gfc_simplify_conjg (gfc_expr *e) 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"); } @@ -864,7 +1448,6 @@ gfc_expr * gfc_simplify_cos (gfc_expr *x) { gfc_expr *result; - mpfr_t xp, xq; if (x->expr_type != EXPR_CONSTANT) return NULL; @@ -878,6 +1461,11 @@ gfc_simplify_cos (gfc_expr *x) 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); @@ -890,8 +1478,9 @@ gfc_simplify_cos (gfc_expr *x) 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"); @@ -919,12 +1508,38 @@ gfc_simplify_cosh (gfc_expr *x) 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); } @@ -933,7 +1548,7 @@ gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) gfc_expr * gfc_simplify_dble (gfc_expr *e) { - gfc_expr *result; + gfc_expr *result = NULL; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -960,11 +1575,15 @@ gfc_simplify_dble (gfc_expr *e) 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"); @@ -1035,6 +1654,32 @@ gfc_simplify_dim (gfc_expr *x, gfc_expr *y) } +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) { @@ -1058,6 +1703,175 @@ 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; @@ -1077,7 +1891,6 @@ gfc_expr * gfc_simplify_exp (gfc_expr *x) { gfc_expr *result; - mpfr_t xp, xq; if (x->expr_type != EXPR_CONSTANT) return NULL; @@ -1092,6 +1905,11 @@ gfc_simplify_exp (gfc_expr *x) 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); @@ -1099,8 +1917,9 @@ gfc_simplify_exp (gfc_expr *x) 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: @@ -1148,13 +1967,17 @@ gfc_simplify_float (gfc_expr *a) 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); @@ -1182,7 +2005,7 @@ gfc_simplify_floor (gfc_expr *e, gfc_expr *k) 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); @@ -1201,14 +2024,13 @@ gfc_simplify_fraction (gfc_expr *x) 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); @@ -1223,9 +2045,7 @@ gfc_simplify_fraction (gfc_expr *x) 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"); } @@ -1241,8 +2061,6 @@ gfc_simplify_gamma (gfc_expr *x) 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"); @@ -1276,6 +2094,21 @@ gfc_simplify_huge (gfc_expr *e) 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. */ @@ -1283,7 +2116,7 @@ gfc_expr * 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; @@ -1294,7 +2127,7 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) 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", @@ -1359,7 +2192,7 @@ gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); - return range_check (result, "IBCLR"); + return result; } @@ -1400,8 +2233,10 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) } 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; @@ -1421,7 +2256,10 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) gfc_free (bits); - return range_check (result, "IBITS"); + convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); + + return result; } @@ -1459,7 +2297,7 @@ gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); - return range_check (result, "IBSET"); + return result; } @@ -1467,7 +2305,7 @@ gfc_expr * 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; @@ -1478,10 +2316,7 @@ gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) 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; @@ -1514,7 +2349,8 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) 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) @@ -1654,7 +2490,7 @@ done: 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); @@ -1664,33 +2500,22 @@ gfc_simplify_int (gfc_expr *e, gfc_expr *k) 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; } @@ -1699,40 +2524,29 @@ gfc_simplify_int (gfc_expr *e, gfc_expr *k) 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; } @@ -1743,21 +2557,21 @@ gfc_simplify_intconv (gfc_expr *e, int kind, const char *name) 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"); } @@ -1775,7 +2589,7 @@ gfc_simplify_ifix (gfc_expr *e) 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"); @@ -1796,7 +2610,7 @@ gfc_simplify_idint (gfc_expr *e) 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"); @@ -1819,6 +2633,54 @@ gfc_simplify_ior (gfc_expr *x, gfc_expr *y) 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; @@ -1857,7 +2719,7 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) 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); @@ -1961,7 +2823,7 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) 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); @@ -2028,7 +2890,7 @@ gfc_simplify_kind (gfc_expr *e) 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; @@ -2038,16 +2900,9 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, { 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); @@ -2056,21 +2911,43 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, 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"); @@ -2103,11 +2980,17 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) 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 (); @@ -2147,7 +3030,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) /* 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; @@ -2166,7 +3049,10 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) 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 @@ -2210,7 +3096,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) return &gfc_bad_expr; } - return simplify_bound_dim (array, kind, d, upper, as); + return simplify_bound_dim (array, kind, d, upper, as, ref); } } @@ -2223,6 +3109,33 @@ gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 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; @@ -2235,7 +3148,13 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind) { 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 @@ -2244,7 +3163,13 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind) { 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; @@ -2280,9 +3205,8 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) } 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; @@ -2291,14 +3215,9 @@ gfc_simplify_lgamma (gfc_expr *x __attribute__((unused))) 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 } @@ -2347,14 +3266,12 @@ gfc_expr * 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) { @@ -2371,8 +3288,8 @@ gfc_simplify_log (gfc_expr *x) 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); @@ -2380,6 +3297,12 @@ gfc_simplify_log (gfc_expr *x) 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); @@ -2392,9 +3315,9 @@ gfc_simplify_log (gfc_expr *x) 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: @@ -2413,8 +3336,6 @@ gfc_simplify_log10 (gfc_expr *x) 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 " @@ -2451,6 +3372,156 @@ gfc_simplify_logical (gfc_expr *e, gfc_expr *k) } +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 @@ -2481,57 +3552,7 @@ simplify_min_max (gfc_expr *expr, int sign) 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) @@ -2576,6 +3597,69 @@ gfc_simplify_max (gfc_expr *e) } +/* 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) { @@ -2610,7 +3694,7 @@ gfc_expr * 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) @@ -2642,18 +3726,12 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) } 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: @@ -2668,7 +3746,7 @@ gfc_expr * 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) @@ -2702,18 +3780,12 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) } 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: @@ -2753,7 +3825,6 @@ gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) return &gfc_bad_expr; } - gfc_set_model_kind (x->ts.kind); result = gfc_copy_expr (x); /* Save current values of emin and emax. */ @@ -2765,6 +3836,7 @@ gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) 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) { @@ -2785,6 +3857,7 @@ gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) 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; } @@ -2811,7 +3884,7 @@ simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) 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); @@ -2825,7 +3898,7 @@ gfc_simplify_new_line (gfc_expr *e) 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 */ @@ -2895,14 +3968,83 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *y) { 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; } @@ -2922,6 +4064,30 @@ gfc_simplify_precision (gfc_expr *e) 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; @@ -2983,7 +4149,7 @@ gfc_simplify_range (gfc_expr *e) 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) @@ -3020,12 +4186,17 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k) 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"); } @@ -3039,7 +4210,11 @@ gfc_simplify_realpart (gfc_expr *e) 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"); } @@ -3128,7 +4303,9 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) 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); @@ -3143,19 +4320,18 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) 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; @@ -3176,21 +4352,14 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, 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; @@ -3202,40 +4371,16 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, 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) @@ -3251,39 +4396,14 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, 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; } } @@ -3310,7 +4430,7 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, 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); @@ -3323,7 +4443,7 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, } 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); @@ -3331,18 +4451,13 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, 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 (); @@ -3352,9 +4467,6 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, tail = tail->next; } - if (e == NULL) - goto bad_reshape; - tail->where = e->where; tail->expr = e; @@ -3386,11 +4498,6 @@ inc: e->rank = rank; return e; - -bad_reshape: - gfc_free_constructor (head); - mpz_clear (index); - return &gfc_bad_expr; } @@ -3455,6 +4562,7 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i) || 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; } @@ -3480,13 +4588,57 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i) 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) { @@ -3520,8 +4672,8 @@ 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; } @@ -3547,6 +4699,30 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) 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; @@ -3642,14 +4818,13 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) 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); @@ -3671,10 +4846,7 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) 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"); } @@ -3687,9 +4859,13 @@ gfc_simplify_shape (gfc_expr *source) 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, @@ -3805,7 +4981,6 @@ gfc_expr * gfc_simplify_sin (gfc_expr *x) { gfc_expr *result; - mpfr_t xp, xq; if (x->expr_type != EXPR_CONSTANT) return NULL; @@ -3820,6 +4995,11 @@ gfc_simplify_sin (gfc_expr *x) 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); @@ -3831,8 +5011,9 @@ gfc_simplify_sin (gfc_expr *x) 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: @@ -3914,10 +5095,116 @@ gfc_simplify_spacing (gfc_expr *x) 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; @@ -3934,10 +5221,15 @@ gfc_simplify_sqrt (gfc_expr *e) 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); @@ -4008,12 +5300,9 @@ gfc_simplify_sqrt (gfc_expr *e) 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: @@ -4030,6 +5319,30 @@ negative_arg: 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; @@ -4081,6 +5394,27 @@ gfc_simplify_tiny (gfc_expr *e) 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; @@ -4119,11 +5453,17 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) /* 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; @@ -4159,6 +5499,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) /* 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); @@ -4171,6 +5512,47 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *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; @@ -4194,7 +5576,7 @@ gfc_simplify_trim (gfc_expr *e) 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]; @@ -4213,6 +5595,54 @@ gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 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; @@ -4251,8 +5681,8 @@ gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) 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; @@ -4296,15 +5726,16 @@ gfc_simplify_xor (gfc_expr *x, gfc_expr *y) { 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"); } @@ -4486,3 +5917,87 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) 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; +}