X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Fsimplify.c;h=6904960eb941bef3d29ee113177c673acb6051ae;hp=7919dae02c66804a94ddfe04a478c59e800fe54f;hb=1f32dec7e0b0e0e64c2ee8fc8f4c76bb5b3b691c;hpb=bdabe786b8a177f39e64d9f48d50b6576d43e021 diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 7919dae02c6..6904960eb94 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -1,5 +1,5 @@ /* Simplify intrinsic functions at compile-time. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb @@ -70,6 +70,9 @@ gfc_expr gfc_bad_expr; static gfc_expr * range_check (gfc_expr *result, const char *name) { + if (result == NULL) + return &gfc_bad_expr; + switch (gfc_range_check (result)) { case ARITH_OK: @@ -115,14 +118,12 @@ get_kind (bt type, gfc_expr *k, const char *name, int default_kind) { gfc_error ("KIND parameter of %s at %L must be an initialization " "expression", name, &k->where); - return -1; } if (gfc_extract_int (k, &kind) != NULL || gfc_validate_kind (type, kind, true) < 0) { - gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where); return -1; } @@ -131,6 +132,20 @@ 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 @@ -241,40 +256,73 @@ gfc_simplify_abs (gfc_expr *e) return result; } -/* We use the processor's collating sequence, because all - systems that gfortran currently works on are ASCII. */ -gfc_expr * -gfc_simplify_achar (gfc_expr *e) +static gfc_expr * +simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii) { gfc_expr *result; - int c; - const char *ch; + int kind; + bool too_large = false; if (e->expr_type != EXPR_CONSTANT) return NULL; - ch = gfc_extract_int (e, &c); - - if (ch != NULL) - gfc_internal_error ("gfc_simplify_achar: %s", ch); + kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind); + if (kind == -1) + return &gfc_bad_expr; - if (gfc_option.warn_surprising && (c < 0 || c > 127)) - gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]", + if (mpz_cmp_si (e->value.integer, 0) < 0) + { + gfc_error ("Argument of %s function at %L is negative", name, &e->where); + return &gfc_bad_expr; + } - result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind, - &e->where); + if (ascii && gfc_option.warn_surprising + && mpz_cmp_si (e->value.integer, 127) > 0) + gfc_warning ("Argument of %s function at %L outside of range [0,127]", + name, &e->where); + + if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0) + too_large = true; + else if (kind == 4) + { + mpz_t t; + mpz_init_set_ui (t, 2); + mpz_pow_ui (t, t, 32); + mpz_sub_ui (t, t, 1); + if (mpz_cmp (e->value.integer, t) > 0) + too_large = true; + mpz_clear (t); + } - result->value.character.string = gfc_getmem (2); + if (too_large) + { + gfc_error ("Argument of %s function at %L is too large for the " + "collating sequence of kind %d", name, &e->where, kind); + return &gfc_bad_expr; + } + result = gfc_constant_result (BT_CHARACTER, kind, &e->where); + result->value.character.string = gfc_get_wide_string (2); result->value.character.length = 1; - result->value.character.string[0] = c; + result->value.character.string[0] = mpz_get_ui (e->value.integer); result->value.character.string[1] = '\0'; /* For debugger */ return result; } + +/* We use the processor's collating sequence, because all + systems that gfortran currently works on are ASCII. */ + +gfc_expr * +gfc_simplify_achar (gfc_expr *e, gfc_expr *k) +{ + return simplify_achar_char (e, k, "ACHAR", true); +} + + gfc_expr * gfc_simplify_acos (gfc_expr *x) { @@ -325,7 +373,7 @@ gfc_simplify_adjustl (gfc_expr *e) { gfc_expr *result; int count, i, len; - char ch; + gfc_char_t ch; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -335,7 +383,7 @@ gfc_simplify_adjustl (gfc_expr *e) result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); result->value.character.length = len; - result->value.character.string = gfc_getmem (len + 1); + result->value.character.string = gfc_get_wide_string (len + 1); for (count = 0, i = 0; i < len; ++i) { @@ -362,7 +410,7 @@ gfc_simplify_adjustr (gfc_expr *e) { gfc_expr *result; int count, i, len; - char ch; + gfc_char_t ch; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -372,7 +420,7 @@ gfc_simplify_adjustr (gfc_expr *e) result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); result->value.character.length = len; - result->value.character.string = gfc_getmem (len + 1); + result->value.character.string = gfc_get_wide_string (len + 1); for (count = 0, i = len - 1; i >= 0; --i) { @@ -487,14 +535,14 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y) { 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 */ { result = gfc_constant_result (BT_LOGICAL, kind, &x->where); result->value.logical = x->value.logical && y->value.logical; + return result; } - - return range_check (result, "AND"); } @@ -602,16 +650,15 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) 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); - if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0) { gfc_error ("If first argument of ATAN2 %L is zero, then the " "second argument must not be zero", &x->where); - gfc_free_expr (result); return &gfc_bad_expr; } + result = gfc_constant_result (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"); @@ -619,6 +666,102 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) gfc_expr * +gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_J0"); +} + + +gfc_expr * +gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_J1"); +} + + +gfc_expr * +gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED, + gfc_expr *x ATTRIBUTE_UNUSED) +{ + 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_constant_result (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) +{ + gfc_expr *result; + + if (x->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); + + return range_check (result, "BESSEL_Y0"); +} + + +gfc_expr * +gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (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 ATTRIBUTE_UNUSED, + gfc_expr *x ATTRIBUTE_UNUSED) +{ + 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_constant_result (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_bit_size (gfc_expr *e) { gfc_expr *result; @@ -665,7 +808,7 @@ gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) ceil = gfc_copy_expr (e); mpfr_ceil (ceil->value.real, e->value.real); - gfc_mpfr_to_mpz (result->value.integer, ceil->value.real); + gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where); gfc_free_expr (ceil); @@ -676,35 +819,7 @@ gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) gfc_expr * gfc_simplify_char (gfc_expr *e, gfc_expr *k) { - gfc_expr *result; - int c, kind; - const char *ch; - - kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind); - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - ch = gfc_extract_int (e, &c); - - if (ch != NULL) - gfc_internal_error ("gfc_simplify_char: %s", ch); - - if (c < 0 || c > UCHAR_MAX) - gfc_error ("Argument of CHAR function at %L outside of range [0,255]", - &e->where); - - result = gfc_constant_result (BT_CHARACTER, kind, &e->where); - - result->value.character.length = 1; - result->value.character.string = gfc_getmem (2); - - result->value.character.string[0] = c; - result->value.character.string[1] = '\0'; /* For debugger */ - - return result; + return simplify_achar_char (e, k, "CHAR", false); } @@ -722,7 +837,8 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) switch (x->ts.type) { case BT_INTEGER: - mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE); + if (!x->is_boz) + mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE); break; case BT_REAL: @@ -743,7 +859,9 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) switch (y->ts.type) { case BT_INTEGER: - mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE); + if (!y->is_boz) + mpfr_set_z (result->value.complex.i, y->value.integer, + GFC_RND_MODE); break; case BT_REAL: @@ -755,23 +873,67 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) } } + /* Handle BOZ. */ + if (x->is_boz) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.kind = result->ts.kind; + ts.type = BT_REAL; + if (!gfc_convert_boz (x, &ts)) + return &gfc_bad_expr; + mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE); + } + + if (y && y->is_boz) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.kind = result->ts.kind; + ts.type = BT_REAL; + if (!gfc_convert_boz (y, &ts)) + return &gfc_bad_expr; + mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE); + } + 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; - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return NULL; - kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_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); } @@ -781,10 +943,6 @@ gfc_simplify_complex (gfc_expr *x, gfc_expr *y) { int kind; - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return NULL; - if (x->ts.type == BT_INTEGER) { if (y->ts.type == BT_INTEGER) @@ -800,6 +958,10 @@ gfc_simplify_complex (gfc_expr *x, gfc_expr *y) 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); + return simplify_cmplx ("COMPLEX", x, y, kind); } @@ -849,8 +1011,7 @@ gfc_simplify_cos (gfc_expr *x) mpfr_mul (xp, xp, xq, GFC_RND_MODE); mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE ); - mpfr_clear (xp); - mpfr_clear (xq); + mpfr_clears (xp, xq, NULL); break; default: gfc_internal_error ("in gfc_simplify_cos(): Bad type"); @@ -883,7 +1044,7 @@ gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return NULL; + return only_convert_cmplx_boz (x, y, gfc_default_double_kind); return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); } @@ -892,7 +1053,7 @@ gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) gfc_expr * gfc_simplify_dble (gfc_expr *e) { - gfc_expr *result; + gfc_expr *result = NULL; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -900,7 +1061,8 @@ gfc_simplify_dble (gfc_expr *e) switch (e->ts.type) { case BT_INTEGER: - result = gfc_int2real (e, gfc_default_double_kind); + if (!e->is_boz) + result = gfc_int2real (e, gfc_default_double_kind); break; case BT_REAL: @@ -915,6 +1077,20 @@ gfc_simplify_dble (gfc_expr *e) gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where); } + 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; + } + } + return range_check (result, "DBLE"); } @@ -1006,6 +1182,38 @@ gfc_simplify_dprod (gfc_expr *x, gfc_expr *y) gfc_expr * +gfc_simplify_erf (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); + + mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "ERF"); +} + + +gfc_expr * +gfc_simplify_erfc (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "ERFC"); +} + + +gfc_expr * gfc_simplify_epsilon (gfc_expr *e) { gfc_expr *result; @@ -1047,8 +1255,7 @@ gfc_simplify_exp (gfc_expr *x) 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_clear (xp); - mpfr_clear (xq); + mpfr_clears (xp, xq, NULL); break; default: @@ -1093,7 +1300,23 @@ gfc_simplify_float (gfc_expr *a) if (a->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_int2real (a, gfc_default_real_kind); + if (a->is_boz) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + ts.type = BT_REAL; + ts.kind = gfc_default_real_kind; + + 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"); } @@ -1118,7 +1341,7 @@ gfc_simplify_floor (gfc_expr *e, gfc_expr *k) mpfr_init (floor); mpfr_floor (floor, e->value.real); - gfc_mpfr_to_mpz (result->value.integer, floor); + gfc_mpfr_to_mpz (result->value.integer, floor, &e->where); mpfr_clear (floor); @@ -1137,14 +1360,13 @@ gfc_simplify_fraction (gfc_expr *x) result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); - gfc_set_model_kind (x->ts.kind); - if (mpfr_sgn (x->value.real) == 0) { mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); return result; } + gfc_set_model_kind (x->ts.kind); mpfr_init (exp); mpfr_init (absv); mpfr_init (pow2); @@ -1159,15 +1381,29 @@ gfc_simplify_fraction (gfc_expr *x) mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE); - mpfr_clear (exp); - mpfr_clear (absv); - mpfr_clear (pow2); + mpfr_clears (exp, absv, pow2, NULL); return range_check (result, "FRACTION"); } gfc_expr * +gfc_simplify_gamma (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "GAMMA"); +} + + +gfc_expr * gfc_simplify_huge (gfc_expr *e) { gfc_expr *result; @@ -1194,14 +1430,29 @@ gfc_simplify_huge (gfc_expr *e) return result; } + +gfc_expr * +gfc_simplify_hypot (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE); + return range_check (result, "HYPOT"); +} + + /* We use the processor's collating sequence, because all systems that gfortran currently works on are ASCII. */ gfc_expr * -gfc_simplify_iachar (gfc_expr *e) +gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) { gfc_expr *result; - int index; + gfc_char_t index; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -1212,13 +1463,15 @@ gfc_simplify_iachar (gfc_expr *e) return &gfc_bad_expr; } - index = (unsigned char) e->value.character.string[0]; + index = e->value.character.string[0]; if (gfc_option.warn_surprising && index > 127) gfc_warning ("Argument of IACHAR function at %L outside of range 0..127", &e->where); - result = gfc_int_expr (index); + if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL) + return &gfc_bad_expr; + result->where = e->where; return range_check (result, "IACHAR"); @@ -1275,7 +1528,7 @@ gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); - return range_check (result, "IBCLR"); + return result; } @@ -1316,8 +1569,10 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) } result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + convert_mpz_to_unsigned (result->value.integer, + gfc_integer_kinds[k].bit_size); - bits = gfc_getmem (bitsize * sizeof (int)); + bits = XCNEWVEC (int, bitsize); for (i = 0; i < bitsize; i++) bits[i] = 0; @@ -1337,7 +1592,10 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) gfc_free (bits); - return range_check (result, "IBITS"); + convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); + + return result; } @@ -1375,15 +1633,15 @@ gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); - return range_check (result, "IBSET"); + return result; } gfc_expr * -gfc_simplify_ichar (gfc_expr *e) +gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) { gfc_expr *result; - int index; + gfc_char_t index; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -1394,12 +1652,11 @@ gfc_simplify_ichar (gfc_expr *e) return &gfc_bad_expr; } - index = (unsigned char) e->value.character.string[0]; + index = e->value.character.string[0]; - if (index < 0 || index > UCHAR_MAX) - gfc_internal_error("Argument of ICHAR at %L out of range", &e->where); + if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL) + return &gfc_bad_expr; - result = gfc_int_expr (index); result->where = e->where; return range_check (result, "ICHAR"); } @@ -1422,13 +1679,14 @@ gfc_simplify_ieor (gfc_expr *x, gfc_expr *y) gfc_expr * -gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b) +gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) { gfc_expr *result; int back, len, lensub; int i, j, k, count, index = 0, start; - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT + || ( b != NULL && b->expr_type != EXPR_CONSTANT)) return NULL; if (b != NULL && b->value.logical != 0) @@ -1436,8 +1694,11 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b) else back = 0; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &x->where); + k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_constant_result (BT_INTEGER, k, &x->where); len = x->value.character.length; lensub = y->value.character.length; @@ -1565,7 +1826,7 @@ done: gfc_expr * gfc_simplify_int (gfc_expr *e, gfc_expr *k) { - gfc_expr *rpart, *rtrunc, *result; + gfc_expr *result = NULL; int kind; kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); @@ -1575,33 +1836,22 @@ gfc_simplify_int (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, kind, &e->where); - switch (e->ts.type) { case BT_INTEGER: - mpz_set (result->value.integer, e->value.integer); + result = gfc_int2int (e, kind); break; case BT_REAL: - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real); - gfc_free_expr (rtrunc); + result = gfc_real2int (e, kind); break; case BT_COMPLEX: - rpart = gfc_complex2real (e, kind); - rtrunc = gfc_copy_expr (rpart); - mpfr_trunc (rtrunc->value.real, rpart->value.real); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real); - gfc_free_expr (rpart); - gfc_free_expr (rtrunc); + result = gfc_complex2int (e, kind); break; default: gfc_error ("Argument of INT at %L is not a valid type", &e->where); - gfc_free_expr (result); return &gfc_bad_expr; } @@ -1610,40 +1860,29 @@ gfc_simplify_int (gfc_expr *e, gfc_expr *k) static gfc_expr * -gfc_simplify_intconv (gfc_expr *e, int kind, const char *name) +simplify_intconv (gfc_expr *e, int kind, const char *name) { - gfc_expr *rpart, *rtrunc, *result; + gfc_expr *result = NULL; if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, kind, &e->where); - switch (e->ts.type) { case BT_INTEGER: - mpz_set (result->value.integer, e->value.integer); + result = gfc_int2int (e, kind); break; case BT_REAL: - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real); - gfc_free_expr (rtrunc); + result = gfc_real2int (e, kind); break; case BT_COMPLEX: - rpart = gfc_complex2real (e, kind); - rtrunc = gfc_copy_expr (rpart); - mpfr_trunc (rtrunc->value.real, rpart->value.real); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real); - gfc_free_expr (rpart); - gfc_free_expr (rtrunc); + result = gfc_complex2int (e, kind); break; default: gfc_error ("Argument of %s at %L is not a valid type", name, &e->where); - gfc_free_expr (result); return &gfc_bad_expr; } @@ -1654,21 +1893,21 @@ gfc_simplify_intconv (gfc_expr *e, int kind, const char *name) gfc_expr * gfc_simplify_int2 (gfc_expr *e) { - return gfc_simplify_intconv (e, 2, "INT2"); + return simplify_intconv (e, 2, "INT2"); } gfc_expr * gfc_simplify_int8 (gfc_expr *e) { - return gfc_simplify_intconv (e, 8, "INT8"); + return simplify_intconv (e, 8, "INT8"); } gfc_expr * gfc_simplify_long (gfc_expr *e) { - return gfc_simplify_intconv (e, 4, "LONG"); + return simplify_intconv (e, 4, "LONG"); } @@ -1686,7 +1925,7 @@ gfc_simplify_ifix (gfc_expr *e) rtrunc = gfc_copy_expr (e); mpfr_trunc (rtrunc->value.real, e->value.real); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real); + gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); gfc_free_expr (rtrunc); return range_check (result, "IFIX"); @@ -1707,7 +1946,7 @@ gfc_simplify_idint (gfc_expr *e) rtrunc = gfc_copy_expr (e); mpfr_trunc (rtrunc->value.real, e->value.real); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real); + gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); gfc_free_expr (rtrunc); return range_check (result, "IDINT"); @@ -1768,7 +2007,7 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) return range_check (result, "ISHFT"); } - bits = gfc_getmem (isize * sizeof (int)); + bits = XCNEWVEC (int, isize); for (i = 0; i < isize; i++) bits[i] = mpz_tstbit (e->value.integer, i); @@ -1872,7 +2111,7 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) convert_mpz_to_unsigned (result->value.integer, isize); - bits = gfc_getmem (ssize * sizeof (int)); + bits = XCNEWVEC (int, ssize); for (i = 0; i < ssize; i++) bits[i] = mpz_tstbit (e->value.integer, i); @@ -1938,9 +2177,11 @@ gfc_simplify_kind (gfc_expr *e) static gfc_expr * -simplify_bound_dim (gfc_expr *array, int d, int upper, gfc_array_spec *as) +simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, + gfc_array_spec *as) { gfc_expr *l, *u, *result; + int k; /* The last dimension of an assumed-size array is special. */ if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) @@ -1958,8 +2199,12 @@ simplify_bound_dim (gfc_expr *array, int d, int upper, gfc_array_spec *as) if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &array->where); + k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", + gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_constant_result (BT_INTEGER, k, &array->where); if (mpz_cmp (l->value.integer, u->value.integer) > 0) { @@ -1983,7 +2228,7 @@ simplify_bound_dim (gfc_expr *array, int d, int upper, gfc_array_spec *as) static gfc_expr * -simplify_bound (gfc_expr *array, gfc_expr *dim, int upper) +simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) { gfc_ref *ref; gfc_array_spec *as; @@ -2039,6 +2284,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, int upper) 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) @@ -2051,7 +2297,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, int upper) /* Simplify the bounds for each dimension. */ for (d = 0; d < array->rank; d++) { - bounds[d] = simplify_bound_dim (array, d + 1, upper, as); + bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as); if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) { int j; @@ -2067,7 +2313,14 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, int upper) e->where = array->where; e->expr_type = EXPR_ARRAY; e->ts.type = BT_INTEGER; - e->ts.kind = gfc_default_integer_kind; + k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", + gfc_default_integer_kind); + if (k == -1) + { + gfc_free_expr (e); + return &gfc_bad_expr; + } + e->ts.kind = k; /* The result is a rank 1 array; its size is the rank of the first argument to {L,U}BOUND. */ @@ -2110,27 +2363,54 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, int upper) return &gfc_bad_expr; } - return simplify_bound_dim (array, d, upper, as); + return simplify_bound_dim (array, kind, d, upper, as); } } gfc_expr * -gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim) +gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + return simplify_bound (array, dim, kind, 0); +} + + +gfc_expr * +gfc_simplify_leadz (gfc_expr *e) { - return simplify_bound (array, dim, 0); + gfc_expr *result; + unsigned long lz, bs; + int i; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + bs = gfc_integer_kinds[i].bit_size; + if (mpz_cmp_si (e->value.integer, 0) == 0) + lz = bs; + else + 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; } gfc_expr * -gfc_simplify_len (gfc_expr *e) +gfc_simplify_len (gfc_expr *e, gfc_expr *kind) { gfc_expr *result; + int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; if (e->expr_type == EXPR_CONSTANT) { - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &e->where); + result = gfc_constant_result (BT_INTEGER, k, &e->where); mpz_set_si (result->value.integer, e->value.character.length); return range_check (result, "LEN"); } @@ -2139,8 +2419,7 @@ gfc_simplify_len (gfc_expr *e) && e->ts.cl->length->expr_type == EXPR_CONSTANT && e->ts.cl->length->ts.type == BT_INTEGER) { - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &e->where); + result = gfc_constant_result (BT_INTEGER, k, &e->where); mpz_set (result->value.integer, e->ts.cl->length->value.integer); return range_check (result, "LEN"); } @@ -2150,17 +2429,19 @@ gfc_simplify_len (gfc_expr *e) gfc_expr * -gfc_simplify_len_trim (gfc_expr *e) +gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) { gfc_expr *result; int count, len, lentrim, i; + int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &e->where); - + result = gfc_constant_result (BT_INTEGER, k, &e->where); len = e->value.character.length; for (count = 0, i = 1; i <= len; i++) @@ -2175,6 +2456,22 @@ gfc_simplify_len_trim (gfc_expr *e) return range_check (result, "LEN_TRIM"); } +gfc_expr * +gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED) +{ + gfc_expr *result; + int sg; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE); + + return range_check (result, "LGAMMA"); +} + gfc_expr * gfc_simplify_lge (gfc_expr *a, gfc_expr *b) @@ -2228,7 +2525,6 @@ gfc_simplify_log (gfc_expr *x) result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - gfc_set_model_kind (x->ts.kind); switch (x->ts.type) { @@ -2254,6 +2550,7 @@ gfc_simplify_log (gfc_expr *x) return &gfc_bad_expr; } + gfc_set_model_kind (x->ts.kind); mpfr_init (xr); mpfr_init (xi); @@ -2266,8 +2563,7 @@ gfc_simplify_log (gfc_expr *x) mpfr_sqrt (xr, xr, GFC_RND_MODE); mpfr_log (result->value.complex.r, xr, GFC_RND_MODE); - mpfr_clear (xr); - mpfr_clear (xi); + mpfr_clears (xr, xi, NULL); break; @@ -2285,9 +2581,7 @@ gfc_simplify_log10 (gfc_expr *x) gfc_expr *result; if (x->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_set_model_kind (x->ts.kind); + return NULL; if (mpfr_sgn (x->value.real) <= 0) { @@ -2325,6 +2619,66 @@ gfc_simplify_logical (gfc_expr *e, gfc_expr *k) } +/* Selects bewteen current value and extremum for simplify_min_max + and simplify_minval_maxval. */ +static void +min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) +{ + switch (arg->ts.type) + { + case BT_INTEGER: + if (mpz_cmp (arg->value.integer, + extremum->value.integer) * sign > 0) + mpz_set (extremum->value.integer, arg->value.integer); + break; + + case BT_REAL: + /* We need to use mpfr_min and mpfr_max to treat NaN properly. */ + if (sign > 0) + mpfr_max (extremum->value.real, extremum->value.real, + arg->value.real, GFC_RND_MODE); + else + mpfr_min (extremum->value.real, extremum->value.real, + arg->value.real, GFC_RND_MODE); + break; + + case BT_CHARACTER: +#define LENGTH(x) ((x)->value.character.length) +#define STRING(x) ((x)->value.character.string) + if (LENGTH(extremum) < LENGTH(arg)) + { + gfc_char_t *tmp = STRING(extremum); + + STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1); + memcpy (STRING(extremum), tmp, + LENGTH(extremum) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', + LENGTH(arg) - LENGTH(extremum)); + STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ + LENGTH(extremum) = LENGTH(arg); + gfc_free (tmp); + } + + if (gfc_compare_string (arg, extremum) * sign > 0) + { + gfc_free (STRING(extremum)); + STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); + memcpy (STRING(extremum), STRING(arg), + LENGTH(arg) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', + LENGTH(extremum) - LENGTH(arg)); + STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ + } +#undef LENGTH +#undef STRING + break; + + default: + gfc_internal_error ("simplify_min_max(): Bad type in arglist"); + } +} + + /* This function is special since MAX() can take any number of arguments. The simplified expression is a rewritten version of the argument list containing at most one constant element. Other @@ -2355,26 +2709,7 @@ simplify_min_max (gfc_expr *expr, int sign) continue; } - switch (arg->expr->ts.type) - { - case BT_INTEGER: - if (mpz_cmp (arg->expr->value.integer, - extremum->expr->value.integer) * sign > 0) - mpz_set (extremum->expr->value.integer, arg->expr->value.integer); - - break; - - case BT_REAL: - if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real) - * sign > 0) - mpfr_set (extremum->expr->value.real, arg->expr->value.real, - GFC_RND_MODE); - - break; - - default: - gfc_internal_error ("gfc_simplify_max(): Bad type in arglist"); - } + min_max_choose (arg->expr, extremum->expr, sign); /* Delete the extra constant argument. */ if (last == NULL) @@ -2419,6 +2754,69 @@ gfc_simplify_max (gfc_expr *e) } +/* This is a simplified version of simplify_min_max to provide + simplification of minval and maxval for a vector. */ + +static gfc_expr * +simplify_minval_maxval (gfc_expr *expr, int sign) +{ + gfc_constructor *ctr, *extremum; + gfc_intrinsic_sym * specific; + + extremum = NULL; + specific = expr->value.function.isym; + + ctr = expr->value.constructor; + + for (; ctr; ctr = ctr->next) + { + if (ctr->expr->expr_type != EXPR_CONSTANT) + return NULL; + + if (extremum == NULL) + { + extremum = ctr; + continue; + } + + min_max_choose (ctr->expr, extremum->expr, sign); + } + + if (extremum == NULL) + return NULL; + + /* Convert to the correct type and kind. */ + if (expr->ts.type != BT_UNKNOWN) + return gfc_convert_constant (extremum->expr, + expr->ts.type, expr->ts.kind); + + if (specific->ts.type != BT_UNKNOWN) + return gfc_convert_constant (extremum->expr, + specific->ts.type, specific->ts.kind); + + return gfc_copy_expr (extremum->expr); +} + + +gfc_expr * +gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) +{ + if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) + return NULL; + + return simplify_minval_maxval (array, -1); +} + + +gfc_expr * +gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) +{ + if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) + return NULL; + return simplify_minval_maxval (array, 1); +} + + gfc_expr * gfc_simplify_maxexponent (gfc_expr *x) { @@ -2453,7 +2851,7 @@ gfc_expr * gfc_simplify_mod (gfc_expr *a, gfc_expr *p) { gfc_expr *result; - mpfr_t quot, iquot, term; + mpfr_t tmp; int kind; if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) @@ -2485,18 +2883,12 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) } gfc_set_model_kind (kind); - mpfr_init (quot); - mpfr_init (iquot); - mpfr_init (term); - - mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE); - mpfr_trunc (iquot, quot); - mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE); - mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE); - - mpfr_clear (quot); - mpfr_clear (iquot); - mpfr_clear (term); + 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: @@ -2511,7 +2903,7 @@ gfc_expr * gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) { gfc_expr *result; - mpfr_t quot, iquot, term; + mpfr_t tmp; int kind; if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) @@ -2545,18 +2937,12 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) } gfc_set_model_kind (kind); - mpfr_init (quot); - mpfr_init (iquot); - mpfr_init (term); - - mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE); - mpfr_floor (iquot, quot); - mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE); - mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE); - - mpfr_clear (quot); - mpfr_clear (iquot); - mpfr_clear (term); + 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: @@ -2583,8 +2969,8 @@ gfc_expr * gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) { gfc_expr *result; - mpfr_t tmp; - int sgn; + mp_exp_t emin, emax; + int kind; if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) return NULL; @@ -2596,16 +2982,43 @@ gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) return &gfc_bad_expr; } - gfc_set_model_kind (x->ts.kind); result = gfc_copy_expr (x); - sgn = mpfr_sgn (s->value.real); - mpfr_init (tmp); - mpfr_set_inf (tmp, sgn); - mpfr_nexttoward (result->value.real, tmp); - mpfr_clear (tmp); + /* Save current values of emin and emax. */ + emin = mpfr_get_emin (); + emax = mpfr_get_emax (); + + /* Set emin and emax for the current model number. */ + kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0); + mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent - + mpfr_get_prec(result->value.real) + 1); + mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1); + mpfr_check_range (result->value.real, 0, GMP_RNDU); + + if (mpfr_sgn (s->value.real) > 0) + { + mpfr_nextabove (result->value.real); + mpfr_subnormalize (result->value.real, 0, GMP_RNDU); + } + else + { + mpfr_nextbelow (result->value.real); + mpfr_subnormalize (result->value.real, 0, GMP_RNDD); + } + + mpfr_set_emin (emin); + mpfr_set_emax (emax); + + /* Only NaN can occur. Do not use range check as it gives an + error for denormal numbers. */ + if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check) + { + gfc_error ("Result of NEAREST is NaN at %L", &result->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } - return range_check (result, "NEAREST"); + return result; } @@ -2628,7 +3041,7 @@ simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) mpfr_round (itrunc->value.real, e->value.real); - gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real); + gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where); gfc_free_expr (itrunc); @@ -2642,7 +3055,7 @@ 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_getmem (2); + result->value.character.string = gfc_get_wide_string (2); result->value.character.length = 1; result->value.character.string[0] = '\n'; result->value.character.string[1] = '\0'; /* For debugger */ @@ -2712,14 +3125,14 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *y) { 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 */ { result = gfc_constant_result (BT_LOGICAL, kind, &x->where); result->value.logical = x->value.logical || y->value.logical; + return result; } - - return range_check (result, "OR"); } @@ -2800,7 +3213,7 @@ gfc_simplify_range (gfc_expr *e) gfc_expr * gfc_simplify_real (gfc_expr *e, gfc_expr *k) { - gfc_expr *result; + gfc_expr *result = NULL; int kind; if (e->ts.type == BT_COMPLEX) @@ -2817,7 +3230,8 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k) switch (e->ts.type) { case BT_INTEGER: - result = gfc_int2real (e, kind); + if (!e->is_boz) + result = gfc_int2real (e, kind); break; case BT_REAL: @@ -2833,6 +3247,20 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k) /* Not reached */ } + 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; + } + } + return range_check (result, "REAL"); } @@ -2935,7 +3363,9 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) if (e->expr_type != EXPR_CONSTANT) return NULL; - if (len || mpz_sgn (e->ts.cl->length->value.integer) != 0) + if (len || + (e->ts.cl->length && + mpz_sgn (e->ts.cl->length->value.integer)) != 0) { const char *res = gfc_extract_int (n, &ncop); gcc_assert (res == NULL); @@ -2950,25 +3380,45 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) if (ncop == 0) { - result->value.character.string = gfc_getmem (1); + result->value.character.string = gfc_get_wide_string (1); result->value.character.length = 0; result->value.character.string[0] = '\0'; return result; } result->value.character.length = nlen; - result->value.character.string = gfc_getmem (nlen + 1); + result->value.character.string = gfc_get_wide_string (nlen + 1); for (i = 0; i < ncop; i++) for (j = 0; j < len; j++) - result->value.character.string[j + i * len] - = e->value.character.string[j]; + result->value.character.string[j+i*len]= e->value.character.string[j]; result->value.character.string[nlen] = '\0'; /* For debugger */ return result; } +/* Test that the expression is an constant array. */ + +static bool +is_constant_array_expr (gfc_expr *e) +{ + gfc_constructor *c; + + if (e == NULL) + return true; + + if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) + return false; + + for (c = e->value.constructor; c; c = c->next) + if (c->expr->expr_type != EXPR_CONSTANT) + return false; + + return true; +} + + /* This one is a bear, but mainly has to do with shuffling elements. */ gfc_expr * @@ -2983,22 +3433,21 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, size_t nsource; gfc_expr *e; - /* Unpack the shape array. */ - if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source)) + /* Check that argument expression types are OK. */ + if (!is_constant_array_expr (source)) return NULL; - if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp)) + if (!is_constant_array_expr (shape_exp)) return NULL; - if (pad != NULL - && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad))) + if (!is_constant_array_expr (pad)) return NULL; - if (order_exp != NULL - && (order_exp->expr_type != EXPR_ARRAY - || !gfc_is_constant_expr (order_exp))) + if (!is_constant_array_expr (order_exp)) return NULL; + /* Proceed with simplification, unpacking the array. */ + mpz_init (index); rank = 0; head = tail = NULL; @@ -3017,13 +3466,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, goto bad_reshape; } - gfc_free_expr (e); - if (rank >= GFC_MAX_DIMENSIONS) { gfc_error ("Too many dimensions in shape specification for RESHAPE " "at %L", &e->where); - + gfc_free_expr (e); goto bad_reshape; } @@ -3031,9 +3478,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, { gfc_error ("Shape specification at %L cannot be negative", &e->where); + gfc_free_expr (e); goto bad_reshape; } + gfc_free_expr (e); rank++; } @@ -3073,12 +3522,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, goto bad_reshape; } - gfc_free_expr (e); - if (order[i] < 1 || order[i] > rank) { gfc_error ("ORDER parameter of RESHAPE at %L is out of range", &e->where); + gfc_free_expr (e); goto bad_reshape; } @@ -3088,9 +3536,12 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, { gfc_error ("Invalid permutation in ORDER parameter at %L", &e->where); + gfc_free_expr (e); goto bad_reshape; } + gfc_free_expr (e); + x[order[i]] = 1; } } @@ -3130,7 +3581,7 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, } if (mpz_cmp_ui (index, INT_MAX) > 0) - gfc_internal_error ("Reshaped array too large at %L", &e->where); + gfc_internal_error ("Reshaped array too large at %C"); j = mpz_get_ui (index); @@ -3262,6 +3713,7 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i) || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0) { gfc_error ("Result of SCALE overflows its kind at %L", &result->where); + gfc_free_expr (result); return &gfc_bad_expr; } @@ -3287,20 +3739,68 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i) else mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE); - mpfr_clear (scale); - mpfr_clear (radix); + mpfr_clears (scale, radix, NULL); return range_check (result, "SCALE"); } +/* Variants of strspn and strcspn that operate on wide characters. */ + +static size_t +wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2) +{ + size_t i = 0; + const gfc_char_t *c; + + while (s1[i]) + { + for (c = s2; *c; c++) + { + if (s1[i] == *c) + break; + } + if (*c == '\0') + break; + i++; + } + + return i; +} + +static size_t +wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2) +{ + size_t i = 0; + const gfc_char_t *c; + + while (s1[i]) + { + for (c = s2; *c; c++) + { + if (s1[i] == *c) + break; + } + if (*c) + break; + i++; + } + + return i; +} + + gfc_expr * -gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b) +gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) { gfc_expr *result; int back; size_t i; size_t indx, len, lenc; + int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT) return NULL; @@ -3310,8 +3810,7 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b) else back = 0; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &e->where); + result = gfc_constant_result (BT_INTEGER, k, &e->where); len = e->value.character.length; lenc = c->value.character.length; @@ -3324,8 +3823,8 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b) { if (back == 0) { - indx = strcspn (e->value.character.string, c->value.character.string) - + 1; + indx = wide_strcspn (e->value.character.string, + c->value.character.string) + 1; if (indx > len) indx = 0; } @@ -3351,6 +3850,30 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b) gfc_expr * +gfc_simplify_selected_char_kind (gfc_expr *e) +{ + int kind; + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_compare_with_Cstring (e, "ascii", false) == 0 + || gfc_compare_with_Cstring (e, "default", false) == 0) + kind = 1; + else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0) + kind = 4; + else + kind = -1; + + result = gfc_int_expr (kind); + result->where = e->where; + + return result; +} + + +gfc_expr * gfc_simplify_selected_int_kind (gfc_expr *e) { int i, kind, range; @@ -3446,14 +3969,13 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); - gfc_set_model_kind (x->ts.kind); - if (mpfr_sgn (x->value.real) == 0) { mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); return result; } + gfc_set_model_kind (x->ts.kind); mpfr_init (absv); mpfr_init (log2); mpfr_init (exp); @@ -3475,10 +3997,7 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) exp2 = (unsigned long) mpz_get_d (i->value.integer); mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE); - mpfr_clear (absv); - mpfr_clear (log2); - mpfr_clear (pow2); - mpfr_clear (frac); + mpfr_clears (absv, log2, pow2, frac, NULL); return range_check (result, "SET_EXPONENT"); } @@ -3491,9 +4010,13 @@ gfc_simplify_shape (gfc_expr *source) gfc_expr *result, *e, *f; gfc_array_ref *ar; int n; - try t; + gfc_try t; + + if (source->rank == 0) + return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind, + &source->where); - if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) + if (source->expr_type != EXPR_VARIABLE) return NULL; result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind, @@ -3517,7 +4040,7 @@ gfc_simplify_shape (gfc_expr *source) { mpz_set_ui (e->value.integer, n + 1); - f = gfc_simplify_size (source, e); + f = gfc_simplify_size (source, e, NULL); gfc_free_expr (e); if (f == NULL) { @@ -3538,11 +4061,15 @@ gfc_simplify_shape (gfc_expr *source) gfc_expr * -gfc_simplify_size (gfc_expr *array, gfc_expr *dim) +gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { mpz_t size; gfc_expr *result; int d; + int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; if (dim == NULL) { @@ -3559,11 +4086,8 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim) return NULL; } - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &array->where); - + result = gfc_constant_result (BT_INTEGER, k, &array->where); mpz_set (result->value.integer, size); - return result; } @@ -3634,8 +4158,7 @@ gfc_simplify_sin (gfc_expr *x) mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE); mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE); - mpfr_clear (xp); - mpfr_clear (xq); + mpfr_clears (xp, xq, NULL); break; default: @@ -3811,11 +4334,7 @@ gfc_simplify_sqrt (gfc_expr *e) gfc_internal_error ("invalid complex argument of SQRT at %L", &e->where); - mpfr_clear (s); - mpfr_clear (t); - mpfr_clear (ac); - mpfr_clear (ad); - mpfr_clear (w); + mpfr_clears (s, t, ac, ad, w, NULL); break; @@ -3884,6 +4403,27 @@ gfc_simplify_tiny (gfc_expr *e) gfc_expr * +gfc_simplify_trailz (gfc_expr *e) +{ + gfc_expr *result; + unsigned long tz, bs; + int i; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + bs = gfc_integer_kinds[i].bit_size; + tz = mpz_scan1 (e->value.integer, 0); + + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where); + mpz_set_ui (result->value.integer, MIN (tz, bs)); + + return result; +} + + +gfc_expr * gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) { gfc_expr *result; @@ -3896,9 +4436,13 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) unsigned char *buffer; if (!gfc_is_constant_expr (source) + || (gfc_init_expr && !gfc_is_constant_expr (mold)) || !gfc_is_constant_expr (size)) return NULL; + if (source->expr_type == EXPR_FUNCTION) + return NULL; + /* Calculate the size of the source. */ if (source->expr_type == EXPR_ARRAY && gfc_array_size (source, &tmp) == FAILURE) @@ -3918,11 +4462,17 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) /* Set result character length, if needed. Note that this needs to be set even for array expressions, in order to pass this information into gfc_target_interpret_expr. */ - if (result->ts.type == BT_CHARACTER) + if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element)) result->value.character.length = mold_element->value.character.length; /* Set the number of elements in the result, and determine its size. */ result_elt_size = gfc_target_expr_size (mold_element); + if (result_elt_size == 0) + { + gfc_free_expr (result); + return NULL; + } + if (mold->expr_type == EXPR_ARRAY || mold->rank || size) { int result_length; @@ -3950,6 +4500,11 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) result_size = result_elt_size; } + if (gfc_option.warn_surprising && source_size < result_size) + gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: " + "source size %ld < result size %ld", &source->where, + (long) source_size, (long) result_size); + /* Allocate the buffer to store the binary version of the source. */ buffer_size = MAX (source_size, result_size); buffer = (unsigned char*)alloca (buffer_size); @@ -3988,7 +4543,7 @@ gfc_simplify_trim (gfc_expr *e) lentrim = len - count; result->value.character.length = lentrim; - result->value.character.string = gfc_getmem (lentrim + 1); + result->value.character.string = gfc_get_wide_string (lentrim + 1); for (i = 0; i < lentrim; i++) result->value.character.string[i] = e->value.character.string[i]; @@ -4000,19 +4555,23 @@ gfc_simplify_trim (gfc_expr *e) gfc_expr * -gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim) +gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - return simplify_bound (array, dim, 1); + return simplify_bound (array, dim, kind, 1); } gfc_expr * -gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b) +gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) { gfc_expr *result; int back; size_t index, len, lenset; size_t i; + int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT) return NULL; @@ -4022,8 +4581,7 @@ gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b) else back = 0; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &s->where); + result = gfc_constant_result (BT_INTEGER, k, &s->where); len = s->value.character.length; lenset = set->value.character.length; @@ -4042,8 +4600,8 @@ gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b) return result; } - index = strspn (s->value.character.string, set->value.character.string) - + 1; + index = wide_strspn (s->value.character.string, + set->value.character.string) + 1; if (index > len) index = 0; @@ -4087,15 +4645,16 @@ gfc_simplify_xor (gfc_expr *x, gfc_expr *y) { 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 */ { 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; } - return range_check (result, "XOR"); } @@ -4277,3 +4836,87 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) return result; } + + +/* Function for converting character constants. */ +gfc_expr * +gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) +{ + gfc_expr *result; + int i; + + if (!gfc_is_constant_expr (e)) + return NULL; + + if (e->expr_type == EXPR_CONSTANT) + { + /* Simple case of a scalar. */ + result = gfc_constant_result (BT_CHARACTER, kind, &e->where); + if (result == NULL) + return &gfc_bad_expr; + + result->value.character.length = e->value.character.length; + result->value.character.string + = gfc_get_wide_string (e->value.character.length + 1); + memcpy (result->value.character.string, e->value.character.string, + (e->value.character.length + 1) * sizeof (gfc_char_t)); + + /* Check we only have values representable in the destination kind. */ + for (i = 0; i < result->value.character.length; i++) + if (!gfc_check_character_range (result->value.character.string[i], + kind)) + { + gfc_error ("Character '%s' in string at %L cannot be converted " + "into character kind %d", + gfc_print_wide_char (result->value.character.string[i]), + &e->where, kind); + return &gfc_bad_expr; + } + + return result; + } + else if (e->expr_type == EXPR_ARRAY) + { + /* For an array constructor, we convert each constructor element. */ + gfc_constructor *head = NULL, *tail = NULL, *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; + } + + tail->where = c->where; + tail->expr = gfc_convert_char_constant (c->expr, type, kind); + if (tail->expr == &gfc_bad_expr) + { + tail->expr = NULL; + return &gfc_bad_expr; + } + + if (tail->expr == NULL) + { + gfc_free_constructor (head); + 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; + + return result; + } + else + return NULL; +}