diff options
Diffstat (limited to 'gcc-4.8.1/gcc/fortran/simplify.c')
| -rw-r--r-- | gcc-4.8.1/gcc/fortran/simplify.c | 6727 |
1 files changed, 0 insertions, 6727 deletions
diff --git a/gcc-4.8.1/gcc/fortran/simplify.c b/gcc-4.8.1/gcc/fortran/simplify.c deleted file mode 100644 index 6cc5c4dd4..000000000 --- a/gcc-4.8.1/gcc/fortran/simplify.c +++ /dev/null @@ -1,6727 +0,0 @@ -/* Simplify intrinsic functions at compile-time. - Copyright (C) 2000-2013 Free Software Foundation, Inc. - Contributed by Andy Vaught & Katherine Holcomb - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -<http://www.gnu.org/licenses/>. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "flags.h" -#include "gfortran.h" -#include "arith.h" -#include "intrinsic.h" -#include "target-memory.h" -#include "constructor.h" -#include "version.h" /* For version_string. */ - - -gfc_expr gfc_bad_expr; - -static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int); - - -/* Note that 'simplification' is not just transforming expressions. - For functions that are not simplified at compile time, range - checking is done if possible. - - The return convention is that each simplification function returns: - - A new expression node corresponding to the simplified arguments. - The original arguments are destroyed by the caller, and must not - be a part of the new expression. - - NULL pointer indicating that no simplification was possible and - the original expression should remain intact. - - An expression pointer to gfc_bad_expr (a static placeholder) - indicating that some error has prevented simplification. The - error is generated within the function and should be propagated - upwards - - By the time a simplification function gets control, it has been - decided that the function call is really supposed to be the - intrinsic. No type checking is strictly necessary, since only - valid types will be passed on. On the other hand, a simplification - subroutine may have to look at the type of an argument as part of - its processing. - - Array arguments are only passed to these subroutines that implement - the simplification of transformational intrinsics. - - The functions in this file don't have much comment with them, but - everything is reasonably straight-forward. The Standard, chapter 13 - is the best comment you'll find for this file anyway. */ - -/* Range checks an expression node. If all goes well, returns the - node, otherwise returns &gfc_bad_expr and frees the node. */ - -static gfc_expr * -range_check (gfc_expr *result, const char *name) -{ - if (result == NULL) - return &gfc_bad_expr; - - if (result->expr_type != EXPR_CONSTANT) - return result; - - switch (gfc_range_check (result)) - { - case ARITH_OK: - return result; - - case ARITH_OVERFLOW: - gfc_error ("Result of %s overflows its kind at %L", name, - &result->where); - break; - - case ARITH_UNDERFLOW: - gfc_error ("Result of %s underflows its kind at %L", name, - &result->where); - break; - - case ARITH_NAN: - gfc_error ("Result of %s is NaN at %L", name, &result->where); - break; - - default: - gfc_error ("Result of %s gives range error for its kind at %L", name, - &result->where); - break; - } - - gfc_free_expr (result); - return &gfc_bad_expr; -} - - -/* A helper function that gets an optional and possibly missing - kind parameter. Returns the kind, -1 if something went wrong. */ - -static int -get_kind (bt type, gfc_expr *k, const char *name, int default_kind) -{ - int kind; - - if (k == NULL) - return default_kind; - - if (k->expr_type != EXPR_CONSTANT) - { - gfc_error ("KIND parameter of %s at %L must be an initialization " - "expression", name, &k->where); - return -1; - } - - if (gfc_extract_int (k, &kind) != NULL - || gfc_validate_kind (type, kind, true) < 0) - { - gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where); - return -1; - } - - return kind; -} - - -/* Converts an mpz_t signed variable into an unsigned one, assuming - two's complement representations and a binary width of bitsize. - The conversion is a no-op unless x is negative; otherwise, it can - be accomplished by masking out the high bits. */ - -static void -convert_mpz_to_unsigned (mpz_t x, int bitsize) -{ - mpz_t mask; - - if (mpz_sgn (x) < 0) - { - /* Confirm that no bits above the signed range are unset. */ - gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX); - - mpz_init_set_ui (mask, 1); - mpz_mul_2exp (mask, mask, bitsize); - mpz_sub_ui (mask, mask, 1); - - mpz_and (x, x, mask); - - mpz_clear (mask); - } - else - { - /* Confirm that no bits above the signed range are set. */ - gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX); - } -} - - -/* Converts an mpz_t unsigned variable into a signed one, assuming - two's complement representations and a binary width of bitsize. - If the bitsize-1 bit is set, this is taken as a sign bit and - the number is converted to the corresponding negative number. */ - -static void -convert_mpz_to_signed (mpz_t x, int bitsize) -{ - mpz_t mask; - - /* Confirm that no bits above the unsigned range are set. */ - gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX); - - if (mpz_tstbit (x, bitsize - 1) == 1) - { - mpz_init_set_ui (mask, 1); - mpz_mul_2exp (mask, mask, bitsize); - mpz_sub_ui (mask, mask, 1); - - /* We negate the number by hand, zeroing the high bits, that is - make it the corresponding positive number, and then have it - negated by GMP, giving the correct representation of the - negative number. */ - mpz_com (x, x); - mpz_add_ui (x, x, 1); - mpz_and (x, x, mask); - - mpz_neg (x, x); - - mpz_clear (mask); - } -} - - -/* In-place convert BOZ to REAL of the specified kind. */ - -static gfc_expr * -convert_boz (gfc_expr *x, int kind) -{ - if (x && x->ts.type == BT_INTEGER && x->is_boz) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_REAL; - ts.kind = kind; - - if (!gfc_convert_boz (x, &ts)) - return &gfc_bad_expr; - } - - return x; -} - - -/* 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 = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - if (c->expr->expr_type != EXPR_CONSTANT - && c->expr->expr_type != EXPR_STRUCTURE) - 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 = gfc_constructor_first (e->value.constructor); - while (ctor) - { - init_result_expr (ctor->expr, init, array); - ctor = gfc_constructor_next (ctor); - } - } - 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: - mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE); - 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_expr *matrix_a, int stride_a, int offset_a, - gfc_expr *matrix_b, int stride_b, int offset_b) -{ - gfc_expr *result, *a, *b; - - result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind, - &matrix_a->where); - init_result_expr (result, 0, NULL); - - a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); - b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); - while (a && 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 (a), - gfc_copy_expr (b))); - break; - - case BT_INTEGER: - case BT_REAL: - case BT_COMPLEX: - result = gfc_add (result, - gfc_multiply (gfc_copy_expr (a), - gfc_copy_expr (b))); - break; - - default: - gcc_unreachable(); - } - - offset_a += stride_a; - a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); - - offset_b += stride_b; - b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_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_get_constant_expr (type, kind, where); - - result = gfc_get_array_expr (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_constructor_append_expr (&result->value.constructor, - gfc_get_constant_expr (type, kind, where), - NULL); - } - - 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 implementation 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 = gfc_constructor_first (array->value.constructor); - mask_ctor = NULL; - if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = gfc_constructor_first (mask->value.constructor); - - while (array_ctor) - { - a = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - - /* A constant MASK equals .TRUE. here and can be ignored. */ - if (mask_ctor) - { - m = mask_ctor->expr; - mask_ctor = gfc_constructor_next (mask_ctor); - 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(). The result might be post processed using post_op. */ - -static gfc_expr * -simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask, transformational_op op, - transformational_op post_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); - mpz_clear (size); - - arrayvec = XCNEWVEC (gfc_expr*, arraysize); - - array_ctor = gfc_constructor_first (array->value.constructor); - mask_ctor = NULL; - if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = gfc_constructor_first (mask->value.constructor); - - for (i = 0; i < arraysize; ++i) - { - arrayvec[i] = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - - if (mask_ctor) - { - if (!mask_ctor->expr->value.logical) - arrayvec[i] = NULL; - - mask_ctor = gfc_constructor_next (mask_ctor); - } - } - - /* Same for the result expression. */ - gfc_array_size (result, &size); - resultsize = mpz_get_ui (size); - mpz_clear (size); - - resultvec = XCNEWVEC (gfc_expr*, resultsize); - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < resultsize; ++i) - { - resultvec[i] = result_ctor->expr; - result_ctor = gfc_constructor_next (result_ctor); - } - - 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 = gfc_constructor_first (result->value.constructor); - for (i = 0; i < resultsize; ++i) - { - if (post_op) - result_ctor->expr = post_op (result_ctor->expr, resultvec[i]); - else - result_ctor->expr = resultvec[i]; - result_ctor = gfc_constructor_next (result_ctor); - } - - free (arrayvec); - free (resultvec); - return result; -} - - -static gfc_expr * -simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, - int init_val, transformational_op op) -{ - 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, init_val, NULL); - - return !dim || array->rank == 1 ? - simplify_transformation_to_scalar (result, array, mask, op) : - simplify_transformation_to_array (result, array, dim, mask, op, NULL); -} - - -/********************** Simplification functions *****************************/ - -gfc_expr * -gfc_simplify_abs (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - switch (e->ts.type) - { - case BT_INTEGER: - result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where); - mpz_abs (result->value.integer, e->value.integer); - return range_check (result, "IABS"); - - case BT_REAL: - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE); - return range_check (result, "ABS"); - - case BT_COMPLEX: - gfc_set_model_kind (e->ts.kind); - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE); - return range_check (result, "CABS"); - - default: - gfc_internal_error ("gfc_simplify_abs(): Bad type"); - } -} - - -static gfc_expr * -simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii) -{ - gfc_expr *result; - int kind; - bool too_large = false; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind); - if (kind == -1) - return &gfc_bad_expr; - - 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; - } - - 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); - - 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_get_character_expr (kind, &e->where, NULL, 1); - result->value.character.string[0] = mpz_get_ui (e->value.integer); - - 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; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - switch (x->ts.type) - { - case BT_REAL: - if (mpfr_cmp_si (x->value.real, 1) > 0 - || mpfr_cmp_si (x->value.real, -1) < 0) - { - gfc_error ("Argument of ACOS at %L must be between -1 and 1", - &x->where); - return &gfc_bad_expr; - } - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_acos(): Bad type"); - } - - return range_check (result, "ACOS"); -} - -gfc_expr * -gfc_simplify_acosh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - switch (x->ts.type) - { - case BT_REAL: - if (mpfr_cmp_si (x->value.real, 1) < 0) - { - gfc_error ("Argument of ACOSH at %L must not be less than 1", - &x->where); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_acosh(): Bad type"); - } - - return range_check (result, "ACOSH"); -} - -gfc_expr * -gfc_simplify_adjustl (gfc_expr *e) -{ - gfc_expr *result; - int count, i, len; - gfc_char_t ch; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - len = e->value.character.length; - - for (count = 0, i = 0; i < len; ++i) - { - ch = e->value.character.string[i]; - if (ch != ' ') - break; - ++count; - } - - result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); - for (i = 0; i < len - count; ++i) - result->value.character.string[i] = e->value.character.string[count + i]; - - return result; -} - - -gfc_expr * -gfc_simplify_adjustr (gfc_expr *e) -{ - gfc_expr *result; - int count, i, len; - gfc_char_t ch; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - len = e->value.character.length; - - for (count = 0, i = len - 1; i >= 0; --i) - { - ch = e->value.character.string[i]; - if (ch != ' ') - break; - ++count; - } - - result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); - for (i = 0; i < count; ++i) - result->value.character.string[i] = ' '; - - for (i = count; i < len; ++i) - result->value.character.string[i] = e->value.character.string[i - count]; - - return result; -} - - -gfc_expr * -gfc_simplify_aimag (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE); - - return range_check (result, "AIMAG"); -} - - -gfc_expr * -gfc_simplify_aint (gfc_expr *e, gfc_expr *k) -{ - gfc_expr *rtrunc, *result; - int kind; - - kind = get_kind (BT_REAL, k, "AINT", e->ts.kind); - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - - result = gfc_real2real (rtrunc, kind); - - gfc_free_expr (rtrunc); - - return range_check (result, "AINT"); -} - - -gfc_expr * -gfc_simplify_all (gfc_expr *mask, gfc_expr *dim) -{ - return simplify_transformation (mask, dim, NULL, true, gfc_and); -} - - -gfc_expr * -gfc_simplify_dint (gfc_expr *e) -{ - gfc_expr *rtrunc, *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - - result = gfc_real2real (rtrunc, gfc_default_double_kind); - - gfc_free_expr (rtrunc); - - return range_check (result, "DINT"); -} - - -gfc_expr * -gfc_simplify_dreal (gfc_expr *e) -{ - gfc_expr *result = NULL; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); - - return range_check (result, "DREAL"); -} - - -gfc_expr * -gfc_simplify_anint (gfc_expr *e, gfc_expr *k) -{ - gfc_expr *result; - int kind; - - kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind); - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (e->ts.type, kind, &e->where); - mpfr_round (result->value.real, e->value.real); - - return range_check (result, "ANINT"); -} - - -gfc_expr * -gfc_simplify_and (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int kind; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - - switch (x->ts.type) - { - case BT_INTEGER: - result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); - mpz_and (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "AND"); - - case BT_LOGICAL: - return gfc_get_logical_expr (kind, &x->where, - x->value.logical && y->value.logical); - - default: - gcc_unreachable (); - } -} - - -gfc_expr * -gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) -{ - return simplify_transformation (mask, dim, NULL, false, gfc_or); -} - - -gfc_expr * -gfc_simplify_dnint (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where); - mpfr_round (result->value.real, e->value.real); - - return range_check (result, "DNINT"); -} - - -gfc_expr * -gfc_simplify_asin (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - switch (x->ts.type) - { - case BT_REAL: - if (mpfr_cmp_si (x->value.real, 1) > 0 - || mpfr_cmp_si (x->value.real, -1) < 0) - { - gfc_error ("Argument of ASIN at %L must be between -1 and 1", - &x->where); - return &gfc_bad_expr; - } - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_asin(): Bad type"); - } - - return range_check (result, "ASIN"); -} - - -gfc_expr * -gfc_simplify_asinh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_asinh(): Bad type"); - } - - return range_check (result, "ASINH"); -} - - -gfc_expr * -gfc_simplify_atan (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_atan(): Bad type"); - } - - return range_check (result, "ATAN"); -} - - -gfc_expr * -gfc_simplify_atanh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - switch (x->ts.type) - { - case BT_REAL: - if (mpfr_cmp_si (x->value.real, 1) >= 0 - || mpfr_cmp_si (x->value.real, -1) <= 0) - { - gfc_error ("Argument of ATANH at %L must be inside the range -1 " - "to 1", &x->where); - return &gfc_bad_expr; - } - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_atanh(): Bad type"); - } - - return range_check (result, "ATANH"); -} - - -gfc_expr * -gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - 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); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (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) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (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) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (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, gfc_expr *x) -{ - 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_get_constant_expr (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"); -} - - -/* Simplify transformational form of JN and YN. */ - -static gfc_expr * -gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, - bool jn) -{ - gfc_expr *result; - gfc_expr *e; - long n1, n2; - int i; - mpfr_t x2rev, last1, last2; - - if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT - || order2->expr_type != EXPR_CONSTANT) - return NULL; - - n1 = mpz_get_si (order1->value.integer); - n2 = mpz_get_si (order2->value.integer); - result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where); - result->rank = 1; - result->shape = gfc_get_shape (1); - mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0)); - - if (n2 < n1) - return result; - - /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and - YN(N, 0.0) = -Inf. */ - - if (mpfr_cmp_ui (x->value.real, 0.0) == 0) - { - if (!jn && gfc_option.flag_range_check) - { - gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - - if (jn && n1 == 0) - { - e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_set_ui (e->value.real, 1, GFC_RND_MODE); - gfc_constructor_append_expr (&result->value.constructor, e, - &x->where); - n1++; - } - - for (i = n1; i <= n2; i++) - { - e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - if (jn) - mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); - else - mpfr_set_inf (e->value.real, -1); - gfc_constructor_append_expr (&result->value.constructor, e, - &x->where); - } - - return result; - } - - /* Use the faster but more verbose recurrence algorithm. Bessel functions - are stable for downward recursion and Neumann functions are stable - for upward recursion. It is - x2rev = 2.0/x, - J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x), - Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x). - Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */ - - gfc_set_model_kind (x->ts.kind); - - /* Get first recursion anchor. */ - - mpfr_init (last1); - if (jn) - mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE); - else - mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE); - - e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_set (e->value.real, last1, GFC_RND_MODE); - if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) - { - mpfr_clear (last1); - gfc_free_expr (e); - gfc_free_expr (result); - return &gfc_bad_expr; - } - gfc_constructor_append_expr (&result->value.constructor, e, &x->where); - - if (n1 == n2) - { - mpfr_clear (last1); - return result; - } - - /* Get second recursion anchor. */ - - mpfr_init (last2); - if (jn) - mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE); - else - mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE); - - e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_set (e->value.real, last2, GFC_RND_MODE); - if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) - { - mpfr_clear (last1); - mpfr_clear (last2); - gfc_free_expr (e); - gfc_free_expr (result); - return &gfc_bad_expr; - } - if (jn) - gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2); - else - gfc_constructor_append_expr (&result->value.constructor, e, &x->where); - - if (n1 + 1 == n2) - { - mpfr_clear (last1); - mpfr_clear (last2); - return result; - } - - /* Start actual recursion. */ - - mpfr_init (x2rev); - mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE); - - for (i = 2; i <= n2-n1; i++) - { - e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - /* Special case: For YN, if the previous N gave -INF, set - also N+1 to -INF. */ - if (!jn && !gfc_option.flag_range_check && mpfr_inf_p (last2)) - { - mpfr_set_inf (e->value.real, -1); - gfc_constructor_append_expr (&result->value.constructor, e, - &x->where); - continue; - } - - mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1), - GFC_RND_MODE); - mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE); - mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE); - - if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) - { - /* Range_check frees "e" in that case. */ - e = NULL; - goto error; - } - - if (jn) - gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, - -i-1); - else - gfc_constructor_append_expr (&result->value.constructor, e, &x->where); - - mpfr_set (last1, last2, GFC_RND_MODE); - mpfr_set (last2, e->value.real, GFC_RND_MODE); - } - - mpfr_clear (last1); - mpfr_clear (last2); - mpfr_clear (x2rev); - return result; - -error: - mpfr_clear (last1); - mpfr_clear (last2); - mpfr_clear (x2rev); - gfc_free_expr (e); - gfc_free_expr (result); - return &gfc_bad_expr; -} - - -gfc_expr * -gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) -{ - return gfc_simplify_bessel_n2 (order1, order2, x, true); -} - - -gfc_expr * -gfc_simplify_bessel_y0 (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (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) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (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, gfc_expr *x) -{ - 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_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE); - - return range_check (result, "BESSEL_YN"); -} - - -gfc_expr * -gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) -{ - return gfc_simplify_bessel_n2 (order1, order2, x, false); -} - - -gfc_expr * -gfc_simplify_bit_size (gfc_expr *e) -{ - int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - return gfc_get_int_expr (e->ts.kind, &e->where, - gfc_integer_kinds[i].bit_size); -} - - -gfc_expr * -gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) -{ - int b; - - if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT) - return NULL; - - if (gfc_extract_int (bit, &b) != NULL || b < 0) - return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false); - - return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, - mpz_tstbit (e->value.integer, b)); -} - - -static int -compare_bitwise (gfc_expr *i, gfc_expr *j) -{ - mpz_t x, y; - int k, res; - - gcc_assert (i->ts.type == BT_INTEGER); - gcc_assert (j->ts.type == BT_INTEGER); - - mpz_init_set (x, i->value.integer); - k = gfc_validate_kind (i->ts.type, i->ts.kind, false); - convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); - - mpz_init_set (y, j->value.integer); - k = gfc_validate_kind (j->ts.type, j->ts.kind, false); - convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size); - - res = mpz_cmp (x, y); - mpz_clear (x); - mpz_clear (y); - return res; -} - - -gfc_expr * -gfc_simplify_bge (gfc_expr *i, gfc_expr *j) -{ - if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) >= 0); -} - - -gfc_expr * -gfc_simplify_bgt (gfc_expr *i, gfc_expr *j) -{ - if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) > 0); -} - - -gfc_expr * -gfc_simplify_ble (gfc_expr *i, gfc_expr *j) -{ - if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) <= 0); -} - - -gfc_expr * -gfc_simplify_blt (gfc_expr *i, gfc_expr *j) -{ - if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) < 0); -} - - -gfc_expr * -gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) -{ - gfc_expr *ceil, *result; - int kind; - - kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - ceil = gfc_copy_expr (e); - mpfr_ceil (ceil->value.real, e->value.real); - - result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); - gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where); - - gfc_free_expr (ceil); - - return range_check (result, "CEILING"); -} - - -gfc_expr * -gfc_simplify_char (gfc_expr *e, gfc_expr *k) -{ - return simplify_achar_char (e, k, "CHAR", false); -} - - -/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */ - -static gfc_expr * -simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) -{ - gfc_expr *result; - - if (convert_boz (x, kind) == &gfc_bad_expr) - return &gfc_bad_expr; - - if (convert_boz (y, kind) == &gfc_bad_expr) - return &gfc_bad_expr; - - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return NULL; - - result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where); - - switch (x->ts.type) - { - case BT_INTEGER: - mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE); - break; - - case BT_REAL: - mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)"); - } - - if (!y) - return range_check (result, name); - - switch (y->ts.type) - { - case BT_INTEGER: - mpfr_set_z (mpc_imagref (result->value.complex), - y->value.integer, GFC_RND_MODE); - break; - - case BT_REAL: - mpfr_set (mpc_imagref (result->value.complex), - y->value.real, GFC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)"); - } - - return range_check (result, name); -} - - -gfc_expr * -gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k) -{ - int kind; - - kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind); - if (kind == -1) - return &gfc_bad_expr; - - return simplify_cmplx ("CMPLX", x, y, kind); -} - - -gfc_expr * -gfc_simplify_complex (gfc_expr *x, gfc_expr *y) -{ - int kind; - - if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER) - kind = gfc_default_complex_kind; - else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER) - kind = x->ts.kind; - else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL) - kind = y->ts.kind; - else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL) - kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; - else - gcc_unreachable (); - - return simplify_cmplx ("COMPLEX", x, y, kind); -} - - -gfc_expr * -gfc_simplify_conjg (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_copy_expr (e); - mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE); - - return range_check (result, "CONJG"); -} - - -gfc_expr * -gfc_simplify_cos (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model_kind (x->ts.kind); - mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_cos(): Bad type"); - } - - return range_check (result, "COS"); -} - - -gfc_expr * -gfc_simplify_cosh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gcc_unreachable (); - } - - return range_check (result, "COSH"); -} - - -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, NULL); -} - - -gfc_expr * -gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) -{ - return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); -} - - -gfc_expr * -gfc_simplify_dble (gfc_expr *e) -{ - gfc_expr *result = NULL; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr) - return &gfc_bad_expr; - - result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind); - if (result == &gfc_bad_expr) - return &gfc_bad_expr; - - return range_check (result, "DBLE"); -} - - -gfc_expr * -gfc_simplify_digits (gfc_expr *x) -{ - int i, digits; - - i = gfc_validate_kind (x->ts.type, x->ts.kind, false); - - switch (x->ts.type) - { - case BT_INTEGER: - digits = gfc_integer_kinds[i].digits; - break; - - case BT_REAL: - case BT_COMPLEX: - digits = gfc_real_kinds[i].digits; - break; - - default: - gcc_unreachable (); - } - - return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits); -} - - -gfc_expr * -gfc_simplify_dim (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int kind; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - result = gfc_get_constant_expr (x->ts.type, kind, &x->where); - - switch (x->ts.type) - { - case BT_INTEGER: - if (mpz_cmp (x->value.integer, y->value.integer) > 0) - mpz_sub (result->value.integer, x->value.integer, y->value.integer); - else - mpz_set_ui (result->value.integer, 0); - - break; - - case BT_REAL: - if (mpfr_cmp (x->value.real, y->value.real) > 0) - mpfr_sub (result->value.real, x->value.real, y->value.real, - GFC_RND_MODE); - else - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); - - break; - - default: - gfc_internal_error ("gfc_simplify_dim(): Bad type"); - } - - return range_check (result, "DIM"); -} - - -gfc_expr* -gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) -{ - 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)); - - return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0); -} - - -gfc_expr * -gfc_simplify_dprod (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *a1, *a2, *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - a1 = gfc_real2real (x, gfc_default_double_kind); - a2 = gfc_real2real (y, gfc_default_double_kind); - - result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where); - mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE); - - gfc_free_expr (a2); - gfc_free_expr (a1); - - return range_check (result, "DPROD"); -} - - -static gfc_expr * -simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, - bool right) -{ - gfc_expr *result; - int i, k, size, shift; - - if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT - || shiftarg->expr_type != EXPR_CONSTANT) - return NULL; - - k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false); - size = gfc_integer_kinds[k].bit_size; - - gfc_extract_int (shiftarg, &shift); - - /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */ - if (right) - shift = size - shift; - - result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where); - mpz_set_ui (result->value.integer, 0); - - for (i = 0; i < shift; i++) - if (mpz_tstbit (arg2->value.integer, size - shift + i)) - mpz_setbit (result->value.integer, i); - - for (i = 0; i < size - shift; i++) - if (mpz_tstbit (arg1->value.integer, i)) - mpz_setbit (result->value.integer, shift + i); - - /* Convert to a signed value. */ - convert_mpz_to_signed (result->value.integer, size); - - return result; -} - - -gfc_expr * -gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) -{ - return simplify_dshift (arg1, arg2, shiftarg, true); -} - - -gfc_expr * -gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) -{ - return simplify_dshift (arg1, arg2, shiftarg, false); -} - - -gfc_expr * -gfc_simplify_erf (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (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_get_constant_expr (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_get_constant_expr (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; - int i; - - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE); - - return range_check (result, "EPSILON"); -} - - -gfc_expr * -gfc_simplify_exp (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model_kind (x->ts.kind); - mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_exp(): Bad type"); - } - - return range_check (result, "EXP"); -} - - -gfc_expr * -gfc_simplify_exponent (gfc_expr *x) -{ - int i; - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &x->where); - - gfc_set_model (x->value.real); - - if (mpfr_sgn (x->value.real) == 0) - { - mpz_set_ui (result->value.integer, 0); - return result; - } - - i = (int) mpfr_get_exp (x->value.real); - mpz_set_si (result->value.integer, i); - - return range_check (result, "EXPONENT"); -} - - -gfc_expr * -gfc_simplify_float (gfc_expr *a) -{ - gfc_expr *result; - - if (a->expr_type != EXPR_CONSTANT) - return NULL; - - if (a->is_boz) - { - if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr) - return &gfc_bad_expr; - - result = gfc_copy_expr (a); - } - else - result = gfc_int2real (a, gfc_default_real_kind); - - return range_check (result, "FLOAT"); -} - - -static bool -is_last_ref_vtab (gfc_expr *e) -{ - gfc_ref *ref; - gfc_component *comp = NULL; - - if (e->expr_type != EXPR_VARIABLE) - return false; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - comp = ref->u.c.component; - - if (!e->ref || !comp) - return e->symtree->n.sym->attr.vtab; - - if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0) - return true; - - return false; -} - - -gfc_expr * -gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) -{ - /* Avoid simplification of resolved symbols. */ - if (is_last_ref_vtab (a) || is_last_ref_vtab (mold)) - return NULL; - - if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED) - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_type_is_extension_of (mold->ts.u.derived, - a->ts.u.derived)); - - if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold)) - return NULL; - - /* Return .false. if the dynamic type can never be the same. */ - if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS - && !gfc_type_is_extension_of - (mold->ts.u.derived->components->ts.u.derived, - a->ts.u.derived->components->ts.u.derived) - && !gfc_type_is_extension_of - (a->ts.u.derived->components->ts.u.derived, - mold->ts.u.derived->components->ts.u.derived)) - || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS - && !gfc_type_is_extension_of - (a->ts.u.derived, - mold->ts.u.derived->components->ts.u.derived) - && !gfc_type_is_extension_of - (mold->ts.u.derived->components->ts.u.derived, - a->ts.u.derived)) - || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED - && !gfc_type_is_extension_of - (mold->ts.u.derived, - a->ts.u.derived->components->ts.u.derived))) - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); - - if (mold->ts.type == BT_DERIVED - && gfc_type_is_extension_of (mold->ts.u.derived, - a->ts.u.derived->components->ts.u.derived)) - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true); - - return NULL; -} - - -gfc_expr * -gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b) -{ - /* Avoid simplification of resolved symbols. */ - if (is_last_ref_vtab (a) || is_last_ref_vtab (b)) - return NULL; - - /* Return .false. if the dynamic type can never be the - same. */ - if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS) - && !gfc_type_compatible (&a->ts, &b->ts) - && !gfc_type_compatible (&b->ts, &a->ts)) - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); - - if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_compare_derived_types (a->ts.u.derived, - b->ts.u.derived)); -} - - -gfc_expr * -gfc_simplify_floor (gfc_expr *e, gfc_expr *k) -{ - gfc_expr *result; - mpfr_t floor; - int kind; - - kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind); - if (kind == -1) - gfc_internal_error ("gfc_simplify_floor(): Bad kind"); - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_set_model_kind (kind); - - mpfr_init (floor); - mpfr_floor (floor, e->value.real); - - result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); - gfc_mpfr_to_mpz (result->value.integer, floor, &e->where); - - mpfr_clear (floor); - - return range_check (result, "FLOOR"); -} - - -gfc_expr * -gfc_simplify_fraction (gfc_expr *x) -{ - gfc_expr *result; - mpfr_t absv, exp, pow2; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - - 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_abs (absv, x->value.real, GFC_RND_MODE); - mpfr_log2 (exp, absv, GFC_RND_MODE); - - mpfr_trunc (exp, exp); - mpfr_add_ui (exp, exp, 1, GFC_RND_MODE); - - mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE); - - mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE); - - mpfr_clears (exp, absv, pow2, NULL); - - return range_check (result, "FRACTION"); -} - - -gfc_expr * -gfc_simplify_gamma (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "GAMMA"); -} - - -gfc_expr * -gfc_simplify_huge (gfc_expr *e) -{ - gfc_expr *result; - int i; - - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - - switch (e->ts.type) - { - case BT_INTEGER: - mpz_set (result->value.integer, gfc_integer_kinds[i].huge); - break; - - case BT_REAL: - mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); - break; - - default: - gcc_unreachable (); - } - - 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_get_constant_expr (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_expr * -gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) -{ - gfc_expr *result; - gfc_char_t index; - int k; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - if (e->value.character.length != 1) - { - gfc_error ("Argument of IACHAR at %L must be of length one", &e->where); - return &gfc_bad_expr; - } - - 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", - &e->where); - - k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - result = gfc_get_int_expr (k, &e->where, index); - - return range_check (result, "IACHAR"); -} - - -static gfc_expr * -do_bit_and (gfc_expr *result, gfc_expr *e) -{ - gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_INTEGER - && result->expr_type == EXPR_CONSTANT); - - mpz_and (result->value.integer, result->value.integer, e->value.integer); - return result; -} - - -gfc_expr * -gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, -1, do_bit_and); -} - - -static gfc_expr * -do_bit_ior (gfc_expr *result, gfc_expr *e) -{ - gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_INTEGER - && result->expr_type == EXPR_CONSTANT); - - mpz_ior (result->value.integer, result->value.integer, e->value.integer); - return result; -} - - -gfc_expr * -gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, 0, do_bit_ior); -} - - -gfc_expr * -gfc_simplify_iand (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); - mpz_and (result->value.integer, x->value.integer, y->value.integer); - - return range_check (result, "IAND"); -} - - -gfc_expr * -gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int k, pos; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (y, &pos); - - k = gfc_validate_kind (x->ts.type, x->ts.kind, false); - - result = gfc_copy_expr (x); - - convert_mpz_to_unsigned (result->value.integer, - gfc_integer_kinds[k].bit_size); - - mpz_clrbit (result->value.integer, pos); - - convert_mpz_to_signed (result->value.integer, - gfc_integer_kinds[k].bit_size); - - return result; -} - - -gfc_expr * -gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) -{ - gfc_expr *result; - int pos, len; - int i, k, bitsize; - int *bits; - - if (x->expr_type != EXPR_CONSTANT - || y->expr_type != EXPR_CONSTANT - || z->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (y, &pos); - gfc_extract_int (z, &len); - - k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false); - - bitsize = gfc_integer_kinds[k].bit_size; - - if (pos + len > bitsize) - { - gfc_error ("Sum of second and third arguments of IBITS exceeds " - "bit size at %L", &y->where); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - convert_mpz_to_unsigned (result->value.integer, - gfc_integer_kinds[k].bit_size); - - bits = XCNEWVEC (int, bitsize); - - for (i = 0; i < bitsize; i++) - bits[i] = 0; - - for (i = 0; i < len; i++) - bits[i] = mpz_tstbit (x->value.integer, i + pos); - - for (i = 0; i < bitsize; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i); - else if (bits[i] == 1) - mpz_setbit (result->value.integer, i); - else - gfc_internal_error ("IBITS: Bad bit"); - } - - free (bits); - - convert_mpz_to_signed (result->value.integer, - gfc_integer_kinds[k].bit_size); - - return result; -} - - -gfc_expr * -gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int k, pos; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (y, &pos); - - k = gfc_validate_kind (x->ts.type, x->ts.kind, false); - - result = gfc_copy_expr (x); - - convert_mpz_to_unsigned (result->value.integer, - gfc_integer_kinds[k].bit_size); - - mpz_setbit (result->value.integer, pos); - - convert_mpz_to_signed (result->value.integer, - gfc_integer_kinds[k].bit_size); - - return result; -} - - -gfc_expr * -gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) -{ - gfc_expr *result; - gfc_char_t index; - int k; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - if (e->value.character.length != 1) - { - gfc_error ("Argument of ICHAR at %L must be of length one", &e->where); - return &gfc_bad_expr; - } - - index = e->value.character.string[0]; - - k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - result = gfc_get_int_expr (k, &e->where, index); - - return range_check (result, "ICHAR"); -} - - -gfc_expr * -gfc_simplify_ieor (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); - mpz_xor (result->value.integer, x->value.integer, y->value.integer); - - return range_check (result, "IEOR"); -} - - -gfc_expr * -gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) -{ - gfc_expr *result; - int back, len, lensub; - int i, j, k, count, index = 0, start; - - 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) - back = 1; - else - back = 0; - - k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); - - len = x->value.character.length; - lensub = y->value.character.length; - - if (len < lensub) - { - mpz_set_si (result->value.integer, 0); - return result; - } - - if (back == 0) - { - if (lensub == 0) - { - mpz_set_si (result->value.integer, 1); - return result; - } - else if (lensub == 1) - { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[i]) - { - index = i + 1; - goto done; - } - } - } - } - else - { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[i]) - { - start = i; - count = 0; - - for (k = 0; k < lensub; k++) - { - if (y->value.character.string[k] - == x->value.character.string[k + start]) - count++; - } - - if (count == lensub) - { - index = start + 1; - goto done; - } - } - } - } - } - - } - else - { - if (lensub == 0) - { - mpz_set_si (result->value.integer, len + 1); - return result; - } - else if (lensub == 1) - { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[len - i]) - { - index = len - i + 1; - goto done; - } - } - } - } - else - { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[len - i]) - { - start = len - i; - if (start <= len - lensub) - { - count = 0; - for (k = 0; k < lensub; k++) - if (y->value.character.string[k] - == x->value.character.string[k + start]) - count++; - - if (count == lensub) - { - index = start + 1; - goto done; - } - } - else - { - continue; - } - } - } - } - } - } - -done: - mpz_set_si (result->value.integer, index); - return range_check (result, "INDEX"); -} - - -static gfc_expr * -simplify_intconv (gfc_expr *e, int kind, const char *name) -{ - gfc_expr *result = NULL; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_convert_constant (e, BT_INTEGER, kind); - if (result == &gfc_bad_expr) - return &gfc_bad_expr; - - return range_check (result, name); -} - - -gfc_expr * -gfc_simplify_int (gfc_expr *e, gfc_expr *k) -{ - int kind; - - kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; - - return simplify_intconv (e, kind, "INT"); -} - -gfc_expr * -gfc_simplify_int2 (gfc_expr *e) -{ - return simplify_intconv (e, 2, "INT2"); -} - - -gfc_expr * -gfc_simplify_int8 (gfc_expr *e) -{ - return simplify_intconv (e, 8, "INT8"); -} - - -gfc_expr * -gfc_simplify_long (gfc_expr *e) -{ - return simplify_intconv (e, 4, "LONG"); -} - - -gfc_expr * -gfc_simplify_ifix (gfc_expr *e) -{ - gfc_expr *rtrunc, *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &e->where); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); - - gfc_free_expr (rtrunc); - - return range_check (result, "IFIX"); -} - - -gfc_expr * -gfc_simplify_idint (gfc_expr *e) -{ - gfc_expr *rtrunc, *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &e->where); - 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_ior (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); - mpz_ior (result->value.integer, x->value.integer, y->value.integer); - - return range_check (result, "IOR"); -} - - -static gfc_expr * -do_bit_xor (gfc_expr *result, gfc_expr *e) -{ - gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_INTEGER - && result->expr_type == EXPR_CONSTANT); - - mpz_xor (result->value.integer, result->value.integer, e->value.integer); - return result; -} - - -gfc_expr * -gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, 0, do_bit_xor); -} - - -gfc_expr * -gfc_simplify_is_iostat_end (gfc_expr *x) -{ - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, - mpz_cmp_si (x->value.integer, - LIBERROR_END) == 0); -} - - -gfc_expr * -gfc_simplify_is_iostat_eor (gfc_expr *x) -{ - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, - mpz_cmp_si (x->value.integer, - LIBERROR_EOR) == 0); -} - - -gfc_expr * -gfc_simplify_isnan (gfc_expr *x) -{ - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, - mpfr_nan_p (x->value.real)); -} - - -/* Performs a shift on its first argument. Depending on the last - argument, the shift can be arithmetic, i.e. with filling from the - left like in the SHIFTA intrinsic. */ -static gfc_expr * -simplify_shift (gfc_expr *e, gfc_expr *s, const char *name, - bool arithmetic, int direction) -{ - gfc_expr *result; - int ashift, *bits, i, k, bitsize, shift; - - if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (s, &shift); - - k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false); - bitsize = gfc_integer_kinds[k].bit_size; - - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - - if (shift == 0) - { - mpz_set (result->value.integer, e->value.integer); - return result; - } - - if (direction > 0 && shift < 0) - { - /* Left shift, as in SHIFTL. */ - gfc_error ("Second argument of %s is negative at %L", name, &e->where); - return &gfc_bad_expr; - } - else if (direction < 0) - { - /* Right shift, as in SHIFTR or SHIFTA. */ - if (shift < 0) - { - gfc_error ("Second argument of %s is negative at %L", - name, &e->where); - return &gfc_bad_expr; - } - - shift = -shift; - } - - ashift = (shift >= 0 ? shift : -shift); - - if (ashift > bitsize) - { - gfc_error ("Magnitude of second argument of %s exceeds bit size " - "at %L", name, &e->where); - return &gfc_bad_expr; - } - - bits = XCNEWVEC (int, bitsize); - - for (i = 0; i < bitsize; i++) - bits[i] = mpz_tstbit (e->value.integer, i); - - if (shift > 0) - { - /* Left shift. */ - for (i = 0; i < shift; i++) - mpz_clrbit (result->value.integer, i); - - for (i = 0; i < bitsize - shift; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i + shift); - else - mpz_setbit (result->value.integer, i + shift); - } - } - else - { - /* Right shift. */ - if (arithmetic && bits[bitsize - 1]) - for (i = bitsize - 1; i >= bitsize - ashift; i--) - mpz_setbit (result->value.integer, i); - else - for (i = bitsize - 1; i >= bitsize - ashift; i--) - mpz_clrbit (result->value.integer, i); - - for (i = bitsize - 1; i >= ashift; i--) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i - ashift); - else - mpz_setbit (result->value.integer, i - ashift); - } - } - - convert_mpz_to_signed (result->value.integer, bitsize); - free (bits); - - return result; -} - - -gfc_expr * -gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "ISHFT", false, 0); -} - - -gfc_expr * -gfc_simplify_lshift (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "LSHIFT", false, 1); -} - - -gfc_expr * -gfc_simplify_rshift (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "RSHIFT", true, -1); -} - - -gfc_expr * -gfc_simplify_shifta (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "SHIFTA", true, -1); -} - - -gfc_expr * -gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "SHIFTL", false, 1); -} - - -gfc_expr * -gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "SHIFTR", false, -1); -} - - -gfc_expr * -gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) -{ - gfc_expr *result; - int shift, ashift, isize, ssize, delta, k; - int i, *bits; - - if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (s, &shift); - - k = gfc_validate_kind (e->ts.type, e->ts.kind, false); - isize = gfc_integer_kinds[k].bit_size; - - if (sz != NULL) - { - if (sz->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (sz, &ssize); - - } - else - ssize = isize; - - if (shift >= 0) - ashift = shift; - else - ashift = -shift; - - if (ashift > ssize) - { - if (sz == NULL) - gfc_error ("Magnitude of second argument of ISHFTC exceeds " - "BIT_SIZE of first argument at %L", &s->where); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - - mpz_set (result->value.integer, e->value.integer); - - if (shift == 0) - return result; - - convert_mpz_to_unsigned (result->value.integer, isize); - - bits = XCNEWVEC (int, ssize); - - for (i = 0; i < ssize; i++) - bits[i] = mpz_tstbit (e->value.integer, i); - - delta = ssize - ashift; - - if (shift > 0) - { - for (i = 0; i < delta; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i + shift); - else - mpz_setbit (result->value.integer, i + shift); - } - - for (i = delta; i < ssize; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i - delta); - else - mpz_setbit (result->value.integer, i - delta); - } - } - else - { - for (i = 0; i < ashift; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i + delta); - else - mpz_setbit (result->value.integer, i + delta); - } - - for (i = ashift; i < ssize; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i + shift); - else - mpz_setbit (result->value.integer, i + shift); - } - } - - convert_mpz_to_signed (result->value.integer, isize); - - free (bits); - return result; -} - - -gfc_expr * -gfc_simplify_kind (gfc_expr *e) -{ - return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind); -} - - -static gfc_expr * -simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, - gfc_array_spec *as, gfc_ref *ref, bool coarray) -{ - gfc_expr *l, *u, *result; - int k; - - k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", - gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); - - /* For non-variables, LBOUND(expr, DIM=n) = 1 and - UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */ - if (!coarray && array->expr_type != EXPR_VARIABLE) - { - if (upper) - { - gfc_expr* dim = result; - mpz_set_si (dim->value.integer, d); - - result = simplify_size (array, dim, k); - gfc_free_expr (dim); - if (!result) - goto returnNull; - } - else - mpz_set_si (result->value.integer, 1); - - goto done; - } - - /* Otherwise, we have a variable expression. */ - gcc_assert (array->expr_type == EXPR_VARIABLE); - gcc_assert (as); - - if (gfc_resolve_array_spec (as, 0) == FAILURE) - return NULL; - - /* The last dimension of an assumed-size array is special. */ - if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) - || (coarray && d == as->rank + as->corank - && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE))) - { - if (as->lower[d-1]->expr_type == EXPR_CONSTANT) - { - gfc_free_expr (result); - return gfc_copy_expr (as->lower[d-1]); - } - - goto returnNull; - } - - result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); - - /* Then, we need to know the extent of the given dimension. */ - if (coarray || ref->u.ar.type == AR_FULL) - { - l = as->lower[d-1]; - u = as->upper[d-1]; - - if (l->expr_type != EXPR_CONSTANT || u == NULL - || u->expr_type != EXPR_CONSTANT) - goto returnNull; - - 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 - { - /* Nonzero extent. */ - if (upper) - mpz_set (result->value.integer, u->value.integer); - else - mpz_set (result->value.integer, l->value.integer); - } - } - else - { - if (upper) - { - if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer, NULL) - != SUCCESS) - goto returnNull; - } - else - mpz_set_si (result->value.integer, (long int) 1); - } - -done: - return range_check (result, upper ? "UBOUND" : "LBOUND"); - -returnNull: - gfc_free_expr (result); - return NULL; -} - - -static gfc_expr * -simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) -{ - gfc_ref *ref; - gfc_array_spec *as; - int d; - - if (array->ts.type == BT_CLASS) - return NULL; - - if (array->expr_type != EXPR_VARIABLE) - { - as = NULL; - ref = NULL; - goto done; - } - - /* Follow any component references. */ - as = array->symtree->n.sym->as; - for (ref = array->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - switch (ref->u.ar.type) - { - case AR_ELEMENT: - as = NULL; - continue; - - case AR_FULL: - /* We're done because 'as' has already been set in the - previous iteration. */ - if (!ref->next) - goto done; - - /* Fall through. */ - - case AR_UNKNOWN: - return NULL; - - case AR_SECTION: - as = ref->u.ar.as; - goto done; - } - - gcc_unreachable (); - - case REF_COMPONENT: - as = ref->u.c.component->as; - continue; - - case REF_SUBSTRING: - continue; - } - } - - gcc_unreachable (); - - done: - - if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE - || as->type == AS_ASSUMED_RANK)) - return NULL; - - if (dim == NULL) - { - /* Multi-dimensional bounds. */ - gfc_expr *bounds[GFC_MAX_DIMENSIONS]; - gfc_expr *e; - int k; - - /* UBOUND(ARRAY) is not valid for an assumed-size array. */ - if (upper && as && as->type == AS_ASSUMED_SIZE) - { - /* An error message will be emitted in - check_assumed_size_reference (resolve.c). */ - return &gfc_bad_expr; - } - - /* Simplify the bounds for each dimension. */ - for (d = 0; d < array->rank; d++) - { - bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref, - false); - if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) - { - int j; - - for (j = 0; j < d; j++) - gfc_free_expr (bounds[j]); - return bounds[d]; - } - } - - /* Allocate the result expression. */ - k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", - gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - e = gfc_get_array_expr (BT_INTEGER, k, &array->where); - - /* The result is a rank 1 array; its size is the rank of the first - argument to {L,U}BOUND. */ - e->rank = 1; - e->shape = gfc_get_shape (1); - mpz_init_set_ui (e->shape[0], array->rank); - - /* Create the constructor for this array. */ - for (d = 0; d < array->rank; d++) - gfc_constructor_append_expr (&e->value.constructor, - bounds[d], &e->where); - - return e; - } - else - { - /* A DIM argument is specified. */ - if (dim->expr_type != EXPR_CONSTANT) - return NULL; - - d = mpz_get_si (dim->value.integer); - - if ((d < 1 || d > array->rank) - || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) - { - gfc_error ("DIM argument at %L is out of bounds", &dim->where); - return &gfc_bad_expr; - } - - if (as && as->type == AS_ASSUMED_RANK) - return NULL; - - return simplify_bound_dim (array, kind, d, upper, as, ref, false); - } -} - - -static gfc_expr * -simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) -{ - gfc_ref *ref; - gfc_array_spec *as; - int d; - - if (array->expr_type != EXPR_VARIABLE) - return NULL; - - /* Follow any component references. */ - as = (array->ts.type == BT_CLASS && array->ts.u.derived->components) - ? array->ts.u.derived->components->as - : array->symtree->n.sym->as; - for (ref = array->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - switch (ref->u.ar.type) - { - case AR_ELEMENT: - if (ref->u.ar.as->corank > 0) - { - gcc_assert (as == ref->u.ar.as); - goto done; - } - as = NULL; - continue; - - case AR_FULL: - /* We're done because 'as' has already been set in the - previous iteration. */ - if (!ref->next) - goto done; - - /* Fall through. */ - - case AR_UNKNOWN: - return NULL; - - case AR_SECTION: - as = ref->u.ar.as; - goto done; - } - - gcc_unreachable (); - - case REF_COMPONENT: - as = ref->u.c.component->as; - continue; - - case REF_SUBSTRING: - continue; - } - } - - if (!as) - gcc_unreachable (); - - done: - - if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE) - return NULL; - - if (dim == NULL) - { - /* Multi-dimensional cobounds. */ - gfc_expr *bounds[GFC_MAX_DIMENSIONS]; - gfc_expr *e; - int k; - - /* Simplify the cobounds for each dimension. */ - for (d = 0; d < as->corank; d++) - { - bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank, - upper, as, ref, true); - if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) - { - int j; - - for (j = 0; j < d; j++) - gfc_free_expr (bounds[j]); - return bounds[d]; - } - } - - /* Allocate the result expression. */ - e = gfc_get_expr (); - e->where = array->where; - e->expr_type = EXPR_ARRAY; - e->ts.type = BT_INTEGER; - k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND", - gfc_default_integer_kind); - if (k == -1) - { - 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 - argument to {L,U}COBOUND. */ - e->rank = 1; - e->shape = gfc_get_shape (1); - mpz_init_set_ui (e->shape[0], as->corank); - - /* Create the constructor for this array. */ - for (d = 0; d < as->corank; d++) - gfc_constructor_append_expr (&e->value.constructor, - bounds[d], &e->where); - return e; - } - else - { - /* A DIM argument is specified. */ - if (dim->expr_type != EXPR_CONSTANT) - return NULL; - - d = mpz_get_si (dim->value.integer); - - if (d < 1 || d > as->corank) - { - gfc_error ("DIM argument at %L is out of bounds", &dim->where); - return &gfc_bad_expr; - } - - return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true); - } -} - - -gfc_expr * -gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - return simplify_bound (array, dim, kind, 0); -} - - -gfc_expr * -gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - return simplify_cobound (array, dim, kind, 0); -} - -gfc_expr * -gfc_simplify_leadz (gfc_expr *e) -{ - 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); - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); -} - - -gfc_expr * -gfc_simplify_len (gfc_expr *e, gfc_expr *kind) -{ - gfc_expr *result; - int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind); - - if (k == -1) - return &gfc_bad_expr; - - if (e->expr_type == EXPR_CONSTANT) - { - result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); - mpz_set_si (result->value.integer, e->value.character.length); - return range_check (result, "LEN"); - } - else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL - && e->ts.u.cl->length->expr_type == EXPR_CONSTANT - && e->ts.u.cl->length->ts.type == BT_INTEGER) - { - result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); - mpz_set (result->value.integer, e->ts.u.cl->length->value.integer); - return range_check (result, "LEN"); - } - else - return NULL; -} - - -gfc_expr * -gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) -{ - gfc_expr *result; - int count, len, i; - int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind); - - if (k == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - len = e->value.character.length; - for (count = 0, i = 1; i <= len; i++) - if (e->value.character.string[len - i] == ' ') - count++; - else - break; - - result = gfc_get_int_expr (k, &e->where, len - count); - return range_check (result, "LEN_TRIM"); -} - -gfc_expr * -gfc_simplify_lgamma (gfc_expr *x) -{ - gfc_expr *result; - int sg; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE); - - return range_check (result, "LGAMMA"); -} - - -gfc_expr * -gfc_simplify_lge (gfc_expr *a, gfc_expr *b) -{ - if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_compare_string (a, b) >= 0); -} - - -gfc_expr * -gfc_simplify_lgt (gfc_expr *a, gfc_expr *b) -{ - if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_compare_string (a, b) > 0); -} - - -gfc_expr * -gfc_simplify_lle (gfc_expr *a, gfc_expr *b) -{ - if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_compare_string (a, b) <= 0); -} - - -gfc_expr * -gfc_simplify_llt (gfc_expr *a, gfc_expr *b) -{ - if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_compare_string (a, b) < 0); -} - - -gfc_expr * -gfc_simplify_log (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - if (mpfr_sgn (x->value.real) <= 0) - { - gfc_error ("Argument of LOG at %L cannot be less than or equal " - "to zero", &x->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - - mpfr_log (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - 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); - gfc_free_expr (result); - return &gfc_bad_expr; - } - - gfc_set_model_kind (x->ts.kind); - mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_simplify_log: bad type"); - } - - return range_check (result, "LOG"); -} - - -gfc_expr * -gfc_simplify_log10 (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - if (mpfr_sgn (x->value.real) <= 0) - { - gfc_error ("Argument of LOG10 at %L cannot be less than or equal " - "to zero", &x->where); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "LOG10"); -} - - -gfc_expr * -gfc_simplify_logical (gfc_expr *e, gfc_expr *k) -{ - int kind; - - kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind); - if (kind < 0) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (kind, &e->where, e->value.logical); -} - - -gfc_expr* -gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) -{ - gfc_expr *result; - int row, result_rows, col, result_columns; - int stride_a, offset_a, stride_b, offset_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_get_array_expr (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[1]); - 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_a->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[0]); - 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(); - - offset_a = offset_b = 0; - for (col = 0; col < result_columns; ++col) - { - offset_a = 0; - - for (row = 0; row < result_rows; ++row) - { - gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a, - matrix_b, 1, offset_b); - gfc_constructor_append_expr (&result->value.constructor, - e, NULL); - - offset_a += 1; - } - - offset_b += stride_b; - } - - return result; -} - - -gfc_expr * -gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg) -{ - gfc_expr *result; - int kind, arg, k; - const char *s; - - if (i->expr_type != EXPR_CONSTANT) - return NULL; - - kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; - k = gfc_validate_kind (BT_INTEGER, kind, false); - - s = gfc_extract_int (i, &arg); - gcc_assert (!s); - - result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); - - /* MASKR(n) = 2^n - 1 */ - mpz_set_ui (result->value.integer, 1); - mpz_mul_2exp (result->value.integer, result->value.integer, arg); - mpz_sub_ui (result->value.integer, result->value.integer, 1); - - convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); - - return result; -} - - -gfc_expr * -gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) -{ - gfc_expr *result; - int kind, arg, k; - const char *s; - mpz_t z; - - if (i->expr_type != EXPR_CONSTANT) - return NULL; - - kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; - k = gfc_validate_kind (BT_INTEGER, kind, false); - - s = gfc_extract_int (i, &arg); - gcc_assert (!s); - - result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); - - /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */ - mpz_init_set_ui (z, 1); - mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size); - mpz_set_ui (result->value.integer, 1); - mpz_mul_2exp (result->value.integer, result->value.integer, - gfc_integer_kinds[k].bit_size - arg); - mpz_sub (result->value.integer, z, result->value.integer); - mpz_clear (z); - - convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); - - 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); -} - - -gfc_expr * -gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr) -{ - mpz_t arg1, arg2, mask; - gfc_expr *result; - - if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT - || mask_expr->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where); - - /* Convert all argument to unsigned. */ - mpz_init_set (arg1, i->value.integer); - mpz_init_set (arg2, j->value.integer); - mpz_init_set (mask, mask_expr->value.integer); - - /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */ - mpz_and (arg1, arg1, mask); - mpz_com (mask, mask); - mpz_and (arg2, arg2, mask); - mpz_ior (result->value.integer, arg1, arg2); - - mpz_clear (arg1); - mpz_clear (arg2); - mpz_clear (mask); - - return result; -} - - -/* Selects between 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); - free (tmp); - } - - if (gfc_compare_string (arg, extremum) * sign > 0) - { - 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 - constant elements are deleted. Because the argument list has - already been checked, this function always succeeds. sign is 1 for - MAX(), -1 for MIN(). */ - -static gfc_expr * -simplify_min_max (gfc_expr *expr, int sign) -{ - gfc_actual_arglist *arg, *last, *extremum; - gfc_intrinsic_sym * specific; - - last = NULL; - extremum = NULL; - specific = expr->value.function.isym; - - arg = expr->value.function.actual; - - for (; arg; last = arg, arg = arg->next) - { - if (arg->expr->expr_type != EXPR_CONSTANT) - continue; - - if (extremum == NULL) - { - extremum = arg; - continue; - } - - min_max_choose (arg->expr, extremum->expr, sign); - - /* Delete the extra constant argument. */ - last->next = arg->next; - - arg->next = NULL; - gfc_free_actual_arglist (arg); - arg = last; - } - - /* If there is one value left, replace the function call with the - expression. */ - if (expr->value.function.actual->next != NULL) - return NULL; - - /* Convert to the correct type and kind. */ - if (expr->ts.type != BT_UNKNOWN) - return gfc_convert_constant (expr->value.function.actual->expr, - expr->ts.type, expr->ts.kind); - - if (specific->ts.type != BT_UNKNOWN) - return gfc_convert_constant (expr->value.function.actual->expr, - specific->ts.type, specific->ts.kind); - - return gfc_copy_expr (expr->value.function.actual->expr); -} - - -gfc_expr * -gfc_simplify_min (gfc_expr *e) -{ - return simplify_min_max (e, -1); -} - - -gfc_expr * -gfc_simplify_max (gfc_expr *e) -{ - return simplify_min_max (e, 1); -} - - -/* 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 *c, *extremum; - gfc_intrinsic_sym * specific; - - extremum = NULL; - specific = expr->value.function.isym; - - for (c = gfc_constructor_first (expr->value.constructor); - c; c = gfc_constructor_next (c)) - { - if (c->expr->expr_type != EXPR_CONSTANT) - return NULL; - - if (extremum == NULL) - { - extremum = c; - continue; - } - - min_max_choose (c->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) -{ - int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); - return gfc_get_int_expr (gfc_default_integer_kind, &x->where, - gfc_real_kinds[i].max_exponent); -} - - -gfc_expr * -gfc_simplify_minexponent (gfc_expr *x) -{ - int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); - return gfc_get_int_expr (gfc_default_integer_kind, &x->where, - gfc_real_kinds[i].min_exponent); -} - - -gfc_expr * -gfc_simplify_mod (gfc_expr *a, gfc_expr *p) -{ - gfc_expr *result; - int kind; - - if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) - return NULL; - - kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - result = gfc_get_constant_expr (a->ts.type, kind, &a->where); - - switch (a->ts.type) - { - case BT_INTEGER: - if (mpz_cmp_ui (p->value.integer, 0) == 0) - { - /* Result is processor-dependent. */ - gfc_error ("Second argument MOD at %L is zero", &a->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); - break; - - case BT_REAL: - if (mpfr_cmp_ui (p->value.real, 0) == 0) - { - /* Result is processor-dependent. */ - gfc_error ("Second argument of MOD at %L is zero", &p->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - - gfc_set_model_kind (kind); - mpfr_fmod (result->value.real, a->value.real, p->value.real, - GFC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); - } - - return range_check (result, "MOD"); -} - - -gfc_expr * -gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) -{ - gfc_expr *result; - int kind; - - if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) - return NULL; - - kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - result = gfc_get_constant_expr (a->ts.type, kind, &a->where); - - switch (a->ts.type) - { - case BT_INTEGER: - if (mpz_cmp_ui (p->value.integer, 0) == 0) - { - /* Result is processor-dependent. This processor just opts - to not handle it at all. */ - gfc_error ("Second argument of MODULO at %L is zero", &a->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); - - break; - - case BT_REAL: - if (mpfr_cmp_ui (p->value.real, 0) == 0) - { - /* Result is processor-dependent. */ - gfc_error ("Second argument of MODULO at %L is zero", &p->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - - gfc_set_model_kind (kind); - mpfr_fmod (result->value.real, a->value.real, p->value.real, - GFC_RND_MODE); - if (mpfr_cmp_ui (result->value.real, 0) != 0) - { - if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real)) - mpfr_add (result->value.real, result->value.real, p->value.real, - GFC_RND_MODE); - } - else - mpfr_copysign (result->value.real, result->value.real, - p->value.real, GFC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); - } - - return range_check (result, "MODULO"); -} - - -/* Exists for the sole purpose of consistency with other intrinsics. */ -gfc_expr * -gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED, - gfc_expr *fp ATTRIBUTE_UNUSED, - gfc_expr *l ATTRIBUTE_UNUSED, - gfc_expr *to ATTRIBUTE_UNUSED, - gfc_expr *tp ATTRIBUTE_UNUSED) -{ - return NULL; -} - - -gfc_expr * -gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) -{ - gfc_expr *result; - mp_exp_t emin, emax; - int kind; - - if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_copy_expr (x); - - /* Save current values of emin and emax. */ - emin = mpfr_get_emin (); - emax = mpfr_get_emax (); - - /* Set emin and emax for the current model number. */ - kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0); - 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) - { - mpfr_nextabove (result->value.real); - mpfr_subnormalize (result->value.real, 0, GMP_RNDU); - } - else - { - mpfr_nextbelow (result->value.real); - mpfr_subnormalize (result->value.real, 0, GMP_RNDD); - } - - mpfr_set_emin (emin); - mpfr_set_emax (emax); - - /* Only NaN can occur. Do not use range check as it gives an - error for denormal numbers. */ - 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; - } - - return result; -} - - -static gfc_expr * -simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) -{ - gfc_expr *itrunc, *result; - int kind; - - kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - itrunc = gfc_copy_expr (e); - mpfr_round (itrunc->value.real, e->value.real); - - result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); - gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where); - - gfc_free_expr (itrunc); - - return range_check (result, name); -} - - -gfc_expr * -gfc_simplify_new_line (gfc_expr *e) -{ - gfc_expr *result; - - result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1); - result->value.character.string[0] = '\n'; - - return result; -} - - -gfc_expr * -gfc_simplify_nint (gfc_expr *e, gfc_expr *k) -{ - return simplify_nint ("NINT", e, k); -} - - -gfc_expr * -gfc_simplify_idnint (gfc_expr *e) -{ - return simplify_nint ("IDNINT", e, NULL); -} - - -static gfc_expr * -add_squared (gfc_expr *result, gfc_expr *e) -{ - mpfr_t tmp; - - gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_REAL - && result->expr_type == EXPR_CONSTANT); - - gfc_set_model_kind (result->ts.kind); - mpfr_init (tmp); - mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE); - mpfr_add (result->value.real, result->value.real, tmp, - GFC_RND_MODE); - mpfr_clear (tmp); - - return result; -} - - -static gfc_expr * -do_sqrt (gfc_expr *result, gfc_expr *e) -{ - gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_REAL - && result->expr_type == EXPR_CONSTANT); - - mpfr_set (result->value.real, e->value.real, GFC_RND_MODE); - mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); - return result; -} - - -gfc_expr * -gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) -{ - gfc_expr *result; - - if (!is_constant_array_expr (e) - || (dim != NULL && !gfc_is_constant_expr (dim))) - return NULL; - - result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); - init_result_expr (result, 0, NULL); - - if (!dim || e->rank == 1) - { - result = simplify_transformation_to_scalar (result, e, NULL, - add_squared); - mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); - } - else - result = simplify_transformation_to_array (result, e, dim, NULL, - add_squared, &do_sqrt); - - return result; -} - - -gfc_expr * -gfc_simplify_not (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - mpz_com (result->value.integer, e->value.integer); - - return range_check (result, "NOT"); -} - - -gfc_expr * -gfc_simplify_null (gfc_expr *mold) -{ - gfc_expr *result; - - if (mold) - { - result = gfc_copy_expr (mold); - result->expr_type = EXPR_NULL; - } - else - result = gfc_get_null_expr (NULL); - - return result; -} - - -gfc_expr * -gfc_simplify_num_images (void) -{ - gfc_expr *result; - - if (gfc_option.coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); - return &gfc_bad_expr; - } - - if (gfc_option.coarray != GFC_FCOARRAY_SINGLE) - return NULL; - - /* FIXME: gfc_current_locus is wrong. */ - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &gfc_current_locus); - mpz_set_si (result->value.integer, 1); - return result; -} - - -gfc_expr * -gfc_simplify_or (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int kind; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - - switch (x->ts.type) - { - case BT_INTEGER: - result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); - mpz_ior (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "OR"); - - case BT_LOGICAL: - return gfc_get_logical_expr (kind, &x->where, - x->value.logical || y->value.logical); - default: - gcc_unreachable(); - } -} - - -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_get_array_expr (array->ts.type, array->ts.kind, &array->where); - if (array->ts.type == BT_DERIVED) - result->ts.u.derived = array->ts.u.derived; - - array_ctor = gfc_constructor_first (array->value.constructor); - vector_ctor = vector - ? gfc_constructor_first (vector->value.constructor) - : NULL; - - if (mask->expr_type == EXPR_CONSTANT - && mask->value.logical) - { - /* Copy all elements of ARRAY to RESULT. */ - while (array_ctor) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (array_ctor->expr), - NULL); - - array_ctor = gfc_constructor_next (array_ctor); - vector_ctor = gfc_constructor_next (vector_ctor); - } - } - else if (mask->expr_type == EXPR_ARRAY) - { - /* Copy only those elements of ARRAY to RESULT whose - MASK equals .TRUE.. */ - mask_ctor = gfc_constructor_first (mask->value.constructor); - while (mask_ctor) - { - if (mask_ctor->expr->value.logical) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (array_ctor->expr), - NULL); - vector_ctor = gfc_constructor_next (vector_ctor); - } - - array_ctor = gfc_constructor_next (array_ctor); - mask_ctor = gfc_constructor_next (mask_ctor); - } - } - - /* Append any left-over elements from VECTOR to RESULT. */ - while (vector_ctor) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (vector_ctor->expr), - NULL); - vector_ctor = gfc_constructor_next (vector_ctor); - } - - result->shape = gfc_get_shape (1); - gfc_array_size (result, &result->shape[0]); - - if (array->ts.type == BT_CHARACTER) - result->ts.u.cl = array->ts.u.cl; - - return result; -} - - -static gfc_expr * -do_xor (gfc_expr *result, gfc_expr *e) -{ - gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_LOGICAL - && result->expr_type == EXPR_CONSTANT); - - result->value.logical = result->value.logical != e->value.logical; - return result; -} - - - -gfc_expr * -gfc_simplify_parity (gfc_expr *e, gfc_expr *dim) -{ - return simplify_transformation (e, dim, NULL, 0, do_xor); -} - - -gfc_expr * -gfc_simplify_popcnt (gfc_expr *e) -{ - int res, k; - mpz_t x; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - k = gfc_validate_kind (e->ts.type, e->ts.kind, false); - - /* Convert argument to unsigned, then count the '1' bits. */ - mpz_init_set (x, e->value.integer); - convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); - res = mpz_popcount (x); - mpz_clear (x); - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res); -} - - -gfc_expr * -gfc_simplify_poppar (gfc_expr *e) -{ - gfc_expr *popcnt; - const char *s; - int i; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - popcnt = gfc_simplify_popcnt (e); - gcc_assert (popcnt); - - s = gfc_extract_int (popcnt, &i); - gcc_assert (!s); - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2); -} - - -gfc_expr * -gfc_simplify_precision (gfc_expr *e) -{ - int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, - gfc_real_kinds[i].precision); -} - - -gfc_expr * -gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, 1, gfc_multiply); -} - - -gfc_expr * -gfc_simplify_radix (gfc_expr *e) -{ - int i; - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - - switch (e->ts.type) - { - case BT_INTEGER: - i = gfc_integer_kinds[i].radix; - break; - - case BT_REAL: - i = gfc_real_kinds[i].radix; - break; - - default: - gcc_unreachable (); - } - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); -} - - -gfc_expr * -gfc_simplify_range (gfc_expr *e) -{ - int i; - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - - switch (e->ts.type) - { - case BT_INTEGER: - i = gfc_integer_kinds[i].range; - break; - - case BT_REAL: - case BT_COMPLEX: - i = gfc_real_kinds[i].range; - break; - - default: - gcc_unreachable (); - } - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); -} - - -gfc_expr * -gfc_simplify_rank (gfc_expr *e) -{ - /* Assumed rank. */ - if (e->rank == -1) - return NULL; - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank); -} - - -gfc_expr * -gfc_simplify_real (gfc_expr *e, gfc_expr *k) -{ - gfc_expr *result = NULL; - int kind; - - if (e->ts.type == BT_COMPLEX) - kind = get_kind (BT_REAL, k, "REAL", e->ts.kind); - else - kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind); - - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - if (convert_boz (e, kind) == &gfc_bad_expr) - return &gfc_bad_expr; - - result = gfc_convert_constant (e, BT_REAL, kind); - if (result == &gfc_bad_expr) - return &gfc_bad_expr; - - return range_check (result, "REAL"); -} - - -gfc_expr * -gfc_simplify_realpart (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); - - return range_check (result, "REALPART"); -} - -gfc_expr * -gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) -{ - gfc_expr *result; - int i, j, len, ncop, nlen; - mpz_t ncopies; - bool have_length = false; - - /* If NCOPIES isn't a constant, there's nothing we can do. */ - if (n->expr_type != EXPR_CONSTANT) - return NULL; - - /* If NCOPIES is negative, it's an error. */ - if (mpz_sgn (n->value.integer) < 0) - { - gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L", - &n->where); - return &gfc_bad_expr; - } - - /* If we don't know the character length, we can do no more. */ - if (e->ts.u.cl && e->ts.u.cl->length - && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - len = mpz_get_si (e->ts.u.cl->length->value.integer); - have_length = true; - } - else if (e->expr_type == EXPR_CONSTANT - && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) - { - len = e->value.character.length; - } - else - return NULL; - - /* If the source length is 0, any value of NCOPIES is valid - and everything behaves as if NCOPIES == 0. */ - mpz_init (ncopies); - if (len == 0) - mpz_set_ui (ncopies, 0); - else - mpz_set (ncopies, n->value.integer); - - /* Check that NCOPIES isn't too large. */ - if (len) - { - mpz_t max, mlen; - int i; - - /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */ - mpz_init (max); - i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); - - if (have_length) - { - mpz_tdiv_q (max, gfc_integer_kinds[i].huge, - e->ts.u.cl->length->value.integer); - } - else - { - mpz_init_set_si (mlen, len); - mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen); - mpz_clear (mlen); - } - - /* The check itself. */ - if (mpz_cmp (ncopies, max) > 0) - { - mpz_clear (max); - mpz_clear (ncopies); - gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L", - &n->where); - return &gfc_bad_expr; - } - - mpz_clear (max); - } - mpz_clear (ncopies); - - /* For further simplification, we need the character string to be - constant. */ - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - if (len || - (e->ts.u.cl->length && - mpz_sgn (e->ts.u.cl->length->value.integer)) != 0) - { - const char *res = gfc_extract_int (n, &ncop); - gcc_assert (res == NULL); - } - else - ncop = 0; - - if (ncop == 0) - return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); - - len = e->value.character.length; - nlen = ncop * len; - - result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen); - 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[nlen] = '\0'; /* For debugger */ - return result; -} - - -/* This one is a bear, but mainly has to do with shuffling elements. */ - -gfc_expr * -gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, - gfc_expr *pad, gfc_expr *order_exp) -{ - int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS]; - int i, rank, npad, x[GFC_MAX_DIMENSIONS]; - mpz_t index, size; - unsigned long j; - size_t nsource; - gfc_expr *e, *result; - - /* 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; - - /* Proceed with simplification, unpacking the array. */ - - mpz_init (index); - rank = 0; - - for (;;) - { - e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank); - if (e == NULL) - break; - - gfc_extract_int (e, &shape[rank]); - - gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS); - gcc_assert (shape[rank] >= 0); - - rank++; - } - - gcc_assert (rank > 0); - - /* Now unpack the order array if present. */ - if (order_exp == NULL) - { - for (i = 0; i < rank; i++) - order[i] = i; - } - else - { - for (i = 0; i < rank; i++) - x[i] = 0; - - for (i = 0; i < rank; i++) - { - e = gfc_constructor_lookup_expr (order_exp->value.constructor, i); - gcc_assert (e); - - gfc_extract_int (e, &order[i]); - - gcc_assert (order[i] >= 1 && order[i] <= rank); - order[i]--; - gcc_assert (x[order[i]] == 0); - x[order[i]] = 1; - } - } - - /* Count the elements in the source and padding arrays. */ - - npad = 0; - if (pad != NULL) - { - gfc_array_size (pad, &size); - npad = mpz_get_ui (size); - mpz_clear (size); - } - - gfc_array_size (source, &size); - nsource = mpz_get_ui (size); - mpz_clear (size); - - /* If it weren't for that pesky permutation we could just loop - through the source and round out any shortage with pad elements. - But no, someone just had to have the compiler do something the - user should be doing. */ - - for (i = 0; i < rank; i++) - x[i] = 0; - - result = gfc_get_array_expr (source->ts.type, source->ts.kind, - &source->where); - if (source->ts.type == BT_DERIVED) - result->ts.u.derived = source->ts.u.derived; - result->rank = rank; - result->shape = gfc_get_shape (rank); - for (i = 0; i < rank; i++) - mpz_init_set_ui (result->shape[i], shape[i]); - - while (nsource > 0 || npad > 0) - { - /* Figure out which element to extract. */ - mpz_set_ui (index, 0); - - for (i = rank - 1; i >= 0; i--) - { - mpz_add_ui (index, index, x[order[i]]); - if (i != 0) - mpz_mul_ui (index, index, shape[order[i - 1]]); - } - - if (mpz_cmp_ui (index, INT_MAX) > 0) - gfc_internal_error ("Reshaped array too large at %C"); - - j = mpz_get_ui (index); - - if (j < nsource) - e = gfc_constructor_lookup_expr (source->value.constructor, j); - else - { - gcc_assert (npad > 0); - - j = j - nsource; - j = j % npad; - e = gfc_constructor_lookup_expr (pad->value.constructor, j); - } - gcc_assert (e); - - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (e), &e->where); - - /* Calculate the next element. */ - i = 0; - -inc: - if (++x[i] < shape[i]) - continue; - x[i++] = 0; - if (i < rank) - goto inc; - - break; - } - - mpz_clear (index); - - return result; -} - - -gfc_expr * -gfc_simplify_rrspacing (gfc_expr *x) -{ - gfc_expr *result; - int i; - long int e, p; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - i = gfc_validate_kind (x->ts.type, x->ts.kind, false); - - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); - - /* Special case x = -0 and 0. */ - if (mpfr_sgn (result->value.real) == 0) - { - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); - return result; - } - - /* | x * 2**(-e) | * 2**p. */ - e = - (long int) mpfr_get_exp (x->value.real); - mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE); - - p = (long int) gfc_real_kinds[i].digits; - mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE); - - return range_check (result, "RRSPACING"); -} - - -gfc_expr * -gfc_simplify_scale (gfc_expr *x, gfc_expr *i) -{ - int k, neg_flag, power, exp_range; - mpfr_t scale, radix; - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - - if (mpfr_sgn (x->value.real) == 0) - { - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); - return result; - } - - k = gfc_validate_kind (BT_REAL, x->ts.kind, false); - - exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent; - - /* This check filters out values of i that would overflow an int. */ - if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0 - || 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; - } - - /* Compute scale = radix ** power. */ - power = mpz_get_si (i->value.integer); - - if (power >= 0) - neg_flag = 0; - else - { - neg_flag = 1; - power = -power; - } - - gfc_set_model_kind (x->ts.kind); - mpfr_init (scale); - mpfr_init (radix); - mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE); - mpfr_pow_ui (scale, radix, power, GFC_RND_MODE); - - if (neg_flag) - mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE); - else - mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE); - - 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) -{ - gfc_expr *result; - int back; - size_t i; - size_t indx, len, lenc; - int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind); - - if (k == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT - || ( b != NULL && b->expr_type != EXPR_CONSTANT)) - return NULL; - - if (b != NULL && b->value.logical != 0) - back = 1; - else - back = 0; - - len = e->value.character.length; - lenc = c->value.character.length; - - if (len == 0 || lenc == 0) - { - indx = 0; - } - else - { - if (back == 0) - { - indx = wide_strcspn (e->value.character.string, - c->value.character.string) + 1; - if (indx > len) - indx = 0; - } - else - { - i = 0; - for (indx = len; indx > 0; indx--) - { - for (i = 0; i < lenc; i++) - { - if (c->value.character.string[i] - == e->value.character.string[indx - 1]) - break; - } - if (i < lenc) - break; - } - } - } - - result = gfc_get_int_expr (k, &e->where, indx); - return range_check (result, "SCAN"); -} - - -gfc_expr * -gfc_simplify_selected_char_kind (gfc_expr *e) -{ - int kind; - - 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; - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); -} - - -gfc_expr * -gfc_simplify_selected_int_kind (gfc_expr *e) -{ - int i, kind, range; - - if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL) - return NULL; - - kind = INT_MAX; - - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - if (gfc_integer_kinds[i].range >= range - && gfc_integer_kinds[i].kind < kind) - kind = gfc_integer_kinds[i].kind; - - if (kind == INT_MAX) - kind = -1; - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); -} - - -gfc_expr * -gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx) -{ - int range, precision, radix, i, kind, found_precision, found_range, - found_radix; - locus *loc = &gfc_current_locus; - - if (p == NULL) - precision = 0; - else - { - if (p->expr_type != EXPR_CONSTANT - || gfc_extract_int (p, &precision) != NULL) - return NULL; - loc = &p->where; - } - - if (q == NULL) - range = 0; - else - { - if (q->expr_type != EXPR_CONSTANT - || gfc_extract_int (q, &range) != NULL) - return NULL; - - if (!loc) - loc = &q->where; - } - - if (rdx == NULL) - radix = 0; - else - { - if (rdx->expr_type != EXPR_CONSTANT - || gfc_extract_int (rdx, &radix) != NULL) - return NULL; - - if (!loc) - loc = &rdx->where; - } - - kind = INT_MAX; - found_precision = 0; - found_range = 0; - found_radix = 0; - - for (i = 0; gfc_real_kinds[i].kind != 0; i++) - { - if (gfc_real_kinds[i].precision >= precision) - found_precision = 1; - - if (gfc_real_kinds[i].range >= range) - found_range = 1; - - if (gfc_real_kinds[i].radix >= radix) - found_radix = 1; - - if (gfc_real_kinds[i].precision >= precision - && gfc_real_kinds[i].range >= range - && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind) - kind = gfc_real_kinds[i].kind; - } - - if (kind == INT_MAX) - { - if (found_radix && found_range && !found_precision) - kind = -1; - else if (found_radix && found_precision && !found_range) - kind = -2; - else if (found_radix && !found_precision && !found_range) - kind = -3; - else if (found_radix) - kind = -4; - else - kind = -5; - } - - return gfc_get_int_expr (gfc_default_integer_kind, loc, kind); -} - - -gfc_expr * -gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) -{ - gfc_expr *result; - mpfr_t exp, absv, log2, pow2, frac; - unsigned long exp2; - - if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - - 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); - mpfr_init (pow2); - mpfr_init (frac); - - mpfr_abs (absv, x->value.real, GFC_RND_MODE); - mpfr_log2 (log2, absv, GFC_RND_MODE); - - mpfr_trunc (log2, log2); - mpfr_add_ui (exp, log2, 1, GFC_RND_MODE); - - /* Old exponent value, and fraction. */ - mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE); - - mpfr_div (frac, absv, pow2, GFC_RND_MODE); - - /* New exponent. */ - exp2 = (unsigned long) mpz_get_d (i->value.integer); - mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE); - - mpfr_clears (absv, log2, pow2, frac, NULL); - - return range_check (result, "SET_EXPONENT"); -} - - -gfc_expr * -gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) -{ - mpz_t shape[GFC_MAX_DIMENSIONS]; - gfc_expr *result, *e, *f; - gfc_array_ref *ar; - int n; - gfc_try t; - int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); - - if (source->rank == -1) - return NULL; - - result = gfc_get_array_expr (BT_INTEGER, k, &source->where); - - if (source->rank == 0) - return result; - - if (source->expr_type == EXPR_VARIABLE) - { - ar = gfc_find_array_ref (source); - t = gfc_array_ref_shape (ar, shape); - } - else if (source->shape) - { - t = SUCCESS; - for (n = 0; n < source->rank; n++) - { - mpz_init (shape[n]); - mpz_set (shape[n], source->shape[n]); - } - } - else - t = FAILURE; - - for (n = 0; n < source->rank; n++) - { - e = gfc_get_constant_expr (BT_INTEGER, k, &source->where); - - if (t == SUCCESS) - mpz_set (e->value.integer, shape[n]); - else - { - mpz_set_ui (e->value.integer, n + 1); - - f = simplify_size (source, e, k); - gfc_free_expr (e); - if (f == NULL) - { - gfc_free_expr (result); - return NULL; - } - else - e = f; - } - - if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr) - { - gfc_free_expr (result); - if (t) - gfc_clear_shape (shape, source->rank); - return &gfc_bad_expr; - } - - gfc_constructor_append_expr (&result->value.constructor, e, NULL); - } - - if (t) - gfc_clear_shape (shape, source->rank); - - return result; -} - - -static gfc_expr * -simplify_size (gfc_expr *array, gfc_expr *dim, int k) -{ - mpz_t size; - gfc_expr *return_value; - int d; - - /* For unary operations, the size of the result is given by the size - of the operand. For binary ones, it's the size of the first operand - unless it is scalar, then it is the size of the second. */ - if (array->expr_type == EXPR_OP && !array->value.op.uop) - { - gfc_expr* replacement; - gfc_expr* simplified; - - switch (array->value.op.op) - { - /* Unary operations. */ - case INTRINSIC_NOT: - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - case INTRINSIC_PARENTHESES: - replacement = array->value.op.op1; - break; - - /* Binary operations. If any one of the operands is scalar, take - the other one's size. If both of them are arrays, it does not - matter -- try to find one with known shape, if possible. */ - default: - if (array->value.op.op1->rank == 0) - replacement = array->value.op.op2; - else if (array->value.op.op2->rank == 0) - replacement = array->value.op.op1; - else - { - simplified = simplify_size (array->value.op.op1, dim, k); - if (simplified) - return simplified; - - replacement = array->value.op.op2; - } - break; - } - - /* Try to reduce it directly if possible. */ - simplified = simplify_size (replacement, dim, k); - - /* Otherwise, we build a new SIZE call. This is hopefully at least - simpler than the original one. */ - if (!simplified) - { - gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k); - simplified = gfc_build_intrinsic_call (gfc_current_ns, - GFC_ISYM_SIZE, "size", - array->where, 3, - gfc_copy_expr (replacement), - gfc_copy_expr (dim), - kind); - } - return simplified; - } - - if (dim == NULL) - { - if (gfc_array_size (array, &size) == FAILURE) - return NULL; - } - else - { - if (dim->expr_type != EXPR_CONSTANT) - return NULL; - - d = mpz_get_ui (dim->value.integer) - 1; - if (gfc_array_dimen_size (array, d, &size) == FAILURE) - return NULL; - } - - return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where); - mpz_set (return_value->value.integer, size); - mpz_clear (size); - - return return_value; -} - - -gfc_expr * -gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - gfc_expr *result; - int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); - - if (k == -1) - return &gfc_bad_expr; - - result = simplify_size (array, dim, k); - if (result == NULL || result == &gfc_bad_expr) - return result; - - return range_check (result, "SIZE"); -} - - -gfc_expr * -gfc_simplify_sign (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_INTEGER: - mpz_abs (result->value.integer, x->value.integer); - if (mpz_sgn (y->value.integer) < 0) - mpz_neg (result->value.integer, result->value.integer); - break; - - case BT_REAL: - if (gfc_option.flag_sign_zero) - mpfr_copysign (result->value.real, x->value.real, y->value.real, - GFC_RND_MODE); - else - mpfr_setsign (result->value.real, x->value.real, - mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); - break; - - default: - gfc_internal_error ("Bad type in gfc_simplify_sign"); - } - - return result; -} - - -gfc_expr * -gfc_simplify_sin (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model (x->value.real); - mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_sin(): Bad type"); - } - - return range_check (result, "SIN"); -} - - -gfc_expr * -gfc_simplify_sinh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gcc_unreachable (); - } - - return range_check (result, "SINH"); -} - - -/* The argument is always a double precision real that is converted to - single precision. TODO: Rounding! */ - -gfc_expr * -gfc_simplify_sngl (gfc_expr *a) -{ - gfc_expr *result; - - if (a->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_real2real (a, gfc_default_real_kind); - return range_check (result, "SNGL"); -} - - -gfc_expr * -gfc_simplify_spacing (gfc_expr *x) -{ - gfc_expr *result; - int i; - long int en, ep; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - i = gfc_validate_kind (x->ts.type, x->ts.kind, false); - - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - - /* Special case x = 0 and -0. */ - mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); - if (mpfr_sgn (result->value.real) == 0) - { - mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); - return result; - } - - /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p - are the radix, exponent of x, and precision. This excludes the - possibility of subnormal numbers. Fortran 2003 states the result is - b**max(e - p, emin - 1). */ - - ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits; - en = (long int) gfc_real_kinds[i].min_exponent - 1; - en = en > ep ? en : ep; - - mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); - mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE); - - return range_check (result, "SPACING"); -} - - -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_get_array_expr (source->ts.type, source->ts.kind, - &source->where); - if (source->ts.type == BT_DERIVED) - result->ts.u.derived = source->ts.u.derived; - 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_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (source), NULL); - } - else if (source->expr_type == EXPR_ARRAY) - { - int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS]; - gfc_constructor *source_ctor; - - gcc_assert (source->rank < GFC_MAX_DIMENSIONS); - gcc_assert (dim >= 0 && dim <= source->rank); - - result = gfc_get_array_expr (source->ts.type, source->ts.kind, - &source->where); - if (source->ts.type == BT_DERIVED) - result->ts.u.derived = source->ts.u.derived; - result->rank = source->rank + 1; - result->shape = gfc_get_shape (result->rank); - - 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]; - } - - offset = 0; - for (source_ctor = gfc_constructor_first (source->value.constructor); - source_ctor; source_ctor = gfc_constructor_next (source_ctor)) - { - for (i = 0; i < ncopies; ++i) - gfc_constructor_insert_expr (&result->value.constructor, - gfc_copy_expr (source_ctor->expr), - NULL, offset + i * rstride[dim]); - - offset += (dim == 0 ? ncopies : 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.u.cl = source->ts.u.cl; - - return result; -} - - -gfc_expr * -gfc_simplify_sqrt (gfc_expr *e) -{ - gfc_expr *result = NULL; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - switch (e->ts.type) - { - case BT_REAL: - if (mpfr_cmp_si (e->value.real, 0) < 0) - { - gfc_error ("Argument of SQRT at %L has a negative value", - &e->where); - return &gfc_bad_expr; - } - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model (e->value.real); - - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("invalid argument of SQRT at %L", &e->where); - } - - return range_check (result, "SQRT"); -} - - -gfc_expr * -gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, 0, gfc_add); -} - - -gfc_expr * -gfc_simplify_tan (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gcc_unreachable (); - } - - return range_check (result, "TAN"); -} - - -gfc_expr * -gfc_simplify_tanh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gcc_unreachable (); - } - - return range_check (result, "TANH"); -} - - -gfc_expr * -gfc_simplify_tiny (gfc_expr *e) -{ - gfc_expr *result; - int i; - - i = gfc_validate_kind (BT_REAL, e->ts.kind, false); - - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); - - return result; -} - - -gfc_expr * -gfc_simplify_trailz (gfc_expr *e) -{ - 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); - - return gfc_get_int_expr (gfc_default_integer_kind, - &e->where, MIN (tz, bs)); -} - - -gfc_expr * -gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) -{ - gfc_expr *result; - gfc_expr *mold_element; - size_t source_size; - size_t result_size; - size_t buffer_size; - mpz_t tmp; - unsigned char *buffer; - size_t result_length; - - - if (!gfc_is_constant_expr (source) - || (gfc_init_expr_flag && !gfc_is_constant_expr (mold)) - || !gfc_is_constant_expr (size)) - return NULL; - - if (gfc_calculate_transfer_sizes (source, mold, size, &source_size, - &result_size, &result_length) == FAILURE) - return NULL; - - /* Calculate the size of the source. */ - if (source->expr_type == EXPR_ARRAY - && gfc_array_size (source, &tmp) == FAILURE) - gfc_internal_error ("Failure getting length of a constant array."); - - /* Create an empty new expression with the appropriate characteristics. */ - result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind, - &source->where); - result->ts = mold->ts; - - mold_element = mold->expr_type == EXPR_ARRAY - ? gfc_constructor_first (mold->value.constructor)->expr - : mold; - - /* 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 && 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. */ - - if (mold->expr_type == EXPR_ARRAY || mold->rank || size) - { - result->expr_type = EXPR_ARRAY; - result->rank = 1; - result->shape = gfc_get_shape (1); - mpz_init_set_ui (result->shape[0], result_length); - } - else - result->rank = 0; - - /* 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); - - /* And read the buffer back into the new expression. */ - gfc_target_interpret_expr (buffer, buffer_size, result, false); - - return result; -} - - -gfc_expr * -gfc_simplify_transpose (gfc_expr *matrix) -{ - int row, matrix_rows, col, matrix_cols; - gfc_expr *result; - - if (!is_constant_array_expr (matrix)) - return NULL; - - gcc_assert (matrix->rank == 2); - - result = gfc_get_array_expr (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.u.cl = matrix->ts.u.cl; - else if (matrix->ts.type == BT_DERIVED) - result->ts.u.derived = matrix->ts.u.derived; - - matrix_rows = mpz_get_si (matrix->shape[0]); - matrix_cols = mpz_get_si (matrix->shape[1]); - for (row = 0; row < matrix_rows; ++row) - for (col = 0; col < matrix_cols; ++col) - { - gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor, - col * matrix_rows + row); - gfc_constructor_insert_expr (&result->value.constructor, - gfc_copy_expr (e), &matrix->where, - row * matrix_cols + col); - } - - return result; -} - - -gfc_expr * -gfc_simplify_trim (gfc_expr *e) -{ - gfc_expr *result; - int count, i, len, lentrim; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - len = e->value.character.length; - for (count = 0, i = 1; i <= len; ++i) - { - if (e->value.character.string[len - i] == ' ') - count++; - else - break; - } - - lentrim = len - count; - - result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim); - for (i = 0; i < lentrim; i++) - result->value.character.string[i] = e->value.character.string[i]; - - return result; -} - - -gfc_expr * -gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) -{ - gfc_expr *result; - gfc_ref *ref; - gfc_array_spec *as; - gfc_constructor *sub_cons; - bool first_image; - int d; - - if (!is_constant_array_expr (sub)) - return NULL; - - /* Follow any component references. */ - as = coarray->symtree->n.sym->as; - for (ref = coarray->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - as = ref->u.ar.as; - - if (as->type == AS_DEFERRED) - return NULL; - - /* "valid sequence of cosubscripts" are required; thus, return 0 unless - the cosubscript addresses the first image. */ - - sub_cons = gfc_constructor_first (sub->value.constructor); - first_image = true; - - for (d = 1; d <= as->corank; d++) - { - gfc_expr *ca_bound; - int cmp; - - gcc_assert (sub_cons != NULL); - - ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, - NULL, true); - if (ca_bound == NULL) - return NULL; - - if (ca_bound == &gfc_bad_expr) - return ca_bound; - - cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer); - - if (cmp == 0) - { - gfc_free_expr (ca_bound); - sub_cons = gfc_constructor_next (sub_cons); - continue; - } - - first_image = false; - - if (cmp > 0) - { - gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " - "SUB has %ld and COARRAY lower bound is %ld)", - &coarray->where, d, - mpz_get_si (sub_cons->expr->value.integer), - mpz_get_si (ca_bound->value.integer)); - gfc_free_expr (ca_bound); - return &gfc_bad_expr; - } - - gfc_free_expr (ca_bound); - - /* Check whether upperbound is valid for the multi-images case. */ - if (d < as->corank) - { - ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as, - NULL, true); - if (ca_bound == &gfc_bad_expr) - return ca_bound; - - if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT - && mpz_cmp (ca_bound->value.integer, - sub_cons->expr->value.integer) < 0) - { - gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " - "SUB has %ld and COARRAY upper bound is %ld)", - &coarray->where, d, - mpz_get_si (sub_cons->expr->value.integer), - mpz_get_si (ca_bound->value.integer)); - gfc_free_expr (ca_bound); - return &gfc_bad_expr; - } - - if (ca_bound) - gfc_free_expr (ca_bound); - } - - sub_cons = gfc_constructor_next (sub_cons); - } - - gcc_assert (sub_cons == NULL); - - if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &gfc_current_locus); - if (first_image) - mpz_set_si (result->value.integer, 1); - else - mpz_set_si (result->value.integer, 0); - - return result; -} - - -gfc_expr * -gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) -{ - if (gfc_option.coarray != GFC_FCOARRAY_SINGLE) - return NULL; - - if (coarray == NULL) - { - gfc_expr *result; - /* FIXME: gfc_current_locus is wrong. */ - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &gfc_current_locus); - mpz_set_si (result->value.integer, 1); - return result; - } - - /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */ - return simplify_cobound (coarray, dim, NULL, 0); -} - - -gfc_expr * -gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - return simplify_bound (array, dim, kind, 1); -} - -gfc_expr * -gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - return simplify_cobound (array, dim, kind, 1); -} - - -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_get_array_expr (vector->ts.type, vector->ts.kind, - &vector->where); - if (vector->ts.type == BT_DERIVED) - result->ts.u.derived = vector->ts.u.derived; - result->rank = mask->rank; - result->shape = gfc_copy_shape (mask->shape, mask->rank); - - if (vector->ts.type == BT_CHARACTER) - result->ts.u.cl = vector->ts.u.cl; - - vector_ctor = gfc_constructor_first (vector->value.constructor); - mask_ctor = gfc_constructor_first (mask->value.constructor); - field_ctor - = field->expr_type == EXPR_ARRAY - ? gfc_constructor_first (field->value.constructor) - : NULL; - - while (mask_ctor) - { - if (mask_ctor->expr->value.logical) - { - gcc_assert (vector_ctor); - e = gfc_copy_expr (vector_ctor->expr); - vector_ctor = gfc_constructor_next (vector_ctor); - } - else if (field->expr_type == EXPR_ARRAY) - e = gfc_copy_expr (field_ctor->expr); - else - e = gfc_copy_expr (field); - - gfc_constructor_append_expr (&result->value.constructor, e, NULL); - - mask_ctor = gfc_constructor_next (mask_ctor); - field_ctor = gfc_constructor_next (field_ctor); - } - - return result; -} - - -gfc_expr * -gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) -{ - gfc_expr *result; - int back; - size_t index, len, lenset; - size_t i; - int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind); - - if (k == -1) - return &gfc_bad_expr; - - if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT - || ( b != NULL && b->expr_type != EXPR_CONSTANT)) - return NULL; - - if (b != NULL && b->value.logical != 0) - back = 1; - else - back = 0; - - result = gfc_get_constant_expr (BT_INTEGER, k, &s->where); - - len = s->value.character.length; - lenset = set->value.character.length; - - if (len == 0) - { - mpz_set_ui (result->value.integer, 0); - return result; - } - - if (back == 0) - { - if (lenset == 0) - { - mpz_set_ui (result->value.integer, 1); - return result; - } - - index = wide_strspn (s->value.character.string, - set->value.character.string) + 1; - if (index > len) - index = 0; - - } - else - { - if (lenset == 0) - { - mpz_set_ui (result->value.integer, len); - return result; - } - for (index = len; index > 0; index --) - { - for (i = 0; i < lenset; i++) - { - if (s->value.character.string[index - 1] - == set->value.character.string[i]) - break; - } - if (i == lenset) - break; - } - } - - mpz_set_ui (result->value.integer, index); - return result; -} - - -gfc_expr * -gfc_simplify_xor (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int kind; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - - switch (x->ts.type) - { - case BT_INTEGER: - result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); - mpz_xor (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "XOR"); - - case BT_LOGICAL: - return gfc_get_logical_expr (kind, &x->where, - (x->value.logical && !y->value.logical) - || (!x->value.logical && y->value.logical)); - - default: - gcc_unreachable (); - } -} - - -/****************** Constant simplification *****************/ - -/* Master function to convert one constant to another. While this is - used as a simplification function, it requires the destination type - and kind information which is supplied by a special case in - do_simplify(). */ - -gfc_expr * -gfc_convert_constant (gfc_expr *e, bt type, int kind) -{ - gfc_expr *g, *result, *(*f) (gfc_expr *, int); - gfc_constructor *c; - - switch (e->ts.type) - { - case BT_INTEGER: - switch (type) - { - case BT_INTEGER: - f = gfc_int2int; - break; - case BT_REAL: - f = gfc_int2real; - break; - case BT_COMPLEX: - f = gfc_int2complex; - break; - case BT_LOGICAL: - f = gfc_int2log; - break; - default: - goto oops; - } - break; - - case BT_REAL: - switch (type) - { - case BT_INTEGER: - f = gfc_real2int; - break; - case BT_REAL: - f = gfc_real2real; - break; - case BT_COMPLEX: - f = gfc_real2complex; - break; - default: - goto oops; - } - break; - - case BT_COMPLEX: - switch (type) - { - case BT_INTEGER: - f = gfc_complex2int; - break; - case BT_REAL: - f = gfc_complex2real; - break; - case BT_COMPLEX: - f = gfc_complex2complex; - break; - - default: - goto oops; - } - break; - - case BT_LOGICAL: - switch (type) - { - case BT_INTEGER: - f = gfc_log2int; - break; - case BT_LOGICAL: - f = gfc_log2log; - break; - default: - goto oops; - } - break; - - case BT_HOLLERITH: - switch (type) - { - case BT_INTEGER: - f = gfc_hollerith2int; - break; - - case BT_REAL: - f = gfc_hollerith2real; - break; - - case BT_COMPLEX: - f = gfc_hollerith2complex; - break; - - case BT_CHARACTER: - f = gfc_hollerith2character; - break; - - case BT_LOGICAL: - f = gfc_hollerith2logical; - break; - - default: - goto oops; - } - break; - - default: - oops: - gfc_internal_error ("gfc_convert_constant(): Unexpected type"); - } - - result = NULL; - - switch (e->expr_type) - { - case EXPR_CONSTANT: - result = f (e, kind); - if (result == NULL) - return &gfc_bad_expr; - break; - - case EXPR_ARRAY: - if (!gfc_is_constant_expr (e)) - break; - - result = gfc_get_array_expr (type, kind, &e->where); - result->shape = gfc_copy_shape (e->shape, e->rank); - result->rank = e->rank; - - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - { - gfc_expr *tmp; - if (c->iterator == NULL) - tmp = f (c->expr, kind); - else - { - g = gfc_convert_constant (c->expr, type, kind); - if (g == &gfc_bad_expr) - { - gfc_free_expr (result); - return g; - } - tmp = g; - } - - if (tmp == NULL) - { - gfc_free_expr (result); - return NULL; - } - - gfc_constructor_append_expr (&result->value.constructor, - tmp, &c->where); - } - - break; - - default: - break; - } - - 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_get_constant_expr (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 *c; - - result = gfc_get_array_expr (type, kind, &e->where); - result->shape = gfc_copy_shape (e->shape, e->rank); - result->rank = e->rank; - result->ts.u.cl = e->ts.u.cl; - - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - { - gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind); - if (tmp == &gfc_bad_expr) - { - gfc_free_expr (result); - return &gfc_bad_expr; - } - - if (tmp == NULL) - { - gfc_free_expr (result); - return NULL; - } - - gfc_constructor_append_expr (&result->value.constructor, - tmp, &c->where); - } - - return result; - } - else - return NULL; -} - - -gfc_expr * -gfc_simplify_compiler_options (void) -{ - char *str; - gfc_expr *result; - - str = gfc_get_option_string (); - result = gfc_get_character_expr (gfc_default_character_kind, - &gfc_current_locus, str, strlen (str)); - free (str); - return result; -} - - -gfc_expr * -gfc_simplify_compiler_version (void) -{ - char *buffer; - size_t len; - - len = strlen ("GCC version ") + strlen (version_string); - buffer = XALLOCAVEC (char, len + 1); - snprintf (buffer, len + 1, "GCC version %s", version_string); - return gfc_get_character_expr (gfc_default_character_kind, - &gfc_current_locus, buffer, len); -} |