1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
27 #include "intrinsic.h"
28 #include "target-memory.h"
30 gfc_expr gfc_bad_expr;
33 /* Note that 'simplification' is not just transforming expressions.
34 For functions that are not simplified at compile time, range
35 checking is done if possible.
37 The return convention is that each simplification function returns:
39 A new expression node corresponding to the simplified arguments.
40 The original arguments are destroyed by the caller, and must not
41 be a part of the new expression.
43 NULL pointer indicating that no simplification was possible and
44 the original expression should remain intact. If the
45 simplification function sets the type and/or the function name
46 via the pointer gfc_simple_expression, then this type is
49 An expression pointer to gfc_bad_expr (a static placeholder)
50 indicating that some error has prevented simplification. For
51 example, sqrt(-1.0). The error is generated within the function
52 and should be propagated upwards
54 By the time a simplification function gets control, it has been
55 decided that the function call is really supposed to be the
56 intrinsic. No type checking is strictly necessary, since only
57 valid types will be passed on. On the other hand, a simplification
58 subroutine may have to look at the type of an argument as part of
61 Array arguments are never passed to these subroutines.
63 The functions in this file don't have much comment with them, but
64 everything is reasonably straight-forward. The Standard, chapter 13
65 is the best comment you'll find for this file anyway. */
67 /* Range checks an expression node. If all goes well, returns the
68 node, otherwise returns &gfc_bad_expr and frees the node. */
71 range_check (gfc_expr *result, const char *name)
76 switch (gfc_range_check (result))
82 gfc_error ("Result of %s overflows its kind at %L", name,
87 gfc_error ("Result of %s underflows its kind at %L", name,
92 gfc_error ("Result of %s is NaN at %L", name, &result->where);
96 gfc_error ("Result of %s gives range error for its kind at %L", name,
101 gfc_free_expr (result);
102 return &gfc_bad_expr;
106 /* A helper function that gets an optional and possibly missing
107 kind parameter. Returns the kind, -1 if something went wrong. */
110 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
117 if (k->expr_type != EXPR_CONSTANT)
119 gfc_error ("KIND parameter of %s at %L must be an initialization "
120 "expression", name, &k->where);
124 if (gfc_extract_int (k, &kind) != NULL
125 || gfc_validate_kind (type, kind, true) < 0)
127 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
135 /* Helper function to get an integer constant with a kind number given
136 by an integer constant expression. */
138 int_expr_with_kind (int i, gfc_expr *kind, const char *name)
140 gfc_expr *res = gfc_int_expr (i);
141 res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind);
142 if (res->ts.kind == -1)
149 /* Converts an mpz_t signed variable into an unsigned one, assuming
150 two's complement representations and a binary width of bitsize.
151 The conversion is a no-op unless x is negative; otherwise, it can
152 be accomplished by masking out the high bits. */
155 convert_mpz_to_unsigned (mpz_t x, int bitsize)
161 /* Confirm that no bits above the signed range are unset. */
162 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
164 mpz_init_set_ui (mask, 1);
165 mpz_mul_2exp (mask, mask, bitsize);
166 mpz_sub_ui (mask, mask, 1);
168 mpz_and (x, x, mask);
174 /* Confirm that no bits above the signed range are set. */
175 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
180 /* Converts an mpz_t unsigned variable into a signed one, assuming
181 two's complement representations and a binary width of bitsize.
182 If the bitsize-1 bit is set, this is taken as a sign bit and
183 the number is converted to the corresponding negative number. */
186 convert_mpz_to_signed (mpz_t x, int bitsize)
190 /* Confirm that no bits above the unsigned range are set. */
191 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
193 if (mpz_tstbit (x, bitsize - 1) == 1)
195 mpz_init_set_ui (mask, 1);
196 mpz_mul_2exp (mask, mask, bitsize);
197 mpz_sub_ui (mask, mask, 1);
199 /* We negate the number by hand, zeroing the high bits, that is
200 make it the corresponding positive number, and then have it
201 negated by GMP, giving the correct representation of the
204 mpz_add_ui (x, x, 1);
205 mpz_and (x, x, mask);
213 /* Helper function to convert to/from mpfr_t & mpc_t and call the
214 supplied mpc function on the respective values. */
218 call_mpc_func (mpfr_ptr result_re, mpfr_ptr result_im,
219 mpfr_srcptr input_re, mpfr_srcptr input_im,
220 int (*func)(mpc_ptr, mpc_srcptr, mpc_rnd_t))
223 mpc_init2 (c, mpfr_get_default_prec());
224 mpc_set_fr_fr (c, input_re, input_im, GFC_MPC_RND_MODE);
225 func (c, c, GFC_MPC_RND_MODE);
226 mpfr_set (result_re, MPC_RE (c), GFC_RND_MODE);
227 mpfr_set (result_im, MPC_IM (c), GFC_RND_MODE);
232 /********************** Simplification functions *****************************/
235 gfc_simplify_abs (gfc_expr *e)
239 if (e->expr_type != EXPR_CONSTANT)
245 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
247 mpz_abs (result->value.integer, e->value.integer);
249 result = range_check (result, "IABS");
253 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
255 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
257 result = range_check (result, "ABS");
261 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
263 gfc_set_model_kind (e->ts.kind);
265 mpfr_hypot (result->value.real, e->value.complex.r,
266 e->value.complex.i, GFC_RND_MODE);
267 result = range_check (result, "CABS");
271 gfc_internal_error ("gfc_simplify_abs(): Bad type");
279 simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
283 bool too_large = false;
285 if (e->expr_type != EXPR_CONSTANT)
288 kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
290 return &gfc_bad_expr;
292 if (mpz_cmp_si (e->value.integer, 0) < 0)
294 gfc_error ("Argument of %s function at %L is negative", name,
296 return &gfc_bad_expr;
299 if (ascii && gfc_option.warn_surprising
300 && mpz_cmp_si (e->value.integer, 127) > 0)
301 gfc_warning ("Argument of %s function at %L outside of range [0,127]",
304 if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
309 mpz_init_set_ui (t, 2);
310 mpz_pow_ui (t, t, 32);
311 mpz_sub_ui (t, t, 1);
312 if (mpz_cmp (e->value.integer, t) > 0)
319 gfc_error ("Argument of %s function at %L is too large for the "
320 "collating sequence of kind %d", name, &e->where, kind);
321 return &gfc_bad_expr;
324 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
325 result->value.character.string = gfc_get_wide_string (2);
326 result->value.character.length = 1;
327 result->value.character.string[0] = mpz_get_ui (e->value.integer);
328 result->value.character.string[1] = '\0'; /* For debugger */
334 /* We use the processor's collating sequence, because all
335 systems that gfortran currently works on are ASCII. */
338 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
340 return simplify_achar_char (e, k, "ACHAR", true);
345 gfc_simplify_acos (gfc_expr *x)
349 if (x->expr_type != EXPR_CONSTANT)
352 if (mpfr_cmp_si (x->value.real, 1) > 0
353 || mpfr_cmp_si (x->value.real, -1) < 0)
355 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
357 return &gfc_bad_expr;
360 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
362 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
364 return range_check (result, "ACOS");
368 gfc_simplify_acosh (gfc_expr *x)
372 if (x->expr_type != EXPR_CONSTANT)
375 if (mpfr_cmp_si (x->value.real, 1) < 0)
377 gfc_error ("Argument of ACOSH at %L must not be less than 1",
379 return &gfc_bad_expr;
382 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
384 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
386 return range_check (result, "ACOSH");
390 gfc_simplify_adjustl (gfc_expr *e)
396 if (e->expr_type != EXPR_CONSTANT)
399 len = e->value.character.length;
401 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
403 result->value.character.length = len;
404 result->value.character.string = gfc_get_wide_string (len + 1);
406 for (count = 0, i = 0; i < len; ++i)
408 ch = e->value.character.string[i];
414 for (i = 0; i < len - count; ++i)
415 result->value.character.string[i] = e->value.character.string[count + i];
417 for (i = len - count; i < len; ++i)
418 result->value.character.string[i] = ' ';
420 result->value.character.string[len] = '\0'; /* For debugger */
427 gfc_simplify_adjustr (gfc_expr *e)
433 if (e->expr_type != EXPR_CONSTANT)
436 len = e->value.character.length;
438 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
440 result->value.character.length = len;
441 result->value.character.string = gfc_get_wide_string (len + 1);
443 for (count = 0, i = len - 1; i >= 0; --i)
445 ch = e->value.character.string[i];
451 for (i = 0; i < count; ++i)
452 result->value.character.string[i] = ' ';
454 for (i = count; i < len; ++i)
455 result->value.character.string[i] = e->value.character.string[i - count];
457 result->value.character.string[len] = '\0'; /* For debugger */
464 gfc_simplify_aimag (gfc_expr *e)
468 if (e->expr_type != EXPR_CONSTANT)
471 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
472 mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
474 return range_check (result, "AIMAG");
479 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
481 gfc_expr *rtrunc, *result;
484 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
486 return &gfc_bad_expr;
488 if (e->expr_type != EXPR_CONSTANT)
491 rtrunc = gfc_copy_expr (e);
493 mpfr_trunc (rtrunc->value.real, e->value.real);
495 result = gfc_real2real (rtrunc, kind);
496 gfc_free_expr (rtrunc);
498 return range_check (result, "AINT");
503 gfc_simplify_dint (gfc_expr *e)
505 gfc_expr *rtrunc, *result;
507 if (e->expr_type != EXPR_CONSTANT)
510 rtrunc = gfc_copy_expr (e);
512 mpfr_trunc (rtrunc->value.real, e->value.real);
514 result = gfc_real2real (rtrunc, gfc_default_double_kind);
515 gfc_free_expr (rtrunc);
517 return range_check (result, "DINT");
522 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
527 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
529 return &gfc_bad_expr;
531 if (e->expr_type != EXPR_CONSTANT)
534 result = gfc_constant_result (e->ts.type, kind, &e->where);
536 mpfr_round (result->value.real, e->value.real);
538 return range_check (result, "ANINT");
543 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
548 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
551 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
552 if (x->ts.type == BT_INTEGER)
554 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
555 mpz_and (result->value.integer, x->value.integer, y->value.integer);
556 return range_check (result, "AND");
558 else /* BT_LOGICAL */
560 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
561 result->value.logical = x->value.logical && y->value.logical;
568 gfc_simplify_dnint (gfc_expr *e)
572 if (e->expr_type != EXPR_CONSTANT)
575 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
577 mpfr_round (result->value.real, e->value.real);
579 return range_check (result, "DNINT");
584 gfc_simplify_asin (gfc_expr *x)
588 if (x->expr_type != EXPR_CONSTANT)
591 if (mpfr_cmp_si (x->value.real, 1) > 0
592 || mpfr_cmp_si (x->value.real, -1) < 0)
594 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
596 return &gfc_bad_expr;
599 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
601 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
603 return range_check (result, "ASIN");
608 gfc_simplify_asinh (gfc_expr *x)
612 if (x->expr_type != EXPR_CONSTANT)
615 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
617 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
619 return range_check (result, "ASINH");
624 gfc_simplify_atan (gfc_expr *x)
628 if (x->expr_type != EXPR_CONSTANT)
631 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
633 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
635 return range_check (result, "ATAN");
640 gfc_simplify_atanh (gfc_expr *x)
644 if (x->expr_type != EXPR_CONSTANT)
647 if (mpfr_cmp_si (x->value.real, 1) >= 0
648 || mpfr_cmp_si (x->value.real, -1) <= 0)
650 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
652 return &gfc_bad_expr;
655 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
657 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
659 return range_check (result, "ATANH");
664 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
668 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
671 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
673 gfc_error ("If first argument of ATAN2 %L is zero, then the "
674 "second argument must not be zero", &x->where);
675 return &gfc_bad_expr;
678 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
680 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
682 return range_check (result, "ATAN2");
687 gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
691 if (x->expr_type != EXPR_CONSTANT)
694 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
695 mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
697 return range_check (result, "BESSEL_J0");
702 gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
706 if (x->expr_type != EXPR_CONSTANT)
709 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
710 mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
712 return range_check (result, "BESSEL_J1");
717 gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
718 gfc_expr *x ATTRIBUTE_UNUSED)
723 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
726 n = mpz_get_si (order->value.integer);
727 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
728 mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
730 return range_check (result, "BESSEL_JN");
735 gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
739 if (x->expr_type != EXPR_CONSTANT)
742 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
743 mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
745 return range_check (result, "BESSEL_Y0");
750 gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
754 if (x->expr_type != EXPR_CONSTANT)
757 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
758 mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
760 return range_check (result, "BESSEL_Y1");
765 gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
766 gfc_expr *x ATTRIBUTE_UNUSED)
771 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
774 n = mpz_get_si (order->value.integer);
775 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
776 mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
778 return range_check (result, "BESSEL_YN");
783 gfc_simplify_bit_size (gfc_expr *e)
788 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
789 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
790 mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
797 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
801 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
804 if (gfc_extract_int (bit, &b) != NULL || b < 0)
805 return gfc_logical_expr (0, &e->where);
807 return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
812 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
814 gfc_expr *ceil, *result;
817 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
819 return &gfc_bad_expr;
821 if (e->expr_type != EXPR_CONSTANT)
824 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
826 ceil = gfc_copy_expr (e);
828 mpfr_ceil (ceil->value.real, e->value.real);
829 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
831 gfc_free_expr (ceil);
833 return range_check (result, "CEILING");
838 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
840 return simplify_achar_char (e, k, "CHAR", false);
844 /* Common subroutine for simplifying CMPLX and DCMPLX. */
847 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
851 result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
853 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
859 mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
863 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
867 mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
868 mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
872 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
881 mpfr_set_z (result->value.complex.i, y->value.integer,
886 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
890 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
899 ts.kind = result->ts.kind;
901 if (!gfc_convert_boz (x, &ts))
902 return &gfc_bad_expr;
903 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
910 ts.kind = result->ts.kind;
912 if (!gfc_convert_boz (y, &ts))
913 return &gfc_bad_expr;
914 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
917 return range_check (result, name);
921 /* Function called when we won't simplify an expression like CMPLX (or
922 COMPLEX or DCMPLX) but still want to convert BOZ arguments. */
925 only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
932 if (x->is_boz && !gfc_convert_boz (x, &ts))
933 return &gfc_bad_expr;
935 if (y && y->is_boz && !gfc_convert_boz (y, &ts))
936 return &gfc_bad_expr;
943 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
947 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
949 return &gfc_bad_expr;
951 if (x->expr_type != EXPR_CONSTANT
952 || (y != NULL && y->expr_type != EXPR_CONSTANT))
953 return only_convert_cmplx_boz (x, y, kind);
955 return simplify_cmplx ("CMPLX", x, y, kind);
960 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
964 if (x->ts.type == BT_INTEGER)
966 if (y->ts.type == BT_INTEGER)
967 kind = gfc_default_real_kind;
973 if (y->ts.type == BT_REAL)
974 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
979 if (x->expr_type != EXPR_CONSTANT
980 || (y != NULL && y->expr_type != EXPR_CONSTANT))
981 return only_convert_cmplx_boz (x, y, kind);
983 return simplify_cmplx ("COMPLEX", x, y, kind);
988 gfc_simplify_conjg (gfc_expr *e)
992 if (e->expr_type != EXPR_CONSTANT)
995 result = gfc_copy_expr (e);
996 mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
998 return range_check (result, "CONJG");
1003 gfc_simplify_cos (gfc_expr *x)
1007 if (x->expr_type != EXPR_CONSTANT)
1010 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1015 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1018 gfc_set_model_kind (x->ts.kind);
1020 call_mpc_func (result->value.complex.r, result->value.complex.i,
1021 x->value.complex.r, x->value.complex.i, mpc_cos);
1028 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
1029 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
1030 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
1032 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
1033 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
1034 mpfr_mul (xp, xp, xq, GFC_RND_MODE);
1035 mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
1037 mpfr_clears (xp, xq, NULL);
1042 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1045 return range_check (result, "COS");
1051 gfc_simplify_cosh (gfc_expr *x)
1055 if (x->expr_type != EXPR_CONSTANT)
1058 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1060 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1062 return range_check (result, "COSH");
1067 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
1070 if (x->expr_type != EXPR_CONSTANT
1071 || (y != NULL && y->expr_type != EXPR_CONSTANT))
1072 return only_convert_cmplx_boz (x, y, gfc_default_double_kind);
1074 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
1079 gfc_simplify_dble (gfc_expr *e)
1081 gfc_expr *result = NULL;
1083 if (e->expr_type != EXPR_CONSTANT)
1090 result = gfc_int2real (e, gfc_default_double_kind);
1094 result = gfc_real2real (e, gfc_default_double_kind);
1098 result = gfc_complex2real (e, gfc_default_double_kind);
1102 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
1105 if (e->ts.type == BT_INTEGER && e->is_boz)
1110 ts.kind = gfc_default_double_kind;
1111 result = gfc_copy_expr (e);
1112 if (!gfc_convert_boz (result, &ts))
1114 gfc_free_expr (result);
1115 return &gfc_bad_expr;
1119 return range_check (result, "DBLE");
1124 gfc_simplify_digits (gfc_expr *x)
1128 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1132 digits = gfc_integer_kinds[i].digits;
1137 digits = gfc_real_kinds[i].digits;
1144 return gfc_int_expr (digits);
1149 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1154 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1157 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1158 result = gfc_constant_result (x->ts.type, kind, &x->where);
1163 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1164 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1166 mpz_set_ui (result->value.integer, 0);
1171 if (mpfr_cmp (x->value.real, y->value.real) > 0)
1172 mpfr_sub (result->value.real, x->value.real, y->value.real,
1175 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1180 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1183 return range_check (result, "DIM");
1188 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1190 gfc_expr *a1, *a2, *result;
1192 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1195 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1197 a1 = gfc_real2real (x, gfc_default_double_kind);
1198 a2 = gfc_real2real (y, gfc_default_double_kind);
1200 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1205 return range_check (result, "DPROD");
1210 gfc_simplify_erf (gfc_expr *x)
1214 if (x->expr_type != EXPR_CONSTANT)
1217 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1219 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1221 return range_check (result, "ERF");
1226 gfc_simplify_erfc (gfc_expr *x)
1230 if (x->expr_type != EXPR_CONSTANT)
1233 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1235 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1237 return range_check (result, "ERFC");
1241 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
1243 #define MAX_ITER 200
1244 #define ARG_LIMIT 12
1246 /* Calculate ERFC_SCALED directly by its definition:
1248 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
1250 using a large precision for intermediate results. This is used for all
1251 but large values of the argument. */
1253 fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
1258 prec = mpfr_get_default_prec ();
1259 mpfr_set_default_prec (10 * prec);
1264 mpfr_set (a, arg, GFC_RND_MODE);
1265 mpfr_sqr (b, a, GFC_RND_MODE);
1266 mpfr_exp (b, b, GFC_RND_MODE);
1267 mpfr_erfc (a, a, GFC_RND_MODE);
1268 mpfr_mul (a, a, b, GFC_RND_MODE);
1270 mpfr_set (res, a, GFC_RND_MODE);
1271 mpfr_set_default_prec (prec);
1277 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
1279 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
1280 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
1283 This is used for large values of the argument. Intermediate calculations
1284 are performed with twice the precision. We don't do a fixed number of
1285 iterations of the sum, but stop when it has converged to the required
1288 asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
1290 mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
1295 prec = mpfr_get_default_prec ();
1296 mpfr_set_default_prec (2 * prec);
1306 mpfr_init (sumtrunc);
1307 mpfr_set_prec (oldsum, prec);
1308 mpfr_set_prec (sumtrunc, prec);
1310 mpfr_set (x, arg, GFC_RND_MODE);
1311 mpfr_set_ui (sum, 1, GFC_RND_MODE);
1312 mpz_set_ui (num, 1);
1314 mpfr_set (u, x, GFC_RND_MODE);
1315 mpfr_sqr (u, u, GFC_RND_MODE);
1316 mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
1317 mpfr_pow_si (u, u, -1, GFC_RND_MODE);
1319 for (i = 1; i < MAX_ITER; i++)
1321 mpfr_set (oldsum, sum, GFC_RND_MODE);
1323 mpz_mul_ui (num, num, 2 * i - 1);
1326 mpfr_set (w, u, GFC_RND_MODE);
1327 mpfr_pow_ui (w, w, i, GFC_RND_MODE);
1329 mpfr_set_z (v, num, GFC_RND_MODE);
1330 mpfr_mul (v, v, w, GFC_RND_MODE);
1332 mpfr_add (sum, sum, v, GFC_RND_MODE);
1334 mpfr_set (sumtrunc, sum, GFC_RND_MODE);
1335 if (mpfr_cmp (sumtrunc, oldsum) == 0)
1339 /* We should have converged by now; otherwise, ARG_LIMIT is probably
1341 gcc_assert (i < MAX_ITER);
1343 /* Divide by x * sqrt(Pi). */
1344 mpfr_const_pi (u, GFC_RND_MODE);
1345 mpfr_sqrt (u, u, GFC_RND_MODE);
1346 mpfr_mul (u, u, x, GFC_RND_MODE);
1347 mpfr_div (sum, sum, u, GFC_RND_MODE);
1349 mpfr_set (res, sum, GFC_RND_MODE);
1350 mpfr_set_default_prec (prec);
1352 mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
1358 gfc_simplify_erfc_scaled (gfc_expr *x)
1362 if (x->expr_type != EXPR_CONSTANT)
1365 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1366 if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
1367 asympt_erfc_scaled (result->value.real, x->value.real);
1369 fullprec_erfc_scaled (result->value.real, x->value.real);
1371 return range_check (result, "ERFC_SCALED");
1379 gfc_simplify_epsilon (gfc_expr *e)
1384 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1386 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1388 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1390 return range_check (result, "EPSILON");
1395 gfc_simplify_exp (gfc_expr *x)
1399 if (x->expr_type != EXPR_CONSTANT)
1402 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1407 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1411 gfc_set_model_kind (x->ts.kind);
1413 call_mpc_func (result->value.complex.r, result->value.complex.i,
1414 x->value.complex.r, x->value.complex.i, mpc_exp);
1420 mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1421 mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1422 mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1423 mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1424 mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1425 mpfr_clears (xp, xq, NULL);
1431 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1434 return range_check (result, "EXP");
1438 gfc_simplify_exponent (gfc_expr *x)
1443 if (x->expr_type != EXPR_CONSTANT)
1446 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1449 gfc_set_model (x->value.real);
1451 if (mpfr_sgn (x->value.real) == 0)
1453 mpz_set_ui (result->value.integer, 0);
1457 i = (int) mpfr_get_exp (x->value.real);
1458 mpz_set_si (result->value.integer, i);
1460 return range_check (result, "EXPONENT");
1465 gfc_simplify_float (gfc_expr *a)
1469 if (a->expr_type != EXPR_CONSTANT)
1478 ts.kind = gfc_default_real_kind;
1480 result = gfc_copy_expr (a);
1481 if (!gfc_convert_boz (result, &ts))
1483 gfc_free_expr (result);
1484 return &gfc_bad_expr;
1488 result = gfc_int2real (a, gfc_default_real_kind);
1489 return range_check (result, "FLOAT");
1494 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1500 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1502 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1504 if (e->expr_type != EXPR_CONSTANT)
1507 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1509 gfc_set_model_kind (kind);
1511 mpfr_floor (floor, e->value.real);
1513 gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
1517 return range_check (result, "FLOOR");
1522 gfc_simplify_fraction (gfc_expr *x)
1525 mpfr_t absv, exp, pow2;
1527 if (x->expr_type != EXPR_CONSTANT)
1530 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1532 if (mpfr_sgn (x->value.real) == 0)
1534 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1538 gfc_set_model_kind (x->ts.kind);
1543 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1544 mpfr_log2 (exp, absv, GFC_RND_MODE);
1546 mpfr_trunc (exp, exp);
1547 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1549 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1551 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1553 mpfr_clears (exp, absv, pow2, NULL);
1555 return range_check (result, "FRACTION");
1560 gfc_simplify_gamma (gfc_expr *x)
1564 if (x->expr_type != EXPR_CONSTANT)
1567 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1569 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1571 return range_check (result, "GAMMA");
1576 gfc_simplify_huge (gfc_expr *e)
1581 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1583 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1588 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1592 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1604 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
1608 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1611 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1612 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
1613 return range_check (result, "HYPOT");
1617 /* We use the processor's collating sequence, because all
1618 systems that gfortran currently works on are ASCII. */
1621 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
1626 if (e->expr_type != EXPR_CONSTANT)
1629 if (e->value.character.length != 1)
1631 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1632 return &gfc_bad_expr;
1635 index = e->value.character.string[0];
1637 if (gfc_option.warn_surprising && index > 127)
1638 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1641 if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
1642 return &gfc_bad_expr;
1644 result->where = e->where;
1646 return range_check (result, "IACHAR");
1651 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1655 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1658 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1660 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1662 return range_check (result, "IAND");
1667 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1672 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1675 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1677 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1678 return &gfc_bad_expr;
1681 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1683 if (pos >= gfc_integer_kinds[k].bit_size)
1685 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1687 return &gfc_bad_expr;
1690 result = gfc_copy_expr (x);
1692 convert_mpz_to_unsigned (result->value.integer,
1693 gfc_integer_kinds[k].bit_size);
1695 mpz_clrbit (result->value.integer, pos);
1697 convert_mpz_to_signed (result->value.integer,
1698 gfc_integer_kinds[k].bit_size);
1705 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1712 if (x->expr_type != EXPR_CONSTANT
1713 || y->expr_type != EXPR_CONSTANT
1714 || z->expr_type != EXPR_CONSTANT)
1717 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1719 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1720 return &gfc_bad_expr;
1723 if (gfc_extract_int (z, &len) != NULL || len < 0)
1725 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1726 return &gfc_bad_expr;
1729 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1731 bitsize = gfc_integer_kinds[k].bit_size;
1733 if (pos + len > bitsize)
1735 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1736 "bit size at %L", &y->where);
1737 return &gfc_bad_expr;
1740 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1741 convert_mpz_to_unsigned (result->value.integer,
1742 gfc_integer_kinds[k].bit_size);
1744 bits = XCNEWVEC (int, bitsize);
1746 for (i = 0; i < bitsize; i++)
1749 for (i = 0; i < len; i++)
1750 bits[i] = mpz_tstbit (x->value.integer, i + pos);
1752 for (i = 0; i < bitsize; i++)
1755 mpz_clrbit (result->value.integer, i);
1756 else if (bits[i] == 1)
1757 mpz_setbit (result->value.integer, i);
1759 gfc_internal_error ("IBITS: Bad bit");
1764 convert_mpz_to_signed (result->value.integer,
1765 gfc_integer_kinds[k].bit_size);
1772 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1777 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1780 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1782 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1783 return &gfc_bad_expr;
1786 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1788 if (pos >= gfc_integer_kinds[k].bit_size)
1790 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1792 return &gfc_bad_expr;
1795 result = gfc_copy_expr (x);
1797 convert_mpz_to_unsigned (result->value.integer,
1798 gfc_integer_kinds[k].bit_size);
1800 mpz_setbit (result->value.integer, pos);
1802 convert_mpz_to_signed (result->value.integer,
1803 gfc_integer_kinds[k].bit_size);
1810 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
1815 if (e->expr_type != EXPR_CONSTANT)
1818 if (e->value.character.length != 1)
1820 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1821 return &gfc_bad_expr;
1824 index = e->value.character.string[0];
1826 if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
1827 return &gfc_bad_expr;
1829 result->where = e->where;
1830 return range_check (result, "ICHAR");
1835 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
1839 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1842 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1844 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1846 return range_check (result, "IEOR");
1851 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
1854 int back, len, lensub;
1855 int i, j, k, count, index = 0, start;
1857 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
1858 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
1861 if (b != NULL && b->value.logical != 0)
1866 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
1868 return &gfc_bad_expr;
1870 result = gfc_constant_result (BT_INTEGER, k, &x->where);
1872 len = x->value.character.length;
1873 lensub = y->value.character.length;
1877 mpz_set_si (result->value.integer, 0);
1885 mpz_set_si (result->value.integer, 1);
1888 else if (lensub == 1)
1890 for (i = 0; i < len; i++)
1892 for (j = 0; j < lensub; j++)
1894 if (y->value.character.string[j]
1895 == x->value.character.string[i])
1905 for (i = 0; i < len; i++)
1907 for (j = 0; j < lensub; j++)
1909 if (y->value.character.string[j]
1910 == x->value.character.string[i])
1915 for (k = 0; k < lensub; k++)
1917 if (y->value.character.string[k]
1918 == x->value.character.string[k + start])
1922 if (count == lensub)
1937 mpz_set_si (result->value.integer, len + 1);
1940 else if (lensub == 1)
1942 for (i = 0; i < len; i++)
1944 for (j = 0; j < lensub; j++)
1946 if (y->value.character.string[j]
1947 == x->value.character.string[len - i])
1949 index = len - i + 1;
1957 for (i = 0; i < len; i++)
1959 for (j = 0; j < lensub; j++)
1961 if (y->value.character.string[j]
1962 == x->value.character.string[len - i])
1965 if (start <= len - lensub)
1968 for (k = 0; k < lensub; k++)
1969 if (y->value.character.string[k]
1970 == x->value.character.string[k + start])
1973 if (count == lensub)
1990 mpz_set_si (result->value.integer, index);
1991 return range_check (result, "INDEX");
1996 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
1998 gfc_expr *result = NULL;
2001 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
2003 return &gfc_bad_expr;
2005 if (e->expr_type != EXPR_CONSTANT)
2011 result = gfc_int2int (e, kind);
2015 result = gfc_real2int (e, kind);
2019 result = gfc_complex2int (e, kind);
2023 gfc_error ("Argument of INT at %L is not a valid type", &e->where);
2024 return &gfc_bad_expr;
2027 return range_check (result, "INT");
2032 simplify_intconv (gfc_expr *e, int kind, const char *name)
2034 gfc_expr *result = NULL;
2036 if (e->expr_type != EXPR_CONSTANT)
2042 result = gfc_int2int (e, kind);
2046 result = gfc_real2int (e, kind);
2050 result = gfc_complex2int (e, kind);
2054 gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
2055 return &gfc_bad_expr;
2058 return range_check (result, name);
2063 gfc_simplify_int2 (gfc_expr *e)
2065 return simplify_intconv (e, 2, "INT2");
2070 gfc_simplify_int8 (gfc_expr *e)
2072 return simplify_intconv (e, 8, "INT8");
2077 gfc_simplify_long (gfc_expr *e)
2079 return simplify_intconv (e, 4, "LONG");
2084 gfc_simplify_ifix (gfc_expr *e)
2086 gfc_expr *rtrunc, *result;
2088 if (e->expr_type != EXPR_CONSTANT)
2091 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2094 rtrunc = gfc_copy_expr (e);
2096 mpfr_trunc (rtrunc->value.real, e->value.real);
2097 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2099 gfc_free_expr (rtrunc);
2100 return range_check (result, "IFIX");
2105 gfc_simplify_idint (gfc_expr *e)
2107 gfc_expr *rtrunc, *result;
2109 if (e->expr_type != EXPR_CONSTANT)
2112 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2115 rtrunc = gfc_copy_expr (e);
2117 mpfr_trunc (rtrunc->value.real, e->value.real);
2118 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2120 gfc_free_expr (rtrunc);
2121 return range_check (result, "IDINT");
2126 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
2130 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2133 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
2135 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2136 return range_check (result, "IOR");
2141 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
2144 int shift, ashift, isize, k, *bits, i;
2146 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2149 if (gfc_extract_int (s, &shift) != NULL)
2151 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
2152 return &gfc_bad_expr;
2155 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2157 isize = gfc_integer_kinds[k].bit_size;
2166 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
2167 "at %L", &s->where);
2168 return &gfc_bad_expr;
2171 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2175 mpz_set (result->value.integer, e->value.integer);
2176 return range_check (result, "ISHFT");
2179 bits = XCNEWVEC (int, isize);
2181 for (i = 0; i < isize; i++)
2182 bits[i] = mpz_tstbit (e->value.integer, i);
2186 for (i = 0; i < shift; i++)
2187 mpz_clrbit (result->value.integer, i);
2189 for (i = 0; i < isize - shift; i++)
2192 mpz_clrbit (result->value.integer, i + shift);
2194 mpz_setbit (result->value.integer, i + shift);
2199 for (i = isize - 1; i >= isize - ashift; i--)
2200 mpz_clrbit (result->value.integer, i);
2202 for (i = isize - 1; i >= ashift; i--)
2205 mpz_clrbit (result->value.integer, i - ashift);
2207 mpz_setbit (result->value.integer, i - ashift);
2211 convert_mpz_to_signed (result->value.integer, isize);
2219 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
2222 int shift, ashift, isize, ssize, delta, k;
2225 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2228 if (gfc_extract_int (s, &shift) != NULL)
2230 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
2231 return &gfc_bad_expr;
2234 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2235 isize = gfc_integer_kinds[k].bit_size;
2239 if (sz->expr_type != EXPR_CONSTANT)
2242 if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
2244 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
2245 return &gfc_bad_expr;
2250 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
2251 "BIT_SIZE of first argument at %L", &s->where);
2252 return &gfc_bad_expr;
2266 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2267 "third argument at %L", &s->where);
2269 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2270 "BIT_SIZE of first argument at %L", &s->where);
2271 return &gfc_bad_expr;
2274 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2276 mpz_set (result->value.integer, e->value.integer);
2281 convert_mpz_to_unsigned (result->value.integer, isize);
2283 bits = XCNEWVEC (int, ssize);
2285 for (i = 0; i < ssize; i++)
2286 bits[i] = mpz_tstbit (e->value.integer, i);
2288 delta = ssize - ashift;
2292 for (i = 0; i < delta; i++)
2295 mpz_clrbit (result->value.integer, i + shift);
2297 mpz_setbit (result->value.integer, i + shift);
2300 for (i = delta; i < ssize; i++)
2303 mpz_clrbit (result->value.integer, i - delta);
2305 mpz_setbit (result->value.integer, i - delta);
2310 for (i = 0; i < ashift; i++)
2313 mpz_clrbit (result->value.integer, i + delta);
2315 mpz_setbit (result->value.integer, i + delta);
2318 for (i = ashift; i < ssize; i++)
2321 mpz_clrbit (result->value.integer, i + shift);
2323 mpz_setbit (result->value.integer, i + shift);
2327 convert_mpz_to_signed (result->value.integer, isize);
2335 gfc_simplify_kind (gfc_expr *e)
2338 if (e->ts.type == BT_DERIVED)
2340 gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
2341 return &gfc_bad_expr;
2344 return gfc_int_expr (e->ts.kind);
2349 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2350 gfc_array_spec *as, gfc_ref *ref)
2352 gfc_expr *l, *u, *result;
2355 /* The last dimension of an assumed-size array is special. */
2356 if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2358 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2359 return gfc_copy_expr (as->lower[d-1]);
2364 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2365 gfc_default_integer_kind);
2367 return &gfc_bad_expr;
2369 result = gfc_constant_result (BT_INTEGER, k, &array->where);
2372 /* Then, we need to know the extent of the given dimension. */
2373 if (ref->u.ar.type == AR_FULL)
2378 if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
2381 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2385 mpz_set_si (result->value.integer, 0);
2387 mpz_set_si (result->value.integer, 1);
2391 /* Nonzero extent. */
2393 mpz_set (result->value.integer, u->value.integer);
2395 mpz_set (result->value.integer, l->value.integer);
2402 if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer)
2407 mpz_set_si (result->value.integer, (long int) 1);
2410 return range_check (result, upper ? "UBOUND" : "LBOUND");
2415 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2421 if (array->expr_type != EXPR_VARIABLE)
2424 /* Follow any component references. */
2425 as = array->symtree->n.sym->as;
2426 for (ref = array->ref; ref; ref = ref->next)
2431 switch (ref->u.ar.type)
2438 /* We're done because 'as' has already been set in the
2439 previous iteration. */
2456 as = ref->u.c.component->as;
2468 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2473 /* Multi-dimensional bounds. */
2474 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2476 gfc_constructor *head, *tail;
2479 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2480 if (upper && as->type == AS_ASSUMED_SIZE)
2482 /* An error message will be emitted in
2483 check_assumed_size_reference (resolve.c). */
2484 return &gfc_bad_expr;
2487 /* Simplify the bounds for each dimension. */
2488 for (d = 0; d < array->rank; d++)
2490 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref);
2491 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2495 for (j = 0; j < d; j++)
2496 gfc_free_expr (bounds[j]);
2501 /* Allocate the result expression. */
2502 e = gfc_get_expr ();
2503 e->where = array->where;
2504 e->expr_type = EXPR_ARRAY;
2505 e->ts.type = BT_INTEGER;
2506 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2507 gfc_default_integer_kind);
2511 return &gfc_bad_expr;
2515 /* The result is a rank 1 array; its size is the rank of the first
2516 argument to {L,U}BOUND. */
2518 e->shape = gfc_get_shape (1);
2519 mpz_init_set_ui (e->shape[0], array->rank);
2521 /* Create the constructor for this array. */
2523 for (d = 0; d < array->rank; d++)
2525 /* Get a new constructor element. */
2527 head = tail = gfc_get_constructor ();
2530 tail->next = gfc_get_constructor ();
2534 tail->where = e->where;
2535 tail->expr = bounds[d];
2537 e->value.constructor = head;
2543 /* A DIM argument is specified. */
2544 if (dim->expr_type != EXPR_CONSTANT)
2547 d = mpz_get_si (dim->value.integer);
2549 if (d < 1 || d > as->rank
2550 || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2552 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2553 return &gfc_bad_expr;
2556 return simplify_bound_dim (array, kind, d, upper, as, ref);
2562 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2564 return simplify_bound (array, dim, kind, 0);
2569 gfc_simplify_leadz (gfc_expr *e)
2572 unsigned long lz, bs;
2575 if (e->expr_type != EXPR_CONSTANT)
2578 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2579 bs = gfc_integer_kinds[i].bit_size;
2580 if (mpz_cmp_si (e->value.integer, 0) == 0)
2582 else if (mpz_cmp_si (e->value.integer, 0) < 0)
2585 lz = bs - mpz_sizeinbase (e->value.integer, 2);
2587 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2589 mpz_set_ui (result->value.integer, lz);
2596 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
2599 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
2602 return &gfc_bad_expr;
2604 if (e->expr_type == EXPR_CONSTANT)
2606 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2607 mpz_set_si (result->value.integer, e->value.character.length);
2608 if (gfc_range_check (result) == ARITH_OK)
2612 gfc_free_expr (result);
2617 if (e->ts.cl != NULL && e->ts.cl->length != NULL
2618 && e->ts.cl->length->expr_type == EXPR_CONSTANT
2619 && e->ts.cl->length->ts.type == BT_INTEGER)
2621 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2622 mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2623 if (gfc_range_check (result) == ARITH_OK)
2627 gfc_free_expr (result);
2637 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
2640 int count, len, lentrim, i;
2641 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
2644 return &gfc_bad_expr;
2646 if (e->expr_type != EXPR_CONSTANT)
2649 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2650 len = e->value.character.length;
2652 for (count = 0, i = 1; i <= len; i++)
2653 if (e->value.character.string[len - i] == ' ')
2658 lentrim = len - count;
2660 mpz_set_si (result->value.integer, lentrim);
2661 return range_check (result, "LEN_TRIM");
2665 gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED)
2670 if (x->expr_type != EXPR_CONSTANT)
2673 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2675 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
2677 return range_check (result, "LGAMMA");
2682 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
2684 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2687 return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
2692 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
2694 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2697 return gfc_logical_expr (gfc_compare_string (a, b) > 0,
2703 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
2705 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2708 return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
2713 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
2715 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2718 return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
2723 gfc_simplify_log (gfc_expr *x)
2727 if (x->expr_type != EXPR_CONSTANT)
2730 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2736 if (mpfr_sgn (x->value.real) <= 0)
2738 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2739 "to zero", &x->where);
2740 gfc_free_expr (result);
2741 return &gfc_bad_expr;
2744 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
2748 if ((mpfr_sgn (x->value.complex.r) == 0)
2749 && (mpfr_sgn (x->value.complex.i) == 0))
2751 gfc_error ("Complex argument of LOG at %L cannot be zero",
2753 gfc_free_expr (result);
2754 return &gfc_bad_expr;
2757 gfc_set_model_kind (x->ts.kind);
2759 call_mpc_func (result->value.complex.r, result->value.complex.i,
2760 x->value.complex.r, x->value.complex.i, mpc_log);
2767 mpfr_atan2 (result->value.complex.i, x->value.complex.i,
2768 x->value.complex.r, GFC_RND_MODE);
2770 mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2771 mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2772 mpfr_add (xr, xr, xi, GFC_RND_MODE);
2773 mpfr_sqrt (xr, xr, GFC_RND_MODE);
2774 mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2776 mpfr_clears (xr, xi, NULL);
2782 gfc_internal_error ("gfc_simplify_log: bad type");
2785 return range_check (result, "LOG");
2790 gfc_simplify_log10 (gfc_expr *x)
2794 if (x->expr_type != EXPR_CONSTANT)
2797 if (mpfr_sgn (x->value.real) <= 0)
2799 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2800 "to zero", &x->where);
2801 return &gfc_bad_expr;
2804 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2806 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2808 return range_check (result, "LOG10");
2813 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
2818 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2820 return &gfc_bad_expr;
2822 if (e->expr_type != EXPR_CONSTANT)
2825 result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2827 result->value.logical = e->value.logical;
2834 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2836 if (tsource->expr_type != EXPR_CONSTANT
2837 || fsource->expr_type != EXPR_CONSTANT
2838 || mask->expr_type != EXPR_CONSTANT)
2841 return gfc_copy_expr (mask->value.logical ? tsource : fsource);
2845 /* Selects bewteen current value and extremum for simplify_min_max
2846 and simplify_minval_maxval. */
2848 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
2850 switch (arg->ts.type)
2853 if (mpz_cmp (arg->value.integer,
2854 extremum->value.integer) * sign > 0)
2855 mpz_set (extremum->value.integer, arg->value.integer);
2859 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
2861 mpfr_max (extremum->value.real, extremum->value.real,
2862 arg->value.real, GFC_RND_MODE);
2864 mpfr_min (extremum->value.real, extremum->value.real,
2865 arg->value.real, GFC_RND_MODE);
2869 #define LENGTH(x) ((x)->value.character.length)
2870 #define STRING(x) ((x)->value.character.string)
2871 if (LENGTH(extremum) < LENGTH(arg))
2873 gfc_char_t *tmp = STRING(extremum);
2875 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
2876 memcpy (STRING(extremum), tmp,
2877 LENGTH(extremum) * sizeof (gfc_char_t));
2878 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2879 LENGTH(arg) - LENGTH(extremum));
2880 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
2881 LENGTH(extremum) = LENGTH(arg);
2885 if (gfc_compare_string (arg, extremum) * sign > 0)
2887 gfc_free (STRING(extremum));
2888 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
2889 memcpy (STRING(extremum), STRING(arg),
2890 LENGTH(arg) * sizeof (gfc_char_t));
2891 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
2892 LENGTH(extremum) - LENGTH(arg));
2893 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
2900 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2905 /* This function is special since MAX() can take any number of
2906 arguments. The simplified expression is a rewritten version of the
2907 argument list containing at most one constant element. Other
2908 constant elements are deleted. Because the argument list has
2909 already been checked, this function always succeeds. sign is 1 for
2910 MAX(), -1 for MIN(). */
2913 simplify_min_max (gfc_expr *expr, int sign)
2915 gfc_actual_arglist *arg, *last, *extremum;
2916 gfc_intrinsic_sym * specific;
2920 specific = expr->value.function.isym;
2922 arg = expr->value.function.actual;
2924 for (; arg; last = arg, arg = arg->next)
2926 if (arg->expr->expr_type != EXPR_CONSTANT)
2929 if (extremum == NULL)
2935 min_max_choose (arg->expr, extremum->expr, sign);
2937 /* Delete the extra constant argument. */
2939 expr->value.function.actual = arg->next;
2941 last->next = arg->next;
2944 gfc_free_actual_arglist (arg);
2948 /* If there is one value left, replace the function call with the
2950 if (expr->value.function.actual->next != NULL)
2953 /* Convert to the correct type and kind. */
2954 if (expr->ts.type != BT_UNKNOWN)
2955 return gfc_convert_constant (expr->value.function.actual->expr,
2956 expr->ts.type, expr->ts.kind);
2958 if (specific->ts.type != BT_UNKNOWN)
2959 return gfc_convert_constant (expr->value.function.actual->expr,
2960 specific->ts.type, specific->ts.kind);
2962 return gfc_copy_expr (expr->value.function.actual->expr);
2967 gfc_simplify_min (gfc_expr *e)
2969 return simplify_min_max (e, -1);
2974 gfc_simplify_max (gfc_expr *e)
2976 return simplify_min_max (e, 1);
2980 /* This is a simplified version of simplify_min_max to provide
2981 simplification of minval and maxval for a vector. */
2984 simplify_minval_maxval (gfc_expr *expr, int sign)
2986 gfc_constructor *ctr, *extremum;
2987 gfc_intrinsic_sym * specific;
2990 specific = expr->value.function.isym;
2992 ctr = expr->value.constructor;
2994 for (; ctr; ctr = ctr->next)
2996 if (ctr->expr->expr_type != EXPR_CONSTANT)
2999 if (extremum == NULL)
3005 min_max_choose (ctr->expr, extremum->expr, sign);
3008 if (extremum == NULL)
3011 /* Convert to the correct type and kind. */
3012 if (expr->ts.type != BT_UNKNOWN)
3013 return gfc_convert_constant (extremum->expr,
3014 expr->ts.type, expr->ts.kind);
3016 if (specific->ts.type != BT_UNKNOWN)
3017 return gfc_convert_constant (extremum->expr,
3018 specific->ts.type, specific->ts.kind);
3020 return gfc_copy_expr (extremum->expr);
3025 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3027 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3030 return simplify_minval_maxval (array, -1);
3035 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3037 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3039 return simplify_minval_maxval (array, 1);
3044 gfc_simplify_maxexponent (gfc_expr *x)
3049 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3051 result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
3052 result->where = x->where;
3059 gfc_simplify_minexponent (gfc_expr *x)
3064 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3066 result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
3067 result->where = x->where;
3074 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
3080 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3083 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3084 result = gfc_constant_result (a->ts.type, kind, &a->where);
3089 if (mpz_cmp_ui (p->value.integer, 0) == 0)
3091 /* Result is processor-dependent. */
3092 gfc_error ("Second argument MOD at %L is zero", &a->where);
3093 gfc_free_expr (result);
3094 return &gfc_bad_expr;
3096 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
3100 if (mpfr_cmp_ui (p->value.real, 0) == 0)
3102 /* Result is processor-dependent. */
3103 gfc_error ("Second argument of MOD at %L is zero", &p->where);
3104 gfc_free_expr (result);
3105 return &gfc_bad_expr;
3108 gfc_set_model_kind (kind);
3110 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3111 mpfr_trunc (tmp, tmp);
3112 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3113 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3118 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
3121 return range_check (result, "MOD");
3126 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
3132 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3135 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3136 result = gfc_constant_result (a->ts.type, kind, &a->where);
3141 if (mpz_cmp_ui (p->value.integer, 0) == 0)
3143 /* Result is processor-dependent. This processor just opts
3144 to not handle it at all. */
3145 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
3146 gfc_free_expr (result);
3147 return &gfc_bad_expr;
3149 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
3154 if (mpfr_cmp_ui (p->value.real, 0) == 0)
3156 /* Result is processor-dependent. */
3157 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
3158 gfc_free_expr (result);
3159 return &gfc_bad_expr;
3162 gfc_set_model_kind (kind);
3164 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3165 mpfr_floor (tmp, tmp);
3166 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3167 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3172 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
3175 return range_check (result, "MODULO");
3179 /* Exists for the sole purpose of consistency with other intrinsics. */
3181 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
3182 gfc_expr *fp ATTRIBUTE_UNUSED,
3183 gfc_expr *l ATTRIBUTE_UNUSED,
3184 gfc_expr *to ATTRIBUTE_UNUSED,
3185 gfc_expr *tp ATTRIBUTE_UNUSED)
3192 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
3195 mp_exp_t emin, emax;
3198 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3201 if (mpfr_sgn (s->value.real) == 0)
3203 gfc_error ("Second argument of NEAREST at %L shall not be zero",
3205 return &gfc_bad_expr;
3208 result = gfc_copy_expr (x);
3210 /* Save current values of emin and emax. */
3211 emin = mpfr_get_emin ();
3212 emax = mpfr_get_emax ();
3214 /* Set emin and emax for the current model number. */
3215 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
3216 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
3217 mpfr_get_prec(result->value.real) + 1);
3218 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
3219 mpfr_check_range (result->value.real, 0, GMP_RNDU);
3221 if (mpfr_sgn (s->value.real) > 0)
3223 mpfr_nextabove (result->value.real);
3224 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
3228 mpfr_nextbelow (result->value.real);
3229 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
3232 mpfr_set_emin (emin);
3233 mpfr_set_emax (emax);
3235 /* Only NaN can occur. Do not use range check as it gives an
3236 error for denormal numbers. */
3237 if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
3239 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
3240 gfc_free_expr (result);
3241 return &gfc_bad_expr;
3249 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
3251 gfc_expr *itrunc, *result;
3254 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
3256 return &gfc_bad_expr;
3258 if (e->expr_type != EXPR_CONSTANT)
3261 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
3263 itrunc = gfc_copy_expr (e);
3265 mpfr_round (itrunc->value.real, e->value.real);
3267 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
3269 gfc_free_expr (itrunc);
3271 return range_check (result, name);
3276 gfc_simplify_new_line (gfc_expr *e)
3280 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3281 result->value.character.string = gfc_get_wide_string (2);
3282 result->value.character.length = 1;
3283 result->value.character.string[0] = '\n';
3284 result->value.character.string[1] = '\0'; /* For debugger */
3290 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
3292 return simplify_nint ("NINT", e, k);
3297 gfc_simplify_idnint (gfc_expr *e)
3299 return simplify_nint ("IDNINT", e, NULL);
3304 gfc_simplify_not (gfc_expr *e)
3308 if (e->expr_type != EXPR_CONSTANT)
3311 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3313 mpz_com (result->value.integer, e->value.integer);
3315 return range_check (result, "NOT");
3320 gfc_simplify_null (gfc_expr *mold)
3326 result = gfc_get_expr ();
3327 result->ts.type = BT_UNKNOWN;
3330 result = gfc_copy_expr (mold);
3331 result->expr_type = EXPR_NULL;
3338 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3343 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3346 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3347 if (x->ts.type == BT_INTEGER)
3349 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
3350 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3351 return range_check (result, "OR");
3353 else /* BT_LOGICAL */
3355 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
3356 result->value.logical = x->value.logical || y->value.logical;
3363 gfc_simplify_precision (gfc_expr *e)
3368 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3370 result = gfc_int_expr (gfc_real_kinds[i].precision);
3371 result->where = e->where;
3378 gfc_simplify_radix (gfc_expr *e)
3383 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3387 i = gfc_integer_kinds[i].radix;
3391 i = gfc_real_kinds[i].radix;
3398 result = gfc_int_expr (i);
3399 result->where = e->where;
3406 gfc_simplify_range (gfc_expr *e)
3412 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3417 j = gfc_integer_kinds[i].range;
3422 j = gfc_real_kinds[i].range;
3429 result = gfc_int_expr (j);
3430 result->where = e->where;
3437 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
3439 gfc_expr *result = NULL;
3442 if (e->ts.type == BT_COMPLEX)
3443 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
3445 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
3448 return &gfc_bad_expr;
3450 if (e->expr_type != EXPR_CONSTANT)
3457 result = gfc_int2real (e, kind);
3461 result = gfc_real2real (e, kind);
3465 result = gfc_complex2real (e, kind);
3469 gfc_internal_error ("bad type in REAL");
3473 if (e->ts.type == BT_INTEGER && e->is_boz)
3479 result = gfc_copy_expr (e);
3480 if (!gfc_convert_boz (result, &ts))
3482 gfc_free_expr (result);
3483 return &gfc_bad_expr;
3487 return range_check (result, "REAL");
3492 gfc_simplify_realpart (gfc_expr *e)
3496 if (e->expr_type != EXPR_CONSTANT)
3499 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3500 mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
3502 return range_check (result, "REALPART");
3506 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
3509 int i, j, len, ncop, nlen;
3511 bool have_length = false;
3513 /* If NCOPIES isn't a constant, there's nothing we can do. */
3514 if (n->expr_type != EXPR_CONSTANT)
3517 /* If NCOPIES is negative, it's an error. */
3518 if (mpz_sgn (n->value.integer) < 0)
3520 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3522 return &gfc_bad_expr;
3525 /* If we don't know the character length, we can do no more. */
3526 if (e->ts.cl && e->ts.cl->length
3527 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
3529 len = mpz_get_si (e->ts.cl->length->value.integer);
3532 else if (e->expr_type == EXPR_CONSTANT
3533 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
3535 len = e->value.character.length;
3540 /* If the source length is 0, any value of NCOPIES is valid
3541 and everything behaves as if NCOPIES == 0. */
3544 mpz_set_ui (ncopies, 0);
3546 mpz_set (ncopies, n->value.integer);
3548 /* Check that NCOPIES isn't too large. */
3554 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
3556 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3560 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
3561 e->ts.cl->length->value.integer);
3565 mpz_init_set_si (mlen, len);
3566 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
3570 /* The check itself. */
3571 if (mpz_cmp (ncopies, max) > 0)
3574 mpz_clear (ncopies);
3575 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3577 return &gfc_bad_expr;
3582 mpz_clear (ncopies);
3584 /* For further simplification, we need the character string to be
3586 if (e->expr_type != EXPR_CONSTANT)
3590 (e->ts.cl->length &&
3591 mpz_sgn (e->ts.cl->length->value.integer)) != 0)
3593 const char *res = gfc_extract_int (n, &ncop);
3594 gcc_assert (res == NULL);
3599 len = e->value.character.length;
3602 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3606 result->value.character.string = gfc_get_wide_string (1);
3607 result->value.character.length = 0;
3608 result->value.character.string[0] = '\0';
3612 result->value.character.length = nlen;
3613 result->value.character.string = gfc_get_wide_string (nlen + 1);
3615 for (i = 0; i < ncop; i++)
3616 for (j = 0; j < len; j++)
3617 result->value.character.string[j+i*len]= e->value.character.string[j];
3619 result->value.character.string[nlen] = '\0'; /* For debugger */
3624 /* Test that the expression is an constant array. */
3627 is_constant_array_expr (gfc_expr *e)
3634 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
3637 for (c = e->value.constructor; c; c = c->next)
3638 if (c->expr->expr_type != EXPR_CONSTANT)
3645 /* This one is a bear, but mainly has to do with shuffling elements. */
3648 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3649 gfc_expr *pad, gfc_expr *order_exp)
3651 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3652 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3653 gfc_constructor *head, *tail;
3659 /* Check that argument expression types are OK. */
3660 if (!is_constant_array_expr (source)
3661 || !is_constant_array_expr (shape_exp)
3662 || !is_constant_array_expr (pad)
3663 || !is_constant_array_expr (order_exp))
3666 /* Proceed with simplification, unpacking the array. */
3674 e = gfc_get_array_element (shape_exp, rank);
3678 gfc_extract_int (e, &shape[rank]);
3680 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
3681 gcc_assert (shape[rank] >= 0);
3687 gcc_assert (rank > 0);
3689 /* Now unpack the order array if present. */
3690 if (order_exp == NULL)
3692 for (i = 0; i < rank; i++)
3697 for (i = 0; i < rank; i++)
3700 for (i = 0; i < rank; i++)
3702 e = gfc_get_array_element (order_exp, i);
3705 gfc_extract_int (e, &order[i]);
3708 gcc_assert (order[i] >= 1 && order[i] <= rank);
3710 gcc_assert (x[order[i]] == 0);
3715 /* Count the elements in the source and padding arrays. */
3720 gfc_array_size (pad, &size);
3721 npad = mpz_get_ui (size);
3725 gfc_array_size (source, &size);
3726 nsource = mpz_get_ui (size);
3729 /* If it weren't for that pesky permutation we could just loop
3730 through the source and round out any shortage with pad elements.
3731 But no, someone just had to have the compiler do something the
3732 user should be doing. */
3734 for (i = 0; i < rank; i++)
3739 /* Figure out which element to extract. */
3740 mpz_set_ui (index, 0);
3742 for (i = rank - 1; i >= 0; i--)
3744 mpz_add_ui (index, index, x[order[i]]);
3746 mpz_mul_ui (index, index, shape[order[i - 1]]);
3749 if (mpz_cmp_ui (index, INT_MAX) > 0)
3750 gfc_internal_error ("Reshaped array too large at %C");
3752 j = mpz_get_ui (index);
3755 e = gfc_get_array_element (source, j);
3758 gcc_assert (npad > 0);
3762 e = gfc_get_array_element (pad, j);
3767 head = tail = gfc_get_constructor ();
3770 tail->next = gfc_get_constructor ();
3774 tail->where = e->where;
3777 /* Calculate the next element. */
3781 if (++x[i] < shape[i])
3792 e = gfc_get_expr ();
3793 e->where = source->where;
3794 e->expr_type = EXPR_ARRAY;
3795 e->value.constructor = head;
3796 e->shape = gfc_get_shape (rank);
3798 for (i = 0; i < rank; i++)
3799 mpz_init_set_ui (e->shape[i], shape[i]);
3809 gfc_simplify_rrspacing (gfc_expr *x)
3815 if (x->expr_type != EXPR_CONSTANT)
3818 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3820 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3822 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3824 /* Special case x = -0 and 0. */
3825 if (mpfr_sgn (result->value.real) == 0)
3827 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3831 /* | x * 2**(-e) | * 2**p. */
3832 e = - (long int) mpfr_get_exp (x->value.real);
3833 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3835 p = (long int) gfc_real_kinds[i].digits;
3836 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3838 return range_check (result, "RRSPACING");
3843 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3845 int k, neg_flag, power, exp_range;
3846 mpfr_t scale, radix;
3849 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3852 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3854 if (mpfr_sgn (x->value.real) == 0)
3856 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3860 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3862 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3864 /* This check filters out values of i that would overflow an int. */
3865 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3866 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3868 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3869 gfc_free_expr (result);
3870 return &gfc_bad_expr;
3873 /* Compute scale = radix ** power. */
3874 power = mpz_get_si (i->value.integer);
3884 gfc_set_model_kind (x->ts.kind);
3887 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3888 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3891 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3893 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3895 mpfr_clears (scale, radix, NULL);
3897 return range_check (result, "SCALE");
3901 /* Variants of strspn and strcspn that operate on wide characters. */
3904 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
3907 const gfc_char_t *c;
3911 for (c = s2; *c; c++)
3925 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
3928 const gfc_char_t *c;
3932 for (c = s2; *c; c++)
3947 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
3952 size_t indx, len, lenc;
3953 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3956 return &gfc_bad_expr;
3958 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3961 if (b != NULL && b->value.logical != 0)
3966 result = gfc_constant_result (BT_INTEGER, k, &e->where);
3968 len = e->value.character.length;
3969 lenc = c->value.character.length;
3971 if (len == 0 || lenc == 0)
3979 indx = wide_strcspn (e->value.character.string,
3980 c->value.character.string) + 1;
3987 for (indx = len; indx > 0; indx--)
3989 for (i = 0; i < lenc; i++)
3991 if (c->value.character.string[i]
3992 == e->value.character.string[indx - 1])
4000 mpz_set_ui (result->value.integer, indx);
4001 return range_check (result, "SCAN");
4006 gfc_simplify_selected_char_kind (gfc_expr *e)
4011 if (e->expr_type != EXPR_CONSTANT)
4014 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
4015 || gfc_compare_with_Cstring (e, "default", false) == 0)
4017 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
4022 result = gfc_int_expr (kind);
4023 result->where = e->where;
4030 gfc_simplify_selected_int_kind (gfc_expr *e)
4035 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
4040 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
4041 if (gfc_integer_kinds[i].range >= range
4042 && gfc_integer_kinds[i].kind < kind)
4043 kind = gfc_integer_kinds[i].kind;
4045 if (kind == INT_MAX)
4048 result = gfc_int_expr (kind);
4049 result->where = e->where;
4056 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
4058 int range, precision, i, kind, found_precision, found_range;
4065 if (p->expr_type != EXPR_CONSTANT
4066 || gfc_extract_int (p, &precision) != NULL)
4074 if (q->expr_type != EXPR_CONSTANT
4075 || gfc_extract_int (q, &range) != NULL)
4080 found_precision = 0;
4083 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
4085 if (gfc_real_kinds[i].precision >= precision)
4086 found_precision = 1;
4088 if (gfc_real_kinds[i].range >= range)
4091 if (gfc_real_kinds[i].precision >= precision
4092 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
4093 kind = gfc_real_kinds[i].kind;
4096 if (kind == INT_MAX)
4100 if (!found_precision)
4106 result = gfc_int_expr (kind);
4107 result->where = (p != NULL) ? p->where : q->where;
4114 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
4117 mpfr_t exp, absv, log2, pow2, frac;
4120 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4123 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
4125 if (mpfr_sgn (x->value.real) == 0)
4127 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4131 gfc_set_model_kind (x->ts.kind);
4138 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
4139 mpfr_log2 (log2, absv, GFC_RND_MODE);
4141 mpfr_trunc (log2, log2);
4142 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
4144 /* Old exponent value, and fraction. */
4145 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
4147 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
4150 exp2 = (unsigned long) mpz_get_d (i->value.integer);
4151 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
4153 mpfr_clears (absv, log2, pow2, frac, NULL);
4155 return range_check (result, "SET_EXPONENT");
4160 gfc_simplify_shape (gfc_expr *source)
4162 mpz_t shape[GFC_MAX_DIMENSIONS];
4163 gfc_expr *result, *e, *f;
4168 if (source->rank == 0)
4169 return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
4172 if (source->expr_type != EXPR_VARIABLE)
4175 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
4178 ar = gfc_find_array_ref (source);
4180 t = gfc_array_ref_shape (ar, shape);
4182 for (n = 0; n < source->rank; n++)
4184 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
4189 mpz_set (e->value.integer, shape[n]);
4190 mpz_clear (shape[n]);
4194 mpz_set_ui (e->value.integer, n + 1);
4196 f = gfc_simplify_size (source, e, NULL);
4200 gfc_free_expr (result);
4209 gfc_append_constructor (result, e);
4217 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4222 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4225 return &gfc_bad_expr;
4229 if (gfc_array_size (array, &size) == FAILURE)
4234 if (dim->expr_type != EXPR_CONSTANT)
4237 d = mpz_get_ui (dim->value.integer) - 1;
4238 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4242 result = gfc_constant_result (BT_INTEGER, k, &array->where);
4243 mpz_set (result->value.integer, size);
4249 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4253 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4256 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4261 mpz_abs (result->value.integer, x->value.integer);
4262 if (mpz_sgn (y->value.integer) < 0)
4263 mpz_neg (result->value.integer, result->value.integer);
4268 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
4270 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4271 if (mpfr_sgn (y->value.real) < 0)
4272 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
4277 gfc_internal_error ("Bad type in gfc_simplify_sign");
4285 gfc_simplify_sin (gfc_expr *x)
4289 if (x->expr_type != EXPR_CONSTANT)
4292 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4297 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4301 gfc_set_model (x->value.real);
4303 call_mpc_func (result->value.complex.r, result->value.complex.i,
4304 x->value.complex.r, x->value.complex.i, mpc_sin);
4311 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
4312 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
4313 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
4315 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
4316 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
4317 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
4319 mpfr_clears (xp, xq, NULL);
4325 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4328 return range_check (result, "SIN");
4333 gfc_simplify_sinh (gfc_expr *x)
4337 if (x->expr_type != EXPR_CONSTANT)
4340 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4342 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4344 return range_check (result, "SINH");
4348 /* The argument is always a double precision real that is converted to
4349 single precision. TODO: Rounding! */
4352 gfc_simplify_sngl (gfc_expr *a)
4356 if (a->expr_type != EXPR_CONSTANT)
4359 result = gfc_real2real (a, gfc_default_real_kind);
4360 return range_check (result, "SNGL");
4365 gfc_simplify_spacing (gfc_expr *x)
4371 if (x->expr_type != EXPR_CONSTANT)
4374 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4376 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
4378 /* Special case x = 0 and -0. */
4379 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4380 if (mpfr_sgn (result->value.real) == 0)
4382 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4386 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4387 are the radix, exponent of x, and precision. This excludes the
4388 possibility of subnormal numbers. Fortran 2003 states the result is
4389 b**max(e - p, emin - 1). */
4391 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
4392 en = (long int) gfc_real_kinds[i].min_exponent - 1;
4393 en = en > ep ? en : ep;
4395 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
4396 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
4398 return range_check (result, "SPACING");
4403 gfc_simplify_sqrt (gfc_expr *e)
4407 if (e->expr_type != EXPR_CONSTANT)
4410 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
4415 if (mpfr_cmp_si (e->value.real, 0) < 0)
4417 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
4422 gfc_set_model (e->value.real);
4424 call_mpc_func (result->value.complex.r, result->value.complex.i,
4425 e->value.complex.r, e->value.complex.i, mpc_sqrt);
4428 /* Formula taken from Numerical Recipes to avoid over- and
4431 mpfr_t ac, ad, s, t, w;
4438 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
4439 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
4441 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
4442 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
4446 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
4447 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
4449 if (mpfr_cmp (ac, ad) >= 0)
4451 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
4452 mpfr_mul (t, t, t, GFC_RND_MODE);
4453 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4454 mpfr_sqrt (t, t, GFC_RND_MODE);
4455 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4456 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4457 mpfr_sqrt (t, t, GFC_RND_MODE);
4458 mpfr_sqrt (s, ac, GFC_RND_MODE);
4459 mpfr_mul (w, s, t, GFC_RND_MODE);
4463 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
4464 mpfr_mul (t, s, s, GFC_RND_MODE);
4465 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4466 mpfr_sqrt (t, t, GFC_RND_MODE);
4467 mpfr_abs (s, s, GFC_RND_MODE);
4468 mpfr_add (t, t, s, GFC_RND_MODE);
4469 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4470 mpfr_sqrt (t, t, GFC_RND_MODE);
4471 mpfr_sqrt (s, ad, GFC_RND_MODE);
4472 mpfr_mul (w, s, t, GFC_RND_MODE);
4475 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
4477 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4478 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
4479 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
4481 else if (mpfr_cmp_ui (w, 0) != 0
4482 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4483 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
4485 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4486 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
4487 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4489 else if (mpfr_cmp_ui (w, 0) != 0
4490 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4491 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
4493 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4494 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
4495 mpfr_neg (w, w, GFC_RND_MODE);
4496 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4499 gfc_internal_error ("invalid complex argument of SQRT at %L",
4502 mpfr_clears (s, t, ac, ad, w, NULL);
4508 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
4511 return range_check (result, "SQRT");
4514 gfc_free_expr (result);
4515 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
4516 return &gfc_bad_expr;
4521 gfc_simplify_tan (gfc_expr *x)
4526 if (x->expr_type != EXPR_CONSTANT)
4529 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4531 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4533 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
4535 return range_check (result, "TAN");
4540 gfc_simplify_tanh (gfc_expr *x)
4544 if (x->expr_type != EXPR_CONSTANT)
4547 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4549 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
4551 return range_check (result, "TANH");
4557 gfc_simplify_tiny (gfc_expr *e)
4562 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
4564 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
4565 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4572 gfc_simplify_trailz (gfc_expr *e)
4575 unsigned long tz, bs;
4578 if (e->expr_type != EXPR_CONSTANT)
4581 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4582 bs = gfc_integer_kinds[i].bit_size;
4583 tz = mpz_scan1 (e->value.integer, 0);
4585 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
4586 mpz_set_ui (result->value.integer, MIN (tz, bs));
4593 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4596 gfc_expr *mold_element;
4599 size_t result_elt_size;
4602 unsigned char *buffer;
4604 if (!gfc_is_constant_expr (source)
4605 || (gfc_init_expr && !gfc_is_constant_expr (mold))
4606 || !gfc_is_constant_expr (size))
4609 if (source->expr_type == EXPR_FUNCTION)
4612 /* Calculate the size of the source. */
4613 if (source->expr_type == EXPR_ARRAY
4614 && gfc_array_size (source, &tmp) == FAILURE)
4615 gfc_internal_error ("Failure getting length of a constant array.");
4617 source_size = gfc_target_expr_size (source);
4619 /* Create an empty new expression with the appropriate characteristics. */
4620 result = gfc_constant_result (mold->ts.type, mold->ts.kind,
4622 result->ts = mold->ts;
4624 mold_element = mold->expr_type == EXPR_ARRAY
4625 ? mold->value.constructor->expr
4628 /* Set result character length, if needed. Note that this needs to be
4629 set even for array expressions, in order to pass this information into
4630 gfc_target_interpret_expr. */
4631 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
4632 result->value.character.length = mold_element->value.character.length;
4634 /* Set the number of elements in the result, and determine its size. */
4635 result_elt_size = gfc_target_expr_size (mold_element);
4636 if (result_elt_size == 0)
4638 gfc_free_expr (result);
4642 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4646 result->expr_type = EXPR_ARRAY;
4650 result_length = (size_t)mpz_get_ui (size->value.integer);
4653 result_length = source_size / result_elt_size;
4654 if (result_length * result_elt_size < source_size)
4658 result->shape = gfc_get_shape (1);
4659 mpz_init_set_ui (result->shape[0], result_length);
4661 result_size = result_length * result_elt_size;
4666 result_size = result_elt_size;
4669 if (gfc_option.warn_surprising && source_size < result_size)
4670 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4671 "source size %ld < result size %ld", &source->where,
4672 (long) source_size, (long) result_size);
4674 /* Allocate the buffer to store the binary version of the source. */
4675 buffer_size = MAX (source_size, result_size);
4676 buffer = (unsigned char*)alloca (buffer_size);
4677 memset (buffer, 0, buffer_size);
4679 /* Now write source to the buffer. */
4680 gfc_target_encode_expr (source, buffer, buffer_size);
4682 /* And read the buffer back into the new expression. */
4683 gfc_target_interpret_expr (buffer, buffer_size, result);
4690 gfc_simplify_trim (gfc_expr *e)
4693 int count, i, len, lentrim;
4695 if (e->expr_type != EXPR_CONSTANT)
4698 len = e->value.character.length;
4700 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4702 for (count = 0, i = 1; i <= len; ++i)
4704 if (e->value.character.string[len - i] == ' ')
4710 lentrim = len - count;
4712 result->value.character.length = lentrim;
4713 result->value.character.string = gfc_get_wide_string (lentrim + 1);
4715 for (i = 0; i < lentrim; i++)
4716 result->value.character.string[i] = e->value.character.string[i];
4718 result->value.character.string[lentrim] = '\0'; /* For debugger */
4725 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4727 return simplify_bound (array, dim, kind, 1);
4732 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
4736 size_t index, len, lenset;
4738 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
4741 return &gfc_bad_expr;
4743 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4746 if (b != NULL && b->value.logical != 0)
4751 result = gfc_constant_result (BT_INTEGER, k, &s->where);
4753 len = s->value.character.length;
4754 lenset = set->value.character.length;
4758 mpz_set_ui (result->value.integer, 0);
4766 mpz_set_ui (result->value.integer, 1);
4770 index = wide_strspn (s->value.character.string,
4771 set->value.character.string) + 1;
4780 mpz_set_ui (result->value.integer, len);
4783 for (index = len; index > 0; index --)
4785 for (i = 0; i < lenset; i++)
4787 if (s->value.character.string[index - 1]
4788 == set->value.character.string[i])
4796 mpz_set_ui (result->value.integer, index);
4802 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4807 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4810 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4811 if (x->ts.type == BT_INTEGER)
4813 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4814 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4815 return range_check (result, "XOR");
4817 else /* BT_LOGICAL */
4819 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4820 result->value.logical = (x->value.logical && !y->value.logical)
4821 || (!x->value.logical && y->value.logical);
4828 /****************** Constant simplification *****************/
4830 /* Master function to convert one constant to another. While this is
4831 used as a simplification function, it requires the destination type
4832 and kind information which is supplied by a special case in
4836 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4838 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4839 gfc_constructor *head, *c, *tail = NULL;
4853 f = gfc_int2complex;
4873 f = gfc_real2complex;
4884 f = gfc_complex2int;
4887 f = gfc_complex2real;
4890 f = gfc_complex2complex;
4916 f = gfc_hollerith2int;
4920 f = gfc_hollerith2real;
4924 f = gfc_hollerith2complex;
4928 f = gfc_hollerith2character;
4932 f = gfc_hollerith2logical;
4942 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4947 switch (e->expr_type)
4950 result = f (e, kind);
4952 return &gfc_bad_expr;
4956 if (!gfc_is_constant_expr (e))
4961 for (c = e->value.constructor; c; c = c->next)
4964 head = tail = gfc_get_constructor ();
4967 tail->next = gfc_get_constructor ();
4971 tail->where = c->where;
4973 if (c->iterator == NULL)
4974 tail->expr = f (c->expr, kind);
4977 g = gfc_convert_constant (c->expr, type, kind);
4978 if (g == &gfc_bad_expr)
4983 if (tail->expr == NULL)
4985 gfc_free_constructor (head);
4990 result = gfc_get_expr ();
4991 result->ts.type = type;
4992 result->ts.kind = kind;
4993 result->expr_type = EXPR_ARRAY;
4994 result->value.constructor = head;
4995 result->shape = gfc_copy_shape (e->shape, e->rank);
4996 result->where = e->where;
4997 result->rank = e->rank;
5008 /* Function for converting character constants. */
5010 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
5015 if (!gfc_is_constant_expr (e))
5018 if (e->expr_type == EXPR_CONSTANT)
5020 /* Simple case of a scalar. */
5021 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
5023 return &gfc_bad_expr;
5025 result->value.character.length = e->value.character.length;
5026 result->value.character.string
5027 = gfc_get_wide_string (e->value.character.length + 1);
5028 memcpy (result->value.character.string, e->value.character.string,
5029 (e->value.character.length + 1) * sizeof (gfc_char_t));
5031 /* Check we only have values representable in the destination kind. */
5032 for (i = 0; i < result->value.character.length; i++)
5033 if (!gfc_check_character_range (result->value.character.string[i],
5036 gfc_error ("Character '%s' in string at %L cannot be converted "
5037 "into character kind %d",
5038 gfc_print_wide_char (result->value.character.string[i]),
5040 return &gfc_bad_expr;
5045 else if (e->expr_type == EXPR_ARRAY)
5047 /* For an array constructor, we convert each constructor element. */
5048 gfc_constructor *head = NULL, *tail = NULL, *c;
5050 for (c = e->value.constructor; c; c = c->next)
5053 head = tail = gfc_get_constructor ();
5056 tail->next = gfc_get_constructor ();
5060 tail->where = c->where;
5061 tail->expr = gfc_convert_char_constant (c->expr, type, kind);
5062 if (tail->expr == &gfc_bad_expr)
5065 return &gfc_bad_expr;
5068 if (tail->expr == NULL)
5070 gfc_free_constructor (head);
5075 result = gfc_get_expr ();
5076 result->ts.type = type;
5077 result->ts.kind = kind;
5078 result->expr_type = EXPR_ARRAY;
5079 result->value.constructor = head;
5080 result->shape = gfc_copy_shape (e->shape, e->rank);
5081 result->where = e->where;
5082 result->rank = e->rank;
5083 result->ts.cl = e->ts.cl;