X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fsimplify.c;h=ba2d7f5a83d5d8534d5300f74cc52cc0886545f2;hb=6292970e8788d24d3675650bcd24a5b9ca41287b;hp=49a4affd3c31b8766c64ca68b947723c95e13bf0;hpb=c83d115e711bab71efbbcc0c1bb9fcb7e400b3e1;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 49a4affd3c3..ba2d7f5a83d 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -1,6 +1,6 @@ /* Simplify intrinsic functions at compile-time. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 - Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, + 2010 Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb This file is part of GCC. @@ -26,6 +26,8 @@ along with GCC; see the file COPYING3. If not see #include "arith.h" #include "intrinsic.h" #include "target-memory.h" +#include "constructor.h" + gfc_expr gfc_bad_expr; @@ -41,15 +43,12 @@ gfc_expr gfc_bad_expr; be a part of the new expression. NULL pointer indicating that no simplification was possible and - the original expression should remain intact. If the - simplification function sets the type and/or the function name - via the pointer gfc_simple_expression, then this type is - retained. + the original expression should remain intact. An expression pointer to gfc_bad_expr (a static placeholder) - indicating that some error has prevented simplification. For - example, sqrt(-1.0). The error is generated within the function - and should be propagated upwards + 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 @@ -58,7 +57,8 @@ gfc_expr gfc_bad_expr; subroutine may have to look at the type of an argument as part of its processing. - Array arguments are never passed to these subroutines. + 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 @@ -132,20 +132,6 @@ get_kind (bt type, gfc_expr *k, const char *name, int default_kind) } -/* Helper function to get an integer constant with a kind number given - by an integer constant expression. */ -static gfc_expr * -int_expr_with_kind (int i, gfc_expr *kind, const char *name) -{ - gfc_expr *res = gfc_int_expr (i); - res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind); - if (res->ts.kind == -1) - return NULL; - else - return res; -} - - /* 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 @@ -211,52 +197,457 @@ convert_mpz_to_signed (mpz_t x, int bitsize) } -/********************** Simplification functions *****************************/ +/* In-place convert BOZ to REAL of the specified kind. */ -gfc_expr * -gfc_simplify_abs (gfc_expr *e) +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) + 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 (e->expr_type != EXPR_CONSTANT) - return NULL; + if (!dim || array->rank == 1) + return gfc_get_constant_expr (type, kind, where); - switch (e->ts.type) + 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) { - case BT_INTEGER: - result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where); + gfc_constructor_append_expr (&result->value.constructor, + gfc_get_constant_expr (type, kind, where), + NULL); + } - mpz_abs (result->value.integer, e->value.integer); + return result; +} - result = range_check (result, "IABS"); - break; - case BT_REAL: - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); +typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*); - mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE); +/* Wrapper function, implements 'op1 += 1'. Only called if MASK + of COUNT intrinsic is .TRUE.. - result = range_check (result, "ABS"); - break; + Interface and implimentation mimics arith functions as + gfc_add, gfc_multiply, etc. */ - case BT_COMPLEX: - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); +static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr *result; - gfc_set_model_kind (e->ts.kind); + gcc_assert (op1->ts.type == BT_INTEGER); + gcc_assert (op2->ts.type == BT_LOGICAL); + gcc_assert (op2->value.logical); - mpfr_hypot (result->value.real, e->value.complex.r, - e->value.complex.i, GFC_RND_MODE); - result = range_check (result, "CABS"); - break; + result = gfc_copy_expr (op1); + mpz_add_ui (result->value.integer, result->value.integer, 1); - default: - gfc_internal_error ("gfc_simplify_abs(): Bad type"); + 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(). */ + +static gfc_expr * +simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask, transformational_op op) +{ + mpz_t size; + int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; + gfc_expr **arrayvec, **resultvec, **base, **src, **dest; + gfc_constructor *array_ctor, *mask_ctor, *result_ctor; + + int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], + tmpstride[GFC_MAX_DIMENSIONS]; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + /* Build an indexed table for array element expressions to minimize + linked-list traversal. Masked elements are set to NULL. */ + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + + arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize); + + array_ctor = 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) + { + result_ctor->expr = resultvec[i]; + result_ctor = gfc_constructor_next (result_ctor); } + gfc_free (arrayvec); + gfc_free (resultvec); return result; } + +/********************** 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) { @@ -303,11 +694,9 @@ simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii) return &gfc_bad_expr; } - result = gfc_constant_result (BT_CHARACTER, kind, &e->where); - result->value.character.string = gfc_get_wide_string (2); - result->value.character.length = 1; + result = gfc_get_character_expr (kind, &e->where, NULL, 1); result->value.character.string[0] = mpz_get_ui (e->value.integer); - result->value.character.string[1] = '\0'; /* For debugger */ + return result; } @@ -331,17 +720,28 @@ gfc_simplify_acos (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - if (mpfr_cmp_si (x->value.real, 1) > 0 - || mpfr_cmp_si (x->value.real, -1) < 0) + switch (x->ts.type) { - gfc_error ("Argument of ACOS at %L must be between -1 and 1", - &x->where); - return &gfc_bad_expr; - } + 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; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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; - mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); + default: + gfc_internal_error ("in gfc_simplify_acos(): Bad type"); + } return range_check (result, "ACOS"); } @@ -354,16 +754,28 @@ gfc_simplify_acosh (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - if (mpfr_cmp_si (x->value.real, 1) < 0) + switch (x->ts.type) { - gfc_error ("Argument of ACOSH at %L must not be less than 1", - &x->where); - return &gfc_bad_expr; - } + 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; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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; - mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE); + default: + gfc_internal_error ("in gfc_simplify_acosh(): Bad type"); + } return range_check (result, "ACOSH"); } @@ -380,11 +792,6 @@ gfc_simplify_adjustl (gfc_expr *e) len = e->value.character.length; - result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); - - result->value.character.length = len; - result->value.character.string = gfc_get_wide_string (len + 1); - for (count = 0, i = 0; i < len; ++i) { ch = e->value.character.string[i]; @@ -393,14 +800,10 @@ gfc_simplify_adjustl (gfc_expr *e) ++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]; - for (i = len - count; i < len; ++i) - result->value.character.string[i] = ' '; - - result->value.character.string[len] = '\0'; /* For debugger */ - return result; } @@ -417,11 +820,6 @@ gfc_simplify_adjustr (gfc_expr *e) len = e->value.character.length; - result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); - - result->value.character.length = len; - result->value.character.string = gfc_get_wide_string (len + 1); - for (count = 0, i = len - 1; i >= 0; --i) { ch = e->value.character.string[i]; @@ -430,14 +828,13 @@ gfc_simplify_adjustr (gfc_expr *e) ++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]; - result->value.character.string[len] = '\0'; /* For debugger */ - return result; } @@ -450,8 +847,8 @@ gfc_simplify_aimag (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); - mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE); + 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"); } @@ -471,10 +868,10 @@ gfc_simplify_aint (gfc_expr *e, gfc_expr *k) 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"); @@ -482,6 +879,25 @@ gfc_simplify_aint (gfc_expr *e, gfc_expr *k) gfc_expr * +gfc_simplify_all (gfc_expr *mask, gfc_expr *dim) +{ + gfc_expr *result; + + if (!is_constant_array_expr (mask) + || !gfc_is_constant_expr (dim)) + return NULL; + + result = transformational_result (mask, dim, mask->ts.type, + mask->ts.kind, &mask->where); + init_result_expr (result, true, NULL); + + return !dim || mask->rank == 1 ? + simplify_transformation_to_scalar (result, mask, NULL, gfc_and) : + simplify_transformation_to_array (result, mask, dim, NULL, gfc_and); +} + + +gfc_expr * gfc_simplify_dint (gfc_expr *e) { gfc_expr *rtrunc, *result; @@ -490,10 +906,10 @@ gfc_simplify_dint (gfc_expr *e) 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"); @@ -513,8 +929,7 @@ gfc_simplify_anint (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (e->ts.type, kind, &e->where); - + result = gfc_get_constant_expr (e->ts.type, kind, &e->where); mpfr_round (result->value.real, e->value.real); return range_check (result, "ANINT"); @@ -531,56 +946,88 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y) return NULL; kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - if (x->ts.type == BT_INTEGER) - { - result = gfc_constant_result (BT_INTEGER, kind, &x->where); - mpz_and (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "AND"); - } - else /* BT_LOGICAL */ + + switch (x->ts.type) { - result = gfc_constant_result (BT_LOGICAL, kind, &x->where); - result->value.logical = x->value.logical && y->value.logical; - return result; + 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_dnint (gfc_expr *e) +gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) { gfc_expr *result; - if (e->expr_type != EXPR_CONSTANT) + if (!is_constant_array_expr (mask) + || !gfc_is_constant_expr (dim)) return NULL; - result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where); + result = transformational_result (mask, dim, mask->ts.type, + mask->ts.kind, &mask->where); + init_result_expr (result, false, NULL); - mpfr_round (result->value.real, e->value.real); - - return range_check (result, "DNINT"); + return !dim || mask->rank == 1 ? + simplify_transformation_to_scalar (result, mask, NULL, gfc_or) : + simplify_transformation_to_array (result, mask, dim, NULL, gfc_or); } gfc_expr * -gfc_simplify_asin (gfc_expr *x) +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; - if (mpfr_cmp_si (x->value.real, 1) > 0 - || mpfr_cmp_si (x->value.real, -1) < 0) + switch (x->ts.type) { - gfc_error ("Argument of ASIN at %L must be between -1 and 1", - &x->where); - return &gfc_bad_expr; - } + 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; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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; - mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); + default: + gfc_internal_error ("in gfc_simplify_asin(): Bad type"); + } return range_check (result, "ASIN"); } @@ -594,9 +1041,21 @@ gfc_simplify_asinh (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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; - mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE); + default: + gfc_internal_error ("in gfc_simplify_asinh(): Bad type"); + } return range_check (result, "ASINH"); } @@ -609,10 +1068,22 @@ gfc_simplify_atan (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); + 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"); } @@ -626,17 +1097,28 @@ gfc_simplify_atanh (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - if (mpfr_cmp_si (x->value.real, 1) >= 0 - || mpfr_cmp_si (x->value.real, -1) <= 0) + switch (x->ts.type) { - gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1", - &x->where); - return &gfc_bad_expr; - } + 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; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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; - mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE); + default: + gfc_internal_error ("in gfc_simplify_atanh(): Bad type"); + } return range_check (result, "ATANH"); } @@ -657,8 +1139,7 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) return &gfc_bad_expr; } - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + 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"); @@ -666,14 +1147,14 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) gfc_expr * -gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_j0 (gfc_expr *x) { gfc_expr *result; if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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"); @@ -681,14 +1162,14 @@ gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED) gfc_expr * -gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_j1 (gfc_expr *x) { gfc_expr *result; if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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"); @@ -696,8 +1177,7 @@ gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED) gfc_expr * -gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED, - gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x) { gfc_expr *result; long n; @@ -706,7 +1186,7 @@ gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED, return NULL; n = mpz_get_si (order->value.integer); - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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"); @@ -714,14 +1194,14 @@ gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED, gfc_expr * -gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_y0 (gfc_expr *x) { gfc_expr *result; if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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"); @@ -729,14 +1209,14 @@ gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED) gfc_expr * -gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_y1 (gfc_expr *x) { gfc_expr *result; if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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"); @@ -744,8 +1224,7 @@ gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED) gfc_expr * -gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED, - gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x) { gfc_expr *result; long n; @@ -754,7 +1233,7 @@ gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED, return NULL; n = mpz_get_si (order->value.integer); - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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"); @@ -764,14 +1243,9 @@ gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED, gfc_expr * gfc_simplify_bit_size (gfc_expr *e) { - gfc_expr *result; - int i; - - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where); - mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size); - - return result; + 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); } @@ -784,9 +1258,10 @@ gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) return NULL; if (gfc_extract_int (bit, &b) != NULL || b < 0) - return gfc_logical_expr (0, &e->where); + return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false); - return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where); + return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, + mpz_tstbit (e->value.integer, b)); } @@ -803,11 +1278,10 @@ gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, kind, &e->where); - 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); @@ -823,117 +1297,75 @@ gfc_simplify_char (gfc_expr *e, gfc_expr *k) } -/* Common subroutine for simplifying CMPLX and DCMPLX. */ +/* 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; - result = gfc_constant_result (BT_COMPLEX, kind, &x->where); + 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; - mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); + result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where); switch (x->ts.type) { - case BT_INTEGER: - if (!x->is_boz) - mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE); - break; + case BT_INTEGER: + mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE); + break; - case BT_REAL: - mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE); - break; + case BT_REAL: + mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); + break; - case BT_COMPLEX: - mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE); - mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE); - 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)"); + default: + gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)"); } - if (y != NULL) - { - switch (y->ts.type) - { - case BT_INTEGER: - if (!y->is_boz) - mpfr_set_z (result->value.complex.i, y->value.integer, - GFC_RND_MODE); - break; - - case BT_REAL: - mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE); - break; + if (!y) + return range_check (result, name); - default: - gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)"); - } - } - - /* Handle BOZ. */ - if (x->is_boz) + switch (y->ts.type) { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.kind = result->ts.kind; - ts.type = BT_REAL; - if (!gfc_convert_boz (x, &ts)) - return &gfc_bad_expr; - mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE); - } + case BT_INTEGER: + mpfr_set_z (mpc_imagref (result->value.complex), + y->value.integer, GFC_RND_MODE); + break; - if (y && y->is_boz) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.kind = result->ts.kind; - ts.type = BT_REAL; - if (!gfc_convert_boz (y, &ts)) - return &gfc_bad_expr; - mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE); + 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); } -/* Function called when we won't simplify an expression like CMPLX (or - COMPLEX or DCMPLX) but still want to convert BOZ arguments. */ - -static gfc_expr * -only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_REAL; - ts.kind = kind; - - if (x->is_boz && !gfc_convert_boz (x, &ts)) - return &gfc_bad_expr; - - if (y && y->is_boz && !gfc_convert_boz (y, &ts)) - return &gfc_bad_expr; - - return NULL; -} - - gfc_expr * gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k) { int kind; - kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind); + kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind); if (kind == -1) return &gfc_bad_expr; - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return only_convert_cmplx_boz (x, y, kind); - return simplify_cmplx ("CMPLX", x, y, kind); } @@ -943,24 +1375,16 @@ gfc_simplify_complex (gfc_expr *x, gfc_expr *y) { int kind; - if (x->ts.type == BT_INTEGER) - { - if (y->ts.type == BT_INTEGER) - kind = gfc_default_real_kind; - else - kind = y->ts.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 - { - if (y->ts.type == BT_REAL) - kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; - else - kind = x->ts.kind; - } - - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return only_convert_cmplx_boz (x, y, kind); + gcc_unreachable (); return simplify_cmplx ("COMPLEX", x, y, kind); } @@ -975,7 +1399,7 @@ gfc_simplify_conjg (gfc_expr *e) return NULL; result = gfc_copy_expr (e); - mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE); + mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE); return range_check (result, "CONJG"); } @@ -985,40 +1409,28 @@ gfc_expr * gfc_simplify_cos (gfc_expr *x) { gfc_expr *result; - mpfr_t xp, xq; if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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); - mpfr_init (xp); - mpfr_init (xq); - - mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE); - mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE); - mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE); + case BT_REAL: + mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE); + break; - mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE); - mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE); - mpfr_mul (xp, xp, xq, GFC_RND_MODE); - mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE ); + case BT_COMPLEX: + gfc_set_model_kind (x->ts.kind); + mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; - mpfr_clears (xp, xq, NULL); - break; - default: - gfc_internal_error ("in gfc_simplify_cos(): Bad type"); + default: + gfc_internal_error ("in gfc_simplify_cos(): Bad type"); } return range_check (result, "COS"); - } @@ -1030,22 +1442,55 @@ gfc_simplify_cosh (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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; - mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE); + 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_dcmplx (gfc_expr *x, gfc_expr *y) +gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) { + gfc_expr *result; - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return only_convert_cmplx_boz (x, y, gfc_default_double_kind); + if (!is_constant_array_expr (mask) + || !gfc_is_constant_expr (dim) + || !gfc_is_constant_expr (kind)) + return NULL; + + result = transformational_result (mask, dim, + BT_INTEGER, + get_kind (BT_INTEGER, kind, "COUNT", + gfc_default_integer_kind), + &mask->where); + + init_result_expr (result, 0, NULL); + /* Passing MASK twice, once as data array, once as mask. + Whenever gfc_count is called, '1' is added to the result. */ + return !dim || mask->rank == 1 ? + simplify_transformation_to_scalar (result, mask, mask, gfc_count) : + simplify_transformation_to_array (result, mask, dim, mask, gfc_count); +} + + +gfc_expr * +gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) +{ return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); } @@ -1058,38 +1503,12 @@ gfc_simplify_dble (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - switch (e->ts.type) - { - case BT_INTEGER: - if (!e->is_boz) - result = gfc_int2real (e, gfc_default_double_kind); - break; - - case BT_REAL: - result = gfc_real2real (e, gfc_default_double_kind); - break; - - case BT_COMPLEX: - result = gfc_complex2real (e, gfc_default_double_kind); - break; - - default: - gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where); - } + if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr) + return &gfc_bad_expr; - if (e->ts.type == BT_INTEGER && e->is_boz) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_REAL; - ts.kind = gfc_default_double_kind; - result = gfc_copy_expr (e); - if (!gfc_convert_boz (result, &ts)) - { - gfc_free_expr (result); - 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"); } @@ -1101,22 +1520,23 @@ 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_INTEGER: + digits = gfc_integer_kinds[i].digits; + break; - case BT_REAL: - case BT_COMPLEX: - digits = gfc_real_kinds[i].digits; - break; + case BT_REAL: + case BT_COMPLEX: + digits = gfc_real_kinds[i].digits; + break; - default: - gcc_unreachable (); + default: + gcc_unreachable (); } - return gfc_int_expr (digits); + return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits); } @@ -1130,35 +1550,50 @@ gfc_simplify_dim (gfc_expr *x, gfc_expr *y) return NULL; kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - result = gfc_constant_result (x->ts.type, kind, &x->where); + 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); + 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; + 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); + 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; + break; - default: - gfc_internal_error ("gfc_simplify_dim(): Bad type"); + 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) { @@ -1167,15 +1602,14 @@ gfc_simplify_dprod (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where); - 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 (a1); gfc_free_expr (a2); + gfc_free_expr (a1); return range_check (result, "DPROD"); } @@ -1189,8 +1623,7 @@ gfc_simplify_erf (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + 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"); @@ -1205,77 +1638,205 @@ gfc_simplify_erfc (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + 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"); } -gfc_expr * -gfc_simplify_epsilon (gfc_expr *e) +/* 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) { - gfc_expr *result; - int i; + mp_prec_t prec; + mpfr_t a, b; - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + prec = mpfr_get_default_prec (); + mpfr_set_default_prec (10 * prec); - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + mpfr_init (a); + mpfr_init (b); - mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE); + 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); - return range_check (result, "EPSILON"); + 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: -gfc_expr * -gfc_simplify_exp (gfc_expr *x) + 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) { - gfc_expr *result; - mpfr_t xp, xq; + mpfr_t sum, x, u, v, w, oldsum, sumtrunc; + mpz_t num; + mp_prec_t prec; + unsigned i; - if (x->expr_type != EXPR_CONSTANT) - return NULL; + prec = mpfr_get_default_prec (); + mpfr_set_default_prec (2 * prec); - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + mpfr_init (sum); + mpfr_init (x); + mpfr_init (u); + mpfr_init (v); + mpfr_init (w); + mpz_init (num); - switch (x->ts.type) - { - case BT_REAL: - mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE); - break; + mpfr_init (oldsum); + mpfr_init (sumtrunc); + mpfr_set_prec (oldsum, prec); + mpfr_set_prec (sumtrunc, prec); - case BT_COMPLEX: - gfc_set_model_kind (x->ts.kind); - mpfr_init (xp); - mpfr_init (xq); - mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE); - mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE); - mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE); - mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE); - mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE); - mpfr_clears (xp, xq, NULL); - break; + mpfr_set (x, arg, GFC_RND_MODE); + mpfr_set_ui (sum, 1, GFC_RND_MODE); + mpz_set_ui (num, 1); - default: - gfc_internal_error ("in gfc_simplify_exp(): Bad type"); - } + 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); - return range_check (result, "EXP"); -} + for (i = 1; i < MAX_ITER; i++) + { + mpfr_set (oldsum, sum, GFC_RND_MODE); -gfc_expr * -gfc_simplify_exponent (gfc_expr *x) -{ - int i; - gfc_expr *result; + mpz_mul_ui (num, num, 2 * i - 1); + mpz_neg (num, num); - if (x->expr_type != EXPR_CONSTANT) - return NULL; + mpfr_set (w, u, GFC_RND_MODE); + mpfr_pow_ui (w, w, i, GFC_RND_MODE); - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &x->where); + 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); @@ -1302,21 +1863,14 @@ gfc_simplify_float (gfc_expr *a) if (a->is_boz) { - gfc_typespec ts; - gfc_clear_ts (&ts); - - ts.type = BT_REAL; - ts.kind = gfc_default_real_kind; + if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr) + return &gfc_bad_expr; result = gfc_copy_expr (a); - if (!gfc_convert_boz (result, &ts)) - { - gfc_free_expr (result); - return &gfc_bad_expr; - } } else result = gfc_int2real (a, gfc_default_real_kind); + return range_check (result, "FLOAT"); } @@ -1335,12 +1889,12 @@ gfc_simplify_floor (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, kind, &e->where); - 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); @@ -1358,7 +1912,7 @@ gfc_simplify_fraction (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); if (mpfr_sgn (x->value.real) == 0) { @@ -1395,8 +1949,7 @@ gfc_simplify_gamma (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + 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"); @@ -1410,21 +1963,20 @@ gfc_simplify_huge (gfc_expr *e) int i; i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + 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_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; + case BT_REAL: + mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); + break; - default: - gcc_unreachable (); + default: + gcc_unreachable (); } return result; @@ -1439,7 +1991,7 @@ gfc_simplify_hypot (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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"); } @@ -1453,6 +2005,7 @@ 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; @@ -1469,10 +2022,11 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) gfc_warning ("Argument of IACHAR function at %L outside of range 0..127", &e->where); - if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL) + k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind); + if (k == -1) return &gfc_bad_expr; - result->where = e->where; + result = gfc_get_int_expr (k, &e->where, index); return range_check (result, "IACHAR"); } @@ -1486,8 +2040,7 @@ gfc_simplify_iand (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where); - + 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"); @@ -1568,7 +2121,7 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) return &gfc_bad_expr; } - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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); @@ -1642,6 +2195,7 @@ 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; @@ -1654,10 +2208,12 @@ gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) index = e->value.character.string[0]; - if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL) + k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind); + if (k == -1) return &gfc_bad_expr; - result->where = e->where; + result = gfc_get_int_expr (k, &e->where, index); + return range_check (result, "ICHAR"); } @@ -1670,8 +2226,7 @@ gfc_simplify_ieor (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where); - + 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"); @@ -1698,7 +2253,7 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) if (k == -1) return &gfc_bad_expr; - result = gfc_constant_result (BT_INTEGER, k, &x->where); + result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); len = x->value.character.length; lensub = y->value.character.length; @@ -1823,73 +2378,34 @@ done: } -gfc_expr * -gfc_simplify_int (gfc_expr *e, gfc_expr *k) +static gfc_expr * +simplify_intconv (gfc_expr *e, int kind, const char *name) { gfc_expr *result = NULL; - int kind; - - kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; if (e->expr_type != EXPR_CONSTANT) return NULL; - switch (e->ts.type) - { - case BT_INTEGER: - result = gfc_int2int (e, kind); - break; - - case BT_REAL: - result = gfc_real2int (e, kind); - break; - - case BT_COMPLEX: - result = gfc_complex2int (e, kind); - break; - - default: - gfc_error ("Argument of INT at %L is not a valid type", &e->where); - return &gfc_bad_expr; - } + result = gfc_convert_constant (e, BT_INTEGER, kind); + if (result == &gfc_bad_expr) + return &gfc_bad_expr; - return range_check (result, "INT"); + return range_check (result, name); } -static gfc_expr * -simplify_intconv (gfc_expr *e, int kind, const char *name) +gfc_expr * +gfc_simplify_int (gfc_expr *e, gfc_expr *k) { - gfc_expr *result = NULL; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - switch (e->ts.type) - { - case BT_INTEGER: - result = gfc_int2int (e, kind); - break; - - case BT_REAL: - result = gfc_real2int (e, kind); - break; - - case BT_COMPLEX: - result = gfc_complex2int (e, kind); - break; + int kind; - default: - gfc_error ("Argument of %s at %L is not a valid type", name, &e->where); - return &gfc_bad_expr; - } + kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; - return range_check (result, name); + return simplify_intconv (e, kind, "INT"); } - gfc_expr * gfc_simplify_int2 (gfc_expr *e) { @@ -1919,15 +2435,15 @@ gfc_simplify_ifix (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &e->where); - 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"); } @@ -1940,15 +2456,15 @@ gfc_simplify_idint (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &e->where); - 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"); } @@ -1961,14 +2477,49 @@ gfc_simplify_ior (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where); - + 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"); } 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)); +} + + +gfc_expr * gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) { gfc_expr *result; @@ -1999,7 +2550,7 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) return &gfc_bad_expr; } - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); if (shift == 0) { @@ -2102,7 +2653,7 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) return &gfc_bad_expr; } - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); mpz_set (result->value.integer, e->value.integer); @@ -2165,26 +2716,20 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) gfc_expr * gfc_simplify_kind (gfc_expr *e) { - - if (e->ts.type == BT_DERIVED) - { - gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where); - return &gfc_bad_expr; - } - - return gfc_int_expr (e->ts.kind); + 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_array_spec *as, gfc_ref *ref, bool coarray) { gfc_expr *l, *u, *result; int k; /* The last dimension of an assumed-size array is special. */ - if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) + 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) return gfc_copy_expr (as->lower[d-1]); @@ -2192,35 +2737,51 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, return NULL; } - /* Then, we need to know the extent of the given dimension. */ - l = as->lower[d-1]; - u = as->upper[d-1]; - - if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT) - return NULL; - k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", gfc_default_integer_kind); if (k == -1) return &gfc_bad_expr; - result = gfc_constant_result (BT_INTEGER, k, &array->where); + result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); + - if (mpz_cmp (l->value.integer, u->value.integer) > 0) + /* Then, we need to know the extent of the given dimension. */ + if (coarray || ref->u.ar.type == AR_FULL) { - /* Zero extent. */ - if (upper) - mpz_set_si (result->value.integer, 0); + l = as->lower[d-1]; + u = as->upper[d-1]; + + if (l->expr_type != EXPR_CONSTANT || u == NULL + || u->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpz_cmp (l->value.integer, u->value.integer) > 0) + { + /* Zero extent. */ + if (upper) + mpz_set_si (result->value.integer, 0); + else + mpz_set_si (result->value.integer, 1); + } else - mpz_set_si (result->value.integer, 1); + { + /* Nonzero extent. */ + if (upper) + mpz_set (result->value.integer, u->value.integer); + else + mpz_set (result->value.integer, l->value.integer); + } } else { - /* Nonzero extent. */ if (upper) - mpz_set (result->value.integer, u->value.integer); + { + if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer) + != SUCCESS) + return NULL; + } else - mpz_set (result->value.integer, l->value.integer); + mpz_set_si (result->value.integer, (long int) 1); } return range_check (result, upper ? "UBOUND" : "LBOUND"); @@ -2253,11 +2814,17 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) case AR_FULL: /* We're done because 'as' has already been set in the previous iteration. */ - goto done; + if (!ref->next) + goto done; + + /* Fall through. */ - case AR_SECTION: case AR_UNKNOWN: return NULL; + + case AR_SECTION: + as = ref->u.ar.as; + goto done; } gcc_unreachable (); @@ -2283,7 +2850,6 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) /* Multi-dimensional bounds. */ gfc_expr *bounds[GFC_MAX_DIMENSIONS]; gfc_expr *e; - gfc_constructor *head, *tail; int k; /* UBOUND(ARRAY) is not valid for an assumed-size array. */ @@ -2297,7 +2863,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) /* Simplify the bounds for each dimension. */ for (d = 0; d < array->rank; d++) { - bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as); + bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref, + false); if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) { int j; @@ -2309,18 +2876,12 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) } /* 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 ? "UBOUND" : "LBOUND", - gfc_default_integer_kind); + gfc_default_integer_kind); if (k == -1) - { - gfc_free_expr (e); - return &gfc_bad_expr; - } - e->ts.kind = k; + 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. */ @@ -2329,22 +2890,9 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) mpz_init_set_ui (e->shape[0], array->rank); /* Create the constructor for this array. */ - head = tail = NULL; for (d = 0; d < array->rank; d++) - { - /* Get a new constructor element. */ - if (head == NULL) - head = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } - - tail->where = e->where; - tail->expr = bounds[d]; - } - e->value.constructor = head; + gfc_constructor_append_expr (&e->value.constructor, + bounds[d], &e->where); return e; } @@ -2363,68 +2911,215 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) return &gfc_bad_expr; } - return simplify_bound_dim (array, kind, d, upper, as); + return simplify_bound_dim (array, kind, d, upper, as, ref, false); } } -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_leadz (gfc_expr *e) +static gfc_expr * +simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) { - gfc_expr *result; - unsigned long lz, bs; - int i; + gfc_ref *ref; + gfc_array_spec *as; + int d; - if (e->expr_type != EXPR_CONSTANT) + if (array->expr_type != EXPR_VARIABLE) 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 - lz = bs - mpz_sizeinbase (e->value.integer, 2); - - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where); - mpz_set_ui (result->value.integer, lz); - - return result; -} + /* 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->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_len (gfc_expr *e, gfc_expr *kind) +gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - gfc_expr *result; - int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind); + gfc_expr *e; + /* return simplify_cobound (array, dim, kind, 0);*/ - if (k == -1) - return &gfc_bad_expr; + 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 (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; + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); +} + + case AR_UNKNOWN: + return NULL; + + case AR_SECTION: + as = ref->u.ar.as; + goto done; + } + + gcc_unreachable (); if (e->expr_type == EXPR_CONSTANT) { - result = gfc_constant_result (BT_INTEGER, k, &e->where); + 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"); } - - if (e->ts.cl != NULL && e->ts.cl->length != NULL - && e->ts.cl->length->expr_type == EXPR_CONSTANT - && e->ts.cl->length->ts.type == BT_INTEGER) + 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_constant_result (BT_INTEGER, k, &e->where); - mpz_set (result->value.integer, e->ts.cl->length->value.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"); } - - return NULL; + else + return NULL; } @@ -2432,32 +3127,27 @@ gfc_expr * gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) { gfc_expr *result; - int count, len, lentrim, i; + int count, len, i; int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; + done: - if (e->expr_type != EXPR_CONSTANT) + if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE) return NULL; - result = gfc_constant_result (BT_INTEGER, k, &e->where); 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; - - mpz_set_si (result->value.integer, lentrim); + result = gfc_get_int_expr (k, &e->where, len - count); return range_check (result, "LEN_TRIM"); } gfc_expr * -gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_lgamma (gfc_expr *x) { gfc_expr *result; int sg; @@ -2465,8 +3155,7 @@ gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + 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"); @@ -2479,7 +3168,8 @@ gfc_simplify_lge (gfc_expr *a, gfc_expr *b) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) return NULL; - return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where); + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) >= 0); } @@ -2489,8 +3179,8 @@ gfc_simplify_lgt (gfc_expr *a, gfc_expr *b) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) return NULL; - return gfc_logical_expr (gfc_compare_string (a, b) > 0, - &a->where); + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) > 0); } @@ -2500,7 +3190,8 @@ gfc_simplify_lle (gfc_expr *a, gfc_expr *b) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) return NULL; - return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where); + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) <= 0); } @@ -2510,7 +3201,8 @@ gfc_simplify_llt (gfc_expr *a, gfc_expr *b) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) return NULL; - return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where); + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) < 0); } @@ -2518,13 +3210,11 @@ gfc_expr * gfc_simplify_log (gfc_expr *x) { gfc_expr *result; - mpfr_t xr, xi; if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); switch (x->ts.type) { @@ -2541,8 +3231,8 @@ gfc_simplify_log (gfc_expr *x) break; case BT_COMPLEX: - if ((mpfr_sgn (x->value.complex.r) == 0) - && (mpfr_sgn (x->value.complex.i) == 0)) + if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0) + && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0)) { gfc_error ("Complex argument of LOG at %L cannot be zero", &x->where); @@ -2551,20 +3241,7 @@ gfc_simplify_log (gfc_expr *x) } gfc_set_model_kind (x->ts.kind); - mpfr_init (xr); - mpfr_init (xi); - - mpfr_atan2 (result->value.complex.i, x->value.complex.i, - x->value.complex.r, GFC_RND_MODE); - - mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE); - mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE); - mpfr_add (xr, xr, xi, GFC_RND_MODE); - mpfr_sqrt (xr, xr, GFC_RND_MODE); - mpfr_log (result->value.complex.r, xr, GFC_RND_MODE); - - mpfr_clears (xr, xi, NULL); - + mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); break; default: @@ -2590,8 +3267,7 @@ gfc_simplify_log10 (gfc_expr *x) return &gfc_bad_expr; } - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + 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"); @@ -2601,7 +3277,6 @@ gfc_simplify_log10 (gfc_expr *x) gfc_expr * gfc_simplify_logical (gfc_expr *e, gfc_expr *k) { - gfc_expr *result; int kind; kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind); @@ -2611,14 +3286,157 @@ gfc_simplify_logical (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_LOGICAL, kind, &e->where); + 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[0]); + stride_a = 1; + stride_b = mpz_get_si (matrix_b->shape[0]); + + result->rank = 1; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_columns); + } + else if (matrix_a->rank == 2 && matrix_b->rank == 1) + { + result_rows = mpz_get_si (matrix_b->shape[0]); + result_columns = 1; + stride_a = mpz_get_si (matrix_a->shape[0]); + stride_b = 1; + + result->rank = 1; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_rows); + } + else if (matrix_a->rank == 2 && matrix_b->rank == 2) + { + result_rows = mpz_get_si (matrix_a->shape[0]); + result_columns = mpz_get_si (matrix_b->shape[1]); + stride_a = mpz_get_si (matrix_a->shape[1]); + stride_b = mpz_get_si (matrix_b->shape[0]); + + result->rank = 2; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_rows); + mpz_init_set_si (result->shape[1], result_columns); + } + else + gcc_unreachable(); + + offset_a = offset_b = 0; + for (col = 0; col < result_columns; ++col) + { + offset_a = 0; - result->value.logical = e->value.logical; + 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_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) +{ + if (tsource->expr_type != EXPR_CONSTANT + || fsource->expr_type != EXPR_CONSTANT + || mask->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_copy_expr (mask->value.logical ? tsource : fsource); +} + + +/* Selects bewteen current value and extremum for simplify_min_max + and simplify_minval_maxval. */ +static void +min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) +{ + switch (arg->ts.type) + { + case BT_INTEGER: + if (mpz_cmp (arg->value.integer, + extremum->value.integer) * sign > 0) + mpz_set (extremum->value.integer, arg->value.integer); + break; + + case BT_REAL: + /* We need to use mpfr_min and mpfr_max to treat NaN properly. */ + if (sign > 0) + mpfr_max (extremum->value.real, extremum->value.real, + arg->value.real, GFC_RND_MODE); + else + mpfr_min (extremum->value.real, extremum->value.real, + arg->value.real, GFC_RND_MODE); + break; + + case BT_CHARACTER: +#define LENGTH(x) ((x)->value.character.length) +#define STRING(x) ((x)->value.character.string) + if (LENGTH(extremum) < LENGTH(arg)) + { + gfc_char_t *tmp = STRING(extremum); + + STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1); + memcpy (STRING(extremum), tmp, + LENGTH(extremum) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', + LENGTH(arg) - LENGTH(extremum)); + STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ + LENGTH(extremum) = LENGTH(arg); + gfc_free (tmp); + } + + if (gfc_compare_string (arg, extremum) * sign > 0) + { + gfc_free (STRING(extremum)); + STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); + memcpy (STRING(extremum), STRING(arg), + LENGTH(arg) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', + LENGTH(extremum) - LENGTH(arg)); + STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ + } +#undef LENGTH +#undef STRING + break; + + default: + gfc_internal_error ("simplify_min_max(): Bad type in arglist"); + } +} + + /* This function is special since MAX() can take any number of arguments. The simplified expression is a rewritten version of the argument list containing at most one constant element. Other @@ -2649,59 +3467,7 @@ simplify_min_max (gfc_expr *expr, int sign) continue; } - switch (arg->expr->ts.type) - { - case BT_INTEGER: - if (mpz_cmp (arg->expr->value.integer, - extremum->expr->value.integer) * sign > 0) - mpz_set (extremum->expr->value.integer, arg->expr->value.integer); - break; - - case BT_REAL: - /* We need to use mpfr_min and mpfr_max to treat NaN properly. */ - if (sign > 0) - mpfr_max (extremum->expr->value.real, extremum->expr->value.real, - arg->expr->value.real, GFC_RND_MODE); - else - mpfr_min (extremum->expr->value.real, extremum->expr->value.real, - arg->expr->value.real, GFC_RND_MODE); - break; - - case BT_CHARACTER: -#define LENGTH(x) ((x)->expr->value.character.length) -#define STRING(x) ((x)->expr->value.character.string) - if (LENGTH(extremum) < LENGTH(arg)) - { - 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->expr, extremum->expr) * 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"); - } + min_max_choose (arg->expr, extremum->expr, sign); /* Delete the extra constant argument. */ if (last == NULL) @@ -2746,33 +3512,84 @@ gfc_simplify_max (gfc_expr *e) } -gfc_expr * -gfc_simplify_maxexponent (gfc_expr *x) -{ - gfc_expr *result; - int i; +/* This is a simplified version of simplify_min_max to provide + simplification of minval and maxval for a vector. */ - i = gfc_validate_kind (BT_REAL, x->ts.kind, false); +static gfc_expr * +simplify_minval_maxval (gfc_expr *expr, int sign) +{ + gfc_constructor *c, *extremum; + gfc_intrinsic_sym * specific; - result = gfc_int_expr (gfc_real_kinds[i].max_exponent); - result->where = x->where; + extremum = NULL; + specific = expr->value.function.isym; - return result; + 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_minexponent (gfc_expr *x) +gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) { - gfc_expr *result; - int i; + if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) + return NULL; - i = gfc_validate_kind (BT_REAL, x->ts.kind, false); + return simplify_minval_maxval (array, -1); +} - result = gfc_int_expr (gfc_real_kinds[i].min_exponent); - result->where = x->where; - return result; +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); } @@ -2787,41 +3604,41 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) return NULL; kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - result = gfc_constant_result (a->ts.type, kind, &a->where); + 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_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; - } + 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; + 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"); + default: + gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); } return range_check (result, "MOD"); @@ -2839,43 +3656,43 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) return NULL; kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - result = gfc_constant_result (a->ts.type, kind, &a->where); + 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); + 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; + 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; - } + 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; + 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"); + default: + gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); } return range_check (result, "MODULO"); @@ -2922,6 +3739,7 @@ gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent - mpfr_get_prec(result->value.real) + 1); mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1); + mpfr_check_range (result->value.real, 0, GMP_RNDU); if (mpfr_sgn (s->value.real) > 0) { @@ -2963,12 +3781,10 @@ simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, kind, &e->where); - 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); @@ -2982,11 +3798,9 @@ gfc_simplify_new_line (gfc_expr *e) { gfc_expr *result; - result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); - result->value.character.string = gfc_get_wide_string (2); - result->value.character.length = 1; + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1); result->value.character.string[0] = '\n'; - result->value.character.string[1] = '\0'; /* For debugger */ + return result; } @@ -3013,8 +3827,7 @@ gfc_simplify_not (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); - + 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"); @@ -3026,15 +3839,33 @@ gfc_simplify_null (gfc_expr *mold) { gfc_expr *result; - if (mold == NULL) + if (mold) { - result = gfc_get_expr (); - result->ts.type = BT_UNKNOWN; + result = gfc_copy_expr (mold); + result->expr_type = EXPR_NULL; } else - result = gfc_copy_expr (mold); - result->expr_type = EXPR_NULL; + 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; } @@ -3049,92 +3880,174 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *y) return NULL; kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - if (x->ts.type == BT_INTEGER) + + 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); + + 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) { - result = gfc_constant_result (BT_INTEGER, kind, &x->where); - mpz_ior (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "OR"); + /* 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 /* BT_LOGICAL */ + else if (mask->expr_type == EXPR_ARRAY) { - result = gfc_constant_result (BT_LOGICAL, kind, &x->where); - result->value.logical = x->value.logical || y->value.logical; - return result; + /* 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; } 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) +{ gfc_expr *result; - int i; - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + if (!is_constant_array_expr (array) + || !gfc_is_constant_expr (dim)) + return NULL; + + if (mask + && !is_constant_array_expr (mask) + && mask->expr_type != EXPR_CONSTANT) + return NULL; - result = gfc_int_expr (gfc_real_kinds[i].precision); - result->where = e->where; + result = transformational_result (array, dim, array->ts.type, + array->ts.kind, &array->where); + init_result_expr (result, 1, NULL); - return result; + return !dim || array->rank == 1 ? + simplify_transformation_to_scalar (result, array, mask, gfc_multiply) : + simplify_transformation_to_array (result, array, dim, mask, gfc_multiply); } gfc_expr * gfc_simplify_radix (gfc_expr *e) { - gfc_expr *result; 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_INTEGER: + i = gfc_integer_kinds[i].radix; + break; - case BT_REAL: - i = gfc_real_kinds[i].radix; - break; + case BT_REAL: + i = gfc_real_kinds[i].radix; + break; - default: - gcc_unreachable (); + default: + gcc_unreachable (); } - result = gfc_int_expr (i); - result->where = e->where; - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); } gfc_expr * gfc_simplify_range (gfc_expr *e) { - gfc_expr *result; int i; - long j; - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); switch (e->ts.type) { - case BT_INTEGER: - j = gfc_integer_kinds[i].range; - break; + case BT_INTEGER: + i = gfc_integer_kinds[i].range; + break; - case BT_REAL: - case BT_COMPLEX: - j = gfc_real_kinds[i].range; - break; + case BT_REAL: + case BT_COMPLEX: + i = gfc_real_kinds[i].range; + break; - default: - gcc_unreachable (); + default: + gcc_unreachable (); } - result = gfc_int_expr (j); - result->where = e->where; - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); } @@ -3155,39 +4068,12 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - switch (e->ts.type) - { - case BT_INTEGER: - if (!e->is_boz) - result = gfc_int2real (e, kind); - break; - - case BT_REAL: - result = gfc_real2real (e, kind); - break; - - case BT_COMPLEX: - result = gfc_complex2real (e, kind); - break; - - default: - gfc_internal_error ("bad type in REAL"); - /* Not reached */ - } + if (convert_boz (e, kind) == &gfc_bad_expr) + return &gfc_bad_expr; - if (e->ts.type == BT_INTEGER && e->is_boz) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_REAL; - ts.kind = kind; - result = gfc_copy_expr (e); - if (!gfc_convert_boz (result, &ts)) - { - gfc_free_expr (result); - 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"); } @@ -3201,8 +4087,8 @@ gfc_simplify_realpart (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); - mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE); + 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"); } @@ -3228,14 +4114,14 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) } /* If we don't know the character length, we can do no more. */ - if (e->ts.cl && e->ts.cl->length - && e->ts.cl->length->expr_type == EXPR_CONSTANT) + 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.cl->length->value.integer); + len = mpz_get_si (e->ts.u.cl->length->value.integer); have_length = true; } else if (e->expr_type == EXPR_CONSTANT - && (e->ts.cl == NULL || e->ts.cl->length == NULL)) + && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) { len = e->value.character.length; } @@ -3263,7 +4149,7 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) if (have_length) { mpz_tdiv_q (max, gfc_integer_kinds[i].huge, - e->ts.cl->length->value.integer); + e->ts.u.cl->length->value.integer); } else { @@ -3292,8 +4178,8 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) return NULL; if (len || - (e->ts.cl->length && - mpz_sgn (e->ts.cl->length->value.integer)) != 0) + (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); @@ -3304,19 +4190,15 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) len = e->value.character.length; nlen = ncop * len; - result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); + result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where); if (ncop == 0) - { - result->value.character.string = gfc_get_wide_string (1); - result->value.character.length = 0; - result->value.character.string[0] = '\0'; - return result; - } + return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); - result->value.character.length = nlen; - result->value.character.string = gfc_get_wide_string (nlen + 1); + 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]; @@ -3326,30 +4208,6 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) } -/* 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; - - if (e->value.constructor == NULL) - return false; - - for (c = e->value.constructor; c; c = c->next) - if (c->expr->expr_type != EXPR_CONSTANT) - return false; - - return true; -} - - /* This one is a bear, but mainly has to do with shuffling elements. */ gfc_expr * @@ -3358,71 +4216,38 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, { int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS]; int i, rank, npad, x[GFC_MAX_DIMENSIONS]; - gfc_constructor *head, *tail; mpz_t index, size; unsigned long j; size_t nsource; - gfc_expr *e; + gfc_expr *e, *result; /* Check that argument expression types are OK. */ - if (!is_constant_array_expr (source)) - return NULL; - - if (!is_constant_array_expr (shape_exp)) - return NULL; - - if (!is_constant_array_expr (pad)) - return NULL; - - if (!is_constant_array_expr (order_exp)) + 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; - head = tail = NULL; for (;;) { - e = gfc_get_array_element (shape_exp, rank); + e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank); if (e == NULL) break; - if (gfc_extract_int (e, &shape[rank]) != NULL) - { - gfc_error ("Integer too large in shape specification at %L", - &e->where); - gfc_free_expr (e); - goto bad_reshape; - } - - if (rank >= GFC_MAX_DIMENSIONS) - { - gfc_error ("Too many dimensions in shape specification for RESHAPE " - "at %L", &e->where); - gfc_free_expr (e); - goto bad_reshape; - } + gfc_extract_int (e, &shape[rank]); - if (shape[rank] < 0) - { - gfc_error ("Shape specification at %L cannot be negative", - &e->where); - gfc_free_expr (e); - goto bad_reshape; - } + gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS); + gcc_assert (shape[rank] >= 0); - gfc_free_expr (e); rank++; } - if (rank == 0) - { - gfc_error ("Shape specification at %L cannot be the null array", - &shape_exp->where); - goto bad_reshape; - } + gcc_assert (rank > 0); /* Now unpack the order array if present. */ if (order_exp == NULL) @@ -3437,42 +4262,14 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, for (i = 0; i < rank; i++) { - e = gfc_get_array_element (order_exp, i); - if (e == NULL) - { - gfc_error ("ORDER parameter of RESHAPE at %L is not the same " - "size as SHAPE parameter", &order_exp->where); - goto bad_reshape; - } - - if (gfc_extract_int (e, &order[i]) != NULL) - { - gfc_error ("Error in ORDER parameter of RESHAPE at %L", - &e->where); - gfc_free_expr (e); - goto bad_reshape; - } + e = gfc_constructor_lookup_expr (order_exp->value.constructor, i); + gcc_assert (e); - if (order[i] < 1 || order[i] > rank) - { - gfc_error ("ORDER parameter of RESHAPE at %L is out of range", - &e->where); - gfc_free_expr (e); - goto bad_reshape; - } + gfc_extract_int (e, &order[i]); + gcc_assert (order[i] >= 1 && order[i] <= rank); order[i]--; - - if (x[order[i]]) - { - gfc_error ("Invalid permutation in ORDER parameter at %L", - &e->where); - gfc_free_expr (e); - goto bad_reshape; - } - - gfc_free_expr (e); - + gcc_assert (x[order[i]] == 0); x[order[i]] = 1; } } @@ -3499,7 +4296,14 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, for (i = 0; i < rank; i++) x[i] = 0; - for (;;) + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + 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); @@ -3517,35 +4321,19 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, j = mpz_get_ui (index); if (j < nsource) - e = gfc_get_array_element (source, j); + e = gfc_constructor_lookup_expr (source->value.constructor, j); else { - j = j - nsource; - - if (npad == 0) - { - gfc_error ("PAD parameter required for short SOURCE parameter " - "at %L", &source->where); - goto bad_reshape; - } + gcc_assert (npad > 0); + j = j - nsource; j = j % npad; - e = gfc_get_array_element (pad, j); + e = gfc_constructor_lookup_expr (pad->value.constructor, j); } + gcc_assert (e); - if (head == NULL) - head = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } - - if (e == NULL) - goto bad_reshape; - - tail->where = e->where; - tail->expr = e; + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (e), &e->where); /* Calculate the next element. */ i = 0; @@ -3562,24 +4350,7 @@ inc: mpz_clear (index); - e = gfc_get_expr (); - e->where = source->where; - e->expr_type = EXPR_ARRAY; - e->value.constructor = head; - e->shape = gfc_get_shape (rank); - - for (i = 0; i < rank; i++) - mpz_init_set_ui (e->shape[i], shape[i]); - - e->ts = source->ts; - e->rank = rank; - - return e; - -bad_reshape: - gfc_free_constructor (head); - mpz_clear (index); - return &gfc_bad_expr; + return result; } @@ -3595,8 +4366,7 @@ gfc_simplify_rrspacing (gfc_expr *x) i = gfc_validate_kind (x->ts.type, x->ts.kind, false); - result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); - + 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. */ @@ -3627,7 +4397,7 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i) if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); if (mpfr_sgn (x->value.real) == 0) { @@ -3741,8 +4511,6 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) else back = 0; - result = gfc_constant_result (BT_INTEGER, k, &e->where); - len = e->value.character.length; lenc = c->value.character.length; @@ -3775,7 +4543,8 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) } } } - mpz_set_ui (result->value.integer, indx); + + result = gfc_get_int_expr (k, &e->where, indx); return range_check (result, "SCAN"); } @@ -3784,7 +4553,6 @@ gfc_expr * gfc_simplify_selected_char_kind (gfc_expr *e) { int kind; - gfc_expr *result; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -3797,10 +4565,7 @@ gfc_simplify_selected_char_kind (gfc_expr *e) else kind = -1; - result = gfc_int_expr (kind); - result->where = e->where; - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); } @@ -3808,7 +4573,6 @@ gfc_expr * gfc_simplify_selected_int_kind (gfc_expr *e) { int i, kind, range; - gfc_expr *result; if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL) return NULL; @@ -3823,10 +4587,7 @@ gfc_simplify_selected_int_kind (gfc_expr *e) if (kind == INT_MAX) kind = -1; - result = gfc_int_expr (kind); - result->where = e->where; - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); } @@ -3834,7 +4595,6 @@ gfc_expr * gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) { int range, precision, i, kind, found_precision, found_range; - gfc_expr *result; if (p == NULL) precision = 0; @@ -3881,10 +4641,8 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) kind -= 2; } - result = gfc_int_expr (kind); - result->where = (p != NULL) ? p->where : q->where; - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, + p ? &p->where : &q->where, kind); } @@ -3898,7 +4656,7 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); if (mpfr_sgn (x->value.real) == 0) { @@ -3944,14 +4702,14 @@ gfc_simplify_shape (gfc_expr *source) gfc_try t; if (source->rank == 0) - return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind, - &source->where); + return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, + &source->where); if (source->expr_type != EXPR_VARIABLE) return NULL; - result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind, - &source->where); + result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, + &source->where); ar = gfc_find_array_ref (source); @@ -3959,8 +4717,8 @@ gfc_simplify_shape (gfc_expr *source) for (n = 0; n < source->rank; n++) { - e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &source->where); + e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &source->where); if (t == SUCCESS) { @@ -3984,7 +4742,7 @@ gfc_simplify_shape (gfc_expr *source) } } - gfc_append_constructor (result, e); + gfc_constructor_append_expr (&result->value.constructor, e, NULL); } return result; @@ -3995,7 +4753,6 @@ gfc_expr * gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { mpz_t size; - gfc_expr *result; int d; int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); @@ -4017,9 +4774,7 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) return NULL; } - result = gfc_constant_result (BT_INTEGER, k, &array->where); - mpz_set (result->value.integer, size); - return result; + return gfc_get_int_expr (k, &array->where, mpz_get_si (size)); } @@ -4031,28 +4786,27 @@ gfc_simplify_sign (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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: - /* TODO: Handle -0.0 and +0.0 correctly on machines that support - it. */ - mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); - if (mpfr_sgn (y->value.real) < 0) - mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE); + 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; - 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"); + default: + gfc_internal_error ("Bad type in gfc_simplify_sign"); } return result; @@ -4063,37 +4817,25 @@ gfc_expr * gfc_simplify_sin (gfc_expr *x) { gfc_expr *result; - mpfr_t xp, xq; if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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); - mpfr_init (xp); - mpfr_init (xq); - - mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE); - mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE); - mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE); - - mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE); - mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE); - mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE); + case BT_REAL: + mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE); + break; - mpfr_clears (xp, xq, NULL); - 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"); + default: + gfc_internal_error ("in gfc_simplify_sin(): Bad type"); } return range_check (result, "SIN"); @@ -4108,9 +4850,21 @@ gfc_simplify_sinh (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + 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; - mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE); + default: + gcc_unreachable (); + } return range_check (result, "SINH"); } @@ -4144,7 +4898,7 @@ gfc_simplify_spacing (gfc_expr *x) i = gfc_validate_kind (x->ts.type, x->ts.kind, false); - result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + 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); @@ -4171,328 +4925,812 @@ gfc_simplify_spacing (gfc_expr *x) gfc_expr * -gfc_simplify_sqrt (gfc_expr *e) +gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr) { - gfc_expr *result; - mpfr_t ac, ad, s, t, w; + gfc_expr *result = 0L; + int i, j, dim, ncopies; + mpz_t size; - if (e->expr_type != EXPR_CONSTANT) + 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; - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + gcc_assert (dim_expr->ts.type == BT_INTEGER); + gfc_extract_int (dim_expr, &dim); + dim -= 1; /* zero-base DIM */ - switch (e->ts.type) + 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) { - case BT_REAL: - if (mpfr_cmp_si (e->value.real, 0) < 0) - goto negative_arg; - mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE); + if (gfc_array_size (source, &size) == FAILURE) + gfc_internal_error ("Failure getting length of a constant array."); + } + else + mpz_init_set_ui (size, 1); - break; + if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor) + return NULL; - case BT_COMPLEX: - /* Formula taken from Numerical Recipes to avoid over- and - underflow. */ - - gfc_set_model (e->value.real); - mpfr_init (ac); - mpfr_init (ad); - mpfr_init (s); - mpfr_init (t); - mpfr_init (w); - - if (mpfr_cmp_ui (e->value.complex.r, 0) == 0 - && mpfr_cmp_ui (e->value.complex.i, 0) == 0) - { - mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE); - mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); - break; - } + if (source->expr_type == EXPR_CONSTANT) + { + gcc_assert (dim == 0); - mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE); - mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE); + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + result->rank = 1; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], ncopies); - if (mpfr_cmp (ac, ad) >= 0) - { - mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE); - mpfr_mul (t, t, t, GFC_RND_MODE); - mpfr_add_ui (t, t, 1, GFC_RND_MODE); - mpfr_sqrt (t, t, GFC_RND_MODE); - mpfr_add_ui (t, t, 1, GFC_RND_MODE); - mpfr_div_ui (t, t, 2, GFC_RND_MODE); - mpfr_sqrt (t, t, GFC_RND_MODE); - mpfr_sqrt (s, ac, GFC_RND_MODE); - mpfr_mul (w, s, t, GFC_RND_MODE); - } - else + 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); + result->rank = source->rank + 1; + result->shape = gfc_get_shape (result->rank); + + for (i = 0, j = 0; i < result->rank; ++i) { - mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE); - mpfr_mul (t, s, s, GFC_RND_MODE); - mpfr_add_ui (t, t, 1, GFC_RND_MODE); - mpfr_sqrt (t, t, GFC_RND_MODE); - mpfr_abs (s, s, GFC_RND_MODE); - mpfr_add (t, t, s, GFC_RND_MODE); - mpfr_div_ui (t, t, 2, GFC_RND_MODE); - mpfr_sqrt (t, t, GFC_RND_MODE); - mpfr_sqrt (s, ad, GFC_RND_MODE); - mpfr_mul (w, s, t, GFC_RND_MODE); + 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]; } - if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0) + offset = 0; + for (source_ctor = gfc_constructor_first (source->value.constructor); + source_ctor; source_ctor = gfc_constructor_next (source_ctor)) { - mpfr_mul_ui (t, w, 2, GFC_RND_MODE); - mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE); - mpfr_set (result->value.complex.r, w, GFC_RND_MODE); + 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 if (mpfr_cmp_ui (w, 0) != 0 - && mpfr_cmp_ui (e->value.complex.r, 0) < 0 - && mpfr_cmp_ui (e->value.complex.i, 0) >= 0) + } + 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) +{ + gfc_expr *result; + + if (!is_constant_array_expr (array) + || !gfc_is_constant_expr (dim)) + return NULL; + + if (mask + && !is_constant_array_expr (mask) + && mask->expr_type != EXPR_CONSTANT) + return NULL; + + result = transformational_result (array, dim, array->ts.type, + array->ts.kind, &array->where); + init_result_expr (result, 0, NULL); + + return !dim || array->rank == 1 ? + simplify_transformation_to_scalar (result, array, mask, gfc_add) : + simplify_transformation_to_array (result, array, dim, mask, gfc_add); +} + + +gfc_expr * +gfc_simplify_tan (gfc_expr *x) +{ + 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 { - mpfr_mul_ui (t, w, 2, GFC_RND_MODE); - mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE); - mpfr_set (result->value.complex.i, w, GFC_RND_MODE); + result_length = source_size / result_elt_size; + if (result_length * result_elt_size < source_size) + result_length += 1; } - else if (mpfr_cmp_ui (w, 0) != 0 - && mpfr_cmp_ui (e->value.complex.r, 0) < 0 - && mpfr_cmp_ui (e->value.complex.i, 0) < 0) + + 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; + + 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; + +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++) { - mpfr_mul_ui (t, w, 2, GFC_RND_MODE); - mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE); - mpfr_neg (w, w, GFC_RND_MODE); - mpfr_set (result->value.complex.i, w, GFC_RND_MODE); + 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]; + } } - else - gfc_internal_error ("invalid complex argument of SQRT at %L", - &e->where); - mpfr_clears (s, t, ac, ad, w, NULL); + /* 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;*/ - break; + d = mpz_get_si (dim->value.integer); - default: - gfc_internal_error ("invalid argument of SQRT at %L", &e->where); - } + if (d < 1 || d > as->corank) + { + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; + } - return range_check (result, "SQRT"); + /*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; + } -negative_arg: - gfc_free_expr (result); - gfc_error ("Argument of SQRT at %L has a negative value", &e->where); +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_tan (gfc_expr *x) +gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) { - int i; gfc_expr *result; + gfc_ref *ref; + gfc_array_spec *as; + gfc_constructor *sub_cons; + bool first_image; + int d; - if (x->expr_type != EXPR_CONSTANT) - return NULL; + if (!is_constant_array_expr (sub)) + goto not_implemented; /* return NULL;*/ - i = gfc_validate_kind (BT_REAL, x->ts.kind, false); + /* 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; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + if (as->type == AS_DEFERRED) + goto not_implemented; /* return NULL;*/ - mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); + /* "valid sequence of cosubscripts" are required; thus, return 0 unless + the cosubscript addresses the first image. */ - return range_check (result, "TAN"); -} + sub_cons = gfc_constructor_first (sub->value.constructor); + first_image = true; + for (d = 1; d <= as->corank; d++) + { + gfc_expr *ca_bound; + int cmp; -gfc_expr * -gfc_simplify_tanh (gfc_expr *x) -{ - gfc_expr *result; + if (sub_cons == NULL) + { + gfc_error ("Too few elements in expression for SUB= argument at %L", + &sub->where); + return &gfc_bad_expr; + } - if (x->expr_type != EXPR_CONSTANT) - return NULL; + ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, + NULL, true); + if (ca_bound == NULL) + goto not_implemented; /* return NULL */ - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + if (ca_bound == &gfc_bad_expr) + return ca_bound; - mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); + cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer); - return range_check (result, "TANH"); + 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_expr * -gfc_simplify_tiny (gfc_expr *e) -{ - gfc_expr *result; - int i; + gfc_free_expr (ca_bound); - i = gfc_validate_kind (BT_REAL, e->ts.kind, false); + /* 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; + } - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); - mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); + 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_trailz (gfc_expr *e) +gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) { - gfc_expr *result; - unsigned long tz, bs; - int i; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - bs = gfc_integer_kinds[i].bit_size; - tz = mpz_scan1 (e->value.integer, 0); + gfc_ref *ref; + gfc_array_spec *as; + int d; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where); - mpz_set_ui (result->value.integer, MIN (tz, bs)); + 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; + } - 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; -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 (as->type == AS_DEFERRED) + goto not_implemented; /* return NULL;*/ - if (!gfc_is_constant_expr (source) - || (gfc_init_expr && !gfc_is_constant_expr (mold)) - || !gfc_is_constant_expr (size)) - return NULL; + if (dim == NULL) + { + /* Multi-dimensional bounds. */ + gfc_expr *bounds[GFC_MAX_DIMENSIONS]; + gfc_expr *e; - if (source->expr_type == EXPR_FUNCTION) - return NULL; + /* 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; - /* 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."); + for (j = 0; j < d; j++) + gfc_free_expr (bounds[j]); + if (bounds[d] == NULL) + goto not_implemented; + return bounds[d]; + } + } - source_size = gfc_target_expr_size (source); + /* 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; - /* Create an empty new expression with the appropriate characteristics. */ - result = gfc_constant_result (mold->ts.type, mold->ts.kind, - &source->where); - result->ts = mold->ts; + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], as->corank); - mold_element = mold->expr_type == EXPR_ARRAY - ? mold->value.constructor->expr - : mold; + /* Create the constructor for this array. */ + for (d = 0; d < as->corank; d++) + gfc_constructor_append_expr (&e->value.constructor, + bounds[d], &e->where); - /* 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; + return e; } - - if (mold->expr_type == EXPR_ARRAY || mold->rank || size) + else { - int result_length; + gfc_expr *e; + /* A DIM argument is specified. */ + if (dim->expr_type != EXPR_CONSTANT) + goto not_implemented; /*return NULL;*/ - result->expr_type = EXPR_ARRAY; - result->rank = 1; + d = mpz_get_si (dim->value.integer); - if (size) - result_length = (size_t)mpz_get_ui (size->value.integer); - else + if (d < 1 || d > as->corank) { - result_length = source_size / result_elt_size; - if (result_length * result_elt_size < source_size) - result_length += 1; + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; } - result->shape = gfc_get_shape (1); - mpz_init_set_ui (result->shape[0], result_length); + /*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; + } - result_size = result_length * result_elt_size; - } - else - { - result->rank = 0; - result_size = result_elt_size; - } +not_implemented: + gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant " + "cobounds at %L", &coarray->where); + return &gfc_bad_expr; +} - 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); +gfc_expr * +gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + return simplify_bound (array, dim, kind, 1); +} - /* Now write source to the buffer. */ - gfc_target_encode_expr (source, buffer, buffer_size); +gfc_expr * +gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + gfc_expr *e; + /* return simplify_cobound (array, dim, kind, 1);*/ - /* And read the buffer back into the new expression. */ - gfc_target_interpret_expr (buffer, buffer_size, result); + e = simplify_cobound (array, dim, kind, 1); + if (e != NULL) + return e; - return result; + gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant " + "cobounds at %L", &array->where); + return &gfc_bad_expr; } gfc_expr * -gfc_simplify_trim (gfc_expr *e) +gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { - gfc_expr *result; - int count, i, len, lentrim; + gfc_expr *result, *e; + gfc_constructor *vector_ctor, *mask_ctor, *field_ctor; - if (e->expr_type != EXPR_CONSTANT) + if (!is_constant_array_expr (vector) + || !is_constant_array_expr (mask) + || (!gfc_is_constant_expr (field) + && !is_constant_array_expr(field))) return NULL; - len = e->value.character.length; + result = gfc_get_array_expr (vector->ts.type, vector->ts.kind, + &vector->where); + result->rank = mask->rank; + result->shape = gfc_copy_shape (mask->shape, mask->rank); - result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); + if (vector->ts.type == BT_CHARACTER) + result->ts.u.cl = vector->ts.u.cl; - for (count = 0, i = 1; i <= len; ++i) + 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 (e->value.character.string[len - i] == ' ') - count++; + 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 - break; - } - - lentrim = len - count; + e = gfc_copy_expr (field); - result->value.character.length = lentrim; - result->value.character.string = gfc_get_wide_string (lentrim + 1); + gfc_constructor_append_expr (&result->value.constructor, e, NULL); - for (i = 0; i < lentrim; i++) - result->value.character.string[i] = e->value.character.string[i]; - - result->value.character.string[lentrim] = '\0'; /* For debugger */ + mask_ctor = gfc_constructor_next (mask_ctor); + field_ctor = gfc_constructor_next (field_ctor); + } return result; } 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_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) { gfc_expr *result; @@ -4512,7 +5750,7 @@ gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) else back = 0; - result = gfc_constant_result (BT_INTEGER, k, &s->where); + result = gfc_get_constant_expr (BT_INTEGER, k, &s->where); len = s->value.character.length; lenset = set->value.character.length; @@ -4572,20 +5810,22 @@ gfc_simplify_xor (gfc_expr *x, gfc_expr *y) return NULL; kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - if (x->ts.type == BT_INTEGER) - { - result = gfc_constant_result (BT_INTEGER, kind, &x->where); - mpz_xor (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "XOR"); - } - else /* BT_LOGICAL */ + + switch (x->ts.type) { - result = gfc_constant_result (BT_LOGICAL, kind, &x->where); - result->value.logical = (x->value.logical && !y->value.logical) - || (!x->value.logical && y->value.logical); - return result; - } + 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 (); + } } @@ -4600,7 +5840,7 @@ gfc_expr * gfc_convert_constant (gfc_expr *e, bt type, int kind) { gfc_expr *g, *result, *(*f) (gfc_expr *, int); - gfc_constructor *head, *c, *tail = NULL; + gfc_constructor *c; switch (e->ts.type) { @@ -4720,45 +5960,37 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) if (!gfc_is_constant_expr (e)) break; - head = NULL; + result = gfc_get_array_expr (type, kind, &e->where); + result->shape = gfc_copy_shape (e->shape, e->rank); + result->rank = e->rank; - for (c = e->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) { - if (head == NULL) - head = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } - - tail->where = c->where; - + gfc_expr *tmp; if (c->iterator == NULL) - tail->expr = f (c->expr, kind); + tmp = f (c->expr, kind); else { g = gfc_convert_constant (c->expr, type, kind); if (g == &gfc_bad_expr) - return g; - tail->expr = g; + { + gfc_free_expr (result); + return g; + } + tmp = g; } - if (tail->expr == NULL) + if (tmp == NULL) { - gfc_free_constructor (head); + gfc_free_expr (result); return NULL; } + + gfc_constructor_append_expr (&result->value.constructor, + tmp, &c->where); } - result = gfc_get_expr (); - result->ts.type = type; - result->ts.kind = kind; - result->expr_type = EXPR_ARRAY; - result->value.constructor = head; - result->shape = gfc_copy_shape (e->shape, e->rank); - result->where = e->where; - result->rank = e->rank; break; default: @@ -4782,7 +6014,7 @@ gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) if (e->expr_type == EXPR_CONSTANT) { /* Simple case of a scalar. */ - result = gfc_constant_result (BT_CHARACTER, kind, &e->where); + result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where); if (result == NULL) return &gfc_bad_expr; @@ -4809,42 +6041,32 @@ gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) else if (e->expr_type == EXPR_ARRAY) { /* For an array constructor, we convert each constructor element. */ - gfc_constructor *head = NULL, *tail = NULL, *c; + gfc_constructor *c; - for (c = e->value.constructor; c; c = c->next) - { - if (head == NULL) - head = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } + 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; - tail->where = c->where; - tail->expr = gfc_convert_char_constant (c->expr, type, kind); - if (tail->expr == &gfc_bad_expr) + 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) { - tail->expr = NULL; + gfc_free_expr (result); return &gfc_bad_expr; } - if (tail->expr == NULL) + if (tmp == NULL) { - gfc_free_constructor (head); + gfc_free_expr (result); return NULL; } - } - result = gfc_get_expr (); - result->ts.type = type; - result->ts.kind = kind; - result->expr_type = EXPR_ARRAY; - result->value.constructor = head; - result->shape = gfc_copy_shape (e->shape, e->rank); - result->where = e->where; - result->rank = e->rank; - result->ts.cl = e->ts.cl; + gfc_constructor_append_expr (&result->value.constructor, + tmp, &c->where); + } return result; }