X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Fsimplify.c;h=86de9cd6187f6274bdfbd5cc0e1e76bd23b94850;hp=79341d3d1e12d6e5310c88cdee1a373296742c93;hb=0ffa0eb3d455bcada785c3f8d4f696ffa21e122e;hpb=95f99f0564794ac8288d5bbb593fa03f2d6396cd diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 79341d3d1e1..86de9cd6187 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, 2009 - Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, + 2010, 2011 Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb This file is part of GCC. @@ -26,10 +26,9 @@ along with GCC; see the file COPYING3. If not see #include "arith.h" #include "intrinsic.h" #include "target-memory.h" +#include "constructor.h" +#include "version.h" /* For version_string. */ -/* Savely advance an array constructor by 'n' elements. - Mainly used by simplifiers of transformational intrinsics. */ -#define ADVANCE(ctor, n) do { int i; for (i = 0; i < n && ctor; ++i) ctor = ctor->next; } while (0) gfc_expr gfc_bad_expr; @@ -45,15 +44,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 @@ -62,7 +58,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 @@ -77,6 +74,9 @@ range_check (gfc_expr *result, const char *name) if (result == NULL) return &gfc_bad_expr; + if (result->expr_type != EXPR_CONSTANT) + return result; + switch (gfc_range_check (result)) { case ARITH_OK: @@ -136,20 +136,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 @@ -214,6 +200,27 @@ convert_mpz_to_signed (mpz_t x, int bitsize) } } + +/* In-place convert BOZ to REAL of the specified kind. */ + +static gfc_expr * +convert_boz (gfc_expr *x, int kind) +{ + if (x && x->ts.type == BT_INTEGER && x->is_boz) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_REAL; + ts.kind = kind; + + if (!gfc_convert_boz (x, &ts)) + return &gfc_bad_expr; + } + + return x; +} + + /* Test that the expression is an constant array. */ static bool @@ -227,8 +234,10 @@ is_constant_array_expr (gfc_expr *e) if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) return false; - for (c = e->value.constructor; c; c = c->next) - if (c->expr->expr_type != EXPR_CONSTANT) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + if (c->expr->expr_type != EXPR_CONSTANT + && c->expr->expr_type != EXPR_STRUCTURE) return false; return true; @@ -242,11 +251,11 @@ init_result_expr (gfc_expr *e, int init, gfc_expr *array) { if (e && e->expr_type == EXPR_ARRAY) { - gfc_constructor *ctor = e->value.constructor; + gfc_constructor *ctor = gfc_constructor_first (e->value.constructor); while (ctor) { init_result_expr (ctor->expr, init, array); - ctor = ctor->next; + ctor = gfc_constructor_next (ctor); } } else if (e && e->expr_type == EXPR_CONSTANT) @@ -283,12 +292,7 @@ init_result_expr (gfc_expr *e, int init, gfc_expr *array) break; case BT_COMPLEX: -#ifdef HAVE_mpc mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE); -#else - mpfr_set_si (e->value.complex.r, init, GFC_RND_MODE); - mpfr_set_si (e->value.complex.i, 0, GFC_RND_MODE); -#endif break; case BT_CHARACTER: @@ -329,18 +333,18 @@ init_result_expr (gfc_expr *e, int init, gfc_expr *array) /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */ static gfc_expr * -compute_dot_product (gfc_constructor *ctor_a, int stride_a, - gfc_constructor *ctor_b, int stride_b) +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; - gfc_expr *a = ctor_a->expr, *b = ctor_b->expr; - - gcc_assert (gfc_compare_types (&a->ts, &b->ts)); + gfc_expr *result, *a, *b; - result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where); + result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind, + &matrix_a->where); init_result_expr (result, 0, NULL); - while (ctor_a && ctor_b) + 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. */ @@ -348,24 +352,27 @@ compute_dot_product (gfc_constructor *ctor_a, int stride_a, { case BT_LOGICAL: result = gfc_or (result, - gfc_and (gfc_copy_expr (ctor_a->expr), - gfc_copy_expr (ctor_b->expr))); + 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 (ctor_a->expr), - gfc_copy_expr (ctor_b->expr))); + gfc_multiply (gfc_copy_expr (a), + gfc_copy_expr (b))); break; default: gcc_unreachable(); } - ADVANCE (ctor_a, stride_a); - ADVANCE (ctor_b, stride_b); + 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; @@ -383,9 +390,9 @@ transformational_result (gfc_expr *array, gfc_expr *dim, bt type, int i, nelem; if (!dim || array->rank == 1) - return gfc_constant_result (type, kind, where); + return gfc_get_constant_expr (type, kind, where); - result = gfc_start_constructor (type, kind, where); + result = gfc_get_array_expr (type, kind, where); result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); result->rank = array->rank - 1; @@ -397,8 +404,9 @@ transformational_result (gfc_expr *array, gfc_expr *dim, bt type, for (i = 0; i < nelem; ++i) { - gfc_expr *e = gfc_constant_result (type, kind, where); - gfc_append_constructor (result, e); + gfc_constructor_append_expr (&result->value.constructor, + gfc_get_constant_expr (type, kind, where), + NULL); } return result; @@ -451,21 +459,21 @@ simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr * && !mask->value.logical) return result; - array_ctor = array->value.constructor; + array_ctor = gfc_constructor_first (array->value.constructor); mask_ctor = NULL; if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = mask->value.constructor; + mask_ctor = gfc_constructor_first (mask->value.constructor); while (array_ctor) { a = array_ctor->expr; - array_ctor = array_ctor->next; + 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 = mask_ctor->next; + mask_ctor = gfc_constructor_next (mask_ctor); if (!m->value.logical) continue; } @@ -482,11 +490,12 @@ simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr * REAL, PARAMETER :: array(n, m) = ... REAL, PARAMETER :: s(n) = PROD(array, DIM=1) - where OP == gfc_multiply(). */ + where OP == gfc_multiply(). The result might be post processed using post_op. */ static gfc_expr * simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask, transformational_op op) + gfc_expr *mask, transformational_op op, + transformational_op post_op) { mpz_t size; int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; @@ -507,25 +516,26 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d linked-list traversal. Masked elements are set to NULL. */ gfc_array_size (array, &size); arraysize = mpz_get_ui (size); + mpz_clear (size); - arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize); + arrayvec = XCNEWVEC (gfc_expr*, arraysize); - array_ctor = array->value.constructor; + array_ctor = gfc_constructor_first (array->value.constructor); mask_ctor = NULL; if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = mask->value.constructor; + mask_ctor = gfc_constructor_first (mask->value.constructor); for (i = 0; i < arraysize; ++i) { arrayvec[i] = array_ctor->expr; - array_ctor = array_ctor->next; + array_ctor = gfc_constructor_next (array_ctor); if (mask_ctor) { if (!mask_ctor->expr->value.logical) arrayvec[i] = NULL; - mask_ctor = mask_ctor->next; + mask_ctor = gfc_constructor_next (mask_ctor); } } @@ -534,12 +544,12 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d resultsize = mpz_get_ui (size); mpz_clear (size); - resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize); - result_ctor = result->value.constructor; + resultvec = XCNEWVEC (gfc_expr*, resultsize); + result_ctor = gfc_constructor_first (result->value.constructor); for (i = 0; i < resultsize; ++i) { resultvec[i] = result_ctor->expr; - result_ctor = result_ctor->next; + result_ctor = gfc_constructor_next (result_ctor); } gfc_extract_int (dim, &dim_index); @@ -597,19 +607,46 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d } /* Place updated expression in result constructor. */ - result_ctor = result->value.constructor; + result_ctor = gfc_constructor_first (result->value.constructor); for (i = 0; i < resultsize; ++i) { - result_ctor->expr = resultvec[i]; - result_ctor = result_ctor->next; + if (post_op) + result_ctor->expr = post_op (result_ctor->expr, resultvec[i]); + else + result_ctor->expr = resultvec[i]; + result_ctor = gfc_constructor_next (result_ctor); } - gfc_free (arrayvec); - gfc_free (resultvec); + free (arrayvec); + free (resultvec); return result; } +static gfc_expr * +simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, + int init_val, transformational_op op) +{ + gfc_expr *result; + + if (!is_constant_array_expr (array) + || !gfc_is_constant_expr (dim)) + return NULL; + + if (mask + && !is_constant_array_expr (mask) + && mask->expr_type != EXPR_CONSTANT) + return NULL; + + result = transformational_result (array, dim, array->ts.type, + array->ts.kind, &array->where); + init_result_expr (result, init_val, NULL); + + return !dim || array->rank == 1 ? + simplify_transformation_to_scalar (result, array, mask, op) : + simplify_transformation_to_array (result, array, dim, mask, op, NULL); +} + /********************** Simplification functions *****************************/ @@ -623,41 +660,25 @@ gfc_simplify_abs (gfc_expr *e) switch (e->ts.type) { - case BT_INTEGER: - result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where); - - mpz_abs (result->value.integer, e->value.integer); - - result = range_check (result, "IABS"); - break; - - case BT_REAL: - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); - - mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE); - - result = range_check (result, "ABS"); - break; - - case BT_COMPLEX: - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + 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"); - gfc_set_model_kind (e->ts.kind); + 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"); -#ifdef HAVE_mpc - mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE); -#else - mpfr_hypot (result->value.real, e->value.complex.r, - e->value.complex.i, GFC_RND_MODE); -#endif - result = range_check (result, "CABS"); - break; + 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"); + default: + gfc_internal_error ("gfc_simplify_abs(): Bad type"); } - - return result; } @@ -707,11 +728,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; } @@ -735,17 +754,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"); } @@ -758,16 +788,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_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; - 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"); } @@ -784,11 +826,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]; @@ -797,14 +834,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; } @@ -821,11 +854,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]; @@ -834,14 +862,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; } @@ -854,7 +881,7 @@ 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); + 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"); @@ -875,10 +902,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"); @@ -888,19 +915,7 @@ 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); + return simplify_transformation (mask, dim, NULL, true, gfc_and); } @@ -913,10 +928,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"); @@ -924,6 +939,21 @@ gfc_simplify_dint (gfc_expr *e) gfc_expr * +gfc_simplify_dreal (gfc_expr *e) +{ + gfc_expr *result = NULL; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); + + return range_check (result, "DREAL"); +} + + +gfc_expr * gfc_simplify_anint (gfc_expr *e, gfc_expr *k) { gfc_expr *result; @@ -936,8 +966,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"); @@ -954,17 +983,20 @@ 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 (); } } @@ -972,19 +1004,7 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y) gfc_expr * gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) { - gfc_expr *result; - - if (!is_constant_array_expr (mask) - || !gfc_is_constant_expr (dim)) - return NULL; - - result = transformational_result (mask, dim, mask->ts.type, - mask->ts.kind, &mask->where); - init_result_expr (result, false, NULL); - - return !dim || mask->rank == 1 ? - simplify_transformation_to_scalar (result, mask, NULL, gfc_or) : - simplify_transformation_to_array (result, mask, dim, NULL, gfc_or); + return simplify_transformation (mask, dim, NULL, false, gfc_or); } @@ -996,8 +1016,7 @@ gfc_simplify_dnint (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where); - + 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"); @@ -1012,17 +1031,28 @@ gfc_simplify_asin (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 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"); } @@ -1036,9 +1066,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"); } @@ -1051,10 +1093,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"); } @@ -1068,17 +1122,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"); } @@ -1099,8 +1164,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"); @@ -1108,14 +1172,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"); @@ -1123,14 +1187,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"); @@ -1138,8 +1202,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; @@ -1148,77 +1211,263 @@ 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"); } -gfc_expr * -gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED) +/* Simplify transformational form of JN and YN. */ + +static gfc_expr * +gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, + bool jn) { gfc_expr *result; + gfc_expr *e; + long n1, n2; + int i; + mpfr_t x2rev, last1, last2; - if (x->expr_type != EXPR_CONSTANT) + if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT + || order2->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE); + n1 = mpz_get_si (order1->value.integer); + n2 = mpz_get_si (order2->value.integer); + result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where); + result->rank = 1; + result->shape = gfc_get_shape (1); + mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0)); - return range_check (result, "BESSEL_Y0"); -} + if (n2 < n1) + return result; + /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and + YN(N, 0.0) = -Inf. */ -gfc_expr * -gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED) -{ - gfc_expr *result; + if (mpfr_cmp_ui (x->value.real, 0.0) == 0) + { + if (!jn && gfc_option.flag_range_check) + { + gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } - if (x->expr_type != EXPR_CONSTANT) - return NULL; + if (jn && n1 == 0) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set_ui (e->value.real, 1, GFC_RND_MODE); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + n1++; + } - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE); + for (i = n1; i <= n2; i++) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + if (jn) + mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); + else + mpfr_set_inf (e->value.real, -1); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + } - return range_check (result, "BESSEL_Y1"); -} + return result; + } + /* Use the faster but more verbose recurrence algorithm. Bessel functions + are stable for downward recursion and Neumann functions are stable + for upward recursion. It is + x2rev = 2.0/x, + J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x), + Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x). + Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */ -gfc_expr * -gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED, - gfc_expr *x ATTRIBUTE_UNUSED) -{ - gfc_expr *result; - long n; + gfc_set_model_kind (x->ts.kind); - if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) - return NULL; + /* Get first recursion anchor. */ - n = mpz_get_si (order->value.integer); - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE); + mpfr_init (last1); + if (jn) + mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE); + else + mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE); - return range_check (result, "BESSEL_YN"); -} + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (e->value.real, last1, GFC_RND_MODE); + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + { + mpfr_clear (last1); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; + } + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); + if (n1 == n2) + { + mpfr_clear (last1); + return result; + } + + /* Get second recursion anchor. */ -gfc_expr * -gfc_simplify_bit_size (gfc_expr *e) -{ - gfc_expr *result; - int i; + mpfr_init (last2); + if (jn) + mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE); + else + mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE); - 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); + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (e->value.real, last2, GFC_RND_MODE); + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + { + mpfr_clear (last1); + mpfr_clear (last2); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; + } + if (jn) + gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2); + else + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); - return result; -} + if (n1 + 1 == n2) + { + mpfr_clear (last1); + mpfr_clear (last2); + return result; + } + /* Start actual recursion. */ -gfc_expr * -gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) + mpfr_init (x2rev); + mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE); + + for (i = 2; i <= n2-n1; i++) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + /* Special case: For YN, if the previous N gave -INF, set + also N+1 to -INF. */ + if (!jn && !gfc_option.flag_range_check && mpfr_inf_p (last2)) + { + mpfr_set_inf (e->value.real, -1); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + continue; + } + + mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1), + GFC_RND_MODE); + mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE); + mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE); + + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + goto error; + + if (jn) + gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, + -i-1); + else + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); + + mpfr_set (last1, last2, GFC_RND_MODE); + mpfr_set (last2, e->value.real, GFC_RND_MODE); + } + + mpfr_clear (last1); + mpfr_clear (last2); + mpfr_clear (x2rev); + return result; + +error: + mpfr_clear (last1); + mpfr_clear (last2); + mpfr_clear (x2rev); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; +} + + +gfc_expr * +gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) +{ + return gfc_simplify_bessel_n2 (order1, order2, x, true); +} + + +gfc_expr * +gfc_simplify_bessel_y0 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_Y0"); +} + + +gfc_expr * +gfc_simplify_bessel_y1 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_Y1"); +} + + +gfc_expr * +gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x) +{ + gfc_expr *result; + long n; + + if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) + return NULL; + + n = mpz_get_si (order->value.integer); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_YN"); +} + + +gfc_expr * +gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) +{ + return gfc_simplify_bessel_n2 (order1, order2, x, false); +} + + +gfc_expr * +gfc_simplify_bit_size (gfc_expr *e) +{ + int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + return gfc_get_int_expr (e->ts.kind, &e->where, + gfc_integer_kinds[i].bit_size); +} + + +gfc_expr * +gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) { int b; @@ -1226,9 +1475,78 @@ 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)); +} + + +static int +compare_bitwise (gfc_expr *i, gfc_expr *j) +{ + mpz_t x, y; + int k, res; + + gcc_assert (i->ts.type == BT_INTEGER); + gcc_assert (j->ts.type == BT_INTEGER); + + mpz_init_set (x, i->value.integer); + k = gfc_validate_kind (i->ts.type, i->ts.kind, false); + convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); + + mpz_init_set (y, j->value.integer); + k = gfc_validate_kind (j->ts.type, j->ts.kind, false); + convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size); + + res = mpz_cmp (x, y); + mpz_clear (x); + mpz_clear (y); + return res; +} + + +gfc_expr * +gfc_simplify_bge (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) >= 0); +} + + +gfc_expr * +gfc_simplify_bgt (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) > 0); +} + + +gfc_expr * +gfc_simplify_ble (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) <= 0); +} + + +gfc_expr * +gfc_simplify_blt (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) < 0); } @@ -1245,11 +1563,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); @@ -1265,134 +1582,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; -#ifndef HAVE_mpc - mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); -#endif + if (convert_boz (y, kind) == &gfc_bad_expr) + return &gfc_bad_expr; + + if (x->expr_type != EXPR_CONSTANT + || (y != NULL && y->expr_type != EXPR_CONSTANT)) + return NULL; + + result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where); switch (x->ts.type) { - case BT_INTEGER: - if (!x->is_boz) -#ifdef HAVE_mpc + case BT_INTEGER: mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE); -#else - mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE); -#endif - break; + break; - case BT_REAL: -#ifdef HAVE_mpc - mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); -#else - mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE); -#endif - break; + case BT_REAL: + mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); + break; - case BT_COMPLEX: -#ifdef HAVE_mpc - mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); -#else - mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE); - mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE); -#endif - break; + 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 (mpc_imagref (result->value.complex), - y->value.integer, GFC_RND_MODE); - break; + if (!y) + return range_check (result, name); - 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)"); - } - } - - /* 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 (mpc_realref (result->value.complex), - 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 (mpc_imagref (result->value.complex), - 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); } @@ -1402,24 +1660,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); } @@ -1434,11 +1684,7 @@ gfc_simplify_conjg (gfc_expr *e) return NULL; result = gfc_copy_expr (e); -#ifdef HAVE_mpc mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE); -#else - mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE); -#endif return range_check (result, "CONJG"); } @@ -1452,42 +1698,24 @@ gfc_simplify_cos (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_cos (result->value.real, x->value.real, GFC_RND_MODE); - break; - case BT_COMPLEX: - gfc_set_model_kind (x->ts.kind); -#ifdef HAVE_mpc - mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); -#else - { - mpfr_t xp, xq; - mpfr_init (xp); - mpfr_init (xq); - - 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); - } -#endif - 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"); - } @@ -1499,9 +1727,21 @@ 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"); } @@ -1529,18 +1769,13 @@ gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) 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); + simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL); } gfc_expr * gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) { - - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return only_convert_cmplx_boz (x, y, gfc_default_double_kind); - return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); } @@ -1553,38 +1788,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"); } @@ -1596,22 +1805,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); } @@ -1625,29 +1835,29 @@ 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"); @@ -1657,8 +1867,6 @@ gfc_simplify_dim (gfc_expr *x, gfc_expr *y) gfc_expr* gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) { - gfc_expr *result; - if (!is_constant_array_expr (vector_a) || !is_constant_array_expr (vector_b)) return NULL; @@ -1667,16 +1875,7 @@ gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) gcc_assert (vector_b->rank == 1); gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts)); - if (vector_a->value.constructor && vector_b->value.constructor) - return compute_dot_product (vector_a->value.constructor, 1, - vector_b->value.constructor, 1); - - /* Zero sized array ... */ - result = gfc_constant_result (vector_a->ts.type, - vector_a->ts.kind, - &vector_a->where); - init_result_expr (result, 0, NULL); - return result; + return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0); } @@ -1688,20 +1887,71 @@ 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"); } +static gfc_expr * +simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, + bool right) +{ + gfc_expr *result; + int i, k, size, shift; + + if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT + || shiftarg->expr_type != EXPR_CONSTANT) + return NULL; + + k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false); + size = gfc_integer_kinds[k].bit_size; + + gfc_extract_int (shiftarg, &shift); + + /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */ + if (right) + shift = size - shift; + + result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where); + mpz_set_ui (result->value.integer, 0); + + for (i = 0; i < shift; i++) + if (mpz_tstbit (arg2->value.integer, size - shift + i)) + mpz_setbit (result->value.integer, i); + + for (i = 0; i < size - shift; i++) + if (mpz_tstbit (arg1->value.integer, i)) + mpz_setbit (result->value.integer, shift + i); + + /* Convert to a signed value. */ + convert_mpz_to_signed (result->value.integer, size); + + return result; +} + + +gfc_expr * +gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) +{ + return simplify_dshift (arg1, arg2, shiftarg, true); +} + + +gfc_expr * +gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) +{ + return simplify_dshift (arg1, arg2, shiftarg, false); +} + + gfc_expr * gfc_simplify_erf (gfc_expr *x) { @@ -1710,8 +1960,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"); @@ -1726,8 +1975,7 @@ 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"); @@ -1858,7 +2106,7 @@ gfc_simplify_erfc_scaled (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); if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0) asympt_erfc_scaled (result->value.real, x->value.real); else @@ -1879,8 +2127,7 @@ gfc_simplify_epsilon (gfc_expr *e) i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); - + 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"); @@ -1895,40 +2142,27 @@ gfc_simplify_exp (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_exp (result->value.real, x->value.real, GFC_RND_MODE); - break; + 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); -#ifdef HAVE_mpc - mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); -#else - { - mpfr_t xp, xq; - mpfr_init (xp); - mpfr_init (xq); - mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE); - 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); - } -#endif - 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"); + default: + gfc_internal_error ("in gfc_simplify_exp(): Bad type"); } return range_check (result, "EXP"); } + gfc_expr * gfc_simplify_exponent (gfc_expr *x) { @@ -1938,8 +2172,8 @@ gfc_simplify_exponent (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &x->where); + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &x->where); gfc_set_model (x->value.real); @@ -1966,25 +2200,105 @@ 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"); } +static bool +is_last_ref_vtab (gfc_expr *e) +{ + gfc_ref *ref; + gfc_component *comp = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + comp = ref->u.c.component; + + if (!e->ref || !comp) + return e->symtree->n.sym->attr.vtab; + + if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0) + return true; + + return false; +} + + +gfc_expr * +gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) +{ + /* Avoid simplification of resolved symbols. */ + if (is_last_ref_vtab (a) || is_last_ref_vtab (mold)) + return NULL; + + if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_type_is_extension_of (mold->ts.u.derived, + a->ts.u.derived)); + /* Return .false. if the dynamic type can never be the same. */ + if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS + && !gfc_type_is_extension_of + (mold->ts.u.derived->components->ts.u.derived, + a->ts.u.derived->components->ts.u.derived) + && !gfc_type_is_extension_of + (a->ts.u.derived->components->ts.u.derived, + mold->ts.u.derived->components->ts.u.derived)) + || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS + && !gfc_type_is_extension_of + (a->ts.u.derived, + mold->ts.u.derived->components->ts.u.derived) + && !gfc_type_is_extension_of + (mold->ts.u.derived->components->ts.u.derived, + a->ts.u.derived)) + || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED + && !gfc_type_is_extension_of + (mold->ts.u.derived, + a->ts.u.derived->components->ts.u.derived))) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); + + if (mold->ts.type == BT_DERIVED + && gfc_type_is_extension_of (mold->ts.u.derived, + a->ts.u.derived->components->ts.u.derived)) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true); + + return NULL; +} + + +gfc_expr * +gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b) +{ + /* Avoid simplification of resolved symbols. */ + if (is_last_ref_vtab (a) || is_last_ref_vtab (b)) + return NULL; + + /* Return .false. if the dynamic type can never be the + same. */ + if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS) + && !gfc_type_compatible (&a->ts, &b->ts) + && !gfc_type_compatible (&b->ts, &a->ts)) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); + + if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_derived_types (a->ts.u.derived, + b->ts.u.derived)); +} + + gfc_expr * gfc_simplify_floor (gfc_expr *e, gfc_expr *k) { @@ -1999,12 +2313,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); @@ -2022,7 +2336,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) { @@ -2059,8 +2373,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"); @@ -2074,21 +2387,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; @@ -2103,7 +2415,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"); } @@ -2117,6 +2429,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; @@ -2133,15 +2446,54 @@ 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"); } +static gfc_expr * +do_bit_and (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_and (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + +gfc_expr * +gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, -1, do_bit_and); +} + + +static gfc_expr * +do_bit_ior (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_ior (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + +gfc_expr * +gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 0, do_bit_ior); +} + + gfc_expr * gfc_simplify_iand (gfc_expr *x, gfc_expr *y) { @@ -2150,8 +2502,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"); @@ -2167,21 +2518,10 @@ gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - if (gfc_extract_int (y, &pos) != NULL || pos < 0) - { - gfc_error ("Invalid second argument of IBCLR at %L", &y->where); - return &gfc_bad_expr; - } + gfc_extract_int (y, &pos); k = gfc_validate_kind (x->ts.type, x->ts.kind, false); - if (pos >= gfc_integer_kinds[k].bit_size) - { - gfc_error ("Second argument of IBCLR exceeds bit size at %L", - &y->where); - return &gfc_bad_expr; - } - result = gfc_copy_expr (x); convert_mpz_to_unsigned (result->value.integer, @@ -2209,17 +2549,8 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) || z->expr_type != EXPR_CONSTANT) return NULL; - if (gfc_extract_int (y, &pos) != NULL || pos < 0) - { - gfc_error ("Invalid second argument of IBITS at %L", &y->where); - return &gfc_bad_expr; - } - - if (gfc_extract_int (z, &len) != NULL || len < 0) - { - gfc_error ("Invalid third argument of IBITS at %L", &z->where); - return &gfc_bad_expr; - } + gfc_extract_int (y, &pos); + gfc_extract_int (z, &len); k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false); @@ -2232,7 +2563,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); @@ -2254,7 +2585,7 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) gfc_internal_error ("IBITS: Bad bit"); } - gfc_free (bits); + free (bits); convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); @@ -2272,21 +2603,10 @@ gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - if (gfc_extract_int (y, &pos) != NULL || pos < 0) - { - gfc_error ("Invalid second argument of IBSET at %L", &y->where); - return &gfc_bad_expr; - } + gfc_extract_int (y, &pos); k = gfc_validate_kind (x->ts.type, x->ts.kind, false); - if (pos >= gfc_integer_kinds[k].bit_size) - { - gfc_error ("Second argument of IBSET exceeds bit size at %L", - &y->where); - return &gfc_bad_expr; - } - result = gfc_copy_expr (x); convert_mpz_to_unsigned (result->value.integer, @@ -2306,6 +2626,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; @@ -2318,10 +2639,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"); } @@ -2334,8 +2657,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"); @@ -2362,7 +2684,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; @@ -2478,48 +2800,12 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) } } } - } - } - -done: - mpz_set_si (result->value.integer, index); - return range_check (result, "INDEX"); -} - - -gfc_expr * -gfc_simplify_int (gfc_expr *e, gfc_expr *k) -{ - 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; + } } - return range_check (result, "INT"); +done: + mpz_set_si (result->value.integer, index); + return range_check (result, "INDEX"); } @@ -2531,28 +2817,25 @@ simplify_intconv (gfc_expr *e, int kind, const char *name) if (e->expr_type != EXPR_CONSTANT) return NULL; - switch (e->ts.type) - { - case BT_INTEGER: - result = gfc_int2int (e, kind); - break; + result = gfc_convert_constant (e, BT_INTEGER, kind); + if (result == &gfc_bad_expr) + return &gfc_bad_expr; - case BT_REAL: - result = gfc_real2int (e, kind); - break; + return range_check (result, name); +} - case BT_COMPLEX: - result = gfc_complex2int (e, kind); - break; - default: - gfc_error ("Argument of %s at %L is not a valid type", name, &e->where); - return &gfc_bad_expr; - } +gfc_expr * +gfc_simplify_int (gfc_expr *e, gfc_expr *k) +{ + int kind; - return range_check (result, name); -} + kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + return simplify_intconv (e, kind, "INT"); +} gfc_expr * gfc_simplify_int2 (gfc_expr *e) @@ -2583,15 +2866,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"); } @@ -2604,15 +2887,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"); } @@ -2625,111 +2908,134 @@ 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"); } +static gfc_expr * +do_bit_xor (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_xor (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + gfc_expr * -gfc_simplify_is_iostat_end (gfc_expr *x) +gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) { - gfc_expr *result; + return simplify_transformation (array, dim, mask, 0, do_bit_xor); +} + + +gfc_expr * +gfc_simplify_is_iostat_end (gfc_expr *x) +{ if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &x->where); - result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_END) == 0); - - return result; + 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) { - gfc_expr *result; - if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &x->where); - result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_EOR) == 0); - - return result; + 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) { - gfc_expr *result; - if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &x->where); - result->value.logical = mpfr_nan_p (x->value.real); - - return result; + 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) +/* Performs a shift on its first argument. Depending on the last + argument, the shift can be arithmetic, i.e. with filling from the + left like in the SHIFTA intrinsic. */ +static gfc_expr * +simplify_shift (gfc_expr *e, gfc_expr *s, const char *name, + bool arithmetic, int direction) { gfc_expr *result; - int shift, ashift, isize, k, *bits, i; + int ashift, *bits, i, k, bitsize, shift; if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) return NULL; - if (gfc_extract_int (s, &shift) != NULL) - { - gfc_error ("Invalid second argument of ISHFT at %L", &s->where); - return &gfc_bad_expr; - } + gfc_extract_int (s, &shift); k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false); + bitsize = gfc_integer_kinds[k].bit_size; - isize = gfc_integer_kinds[k].bit_size; + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - if (shift >= 0) - ashift = shift; - else - ashift = -shift; + if (shift == 0) + { + mpz_set (result->value.integer, e->value.integer); + return result; + } - if (ashift > isize) + if (direction > 0 && shift < 0) { - gfc_error ("Magnitude of second argument of ISHFT exceeds bit size " - "at %L", &s->where); + /* Left shift, as in SHIFTL. */ + gfc_error ("Second argument of %s is negative at %L", name, &e->where); return &gfc_bad_expr; } + else if (direction < 0) + { + /* Right shift, as in SHIFTR or SHIFTA. */ + if (shift < 0) + { + gfc_error ("Second argument of %s is negative at %L", + name, &e->where); + return &gfc_bad_expr; + } - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + shift = -shift; + } - if (shift == 0) + ashift = (shift >= 0 ? shift : -shift); + + if (ashift > bitsize) { - mpz_set (result->value.integer, e->value.integer); - return range_check (result, "ISHFT"); + gfc_error ("Magnitude of second argument of %s exceeds bit size " + "at %L", name, &e->where); + return &gfc_bad_expr; } - - bits = XCNEWVEC (int, isize); - for (i = 0; i < isize; i++) + bits = XCNEWVEC (int, bitsize); + + for (i = 0; i < bitsize; i++) bits[i] = mpz_tstbit (e->value.integer, i); if (shift > 0) { + /* Left shift. */ for (i = 0; i < shift; i++) mpz_clrbit (result->value.integer, i); - for (i = 0; i < isize - shift; i++) + for (i = 0; i < bitsize - shift; i++) { if (bits[i] == 0) mpz_clrbit (result->value.integer, i + shift); @@ -2739,10 +3045,15 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) } else { - for (i = isize - 1; i >= isize - ashift; i--) - mpz_clrbit (result->value.integer, i); + /* Right shift. */ + if (arithmetic && bits[bitsize - 1]) + for (i = bitsize - 1; i >= bitsize - ashift; i--) + mpz_setbit (result->value.integer, i); + else + for (i = bitsize - 1; i >= bitsize - ashift; i--) + mpz_clrbit (result->value.integer, i); - for (i = isize - 1; i >= ashift; i--) + for (i = bitsize - 1; i >= ashift; i--) { if (bits[i] == 0) mpz_clrbit (result->value.integer, i - ashift); @@ -2751,14 +3062,56 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) } } - convert_mpz_to_signed (result->value.integer, isize); + convert_mpz_to_signed (result->value.integer, bitsize); + free (bits); - gfc_free (bits); return result; } gfc_expr * +gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "ISHFT", false, 0); +} + + +gfc_expr * +gfc_simplify_lshift (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "LSHIFT", false, 1); +} + + +gfc_expr * +gfc_simplify_rshift (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "RSHIFT", true, -1); +} + + +gfc_expr * +gfc_simplify_shifta (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "SHIFTA", true, -1); +} + + +gfc_expr * +gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "SHIFTL", false, 1); +} + + +gfc_expr * +gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "SHIFTR", false, -1); +} + + +gfc_expr * gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) { gfc_expr *result; @@ -2768,11 +3121,7 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) return NULL; - if (gfc_extract_int (s, &shift) != NULL) - { - gfc_error ("Invalid second argument of ISHFTC at %L", &s->where); - return &gfc_bad_expr; - } + gfc_extract_int (s, &shift); k = gfc_validate_kind (e->ts.type, e->ts.kind, false); isize = gfc_integer_kinds[k].bit_size; @@ -2782,18 +3131,8 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) if (sz->expr_type != EXPR_CONSTANT) return NULL; - if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0) - { - gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where); - return &gfc_bad_expr; - } + gfc_extract_int (sz, &ssize); - if (ssize > isize) - { - gfc_error ("Magnitude of third argument of ISHFTC exceeds " - "BIT_SIZE of first argument at %L", &s->where); - return &gfc_bad_expr; - } } else ssize = isize; @@ -2805,16 +3144,13 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) if (ashift > ssize) { - if (sz != NULL) - gfc_error ("Magnitude of second argument of ISHFTC exceeds " - "third argument at %L", &s->where); - else + if (sz == NULL) gfc_error ("Magnitude of second argument of ISHFTC exceeds " "BIT_SIZE of first argument at %L", &s->where); return &gfc_bad_expr; } - result = gfc_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); @@ -2869,7 +3205,7 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) convert_mpz_to_signed (result->value.integer, isize); - gfc_free (bits); + free (bits); return result; } @@ -2877,85 +3213,252 @@ 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_ref *ref) + gfc_array_spec *as, gfc_ref *ref, bool coarray) { gfc_expr *l, *u, *result; int k; + k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", + gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); + + /* For non-variables, LBOUND(expr, DIM=n) = 1 and + UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */ + if (!coarray && array->expr_type != EXPR_VARIABLE) + { + if (upper) + { + gfc_expr* dim = result; + mpz_set_si (dim->value.integer, d); + + result = gfc_simplify_size (array, dim, kind); + gfc_free_expr (dim); + if (!result) + goto returnNull; + } + else + mpz_set_si (result->value.integer, 1); + + goto done; + } + + /* Otherwise, we have a variable expression. */ + gcc_assert (array->expr_type == EXPR_VARIABLE); + gcc_assert (as); + + if (gfc_resolve_array_spec (as, 0) == FAILURE) + return NULL; + /* The last dimension of an assumed-size array is special. */ - if (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 + && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE))) { if (as->lower[d-1]->expr_type == EXPR_CONSTANT) - return gfc_copy_expr (as->lower[d-1]); + { + gfc_free_expr (result); + return gfc_copy_expr (as->lower[d-1]); + } + + goto returnNull; + } + + result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); + + /* Then, we need to know the extent of the given dimension. */ + if (coarray || ref->u.ar.type == AR_FULL) + { + l = as->lower[d-1]; + u = as->upper[d-1]; + + if (l->expr_type != EXPR_CONSTANT || u == NULL + || u->expr_type != EXPR_CONSTANT) + goto returnNull; + + if (mpz_cmp (l->value.integer, u->value.integer) > 0) + { + /* Zero extent. */ + if (upper) + mpz_set_si (result->value.integer, 0); + else + mpz_set_si (result->value.integer, 1); + } else - return NULL; + { + /* Nonzero extent. */ + if (upper) + mpz_set (result->value.integer, u->value.integer); + else + mpz_set (result->value.integer, l->value.integer); + } + } + else + { + if (upper) + { + if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer, NULL) + != SUCCESS) + goto returnNull; + } + else + mpz_set_si (result->value.integer, (long int) 1); + } + +done: + return range_check (result, upper ? "UBOUND" : "LBOUND"); + +returnNull: + gfc_free_expr (result); + return NULL; +} + + +static gfc_expr * +simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) +{ + gfc_ref *ref; + gfc_array_spec *as; + int d; + + if (array->ts.type == BT_CLASS) + return NULL; + + if (array->expr_type != EXPR_VARIABLE) + { + as = NULL; + ref = NULL; + goto done; + } + + /* Follow any component references. */ + as = array->symtree->n.sym->as; + for (ref = array->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + switch (ref->u.ar.type) + { + case AR_ELEMENT: + as = NULL; + continue; + + case AR_FULL: + /* We're done because 'as' has already been set in the + previous iteration. */ + if (!ref->next) + goto done; + + /* Fall through. */ + + case AR_UNKNOWN: + return NULL; + + case AR_SECTION: + as = ref->u.ar.as; + goto done; + } + + gcc_unreachable (); + + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + continue; + } } - k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", - gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; + gcc_unreachable (); - result = gfc_constant_result (BT_INTEGER, k, &array->where); + done: + if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)) + return NULL; - /* Then, we need to know the extent of the given dimension. */ - if (ref->u.ar.type == AR_FULL) + if (dim == NULL) { - l = as->lower[d-1]; - u = as->upper[d-1]; - - if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT) - return NULL; + /* Multi-dimensional bounds. */ + gfc_expr *bounds[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + int k; - if (mpz_cmp (l->value.integer, u->value.integer) > 0) + /* UBOUND(ARRAY) is not valid for an assumed-size array. */ + if (upper && as && as->type == AS_ASSUMED_SIZE) { - /* Zero extent. */ - if (upper) - mpz_set_si (result->value.integer, 0); - else - mpz_set_si (result->value.integer, 1); + /* An error message will be emitted in + check_assumed_size_reference (resolve.c). */ + return &gfc_bad_expr; } - else + + /* Simplify the bounds for each dimension. */ + for (d = 0; d < array->rank; d++) { - /* Nonzero extent. */ - if (upper) - mpz_set (result->value.integer, u->value.integer); - else - mpz_set (result->value.integer, l->value.integer); + bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref, + false); + if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) + { + int j; + + for (j = 0; j < d; j++) + gfc_free_expr (bounds[j]); + return bounds[d]; + } } + + /* Allocate the result expression. */ + k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", + gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + e = gfc_get_array_expr (BT_INTEGER, k, &array->where); + + /* The result is a rank 1 array; its size is the rank of the first + argument to {L,U}BOUND. */ + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], array->rank); + + /* Create the constructor for this array. */ + for (d = 0; d < array->rank; d++) + gfc_constructor_append_expr (&e->value.constructor, + bounds[d], &e->where); + + return e; } else { - if (upper) + /* A DIM argument is specified. */ + if (dim->expr_type != EXPR_CONSTANT) + return NULL; + + d = mpz_get_si (dim->value.integer); + + if (d < 1 || d > array->rank + || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) { - if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer) - != SUCCESS) - return NULL; + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; } - else - mpz_set_si (result->value.integer, (long int) 1); - } - return range_check (result, upper ? "UBOUND" : "LBOUND"); + return simplify_bound_dim (array, kind, d, upper, as, ref, false); + } } static gfc_expr * -simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) +simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) { gfc_ref *ref; gfc_array_spec *as; @@ -2965,7 +3468,9 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) return NULL; /* Follow any component references. */ - as = array->symtree->n.sym->as; + as = (array->ts.type == BT_CLASS && array->ts.u.derived->components) + ? array->ts.u.derived->components->as + : array->symtree->n.sym->as; for (ref = array->ref; ref; ref = ref->next) { switch (ref->type) @@ -2974,6 +3479,11 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) switch (ref->u.ar.type) { case AR_ELEMENT: + if (ref->u.ar.as->corank > 0) + { + gcc_assert (as == ref->u.ar.as); + goto done; + } as = NULL; continue; @@ -3004,33 +3514,26 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) } } - gcc_unreachable (); + if (!as) + gcc_unreachable (); done: - if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE) + if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE) return NULL; if (dim == NULL) { - /* Multi-dimensional bounds. */ + /* Multi-dimensional cobounds. */ 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. */ - if (upper && as->type == AS_ASSUMED_SIZE) - { - /* An error message will be emitted in - check_assumed_size_reference (resolve.c). */ - return &gfc_bad_expr; - } - - /* Simplify the bounds for each dimension. */ - for (d = 0; d < array->rank; d++) + /* Simplify the cobounds for each dimension. */ + for (d = 0; d < as->corank; d++) { - bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref); + bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank, + upper, as, ref, true); if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) { int j; @@ -3046,7 +3549,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) e->where = array->where; e->expr_type = EXPR_ARRAY; e->ts.type = BT_INTEGER; - k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", + k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND", gfc_default_integer_kind); if (k == -1) { @@ -3056,29 +3559,15 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) e->ts.kind = k; /* The result is a rank 1 array; its size is the rank of the first - argument to {L,U}BOUND. */ + argument to {L,U}COBOUND. */ e->rank = 1; e->shape = gfc_get_shape (1); - mpz_init_set_ui (e->shape[0], array->rank); + mpz_init_set_ui (e->shape[0], as->corank); /* 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; - + for (d = 0; d < as->corank; d++) + gfc_constructor_append_expr (&e->value.constructor, + bounds[d], &e->where); return e; } else @@ -3089,14 +3578,13 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) d = mpz_get_si (dim->value.integer); - if (d < 1 || d > as->rank - || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper)) + 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, upper, as, ref); + return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true); } } @@ -3109,9 +3597,14 @@ gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_expr * +gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + return simplify_cobound (array, dim, kind, 0); +} + +gfc_expr * gfc_simplify_leadz (gfc_expr *e) { - gfc_expr *result; unsigned long lz, bs; int i; @@ -3127,11 +3620,7 @@ gfc_simplify_leadz (gfc_expr *e) 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; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); } @@ -3146,33 +3635,20 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind) 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); - if (gfc_range_check (result) == ARITH_OK) - return result; - else - { - gfc_free_expr (result); - return NULL; - } + 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); - if (gfc_range_check (result) == ARITH_OK) - return result; - else - { - gfc_free_expr (result); - return NULL; - } + 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; } @@ -3180,7 +3656,7 @@ 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) @@ -3189,23 +3665,19 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) if (e->expr_type != EXPR_CONSTANT) 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; @@ -3213,8 +3685,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"); @@ -3227,7 +3698,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); } @@ -3237,8 +3709,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); } @@ -3248,7 +3720,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); } @@ -3258,7 +3731,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); } @@ -3270,8 +3744,7 @@ gfc_simplify_log (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) { @@ -3298,26 +3771,7 @@ gfc_simplify_log (gfc_expr *x) } gfc_set_model_kind (x->ts.kind); -#ifdef HAVE_mpc mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); -#else - { - mpfr_t xr, xi; - mpfr_init (xr); - mpfr_init (xi); - - 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); - } -#endif break; default: @@ -3343,8 +3797,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"); @@ -3354,7 +3807,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); @@ -3364,11 +3816,7 @@ 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); - - result->value.logical = e->value.logical; - - return result; + return gfc_get_logical_expr (kind, &e->where, e->value.logical); } @@ -3376,17 +3824,17 @@ gfc_expr* gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) { gfc_expr *result; - gfc_constructor *ma_ctor, *mb_ctor; - int row, result_rows, col, result_columns, stride_a, stride_b; + 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_start_constructor (matrix_a->ts.type, - matrix_a->ts.kind, - &matrix_a->where); + 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) { @@ -3425,25 +3873,22 @@ gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) else gcc_unreachable(); - ma_ctor = matrix_a->value.constructor; - mb_ctor = matrix_b->value.constructor; - + offset_a = offset_b = 0; for (col = 0; col < result_columns; ++col) { - ma_ctor = matrix_a->value.constructor; + offset_a = 0; for (row = 0; row < result_rows; ++row) { - gfc_expr *e; - e = compute_dot_product (ma_ctor, stride_a, - mb_ctor, 1); + 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); - gfc_append_constructor (result, e); + offset_a += 1; + } - ADVANCE (ma_ctor, 1); - } - - ADVANCE (mb_ctor, stride_b); + offset_b += stride_b; } return result; @@ -3451,6 +3896,73 @@ gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) gfc_expr * +gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg) +{ + gfc_expr *result; + int kind, arg, k; + const char *s; + + if (i->expr_type != EXPR_CONSTANT) + return NULL; + + kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + k = gfc_validate_kind (BT_INTEGER, kind, false); + + s = gfc_extract_int (i, &arg); + gcc_assert (!s); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); + + /* MASKR(n) = 2^n - 1 */ + mpz_set_ui (result->value.integer, 1); + mpz_mul_2exp (result->value.integer, result->value.integer, arg); + mpz_sub_ui (result->value.integer, result->value.integer, 1); + + convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) +{ + gfc_expr *result; + int kind, arg, k; + const char *s; + mpz_t z; + + if (i->expr_type != EXPR_CONSTANT) + return NULL; + + kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + k = gfc_validate_kind (BT_INTEGER, kind, false); + + s = gfc_extract_int (i, &arg); + gcc_assert (!s); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); + + /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */ + mpz_init_set_ui (z, 1); + mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size); + mpz_set_ui (result->value.integer, 1); + mpz_mul_2exp (result->value.integer, result->value.integer, + gfc_integer_kinds[k].bit_size - arg); + mpz_sub (result->value.integer, z, result->value.integer); + mpz_clear (z); + + convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) { if (tsource->expr_type != EXPR_CONSTANT @@ -3462,7 +3974,38 @@ gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) } -/* Selects bewteen current value and extremum for simplify_min_max +gfc_expr * +gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr) +{ + mpz_t arg1, arg2, mask; + gfc_expr *result; + + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT + || mask_expr->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where); + + /* Convert all argument to unsigned. */ + mpz_init_set (arg1, i->value.integer); + mpz_init_set (arg2, j->value.integer); + mpz_init_set (mask, mask_expr->value.integer); + + /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */ + mpz_and (arg1, arg1, mask); + mpz_com (mask, mask); + mpz_and (arg2, arg2, mask); + mpz_ior (result->value.integer, arg1, arg2); + + mpz_clear (arg1); + mpz_clear (arg2); + mpz_clear (mask); + + return result; +} + + +/* Selects between current value and extremum for simplify_min_max and simplify_minval_maxval. */ static void min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) @@ -3499,12 +4042,12 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) LENGTH(arg) - LENGTH(extremum)); STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ LENGTH(extremum) = LENGTH(arg); - gfc_free (tmp); + free (tmp); } if (gfc_compare_string (arg, extremum) * sign > 0) { - gfc_free (STRING(extremum)); + free (STRING(extremum)); STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); memcpy (STRING(extremum), STRING(arg), LENGTH(arg) * sizeof (gfc_char_t)); @@ -3603,26 +4146,25 @@ gfc_simplify_max (gfc_expr *e) static gfc_expr * simplify_minval_maxval (gfc_expr *expr, int sign) { - gfc_constructor *ctr, *extremum; + gfc_constructor *c, *extremum; gfc_intrinsic_sym * specific; extremum = NULL; specific = expr->value.function.isym; - ctr = expr->value.constructor; - - for (; ctr; ctr = ctr->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) { - if (ctr->expr->expr_type != EXPR_CONSTANT) + if (c->expr->expr_type != EXPR_CONSTANT) return NULL; if (extremum == NULL) { - extremum = ctr; + extremum = c; continue; } - min_max_choose (ctr->expr, extremum->expr, sign); + min_max_choose (c->expr, extremum->expr, sign); } if (extremum == NULL) @@ -3646,7 +4188,7 @@ gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) { if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) return NULL; - + return simplify_minval_maxval (array, -1); } @@ -3656,6 +4198,7 @@ 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); } @@ -3663,30 +4206,18 @@ gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) gfc_expr * gfc_simplify_maxexponent (gfc_expr *x) { - gfc_expr *result; - int i; - - i = gfc_validate_kind (BT_REAL, x->ts.kind, false); - - result = gfc_int_expr (gfc_real_kinds[i].max_exponent); - result->where = x->where; - - return result; + 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) { - gfc_expr *result; - int i; - - i = gfc_validate_kind (BT_REAL, x->ts.kind, false); - - result = gfc_int_expr (gfc_real_kinds[i].min_exponent); - result->where = x->where; - - return result; + 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); } @@ -3701,41 +4232,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"); @@ -3753,43 +4284,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"); @@ -3818,13 +4349,6 @@ gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) return NULL; - if (mpfr_sgn (s->value.real) == 0) - { - gfc_error ("Second argument of NEAREST at %L shall not be zero", - &s->where); - return &gfc_bad_expr; - } - result = gfc_copy_expr (x); /* Save current values of emin and emax. */ @@ -3878,12 +4402,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); @@ -3897,11 +4419,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; } @@ -3920,6 +4440,65 @@ gfc_simplify_idnint (gfc_expr *e) } +static gfc_expr * +add_squared (gfc_expr *result, gfc_expr *e) +{ + mpfr_t tmp; + + gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_REAL + && result->expr_type == EXPR_CONSTANT); + + gfc_set_model_kind (result->ts.kind); + mpfr_init (tmp); + mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE); + mpfr_add (result->value.real, result->value.real, tmp, + GFC_RND_MODE); + mpfr_clear (tmp); + + return result; +} + + +static gfc_expr * +do_sqrt (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_REAL + && result->expr_type == EXPR_CONSTANT); + + mpfr_set (result->value.real, e->value.real, GFC_RND_MODE); + mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); + return result; +} + + +gfc_expr * +gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) +{ + gfc_expr *result; + + if (!is_constant_array_expr (e) + || (dim != NULL && !gfc_is_constant_expr (dim))) + return NULL; + + result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); + init_result_expr (result, 0, NULL); + + if (!dim || e->rank == 1) + { + result = simplify_transformation_to_scalar (result, e, NULL, + add_squared); + mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); + } + else + result = simplify_transformation_to_array (result, e, dim, NULL, + add_squared, &do_sqrt); + + return result; +} + + gfc_expr * gfc_simplify_not (gfc_expr *e) { @@ -3928,8 +4507,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"); @@ -3941,15 +4519,36 @@ 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; + } + + if (gfc_option.coarray != GFC_FCOARRAY_SINGLE) + return NULL; + /* FIXME: gfc_current_locus is wrong. */ + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + mpz_set_si (result->value.integer, 1); return result; } @@ -3964,17 +4563,19 @@ 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) - { - result = gfc_constant_result (BT_INTEGER, kind, &x->where); - mpz_ior (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "OR"); - } - else /* BT_LOGICAL */ + + 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_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(); } } @@ -3991,12 +4592,14 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) && !is_constant_array_expr(mask))) return NULL; - result = gfc_start_constructor (array->ts.type, - array->ts.kind, - &array->where); + result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); + if (array->ts.type == BT_DERIVED) + result->ts.u.derived = array->ts.u.derived; - array_ctor = array->value.constructor; - vector_ctor = vector ? vector->value.constructor : NULL; + 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) @@ -4004,145 +4607,183 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) /* Copy all elements of ARRAY to RESULT. */ while (array_ctor) { - gfc_append_constructor (result, - gfc_copy_expr (array_ctor->expr)); + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (array_ctor->expr), + NULL); - ADVANCE (array_ctor, 1); - ADVANCE (vector_ctor, 1); + array_ctor = gfc_constructor_next (array_ctor); + vector_ctor = gfc_constructor_next (vector_ctor); } } else if (mask->expr_type == EXPR_ARRAY) { /* Copy only those elements of ARRAY to RESULT whose MASK equals .TRUE.. */ - mask_ctor = mask->value.constructor; + mask_ctor = gfc_constructor_first (mask->value.constructor); while (mask_ctor) { if (mask_ctor->expr->value.logical) { - gfc_append_constructor (result, - gfc_copy_expr (array_ctor->expr)); - ADVANCE (vector_ctor, 1); + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (array_ctor->expr), + NULL); + vector_ctor = gfc_constructor_next (vector_ctor); } - ADVANCE (array_ctor, 1); - ADVANCE (mask_ctor, 1); + 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_append_constructor (result, - gfc_copy_expr (vector_ctor->expr)); - ADVANCE (vector_ctor, 1); + 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.cl = array->ts.cl; + result->ts.u.cl = array->ts.u.cl; return result; } -gfc_expr * -gfc_simplify_precision (gfc_expr *e) +static gfc_expr * +do_xor (gfc_expr *result, gfc_expr *e) { - gfc_expr *result; - int i; + gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_LOGICAL + && result->expr_type == EXPR_CONSTANT); - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + result->value.logical = result->value.logical != e->value.logical; + return result; +} - result = gfc_int_expr (gfc_real_kinds[i].precision); - result->where = e->where; - return result; + +gfc_expr * +gfc_simplify_parity (gfc_expr *e, gfc_expr *dim) +{ + return simplify_transformation (e, dim, NULL, 0, do_xor); } gfc_expr * -gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +gfc_simplify_popcnt (gfc_expr *e) { - gfc_expr *result; + int res, k; + mpz_t x; - if (!is_constant_array_expr (array) - || !gfc_is_constant_expr (dim)) + if (e->expr_type != EXPR_CONSTANT) return NULL; - if (mask - && !is_constant_array_expr (mask) - && mask->expr_type != EXPR_CONSTANT) + k = gfc_validate_kind (e->ts.type, e->ts.kind, false); + + /* Convert argument to unsigned, then count the '1' bits. */ + mpz_init_set (x, e->value.integer); + convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); + res = mpz_popcount (x); + mpz_clear (x); + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res); +} + + +gfc_expr * +gfc_simplify_poppar (gfc_expr *e) +{ + gfc_expr *popcnt; + const char *s; + int i; + + if (e->expr_type != EXPR_CONSTANT) return NULL; - result = transformational_result (array, dim, array->ts.type, - array->ts.kind, &array->where); - init_result_expr (result, 1, NULL); + popcnt = gfc_simplify_popcnt (e); + gcc_assert (popcnt); - return !dim || array->rank == 1 ? - simplify_transformation_to_scalar (result, array, mask, gfc_multiply) : - simplify_transformation_to_array (result, array, dim, mask, gfc_multiply); + s = gfc_extract_int (popcnt, &i); + gcc_assert (!s); + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2); +} + + +gfc_expr * +gfc_simplify_precision (gfc_expr *e) +{ + int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, + gfc_real_kinds[i].precision); +} + + +gfc_expr * +gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 1, gfc_multiply); } gfc_expr * gfc_simplify_radix (gfc_expr *e) { - 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 gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); +} - return result; + +gfc_expr * +gfc_simplify_rank (gfc_expr *e) +{ + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank); } @@ -4163,39 +4804,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"); } @@ -4209,12 +4823,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); -#ifdef HAVE_mpc + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); -#else - mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE); -#endif return range_check (result, "REALPART"); } @@ -4240,14 +4850,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; } @@ -4275,7 +4885,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 { @@ -4304,8 +4914,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); @@ -4316,19 +4926,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]; @@ -4346,11 +4952,10 @@ 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) @@ -4363,11 +4968,10 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, 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; @@ -4376,7 +4980,6 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS); gcc_assert (shape[rank] >= 0); - gfc_free_expr (e); rank++; } @@ -4395,11 +4998,10 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, for (i = 0; i < rank; i++) { - e = gfc_get_array_element (order_exp, i); + e = gfc_constructor_lookup_expr (order_exp->value.constructor, i); gcc_assert (e); gfc_extract_int (e, &order[i]); - gfc_free_expr (e); gcc_assert (order[i] >= 1 && order[i] <= rank); order[i]--; @@ -4430,6 +5032,15 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, for (i = 0; i < rank; i++) x[i] = 0; + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + if (source->ts.type == BT_DERIVED) + result->ts.u.derived = source->ts.u.derived; + result->rank = rank; + result->shape = gfc_get_shape (rank); + for (i = 0; i < rank; i++) + mpz_init_set_ui (result->shape[i], shape[i]); + while (nsource > 0 || npad > 0) { /* Figure out which element to extract. */ @@ -4448,27 +5059,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 { 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; - } - - 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; @@ -4485,19 +5088,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; + return result; } @@ -4513,8 +5104,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. */ @@ -4545,7 +5135,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) { @@ -4659,8 +5249,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; @@ -4693,7 +5281,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"); } @@ -4702,7 +5291,6 @@ gfc_expr * gfc_simplify_selected_char_kind (gfc_expr *e) { int kind; - gfc_expr *result; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -4715,10 +5303,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); } @@ -4726,7 +5311,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; @@ -4741,18 +5325,16 @@ 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); } gfc_expr * -gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) +gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx) { - int range, precision, i, kind, found_precision, found_range; - gfc_expr *result; + int range, precision, radix, i, kind, found_precision, found_range, + found_radix; + locus *loc = &gfc_current_locus; if (p == NULL) precision = 0; @@ -4761,6 +5343,7 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) if (p->expr_type != EXPR_CONSTANT || gfc_extract_int (p, &precision) != NULL) return NULL; + loc = &p->where; } if (q == NULL) @@ -4770,11 +5353,27 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) if (q->expr_type != EXPR_CONSTANT || gfc_extract_int (q, &range) != NULL) return NULL; + + if (!loc) + loc = &q->where; + } + + if (rdx == NULL) + radix = 0; + else + { + if (rdx->expr_type != EXPR_CONSTANT + || gfc_extract_int (rdx, &radix) != NULL) + return NULL; + + if (!loc) + loc = &rdx->where; } kind = INT_MAX; found_precision = 0; found_range = 0; + found_radix = 0; for (i = 0; gfc_real_kinds[i].kind != 0; i++) { @@ -4784,25 +5383,30 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) if (gfc_real_kinds[i].range >= range) found_range = 1; + if (gfc_real_kinds[i].radix >= radix) + found_radix = 1; + if (gfc_real_kinds[i].precision >= precision - && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind) + && gfc_real_kinds[i].range >= range + && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind) kind = gfc_real_kinds[i].kind; } if (kind == INT_MAX) { - kind = 0; - - if (!found_precision) + if (found_radix && found_range && !found_precision) kind = -1; - if (!found_range) - kind -= 2; + else if (found_radix && found_precision && !found_range) + kind = -2; + else if (found_radix && !found_precision && !found_range) + kind = -3; + else if (found_radix) + kind = -4; + else + kind = -5; } - result = gfc_int_expr (kind); - result->where = (p != NULL) ? p->where : q->where; - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, loc, kind); } @@ -4816,7 +5420,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) { @@ -4853,32 +5457,40 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) gfc_expr * -gfc_simplify_shape (gfc_expr *source) +gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) { mpz_t shape[GFC_MAX_DIMENSIONS]; gfc_expr *result, *e, *f; gfc_array_ref *ar; int n; gfc_try t; + int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); - if (source->rank == 0) - return gfc_start_constructor (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, k, &source->where); - ar = gfc_find_array_ref (source); + if (source->rank == 0) + return result; - t = gfc_array_ref_shape (ar, shape); + if (source->expr_type == EXPR_VARIABLE) + { + ar = gfc_find_array_ref (source); + t = gfc_array_ref_shape (ar, shape); + } + else if (source->shape) + { + t = SUCCESS; + for (n = 0; n < source->rank; n++) + { + mpz_init (shape[n]); + mpz_set (shape[n], source->shape[n]); + } + } + else + t = FAILURE; for (n = 0; n < source->rank; n++) { - e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &source->where); + e = gfc_get_constant_expr (BT_INTEGER, k, &source->where); if (t == SUCCESS) { @@ -4897,12 +5509,10 @@ gfc_simplify_shape (gfc_expr *source) return NULL; } else - { - e = f; - } + e = f; } - gfc_append_constructor (result, e); + gfc_constructor_append_expr (&result->value.constructor, e, NULL); } return result; @@ -4913,13 +5523,64 @@ gfc_expr * gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { mpz_t size; - gfc_expr *result; + gfc_expr *return_value; int d; int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); if (k == -1) return &gfc_bad_expr; + /* For unary operations, the size of the result is given by the size + of the operand. For binary ones, it's the size of the first operand + unless it is scalar, then it is the size of the second. */ + if (array->expr_type == EXPR_OP && !array->value.op.uop) + { + gfc_expr* replacement; + gfc_expr* simplified; + + switch (array->value.op.op) + { + /* Unary operations. */ + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + case INTRINSIC_PARENTHESES: + replacement = array->value.op.op1; + break; + + /* Binary operations. If any one of the operands is scalar, take + the other one's size. If both of them are arrays, it does not + matter -- try to find one with known shape, if possible. */ + default: + if (array->value.op.op1->rank == 0) + replacement = array->value.op.op2; + else if (array->value.op.op2->rank == 0) + replacement = array->value.op.op1; + else + { + simplified = gfc_simplify_size (array->value.op.op1, dim, kind); + if (simplified) + return simplified; + + replacement = array->value.op.op2; + } + break; + } + + /* Try to reduce it directly if possible. */ + simplified = gfc_simplify_size (replacement, dim, kind); + + /* Otherwise, we build a new SIZE call. This is hopefully at least + simpler than the original one. */ + if (!simplified) + simplified = gfc_build_intrinsic_call ("size", array->where, 3, + gfc_copy_expr (replacement), + gfc_copy_expr (dim), + gfc_copy_expr (kind)); + + return simplified; + } + if (dim == NULL) { if (gfc_array_size (array, &size) == FAILURE) @@ -4935,9 +5596,9 @@ 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_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size)); + mpz_clear (size); + return return_value; } @@ -4949,28 +5610,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; @@ -4985,39 +5645,21 @@ gfc_simplify_sin (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_sin (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model (x->value.real); -#ifdef HAVE_mpc - mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); -#else - { - mpfr_t xp, xq; - mpfr_init (xp); - mpfr_init (xq); - - 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); - } -#endif - 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"); @@ -5032,9 +5674,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"); } @@ -5068,7 +5722,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); @@ -5117,7 +5771,14 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp /* Do not allow the array size to exceed the limit for an array constructor. */ - gfc_array_size (source, &size); + if (source->expr_type == EXPR_ARRAY) + { + if (gfc_array_size (source, &size) == FAILURE) + gfc_internal_error ("Failure getting length of a constant array."); + } + else + mpz_init_set_ui (size, 1); + if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor) return NULL; @@ -5125,31 +5786,33 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp { gcc_assert (dim == 0); - result = gfc_start_constructor (source->ts.type, - source->ts.kind, - &source->where); + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + if (source->ts.type == BT_DERIVED) + result->ts.u.derived = source->ts.u.derived; result->rank = 1; result->shape = gfc_get_shape (result->rank); mpz_init_set_si (result->shape[0], ncopies); for (i = 0; i < ncopies; ++i) - gfc_append_constructor (result, gfc_copy_expr (source)); + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (source), NULL); } else if (source->expr_type == EXPR_ARRAY) { - int result_size, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS]; - gfc_constructor *ctor, *source_ctor, *result_ctor; + 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_start_constructor (source->ts.type, - source->ts.kind, - &source->where); + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + if (source->ts.type == BT_DERIVED) + result->ts.u.derived = source->ts.u.derived; result->rank = source->rank + 1; result->shape = gfc_get_shape (result->rank); - result_size = 1; for (i = 0, j = 0; i < result->rank; ++i) { if (i != dim) @@ -5159,26 +5822,18 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp extent[i] = mpz_get_si (result->shape[i]); rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1]; - result_size *= extent[i]; } - for (i = 0; i < result_size; ++i) - gfc_append_constructor (result, NULL); - - source_ctor = source->value.constructor; - result_ctor = result->value.constructor; - while (source_ctor) + offset = 0; + for (source_ctor = gfc_constructor_first (source->value.constructor); + source_ctor; source_ctor = gfc_constructor_next (source_ctor)) { - ctor = result_ctor; - for (i = 0; i < ncopies; ++i) - { - ctor->expr = gfc_copy_expr (source_ctor->expr); - ADVANCE (ctor, rstride[dim]); - } + gfc_constructor_insert_expr (&result->value.constructor, + gfc_copy_expr (source_ctor->expr), + NULL, offset + i * rstride[dim]); - ADVANCE (result_ctor, (dim == 0 ? ncopies : 1)); - ADVANCE (source_ctor, 1); + offset += (dim == 0 ? ncopies : 1); } } else @@ -5188,7 +5843,7 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp return NULL; if (source->ts.type == BT_CHARACTER) - result->ts.cl = source->ts.cl; + result->ts.u.cl = source->ts.u.cl; return result; } @@ -5197,158 +5852,69 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp gfc_expr * gfc_simplify_sqrt (gfc_expr *e) { - gfc_expr *result; + gfc_expr *result = NULL; if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); - switch (e->ts.type) { - 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); - - break; - - case BT_COMPLEX: - gfc_set_model (e->value.real); -#ifdef HAVE_mpc - mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE); -#else - { - /* Formula taken from Numerical Recipes to avoid over- and - underflow. */ - - mpfr_t ac, ad, s, t, w; - 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; - } - - mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE); - mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE); - - 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 - { - 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); - } + 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; - if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0) - { - 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); - } - 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) - { - 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); - } - 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) - { - 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); - } - else - gfc_internal_error ("invalid complex argument of SQRT at %L", - &e->where); + case BT_COMPLEX: + gfc_set_model (e->value.real); - mpfr_clears (s, t, ac, ad, w, NULL); - } -#endif - break; + 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); + default: + gfc_internal_error ("invalid argument of SQRT at %L", &e->where); } return range_check (result, "SQRT"); - -negative_arg: - gfc_free_expr (result); - gfc_error ("Argument of SQRT at %L has a negative value", &e->where); - return &gfc_bad_expr; } 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); + return simplify_transformation (array, dim, mask, 0, gfc_add); } gfc_expr * gfc_simplify_tan (gfc_expr *x) { - int i; gfc_expr *result; if (x->expr_type != EXPR_CONSTANT) return NULL; - i = gfc_validate_kind (BT_REAL, x->ts.kind, false); + 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; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + case BT_COMPLEX: + mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; - mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); + default: + gcc_unreachable (); + } return range_check (result, "TAN"); } @@ -5362,12 +5928,23 @@ gfc_simplify_tanh (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_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; - mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); + default: + gcc_unreachable (); + } return range_check (result, "TANH"); - } @@ -5379,7 +5956,7 @@ gfc_simplify_tiny (gfc_expr *e) i = gfc_validate_kind (BT_REAL, e->ts.kind, false); - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + 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; @@ -5389,7 +5966,6 @@ gfc_simplify_tiny (gfc_expr *e) gfc_expr * gfc_simplify_trailz (gfc_expr *e) { - gfc_expr *result; unsigned long tz, bs; int i; @@ -5400,10 +5976,8 @@ gfc_simplify_trailz (gfc_expr *e) bs = gfc_integer_kinds[i].bit_size; tz = mpz_scan1 (e->value.integer, 0); - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where); - mpz_set_ui (result->value.integer, MIN (tz, bs)); - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, + &e->where, MIN (tz, bs)); } @@ -5414,17 +5988,19 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) 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; + size_t result_length; + if (!gfc_is_constant_expr (source) - || (gfc_init_expr && !gfc_is_constant_expr (mold)) + || (gfc_init_expr_flag && !gfc_is_constant_expr (mold)) || !gfc_is_constant_expr (size)) return NULL; - if (source->expr_type == EXPR_FUNCTION) + if (gfc_calculate_transfer_sizes (source, mold, size, &source_size, + &result_size, &result_length) == FAILURE) return NULL; /* Calculate the size of the source. */ @@ -5432,15 +6008,13 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) && 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_constant_result (mold->ts.type, mold->ts.kind, - &source->where); + result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind, + &source->where); result->ts = mold->ts; mold_element = mold->expr_type == EXPR_ARRAY - ? mold->value.constructor->expr + ? gfc_constructor_first (mold->value.constructor)->expr : mold; /* Set result character length, if needed. Note that this needs to be @@ -5450,44 +6024,16 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) result->value.character.length = mold_element->value.character.length; /* Set the number of elements in the result, and determine its size. */ - result_elt_size = gfc_target_expr_size (mold_element); - if (result_elt_size == 0) - { - gfc_free_expr (result); - return NULL; - } if (mold->expr_type == EXPR_ARRAY || mold->rank || size) { - int result_length; - result->expr_type = EXPR_ARRAY; result->rank = 1; - - if (size) - result_length = (size_t)mpz_get_ui (size->value.integer); - else - { - result_length = source_size / result_elt_size; - if (result_length * result_elt_size < source_size) - result_length += 1; - } - result->shape = gfc_get_shape (1); mpz_init_set_ui (result->shape[0], result_length); - - result_size = result_length * result_elt_size; } else - { - result->rank = 0; - result_size = result_elt_size; - } - - if (gfc_option.warn_surprising && source_size < result_size) - gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: " - "source size %ld < result size %ld", &source->where, - (long) source_size, (long) result_size); + result->rank = 0; /* Allocate the buffer to store the binary version of the source. */ buffer_size = MAX (source_size, result_size); @@ -5498,7 +6044,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) 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); + gfc_target_interpret_expr (buffer, buffer_size, result, false); return result; } @@ -5507,39 +6053,37 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) gfc_expr * gfc_simplify_transpose (gfc_expr *matrix) { - int i, matrix_rows; + int row, matrix_rows, col, matrix_cols; gfc_expr *result; - gfc_constructor *matrix_ctor; if (!is_constant_array_expr (matrix)) return NULL; gcc_assert (matrix->rank == 2); - result = gfc_start_constructor (matrix->ts.type, matrix->ts.kind, &matrix->where); + result = 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.cl = matrix->ts.cl; + result->ts.u.cl = matrix->ts.u.cl; + else if (matrix->ts.type == BT_DERIVED) + result->ts.u.derived = matrix->ts.u.derived; matrix_rows = mpz_get_si (matrix->shape[0]); - matrix_ctor = matrix->value.constructor; - for (i = 0; i < matrix_rows; ++i) - { - gfc_constructor *column_ctor = matrix_ctor; - while (column_ctor) - { - gfc_append_constructor (result, - gfc_copy_expr (column_ctor->expr)); - - ADVANCE (column_ctor, matrix_rows); - } - - ADVANCE (matrix_ctor, 1); - } + 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; } @@ -5555,9 +6099,6 @@ gfc_simplify_trim (gfc_expr *e) return NULL; len = e->value.character.length; - - result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); - for (count = 0, i = 1; i <= len; ++i) { if (e->value.character.string[len - i] == ' ') @@ -5568,24 +6109,158 @@ gfc_simplify_trim (gfc_expr *e) lentrim = len - count; - result->value.character.length = lentrim; - result->value.character.string = gfc_get_wide_string (lentrim + 1); - + 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]; - result->value.character.string[lentrim] = '\0'; /* For debugger */ + return result; +} + + +gfc_expr * +gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) +{ + gfc_expr *result; + gfc_ref *ref; + gfc_array_spec *as; + gfc_constructor *sub_cons; + bool first_image; + int d; + + if (!is_constant_array_expr (sub)) + return NULL; + + /* Follow any component references. */ + as = coarray->symtree->n.sym->as; + for (ref = coarray->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + as = ref->u.ar.as; + + if (as->type == AS_DEFERRED) + return NULL; + + /* "valid sequence of cosubscripts" are required; thus, return 0 unless + the cosubscript addresses the first image. */ + + sub_cons = gfc_constructor_first (sub->value.constructor); + first_image = true; + + for (d = 1; d <= as->corank; d++) + { + gfc_expr *ca_bound; + int cmp; + + gcc_assert (sub_cons != NULL); + + ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, + NULL, true); + if (ca_bound == NULL) + return NULL; + + if (ca_bound == &gfc_bad_expr) + return ca_bound; + + cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer); + + if (cmp == 0) + { + gfc_free_expr (ca_bound); + sub_cons = gfc_constructor_next (sub_cons); + continue; + } + + first_image = false; + + if (cmp > 0) + { + gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " + "SUB has %ld and COARRAY lower bound is %ld)", + &coarray->where, d, + mpz_get_si (sub_cons->expr->value.integer), + mpz_get_si (ca_bound->value.integer)); + gfc_free_expr (ca_bound); + return &gfc_bad_expr; + } + + gfc_free_expr (ca_bound); + + /* Check whether upperbound is valid for the multi-images case. */ + if (d < as->corank) + { + ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as, + NULL, true); + if (ca_bound == &gfc_bad_expr) + return ca_bound; + + if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT + && mpz_cmp (ca_bound->value.integer, + sub_cons->expr->value.integer) < 0) + { + gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " + "SUB has %ld and COARRAY upper bound is %ld)", + &coarray->where, d, + mpz_get_si (sub_cons->expr->value.integer), + mpz_get_si (ca_bound->value.integer)); + gfc_free_expr (ca_bound); + return &gfc_bad_expr; + } + + if (ca_bound) + gfc_free_expr (ca_bound); + } + + sub_cons = gfc_constructor_next (sub_cons); + } + + gcc_assert (sub_cons == NULL); + + if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + if (first_image) + mpz_set_si (result->value.integer, 1); + else + mpz_set_si (result->value.integer, 0); return result; } gfc_expr * +gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) +{ + if (gfc_option.coarray != GFC_FCOARRAY_SINGLE) + return NULL; + + if (coarray == NULL) + { + gfc_expr *result; + /* FIXME: gfc_current_locus is wrong. */ + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + mpz_set_si (result->value.integer, 1); + return result; + } + + /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */ + return simplify_cobound (coarray, dim, NULL, 0); +} + + +gfc_expr * gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { return simplify_bound (array, dim, kind, 1); } +gfc_expr * +gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + return simplify_cobound (array, dim, kind, 1); +} + gfc_expr * gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) @@ -5599,18 +6274,22 @@ gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) && !is_constant_array_expr(field))) return NULL; - result = gfc_start_constructor (vector->ts.type, - vector->ts.kind, - &vector->where); + result = gfc_get_array_expr (vector->ts.type, vector->ts.kind, + &vector->where); + if (vector->ts.type == BT_DERIVED) + result->ts.u.derived = vector->ts.u.derived; result->rank = mask->rank; result->shape = gfc_copy_shape (mask->shape, mask->rank); if (vector->ts.type == BT_CHARACTER) - result->ts.cl = vector->ts.cl; + result->ts.u.cl = vector->ts.u.cl; - vector_ctor = vector->value.constructor; - mask_ctor = mask->value.constructor; - field_ctor = field->expr_type == EXPR_ARRAY ? field->value.constructor : NULL; + 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) { @@ -5618,17 +6297,17 @@ gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { gcc_assert (vector_ctor); e = gfc_copy_expr (vector_ctor->expr); - ADVANCE (vector_ctor, 1); + vector_ctor = gfc_constructor_next (vector_ctor); } else if (field->expr_type == EXPR_ARRAY) e = gfc_copy_expr (field_ctor->expr); else e = gfc_copy_expr (field); - gfc_append_constructor (result, e); + gfc_constructor_append_expr (&result->value.constructor, e, NULL); - ADVANCE (mask_ctor, 1); - ADVANCE (field_ctor, 1); + mask_ctor = gfc_constructor_next (mask_ctor); + field_ctor = gfc_constructor_next (field_ctor); } return result; @@ -5655,7 +6334,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; @@ -5715,20 +6394,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 (); + } } @@ -5743,7 +6424,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) { @@ -5863,45 +6544,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: @@ -5925,7 +6598,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; @@ -5952,45 +6625,63 @@ 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; } else return NULL; } + + +gfc_expr * +gfc_simplify_compiler_options (void) +{ + char *str; + gfc_expr *result; + + str = gfc_get_option_string (); + result = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, str, strlen (str)); + free (str); + return result; +} + + +gfc_expr * +gfc_simplify_compiler_version (void) +{ + char *buffer; + size_t len; + + len = strlen ("GCC version ") + strlen (version_string); + buffer = XALLOCAVEC (char, len + 1); + snprintf (buffer, len + 1, "GCC version %s", version_string); + return gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, buffer, len); +}