diff options
Diffstat (limited to 'gcc/fortran/simplify.c')
| -rw-r--r-- | gcc/fortran/simplify.c | 8966 |
1 files changed, 0 insertions, 8966 deletions
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c deleted file mode 100644 index cc7d33a..0000000 --- a/gcc/fortran/simplify.c +++ /dev/null @@ -1,8966 +0,0 @@ -/* Simplify intrinsic functions at compile-time. - Copyright (C) 2000-2022 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 "tm.h" /* For BITS_PER_UNIT. */ -#include "gfortran.h" -#include "arith.h" -#include "intrinsic.h" -#include "match.h" -#include "target-memory.h" -#include "constructor.h" -#include "version.h" /* For version_string. */ - -/* Prototypes. */ - -static int min_max_choose (gfc_expr *, gfc_expr *, int, bool back_val = false); - -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) - || 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 if we - are doing range checking. */ - if (flag_range_check != 0) - 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 if we - are doing range checking. */ - if (flag_range_check != 0) - 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. */ - -void -gfc_convert_mpz_to_signed (mpz_t x, int bitsize) -{ - mpz_t mask; - - /* Confirm that no bits above the unsigned range are set if we are - doing range checking. */ - if (flag_range_check != 0) - 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); - } -} - - -/* Test that the expression is a constant array, simplifying if - we are dealing with a parameter array. */ - -static bool -is_constant_array_expr (gfc_expr *e) -{ - gfc_constructor *c; - bool array_OK = true; - mpz_t size; - - if (e == NULL) - return true; - - if (e->expr_type == EXPR_VARIABLE && e->rank > 0 - && e->symtree->n.sym->attr.flavor == FL_PARAMETER) - gfc_simplify_expr (e, 1); - - 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) - { - array_OK = false; - break; - } - - /* Check and expand the constructor. */ - if (!array_OK && gfc_init_expr_flag && e->rank == 1) - { - array_OK = gfc_reduce_init_expr (e); - /* gfc_reduce_init_expr resets the flag. */ - gfc_init_expr_flag = true; - } - else - return array_OK; - - /* Recheck to make sure that any EXPR_ARRAYs have gone. */ - 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; - - /* Make sure that the array has a valid shape. */ - if (e->shape == NULL && e->rank == 1) - { - if (!gfc_array_size(e, &size)) - return false; - e->shape = gfc_get_shape (1); - mpz_init_set (e->shape[0], size); - mpz_clear (size); - } - - return array_OK; -} - -/* Test for a size zero array. */ -bool -gfc_is_size_zero_array (gfc_expr *array) -{ - - if (array->rank == 0) - return false; - - if (array->expr_type == EXPR_VARIABLE && array->rank > 0 - && array->symtree->n.sym->attr.flavor == FL_PARAMETER - && array->shape != NULL) - { - for (int i = 0; i < array->rank; i++) - if (mpz_cmp_si (array->shape[i], 0) <= 0) - return true; - - return false; - } - - if (array->expr_type == EXPR_ARRAY) - return array->value.constructor == NULL; - - return false; -} - - -/* 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); - HOST_WIDE_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_hwi (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_hwi (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; - if conj_a is true, the matrix_a is complex conjugated. */ - -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, - bool conj_a) -{ - gfc_expr *result, *a, *b, *c; - - /* Set result to an INTEGER(1) 0 for numeric types and .false. for - LOGICAL. Mixed-mode math in the loop will promote result to the - correct type and kind. */ - if (matrix_a->ts.type == BT_LOGICAL) - result = gfc_get_logical_expr (gfc_default_logical_kind, NULL, false); - else - result = gfc_get_int_expr (1, NULL, 0); - result->where = matrix_a->where; - - 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: - if (conj_a && a->ts.type == BT_COMPLEX) - c = gfc_simplify_conjg (a); - else - c = gfc_copy_expr (a); - result = gfc_add (result, gfc_multiply (c, 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)); - if (!result) - return result; - } - - 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 = resultsize <= 0; - 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)); - - if (post_op) - *dest = post_op (*dest, *dest); - - 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) - { - /* If the nested loop is unrolled GFC_MAX_DIMENSIONS - times, we'd warn for the last iteration, because the - array index will have already been incremented to the - array sizes, and we can't tell that this must make - the test against result->rank false, because ranks - must not exceed GFC_MAX_DIMENSIONS. */ - GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) - count[n]++; - base += sstride[n]; - dest += dstride[n]; - GCC_DIAGNOSTIC_POP - } - else - done = true; - } - } - - /* Place updated expression in result constructor. */ - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < resultsize; ++i) - { - 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; - bool size_zero; - - size_zero = gfc_is_size_zero_array (array); - - if (!(is_constant_array_expr (array) || size_zero) - || !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, array); - - if (size_zero) - return result; - - 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 && warn_surprising && mpz_cmp_si (e->value.integer, 127) > 0) - gfc_warning (OPT_Wsurprising, - "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"); -} - - -/* Convert radians to degrees, i.e., x * 180 / pi. */ - -static void -rad2deg (mpfr_t x) -{ - mpfr_t tmp; - - mpfr_init (tmp); - mpfr_const_pi (tmp, GFC_RND_MODE); - mpfr_mul_ui (x, x, 180, GFC_RND_MODE); - mpfr_div (x, x, tmp, GFC_RND_MODE); - mpfr_clear (tmp); -} - - -/* Simplify ACOSD(X) where the returned value has units of degree. */ - -gfc_expr * -gfc_simplify_acosd (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - if (mpfr_cmp_si (x->value.real, 1) > 0 - || mpfr_cmp_si (x->value.real, -1) < 0) - { - gfc_error ("Argument of ACOSD 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); - rad2deg (result->value.real); - - return range_check (result, "ACOSD"); -} - - -/* Simplify asind (x) where the returned value has units of degree. */ - -gfc_expr * -gfc_simplify_asind (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - if (mpfr_cmp_si (x->value.real, 1) > 0 - || mpfr_cmp_si (x->value.real, -1) < 0) - { - gfc_error ("Argument of ASIND 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); - rad2deg (result->value.real); - - return range_check (result, "ASIND"); -} - - -/* Simplify atand (x) where the returned value has units of degree. */ - -gfc_expr * -gfc_simplify_atand (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_atan (result->value.real, x->value.real, GFC_RND_MODE); - rad2deg (result->value.real); - - return range_check (result, "ATAND"); -} - - -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_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) - { - gfc_error ("If first argument of ATAN2 at %L is zero, then the " - "second argument must not be zero", &y->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 && 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 && !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) || 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 (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"); -} - - -/* Simplify atan2d (x) where the unit is degree. */ - -gfc_expr * -gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) - { - gfc_error ("If first argument of ATAN2D at %L is zero, then the " - "second argument must not be zero", &y->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); - rad2deg (result->value.real); - - return range_check (result, "ATAN2D"); -} - - -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"); -} - - -static void -deg2rad (mpfr_t x) -{ - mpfr_t d2r; - - mpfr_init (d2r); - mpfr_const_pi (d2r, GFC_RND_MODE); - mpfr_div_ui (d2r, d2r, 180, GFC_RND_MODE); - mpfr_mul (x, x, d2r, GFC_RND_MODE); - mpfr_clear (d2r); -} - - -/* Simplification routines for SIND, COSD, TAND. */ -#include "trigd_fe.inc" - - -/* Simplify COSD(X) where X has the unit of degree. */ - -gfc_expr * -gfc_simplify_cosd (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_set (result->value.real, x->value.real, GFC_RND_MODE); - simplify_cosd (result->value.real); - - return range_check (result, "COSD"); -} - - -/* Simplify SIND(X) where X has the unit of degree. */ - -gfc_expr * -gfc_simplify_sind (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_set (result->value.real, x->value.real, GFC_RND_MODE); - simplify_sind (result->value.real); - - return range_check (result, "SIND"); -} - - -/* Simplify TAND(X) where X has the unit of degree. */ - -gfc_expr * -gfc_simplify_tand (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_set (result->value.real, x->value.real, GFC_RND_MODE); - simplify_tand (result->value.real); - - return range_check (result, "TAND"); -} - - -/* Simplify COTAND(X) where X has the unit of degree. */ - -gfc_expr * -gfc_simplify_cotand (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - /* Implement COTAND = -TAND(x+90). - TAND offers correct exact values for multiples of 30 degrees. - This implementation is also compatible with the behavior of some legacy - compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */ - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); - mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODE); - simplify_tand (result->value.real); - mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE); - - return range_check (result, "COTAND"); -} - - -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; - bool size_zero; - - size_zero = gfc_is_size_zero_array (mask); - - if (!(is_constant_array_expr (mask) || size_zero) - || !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); - - if (size_zero) - return result; - - /* 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); -} - -/* Simplification routine for cshift. This works by copying the array - expressions into a one-dimensional array, shuffling the values into another - one-dimensional array and creating the new array expression from this. The - shuffling part is basically taken from the library routine. */ - -gfc_expr * -gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) -{ - gfc_expr *result; - int which; - gfc_expr **arrayvec, **resultvec; - gfc_expr **rptr, **sptr; - mpz_t size; - size_t arraysize, shiftsize, i; - gfc_constructor *array_ctor, *shift_ctor; - ssize_t *shiftvec, *hptr; - ssize_t shift_val, len; - ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], - hs_ex[GFC_MAX_DIMENSIONS + 1], - hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS], - a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS], - h_extent[GFC_MAX_DIMENSIONS], - ss_ex[GFC_MAX_DIMENSIONS + 1]; - ssize_t rsoffset; - int d, n; - bool continue_loop; - gfc_expr **src, **dest; - - if (!is_constant_array_expr (array)) - return NULL; - - if (shift->rank > 0) - gfc_simplify_expr (shift, 1); - - if (!gfc_is_constant_expr (shift)) - return NULL; - - /* Make dim zero-based. */ - if (dim) - { - if (!gfc_is_constant_expr (dim)) - return NULL; - which = mpz_get_si (dim->value.integer) - 1; - } - else - which = 0; - - if (array->shape == NULL) - return NULL; - - gfc_array_size (array, &size); - arraysize = mpz_get_ui (size); - mpz_clear (size); - - result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); - result->shape = gfc_copy_shape (array->shape, array->rank); - result->rank = array->rank; - result->ts.u.derived = array->ts.u.derived; - - if (arraysize == 0) - return result; - - arrayvec = XCNEWVEC (gfc_expr *, arraysize); - array_ctor = gfc_constructor_first (array->value.constructor); - for (i = 0; i < arraysize; i++) - { - arrayvec[i] = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - } - - resultvec = XCNEWVEC (gfc_expr *, arraysize); - - extent[0] = 1; - count[0] = 0; - - for (d=0; d < array->rank; d++) - { - a_extent[d] = mpz_get_si (array->shape[d]); - a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; - } - - if (shift->rank > 0) - { - gfc_array_size (shift, &size); - shiftsize = mpz_get_ui (size); - mpz_clear (size); - shiftvec = XCNEWVEC (ssize_t, shiftsize); - shift_ctor = gfc_constructor_first (shift->value.constructor); - for (d = 0; d < shift->rank; d++) - { - h_extent[d] = mpz_get_si (shift->shape[d]); - hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1]; - } - } - else - shiftvec = NULL; - - /* Shut up compiler */ - len = 1; - rsoffset = 1; - - n = 0; - for (d=0; d < array->rank; d++) - { - if (d == which) - { - rsoffset = a_stride[d]; - len = a_extent[d]; - } - else - { - count[n] = 0; - extent[n] = a_extent[d]; - sstride[n] = a_stride[d]; - ss_ex[n] = sstride[n] * extent[n]; - if (shiftvec) - hs_ex[n] = hstride[n] * extent[n]; - n++; - } - } - ss_ex[n] = 0; - hs_ex[n] = 0; - - if (shiftvec) - { - for (i = 0; i < shiftsize; i++) - { - ssize_t val; - val = mpz_get_si (shift_ctor->expr->value.integer); - val = val % len; - if (val < 0) - val += len; - shiftvec[i] = val; - shift_ctor = gfc_constructor_next (shift_ctor); - } - shift_val = 0; - } - else - { - shift_val = mpz_get_si (shift->value.integer); - shift_val = shift_val % len; - if (shift_val < 0) - shift_val += len; - } - - continue_loop = true; - d = array->rank; - rptr = resultvec; - sptr = arrayvec; - hptr = shiftvec; - - while (continue_loop) - { - ssize_t sh; - if (shiftvec) - sh = *hptr; - else - sh = shift_val; - - src = &sptr[sh * rsoffset]; - dest = rptr; - for (n = 0; n < len - sh; n++) - { - *dest = *src; - dest += rsoffset; - src += rsoffset; - } - src = sptr; - for ( n = 0; n < sh; n++) - { - *dest = *src; - dest += rsoffset; - src += rsoffset; - } - rptr += sstride[0]; - sptr += sstride[0]; - if (shiftvec) - hptr += hstride[0]; - count[0]++; - n = 0; - while (count[n] == extent[n]) - { - count[n] = 0; - rptr -= ss_ex[n]; - sptr -= ss_ex[n]; - if (shiftvec) - hptr -= hs_ex[n]; - n++; - if (n >= d - 1) - { - continue_loop = false; - break; - } - else - { - count[n]++; - rptr += sstride[n]; - sptr += sstride[n]; - if (shiftvec) - hptr += hstride[n]; - } - } - } - - for (i = 0; i < arraysize; i++) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (resultvec[i]), - NULL); - } - return result; -} - - -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; - int tmp1, tmp2; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - /* For explicit conversion, turn off -Wconversion and -Wconversion-extra - warnings. */ - tmp1 = warn_conversion; - tmp2 = warn_conversion_extra; - warn_conversion = warn_conversion_extra = 0; - - result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind); - - warn_conversion = tmp1; - warn_conversion_extra = tmp2; - - 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 vector_a is a zero-sized array, the result is 0 for INTEGER, - REAL, and COMPLEX types and .false. for LOGICAL. */ - if (vector_a->shape && mpz_get_si (vector_a->shape[0]) == 0) - { - if (vector_a->ts.type == BT_LOGICAL) - return gfc_get_logical_expr (gfc_default_logical_kind, NULL, false); - else - return gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - } - - if (!is_constant_array_expr (vector_a) - || !is_constant_array_expr (vector_b)) - return NULL; - - return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true); -} - - -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. */ - gfc_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_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, - gfc_expr *dim) -{ - bool temp_boundary; - gfc_expr *bnd; - gfc_expr *result; - int which; - gfc_expr **arrayvec, **resultvec; - gfc_expr **rptr, **sptr; - mpz_t size; - size_t arraysize, i; - gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor; - ssize_t shift_val, len; - ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], - sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS], - a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS + 1]; - ssize_t rsoffset; - int d, n; - bool continue_loop; - gfc_expr **src, **dest; - size_t s_len; - - if (!is_constant_array_expr (array)) - return NULL; - - if (shift->rank > 0) - gfc_simplify_expr (shift, 1); - - if (!gfc_is_constant_expr (shift)) - return NULL; - - if (boundary) - { - if (boundary->rank > 0) - gfc_simplify_expr (boundary, 1); - - if (!gfc_is_constant_expr (boundary)) - return NULL; - } - - if (dim) - { - if (!gfc_is_constant_expr (dim)) - return NULL; - which = mpz_get_si (dim->value.integer) - 1; - } - else - which = 0; - - s_len = 0; - if (boundary == NULL) - { - temp_boundary = true; - switch (array->ts.type) - { - - case BT_INTEGER: - bnd = gfc_get_int_expr (array->ts.kind, NULL, 0); - break; - - case BT_LOGICAL: - bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0); - break; - - case BT_REAL: - bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); - mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE); - break; - - case BT_COMPLEX: - bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); - mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE); - break; - - case BT_CHARACTER: - s_len = mpz_get_ui (array->ts.u.cl->length->value.integer); - bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, s_len); - break; - - default: - gcc_unreachable(); - - } - } - else - { - temp_boundary = false; - bnd = boundary; - } - - gfc_array_size (array, &size); - arraysize = mpz_get_ui (size); - mpz_clear (size); - - result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); - result->shape = gfc_copy_shape (array->shape, array->rank); - result->rank = array->rank; - result->ts = array->ts; - - if (arraysize == 0) - goto final; - - arrayvec = XCNEWVEC (gfc_expr *, arraysize); - array_ctor = gfc_constructor_first (array->value.constructor); - for (i = 0; i < arraysize; i++) - { - arrayvec[i] = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - } - - resultvec = XCNEWVEC (gfc_expr *, arraysize); - - extent[0] = 1; - count[0] = 0; - - for (d=0; d < array->rank; d++) - { - a_extent[d] = mpz_get_si (array->shape[d]); - a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; - } - - if (shift->rank > 0) - { - shift_ctor = gfc_constructor_first (shift->value.constructor); - shift_val = 0; - } - else - { - shift_ctor = NULL; - shift_val = mpz_get_si (shift->value.integer); - } - - if (bnd->rank > 0) - bnd_ctor = gfc_constructor_first (bnd->value.constructor); - else - bnd_ctor = NULL; - - /* Shut up compiler */ - len = 1; - rsoffset = 1; - - n = 0; - for (d=0; d < array->rank; d++) - { - if (d == which) - { - rsoffset = a_stride[d]; - len = a_extent[d]; - } - else - { - count[n] = 0; - extent[n] = a_extent[d]; - sstride[n] = a_stride[d]; - ss_ex[n] = sstride[n] * extent[n]; - n++; - } - } - ss_ex[n] = 0; - - continue_loop = true; - d = array->rank; - rptr = resultvec; - sptr = arrayvec; - - while (continue_loop) - { - ssize_t sh, delta; - - if (shift_ctor) - sh = mpz_get_si (shift_ctor->expr->value.integer); - else - sh = shift_val; - - if (( sh >= 0 ? sh : -sh ) > len) - { - delta = len; - sh = len; - } - else - delta = (sh >= 0) ? sh: -sh; - - if (sh > 0) - { - src = &sptr[delta * rsoffset]; - dest = rptr; - } - else - { - src = sptr; - dest = &rptr[delta * rsoffset]; - } - - for (n = 0; n < len - delta; n++) - { - *dest = *src; - dest += rsoffset; - src += rsoffset; - } - - if (sh < 0) - dest = rptr; - - n = delta; - - if (bnd_ctor) - { - while (n--) - { - *dest = gfc_copy_expr (bnd_ctor->expr); - dest += rsoffset; - } - } - else - { - while (n--) - { - *dest = gfc_copy_expr (bnd); - dest += rsoffset; - } - } - rptr += sstride[0]; - sptr += sstride[0]; - if (shift_ctor) - shift_ctor = gfc_constructor_next (shift_ctor); - - if (bnd_ctor) - bnd_ctor = gfc_constructor_next (bnd_ctor); - - count[0]++; - n = 0; - while (count[n] == extent[n]) - { - count[n] = 0; - rptr -= ss_ex[n]; - sptr -= ss_ex[n]; - n++; - if (n >= d - 1) - { - continue_loop = false; - break; - } - else - { - count[n]++; - rptr += sstride[n]; - sptr += sstride[n]; - } - } - } - - for (i = 0; i < arraysize; i++) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (resultvec[i]), - NULL); - } - - final: - if (temp_boundary) - gfc_free_expr (bnd); - - return result; -} - -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) -{ - mpfr_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; - mpfr_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) -{ - long int val; - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &x->where); - - /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */ - if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real)) - { - int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); - mpz_set (result->value.integer, gfc_integer_kinds[i].huge); - return result; - } - - /* EXPONENT(+/- 0.0) = 0 */ - if (mpfr_zero_p (x->value.real)) - { - mpz_set_ui (result->value.integer, 0); - return result; - } - - gfc_set_model (x->value.real); - - val = (long int) mpfr_get_exp (x->value.real); - mpz_set_si (result->value.integer, val); - - return range_check (result, "EXPONENT"); -} - - -gfc_expr * -gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED, - gfc_expr *kind) -{ - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_current_locus = *gfc_current_intrinsic_where; - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return &gfc_bad_expr; - } - - if (flag_coarray == GFC_FCOARRAY_SINGLE) - { - gfc_expr *result; - int actual_kind; - if (kind) - gfc_extract_int (kind, &actual_kind); - else - actual_kind = gfc_default_integer_kind; - - result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus); - result->rank = 1; - return result; - } - - /* For fcoarray = lib no simplification is possible, because it is not known - what images failed or are stopped at compile time. */ - return NULL; -} - - -gfc_expr * -gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED) -{ - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_current_locus = *gfc_current_intrinsic_where; - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return &gfc_bad_expr; - } - - if (flag_coarray == GFC_FCOARRAY_SINGLE) - { - gfc_expr *result; - result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); - result->rank = 0; - return result; - } - - /* For fcoarray = lib no simplification is possible, because it is not known - what images failed or are stopped at compile time. */ - return NULL; -} - - -gfc_expr * -gfc_simplify_float (gfc_expr *a) -{ - gfc_expr *result; - - if (a->expr_type != EXPR_CONSTANT) - return NULL; - - 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 an extension. */ - 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 - (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) - && !gfc_type_is_extension_of - (a->ts.u.derived->components->ts.u.derived, - mold->ts.u.derived))) - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); - - /* Return .true. if the dynamic type is guaranteed to be an extension. */ - if (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, 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 && gfc_expr_attr (a).class_ok) - || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok)) - && !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; - - mpfr_init2 (floor, mpfr_get_prec (e->value.real)); - 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_exp_t e; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - - /* FRACTION(inf) = NaN. */ - if (mpfr_inf_p (x->value.real)) - { - mpfr_set_nan (result->value.real); - return result; - } - - /* mpfr_frexp() correctly handles zeros and NaNs. */ - mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE); - - 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 (warn_surprising && index > 127) - gfc_warning (OPT_Wsurprising, - "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); - - gfc_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); - - gfc_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); - - gfc_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; - int tmp1, tmp2; - - /* Convert BOZ to integer, and return without range checking. */ - if (e->ts.type == BT_BOZ) - { - if (!gfc_boz2int (e, kind)) - return NULL; - result = gfc_copy_expr (e); - return result; - } - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - /* For explicit conversion, turn off -Wconversion and -Wconversion-extra - warnings. */ - tmp1 = warn_conversion; - tmp2 = warn_conversion_extra; - warn_conversion = warn_conversion_extra = 0; - - result = gfc_convert_constant (e, BT_INTEGER, kind); - - warn_conversion = tmp1; - warn_conversion_extra = tmp2; - - 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); - } - } - - gfc_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 %C"); - else - gfc_error ("Absolute value of SHIFT shall be less than or equal " - "to SIZE at %C"); - 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); - } - } - - gfc_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)) - 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 || flag_coarray == GFC_FCOARRAY_SINGLE))) - { - if (as->lower[d-1] && 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 && !ref->next)) - { - gfc_expr *declared_bound; - int empty_bound; - bool constant_lbound, constant_ubound; - - l = as->lower[d-1]; - u = as->upper[d-1]; - - gcc_assert (l != NULL); - - constant_lbound = l->expr_type == EXPR_CONSTANT; - constant_ubound = u && u->expr_type == EXPR_CONSTANT; - - empty_bound = upper ? 0 : 1; - declared_bound = upper ? u : l; - - if ((!upper && !constant_lbound) - || (upper && !constant_ubound)) - goto returnNull; - - if (!coarray) - { - /* For {L,U}BOUND, the value depends on whether the array - is empty. We can nevertheless simplify if the declared bound - has the same value as that of an empty array, in which case - the result isn't dependent on the array emptyness. */ - if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0) - mpz_set_si (result->value.integer, empty_bound); - else if (!constant_lbound || !constant_ubound) - /* Array emptyness can't be determined, we can't simplify. */ - goto returnNull; - else if (mpz_cmp (l->value.integer, u->value.integer) > 0) - mpz_set_si (result->value.integer, empty_bound); - else - mpz_set (result->value.integer, declared_bound->value.integer); - } - else - mpz_set (result->value.integer, declared_bound->value.integer); - } - else - { - if (upper) - { - int d2 = 0, cnt = 0; - for (int idx = 0; idx < ref->u.ar.dimen; ++idx) - { - if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT) - d2++; - else if (cnt < d - 1) - cnt++; - else - break; - } - if (!gfc_ref_dimen_size (&ref->u.ar, d2 + d - 1, &result->value.integer, NULL)) - 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; - ar_type type = AR_UNKNOWN; - int d; - - if (array->ts.type == BT_CLASS) - return NULL; - - if (array->expr_type != EXPR_VARIABLE) - { - as = NULL; - ref = NULL; - goto done; - } - - /* Do not attempt to resolve if error has already been issued. */ - if (array->symtree->n.sym->error) - return NULL; - - /* Follow any component references. */ - as = array->symtree->n.sym->as; - for (ref = array->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - type = ref->u.ar.type; - 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. */ - goto done; - - 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: - case REF_INQUIRY: - continue; - } - } - - gcc_unreachable (); - - done: - - if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK - || (as->type == AS_ASSUMED_SHAPE && upper))) - return NULL; - - /* 'array' shall not be an unallocated allocatable variable or a pointer that - is not associated. */ - if (array->expr_type == EXPR_VARIABLE - && (gfc_expr_attr (array).allocatable || gfc_expr_attr (array).pointer)) - return NULL; - - gcc_assert (!as - || (as->type != AS_DEFERRED - && array->expr_type == EXPR_VARIABLE - && !gfc_expr_attr (array).allocatable - && !gfc_expr_attr (array).pointer)); - - 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 && type == AR_FULL && 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]); - - if (gfc_seen_div0) - return &gfc_bad_expr; - else - 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. */ - goto done; - - 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: - case REF_INQUIRY: - 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); -} - - -/* Check for constant length of a substring. */ - -static bool -substring_has_constant_len (gfc_expr *e) -{ - gfc_ref *ref; - HOST_WIDE_INT istart, iend, length; - bool equal_length = false; - - if (e->ts.type != BT_CHARACTER) - return false; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY) - break; - - if (!ref - || ref->type != REF_SUBSTRING - || !ref->u.ss.start - || ref->u.ss.start->expr_type != EXPR_CONSTANT - || !ref->u.ss.end - || ref->u.ss.end->expr_type != EXPR_CONSTANT) - return false; - - /* Basic checks on substring starting and ending indices. */ - if (!gfc_resolve_substring (ref, &equal_length)) - return false; - - istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer); - iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer); - - if (istart <= iend) - length = iend - istart + 1; - else - length = 0; - - /* Fix substring length. */ - e->value.character.length = length; - - return true; -} - - -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 - || substring_has_constant_len (e)) - { - 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 if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER - && e->symtree->n.sym - && e->symtree->n.sym->ts.type != BT_DERIVED - && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target - && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED - && e->symtree->n.sym->assoc->target->symtree->n.sym - && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym)) - - /* The expression in assoc->target points to a ref to the _data component - of the unlimited polymorphic entity. To get the _len component the last - _data ref needs to be stripped and a ref to the _len component added. */ - return gfc_get_len_component (e->symtree->n.sym->assoc->target, k); - else - return NULL; -} - - -gfc_expr * -gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) -{ - gfc_expr *result; - size_t 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_zero_p (mpc_realref (x->value.complex)) - && mpfr_zero_p (mpc_imagref (x->value.complex))) - { - 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; - - /* MATMUL should do mixed-mode arithmetic. Set the result type. */ - if (matrix_a->ts.type != matrix_b->ts.type) - { - gfc_expr e; - e.expr_type = EXPR_OP; - gfc_clear_ts (&e.ts); - e.value.op.op = INTRINSIC_NONE; - e.value.op.op1 = matrix_a; - e.value.op.op2 = matrix_b; - gfc_type_convert_binary (&e, 1); - result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where); - } - else - { - 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_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, false); - 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; - - 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); - - bool fail = gfc_extract_int (i, &arg); - gcc_assert (!fail); - - if (!gfc_check_mask (i, kind_arg)) - return &gfc_bad_expr; - - 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); - - gfc_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; - 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); - - bool fail = gfc_extract_int (i, &arg); - gcc_assert (!fail); - - if (!gfc_check_mask (i, kind_arg)) - return &gfc_bad_expr; - - 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); - - gfc_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) -{ - gfc_expr * result; - gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor; - - if (mask->expr_type == EXPR_CONSTANT) - { - result = gfc_copy_expr (mask->value.logical ? tsource : fsource); - /* Parenthesis is needed to get lower bounds of 1. */ - result = gfc_get_parentheses (result); - gfc_simplify_expr (result, 1); - return result; - } - - if (!mask->rank || !is_constant_array_expr (mask) - || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource)) - return NULL; - - result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind, - &tsource->where); - if (tsource->ts.type == BT_DERIVED) - result->ts.u.derived = tsource->ts.u.derived; - else if (tsource->ts.type == BT_CHARACTER) - result->ts.u.cl = tsource->ts.u.cl; - - tsource_ctor = gfc_constructor_first (tsource->value.constructor); - fsource_ctor = gfc_constructor_first (fsource->value.constructor); - 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 (tsource_ctor->expr), - NULL); - else - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (fsource_ctor->expr), - NULL); - tsource_ctor = gfc_constructor_next (tsource_ctor); - fsource_ctor = gfc_constructor_next (fsource_ctor); - mask_ctor = gfc_constructor_next (mask_ctor); - } - - result->shape = gfc_get_shape (1); - gfc_array_size (result, &result->shape[0]); - - return result; -} - - -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 int -min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) -{ - int ret; - - switch (arg->ts.type) - { - case BT_INTEGER: - if (extremum->ts.kind < arg->ts.kind) - extremum->ts.kind = arg->ts.kind; - ret = mpz_cmp (arg->value.integer, - extremum->value.integer) * sign; - if (ret > 0) - mpz_set (extremum->value.integer, arg->value.integer); - break; - - case BT_REAL: - if (extremum->ts.kind < arg->ts.kind) - extremum->ts.kind = arg->ts.kind; - if (mpfr_nan_p (extremum->value.real)) - { - ret = 1; - mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE); - } - else if (mpfr_nan_p (arg->value.real)) - ret = -1; - else - { - ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign; - if (ret > 0) - mpfr_set (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); - } - ret = gfc_compare_string (arg, extremum) * sign; - if (ret > 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"); - } - if (back_val && ret == 0) - ret = 1; - - return ret; -} - - -/* 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) -{ - int tmp1, tmp2; - gfc_actual_arglist *arg, *last, *extremum; - gfc_expr *tmp, *ret; - const char *fname; - - last = NULL; - extremum = NULL; - - 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; - - /* Handle special cases of specific functions (min|max)1 and - a(min|max)0. */ - - tmp = expr->value.function.actual->expr; - fname = expr->value.function.isym->name; - - if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind) - && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0)) - { - /* Explicit conversion, turn off -Wconversion and -Wconversion-extra - warnings. */ - tmp1 = warn_conversion; - tmp2 = warn_conversion_extra; - warn_conversion = warn_conversion_extra = 0; - - ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind); - - warn_conversion = tmp1; - warn_conversion_extra = tmp2; - } - else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind) - && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0)) - { - ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind); - } - else - ret = gfc_copy_expr (tmp); - - return ret; - -} - - -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); -} - -/* Helper function for gfc_simplify_minval. */ - -static gfc_expr * -gfc_min (gfc_expr *op1, gfc_expr *op2) -{ - min_max_choose (op1, op2, -1); - gfc_free_expr (op1); - return op2; -} - -/* Simplify minval for constant arrays. */ - -gfc_expr * -gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, INT_MAX, gfc_min); -} - -/* Helper function for gfc_simplify_maxval. */ - -static gfc_expr * -gfc_max (gfc_expr *op1, gfc_expr *op2) -{ - min_max_choose (op1, op2, 1); - gfc_free_expr (op1); - return op2; -} - - -/* Simplify maxval for constant arrays. */ - -gfc_expr * -gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, INT_MIN, gfc_max); -} - - -/* Transform minloc or maxloc of an array, according to MASK, - to the scalar result. This code is mostly identical to - simplify_transformation_to_scalar. */ - -static gfc_expr * -simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, - gfc_expr *extremum, int sign, bool back_val) -{ - gfc_expr *a, *m; - gfc_constructor *array_ctor, *mask_ctor; - mpz_t count; - - mpz_set_si (result->value.integer, 0); - - - /* 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); - if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = gfc_constructor_first (mask->value.constructor); - else - mask_ctor = NULL; - - mpz_init_set_si (count, 0); - while (array_ctor) - { - mpz_add_ui (count, count, 1); - 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; - } - if (min_max_choose (a, extremum, sign, back_val) > 0) - mpz_set (result->value.integer, count); - } - mpz_clear (count); - gfc_free_expr (extremum); - return result; -} - -/* Simplify minloc / maxloc in the absence of a dim argument. */ - -static gfc_expr * -simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum, - gfc_expr *array, gfc_expr *mask, int sign, - bool back_val) -{ - ssize_t res[GFC_MAX_DIMENSIONS]; - int i, n; - gfc_constructor *result_ctor, *array_ctor, *mask_ctor; - ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], - sstride[GFC_MAX_DIMENSIONS]; - gfc_expr *a, *m; - bool continue_loop; - bool ma; - - for (i = 0; i<array->rank; i++) - res[i] = -1; - - /* Shortcut for constant .FALSE. MASK. */ - if (mask - && mask->expr_type == EXPR_CONSTANT - && !mask->value.logical) - goto finish; - - if (array->shape == NULL) - goto finish; - - for (i = 0; i < array->rank; i++) - { - count[i] = 0; - sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]); - extent[i] = mpz_get_si (array->shape[i]); - if (extent[i] <= 0) - goto finish; - } - - continue_loop = true; - array_ctor = gfc_constructor_first (array->value.constructor); - if (mask && mask->rank > 0) - mask_ctor = gfc_constructor_first (mask->value.constructor); - else - mask_ctor = NULL; - - /* Loop over the array elements (and mask), keeping track of - the indices to return. */ - while (continue_loop) - { - do - { - a = array_ctor->expr; - if (mask_ctor) - { - m = mask_ctor->expr; - ma = m->value.logical; - mask_ctor = gfc_constructor_next (mask_ctor); - } - else - ma = true; - - if (ma && min_max_choose (a, extremum, sign, back_val) > 0) - { - for (i = 0; i<array->rank; i++) - res[i] = count[i]; - } - array_ctor = gfc_constructor_next (array_ctor); - count[0] ++; - } while (count[0] != extent[0]); - n = 0; - do - { - /* When we get to the end of a dimension, reset it and increment - the next dimension. */ - count[n] = 0; - n++; - if (n >= array->rank) - { - continue_loop = false; - break; - } - else - count[n] ++; - } while (count[n] == extent[n]); - } - - finish: - gfc_free_expr (extremum); - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i<array->rank; i++) - { - gfc_expr *r_expr; - r_expr = result_ctor->expr; - mpz_set_si (r_expr->value.integer, res[i] + 1); - result_ctor = gfc_constructor_next (result_ctor); - } - return result; -} - -/* Helper function for gfc_simplify_minmaxloc - build an array - expression with n elements. */ - -static gfc_expr * -new_array (bt type, int kind, int n, locus *where) -{ - gfc_expr *result; - int i; - - result = gfc_get_array_expr (type, kind, where); - result->rank = 1; - result->shape = gfc_get_shape(1); - mpz_init_set_si (result->shape[0], n); - for (i = 0; i < n; i++) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_get_constant_expr (type, kind, where), - NULL); - } - - return result; -} - -/* Simplify minloc and maxloc. This code is mostly identical to - simplify_transformation_to_array. */ - -static gfc_expr * -simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array, - gfc_expr *dim, gfc_expr *mask, - gfc_expr *extremum, int sign, bool back_val) -{ - 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 = resultsize <= 0; - base = arrayvec; - dest = resultvec; - while (!done) - { - gfc_expr *ex; - ex = gfc_copy_expr (extremum); - for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) - { - if (*src && min_max_choose (*src, ex, sign, back_val) > 0) - mpz_set_si ((*dest)->value.integer, n + 1); - } - - count[0]++; - base += sstride[0]; - dest += dstride[0]; - gfc_free_expr (ex); - - 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) - { - /* If the nested loop is unrolled GFC_MAX_DIMENSIONS - times, we'd warn for the last iteration, because the - array index will have already been incremented to the - array sizes, and we can't tell that this must make - the test against result->rank false, because ranks - must not exceed GFC_MAX_DIMENSIONS. */ - GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) - count[n]++; - base += sstride[n]; - dest += dstride[n]; - GCC_DIAGNOSTIC_POP - } - else - done = true; - } - } - - /* Place updated expression in result constructor. */ - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < resultsize; ++i) - { - result_ctor->expr = resultvec[i]; - result_ctor = gfc_constructor_next (result_ctor); - } - - free (arrayvec); - free (resultvec); - free (extremum); - return result; -} - -/* Simplify minloc and maxloc for constant arrays. */ - -static gfc_expr * -gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, - gfc_expr *kind, gfc_expr *back, int sign) -{ - gfc_expr *result; - gfc_expr *extremum; - int ikind; - int init_val; - bool back_val = false; - - 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; - - if (kind) - { - if (gfc_extract_int (kind, &ikind, -1)) - return NULL; - } - else - ikind = gfc_default_integer_kind; - - if (back) - { - if (back->expr_type != EXPR_CONSTANT) - return NULL; - - back_val = back->value.logical; - } - - if (sign < 0) - init_val = INT_MAX; - else if (sign > 0) - init_val = INT_MIN; - else - gcc_unreachable(); - - extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where); - init_result_expr (extremum, init_val, array); - - if (dim) - { - result = transformational_result (array, dim, BT_INTEGER, - ikind, &array->where); - init_result_expr (result, 0, array); - - if (array->rank == 1) - return simplify_minmaxloc_to_scalar (result, array, mask, extremum, - sign, back_val); - else - return simplify_minmaxloc_to_array (result, array, dim, mask, extremum, - sign, back_val); - } - else - { - result = new_array (BT_INTEGER, ikind, array->rank, &array->where); - return simplify_minmaxloc_nodim (result, extremum, array, mask, - sign, back_val); - } -} - -gfc_expr * -gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, - gfc_expr *back) -{ - return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1); -} - -gfc_expr * -gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, - gfc_expr *back) -{ - return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1); -} - -/* Simplify findloc to scalar. Similar to - simplify_minmaxloc_to_scalar. */ - -static gfc_expr * -simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value, - gfc_expr *mask, int back_val) -{ - gfc_expr *a, *m; - gfc_constructor *array_ctor, *mask_ctor; - mpz_t count; - - mpz_set_si (result->value.integer, 0); - - /* 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); - if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = gfc_constructor_first (mask->value.constructor); - else - mask_ctor = NULL; - - mpz_init_set_si (count, 0); - while (array_ctor) - { - mpz_add_ui (count, count, 1); - 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; - } - if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) - { - /* We have a match. If BACK is true, continue so we find - the last one. */ - mpz_set (result->value.integer, count); - if (!back_val) - break; - } - } - mpz_clear (count); - return result; -} - -/* Simplify findloc in the absence of a dim argument. Similar to - simplify_minmaxloc_nodim. */ - -static gfc_expr * -simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array, - gfc_expr *mask, bool back_val) -{ - ssize_t res[GFC_MAX_DIMENSIONS]; - int i, n; - gfc_constructor *result_ctor, *array_ctor, *mask_ctor; - ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], - sstride[GFC_MAX_DIMENSIONS]; - gfc_expr *a, *m; - bool continue_loop; - bool ma; - - for (i = 0; i < array->rank; i++) - res[i] = -1; - - /* Shortcut for constant .FALSE. MASK. */ - if (mask - && mask->expr_type == EXPR_CONSTANT - && !mask->value.logical) - goto finish; - - for (i = 0; i < array->rank; i++) - { - count[i] = 0; - sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]); - extent[i] = mpz_get_si (array->shape[i]); - if (extent[i] <= 0) - goto finish; - } - - continue_loop = true; - array_ctor = gfc_constructor_first (array->value.constructor); - if (mask && mask->rank > 0) - mask_ctor = gfc_constructor_first (mask->value.constructor); - else - mask_ctor = NULL; - - /* Loop over the array elements (and mask), keeping track of - the indices to return. */ - while (continue_loop) - { - do - { - a = array_ctor->expr; - if (mask_ctor) - { - m = mask_ctor->expr; - ma = m->value.logical; - mask_ctor = gfc_constructor_next (mask_ctor); - } - else - ma = true; - - if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) - { - for (i = 0; i < array->rank; i++) - res[i] = count[i]; - if (!back_val) - goto finish; - } - array_ctor = gfc_constructor_next (array_ctor); - count[0] ++; - } while (count[0] != extent[0]); - n = 0; - do - { - /* When we get to the end of a dimension, reset it and increment - the next dimension. */ - count[n] = 0; - n++; - if (n >= array->rank) - { - continue_loop = false; - break; - } - else - count[n] ++; - } while (count[n] == extent[n]); - } - -finish: - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < array->rank; i++) - { - gfc_expr *r_expr; - r_expr = result_ctor->expr; - mpz_set_si (r_expr->value.integer, res[i] + 1); - result_ctor = gfc_constructor_next (result_ctor); - } - return result; -} - - -/* Simplify findloc to an array. Similar to - simplify_minmaxloc_to_array. */ - -static gfc_expr * -simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value, - gfc_expr *dim, gfc_expr *mask, bool back_val) -{ - 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 = resultsize <= 0; - base = arrayvec; - dest = resultvec; - while (!done) - { - for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) - { - if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0) - { - mpz_set_si ((*dest)->value.integer, n + 1); - if (!back_val) - break; - } - } - - 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) - { - /* If the nested loop is unrolled GFC_MAX_DIMENSIONS - times, we'd warn for the last iteration, because the - array index will have already been incremented to the - array sizes, and we can't tell that this must make - the test against result->rank false, because ranks - must not exceed GFC_MAX_DIMENSIONS. */ - GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) - count[n]++; - base += sstride[n]; - dest += dstride[n]; - GCC_DIAGNOSTIC_POP - } - else - done = true; - } - } - - /* Place updated expression in result constructor. */ - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < resultsize; ++i) - { - result_ctor->expr = resultvec[i]; - result_ctor = gfc_constructor_next (result_ctor); - } - - free (arrayvec); - free (resultvec); - return result; -} - -/* Simplify findloc. */ - -gfc_expr * -gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim, - gfc_expr *mask, gfc_expr *kind, gfc_expr *back) -{ - gfc_expr *result; - int ikind; - bool back_val = false; - - if (!is_constant_array_expr (array) - || !gfc_is_constant_expr (dim)) - return NULL; - - if (! gfc_is_constant_expr (value)) - return 0; - - if (mask - && !is_constant_array_expr (mask) - && mask->expr_type != EXPR_CONSTANT) - return NULL; - - if (kind) - { - if (gfc_extract_int (kind, &ikind, -1)) - return NULL; - } - else - ikind = gfc_default_integer_kind; - - if (back) - { - if (back->expr_type != EXPR_CONSTANT) - return NULL; - - back_val = back->value.logical; - } - - if (dim) - { - result = transformational_result (array, dim, BT_INTEGER, - ikind, &array->where); - init_result_expr (result, 0, array); - - if (array->rank == 1) - return simplify_findloc_to_scalar (result, array, value, mask, - back_val); - else - return simplify_findloc_to_array (result, array, value, dim, mask, - back_val); - } - else - { - result = new_array (BT_INTEGER, ikind, array->rank, &array->where); - return simplify_findloc_nodim (result, value, array, mask, back_val); - } - return NULL; -} - -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; - - /* First check p. */ - if (p->expr_type != EXPR_CONSTANT) - return NULL; - - /* p shall not be 0. */ - switch (p->ts.type) - { - case BT_INTEGER: - if (mpz_cmp_ui (p->value.integer, 0) == 0) - { - gfc_error ("Argument %qs of MOD at %L shall not be zero", - "P", &p->where); - return &gfc_bad_expr; - } - break; - case BT_REAL: - if (mpfr_cmp_ui (p->value.real, 0) == 0) - { - gfc_error ("Argument %qs of MOD at %L shall not be zero", - "P", &p->where); - return &gfc_bad_expr; - } - break; - default: - gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); - } - - if (a->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); - - if (a->ts.type == BT_INTEGER) - mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); - else - { - gfc_set_model_kind (kind); - mpfr_fmod (result->value.real, a->value.real, p->value.real, - GFC_RND_MODE); - } - - return range_check (result, "MOD"); -} - - -gfc_expr * -gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) -{ - gfc_expr *result; - int kind; - - /* First check p. */ - if (p->expr_type != EXPR_CONSTANT) - return NULL; - - /* p shall not be 0. */ - switch (p->ts.type) - { - case BT_INTEGER: - if (mpz_cmp_ui (p->value.integer, 0) == 0) - { - gfc_error ("Argument %qs of MODULO at %L shall not be zero", - "P", &p->where); - return &gfc_bad_expr; - } - break; - case BT_REAL: - if (mpfr_cmp_ui (p->value.real, 0) == 0) - { - gfc_error ("Argument %qs of MODULO at %L shall not be zero", - "P", &p->where); - return &gfc_bad_expr; - } - break; - default: - gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); - } - - if (a->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); - - if (a->ts.type == BT_INTEGER) - mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); - else - { - 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); - } - - return range_check (result, "MODULO"); -} - - -gfc_expr * -gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) -{ - gfc_expr *result; - mpfr_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 ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent - - mpfr_get_prec(result->value.real) + 1); - mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent - 1); - mpfr_check_range (result->value.real, 0, MPFR_RNDU); - - if (mpfr_sgn (s->value.real) > 0) - { - mpfr_nextabove (result->value.real); - mpfr_subnormalize (result->value.real, 0, MPFR_RNDU); - } - else - { - mpfr_nextbelow (result->value.real); - mpfr_subnormalize (result->value.real, 0, MPFR_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) && 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 int norm2_scale; - -static gfc_expr * -norm2_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); - int index = gfc_validate_kind (BT_REAL, result->ts.kind, false); - mpfr_exp_t exp; - if (mpfr_regular_p (result->value.real)) - { - exp = mpfr_get_exp (result->value.real); - /* If result is getting close to overflowing, scale down. */ - if (exp >= gfc_real_kinds[index].max_exponent - 4 - && norm2_scale <= gfc_real_kinds[index].max_exponent - 2) - { - norm2_scale += 2; - mpfr_div_ui (result->value.real, result->value.real, 16, - GFC_RND_MODE); - } - } - - mpfr_init (tmp); - if (mpfr_regular_p (e->value.real)) - { - exp = mpfr_get_exp (e->value.real); - /* If e**2 would overflow or close to overflowing, scale down. */ - if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2) - { - int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4; - mpfr_set_ui (tmp, 1, GFC_RND_MODE); - mpfr_set_exp (tmp, new_scale - norm2_scale); - mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE); - mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE); - norm2_scale = new_scale; - } - } - if (norm2_scale) - { - mpfr_set_ui (tmp, 1, GFC_RND_MODE); - mpfr_set_exp (tmp, norm2_scale); - mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE); - } - else - mpfr_set (tmp, e->value.real, GFC_RND_MODE); - mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE); - mpfr_add (result->value.real, result->value.real, tmp, - GFC_RND_MODE); - mpfr_clear (tmp); - - return result; -} - - -static gfc_expr * -norm2_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); - - if (result != e) - mpfr_set (result->value.real, e->value.real, GFC_RND_MODE); - mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); - if (norm2_scale && mpfr_regular_p (result->value.real)) - { - mpfr_t tmp; - mpfr_init (tmp); - mpfr_set_ui (tmp, 1, GFC_RND_MODE); - mpfr_set_exp (tmp, norm2_scale); - mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE); - mpfr_clear (tmp); - } - norm2_scale = 0; - - return result; -} - - -gfc_expr * -gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) -{ - gfc_expr *result; - bool size_zero; - - size_zero = gfc_is_size_zero_array (e); - - if (!(is_constant_array_expr (e) || size_zero) - || (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 (size_zero) - return result; - - norm2_scale = 0; - if (!dim || e->rank == 1) - { - result = simplify_transformation_to_scalar (result, e, NULL, - norm2_add_squared); - mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); - if (norm2_scale && mpfr_regular_p (result->value.real)) - { - mpfr_t tmp; - mpfr_init (tmp); - mpfr_set_ui (tmp, 1, GFC_RND_MODE); - mpfr_set_exp (tmp, norm2_scale); - mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE); - mpfr_clear (tmp); - } - norm2_scale = 0; - } - else - result = simplify_transformation_to_array (result, e, dim, NULL, - norm2_add_squared, - norm2_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 (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) -{ - gfc_expr *result; - - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return &gfc_bad_expr; - } - - if (flag_coarray != GFC_FCOARRAY_SINGLE) - return NULL; - - if (failed && failed->expr_type != EXPR_CONSTANT) - return NULL; - - /* FIXME: gfc_current_locus is wrong. */ - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &gfc_current_locus); - - if (failed && failed->value.logical != 0) - mpz_set_si (result->value.integer, 0); - else - 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_is_contiguous (gfc_expr *array) -{ - if (gfc_is_simply_contiguous (array, false, true)) - return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1); - - if (gfc_is_not_contiguous (array)) - return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0); - - return NULL; -} - - -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; - int i; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - popcnt = gfc_simplify_popcnt (e); - gcc_assert (popcnt); - - bool fail = gfc_extract_int (popcnt, &i); - gcc_assert (!fail); - - 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, tmp1, tmp2; - - /* Convert BOZ to real, and return without range checking. */ - if (e->ts.type == BT_BOZ) - { - /* Determine kind for conversion of the BOZ. */ - if (k) - gfc_extract_int (k, &kind); - else - kind = gfc_default_real_kind; - - if (!gfc_boz2real (e, kind)) - return NULL; - result = gfc_copy_expr (e); - return result; - } - - 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; - - /* For explicit conversion, turn off -Wconversion and -Wconversion-extra - warnings. */ - tmp1 = warn_conversion; - tmp2 = warn_conversion_extra; - warn_conversion = warn_conversion_extra = 0; - - result = gfc_convert_constant (e, BT_REAL, kind); - - warn_conversion = tmp1; - warn_conversion_extra = tmp2; - - 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; - gfc_charlen_t len; - 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 = gfc_mpz_get_hwi (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 (mlen); - gfc_mpz_set_hwi (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; - - HOST_WIDE_INT ncop; - if (len || - (e->ts.u.cl->length && - mpz_sgn (e->ts.u.cl->length->value.integer) != 0)) - { - bool fail = gfc_extract_hwi (n, &ncop); - gcc_assert (!fail); - } - else - ncop = 0; - - if (ncop == 0) - return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); - - len = e->value.character.length; - gfc_charlen_t nlen = ncop * len; - - /* Here's a semi-arbitrary limit. If the string is longer than 1 GB - (2**28 elements * 4 bytes (wide chars) per element) defer to - runtime instead of consuming (unbounded) memory and CPU at - compile time. */ - if (nlen > 268435456) - { - gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L" - " deferred to runtime, expect bugs", &e->where); - return NULL; - } - - result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen); - for (size_t i = 0; i < (size_t) ncop; i++) - for (size_t j = 0; j < (size_t) 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; - bool zerosize = false; - - /* Check that argument expression types are OK. */ - if (!is_constant_array_expr (source) - || !is_constant_array_expr (shape_exp) - || !is_constant_array_expr (pad) - || !is_constant_array_expr (order_exp)) - return NULL; - - if (source->shape == NULL) - return NULL; - - /* Proceed with simplification, unpacking the array. */ - - mpz_init (index); - rank = 0; - - for (i = 0; i < GFC_MAX_DIMENSIONS; i++) - x[i] = 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); - if (shape[rank] < 0) - { - gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a " - "negative value %d for dimension %d", - &shape_exp->where, shape[rank], rank+1); - return &gfc_bad_expr; - } - - 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 - { - mpz_t size; - int order_size, shape_size; - - if (order_exp->rank != shape_exp->rank) - { - gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different", - &order_exp->where, &shape_exp->where); - return &gfc_bad_expr; - } - - gfc_array_size (shape_exp, &size); - shape_size = mpz_get_ui (size); - mpz_clear (size); - gfc_array_size (order_exp, &size); - order_size = mpz_get_ui (size); - mpz_clear (size); - if (order_size != shape_size) - { - gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different", - &order_exp->where, &shape_exp->where); - return &gfc_bad_expr; - } - - 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]); - - if (order[i] < 1 || order[i] > rank) - { - gfc_error ("Element with a value of %d in ORDER at %L must be " - "in the range [1, ..., %d] for the RESHAPE intrinsic " - "near %L", order[i], &order_exp->where, rank, - &shape_exp->where); - return &gfc_bad_expr; - } - - order[i]--; - if (x[order[i]] != 0) - { - gfc_error ("ORDER at %L is not a permutation of the size of " - "SHAPE at %L", &order_exp->where, &shape_exp->where); - return &gfc_bad_expr; - } - 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; - if (source->ts.type == BT_CHARACTER && result->ts.u.cl == NULL) - result->ts = source->ts; - result->rank = rank; - result->shape = gfc_get_shape (rank); - for (i = 0; i < rank; i++) - { - mpz_init_set_ui (result->shape[i], shape[i]); - if (shape[i] == 0) - zerosize = true; - } - - if (zerosize) - goto sizezero; - - 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 - { - if (npad <= 0) - { - mpz_clear (index); - return NULL; - } - 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; - } - -sizezero: - - 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); - - /* RRSPACING(+/- 0.0) = 0.0 */ - if (mpfr_zero_p (x->value.real)) - { - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); - return result; - } - - /* RRSPACING(inf) = NaN */ - if (mpfr_inf_p (x->value.real)) - { - mpfr_set_nan (result->value.real); - return result; - } - - /* RRSPACING(NaN) = same NaN */ - if (mpfr_nan_p (x->value.real)) - { - mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); - return result; - } - - /* | x * 2**(-e) | * 2**p. */ - mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); - 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_zero_p (x->value.real)) - { - 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 - 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)) - 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)) - return NULL; - loc = &p->where; - } - - if (q == NULL) - range = 0; - else - { - if (q->expr_type != EXPR_CONSTANT - || gfc_extract_int (q, &range)) - return NULL; - - if (!loc) - loc = &q->where; - } - - if (rdx == NULL) - radix = 0; - else - { - if (rdx->expr_type != EXPR_CONSTANT - || gfc_extract_int (rdx, &radix)) - 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 (radix == 0 || gfc_real_kinds[i].radix == radix) - found_radix = 1; - - if (gfc_real_kinds[i].precision >= precision - && gfc_real_kinds[i].range >= range - && (radix == 0 || 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); - - /* SET_EXPONENT (+/-0.0, I) = +/- 0.0 - SET_EXPONENT (NaN) = same NaN */ - if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real)) - { - mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); - return result; - } - - /* SET_EXPONENT (inf) = NaN */ - if (mpfr_inf_p (x->value.real)) - { - mpfr_set_nan (result->value.real); - 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; - bool 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); - result->shape = gfc_get_shape (1); - mpz_init (result->shape[0]); - - 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 = true; - for (n = 0; n < source->rank; n++) - { - mpz_init (shape[n]); - mpz_set (shape[n], source->shape[n]); - } - } - else - t = false; - - for (n = 0; n < source->rank; n++) - { - e = gfc_get_constant_expr (BT_INTEGER, k, &source->where); - - if (t) - 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); - - mpz_set_si (result->shape[0], 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; - gfc_ref *ref; - - /* 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; - } - - for (ref = array->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.as) - gfc_resolve_array_spec (ref->u.ar.as, 0); - - if (dim == NULL) - { - if (!gfc_array_size (array, &size)) - 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)) - 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"); -} - - -/* SIZEOF and C_SIZEOF return the size in bytes of an array element - multiplied by the array size. */ - -gfc_expr * -gfc_simplify_sizeof (gfc_expr *x) -{ - gfc_expr *result = NULL; - mpz_t array_size; - size_t res_size; - - if (x->ts.type == BT_CLASS || x->ts.deferred) - return NULL; - - if (x->ts.type == BT_CHARACTER - && (!x->ts.u.cl || !x->ts.u.cl->length - || x->ts.u.cl->length->expr_type != EXPR_CONSTANT)) - return NULL; - - if (x->rank && x->expr_type != EXPR_ARRAY - && !gfc_array_size (x, &array_size)) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, - &x->where); - gfc_target_expr_size (x, &res_size); - mpz_set_si (result->value.integer, res_size); - - return result; -} - - -/* STORAGE_SIZE returns the size in bits of a single array element. */ - -gfc_expr * -gfc_simplify_storage_size (gfc_expr *x, - gfc_expr *kind) -{ - gfc_expr *result = NULL; - int k; - size_t siz; - - if (x->ts.type == BT_CLASS || x->ts.deferred) - return NULL; - - if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT - && (!x->ts.u.cl || !x->ts.u.cl->length - || x->ts.u.cl->length->expr_type != EXPR_CONSTANT)) - return NULL; - - k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); - - gfc_element_size (x, &siz); - mpz_set_si (result->value.integer, siz); - mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT); - - return range_check (result, "STORAGE_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 (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; - int tmp1, tmp2; - - if (a->expr_type != EXPR_CONSTANT) - return NULL; - - /* For explicit conversion, turn off -Wconversion and -Wconversion-extra - warnings. */ - tmp1 = warn_conversion; - tmp2 = warn_conversion_extra; - warn_conversion = warn_conversion_extra = 0; - - result = gfc_real2real (a, gfc_default_real_kind); - - warn_conversion = tmp1; - warn_conversion_extra = tmp2; - - 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); - - /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */ - if (mpfr_zero_p (x->value.real)) - { - mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); - return result; - } - - /* SPACING(inf) = NaN */ - if (mpfr_inf_p (x->value.real)) - { - mpfr_set_nan (result->value.real); - return result; - } - - /* SPACING(NaN) = same NaN */ - if (mpfr_nan_p (x->value.real)) - { - mpfr_set (result->value.real, x->value.real, 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 = NULL; - int nelem, 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)) - gfc_internal_error ("Failure getting length of a constant array."); - } - else - mpz_init_set_ui (size, 1); - - nelem = mpz_get_si (size) * ncopies; - if (nelem > flag_max_array_constructor) - { - if (gfc_init_expr_flag) - { - gfc_error ("The number of elements (%d) in the array constructor " - "at %L requires an increase of the allowed %d upper " - "limit. See %<-fmax-array-constructor%> option.", - nelem, &source->where, flag_max_array_constructor); - return &gfc_bad_expr; - } - else - return NULL; - } - - if (source->expr_type == EXPR_CONSTANT - || source->expr_type == EXPR_STRUCTURE) - { - 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 - { - gfc_error ("Simplification of SPREAD at %C not yet implemented"); - return &gfc_bad_expr; - } - - 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); -} - - -/* Simplify COTAN(X) where X has the unit of radian. */ - -gfc_expr * -gfc_simplify_cotan (gfc_expr *x) -{ - gfc_expr *result; - mpc_t swp, *val; - - 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_cot (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - /* There is no builtin mpc_cot, so compute cot = cos / sin. */ - val = &result->value.complex; - mpc_init2 (swp, mpfr_get_default_prec ()); - mpc_sin_cos (*val, swp, x->value.complex, GFC_MPC_RND_MODE, - GFC_MPC_RND_MODE); - mpc_div (*val, swp, *val, GFC_MPC_RND_MODE); - mpc_clear (swp); - break; - - default: - gcc_unreachable (); - } - - return range_check (result, "COTAN"); -} - - -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_is_constant_expr (size)) - return NULL; - - if (!gfc_resolve_expr (mold)) - return NULL; - if (gfc_init_expr_flag && !gfc_is_constant_expr (mold)) - return NULL; - - if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, - &result_size, &result_length)) - return NULL; - - /* Calculate the size of the source. */ - if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp)) - 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 && mold->value.constructor) - ? 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); - - if (matrix->shape == NULL) - return NULL; - - result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind, - &matrix->where); - result->rank = 2; - result->shape = gfc_get_shape (result->rank); - mpz_init_set (result->shape[0], matrix->shape[1]); - mpz_init_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 (flag_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_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED) -{ - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_current_locus = *gfc_current_intrinsic_where; - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return &gfc_bad_expr; - } - - /* Simplification is possible for fcoarray = single only. For all other modes - the result depends on runtime conditions. */ - if (flag_coarray != GFC_FCOARRAY_SINGLE) - return NULL; - - if (gfc_is_constant_expr (image)) - { - gfc_expr *result; - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &image->where); - if (mpz_get_si (image->value.integer) == 1) - mpz_set_si (result->value.integer, 0); - else - mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE); - return result; - } - else - return NULL; -} - - -gfc_expr * -gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim, - gfc_expr *distance ATTRIBUTE_UNUSED) -{ - if (flag_coarray != GFC_FCOARRAY_SINGLE) - return NULL; - - /* If no coarray argument has been passed or when the first argument - is actually a distance argment. */ - if (coarray == NULL || !gfc_is_coarray (coarray)) - { - 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 *result, *(*f) (gfc_expr *, int); - gfc_constructor *c, *t; - - 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; - - case BT_CHARACTER: - switch (type) - { - case BT_INTEGER: - f = gfc_character2int; - break; - - case BT_REAL: - f = gfc_character2real; - break; - - case BT_COMPLEX: - f = gfc_character2complex; - break; - - case BT_CHARACTER: - f = gfc_character2character; - break; - - case BT_LOGICAL: - f = gfc_character2logical; - break; - - default: - goto oops; - } - break; - - default: - oops: - return &gfc_bad_expr; - } - - 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) - { - if (c->expr->expr_type == EXPR_ARRAY) - tmp = gfc_convert_constant (c->expr, type, kind); - else if (c->expr->expr_type == EXPR_OP) - { - if (!gfc_simplify_expr (c->expr, 1)) - return &gfc_bad_expr; - tmp = f (c->expr, kind); - } - else - tmp = f (c->expr, kind); - } - else - tmp = gfc_convert_constant (c->expr, type, kind); - - if (tmp == NULL || tmp == &gfc_bad_expr) - { - gfc_free_expr (result); - return NULL; - } - - t = gfc_constructor_append_expr (&result->value.constructor, - tmp, &c->where); - if (c->iterator) - t->iterator = gfc_copy_iterator (c->iterator); - } - - 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 %qs in string at %L cannot be converted " - "into character kind %d", - gfc_print_wide_char (result->value.character.string[i]), - &e->where, kind); - gfc_free_expr (result); - 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); -} - -/* Simplification routines for intrinsics of IEEE modules. */ - -gfc_expr * -simplify_ieee_selected_real_kind (gfc_expr *expr) -{ - gfc_actual_arglist *arg; - gfc_expr *p = NULL, *q = NULL, *rdx = NULL; - - arg = expr->value.function.actual; - p = arg->expr; - if (arg->next) - { - q = arg->next->expr; - if (arg->next->next) - rdx = arg->next->next->expr; - } - - /* Currently, if IEEE is supported and this module is built, it means - all our floating-point types conform to IEEE. Hence, we simply handle - IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */ - return gfc_simplify_selected_real_kind (p, q, rdx); -} - -gfc_expr * -simplify_ieee_support (gfc_expr *expr) -{ - /* We consider that if the IEEE modules are loaded, we have full support - for flags, halting and rounding, which are the three functions - (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant - expressions. One day, we will need libgfortran to detect support and - communicate it back to us, allowing for partial support. */ - - return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where, - true); -} - -bool -matches_ieee_function_name (gfc_symbol *sym, const char *name) -{ - int n = strlen(name); - - if (!strncmp(sym->name, name, n)) - return true; - - /* If a generic was used and renamed, we need more work to find out. - Compare the specific name. */ - if (sym->generic && !strncmp(sym->generic->sym->name, name, n)) - return true; - - return false; -} - -gfc_expr * -gfc_simplify_ieee_functions (gfc_expr *expr) -{ - gfc_symbol* sym = expr->symtree->n.sym; - - if (matches_ieee_function_name(sym, "ieee_selected_real_kind")) - return simplify_ieee_selected_real_kind (expr); - else if (matches_ieee_function_name(sym, "ieee_support_flag") - || matches_ieee_function_name(sym, "ieee_support_halting") - || matches_ieee_function_name(sym, "ieee_support_rounding")) - return simplify_ieee_support (expr); - else - return NULL; -} |