From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/fortran/simplify.c | 6858 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 6858 insertions(+) create mode 100644 gcc/fortran/simplify.c (limited to 'gcc/fortran/simplify.c') diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c new file mode 100644 index 000000000..57ffa1b82 --- /dev/null +++ b/gcc/fortran/simplify.c @@ -0,0 +1,6858 @@ +/* Simplify intrinsic functions at compile-time. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, + 2010, 2011 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 +. */ + +#include "config.h" +#include "system.h" +#include "flags.h" +#include "gfortran.h" +#include "arith.h" +#include "intrinsic.h" +#include "target-memory.h" +#include "constructor.h" +#include "version.h" /* For version_string. */ + + +gfc_expr gfc_bad_expr; + + +/* Note that 'simplification' is not just transforming expressions. + For functions that are not simplified at compile time, range + checking is done if possible. + + The return convention is that each simplification function returns: + + A new expression node corresponding to the simplified arguments. + The original arguments are destroyed by the caller, and must not + be a part of the new expression. + + NULL pointer indicating that no simplification was possible and + the original expression should remain intact. + + An expression pointer to gfc_bad_expr (a static placeholder) + indicating that some error has prevented simplification. The + error is generated within the function and should be propagated + upwards + + By the time a simplification function gets control, it has been + decided that the function call is really supposed to be the + intrinsic. No type checking is strictly necessary, since only + valid types will be passed on. On the other hand, a simplification + subroutine may have to look at the type of an argument as part of + its processing. + + Array arguments are only passed to these subroutines that implement + the simplification of transformational intrinsics. + + The functions in this file don't have much comment with them, but + everything is reasonably straight-forward. The Standard, chapter 13 + is the best comment you'll find for this file anyway. */ + +/* Range checks an expression node. If all goes well, returns the + node, otherwise returns &gfc_bad_expr and frees the node. */ + +static gfc_expr * +range_check (gfc_expr *result, const char *name) +{ + if (result == NULL) + return &gfc_bad_expr; + + if (result->expr_type != EXPR_CONSTANT) + return result; + + switch (gfc_range_check (result)) + { + case ARITH_OK: + return result; + + case ARITH_OVERFLOW: + gfc_error ("Result of %s overflows its kind at %L", name, + &result->where); + break; + + case ARITH_UNDERFLOW: + gfc_error ("Result of %s underflows its kind at %L", name, + &result->where); + break; + + case ARITH_NAN: + gfc_error ("Result of %s is NaN at %L", name, &result->where); + break; + + default: + gfc_error ("Result of %s gives range error for its kind at %L", name, + &result->where); + break; + } + + gfc_free_expr (result); + return &gfc_bad_expr; +} + + +/* A helper function that gets an optional and possibly missing + kind parameter. Returns the kind, -1 if something went wrong. */ + +static int +get_kind (bt type, gfc_expr *k, const char *name, int default_kind) +{ + int kind; + + if (k == NULL) + return default_kind; + + if (k->expr_type != EXPR_CONSTANT) + { + gfc_error ("KIND parameter of %s at %L must be an initialization " + "expression", name, &k->where); + return -1; + } + + if (gfc_extract_int (k, &kind) != NULL + || gfc_validate_kind (type, kind, true) < 0) + { + gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where); + return -1; + } + + return kind; +} + + +/* Converts an mpz_t signed variable into an unsigned one, assuming + two's complement representations and a binary width of bitsize. + The conversion is a no-op unless x is negative; otherwise, it can + be accomplished by masking out the high bits. */ + +static void +convert_mpz_to_unsigned (mpz_t x, int bitsize) +{ + mpz_t mask; + + if (mpz_sgn (x) < 0) + { + /* Confirm that no bits above the signed range are unset. */ + gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX); + + mpz_init_set_ui (mask, 1); + mpz_mul_2exp (mask, mask, bitsize); + mpz_sub_ui (mask, mask, 1); + + mpz_and (x, x, mask); + + mpz_clear (mask); + } + else + { + /* Confirm that no bits above the signed range are set. */ + gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX); + } +} + + +/* Converts an mpz_t unsigned variable into a signed one, assuming + two's complement representations and a binary width of bitsize. + If the bitsize-1 bit is set, this is taken as a sign bit and + the number is converted to the corresponding negative number. */ + +static void +convert_mpz_to_signed (mpz_t x, int bitsize) +{ + mpz_t mask; + + /* Confirm that no bits above the unsigned range are set. */ + gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX); + + if (mpz_tstbit (x, bitsize - 1) == 1) + { + mpz_init_set_ui (mask, 1); + mpz_mul_2exp (mask, mask, bitsize); + mpz_sub_ui (mask, mask, 1); + + /* We negate the number by hand, zeroing the high bits, that is + make it the corresponding positive number, and then have it + negated by GMP, giving the correct representation of the + negative number. */ + mpz_com (x, x); + mpz_add_ui (x, x, 1); + mpz_and (x, x, mask); + + mpz_neg (x, x); + + mpz_clear (mask); + } +} + + +/* In-place convert BOZ to REAL of the specified kind. */ + +static gfc_expr * +convert_boz (gfc_expr *x, int kind) +{ + if (x && x->ts.type == BT_INTEGER && x->is_boz) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_REAL; + ts.kind = kind; + + if (!gfc_convert_boz (x, &ts)) + return &gfc_bad_expr; + } + + return x; +} + + +/* Test that the expression is an constant array. */ + +static bool +is_constant_array_expr (gfc_expr *e) +{ + gfc_constructor *c; + + if (e == NULL) + return true; + + if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) + return false; + + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + if (c->expr->expr_type != EXPR_CONSTANT + && c->expr->expr_type != EXPR_STRUCTURE) + return false; + + return true; +} + + +/* Initialize a transformational result expression with a given value. */ + +static void +init_result_expr (gfc_expr *e, int init, gfc_expr *array) +{ + if (e && e->expr_type == EXPR_ARRAY) + { + gfc_constructor *ctor = gfc_constructor_first (e->value.constructor); + while (ctor) + { + init_result_expr (ctor->expr, init, array); + ctor = gfc_constructor_next (ctor); + } + } + else if (e && e->expr_type == EXPR_CONSTANT) + { + int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + int length; + gfc_char_t *string; + + switch (e->ts.type) + { + case BT_LOGICAL: + e->value.logical = (init ? 1 : 0); + break; + + case BT_INTEGER: + if (init == INT_MIN) + mpz_set (e->value.integer, gfc_integer_kinds[i].min_int); + else if (init == INT_MAX) + mpz_set (e->value.integer, gfc_integer_kinds[i].huge); + else + mpz_set_si (e->value.integer, init); + break; + + case BT_REAL: + if (init == INT_MIN) + { + mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); + mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE); + } + else if (init == INT_MAX) + mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); + else + mpfr_set_si (e->value.real, init, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE); + break; + + case BT_CHARACTER: + if (init == INT_MIN) + { + gfc_expr *len = gfc_simplify_len (array, NULL); + gfc_extract_int (len, &length); + string = gfc_get_wide_string (length + 1); + gfc_wide_memset (string, 0, length); + } + else if (init == INT_MAX) + { + gfc_expr *len = gfc_simplify_len (array, NULL); + gfc_extract_int (len, &length); + string = gfc_get_wide_string (length + 1); + gfc_wide_memset (string, 255, length); + } + else + { + length = 0; + string = gfc_get_wide_string (1); + } + + string[length] = '\0'; + e->value.character.length = length; + e->value.character.string = string; + break; + + default: + gcc_unreachable(); + } + } + else + gcc_unreachable(); +} + + +/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */ + +static gfc_expr * +compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a, + gfc_expr *matrix_b, int stride_b, int offset_b) +{ + gfc_expr *result, *a, *b; + + result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind, + &matrix_a->where); + init_result_expr (result, 0, NULL); + + a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); + b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); + while (a && b) + { + /* Copying of expressions is required as operands are free'd + by the gfc_arith routines. */ + switch (result->ts.type) + { + case BT_LOGICAL: + result = gfc_or (result, + gfc_and (gfc_copy_expr (a), + gfc_copy_expr (b))); + break; + + case BT_INTEGER: + case BT_REAL: + case BT_COMPLEX: + result = gfc_add (result, + gfc_multiply (gfc_copy_expr (a), + gfc_copy_expr (b))); + break; + + default: + gcc_unreachable(); + } + + offset_a += stride_a; + a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); + + offset_b += stride_b; + b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); + } + + return result; +} + + +/* Build a result expression for transformational intrinsics, + depending on DIM. */ + +static gfc_expr * +transformational_result (gfc_expr *array, gfc_expr *dim, bt type, + int kind, locus* where) +{ + gfc_expr *result; + int i, nelem; + + if (!dim || array->rank == 1) + return gfc_get_constant_expr (type, kind, where); + + result = gfc_get_array_expr (type, kind, where); + result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); + result->rank = array->rank - 1; + + /* gfc_array_size() would count the number of elements in the constructor, + we have not built those yet. */ + nelem = 1; + for (i = 0; i < result->rank; ++i) + nelem *= mpz_get_ui (result->shape[i]); + + for (i = 0; i < nelem; ++i) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_get_constant_expr (type, kind, where), + NULL); + } + + return result; +} + + +typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*); + +/* Wrapper function, implements 'op1 += 1'. Only called if MASK + of COUNT intrinsic is .TRUE.. + + Interface and implimentation mimics arith functions as + gfc_add, gfc_multiply, etc. */ + +static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr *result; + + gcc_assert (op1->ts.type == BT_INTEGER); + gcc_assert (op2->ts.type == BT_LOGICAL); + gcc_assert (op2->value.logical); + + result = gfc_copy_expr (op1); + mpz_add_ui (result->value.integer, result->value.integer, 1); + + gfc_free_expr (op1); + gfc_free_expr (op2); + return result; +} + + +/* Transforms an ARRAY with operation OP, according to MASK, to a + scalar RESULT. E.g. called if + + REAL, PARAMETER :: array(n, m) = ... + REAL, PARAMETER :: s = SUM(array) + + where OP == gfc_add(). */ + +static gfc_expr * +simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, + transformational_op op) +{ + gfc_expr *a, *m; + gfc_constructor *array_ctor, *mask_ctor; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + array_ctor = gfc_constructor_first (array->value.constructor); + mask_ctor = NULL; + if (mask && mask->expr_type == EXPR_ARRAY) + mask_ctor = gfc_constructor_first (mask->value.constructor); + + while (array_ctor) + { + a = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + + /* A constant MASK equals .TRUE. here and can be ignored. */ + if (mask_ctor) + { + m = mask_ctor->expr; + mask_ctor = gfc_constructor_next (mask_ctor); + if (!m->value.logical) + continue; + } + + result = op (result, gfc_copy_expr (a)); + } + + return result; +} + +/* Transforms an ARRAY with operation OP, according to MASK, to an + array RESULT. E.g. called if + + REAL, PARAMETER :: array(n, m) = ... + REAL, PARAMETER :: s(n) = PROD(array, DIM=1) + + where OP == gfc_multiply(). The result might be post processed using post_op. */ + +static gfc_expr * +simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask, transformational_op op, + transformational_op post_op) +{ + mpz_t size; + int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; + gfc_expr **arrayvec, **resultvec, **base, **src, **dest; + gfc_constructor *array_ctor, *mask_ctor, *result_ctor; + + int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], + tmpstride[GFC_MAX_DIMENSIONS]; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + /* Build an indexed table for array element expressions to minimize + linked-list traversal. Masked elements are set to NULL. */ + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + + arrayvec = (gfc_expr**) gfc_getmem (sizeof (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 = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize); + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; i < resultsize; ++i) + { + resultvec[i] = result_ctor->expr; + result_ctor = gfc_constructor_next (result_ctor); + } + + gfc_extract_int (dim, &dim_index); + dim_index -= 1; /* zero-base index */ + dim_extent = 0; + dim_stride = 0; + + for (i = 0, n = 0; i < array->rank; ++i) + { + count[i] = 0; + tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); + if (i == dim_index) + { + dim_extent = mpz_get_si (array->shape[i]); + dim_stride = tmpstride[i]; + continue; + } + + extent[n] = mpz_get_si (array->shape[i]); + sstride[n] = tmpstride[i]; + dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; + n += 1; + } + + done = false; + base = arrayvec; + dest = resultvec; + while (!done) + { + for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) + if (*src) + *dest = op (*dest, gfc_copy_expr (*src)); + + count[0]++; + base += sstride[0]; + dest += dstride[0]; + + n = 0; + while (!done && count[n] == extent[n]) + { + count[n] = 0; + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + + n++; + if (n < result->rank) + { + count [n]++; + base += sstride[n]; + dest += dstride[n]; + } + else + done = true; + } + } + + /* Place updated expression in result constructor. */ + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; i < resultsize; ++i) + { + if (post_op) + result_ctor->expr = post_op (result_ctor->expr, resultvec[i]); + else + result_ctor->expr = resultvec[i]; + result_ctor = gfc_constructor_next (result_ctor); + } + + gfc_free (arrayvec); + gfc_free (resultvec); + return result; +} + + +static gfc_expr * +simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, + int init_val, transformational_op op) +{ + gfc_expr *result; + + if (!is_constant_array_expr (array) + || !gfc_is_constant_expr (dim)) + return NULL; + + if (mask + && !is_constant_array_expr (mask) + && mask->expr_type != EXPR_CONSTANT) + return NULL; + + result = transformational_result (array, dim, array->ts.type, + array->ts.kind, &array->where); + init_result_expr (result, init_val, NULL); + + return !dim || array->rank == 1 ? + simplify_transformation_to_scalar (result, array, mask, op) : + simplify_transformation_to_array (result, array, dim, mask, op, NULL); +} + + +/********************** Simplification functions *****************************/ + +gfc_expr * +gfc_simplify_abs (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + switch (e->ts.type) + { + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where); + mpz_abs (result->value.integer, e->value.integer); + return range_check (result, "IABS"); + + case BT_REAL: + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE); + return range_check (result, "ABS"); + + case BT_COMPLEX: + gfc_set_model_kind (e->ts.kind); + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE); + return range_check (result, "CABS"); + + default: + gfc_internal_error ("gfc_simplify_abs(): Bad type"); + } +} + + +static gfc_expr * +simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii) +{ + gfc_expr *result; + int kind; + bool too_large = false; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind); + if (kind == -1) + return &gfc_bad_expr; + + if (mpz_cmp_si (e->value.integer, 0) < 0) + { + gfc_error ("Argument of %s function at %L is negative", name, + &e->where); + return &gfc_bad_expr; + } + + if (ascii && gfc_option.warn_surprising + && mpz_cmp_si (e->value.integer, 127) > 0) + gfc_warning ("Argument of %s function at %L outside of range [0,127]", + name, &e->where); + + if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0) + too_large = true; + else if (kind == 4) + { + mpz_t t; + mpz_init_set_ui (t, 2); + mpz_pow_ui (t, t, 32); + mpz_sub_ui (t, t, 1); + if (mpz_cmp (e->value.integer, t) > 0) + too_large = true; + mpz_clear (t); + } + + if (too_large) + { + gfc_error ("Argument of %s function at %L is too large for the " + "collating sequence of kind %d", name, &e->where, kind); + return &gfc_bad_expr; + } + + result = gfc_get_character_expr (kind, &e->where, NULL, 1); + result->value.character.string[0] = mpz_get_ui (e->value.integer); + + return result; +} + + + +/* We use the processor's collating sequence, because all + systems that gfortran currently works on are ASCII. */ + +gfc_expr * +gfc_simplify_achar (gfc_expr *e, gfc_expr *k) +{ + return simplify_achar_char (e, k, "ACHAR", true); +} + + +gfc_expr * +gfc_simplify_acos (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + switch (x->ts.type) + { + case BT_REAL: + if (mpfr_cmp_si (x->value.real, 1) > 0 + || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ("Argument of ACOS at %L must be between -1 and 1", + &x->where); + return &gfc_bad_expr; + } + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_acos(): Bad type"); + } + + return range_check (result, "ACOS"); +} + +gfc_expr * +gfc_simplify_acosh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + switch (x->ts.type) + { + case BT_REAL: + if (mpfr_cmp_si (x->value.real, 1) < 0) + { + gfc_error ("Argument of ACOSH at %L must not be less than 1", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_acosh(): Bad type"); + } + + return range_check (result, "ACOSH"); +} + +gfc_expr * +gfc_simplify_adjustl (gfc_expr *e) +{ + gfc_expr *result; + int count, i, len; + gfc_char_t ch; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + len = e->value.character.length; + + for (count = 0, i = 0; i < len; ++i) + { + ch = e->value.character.string[i]; + if (ch != ' ') + break; + ++count; + } + + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); + for (i = 0; i < len - count; ++i) + result->value.character.string[i] = e->value.character.string[count + i]; + + return result; +} + + +gfc_expr * +gfc_simplify_adjustr (gfc_expr *e) +{ + gfc_expr *result; + int count, i, len; + gfc_char_t ch; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + len = e->value.character.length; + + for (count = 0, i = len - 1; i >= 0; --i) + { + ch = e->value.character.string[i]; + if (ch != ' ') + break; + ++count; + } + + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); + for (i = 0; i < count; ++i) + result->value.character.string[i] = ' '; + + for (i = count; i < len; ++i) + result->value.character.string[i] = e->value.character.string[i - count]; + + return result; +} + + +gfc_expr * +gfc_simplify_aimag (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE); + + return range_check (result, "AIMAG"); +} + + +gfc_expr * +gfc_simplify_aint (gfc_expr *e, gfc_expr *k) +{ + gfc_expr *rtrunc, *result; + int kind; + + kind = get_kind (BT_REAL, k, "AINT", e->ts.kind); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + rtrunc = gfc_copy_expr (e); + mpfr_trunc (rtrunc->value.real, e->value.real); + + result = gfc_real2real (rtrunc, kind); + + gfc_free_expr (rtrunc); + + return range_check (result, "AINT"); +} + + +gfc_expr * +gfc_simplify_all (gfc_expr *mask, gfc_expr *dim) +{ + return simplify_transformation (mask, dim, NULL, true, gfc_and); +} + + +gfc_expr * +gfc_simplify_dint (gfc_expr *e) +{ + gfc_expr *rtrunc, *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + rtrunc = gfc_copy_expr (e); + mpfr_trunc (rtrunc->value.real, e->value.real); + + result = gfc_real2real (rtrunc, gfc_default_double_kind); + + gfc_free_expr (rtrunc); + + return range_check (result, "DINT"); +} + + +gfc_expr * +gfc_simplify_anint (gfc_expr *e, gfc_expr *k) +{ + gfc_expr *result; + int kind; + + kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (e->ts.type, kind, &e->where); + mpfr_round (result->value.real, e->value.real); + + return range_check (result, "ANINT"); +} + + +gfc_expr * +gfc_simplify_and (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int kind; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; + + switch (x->ts.type) + { + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); + mpz_and (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "AND"); + + case BT_LOGICAL: + return gfc_get_logical_expr (kind, &x->where, + x->value.logical && y->value.logical); + + default: + gcc_unreachable (); + } +} + + +gfc_expr * +gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) +{ + return simplify_transformation (mask, dim, NULL, false, gfc_or); +} + + +gfc_expr * +gfc_simplify_dnint (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where); + mpfr_round (result->value.real, e->value.real); + + return range_check (result, "DNINT"); +} + + +gfc_expr * +gfc_simplify_asin (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + switch (x->ts.type) + { + case BT_REAL: + if (mpfr_cmp_si (x->value.real, 1) > 0 + || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ("Argument of ASIN at %L must be between -1 and 1", + &x->where); + return &gfc_bad_expr; + } + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_asin(): Bad type"); + } + + return range_check (result, "ASIN"); +} + + +gfc_expr * +gfc_simplify_asinh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_asinh(): Bad type"); + } + + return range_check (result, "ASINH"); +} + + +gfc_expr * +gfc_simplify_atan (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_atan(): Bad type"); + } + + return range_check (result, "ATAN"); +} + + +gfc_expr * +gfc_simplify_atanh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + switch (x->ts.type) + { + case BT_REAL: + if (mpfr_cmp_si (x->value.real, 1) >= 0 + || mpfr_cmp_si (x->value.real, -1) <= 0) + { + gfc_error ("Argument of ATANH at %L must be inside the range -1 " + "to 1", &x->where); + return &gfc_bad_expr; + } + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_atanh(): Bad type"); + } + + return range_check (result, "ATANH"); +} + + +gfc_expr * +gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0) + { + gfc_error ("If first argument of ATAN2 %L is zero, then the " + "second argument must not be zero", &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "ATAN2"); +} + + +gfc_expr * +gfc_simplify_bessel_j0 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_J0"); +} + + +gfc_expr * +gfc_simplify_bessel_j1 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_J1"); +} + + +gfc_expr * +gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x) +{ + gfc_expr *result; + long n; + + if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) + return NULL; + + n = mpz_get_si (order->value.integer); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_JN"); +} + + +/* Simplify transformational form of JN and YN. */ + +static gfc_expr * +gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, + bool jn) +{ + gfc_expr *result; + gfc_expr *e; + long n1, n2; + int i; + mpfr_t x2rev, last1, last2; + + if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT + || order2->expr_type != EXPR_CONSTANT) + return NULL; + + n1 = mpz_get_si (order1->value.integer); + n2 = mpz_get_si (order2->value.integer); + result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where); + result->rank = 1; + result->shape = gfc_get_shape (1); + mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0)); + + if (n2 < n1) + return result; + + /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and + YN(N, 0.0) = -Inf. */ + + if (mpfr_cmp_ui (x->value.real, 0.0) == 0) + { + if (!jn && gfc_option.flag_range_check) + { + gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + if (jn && n1 == 0) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set_ui (e->value.real, 1, GFC_RND_MODE); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + n1++; + } + + for (i = n1; i <= n2; i++) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + if (jn) + mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); + else + mpfr_set_inf (e->value.real, -1); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + } + + return result; + } + + /* Use the faster but more verbose recurrence algorithm. Bessel functions + are stable for downward recursion and Neumann functions are stable + for upward recursion. It is + x2rev = 2.0/x, + J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x), + Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x). + Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */ + + gfc_set_model_kind (x->ts.kind); + + /* Get first recursion anchor. */ + + mpfr_init (last1); + if (jn) + mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE); + else + mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE); + + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (e->value.real, last1, GFC_RND_MODE); + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + { + mpfr_clear (last1); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; + } + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); + + if (n1 == n2) + { + mpfr_clear (last1); + return result; + } + + /* Get second recursion anchor. */ + + mpfr_init (last2); + if (jn) + mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE); + else + mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE); + + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (e->value.real, last2, GFC_RND_MODE); + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + { + mpfr_clear (last1); + mpfr_clear (last2); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; + } + if (jn) + gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2); + else + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); + + if (n1 + 1 == n2) + { + mpfr_clear (last1); + mpfr_clear (last2); + return result; + } + + /* Start actual recursion. */ + + mpfr_init (x2rev); + mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE); + + for (i = 2; i <= n2-n1; i++) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + /* Special case: For YN, if the previous N gave -INF, set + also N+1 to -INF. */ + if (!jn && !gfc_option.flag_range_check && mpfr_inf_p (last2)) + { + mpfr_set_inf (e->value.real, -1); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + continue; + } + + mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1), + GFC_RND_MODE); + mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE); + mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE); + + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + goto error; + + if (jn) + gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, + -i-1); + else + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); + + mpfr_set (last1, last2, GFC_RND_MODE); + mpfr_set (last2, e->value.real, GFC_RND_MODE); + } + + mpfr_clear (last1); + mpfr_clear (last2); + mpfr_clear (x2rev); + return result; + +error: + mpfr_clear (last1); + mpfr_clear (last2); + mpfr_clear (x2rev); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; +} + + +gfc_expr * +gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) +{ + return gfc_simplify_bessel_n2 (order1, order2, x, true); +} + + +gfc_expr * +gfc_simplify_bessel_y0 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_Y0"); +} + + +gfc_expr * +gfc_simplify_bessel_y1 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_Y1"); +} + + +gfc_expr * +gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x) +{ + gfc_expr *result; + long n; + + if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) + return NULL; + + n = mpz_get_si (order->value.integer); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_YN"); +} + + +gfc_expr * +gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) +{ + return gfc_simplify_bessel_n2 (order1, order2, x, false); +} + + +gfc_expr * +gfc_simplify_bit_size (gfc_expr *e) +{ + int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + return gfc_get_int_expr (e->ts.kind, &e->where, + gfc_integer_kinds[i].bit_size); +} + + +gfc_expr * +gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) +{ + int b; + + if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (bit, &b) != NULL || b < 0) + return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false); + + return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, + mpz_tstbit (e->value.integer, b)); +} + + +static int +compare_bitwise (gfc_expr *i, gfc_expr *j) +{ + mpz_t x, y; + int k, res; + + gcc_assert (i->ts.type == BT_INTEGER); + gcc_assert (j->ts.type == BT_INTEGER); + + mpz_init_set (x, i->value.integer); + k = gfc_validate_kind (i->ts.type, i->ts.kind, false); + convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); + + mpz_init_set (y, j->value.integer); + k = gfc_validate_kind (j->ts.type, j->ts.kind, false); + convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size); + + res = mpz_cmp (x, y); + mpz_clear (x); + mpz_clear (y); + return res; +} + + +gfc_expr * +gfc_simplify_bge (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) >= 0); +} + + +gfc_expr * +gfc_simplify_bgt (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) > 0); +} + + +gfc_expr * +gfc_simplify_ble (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) <= 0); +} + + +gfc_expr * +gfc_simplify_blt (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) < 0); +} + + +gfc_expr * +gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) +{ + gfc_expr *ceil, *result; + int kind; + + kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + ceil = gfc_copy_expr (e); + mpfr_ceil (ceil->value.real, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); + gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where); + + gfc_free_expr (ceil); + + return range_check (result, "CEILING"); +} + + +gfc_expr * +gfc_simplify_char (gfc_expr *e, gfc_expr *k) +{ + return simplify_achar_char (e, k, "CHAR", false); +} + + +/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */ + +static gfc_expr * +simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) +{ + gfc_expr *result; + + if (convert_boz (x, kind) == &gfc_bad_expr) + return &gfc_bad_expr; + + if (convert_boz (y, kind) == &gfc_bad_expr) + return &gfc_bad_expr; + + if (x->expr_type != EXPR_CONSTANT + || (y != NULL && y->expr_type != EXPR_CONSTANT)) + return NULL; + + result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where); + + switch (x->ts.type) + { + case BT_INTEGER: + mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE); + break; + + case BT_REAL: + mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)"); + } + + if (!y) + return range_check (result, name); + + switch (y->ts.type) + { + case BT_INTEGER: + mpfr_set_z (mpc_imagref (result->value.complex), + y->value.integer, GFC_RND_MODE); + break; + + case BT_REAL: + mpfr_set (mpc_imagref (result->value.complex), + y->value.real, GFC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)"); + } + + return range_check (result, name); +} + + +gfc_expr * +gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k) +{ + int kind; + + kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind); + if (kind == -1) + return &gfc_bad_expr; + + return simplify_cmplx ("CMPLX", x, y, kind); +} + + +gfc_expr * +gfc_simplify_complex (gfc_expr *x, gfc_expr *y) +{ + int kind; + + if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER) + kind = gfc_default_complex_kind; + else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER) + kind = x->ts.kind; + else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL) + kind = y->ts.kind; + else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL) + kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; + else + gcc_unreachable (); + + return simplify_cmplx ("COMPLEX", x, y, kind); +} + + +gfc_expr * +gfc_simplify_conjg (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_copy_expr (e); + mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE); + + return range_check (result, "CONJG"); +} + + +gfc_expr * +gfc_simplify_cos (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model_kind (x->ts.kind); + mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_cos(): Bad type"); + } + + return range_check (result, "COS"); +} + + +gfc_expr * +gfc_simplify_cosh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gcc_unreachable (); + } + + return range_check (result, "COSH"); +} + + +gfc_expr * +gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) +{ + gfc_expr *result; + + if (!is_constant_array_expr (mask) + || !gfc_is_constant_expr (dim) + || !gfc_is_constant_expr (kind)) + return NULL; + + result = transformational_result (mask, dim, + BT_INTEGER, + get_kind (BT_INTEGER, kind, "COUNT", + gfc_default_integer_kind), + &mask->where); + + init_result_expr (result, 0, NULL); + + /* Passing MASK twice, once as data array, once as mask. + Whenever gfc_count is called, '1' is added to the result. */ + return !dim || mask->rank == 1 ? + simplify_transformation_to_scalar (result, mask, mask, gfc_count) : + simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL); +} + + +gfc_expr * +gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) +{ + return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); +} + + +gfc_expr * +gfc_simplify_dble (gfc_expr *e) +{ + gfc_expr *result = NULL; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr) + return &gfc_bad_expr; + + result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind); + if (result == &gfc_bad_expr) + return &gfc_bad_expr; + + return range_check (result, "DBLE"); +} + + +gfc_expr * +gfc_simplify_digits (gfc_expr *x) +{ + int i, digits; + + i = gfc_validate_kind (x->ts.type, x->ts.kind, false); + + switch (x->ts.type) + { + case BT_INTEGER: + digits = gfc_integer_kinds[i].digits; + break; + + case BT_REAL: + case BT_COMPLEX: + digits = gfc_real_kinds[i].digits; + break; + + default: + gcc_unreachable (); + } + + return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits); +} + + +gfc_expr * +gfc_simplify_dim (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int kind; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; + result = gfc_get_constant_expr (x->ts.type, kind, &x->where); + + switch (x->ts.type) + { + case BT_INTEGER: + if (mpz_cmp (x->value.integer, y->value.integer) > 0) + mpz_sub (result->value.integer, x->value.integer, y->value.integer); + else + mpz_set_ui (result->value.integer, 0); + + break; + + case BT_REAL: + if (mpfr_cmp (x->value.real, y->value.real) > 0) + mpfr_sub (result->value.real, x->value.real, y->value.real, + GFC_RND_MODE); + else + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + + break; + + default: + gfc_internal_error ("gfc_simplify_dim(): Bad type"); + } + + return range_check (result, "DIM"); +} + + +gfc_expr* +gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) +{ + if (!is_constant_array_expr (vector_a) + || !is_constant_array_expr (vector_b)) + return NULL; + + gcc_assert (vector_a->rank == 1); + gcc_assert (vector_b->rank == 1); + gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts)); + + return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0); +} + + +gfc_expr * +gfc_simplify_dprod (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *a1, *a2, *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + a1 = gfc_real2real (x, gfc_default_double_kind); + a2 = gfc_real2real (y, gfc_default_double_kind); + + result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where); + mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE); + + gfc_free_expr (a2); + gfc_free_expr (a1); + + return range_check (result, "DPROD"); +} + + +static gfc_expr * +simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, + bool right) +{ + gfc_expr *result; + int i, k, size, shift; + + if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT + || shiftarg->expr_type != EXPR_CONSTANT) + return NULL; + + k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false); + size = gfc_integer_kinds[k].bit_size; + + if (gfc_extract_int (shiftarg, &shift) != NULL) + { + gfc_error ("Invalid SHIFT argument of DSHIFTL at %L", &shiftarg->where); + return &gfc_bad_expr; + } + + gcc_assert (shift >= 0 && shift <= size); + + /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */ + if (right) + shift = size - shift; + + result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where); + mpz_set_ui (result->value.integer, 0); + + for (i = 0; i < shift; i++) + if (mpz_tstbit (arg2->value.integer, size - shift + i)) + mpz_setbit (result->value.integer, i); + + for (i = 0; i < size - shift; i++) + if (mpz_tstbit (arg1->value.integer, i)) + mpz_setbit (result->value.integer, shift + i); + + /* Convert to a signed value. */ + convert_mpz_to_signed (result->value.integer, size); + + return result; +} + + +gfc_expr * +gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) +{ + return simplify_dshift (arg1, arg2, shiftarg, true); +} + + +gfc_expr * +gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) +{ + return simplify_dshift (arg1, arg2, shiftarg, false); +} + + +gfc_expr * +gfc_simplify_erf (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "ERF"); +} + + +gfc_expr * +gfc_simplify_erfc (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "ERFC"); +} + + +/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */ + +#define MAX_ITER 200 +#define ARG_LIMIT 12 + +/* Calculate ERFC_SCALED directly by its definition: + + ERFC_SCALED(x) = ERFC(x) * EXP(X**2) + + using a large precision for intermediate results. This is used for all + but large values of the argument. */ +static void +fullprec_erfc_scaled (mpfr_t res, mpfr_t arg) +{ + mp_prec_t prec; + mpfr_t a, b; + + prec = mpfr_get_default_prec (); + mpfr_set_default_prec (10 * prec); + + mpfr_init (a); + mpfr_init (b); + + mpfr_set (a, arg, GFC_RND_MODE); + mpfr_sqr (b, a, GFC_RND_MODE); + mpfr_exp (b, b, GFC_RND_MODE); + mpfr_erfc (a, a, GFC_RND_MODE); + mpfr_mul (a, a, b, GFC_RND_MODE); + + mpfr_set (res, a, GFC_RND_MODE); + mpfr_set_default_prec (prec); + + mpfr_clear (a); + mpfr_clear (b); +} + +/* Calculate ERFC_SCALED using a power series expansion in 1/arg: + + ERFC_SCALED(x) = 1 / (x * sqrt(pi)) + * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1)) + / (2 * x**2)**n) + + This is used for large values of the argument. Intermediate calculations + are performed with twice the precision. We don't do a fixed number of + iterations of the sum, but stop when it has converged to the required + precision. */ +static void +asympt_erfc_scaled (mpfr_t res, mpfr_t arg) +{ + mpfr_t sum, x, u, v, w, oldsum, sumtrunc; + mpz_t num; + mp_prec_t prec; + unsigned i; + + prec = mpfr_get_default_prec (); + mpfr_set_default_prec (2 * prec); + + mpfr_init (sum); + mpfr_init (x); + mpfr_init (u); + mpfr_init (v); + mpfr_init (w); + mpz_init (num); + + mpfr_init (oldsum); + mpfr_init (sumtrunc); + mpfr_set_prec (oldsum, prec); + mpfr_set_prec (sumtrunc, prec); + + mpfr_set (x, arg, GFC_RND_MODE); + mpfr_set_ui (sum, 1, GFC_RND_MODE); + mpz_set_ui (num, 1); + + mpfr_set (u, x, GFC_RND_MODE); + mpfr_sqr (u, u, GFC_RND_MODE); + mpfr_mul_ui (u, u, 2, GFC_RND_MODE); + mpfr_pow_si (u, u, -1, GFC_RND_MODE); + + for (i = 1; i < MAX_ITER; i++) + { + mpfr_set (oldsum, sum, GFC_RND_MODE); + + mpz_mul_ui (num, num, 2 * i - 1); + mpz_neg (num, num); + + mpfr_set (w, u, GFC_RND_MODE); + mpfr_pow_ui (w, w, i, GFC_RND_MODE); + + mpfr_set_z (v, num, GFC_RND_MODE); + mpfr_mul (v, v, w, GFC_RND_MODE); + + mpfr_add (sum, sum, v, GFC_RND_MODE); + + mpfr_set (sumtrunc, sum, GFC_RND_MODE); + if (mpfr_cmp (sumtrunc, oldsum) == 0) + break; + } + + /* We should have converged by now; otherwise, ARG_LIMIT is probably + set too low. */ + gcc_assert (i < MAX_ITER); + + /* Divide by x * sqrt(Pi). */ + mpfr_const_pi (u, GFC_RND_MODE); + mpfr_sqrt (u, u, GFC_RND_MODE); + mpfr_mul (u, u, x, GFC_RND_MODE); + mpfr_div (sum, sum, u, GFC_RND_MODE); + + mpfr_set (res, sum, GFC_RND_MODE); + mpfr_set_default_prec (prec); + + mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL); + mpz_clear (num); +} + + +gfc_expr * +gfc_simplify_erfc_scaled (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0) + asympt_erfc_scaled (result->value.real, x->value.real); + else + fullprec_erfc_scaled (result->value.real, x->value.real); + + return range_check (result, "ERFC_SCALED"); +} + +#undef MAX_ITER +#undef ARG_LIMIT + + +gfc_expr * +gfc_simplify_epsilon (gfc_expr *e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE); + + return range_check (result, "EPSILON"); +} + + +gfc_expr * +gfc_simplify_exp (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model_kind (x->ts.kind); + mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_exp(): Bad type"); + } + + return range_check (result, "EXP"); +} + + +gfc_expr * +gfc_simplify_exponent (gfc_expr *x) +{ + int i; + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &x->where); + + gfc_set_model (x->value.real); + + if (mpfr_sgn (x->value.real) == 0) + { + mpz_set_ui (result->value.integer, 0); + return result; + } + + i = (int) mpfr_get_exp (x->value.real); + mpz_set_si (result->value.integer, i); + + return range_check (result, "EXPONENT"); +} + + +gfc_expr * +gfc_simplify_float (gfc_expr *a) +{ + gfc_expr *result; + + if (a->expr_type != EXPR_CONSTANT) + return NULL; + + if (a->is_boz) + { + if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr) + return &gfc_bad_expr; + + result = gfc_copy_expr (a); + } + else + result = gfc_int2real (a, gfc_default_real_kind); + + return range_check (result, "FLOAT"); +} + + +static bool +is_last_ref_vtab (gfc_expr *e) +{ + gfc_ref *ref; + gfc_component *comp = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + comp = ref->u.c.component; + + if (!e->ref || !comp) + return e->symtree->n.sym->attr.vtab; + + if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0) + return true; + + return false; +} + + +gfc_expr * +gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) +{ + /* Avoid simplification of resolved symbols. */ + if (is_last_ref_vtab (a) || is_last_ref_vtab (mold)) + return NULL; + + if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_type_is_extension_of (mold->ts.u.derived, + a->ts.u.derived)); + /* Return .false. if the dynamic type can never be the same. */ + if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS + && !gfc_type_is_extension_of + (mold->ts.u.derived->components->ts.u.derived, + a->ts.u.derived->components->ts.u.derived) + && !gfc_type_is_extension_of + (a->ts.u.derived->components->ts.u.derived, + mold->ts.u.derived->components->ts.u.derived)) + || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS + && !gfc_type_is_extension_of + (a->ts.u.derived, + mold->ts.u.derived->components->ts.u.derived) + && !gfc_type_is_extension_of + (mold->ts.u.derived->components->ts.u.derived, + a->ts.u.derived)) + || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED + && !gfc_type_is_extension_of + (mold->ts.u.derived, + a->ts.u.derived->components->ts.u.derived))) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); + + if (mold->ts.type == BT_DERIVED + && gfc_type_is_extension_of (mold->ts.u.derived, + a->ts.u.derived->components->ts.u.derived)) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true); + + return NULL; +} + + +gfc_expr * +gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b) +{ + /* Avoid simplification of resolved symbols. */ + if (is_last_ref_vtab (a) || is_last_ref_vtab (b)) + return NULL; + + /* Return .false. if the dynamic type can never be the + same. */ + if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS) + && !gfc_type_compatible (&a->ts, &b->ts) + && !gfc_type_compatible (&b->ts, &a->ts)) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); + + if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_derived_types (a->ts.u.derived, + b->ts.u.derived)); +} + + +gfc_expr * +gfc_simplify_floor (gfc_expr *e, gfc_expr *k) +{ + gfc_expr *result; + mpfr_t floor; + int kind; + + kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind); + if (kind == -1) + gfc_internal_error ("gfc_simplify_floor(): Bad kind"); + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + gfc_set_model_kind (kind); + + mpfr_init (floor); + mpfr_floor (floor, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); + gfc_mpfr_to_mpz (result->value.integer, floor, &e->where); + + mpfr_clear (floor); + + return range_check (result, "FLOOR"); +} + + +gfc_expr * +gfc_simplify_fraction (gfc_expr *x) +{ + gfc_expr *result; + mpfr_t absv, exp, pow2; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); + + if (mpfr_sgn (x->value.real) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + gfc_set_model_kind (x->ts.kind); + mpfr_init (exp); + mpfr_init (absv); + mpfr_init (pow2); + + mpfr_abs (absv, x->value.real, GFC_RND_MODE); + mpfr_log2 (exp, absv, GFC_RND_MODE); + + mpfr_trunc (exp, exp); + mpfr_add_ui (exp, exp, 1, GFC_RND_MODE); + + mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE); + + mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE); + + mpfr_clears (exp, absv, pow2, NULL); + + return range_check (result, "FRACTION"); +} + + +gfc_expr * +gfc_simplify_gamma (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "GAMMA"); +} + + +gfc_expr * +gfc_simplify_huge (gfc_expr *e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + + switch (e->ts.type) + { + case BT_INTEGER: + mpz_set (result->value.integer, gfc_integer_kinds[i].huge); + break; + + case BT_REAL: + mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); + break; + + default: + gcc_unreachable (); + } + + return result; +} + + +gfc_expr * +gfc_simplify_hypot (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE); + return range_check (result, "HYPOT"); +} + + +/* We use the processor's collating sequence, because all + systems that gfortran currently works on are ASCII. */ + +gfc_expr * +gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) +{ + gfc_expr *result; + gfc_char_t index; + int k; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (e->value.character.length != 1) + { + gfc_error ("Argument of IACHAR at %L must be of length one", &e->where); + return &gfc_bad_expr; + } + + index = e->value.character.string[0]; + + if (gfc_option.warn_surprising && index > 127) + gfc_warning ("Argument of IACHAR function at %L outside of range 0..127", + &e->where); + + k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_get_int_expr (k, &e->where, index); + + return range_check (result, "IACHAR"); +} + + +static gfc_expr * +do_bit_and (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_and (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + +gfc_expr * +gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, -1, do_bit_and); +} + + +static gfc_expr * +do_bit_ior (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_ior (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + +gfc_expr * +gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 0, do_bit_ior); +} + + +gfc_expr * +gfc_simplify_iand (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); + mpz_and (result->value.integer, x->value.integer, y->value.integer); + + return range_check (result, "IAND"); +} + + +gfc_expr * +gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int k, pos; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (y, &pos) != NULL || pos < 0) + { + gfc_error ("Invalid second argument of IBCLR at %L", &y->where); + return &gfc_bad_expr; + } + + k = gfc_validate_kind (x->ts.type, x->ts.kind, false); + + if (pos >= gfc_integer_kinds[k].bit_size) + { + gfc_error ("Second argument of IBCLR exceeds bit size at %L", + &y->where); + return &gfc_bad_expr; + } + + result = gfc_copy_expr (x); + + convert_mpz_to_unsigned (result->value.integer, + gfc_integer_kinds[k].bit_size); + + mpz_clrbit (result->value.integer, pos); + + convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) +{ + gfc_expr *result; + int pos, len; + int i, k, bitsize; + int *bits; + + if (x->expr_type != EXPR_CONSTANT + || y->expr_type != EXPR_CONSTANT + || z->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (y, &pos) != NULL || pos < 0) + { + gfc_error ("Invalid second argument of IBITS at %L", &y->where); + return &gfc_bad_expr; + } + + if (gfc_extract_int (z, &len) != NULL || len < 0) + { + gfc_error ("Invalid third argument of IBITS at %L", &z->where); + return &gfc_bad_expr; + } + + 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"); + } + + gfc_free (bits); + + convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int k, pos; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (y, &pos) != NULL || pos < 0) + { + gfc_error ("Invalid second argument of IBSET at %L", &y->where); + return &gfc_bad_expr; + } + + k = gfc_validate_kind (x->ts.type, x->ts.kind, false); + + if (pos >= gfc_integer_kinds[k].bit_size) + { + gfc_error ("Second argument of IBSET exceeds bit size at %L", + &y->where); + return &gfc_bad_expr; + } + + result = gfc_copy_expr (x); + + convert_mpz_to_unsigned (result->value.integer, + gfc_integer_kinds[k].bit_size); + + mpz_setbit (result->value.integer, pos); + + convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) +{ + gfc_expr *result; + gfc_char_t index; + int k; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (e->value.character.length != 1) + { + gfc_error ("Argument of ICHAR at %L must be of length one", &e->where); + return &gfc_bad_expr; + } + + index = e->value.character.string[0]; + + k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_get_int_expr (k, &e->where, index); + + return range_check (result, "ICHAR"); +} + + +gfc_expr * +gfc_simplify_ieor (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); + mpz_xor (result->value.integer, x->value.integer, y->value.integer); + + return range_check (result, "IEOR"); +} + + +gfc_expr * +gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) +{ + gfc_expr *result; + int back, len, lensub; + int i, j, k, count, index = 0, start; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT + || ( b != NULL && b->expr_type != EXPR_CONSTANT)) + return NULL; + + if (b != NULL && b->value.logical != 0) + back = 1; + else + back = 0; + + k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); + + len = x->value.character.length; + lensub = y->value.character.length; + + if (len < lensub) + { + mpz_set_si (result->value.integer, 0); + return result; + } + + if (back == 0) + { + if (lensub == 0) + { + mpz_set_si (result->value.integer, 1); + return result; + } + else if (lensub == 1) + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] + == x->value.character.string[i]) + { + index = i + 1; + goto done; + } + } + } + } + else + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] + == x->value.character.string[i]) + { + start = i; + count = 0; + + for (k = 0; k < lensub; k++) + { + if (y->value.character.string[k] + == x->value.character.string[k + start]) + count++; + } + + if (count == lensub) + { + index = start + 1; + goto done; + } + } + } + } + } + + } + else + { + if (lensub == 0) + { + mpz_set_si (result->value.integer, len + 1); + return result; + } + else if (lensub == 1) + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] + == x->value.character.string[len - i]) + { + index = len - i + 1; + goto done; + } + } + } + } + else + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] + == x->value.character.string[len - i]) + { + start = len - i; + if (start <= len - lensub) + { + count = 0; + for (k = 0; k < lensub; k++) + if (y->value.character.string[k] + == x->value.character.string[k + start]) + count++; + + if (count == lensub) + { + index = start + 1; + goto done; + } + } + else + { + continue; + } + } + } + } + } + } + +done: + mpz_set_si (result->value.integer, index); + return range_check (result, "INDEX"); +} + + +static gfc_expr * +simplify_intconv (gfc_expr *e, int kind, const char *name) +{ + gfc_expr *result = NULL; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_convert_constant (e, BT_INTEGER, kind); + if (result == &gfc_bad_expr) + return &gfc_bad_expr; + + return range_check (result, name); +} + + +gfc_expr * +gfc_simplify_int (gfc_expr *e, gfc_expr *k) +{ + int kind; + + kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + + return simplify_intconv (e, kind, "INT"); +} + +gfc_expr * +gfc_simplify_int2 (gfc_expr *e) +{ + return simplify_intconv (e, 2, "INT2"); +} + + +gfc_expr * +gfc_simplify_int8 (gfc_expr *e) +{ + return simplify_intconv (e, 8, "INT8"); +} + + +gfc_expr * +gfc_simplify_long (gfc_expr *e) +{ + return simplify_intconv (e, 4, "LONG"); +} + + +gfc_expr * +gfc_simplify_ifix (gfc_expr *e) +{ + gfc_expr *rtrunc, *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + rtrunc = gfc_copy_expr (e); + mpfr_trunc (rtrunc->value.real, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &e->where); + gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); + + gfc_free_expr (rtrunc); + + return range_check (result, "IFIX"); +} + + +gfc_expr * +gfc_simplify_idint (gfc_expr *e) +{ + gfc_expr *rtrunc, *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + rtrunc = gfc_copy_expr (e); + mpfr_trunc (rtrunc->value.real, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &e->where); + gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); + + gfc_free_expr (rtrunc); + + return range_check (result, "IDINT"); +} + + +gfc_expr * +gfc_simplify_ior (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); + mpz_ior (result->value.integer, x->value.integer, y->value.integer); + + return range_check (result, "IOR"); +} + + +static gfc_expr * +do_bit_xor (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_xor (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + +gfc_expr * +gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 0, do_bit_xor); +} + + + +gfc_expr * +gfc_simplify_is_iostat_end (gfc_expr *x) +{ + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, + mpz_cmp_si (x->value.integer, + LIBERROR_END) == 0); +} + + +gfc_expr * +gfc_simplify_is_iostat_eor (gfc_expr *x) +{ + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, + mpz_cmp_si (x->value.integer, + LIBERROR_EOR) == 0); +} + + +gfc_expr * +gfc_simplify_isnan (gfc_expr *x) +{ + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, + mpfr_nan_p (x->value.real)); +} + + +/* Performs a shift on its first argument. Depending on the last + argument, the shift can be arithmetic, i.e. with filling from the + left like in the SHIFTA intrinsic. */ +static gfc_expr * +simplify_shift (gfc_expr *e, gfc_expr *s, const char *name, + bool arithmetic, int direction) +{ + gfc_expr *result; + int ashift, *bits, i, k, bitsize, shift; + + if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) + return NULL; + if (gfc_extract_int (s, &shift) != NULL) + { + gfc_error ("Invalid second argument of %s at %L", name, &s->where); + return &gfc_bad_expr; + } + + k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false); + bitsize = gfc_integer_kinds[k].bit_size; + + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + + if (shift == 0) + { + mpz_set (result->value.integer, e->value.integer); + return result; + } + + if (direction > 0 && shift < 0) + { + /* Left shift, as in SHIFTL. */ + gfc_error ("Second argument of %s is negative at %L", name, &e->where); + return &gfc_bad_expr; + } + else if (direction < 0) + { + /* Right shift, as in SHIFTR or SHIFTA. */ + if (shift < 0) + { + gfc_error ("Second argument of %s is negative at %L", + name, &e->where); + return &gfc_bad_expr; + } + + shift = -shift; + } + + ashift = (shift >= 0 ? shift : -shift); + + if (ashift > bitsize) + { + gfc_error ("Magnitude of second argument of %s exceeds bit size " + "at %L", name, &e->where); + return &gfc_bad_expr; + } + + bits = XCNEWVEC (int, bitsize); + + for (i = 0; i < bitsize; i++) + bits[i] = mpz_tstbit (e->value.integer, i); + + if (shift > 0) + { + /* Left shift. */ + for (i = 0; i < shift; i++) + mpz_clrbit (result->value.integer, i); + + for (i = 0; i < bitsize - shift; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i + shift); + else + mpz_setbit (result->value.integer, i + shift); + } + } + else + { + /* Right shift. */ + if (arithmetic && bits[bitsize - 1]) + for (i = bitsize - 1; i >= bitsize - ashift; i--) + mpz_setbit (result->value.integer, i); + else + for (i = bitsize - 1; i >= bitsize - ashift; i--) + mpz_clrbit (result->value.integer, i); + + for (i = bitsize - 1; i >= ashift; i--) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i - ashift); + else + mpz_setbit (result->value.integer, i - ashift); + } + } + + convert_mpz_to_signed (result->value.integer, bitsize); + gfc_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; + + if (gfc_extract_int (s, &shift) != NULL) + { + gfc_error ("Invalid second argument of ISHFTC at %L", &s->where); + return &gfc_bad_expr; + } + + 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; + + if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0) + { + gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where); + return &gfc_bad_expr; + } + + if (ssize > isize) + { + gfc_error ("Magnitude of third argument of ISHFTC exceeds " + "BIT_SIZE of first argument at %L", &s->where); + return &gfc_bad_expr; + } + } + 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 " + "third argument at %L", &s->where); + else + gfc_error ("Magnitude of second argument of ISHFTC exceeds " + "BIT_SIZE of first argument at %L", &s->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + + mpz_set (result->value.integer, e->value.integer); + + if (shift == 0) + return result; + + convert_mpz_to_unsigned (result->value.integer, isize); + + bits = XCNEWVEC (int, ssize); + + for (i = 0; i < ssize; i++) + bits[i] = mpz_tstbit (e->value.integer, i); + + delta = ssize - ashift; + + if (shift > 0) + { + for (i = 0; i < delta; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i + shift); + else + mpz_setbit (result->value.integer, i + shift); + } + + for (i = delta; i < ssize; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i - delta); + else + mpz_setbit (result->value.integer, i - delta); + } + } + else + { + for (i = 0; i < ashift; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i + delta); + else + mpz_setbit (result->value.integer, i + delta); + } + + for (i = ashift; i < ssize; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i + shift); + else + mpz_setbit (result->value.integer, i + shift); + } + } + + convert_mpz_to_signed (result->value.integer, isize); + + gfc_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 = gfc_simplify_size (array, dim, kind); + gfc_free_expr (dim); + if (!result) + goto returnNull; + } + else + mpz_set_si (result->value.integer, 1); + + goto done; + } + + /* Otherwise, we have a variable expression. */ + gcc_assert (array->expr_type == EXPR_VARIABLE); + gcc_assert (as); + + if (gfc_resolve_array_spec (as, 0) == FAILURE) + return NULL; + + /* The last dimension of an assumed-size array is special. */ + if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) + || (coarray && d == as->rank + as->corank)) + { + if (as->lower[d-1]->expr_type == EXPR_CONSTANT) + { + gfc_free_expr (result); + return gfc_copy_expr (as->lower[d-1]); + } + + goto returnNull; + } + + result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); + + /* Then, we need to know the extent of the given dimension. */ + if (coarray || ref->u.ar.type == AR_FULL) + { + l = as->lower[d-1]; + u = as->upper[d-1]; + + if (l->expr_type != EXPR_CONSTANT || u == NULL + || u->expr_type != EXPR_CONSTANT) + goto returnNull; + + if (mpz_cmp (l->value.integer, u->value.integer) > 0) + { + /* Zero extent. */ + if (upper) + mpz_set_si (result->value.integer, 0); + else + mpz_set_si (result->value.integer, 1); + } + else + { + /* Nonzero extent. */ + if (upper) + mpz_set (result->value.integer, u->value.integer); + else + mpz_set (result->value.integer, l->value.integer); + } + } + else + { + if (upper) + { + if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer, NULL) + != SUCCESS) + goto returnNull; + } + else + mpz_set_si (result->value.integer, (long int) 1); + } + +done: + return range_check (result, upper ? "UBOUND" : "LBOUND"); + +returnNull: + gfc_free_expr (result); + return NULL; +} + + +static gfc_expr * +simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) +{ + gfc_ref *ref; + gfc_array_spec *as; + int d; + + if (array->expr_type != EXPR_VARIABLE) + { + as = NULL; + ref = NULL; + goto done; + } + + /* Follow any component references. */ + as = array->symtree->n.sym->as; + for (ref = array->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + switch (ref->u.ar.type) + { + case AR_ELEMENT: + as = NULL; + continue; + + case AR_FULL: + /* We're done because 'as' has already been set in the + previous iteration. */ + if (!ref->next) + goto done; + + /* Fall through. */ + + case AR_UNKNOWN: + return NULL; + + case AR_SECTION: + as = ref->u.ar.as; + goto done; + } + + gcc_unreachable (); + + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + continue; + } + } + + gcc_unreachable (); + + done: + + if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)) + return NULL; + + if (dim == NULL) + { + /* Multi-dimensional bounds. */ + gfc_expr *bounds[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + int k; + + /* UBOUND(ARRAY) is not valid for an assumed-size array. */ + if (upper && as && as->type == AS_ASSUMED_SIZE) + { + /* An error message will be emitted in + check_assumed_size_reference (resolve.c). */ + return &gfc_bad_expr; + } + + /* Simplify the bounds for each dimension. */ + for (d = 0; d < array->rank; d++) + { + bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref, + false); + if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) + { + int j; + + for (j = 0; j < d; j++) + gfc_free_expr (bounds[j]); + return bounds[d]; + } + } + + /* Allocate the result expression. */ + k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", + gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + e = gfc_get_array_expr (BT_INTEGER, k, &array->where); + + /* The result is a rank 1 array; its size is the rank of the first + argument to {L,U}BOUND. */ + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], array->rank); + + /* Create the constructor for this array. */ + for (d = 0; d < array->rank; d++) + gfc_constructor_append_expr (&e->value.constructor, + bounds[d], &e->where); + + return e; + } + else + { + /* A DIM argument is specified. */ + if (dim->expr_type != EXPR_CONSTANT) + return NULL; + + d = mpz_get_si (dim->value.integer); + + if (d < 1 || d > array->rank + || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) + { + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; + } + + 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->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->next == NULL) + { + gcc_assert (ref->u.ar.as->corank > 0 + && ref->u.ar.as->rank == 0); + as = ref->u.ar.as; + goto done; + } + as = NULL; + continue; + + case AR_FULL: + /* We're done because 'as' has already been set in the + previous iteration. */ + if (!ref->next) + goto done; + + /* Fall through. */ + + case AR_UNKNOWN: + return NULL; + + case AR_SECTION: + as = ref->u.ar.as; + goto done; + } + + gcc_unreachable (); + + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + continue; + } + } + + gcc_unreachable (); + + done: + + if (as->type == AS_DEFERRED || as->type == 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 + array->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+array->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) +{ + gfc_expr *e; + /* return simplify_cobound (array, dim, kind, 0);*/ + + e = simplify_cobound (array, dim, kind, 0); + if (e != NULL) + return e; + + gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant " + "cobounds at %L", &array->where); + return &gfc_bad_expr; +} + +gfc_expr * +gfc_simplify_leadz (gfc_expr *e) +{ + unsigned long lz, bs; + int i; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + bs = gfc_integer_kinds[i].bit_size; + if (mpz_cmp_si (e->value.integer, 0) == 0) + lz = bs; + else if (mpz_cmp_si (e->value.integer, 0) < 0) + lz = 0; + else + lz = bs - mpz_sizeinbase (e->value.integer, 2); + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); +} + + +gfc_expr * +gfc_simplify_len (gfc_expr *e, gfc_expr *kind) +{ + gfc_expr *result; + int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; + + if (e->expr_type == EXPR_CONSTANT) + { + result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); + mpz_set_si (result->value.integer, e->value.character.length); + return range_check (result, "LEN"); + } + else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL + && e->ts.u.cl->length->expr_type == EXPR_CONSTANT + && e->ts.u.cl->length->ts.type == BT_INTEGER) + { + result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); + mpz_set (result->value.integer, e->ts.u.cl->length->value.integer); + return range_check (result, "LEN"); + } + else + return NULL; +} + + +gfc_expr * +gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) +{ + gfc_expr *result; + int count, len, i; + int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + len = e->value.character.length; + for (count = 0, i = 1; i <= len; i++) + if (e->value.character.string[len - i] == ' ') + count++; + else + break; + + result = gfc_get_int_expr (k, &e->where, len - count); + return range_check (result, "LEN_TRIM"); +} + +gfc_expr * +gfc_simplify_lgamma (gfc_expr *x) +{ + gfc_expr *result; + int sg; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE); + + return range_check (result, "LGAMMA"); +} + + +gfc_expr * +gfc_simplify_lge (gfc_expr *a, gfc_expr *b) +{ + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) >= 0); +} + + +gfc_expr * +gfc_simplify_lgt (gfc_expr *a, gfc_expr *b) +{ + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) > 0); +} + + +gfc_expr * +gfc_simplify_lle (gfc_expr *a, gfc_expr *b) +{ + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) <= 0); +} + + +gfc_expr * +gfc_simplify_llt (gfc_expr *a, gfc_expr *b) +{ + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) < 0); +} + + +gfc_expr * +gfc_simplify_log (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + if (mpfr_sgn (x->value.real) <= 0) + { + gfc_error ("Argument of LOG at %L cannot be less than or equal " + "to zero", &x->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + mpfr_log (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0) + && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0)) + { + gfc_error ("Complex argument of LOG at %L cannot be zero", + &x->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + gfc_set_model_kind (x->ts.kind); + mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_simplify_log: bad type"); + } + + return range_check (result, "LOG"); +} + + +gfc_expr * +gfc_simplify_log10 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_sgn (x->value.real) <= 0) + { + gfc_error ("Argument of LOG10 at %L cannot be less than or equal " + "to zero", &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "LOG10"); +} + + +gfc_expr * +gfc_simplify_logical (gfc_expr *e, gfc_expr *k) +{ + int kind; + + kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind); + if (kind < 0) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (kind, &e->where, e->value.logical); +} + + +gfc_expr* +gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) +{ + gfc_expr *result; + int row, result_rows, col, result_columns; + int stride_a, offset_a, stride_b, offset_b; + + if (!is_constant_array_expr (matrix_a) + || !is_constant_array_expr (matrix_b)) + return NULL; + + gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts)); + result = gfc_get_array_expr (matrix_a->ts.type, + matrix_a->ts.kind, + &matrix_a->where); + + if (matrix_a->rank == 1 && matrix_b->rank == 2) + { + result_rows = 1; + result_columns = mpz_get_si (matrix_b->shape[1]); + stride_a = 1; + stride_b = mpz_get_si (matrix_b->shape[0]); + + result->rank = 1; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_columns); + } + else if (matrix_a->rank == 2 && matrix_b->rank == 1) + { + result_rows = mpz_get_si (matrix_a->shape[0]); + result_columns = 1; + stride_a = mpz_get_si (matrix_a->shape[0]); + stride_b = 1; + + result->rank = 1; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_rows); + } + else if (matrix_a->rank == 2 && matrix_b->rank == 2) + { + result_rows = mpz_get_si (matrix_a->shape[0]); + result_columns = mpz_get_si (matrix_b->shape[1]); + stride_a = mpz_get_si (matrix_a->shape[0]); + stride_b = mpz_get_si (matrix_b->shape[0]); + + result->rank = 2; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_rows); + mpz_init_set_si (result->shape[1], result_columns); + } + else + gcc_unreachable(); + + offset_a = offset_b = 0; + for (col = 0; col < result_columns; ++col) + { + offset_a = 0; + + for (row = 0; row < result_rows; ++row) + { + gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a, + matrix_b, 1, offset_b); + gfc_constructor_append_expr (&result->value.constructor, + e, NULL); + + offset_a += 1; + } + + offset_b += stride_b; + } + + return result; +} + + +gfc_expr * +gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg) +{ + gfc_expr *result; + int kind, arg, k; + const char *s; + + if (i->expr_type != EXPR_CONSTANT) + return NULL; + + kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + k = gfc_validate_kind (BT_INTEGER, kind, false); + + s = gfc_extract_int (i, &arg); + gcc_assert (!s); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); + + /* MASKR(n) = 2^n - 1 */ + mpz_set_ui (result->value.integer, 1); + mpz_mul_2exp (result->value.integer, result->value.integer, arg); + mpz_sub_ui (result->value.integer, result->value.integer, 1); + + convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) +{ + gfc_expr *result; + int kind, arg, k; + const char *s; + mpz_t z; + + if (i->expr_type != EXPR_CONSTANT) + return NULL; + + kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + k = gfc_validate_kind (BT_INTEGER, kind, false); + + s = gfc_extract_int (i, &arg); + gcc_assert (!s); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); + + /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */ + mpz_init_set_ui (z, 1); + mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size); + mpz_set_ui (result->value.integer, 1); + mpz_mul_2exp (result->value.integer, result->value.integer, + gfc_integer_kinds[k].bit_size - arg); + mpz_sub (result->value.integer, z, result->value.integer); + mpz_clear (z); + + convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) +{ + if (tsource->expr_type != EXPR_CONSTANT + || fsource->expr_type != EXPR_CONSTANT + || mask->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_copy_expr (mask->value.logical ? tsource : fsource); +} + + +gfc_expr * +gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr) +{ + mpz_t arg1, arg2, mask; + gfc_expr *result; + + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT + || mask_expr->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where); + + /* Convert all argument to unsigned. */ + mpz_init_set (arg1, i->value.integer); + mpz_init_set (arg2, j->value.integer); + mpz_init_set (mask, mask_expr->value.integer); + + /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */ + mpz_and (arg1, arg1, mask); + mpz_com (mask, mask); + mpz_and (arg2, arg2, mask); + mpz_ior (result->value.integer, arg1, arg2); + + mpz_clear (arg1); + mpz_clear (arg2); + mpz_clear (mask); + + return result; +} + + +/* Selects between current value and extremum for simplify_min_max + and simplify_minval_maxval. */ +static void +min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) +{ + switch (arg->ts.type) + { + case BT_INTEGER: + if (mpz_cmp (arg->value.integer, + extremum->value.integer) * sign > 0) + mpz_set (extremum->value.integer, arg->value.integer); + break; + + case BT_REAL: + /* We need to use mpfr_min and mpfr_max to treat NaN properly. */ + if (sign > 0) + mpfr_max (extremum->value.real, extremum->value.real, + arg->value.real, GFC_RND_MODE); + else + mpfr_min (extremum->value.real, extremum->value.real, + arg->value.real, GFC_RND_MODE); + break; + + case BT_CHARACTER: +#define LENGTH(x) ((x)->value.character.length) +#define STRING(x) ((x)->value.character.string) + if (LENGTH(extremum) < LENGTH(arg)) + { + gfc_char_t *tmp = STRING(extremum); + + STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1); + memcpy (STRING(extremum), tmp, + LENGTH(extremum) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', + LENGTH(arg) - LENGTH(extremum)); + STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ + LENGTH(extremum) = LENGTH(arg); + gfc_free (tmp); + } + + if (gfc_compare_string (arg, extremum) * sign > 0) + { + gfc_free (STRING(extremum)); + STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); + memcpy (STRING(extremum), STRING(arg), + LENGTH(arg) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', + LENGTH(extremum) - LENGTH(arg)); + STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ + } +#undef LENGTH +#undef STRING + break; + + default: + gfc_internal_error ("simplify_min_max(): Bad type in arglist"); + } +} + + +/* This function is special since MAX() can take any number of + arguments. The simplified expression is a rewritten version of the + argument list containing at most one constant element. Other + constant elements are deleted. Because the argument list has + already been checked, this function always succeeds. sign is 1 for + MAX(), -1 for MIN(). */ + +static gfc_expr * +simplify_min_max (gfc_expr *expr, int sign) +{ + gfc_actual_arglist *arg, *last, *extremum; + gfc_intrinsic_sym * specific; + + last = NULL; + extremum = NULL; + specific = expr->value.function.isym; + + arg = expr->value.function.actual; + + for (; arg; last = arg, arg = arg->next) + { + if (arg->expr->expr_type != EXPR_CONSTANT) + continue; + + if (extremum == NULL) + { + extremum = arg; + continue; + } + + min_max_choose (arg->expr, extremum->expr, sign); + + /* Delete the extra constant argument. */ + if (last == NULL) + expr->value.function.actual = arg->next; + else + last->next = arg->next; + + arg->next = NULL; + gfc_free_actual_arglist (arg); + arg = last; + } + + /* If there is one value left, replace the function call with the + expression. */ + if (expr->value.function.actual->next != NULL) + return NULL; + + /* Convert to the correct type and kind. */ + if (expr->ts.type != BT_UNKNOWN) + return gfc_convert_constant (expr->value.function.actual->expr, + expr->ts.type, expr->ts.kind); + + if (specific->ts.type != BT_UNKNOWN) + return gfc_convert_constant (expr->value.function.actual->expr, + specific->ts.type, specific->ts.kind); + + return gfc_copy_expr (expr->value.function.actual->expr); +} + + +gfc_expr * +gfc_simplify_min (gfc_expr *e) +{ + return simplify_min_max (e, -1); +} + + +gfc_expr * +gfc_simplify_max (gfc_expr *e) +{ + return simplify_min_max (e, 1); +} + + +/* This is a simplified version of simplify_min_max to provide + simplification of minval and maxval for a vector. */ + +static gfc_expr * +simplify_minval_maxval (gfc_expr *expr, int sign) +{ + gfc_constructor *c, *extremum; + gfc_intrinsic_sym * specific; + + extremum = NULL; + specific = expr->value.function.isym; + + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) + { + if (c->expr->expr_type != EXPR_CONSTANT) + return NULL; + + if (extremum == NULL) + { + extremum = c; + continue; + } + + min_max_choose (c->expr, extremum->expr, sign); + } + + if (extremum == NULL) + return NULL; + + /* Convert to the correct type and kind. */ + if (expr->ts.type != BT_UNKNOWN) + return gfc_convert_constant (extremum->expr, + expr->ts.type, expr->ts.kind); + + if (specific->ts.type != BT_UNKNOWN) + return gfc_convert_constant (extremum->expr, + specific->ts.type, specific->ts.kind); + + return gfc_copy_expr (extremum->expr); +} + + +gfc_expr * +gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) +{ + if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) + return NULL; + + return simplify_minval_maxval (array, -1); +} + + +gfc_expr * +gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) +{ + if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) + return NULL; + + return simplify_minval_maxval (array, 1); +} + + +gfc_expr * +gfc_simplify_maxexponent (gfc_expr *x) +{ + int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); + return gfc_get_int_expr (gfc_default_integer_kind, &x->where, + gfc_real_kinds[i].max_exponent); +} + + +gfc_expr * +gfc_simplify_minexponent (gfc_expr *x) +{ + int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); + return gfc_get_int_expr (gfc_default_integer_kind, &x->where, + gfc_real_kinds[i].min_exponent); +} + + +gfc_expr * +gfc_simplify_mod (gfc_expr *a, gfc_expr *p) +{ + gfc_expr *result; + mpfr_t tmp; + int kind; + + if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) + return NULL; + + kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; + result = gfc_get_constant_expr (a->ts.type, kind, &a->where); + + switch (a->ts.type) + { + case BT_INTEGER: + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument MOD at %L is zero", &a->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); + break; + + case BT_REAL: + if (mpfr_cmp_ui (p->value.real, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument of MOD at %L is zero", &p->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + gfc_set_model_kind (kind); + mpfr_init (tmp); + mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE); + mpfr_trunc (tmp, tmp); + mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE); + mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE); + mpfr_clear (tmp); + break; + + default: + gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); + } + + return range_check (result, "MOD"); +} + + +gfc_expr * +gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) +{ + gfc_expr *result; + mpfr_t tmp; + int kind; + + if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) + return NULL; + + kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; + result = gfc_get_constant_expr (a->ts.type, kind, &a->where); + + switch (a->ts.type) + { + case BT_INTEGER: + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + /* Result is processor-dependent. This processor just opts + to not handle it at all. */ + gfc_error ("Second argument of MODULO at %L is zero", &a->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); + + break; + + case BT_REAL: + if (mpfr_cmp_ui (p->value.real, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument of MODULO at %L is zero", &p->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + gfc_set_model_kind (kind); + mpfr_init (tmp); + mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE); + mpfr_floor (tmp, tmp); + mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE); + mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE); + mpfr_clear (tmp); + break; + + default: + gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); + } + + return range_check (result, "MODULO"); +} + + +/* Exists for the sole purpose of consistency with other intrinsics. */ +gfc_expr * +gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED, + gfc_expr *fp ATTRIBUTE_UNUSED, + gfc_expr *l ATTRIBUTE_UNUSED, + gfc_expr *to ATTRIBUTE_UNUSED, + gfc_expr *tp ATTRIBUTE_UNUSED) +{ + return NULL; +} + + +gfc_expr * +gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) +{ + gfc_expr *result; + mp_exp_t emin, emax; + int kind; + + if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_sgn (s->value.real) == 0) + { + gfc_error ("Second argument of NEAREST at %L shall not be zero", + &s->where); + return &gfc_bad_expr; + } + + result = gfc_copy_expr (x); + + /* Save current values of emin and emax. */ + emin = mpfr_get_emin (); + emax = mpfr_get_emax (); + + /* Set emin and emax for the current model number. */ + kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0); + mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent - + mpfr_get_prec(result->value.real) + 1); + mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1); + mpfr_check_range (result->value.real, 0, GMP_RNDU); + + if (mpfr_sgn (s->value.real) > 0) + { + mpfr_nextabove (result->value.real); + mpfr_subnormalize (result->value.real, 0, GMP_RNDU); + } + else + { + mpfr_nextbelow (result->value.real); + mpfr_subnormalize (result->value.real, 0, GMP_RNDD); + } + + mpfr_set_emin (emin); + mpfr_set_emax (emax); + + /* Only NaN can occur. Do not use range check as it gives an + error for denormal numbers. */ + if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check) + { + gfc_error ("Result of NEAREST is NaN at %L", &result->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + return result; +} + + +static gfc_expr * +simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) +{ + gfc_expr *itrunc, *result; + int kind; + + kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + itrunc = gfc_copy_expr (e); + mpfr_round (itrunc->value.real, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); + gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where); + + gfc_free_expr (itrunc); + + return range_check (result, name); +} + + +gfc_expr * +gfc_simplify_new_line (gfc_expr *e) +{ + gfc_expr *result; + + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1); + result->value.character.string[0] = '\n'; + + return result; +} + + +gfc_expr * +gfc_simplify_nint (gfc_expr *e, gfc_expr *k) +{ + return simplify_nint ("NINT", e, k); +} + + +gfc_expr * +gfc_simplify_idnint (gfc_expr *e) +{ + return simplify_nint ("IDNINT", e, NULL); +} + + +static gfc_expr * +add_squared (gfc_expr *result, gfc_expr *e) +{ + mpfr_t tmp; + + gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_REAL + && result->expr_type == EXPR_CONSTANT); + + gfc_set_model_kind (result->ts.kind); + mpfr_init (tmp); + mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE); + mpfr_add (result->value.real, result->value.real, tmp, + GFC_RND_MODE); + mpfr_clear (tmp); + + return result; +} + + +static gfc_expr * +do_sqrt (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_REAL + && result->expr_type == EXPR_CONSTANT); + + mpfr_set (result->value.real, e->value.real, GFC_RND_MODE); + mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); + return result; +} + + +gfc_expr * +gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) +{ + gfc_expr *result; + + if (!is_constant_array_expr (e) + || (dim != NULL && !gfc_is_constant_expr (dim))) + return NULL; + + result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); + init_result_expr (result, 0, NULL); + + if (!dim || e->rank == 1) + { + result = simplify_transformation_to_scalar (result, e, NULL, + add_squared); + mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); + } + else + result = simplify_transformation_to_array (result, e, dim, NULL, + add_squared, &do_sqrt); + + return result; +} + + +gfc_expr * +gfc_simplify_not (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + mpz_com (result->value.integer, e->value.integer); + + return range_check (result, "NOT"); +} + + +gfc_expr * +gfc_simplify_null (gfc_expr *mold) +{ + gfc_expr *result; + + if (mold) + { + result = gfc_copy_expr (mold); + result->expr_type = EXPR_NULL; + } + else + result = gfc_get_null_expr (NULL); + + return result; +} + + +gfc_expr * +gfc_simplify_num_images (void) +{ + gfc_expr *result; + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return &gfc_bad_expr; + } + + /* FIXME: gfc_current_locus is wrong. */ + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + mpz_set_si (result->value.integer, 1); + return result; +} + + +gfc_expr * +gfc_simplify_or (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int kind; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; + + switch (x->ts.type) + { + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); + mpz_ior (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "OR"); + + case BT_LOGICAL: + return gfc_get_logical_expr (kind, &x->where, + x->value.logical || y->value.logical); + default: + gcc_unreachable(); + } +} + + +gfc_expr * +gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) +{ + gfc_expr *result; + gfc_constructor *array_ctor, *mask_ctor, *vector_ctor; + + if (!is_constant_array_expr(array) + || !is_constant_array_expr(vector) + || (!gfc_is_constant_expr (mask) + && !is_constant_array_expr(mask))) + return NULL; + + result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); + if (array->ts.type == BT_DERIVED) + result->ts.u.derived = array->ts.u.derived; + + array_ctor = gfc_constructor_first (array->value.constructor); + vector_ctor = vector + ? gfc_constructor_first (vector->value.constructor) + : NULL; + + if (mask->expr_type == EXPR_CONSTANT + && mask->value.logical) + { + /* Copy all elements of ARRAY to RESULT. */ + while (array_ctor) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (array_ctor->expr), + NULL); + + array_ctor = gfc_constructor_next (array_ctor); + vector_ctor = gfc_constructor_next (vector_ctor); + } + } + else if (mask->expr_type == EXPR_ARRAY) + { + /* Copy only those elements of ARRAY to RESULT whose + MASK equals .TRUE.. */ + mask_ctor = gfc_constructor_first (mask->value.constructor); + while (mask_ctor) + { + if (mask_ctor->expr->value.logical) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (array_ctor->expr), + NULL); + vector_ctor = gfc_constructor_next (vector_ctor); + } + + array_ctor = gfc_constructor_next (array_ctor); + mask_ctor = gfc_constructor_next (mask_ctor); + } + } + + /* Append any left-over elements from VECTOR to RESULT. */ + while (vector_ctor) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (vector_ctor->expr), + NULL); + vector_ctor = gfc_constructor_next (vector_ctor); + } + + result->shape = gfc_get_shape (1); + gfc_array_size (result, &result->shape[0]); + + if (array->ts.type == BT_CHARACTER) + result->ts.u.cl = array->ts.u.cl; + + return result; +} + + +static gfc_expr * +do_xor (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_LOGICAL + && result->expr_type == EXPR_CONSTANT); + + result->value.logical = result->value.logical != e->value.logical; + return result; +} + + + +gfc_expr * +gfc_simplify_parity (gfc_expr *e, gfc_expr *dim) +{ + return simplify_transformation (e, dim, NULL, 0, do_xor); +} + + +gfc_expr * +gfc_simplify_popcnt (gfc_expr *e) +{ + int res, k; + mpz_t x; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + k = gfc_validate_kind (e->ts.type, e->ts.kind, false); + + /* Convert argument to unsigned, then count the '1' bits. */ + mpz_init_set (x, e->value.integer); + convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); + res = mpz_popcount (x); + mpz_clear (x); + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res); +} + + +gfc_expr * +gfc_simplify_poppar (gfc_expr *e) +{ + gfc_expr *popcnt; + const char *s; + int i; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + popcnt = gfc_simplify_popcnt (e); + gcc_assert (popcnt); + + s = gfc_extract_int (popcnt, &i); + gcc_assert (!s); + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2); +} + + +gfc_expr * +gfc_simplify_precision (gfc_expr *e) +{ + int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, + gfc_real_kinds[i].precision); +} + + +gfc_expr * +gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 1, gfc_multiply); +} + + +gfc_expr * +gfc_simplify_radix (gfc_expr *e) +{ + int i; + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + + switch (e->ts.type) + { + case BT_INTEGER: + i = gfc_integer_kinds[i].radix; + break; + + case BT_REAL: + i = gfc_real_kinds[i].radix; + break; + + default: + gcc_unreachable (); + } + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); +} + + +gfc_expr * +gfc_simplify_range (gfc_expr *e) +{ + int i; + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + + switch (e->ts.type) + { + case BT_INTEGER: + i = gfc_integer_kinds[i].range; + break; + + case BT_REAL: + case BT_COMPLEX: + i = gfc_real_kinds[i].range; + break; + + default: + gcc_unreachable (); + } + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); +} + + +gfc_expr * +gfc_simplify_real (gfc_expr *e, gfc_expr *k) +{ + gfc_expr *result = NULL; + int kind; + + if (e->ts.type == BT_COMPLEX) + kind = get_kind (BT_REAL, k, "REAL", e->ts.kind); + else + kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind); + + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (convert_boz (e, kind) == &gfc_bad_expr) + return &gfc_bad_expr; + + result = gfc_convert_constant (e, BT_REAL, kind); + if (result == &gfc_bad_expr) + return &gfc_bad_expr; + + return range_check (result, "REAL"); +} + + +gfc_expr * +gfc_simplify_realpart (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); + + return range_check (result, "REALPART"); +} + +gfc_expr * +gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) +{ + gfc_expr *result; + int i, j, len, ncop, nlen; + mpz_t ncopies; + bool have_length = false; + + /* If NCOPIES isn't a constant, there's nothing we can do. */ + if (n->expr_type != EXPR_CONSTANT) + return NULL; + + /* If NCOPIES is negative, it's an error. */ + if (mpz_sgn (n->value.integer) < 0) + { + gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L", + &n->where); + return &gfc_bad_expr; + } + + /* If we don't know the character length, we can do no more. */ + if (e->ts.u.cl && e->ts.u.cl->length + && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) + { + len = mpz_get_si (e->ts.u.cl->length->value.integer); + have_length = true; + } + else if (e->expr_type == EXPR_CONSTANT + && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) + { + len = e->value.character.length; + } + else + return NULL; + + /* If the source length is 0, any value of NCOPIES is valid + and everything behaves as if NCOPIES == 0. */ + mpz_init (ncopies); + if (len == 0) + mpz_set_ui (ncopies, 0); + else + mpz_set (ncopies, n->value.integer); + + /* Check that NCOPIES isn't too large. */ + if (len) + { + mpz_t max, mlen; + int i; + + /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */ + mpz_init (max); + i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); + + if (have_length) + { + mpz_tdiv_q (max, gfc_integer_kinds[i].huge, + e->ts.u.cl->length->value.integer); + } + else + { + mpz_init_set_si (mlen, len); + mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen); + mpz_clear (mlen); + } + + /* The check itself. */ + if (mpz_cmp (ncopies, max) > 0) + { + mpz_clear (max); + mpz_clear (ncopies); + gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L", + &n->where); + return &gfc_bad_expr; + } + + mpz_clear (max); + } + mpz_clear (ncopies); + + /* For further simplification, we need the character string to be + constant. */ + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (len || + (e->ts.u.cl->length && + mpz_sgn (e->ts.u.cl->length->value.integer)) != 0) + { + const char *res = gfc_extract_int (n, &ncop); + gcc_assert (res == NULL); + } + else + ncop = 0; + + len = e->value.character.length; + nlen = ncop * len; + + result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where); + + if (ncop == 0) + return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); + + len = e->value.character.length; + nlen = ncop * len; + + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen); + for (i = 0; i < ncop; i++) + for (j = 0; j < len; j++) + result->value.character.string[j+i*len]= e->value.character.string[j]; + + result->value.character.string[nlen] = '\0'; /* For debugger */ + return result; +} + + +/* This one is a bear, but mainly has to do with shuffling elements. */ + +gfc_expr * +gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, + gfc_expr *pad, gfc_expr *order_exp) +{ + int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS]; + int i, rank, npad, x[GFC_MAX_DIMENSIONS]; + mpz_t index, size; + unsigned long j; + size_t nsource; + gfc_expr *e, *result; + + /* Check that argument expression types are OK. */ + if (!is_constant_array_expr (source) + || !is_constant_array_expr (shape_exp) + || !is_constant_array_expr (pad) + || !is_constant_array_expr (order_exp)) + return NULL; + + /* Proceed with simplification, unpacking the array. */ + + mpz_init (index); + rank = 0; + + for (;;) + { + e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank); + if (e == NULL) + break; + + gfc_extract_int (e, &shape[rank]); + + gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS); + gcc_assert (shape[rank] >= 0); + + rank++; + } + + gcc_assert (rank > 0); + + /* Now unpack the order array if present. */ + if (order_exp == NULL) + { + for (i = 0; i < rank; i++) + order[i] = i; + } + else + { + for (i = 0; i < rank; i++) + x[i] = 0; + + for (i = 0; i < rank; i++) + { + e = gfc_constructor_lookup_expr (order_exp->value.constructor, i); + gcc_assert (e); + + gfc_extract_int (e, &order[i]); + + gcc_assert (order[i] >= 1 && order[i] <= rank); + order[i]--; + gcc_assert (x[order[i]] == 0); + x[order[i]] = 1; + } + } + + /* Count the elements in the source and padding arrays. */ + + npad = 0; + if (pad != NULL) + { + gfc_array_size (pad, &size); + npad = mpz_get_ui (size); + mpz_clear (size); + } + + gfc_array_size (source, &size); + nsource = mpz_get_ui (size); + mpz_clear (size); + + /* If it weren't for that pesky permutation we could just loop + through the source and round out any shortage with pad elements. + But no, someone just had to have the compiler do something the + user should be doing. */ + + for (i = 0; i < rank; i++) + x[i] = 0; + + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + if (source->ts.type == BT_DERIVED) + result->ts.u.derived = source->ts.u.derived; + result->rank = rank; + result->shape = gfc_get_shape (rank); + for (i = 0; i < rank; i++) + mpz_init_set_ui (result->shape[i], shape[i]); + + while (nsource > 0 || npad > 0) + { + /* Figure out which element to extract. */ + mpz_set_ui (index, 0); + + for (i = rank - 1; i >= 0; i--) + { + mpz_add_ui (index, index, x[order[i]]); + if (i != 0) + mpz_mul_ui (index, index, shape[order[i - 1]]); + } + + if (mpz_cmp_ui (index, INT_MAX) > 0) + gfc_internal_error ("Reshaped array too large at %C"); + + j = mpz_get_ui (index); + + if (j < nsource) + e = gfc_constructor_lookup_expr (source->value.constructor, j); + else + { + gcc_assert (npad > 0); + + j = j - nsource; + j = j % npad; + e = gfc_constructor_lookup_expr (pad->value.constructor, j); + } + gcc_assert (e); + + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (e), &e->where); + + /* Calculate the next element. */ + i = 0; + +inc: + if (++x[i] < shape[i]) + continue; + x[i++] = 0; + if (i < rank) + goto inc; + + break; + } + + mpz_clear (index); + + return result; +} + + +gfc_expr * +gfc_simplify_rrspacing (gfc_expr *x) +{ + gfc_expr *result; + int i; + long int e, p; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (x->ts.type, x->ts.kind, false); + + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); + mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); + + /* Special case x = -0 and 0. */ + if (mpfr_sgn (result->value.real) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + /* | x * 2**(-e) | * 2**p. */ + e = - (long int) mpfr_get_exp (x->value.real); + mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE); + + p = (long int) gfc_real_kinds[i].digits; + mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE); + + return range_check (result, "RRSPACING"); +} + + +gfc_expr * +gfc_simplify_scale (gfc_expr *x, gfc_expr *i) +{ + int k, neg_flag, power, exp_range; + mpfr_t scale, radix; + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); + + if (mpfr_sgn (x->value.real) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + k = gfc_validate_kind (BT_REAL, x->ts.kind, false); + + exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent; + + /* This check filters out values of i that would overflow an int. */ + if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0 + || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0) + { + gfc_error ("Result of SCALE overflows its kind at %L", &result->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + /* Compute scale = radix ** power. */ + power = mpz_get_si (i->value.integer); + + if (power >= 0) + neg_flag = 0; + else + { + neg_flag = 1; + power = -power; + } + + gfc_set_model_kind (x->ts.kind); + mpfr_init (scale); + mpfr_init (radix); + mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE); + mpfr_pow_ui (scale, radix, power, GFC_RND_MODE); + + if (neg_flag) + mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE); + else + mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE); + + mpfr_clears (scale, radix, NULL); + + return range_check (result, "SCALE"); +} + + +/* Variants of strspn and strcspn that operate on wide characters. */ + +static size_t +wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2) +{ + size_t i = 0; + const gfc_char_t *c; + + while (s1[i]) + { + for (c = s2; *c; c++) + { + if (s1[i] == *c) + break; + } + if (*c == '\0') + break; + i++; + } + + return i; +} + +static size_t +wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2) +{ + size_t i = 0; + const gfc_char_t *c; + + while (s1[i]) + { + for (c = s2; *c; c++) + { + if (s1[i] == *c) + break; + } + if (*c) + break; + i++; + } + + return i; +} + + +gfc_expr * +gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) +{ + gfc_expr *result; + int back; + size_t i; + size_t indx, len, lenc; + int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT) + return NULL; + + if (b != NULL && b->value.logical != 0) + back = 1; + else + back = 0; + + len = e->value.character.length; + lenc = c->value.character.length; + + if (len == 0 || lenc == 0) + { + indx = 0; + } + else + { + if (back == 0) + { + indx = wide_strcspn (e->value.character.string, + c->value.character.string) + 1; + if (indx > len) + indx = 0; + } + else + { + i = 0; + for (indx = len; indx > 0; indx--) + { + for (i = 0; i < lenc; i++) + { + if (c->value.character.string[i] + == e->value.character.string[indx - 1]) + break; + } + if (i < lenc) + break; + } + } + } + + result = gfc_get_int_expr (k, &e->where, indx); + return range_check (result, "SCAN"); +} + + +gfc_expr * +gfc_simplify_selected_char_kind (gfc_expr *e) +{ + int kind; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_compare_with_Cstring (e, "ascii", false) == 0 + || gfc_compare_with_Cstring (e, "default", false) == 0) + kind = 1; + else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0) + kind = 4; + else + kind = -1; + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); +} + + +gfc_expr * +gfc_simplify_selected_int_kind (gfc_expr *e) +{ + int i, kind, range; + + if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL) + return NULL; + + kind = INT_MAX; + + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].range >= range + && gfc_integer_kinds[i].kind < kind) + kind = gfc_integer_kinds[i].kind; + + if (kind == INT_MAX) + kind = -1; + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); +} + + +gfc_expr * +gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx) +{ + int range, precision, radix, i, kind, found_precision, found_range, + found_radix; + locus *loc = &gfc_current_locus; + + if (p == NULL) + precision = 0; + else + { + if (p->expr_type != EXPR_CONSTANT + || gfc_extract_int (p, &precision) != NULL) + return NULL; + loc = &p->where; + } + + if (q == NULL) + range = 0; + else + { + if (q->expr_type != EXPR_CONSTANT + || gfc_extract_int (q, &range) != NULL) + return NULL; + + if (!loc) + loc = &q->where; + } + + if (rdx == NULL) + radix = 0; + else + { + if (rdx->expr_type != EXPR_CONSTANT + || gfc_extract_int (rdx, &radix) != NULL) + return NULL; + + if (!loc) + loc = &rdx->where; + } + + kind = INT_MAX; + found_precision = 0; + found_range = 0; + found_radix = 0; + + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + { + if (gfc_real_kinds[i].precision >= precision) + found_precision = 1; + + if (gfc_real_kinds[i].range >= range) + found_range = 1; + + if (gfc_real_kinds[i].radix >= radix) + found_radix = 1; + + if (gfc_real_kinds[i].precision >= precision + && gfc_real_kinds[i].range >= range + && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind) + kind = gfc_real_kinds[i].kind; + } + + if (kind == INT_MAX) + { + if (found_radix && found_range && !found_precision) + kind = -1; + else if (found_radix && found_precision && !found_range) + kind = -2; + else if (found_radix && !found_precision && !found_range) + kind = -3; + else if (found_radix) + kind = -4; + else + kind = -5; + } + + return gfc_get_int_expr (gfc_default_integer_kind, loc, kind); +} + + +gfc_expr * +gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) +{ + gfc_expr *result; + mpfr_t exp, absv, log2, pow2, frac; + unsigned long exp2; + + if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); + + if (mpfr_sgn (x->value.real) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + gfc_set_model_kind (x->ts.kind); + mpfr_init (absv); + mpfr_init (log2); + mpfr_init (exp); + mpfr_init (pow2); + mpfr_init (frac); + + mpfr_abs (absv, x->value.real, GFC_RND_MODE); + mpfr_log2 (log2, absv, GFC_RND_MODE); + + mpfr_trunc (log2, log2); + mpfr_add_ui (exp, log2, 1, GFC_RND_MODE); + + /* Old exponent value, and fraction. */ + mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE); + + mpfr_div (frac, absv, pow2, GFC_RND_MODE); + + /* New exponent. */ + exp2 = (unsigned long) mpz_get_d (i->value.integer); + mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE); + + mpfr_clears (absv, log2, pow2, frac, NULL); + + return range_check (result, "SET_EXPONENT"); +} + + +gfc_expr * +gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) +{ + mpz_t shape[GFC_MAX_DIMENSIONS]; + gfc_expr *result, *e, *f; + gfc_array_ref *ar; + int n; + gfc_try t; + int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); + + result = gfc_get_array_expr (BT_INTEGER, k, &source->where); + + if (source->rank == 0) + return result; + + if (source->expr_type == EXPR_VARIABLE) + { + ar = gfc_find_array_ref (source); + t = gfc_array_ref_shape (ar, shape); + } + else if (source->shape) + { + t = SUCCESS; + for (n = 0; n < source->rank; n++) + { + mpz_init (shape[n]); + mpz_set (shape[n], source->shape[n]); + } + } + else + t = FAILURE; + + for (n = 0; n < source->rank; n++) + { + e = gfc_get_constant_expr (BT_INTEGER, k, &source->where); + + if (t == SUCCESS) + { + mpz_set (e->value.integer, shape[n]); + mpz_clear (shape[n]); + } + else + { + mpz_set_ui (e->value.integer, n + 1); + + f = gfc_simplify_size (source, e, NULL); + gfc_free_expr (e); + if (f == NULL) + { + gfc_free_expr (result); + return NULL; + } + else + e = f; + } + + gfc_constructor_append_expr (&result->value.constructor, e, NULL); + } + + return result; +} + + +gfc_expr * +gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + mpz_t size; + gfc_expr *return_value; + int d; + int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; + + /* 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 = gfc_simplify_size (array->value.op.op1, dim, kind); + if (simplified) + return simplified; + + replacement = array->value.op.op2; + } + break; + } + + /* Try to reduce it directly if possible. */ + simplified = gfc_simplify_size (replacement, dim, kind); + + /* Otherwise, we build a new SIZE call. This is hopefully at least + simpler than the original one. */ + if (!simplified) + simplified = gfc_build_intrinsic_call (gfc_current_ns, + GFC_ISYM_SIZE, "size", + array->where, 3, + gfc_copy_expr (replacement), + gfc_copy_expr (dim), + gfc_copy_expr (kind)); + + return simplified; + } + + if (dim == NULL) + { + if (gfc_array_size (array, &size) == FAILURE) + return NULL; + } + else + { + if (dim->expr_type != EXPR_CONSTANT) + return NULL; + + d = mpz_get_ui (dim->value.integer) - 1; + if (gfc_array_dimen_size (array, d, &size) == FAILURE) + return NULL; + } + + return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size)); + mpz_clear (size); + return return_value; +} + + +gfc_expr * +gfc_simplify_sign (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_INTEGER: + mpz_abs (result->value.integer, x->value.integer); + if (mpz_sgn (y->value.integer) < 0) + mpz_neg (result->value.integer, result->value.integer); + break; + + case BT_REAL: + if (gfc_option.flag_sign_zero) + mpfr_copysign (result->value.real, x->value.real, y->value.real, + GFC_RND_MODE); + else + mpfr_setsign (result->value.real, x->value.real, + mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); + break; + + default: + gfc_internal_error ("Bad type in gfc_simplify_sign"); + } + + return result; +} + + +gfc_expr * +gfc_simplify_sin (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model (x->value.real); + mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_sin(): Bad type"); + } + + return range_check (result, "SIN"); +} + + +gfc_expr * +gfc_simplify_sinh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gcc_unreachable (); + } + + return range_check (result, "SINH"); +} + + +/* The argument is always a double precision real that is converted to + single precision. TODO: Rounding! */ + +gfc_expr * +gfc_simplify_sngl (gfc_expr *a) +{ + gfc_expr *result; + + if (a->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_real2real (a, gfc_default_real_kind); + return range_check (result, "SNGL"); +} + + +gfc_expr * +gfc_simplify_spacing (gfc_expr *x) +{ + gfc_expr *result; + int i; + long int en, ep; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (x->ts.type, x->ts.kind, false); + + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); + + /* Special case x = 0 and -0. */ + mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); + if (mpfr_sgn (result->value.real) == 0) + { + mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); + return result; + } + + /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p + are the radix, exponent of x, and precision. This excludes the + possibility of subnormal numbers. Fortran 2003 states the result is + b**max(e - p, emin - 1). */ + + ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits; + en = (long int) gfc_real_kinds[i].min_exponent - 1; + en = en > ep ? en : ep; + + mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); + mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE); + + return range_check (result, "SPACING"); +} + + +gfc_expr * +gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr) +{ + gfc_expr *result = 0L; + int i, j, dim, ncopies; + mpz_t size; + + if ((!gfc_is_constant_expr (source) + && !is_constant_array_expr (source)) + || !gfc_is_constant_expr (dim_expr) + || !gfc_is_constant_expr (ncopies_expr)) + return NULL; + + gcc_assert (dim_expr->ts.type == BT_INTEGER); + gfc_extract_int (dim_expr, &dim); + dim -= 1; /* zero-base DIM */ + + gcc_assert (ncopies_expr->ts.type == BT_INTEGER); + gfc_extract_int (ncopies_expr, &ncopies); + ncopies = MAX (ncopies, 0); + + /* Do not allow the array size to exceed the limit for an array + constructor. */ + if (source->expr_type == EXPR_ARRAY) + { + if (gfc_array_size (source, &size) == FAILURE) + gfc_internal_error ("Failure getting length of a constant array."); + } + else + mpz_init_set_ui (size, 1); + + if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor) + return NULL; + + if (source->expr_type == EXPR_CONSTANT) + { + gcc_assert (dim == 0); + + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + if (source->ts.type == BT_DERIVED) + result->ts.u.derived = source->ts.u.derived; + result->rank = 1; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], ncopies); + + for (i = 0; i < ncopies; ++i) + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (source), NULL); + } + else if (source->expr_type == EXPR_ARRAY) + { + int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS]; + gfc_constructor *source_ctor; + + gcc_assert (source->rank < GFC_MAX_DIMENSIONS); + gcc_assert (dim >= 0 && dim <= source->rank); + + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + if (source->ts.type == BT_DERIVED) + result->ts.u.derived = source->ts.u.derived; + result->rank = source->rank + 1; + result->shape = gfc_get_shape (result->rank); + + for (i = 0, j = 0; i < result->rank; ++i) + { + if (i != dim) + mpz_init_set (result->shape[i], source->shape[j++]); + else + mpz_init_set_si (result->shape[i], ncopies); + + extent[i] = mpz_get_si (result->shape[i]); + rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1]; + } + + offset = 0; + for (source_ctor = gfc_constructor_first (source->value.constructor); + source_ctor; source_ctor = gfc_constructor_next (source_ctor)) + { + for (i = 0; i < ncopies; ++i) + gfc_constructor_insert_expr (&result->value.constructor, + gfc_copy_expr (source_ctor->expr), + NULL, offset + i * rstride[dim]); + + offset += (dim == 0 ? ncopies : 1); + } + } + else + /* FIXME: Returning here avoids a regression in array_simplify_1.f90. + Replace NULL with gcc_unreachable() after implementing + gfc_simplify_cshift(). */ + return NULL; + + if (source->ts.type == BT_CHARACTER) + result->ts.u.cl = source->ts.u.cl; + + return result; +} + + +gfc_expr * +gfc_simplify_sqrt (gfc_expr *e) +{ + gfc_expr *result = NULL; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + switch (e->ts.type) + { + case BT_REAL: + if (mpfr_cmp_si (e->value.real, 0) < 0) + { + gfc_error ("Argument of SQRT at %L has a negative value", + &e->where); + return &gfc_bad_expr; + } + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model (e->value.real); + + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("invalid argument of SQRT at %L", &e->where); + } + + return range_check (result, "SQRT"); +} + + +gfc_expr * +gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 0, gfc_add); +} + + +gfc_expr * +gfc_simplify_tan (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gcc_unreachable (); + } + + return range_check (result, "TAN"); +} + + +gfc_expr * +gfc_simplify_tanh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gcc_unreachable (); + } + + return range_check (result, "TANH"); +} + + +gfc_expr * +gfc_simplify_tiny (gfc_expr *e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (BT_REAL, e->ts.kind, false); + + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); + + return result; +} + + +gfc_expr * +gfc_simplify_trailz (gfc_expr *e) +{ + unsigned long tz, bs; + int i; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + bs = gfc_integer_kinds[i].bit_size; + tz = mpz_scan1 (e->value.integer, 0); + + return gfc_get_int_expr (gfc_default_integer_kind, + &e->where, MIN (tz, bs)); +} + + +gfc_expr * +gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) +{ + gfc_expr *result; + gfc_expr *mold_element; + size_t source_size; + size_t result_size; + size_t result_elt_size; + size_t buffer_size; + mpz_t tmp; + unsigned char *buffer; + + if (!gfc_is_constant_expr (source) + || (gfc_init_expr_flag && !gfc_is_constant_expr (mold)) + || !gfc_is_constant_expr (size)) + return NULL; + + if (source->expr_type == EXPR_FUNCTION) + return NULL; + + /* Calculate the size of the source. */ + if (source->expr_type == EXPR_ARRAY + && gfc_array_size (source, &tmp) == FAILURE) + gfc_internal_error ("Failure getting length of a constant array."); + + source_size = gfc_target_expr_size (source); + + /* Create an empty new expression with the appropriate characteristics. */ + result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind, + &source->where); + result->ts = mold->ts; + + mold_element = mold->expr_type == EXPR_ARRAY + ? gfc_constructor_first (mold->value.constructor)->expr + : mold; + + /* Set result character length, if needed. Note that this needs to be + set even for array expressions, in order to pass this information into + gfc_target_interpret_expr. */ + if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element)) + result->value.character.length = mold_element->value.character.length; + + /* Set the number of elements in the result, and determine its size. */ + result_elt_size = gfc_target_expr_size (mold_element); + if (result_elt_size == 0) + { + gfc_free_expr (result); + return NULL; + } + + if (mold->expr_type == EXPR_ARRAY || mold->rank || size) + { + int result_length; + + result->expr_type = EXPR_ARRAY; + result->rank = 1; + + if (size) + result_length = (size_t)mpz_get_ui (size->value.integer); + else + { + result_length = source_size / result_elt_size; + if (result_length * result_elt_size < source_size) + result_length += 1; + } + + result->shape = gfc_get_shape (1); + mpz_init_set_ui (result->shape[0], result_length); + + result_size = result_length * result_elt_size; + } + else + { + result->rank = 0; + result_size = result_elt_size; + } + + if (gfc_option.warn_surprising && source_size < result_size) + gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: " + "source size %ld < result size %ld", &source->where, + (long) source_size, (long) result_size); + + /* Allocate the buffer to store the binary version of the source. */ + buffer_size = MAX (source_size, result_size); + buffer = (unsigned char*)alloca (buffer_size); + memset (buffer, 0, buffer_size); + + /* Now write source to the buffer. */ + gfc_target_encode_expr (source, buffer, buffer_size); + + /* And read the buffer back into the new expression. */ + gfc_target_interpret_expr (buffer, buffer_size, result); + + return result; +} + + +gfc_expr * +gfc_simplify_transpose (gfc_expr *matrix) +{ + int row, matrix_rows, col, matrix_cols; + gfc_expr *result; + + if (!is_constant_array_expr (matrix)) + return NULL; + + gcc_assert (matrix->rank == 2); + + result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind, + &matrix->where); + result->rank = 2; + result->shape = gfc_get_shape (result->rank); + mpz_set (result->shape[0], matrix->shape[1]); + mpz_set (result->shape[1], matrix->shape[0]); + + if (matrix->ts.type == BT_CHARACTER) + result->ts.u.cl = matrix->ts.u.cl; + else if (matrix->ts.type == BT_DERIVED) + result->ts.u.derived = matrix->ts.u.derived; + + matrix_rows = mpz_get_si (matrix->shape[0]); + matrix_cols = mpz_get_si (matrix->shape[1]); + for (row = 0; row < matrix_rows; ++row) + for (col = 0; col < matrix_cols; ++col) + { + gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor, + col * matrix_rows + row); + gfc_constructor_insert_expr (&result->value.constructor, + gfc_copy_expr (e), &matrix->where, + row * matrix_cols + col); + } + + return result; +} + + +gfc_expr * +gfc_simplify_trim (gfc_expr *e) +{ + gfc_expr *result; + int count, i, len, lentrim; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + len = e->value.character.length; + for (count = 0, i = 1; i <= len; ++i) + { + if (e->value.character.string[len - i] == ' ') + count++; + else + break; + } + + lentrim = len - count; + + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim); + for (i = 0; i < lentrim; i++) + result->value.character.string[i] = e->value.character.string[i]; + + return result; +} + + +gfc_expr * +gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) +{ + gfc_expr *result; + gfc_ref *ref; + gfc_array_spec *as; + gfc_constructor *sub_cons; + bool first_image; + int d; + + if (!is_constant_array_expr (sub)) + goto not_implemented; /* 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) + goto not_implemented; /* 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; + + if (sub_cons == NULL) + { + gfc_error ("Too few elements in expression for SUB= argument at %L", + &sub->where); + return &gfc_bad_expr; + } + + ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, + NULL, true); + if (ca_bound == NULL) + goto not_implemented; /* 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); + } + + if (sub_cons != NULL) + { + gfc_error ("Too many elements in expression for SUB= argument at %L", + &sub->where); + return &gfc_bad_expr; + } + + 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; + +not_implemented: + gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant " + "cobounds at %L", &coarray->where); + return &gfc_bad_expr; +} + + +gfc_expr * +gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) +{ + gfc_ref *ref; + gfc_array_spec *as; + int d; + + if (coarray == NULL) + { + gfc_expr *result; + /* FIXME: gfc_current_locus is wrong. */ + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + mpz_set_si (result->value.integer, 1); + return result; + } + + gcc_assert (coarray->expr_type == EXPR_VARIABLE); + + /* 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) + goto not_implemented; /* return NULL;*/ + + if (dim == NULL) + { + /* Multi-dimensional bounds. */ + gfc_expr *bounds[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + + /* Simplify the bounds for each dimension. */ + for (d = 0; d < as->corank; d++) + { + bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0, + as, NULL, true); + if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) + { + int j; + + for (j = 0; j < d; j++) + gfc_free_expr (bounds[j]); + if (bounds[d] == NULL) + goto not_implemented; + return bounds[d]; + } + } + + /* Allocate the result expression. */ + e = gfc_get_expr (); + e->where = coarray->where; + e->expr_type = EXPR_ARRAY; + e->ts.type = BT_INTEGER; + e->ts.kind = gfc_default_integer_kind; + + 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 + { + gfc_expr *e; + /* A DIM argument is specified. */ + if (dim->expr_type != EXPR_CONSTANT) + goto not_implemented; /*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 (coarray, NULL, d + as->rank, 0, as, NULL, true);*/ + e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true); + if (e != NULL) + return e; + else + goto not_implemented; + } + +not_implemented: + gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant " + "cobounds at %L", &coarray->where); + return &gfc_bad_expr; +} + + +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) +{ + gfc_expr *e; + /* return simplify_cobound (array, dim, kind, 1);*/ + + e = simplify_cobound (array, dim, kind, 1); + if (e != NULL) + return e; + + gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant " + "cobounds at %L", &array->where); + return &gfc_bad_expr; +} + + +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) + return NULL; + + if (b != NULL && b->value.logical != 0) + back = 1; + else + back = 0; + + result = gfc_get_constant_expr (BT_INTEGER, k, &s->where); + + len = s->value.character.length; + lenset = set->value.character.length; + + if (len == 0) + { + mpz_set_ui (result->value.integer, 0); + return result; + } + + if (back == 0) + { + if (lenset == 0) + { + mpz_set_ui (result->value.integer, 1); + return result; + } + + index = wide_strspn (s->value.character.string, + set->value.character.string) + 1; + if (index > len) + index = 0; + + } + else + { + if (lenset == 0) + { + mpz_set_ui (result->value.integer, len); + return result; + } + for (index = len; index > 0; index --) + { + for (i = 0; i < lenset; i++) + { + if (s->value.character.string[index - 1] + == set->value.character.string[i]) + break; + } + if (i == lenset) + break; + } + } + + mpz_set_ui (result->value.integer, index); + return result; +} + + +gfc_expr * +gfc_simplify_xor (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int kind; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; + + switch (x->ts.type) + { + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); + mpz_xor (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "XOR"); + + case BT_LOGICAL: + return gfc_get_logical_expr (kind, &x->where, + (x->value.logical && !y->value.logical) + || (!x->value.logical && y->value.logical)); + + default: + gcc_unreachable (); + } +} + + +/****************** Constant simplification *****************/ + +/* Master function to convert one constant to another. While this is + used as a simplification function, it requires the destination type + and kind information which is supplied by a special case in + do_simplify(). */ + +gfc_expr * +gfc_convert_constant (gfc_expr *e, bt type, int kind) +{ + gfc_expr *g, *result, *(*f) (gfc_expr *, int); + gfc_constructor *c; + + switch (e->ts.type) + { + case BT_INTEGER: + switch (type) + { + case BT_INTEGER: + f = gfc_int2int; + break; + case BT_REAL: + f = gfc_int2real; + break; + case BT_COMPLEX: + f = gfc_int2complex; + break; + case BT_LOGICAL: + f = gfc_int2log; + break; + default: + goto oops; + } + break; + + case BT_REAL: + switch (type) + { + case BT_INTEGER: + f = gfc_real2int; + break; + case BT_REAL: + f = gfc_real2real; + break; + case BT_COMPLEX: + f = gfc_real2complex; + break; + default: + goto oops; + } + break; + + case BT_COMPLEX: + switch (type) + { + case BT_INTEGER: + f = gfc_complex2int; + break; + case BT_REAL: + f = gfc_complex2real; + break; + case BT_COMPLEX: + f = gfc_complex2complex; + break; + + default: + goto oops; + } + break; + + case BT_LOGICAL: + switch (type) + { + case BT_INTEGER: + f = gfc_log2int; + break; + case BT_LOGICAL: + f = gfc_log2log; + break; + default: + goto oops; + } + break; + + case BT_HOLLERITH: + switch (type) + { + case BT_INTEGER: + f = gfc_hollerith2int; + break; + + case BT_REAL: + f = gfc_hollerith2real; + break; + + case BT_COMPLEX: + f = gfc_hollerith2complex; + break; + + case BT_CHARACTER: + f = gfc_hollerith2character; + break; + + case BT_LOGICAL: + f = gfc_hollerith2logical; + break; + + default: + goto oops; + } + break; + + default: + oops: + gfc_internal_error ("gfc_convert_constant(): Unexpected type"); + } + + result = NULL; + + switch (e->expr_type) + { + case EXPR_CONSTANT: + result = f (e, kind); + if (result == NULL) + return &gfc_bad_expr; + break; + + case EXPR_ARRAY: + if (!gfc_is_constant_expr (e)) + break; + + result = gfc_get_array_expr (type, kind, &e->where); + result->shape = gfc_copy_shape (e->shape, e->rank); + result->rank = e->rank; + + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + { + gfc_expr *tmp; + if (c->iterator == NULL) + tmp = f (c->expr, kind); + else + { + g = gfc_convert_constant (c->expr, type, kind); + if (g == &gfc_bad_expr) + { + gfc_free_expr (result); + return g; + } + tmp = g; + } + + if (tmp == NULL) + { + gfc_free_expr (result); + return NULL; + } + + gfc_constructor_append_expr (&result->value.constructor, + tmp, &c->where); + } + + break; + + default: + break; + } + + return result; +} + + +/* Function for converting character constants. */ +gfc_expr * +gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) +{ + gfc_expr *result; + int i; + + if (!gfc_is_constant_expr (e)) + return NULL; + + if (e->expr_type == EXPR_CONSTANT) + { + /* Simple case of a scalar. */ + result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where); + if (result == NULL) + return &gfc_bad_expr; + + result->value.character.length = e->value.character.length; + result->value.character.string + = gfc_get_wide_string (e->value.character.length + 1); + memcpy (result->value.character.string, e->value.character.string, + (e->value.character.length + 1) * sizeof (gfc_char_t)); + + /* Check we only have values representable in the destination kind. */ + for (i = 0; i < result->value.character.length; i++) + if (!gfc_check_character_range (result->value.character.string[i], + kind)) + { + gfc_error ("Character '%s' in string at %L cannot be converted " + "into character kind %d", + gfc_print_wide_char (result->value.character.string[i]), + &e->where, kind); + return &gfc_bad_expr; + } + + return result; + } + else if (e->expr_type == EXPR_ARRAY) + { + /* For an array constructor, we convert each constructor element. */ + gfc_constructor *c; + + result = gfc_get_array_expr (type, kind, &e->where); + result->shape = gfc_copy_shape (e->shape, e->rank); + result->rank = e->rank; + result->ts.u.cl = e->ts.u.cl; + + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + { + gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind); + if (tmp == &gfc_bad_expr) + { + gfc_free_expr (result); + return &gfc_bad_expr; + } + + if (tmp == NULL) + { + gfc_free_expr (result); + return NULL; + } + + gfc_constructor_append_expr (&result->value.constructor, + tmp, &c->where); + } + + return result; + } + else + return NULL; +} + + +gfc_expr * +gfc_simplify_compiler_options (void) +{ + char *str; + gfc_expr *result; + + str = gfc_get_option_string (); + result = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, str, strlen (str)); + gfc_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); +} -- cgit v1.2.3