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);
214 /********************** Simplification functions *****************************/
217 gfc_simplify_abs (gfc_expr *e)
221 if (e->expr_type != EXPR_CONSTANT)
227 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
229 mpz_abs (result->value.integer, e->value.integer);
231 result = range_check (result, "IABS");
235 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
237 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
239 result = range_check (result, "ABS");
243 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
245 gfc_set_model_kind (e->ts.kind);
247 mpfr_hypot (result->value.real, e->value.complex.r,
248 e->value.complex.i, GFC_RND_MODE);
249 result = range_check (result, "CABS");
253 gfc_internal_error ("gfc_simplify_abs(): Bad type");
261 simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
265 bool too_large = false;
267 if (e->expr_type != EXPR_CONSTANT)
270 kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
272 return &gfc_bad_expr;
274 if (mpz_cmp_si (e->value.integer, 0) < 0)
276 gfc_error ("Argument of %s function at %L is negative", name,
278 return &gfc_bad_expr;
281 if (ascii && gfc_option.warn_surprising
282 && mpz_cmp_si (e->value.integer, 127) > 0)
283 gfc_warning ("Argument of %s function at %L outside of range [0,127]",
286 if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
291 mpz_init_set_ui (t, 2);
292 mpz_pow_ui (t, t, 32);
293 mpz_sub_ui (t, t, 1);
294 if (mpz_cmp (e->value.integer, t) > 0)
301 gfc_error ("Argument of %s function at %L is too large for the "
302 "collating sequence of kind %d", name, &e->where, kind);
303 return &gfc_bad_expr;
306 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
307 result->value.character.string = gfc_get_wide_string (2);
308 result->value.character.length = 1;
309 result->value.character.string[0] = mpz_get_ui (e->value.integer);
310 result->value.character.string[1] = '\0'; /* For debugger */
316 /* We use the processor's collating sequence, because all
317 systems that gfortran currently works on are ASCII. */
320 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
322 return simplify_achar_char (e, k, "ACHAR", true);
327 gfc_simplify_acos (gfc_expr *x)
331 if (x->expr_type != EXPR_CONSTANT)
334 if (mpfr_cmp_si (x->value.real, 1) > 0
335 || mpfr_cmp_si (x->value.real, -1) < 0)
337 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
339 return &gfc_bad_expr;
342 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
344 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
346 return range_check (result, "ACOS");
350 gfc_simplify_acosh (gfc_expr *x)
354 if (x->expr_type != EXPR_CONSTANT)
357 if (mpfr_cmp_si (x->value.real, 1) < 0)
359 gfc_error ("Argument of ACOSH at %L must not be less than 1",
361 return &gfc_bad_expr;
364 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
366 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
368 return range_check (result, "ACOSH");
372 gfc_simplify_adjustl (gfc_expr *e)
378 if (e->expr_type != EXPR_CONSTANT)
381 len = e->value.character.length;
383 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
385 result->value.character.length = len;
386 result->value.character.string = gfc_get_wide_string (len + 1);
388 for (count = 0, i = 0; i < len; ++i)
390 ch = e->value.character.string[i];
396 for (i = 0; i < len - count; ++i)
397 result->value.character.string[i] = e->value.character.string[count + i];
399 for (i = len - count; i < len; ++i)
400 result->value.character.string[i] = ' ';
402 result->value.character.string[len] = '\0'; /* For debugger */
409 gfc_simplify_adjustr (gfc_expr *e)
415 if (e->expr_type != EXPR_CONSTANT)
418 len = e->value.character.length;
420 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
422 result->value.character.length = len;
423 result->value.character.string = gfc_get_wide_string (len + 1);
425 for (count = 0, i = len - 1; i >= 0; --i)
427 ch = e->value.character.string[i];
433 for (i = 0; i < count; ++i)
434 result->value.character.string[i] = ' ';
436 for (i = count; i < len; ++i)
437 result->value.character.string[i] = e->value.character.string[i - count];
439 result->value.character.string[len] = '\0'; /* For debugger */
446 gfc_simplify_aimag (gfc_expr *e)
450 if (e->expr_type != EXPR_CONSTANT)
453 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
454 mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
456 return range_check (result, "AIMAG");
461 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
463 gfc_expr *rtrunc, *result;
466 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
468 return &gfc_bad_expr;
470 if (e->expr_type != EXPR_CONSTANT)
473 rtrunc = gfc_copy_expr (e);
475 mpfr_trunc (rtrunc->value.real, e->value.real);
477 result = gfc_real2real (rtrunc, kind);
478 gfc_free_expr (rtrunc);
480 return range_check (result, "AINT");
485 gfc_simplify_dint (gfc_expr *e)
487 gfc_expr *rtrunc, *result;
489 if (e->expr_type != EXPR_CONSTANT)
492 rtrunc = gfc_copy_expr (e);
494 mpfr_trunc (rtrunc->value.real, e->value.real);
496 result = gfc_real2real (rtrunc, gfc_default_double_kind);
497 gfc_free_expr (rtrunc);
499 return range_check (result, "DINT");
504 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
509 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
511 return &gfc_bad_expr;
513 if (e->expr_type != EXPR_CONSTANT)
516 result = gfc_constant_result (e->ts.type, kind, &e->where);
518 mpfr_round (result->value.real, e->value.real);
520 return range_check (result, "ANINT");
525 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
530 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
533 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
534 if (x->ts.type == BT_INTEGER)
536 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
537 mpz_and (result->value.integer, x->value.integer, y->value.integer);
538 return range_check (result, "AND");
540 else /* BT_LOGICAL */
542 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
543 result->value.logical = x->value.logical && y->value.logical;
550 gfc_simplify_dnint (gfc_expr *e)
554 if (e->expr_type != EXPR_CONSTANT)
557 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
559 mpfr_round (result->value.real, e->value.real);
561 return range_check (result, "DNINT");
566 gfc_simplify_asin (gfc_expr *x)
570 if (x->expr_type != EXPR_CONSTANT)
573 if (mpfr_cmp_si (x->value.real, 1) > 0
574 || mpfr_cmp_si (x->value.real, -1) < 0)
576 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
578 return &gfc_bad_expr;
581 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
583 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
585 return range_check (result, "ASIN");
590 gfc_simplify_asinh (gfc_expr *x)
594 if (x->expr_type != EXPR_CONSTANT)
597 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
599 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
601 return range_check (result, "ASINH");
606 gfc_simplify_atan (gfc_expr *x)
610 if (x->expr_type != EXPR_CONSTANT)
613 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
615 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
617 return range_check (result, "ATAN");
622 gfc_simplify_atanh (gfc_expr *x)
626 if (x->expr_type != EXPR_CONSTANT)
629 if (mpfr_cmp_si (x->value.real, 1) >= 0
630 || mpfr_cmp_si (x->value.real, -1) <= 0)
632 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
634 return &gfc_bad_expr;
637 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
639 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
641 return range_check (result, "ATANH");
646 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
650 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
653 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
655 gfc_error ("If first argument of ATAN2 %L is zero, then the "
656 "second argument must not be zero", &x->where);
657 return &gfc_bad_expr;
660 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
662 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
664 return range_check (result, "ATAN2");
669 gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
673 if (x->expr_type != EXPR_CONSTANT)
676 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
677 mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
679 return range_check (result, "BESSEL_J0");
684 gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
688 if (x->expr_type != EXPR_CONSTANT)
691 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
692 mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
694 return range_check (result, "BESSEL_J1");
699 gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
700 gfc_expr *x ATTRIBUTE_UNUSED)
705 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
708 n = mpz_get_si (order->value.integer);
709 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
710 mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
712 return range_check (result, "BESSEL_JN");
717 gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
721 if (x->expr_type != EXPR_CONSTANT)
724 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
725 mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
727 return range_check (result, "BESSEL_Y0");
732 gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
736 if (x->expr_type != EXPR_CONSTANT)
739 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
740 mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
742 return range_check (result, "BESSEL_Y1");
747 gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
748 gfc_expr *x ATTRIBUTE_UNUSED)
753 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
756 n = mpz_get_si (order->value.integer);
757 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
758 mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
760 return range_check (result, "BESSEL_YN");
765 gfc_simplify_bit_size (gfc_expr *e)
770 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
771 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
772 mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
779 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
783 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
786 if (gfc_extract_int (bit, &b) != NULL || b < 0)
787 return gfc_logical_expr (0, &e->where);
789 return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
794 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
796 gfc_expr *ceil, *result;
799 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
801 return &gfc_bad_expr;
803 if (e->expr_type != EXPR_CONSTANT)
806 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
808 ceil = gfc_copy_expr (e);
810 mpfr_ceil (ceil->value.real, e->value.real);
811 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
813 gfc_free_expr (ceil);
815 return range_check (result, "CEILING");
820 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
822 return simplify_achar_char (e, k, "CHAR", false);
826 /* Common subroutine for simplifying CMPLX and DCMPLX. */
829 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
833 result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
835 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
841 mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
845 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
849 mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
850 mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
854 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
863 mpfr_set_z (result->value.complex.i, y->value.integer,
868 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
872 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
881 ts.kind = result->ts.kind;
883 if (!gfc_convert_boz (x, &ts))
884 return &gfc_bad_expr;
885 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
892 ts.kind = result->ts.kind;
894 if (!gfc_convert_boz (y, &ts))
895 return &gfc_bad_expr;
896 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
899 return range_check (result, name);
903 /* Function called when we won't simplify an expression like CMPLX (or
904 COMPLEX or DCMPLX) but still want to convert BOZ arguments. */
907 only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
914 if (x->is_boz && !gfc_convert_boz (x, &ts))
915 return &gfc_bad_expr;
917 if (y && y->is_boz && !gfc_convert_boz (y, &ts))
918 return &gfc_bad_expr;
925 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
929 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
931 return &gfc_bad_expr;
933 if (x->expr_type != EXPR_CONSTANT
934 || (y != NULL && y->expr_type != EXPR_CONSTANT))
935 return only_convert_cmplx_boz (x, y, kind);
937 return simplify_cmplx ("CMPLX", x, y, kind);
942 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
946 if (x->ts.type == BT_INTEGER)
948 if (y->ts.type == BT_INTEGER)
949 kind = gfc_default_real_kind;
955 if (y->ts.type == BT_REAL)
956 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
961 if (x->expr_type != EXPR_CONSTANT
962 || (y != NULL && y->expr_type != EXPR_CONSTANT))
963 return only_convert_cmplx_boz (x, y, kind);
965 return simplify_cmplx ("COMPLEX", x, y, kind);
970 gfc_simplify_conjg (gfc_expr *e)
974 if (e->expr_type != EXPR_CONSTANT)
977 result = gfc_copy_expr (e);
978 mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
980 return range_check (result, "CONJG");
985 gfc_simplify_cos (gfc_expr *x)
990 if (x->expr_type != EXPR_CONSTANT)
993 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
998 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1001 gfc_set_model_kind (x->ts.kind);
1005 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
1006 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
1007 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
1009 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
1010 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
1011 mpfr_mul (xp, xp, xq, GFC_RND_MODE);
1012 mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
1014 mpfr_clears (xp, xq, NULL);
1017 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1020 return range_check (result, "COS");
1026 gfc_simplify_cosh (gfc_expr *x)
1030 if (x->expr_type != EXPR_CONSTANT)
1033 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1035 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1037 return range_check (result, "COSH");
1042 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
1045 if (x->expr_type != EXPR_CONSTANT
1046 || (y != NULL && y->expr_type != EXPR_CONSTANT))
1047 return only_convert_cmplx_boz (x, y, gfc_default_double_kind);
1049 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
1054 gfc_simplify_dble (gfc_expr *e)
1056 gfc_expr *result = NULL;
1058 if (e->expr_type != EXPR_CONSTANT)
1065 result = gfc_int2real (e, gfc_default_double_kind);
1069 result = gfc_real2real (e, gfc_default_double_kind);
1073 result = gfc_complex2real (e, gfc_default_double_kind);
1077 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
1080 if (e->ts.type == BT_INTEGER && e->is_boz)
1085 ts.kind = gfc_default_double_kind;
1086 result = gfc_copy_expr (e);
1087 if (!gfc_convert_boz (result, &ts))
1089 gfc_free_expr (result);
1090 return &gfc_bad_expr;
1094 return range_check (result, "DBLE");
1099 gfc_simplify_digits (gfc_expr *x)
1103 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1107 digits = gfc_integer_kinds[i].digits;
1112 digits = gfc_real_kinds[i].digits;
1119 return gfc_int_expr (digits);
1124 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1129 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1132 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1133 result = gfc_constant_result (x->ts.type, kind, &x->where);
1138 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1139 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1141 mpz_set_ui (result->value.integer, 0);
1146 if (mpfr_cmp (x->value.real, y->value.real) > 0)
1147 mpfr_sub (result->value.real, x->value.real, y->value.real,
1150 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1155 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1158 return range_check (result, "DIM");
1163 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1165 gfc_expr *a1, *a2, *result;
1167 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1170 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1172 a1 = gfc_real2real (x, gfc_default_double_kind);
1173 a2 = gfc_real2real (y, gfc_default_double_kind);
1175 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1180 return range_check (result, "DPROD");
1185 gfc_simplify_erf (gfc_expr *x)
1189 if (x->expr_type != EXPR_CONSTANT)
1192 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1194 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1196 return range_check (result, "ERF");
1201 gfc_simplify_erfc (gfc_expr *x)
1205 if (x->expr_type != EXPR_CONSTANT)
1208 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1210 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1212 return range_check (result, "ERFC");
1217 gfc_simplify_epsilon (gfc_expr *e)
1222 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1224 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1226 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1228 return range_check (result, "EPSILON");
1233 gfc_simplify_exp (gfc_expr *x)
1238 if (x->expr_type != EXPR_CONSTANT)
1241 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1246 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1250 gfc_set_model_kind (x->ts.kind);
1253 mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1254 mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1255 mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1256 mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1257 mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1258 mpfr_clears (xp, xq, NULL);
1262 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1265 return range_check (result, "EXP");
1269 gfc_simplify_exponent (gfc_expr *x)
1274 if (x->expr_type != EXPR_CONSTANT)
1277 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1280 gfc_set_model (x->value.real);
1282 if (mpfr_sgn (x->value.real) == 0)
1284 mpz_set_ui (result->value.integer, 0);
1288 i = (int) mpfr_get_exp (x->value.real);
1289 mpz_set_si (result->value.integer, i);
1291 return range_check (result, "EXPONENT");
1296 gfc_simplify_float (gfc_expr *a)
1300 if (a->expr_type != EXPR_CONSTANT)
1309 ts.kind = gfc_default_real_kind;
1311 result = gfc_copy_expr (a);
1312 if (!gfc_convert_boz (result, &ts))
1314 gfc_free_expr (result);
1315 return &gfc_bad_expr;
1319 result = gfc_int2real (a, gfc_default_real_kind);
1320 return range_check (result, "FLOAT");
1325 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1331 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1333 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1335 if (e->expr_type != EXPR_CONSTANT)
1338 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1340 gfc_set_model_kind (kind);
1342 mpfr_floor (floor, e->value.real);
1344 gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
1348 return range_check (result, "FLOOR");
1353 gfc_simplify_fraction (gfc_expr *x)
1356 mpfr_t absv, exp, pow2;
1358 if (x->expr_type != EXPR_CONSTANT)
1361 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1363 if (mpfr_sgn (x->value.real) == 0)
1365 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1369 gfc_set_model_kind (x->ts.kind);
1374 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1375 mpfr_log2 (exp, absv, GFC_RND_MODE);
1377 mpfr_trunc (exp, exp);
1378 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1380 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1382 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1384 mpfr_clears (exp, absv, pow2, NULL);
1386 return range_check (result, "FRACTION");
1391 gfc_simplify_gamma (gfc_expr *x)
1395 if (x->expr_type != EXPR_CONSTANT)
1398 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1400 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1402 return range_check (result, "GAMMA");
1407 gfc_simplify_huge (gfc_expr *e)
1412 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1414 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1419 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1423 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1435 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
1439 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1442 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1443 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
1444 return range_check (result, "HYPOT");
1448 /* We use the processor's collating sequence, because all
1449 systems that gfortran currently works on are ASCII. */
1452 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
1457 if (e->expr_type != EXPR_CONSTANT)
1460 if (e->value.character.length != 1)
1462 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1463 return &gfc_bad_expr;
1466 index = e->value.character.string[0];
1468 if (gfc_option.warn_surprising && index > 127)
1469 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1472 if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
1473 return &gfc_bad_expr;
1475 result->where = e->where;
1477 return range_check (result, "IACHAR");
1482 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1486 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1489 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1491 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1493 return range_check (result, "IAND");
1498 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1503 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1506 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1508 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1509 return &gfc_bad_expr;
1512 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1514 if (pos >= gfc_integer_kinds[k].bit_size)
1516 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1518 return &gfc_bad_expr;
1521 result = gfc_copy_expr (x);
1523 convert_mpz_to_unsigned (result->value.integer,
1524 gfc_integer_kinds[k].bit_size);
1526 mpz_clrbit (result->value.integer, pos);
1528 convert_mpz_to_signed (result->value.integer,
1529 gfc_integer_kinds[k].bit_size);
1536 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1543 if (x->expr_type != EXPR_CONSTANT
1544 || y->expr_type != EXPR_CONSTANT
1545 || z->expr_type != EXPR_CONSTANT)
1548 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1550 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1551 return &gfc_bad_expr;
1554 if (gfc_extract_int (z, &len) != NULL || len < 0)
1556 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1557 return &gfc_bad_expr;
1560 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1562 bitsize = gfc_integer_kinds[k].bit_size;
1564 if (pos + len > bitsize)
1566 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1567 "bit size at %L", &y->where);
1568 return &gfc_bad_expr;
1571 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1572 convert_mpz_to_unsigned (result->value.integer,
1573 gfc_integer_kinds[k].bit_size);
1575 bits = XCNEWVEC (int, bitsize);
1577 for (i = 0; i < bitsize; i++)
1580 for (i = 0; i < len; i++)
1581 bits[i] = mpz_tstbit (x->value.integer, i + pos);
1583 for (i = 0; i < bitsize; i++)
1586 mpz_clrbit (result->value.integer, i);
1587 else if (bits[i] == 1)
1588 mpz_setbit (result->value.integer, i);
1590 gfc_internal_error ("IBITS: Bad bit");
1595 convert_mpz_to_signed (result->value.integer,
1596 gfc_integer_kinds[k].bit_size);
1603 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1608 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1611 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1613 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1614 return &gfc_bad_expr;
1617 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1619 if (pos >= gfc_integer_kinds[k].bit_size)
1621 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1623 return &gfc_bad_expr;
1626 result = gfc_copy_expr (x);
1628 convert_mpz_to_unsigned (result->value.integer,
1629 gfc_integer_kinds[k].bit_size);
1631 mpz_setbit (result->value.integer, pos);
1633 convert_mpz_to_signed (result->value.integer,
1634 gfc_integer_kinds[k].bit_size);
1641 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
1646 if (e->expr_type != EXPR_CONSTANT)
1649 if (e->value.character.length != 1)
1651 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1652 return &gfc_bad_expr;
1655 index = e->value.character.string[0];
1657 if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
1658 return &gfc_bad_expr;
1660 result->where = e->where;
1661 return range_check (result, "ICHAR");
1666 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
1670 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1673 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1675 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1677 return range_check (result, "IEOR");
1682 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
1685 int back, len, lensub;
1686 int i, j, k, count, index = 0, start;
1688 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
1689 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
1692 if (b != NULL && b->value.logical != 0)
1697 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
1699 return &gfc_bad_expr;
1701 result = gfc_constant_result (BT_INTEGER, k, &x->where);
1703 len = x->value.character.length;
1704 lensub = y->value.character.length;
1708 mpz_set_si (result->value.integer, 0);
1716 mpz_set_si (result->value.integer, 1);
1719 else if (lensub == 1)
1721 for (i = 0; i < len; i++)
1723 for (j = 0; j < lensub; j++)
1725 if (y->value.character.string[j]
1726 == x->value.character.string[i])
1736 for (i = 0; i < len; i++)
1738 for (j = 0; j < lensub; j++)
1740 if (y->value.character.string[j]
1741 == x->value.character.string[i])
1746 for (k = 0; k < lensub; k++)
1748 if (y->value.character.string[k]
1749 == x->value.character.string[k + start])
1753 if (count == lensub)
1768 mpz_set_si (result->value.integer, len + 1);
1771 else if (lensub == 1)
1773 for (i = 0; i < len; i++)
1775 for (j = 0; j < lensub; j++)
1777 if (y->value.character.string[j]
1778 == x->value.character.string[len - i])
1780 index = len - i + 1;
1788 for (i = 0; i < len; i++)
1790 for (j = 0; j < lensub; j++)
1792 if (y->value.character.string[j]
1793 == x->value.character.string[len - i])
1796 if (start <= len - lensub)
1799 for (k = 0; k < lensub; k++)
1800 if (y->value.character.string[k]
1801 == x->value.character.string[k + start])
1804 if (count == lensub)
1821 mpz_set_si (result->value.integer, index);
1822 return range_check (result, "INDEX");
1827 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
1829 gfc_expr *result = NULL;
1832 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1834 return &gfc_bad_expr;
1836 if (e->expr_type != EXPR_CONSTANT)
1842 result = gfc_int2int (e, kind);
1846 result = gfc_real2int (e, kind);
1850 result = gfc_complex2int (e, kind);
1854 gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1855 return &gfc_bad_expr;
1858 return range_check (result, "INT");
1863 simplify_intconv (gfc_expr *e, int kind, const char *name)
1865 gfc_expr *result = NULL;
1867 if (e->expr_type != EXPR_CONSTANT)
1873 result = gfc_int2int (e, kind);
1877 result = gfc_real2int (e, kind);
1881 result = gfc_complex2int (e, kind);
1885 gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
1886 return &gfc_bad_expr;
1889 return range_check (result, name);
1894 gfc_simplify_int2 (gfc_expr *e)
1896 return simplify_intconv (e, 2, "INT2");
1901 gfc_simplify_int8 (gfc_expr *e)
1903 return simplify_intconv (e, 8, "INT8");
1908 gfc_simplify_long (gfc_expr *e)
1910 return simplify_intconv (e, 4, "LONG");
1915 gfc_simplify_ifix (gfc_expr *e)
1917 gfc_expr *rtrunc, *result;
1919 if (e->expr_type != EXPR_CONSTANT)
1922 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1925 rtrunc = gfc_copy_expr (e);
1927 mpfr_trunc (rtrunc->value.real, e->value.real);
1928 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
1930 gfc_free_expr (rtrunc);
1931 return range_check (result, "IFIX");
1936 gfc_simplify_idint (gfc_expr *e)
1938 gfc_expr *rtrunc, *result;
1940 if (e->expr_type != EXPR_CONSTANT)
1943 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1946 rtrunc = gfc_copy_expr (e);
1948 mpfr_trunc (rtrunc->value.real, e->value.real);
1949 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
1951 gfc_free_expr (rtrunc);
1952 return range_check (result, "IDINT");
1957 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
1961 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1964 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1966 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1967 return range_check (result, "IOR");
1972 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
1975 int shift, ashift, isize, k, *bits, i;
1977 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1980 if (gfc_extract_int (s, &shift) != NULL)
1982 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
1983 return &gfc_bad_expr;
1986 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
1988 isize = gfc_integer_kinds[k].bit_size;
1997 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
1998 "at %L", &s->where);
1999 return &gfc_bad_expr;
2002 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2006 mpz_set (result->value.integer, e->value.integer);
2007 return range_check (result, "ISHFT");
2010 bits = XCNEWVEC (int, isize);
2012 for (i = 0; i < isize; i++)
2013 bits[i] = mpz_tstbit (e->value.integer, i);
2017 for (i = 0; i < shift; i++)
2018 mpz_clrbit (result->value.integer, i);
2020 for (i = 0; i < isize - shift; i++)
2023 mpz_clrbit (result->value.integer, i + shift);
2025 mpz_setbit (result->value.integer, i + shift);
2030 for (i = isize - 1; i >= isize - ashift; i--)
2031 mpz_clrbit (result->value.integer, i);
2033 for (i = isize - 1; i >= ashift; i--)
2036 mpz_clrbit (result->value.integer, i - ashift);
2038 mpz_setbit (result->value.integer, i - ashift);
2042 convert_mpz_to_signed (result->value.integer, isize);
2050 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
2053 int shift, ashift, isize, ssize, delta, k;
2056 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2059 if (gfc_extract_int (s, &shift) != NULL)
2061 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
2062 return &gfc_bad_expr;
2065 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2066 isize = gfc_integer_kinds[k].bit_size;
2070 if (sz->expr_type != EXPR_CONSTANT)
2073 if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
2075 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
2076 return &gfc_bad_expr;
2081 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
2082 "BIT_SIZE of first argument at %L", &s->where);
2083 return &gfc_bad_expr;
2097 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2098 "third argument at %L", &s->where);
2100 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2101 "BIT_SIZE of first argument at %L", &s->where);
2102 return &gfc_bad_expr;
2105 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2107 mpz_set (result->value.integer, e->value.integer);
2112 convert_mpz_to_unsigned (result->value.integer, isize);
2114 bits = XCNEWVEC (int, ssize);
2116 for (i = 0; i < ssize; i++)
2117 bits[i] = mpz_tstbit (e->value.integer, i);
2119 delta = ssize - ashift;
2123 for (i = 0; i < delta; i++)
2126 mpz_clrbit (result->value.integer, i + shift);
2128 mpz_setbit (result->value.integer, i + shift);
2131 for (i = delta; i < ssize; i++)
2134 mpz_clrbit (result->value.integer, i - delta);
2136 mpz_setbit (result->value.integer, i - delta);
2141 for (i = 0; i < ashift; i++)
2144 mpz_clrbit (result->value.integer, i + delta);
2146 mpz_setbit (result->value.integer, i + delta);
2149 for (i = ashift; i < ssize; i++)
2152 mpz_clrbit (result->value.integer, i + shift);
2154 mpz_setbit (result->value.integer, i + shift);
2158 convert_mpz_to_signed (result->value.integer, isize);
2166 gfc_simplify_kind (gfc_expr *e)
2169 if (e->ts.type == BT_DERIVED)
2171 gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
2172 return &gfc_bad_expr;
2175 return gfc_int_expr (e->ts.kind);
2180 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2181 gfc_array_spec *as, gfc_ref *ref)
2183 gfc_expr *l, *u, *result;
2186 /* The last dimension of an assumed-size array is special. */
2187 if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2189 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2190 return gfc_copy_expr (as->lower[d-1]);
2195 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2196 gfc_default_integer_kind);
2198 return &gfc_bad_expr;
2200 result = gfc_constant_result (BT_INTEGER, k, &array->where);
2203 /* Then, we need to know the extent of the given dimension. */
2204 if (ref->u.ar.type == AR_FULL)
2209 if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
2212 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2216 mpz_set_si (result->value.integer, 0);
2218 mpz_set_si (result->value.integer, 1);
2222 /* Nonzero extent. */
2224 mpz_set (result->value.integer, u->value.integer);
2226 mpz_set (result->value.integer, l->value.integer);
2233 if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer)
2238 mpz_set_si (result->value.integer, (long int) 1);
2241 return range_check (result, upper ? "UBOUND" : "LBOUND");
2246 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2252 if (array->expr_type != EXPR_VARIABLE)
2255 /* Follow any component references. */
2256 as = array->symtree->n.sym->as;
2257 for (ref = array->ref; ref; ref = ref->next)
2262 switch (ref->u.ar.type)
2269 /* We're done because 'as' has already been set in the
2270 previous iteration. */
2287 as = ref->u.c.component->as;
2299 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2304 /* Multi-dimensional bounds. */
2305 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2307 gfc_constructor *head, *tail;
2310 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2311 if (upper && as->type == AS_ASSUMED_SIZE)
2313 /* An error message will be emitted in
2314 check_assumed_size_reference (resolve.c). */
2315 return &gfc_bad_expr;
2318 /* Simplify the bounds for each dimension. */
2319 for (d = 0; d < array->rank; d++)
2321 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref);
2322 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2326 for (j = 0; j < d; j++)
2327 gfc_free_expr (bounds[j]);
2332 /* Allocate the result expression. */
2333 e = gfc_get_expr ();
2334 e->where = array->where;
2335 e->expr_type = EXPR_ARRAY;
2336 e->ts.type = BT_INTEGER;
2337 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2338 gfc_default_integer_kind);
2342 return &gfc_bad_expr;
2346 /* The result is a rank 1 array; its size is the rank of the first
2347 argument to {L,U}BOUND. */
2349 e->shape = gfc_get_shape (1);
2350 mpz_init_set_ui (e->shape[0], array->rank);
2352 /* Create the constructor for this array. */
2354 for (d = 0; d < array->rank; d++)
2356 /* Get a new constructor element. */
2358 head = tail = gfc_get_constructor ();
2361 tail->next = gfc_get_constructor ();
2365 tail->where = e->where;
2366 tail->expr = bounds[d];
2368 e->value.constructor = head;
2374 /* A DIM argument is specified. */
2375 if (dim->expr_type != EXPR_CONSTANT)
2378 d = mpz_get_si (dim->value.integer);
2380 if (d < 1 || d > as->rank
2381 || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2383 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2384 return &gfc_bad_expr;
2387 return simplify_bound_dim (array, kind, d, upper, as, ref);
2393 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2395 return simplify_bound (array, dim, kind, 0);
2400 gfc_simplify_leadz (gfc_expr *e)
2403 unsigned long lz, bs;
2406 if (e->expr_type != EXPR_CONSTANT)
2409 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2410 bs = gfc_integer_kinds[i].bit_size;
2411 if (mpz_cmp_si (e->value.integer, 0) == 0)
2414 lz = bs - mpz_sizeinbase (e->value.integer, 2);
2416 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
2417 mpz_set_ui (result->value.integer, lz);
2424 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
2427 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
2430 return &gfc_bad_expr;
2432 if (e->expr_type == EXPR_CONSTANT)
2434 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2435 mpz_set_si (result->value.integer, e->value.character.length);
2436 return range_check (result, "LEN");
2439 if (e->ts.cl != NULL && e->ts.cl->length != NULL
2440 && e->ts.cl->length->expr_type == EXPR_CONSTANT
2441 && e->ts.cl->length->ts.type == BT_INTEGER)
2443 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2444 mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2445 return range_check (result, "LEN");
2453 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
2456 int count, len, lentrim, i;
2457 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
2460 return &gfc_bad_expr;
2462 if (e->expr_type != EXPR_CONSTANT)
2465 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2466 len = e->value.character.length;
2468 for (count = 0, i = 1; i <= len; i++)
2469 if (e->value.character.string[len - i] == ' ')
2474 lentrim = len - count;
2476 mpz_set_si (result->value.integer, lentrim);
2477 return range_check (result, "LEN_TRIM");
2481 gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED)
2486 if (x->expr_type != EXPR_CONSTANT)
2489 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2491 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
2493 return range_check (result, "LGAMMA");
2498 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
2500 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2503 return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
2508 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
2510 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2513 return gfc_logical_expr (gfc_compare_string (a, b) > 0,
2519 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
2521 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2524 return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
2529 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
2531 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2534 return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
2539 gfc_simplify_log (gfc_expr *x)
2544 if (x->expr_type != EXPR_CONSTANT)
2547 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2553 if (mpfr_sgn (x->value.real) <= 0)
2555 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2556 "to zero", &x->where);
2557 gfc_free_expr (result);
2558 return &gfc_bad_expr;
2561 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
2565 if ((mpfr_sgn (x->value.complex.r) == 0)
2566 && (mpfr_sgn (x->value.complex.i) == 0))
2568 gfc_error ("Complex argument of LOG at %L cannot be zero",
2570 gfc_free_expr (result);
2571 return &gfc_bad_expr;
2574 gfc_set_model_kind (x->ts.kind);
2578 mpfr_atan2 (result->value.complex.i, x->value.complex.i,
2579 x->value.complex.r, GFC_RND_MODE);
2581 mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2582 mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2583 mpfr_add (xr, xr, xi, GFC_RND_MODE);
2584 mpfr_sqrt (xr, xr, GFC_RND_MODE);
2585 mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2587 mpfr_clears (xr, xi, NULL);
2592 gfc_internal_error ("gfc_simplify_log: bad type");
2595 return range_check (result, "LOG");
2600 gfc_simplify_log10 (gfc_expr *x)
2604 if (x->expr_type != EXPR_CONSTANT)
2607 if (mpfr_sgn (x->value.real) <= 0)
2609 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2610 "to zero", &x->where);
2611 return &gfc_bad_expr;
2614 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2616 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2618 return range_check (result, "LOG10");
2623 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
2628 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2630 return &gfc_bad_expr;
2632 if (e->expr_type != EXPR_CONSTANT)
2635 result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2637 result->value.logical = e->value.logical;
2644 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
2646 if (tsource->expr_type != EXPR_CONSTANT
2647 || fsource->expr_type != EXPR_CONSTANT
2648 || mask->expr_type != EXPR_CONSTANT)
2651 return gfc_copy_expr (mask->value.logical ? tsource : fsource);
2655 /* Selects bewteen current value and extremum for simplify_min_max
2656 and simplify_minval_maxval. */
2658 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
2660 switch (arg->ts.type)
2663 if (mpz_cmp (arg->value.integer,
2664 extremum->value.integer) * sign > 0)
2665 mpz_set (extremum->value.integer, arg->value.integer);
2669 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
2671 mpfr_max (extremum->value.real, extremum->value.real,
2672 arg->value.real, GFC_RND_MODE);
2674 mpfr_min (extremum->value.real, extremum->value.real,
2675 arg->value.real, GFC_RND_MODE);
2679 #define LENGTH(x) ((x)->value.character.length)
2680 #define STRING(x) ((x)->value.character.string)
2681 if (LENGTH(extremum) < LENGTH(arg))
2683 gfc_char_t *tmp = STRING(extremum);
2685 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
2686 memcpy (STRING(extremum), tmp,
2687 LENGTH(extremum) * sizeof (gfc_char_t));
2688 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2689 LENGTH(arg) - LENGTH(extremum));
2690 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
2691 LENGTH(extremum) = LENGTH(arg);
2695 if (gfc_compare_string (arg, extremum) * sign > 0)
2697 gfc_free (STRING(extremum));
2698 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
2699 memcpy (STRING(extremum), STRING(arg),
2700 LENGTH(arg) * sizeof (gfc_char_t));
2701 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
2702 LENGTH(extremum) - LENGTH(arg));
2703 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
2710 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2715 /* This function is special since MAX() can take any number of
2716 arguments. The simplified expression is a rewritten version of the
2717 argument list containing at most one constant element. Other
2718 constant elements are deleted. Because the argument list has
2719 already been checked, this function always succeeds. sign is 1 for
2720 MAX(), -1 for MIN(). */
2723 simplify_min_max (gfc_expr *expr, int sign)
2725 gfc_actual_arglist *arg, *last, *extremum;
2726 gfc_intrinsic_sym * specific;
2730 specific = expr->value.function.isym;
2732 arg = expr->value.function.actual;
2734 for (; arg; last = arg, arg = arg->next)
2736 if (arg->expr->expr_type != EXPR_CONSTANT)
2739 if (extremum == NULL)
2745 min_max_choose (arg->expr, extremum->expr, sign);
2747 /* Delete the extra constant argument. */
2749 expr->value.function.actual = arg->next;
2751 last->next = arg->next;
2754 gfc_free_actual_arglist (arg);
2758 /* If there is one value left, replace the function call with the
2760 if (expr->value.function.actual->next != NULL)
2763 /* Convert to the correct type and kind. */
2764 if (expr->ts.type != BT_UNKNOWN)
2765 return gfc_convert_constant (expr->value.function.actual->expr,
2766 expr->ts.type, expr->ts.kind);
2768 if (specific->ts.type != BT_UNKNOWN)
2769 return gfc_convert_constant (expr->value.function.actual->expr,
2770 specific->ts.type, specific->ts.kind);
2772 return gfc_copy_expr (expr->value.function.actual->expr);
2777 gfc_simplify_min (gfc_expr *e)
2779 return simplify_min_max (e, -1);
2784 gfc_simplify_max (gfc_expr *e)
2786 return simplify_min_max (e, 1);
2790 /* This is a simplified version of simplify_min_max to provide
2791 simplification of minval and maxval for a vector. */
2794 simplify_minval_maxval (gfc_expr *expr, int sign)
2796 gfc_constructor *ctr, *extremum;
2797 gfc_intrinsic_sym * specific;
2800 specific = expr->value.function.isym;
2802 ctr = expr->value.constructor;
2804 for (; ctr; ctr = ctr->next)
2806 if (ctr->expr->expr_type != EXPR_CONSTANT)
2809 if (extremum == NULL)
2815 min_max_choose (ctr->expr, extremum->expr, sign);
2818 if (extremum == NULL)
2821 /* Convert to the correct type and kind. */
2822 if (expr->ts.type != BT_UNKNOWN)
2823 return gfc_convert_constant (extremum->expr,
2824 expr->ts.type, expr->ts.kind);
2826 if (specific->ts.type != BT_UNKNOWN)
2827 return gfc_convert_constant (extremum->expr,
2828 specific->ts.type, specific->ts.kind);
2830 return gfc_copy_expr (extremum->expr);
2835 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
2837 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
2840 return simplify_minval_maxval (array, -1);
2845 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
2847 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
2849 return simplify_minval_maxval (array, 1);
2854 gfc_simplify_maxexponent (gfc_expr *x)
2859 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2861 result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2862 result->where = x->where;
2869 gfc_simplify_minexponent (gfc_expr *x)
2874 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2876 result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2877 result->where = x->where;
2884 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2890 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2893 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2894 result = gfc_constant_result (a->ts.type, kind, &a->where);
2899 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2901 /* Result is processor-dependent. */
2902 gfc_error ("Second argument MOD at %L is zero", &a->where);
2903 gfc_free_expr (result);
2904 return &gfc_bad_expr;
2906 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2910 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2912 /* Result is processor-dependent. */
2913 gfc_error ("Second argument of MOD at %L is zero", &p->where);
2914 gfc_free_expr (result);
2915 return &gfc_bad_expr;
2918 gfc_set_model_kind (kind);
2920 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
2921 mpfr_trunc (tmp, tmp);
2922 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
2923 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
2928 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2931 return range_check (result, "MOD");
2936 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2942 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2945 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2946 result = gfc_constant_result (a->ts.type, kind, &a->where);
2951 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2953 /* Result is processor-dependent. This processor just opts
2954 to not handle it at all. */
2955 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2956 gfc_free_expr (result);
2957 return &gfc_bad_expr;
2959 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2964 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2966 /* Result is processor-dependent. */
2967 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2968 gfc_free_expr (result);
2969 return &gfc_bad_expr;
2972 gfc_set_model_kind (kind);
2974 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
2975 mpfr_floor (tmp, tmp);
2976 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
2977 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
2982 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2985 return range_check (result, "MODULO");
2989 /* Exists for the sole purpose of consistency with other intrinsics. */
2991 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
2992 gfc_expr *fp ATTRIBUTE_UNUSED,
2993 gfc_expr *l ATTRIBUTE_UNUSED,
2994 gfc_expr *to ATTRIBUTE_UNUSED,
2995 gfc_expr *tp ATTRIBUTE_UNUSED)
3002 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
3005 mp_exp_t emin, emax;
3008 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3011 if (mpfr_sgn (s->value.real) == 0)
3013 gfc_error ("Second argument of NEAREST at %L shall not be zero",
3015 return &gfc_bad_expr;
3018 result = gfc_copy_expr (x);
3020 /* Save current values of emin and emax. */
3021 emin = mpfr_get_emin ();
3022 emax = mpfr_get_emax ();
3024 /* Set emin and emax for the current model number. */
3025 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
3026 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
3027 mpfr_get_prec(result->value.real) + 1);
3028 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
3029 mpfr_check_range (result->value.real, 0, GMP_RNDU);
3031 if (mpfr_sgn (s->value.real) > 0)
3033 mpfr_nextabove (result->value.real);
3034 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
3038 mpfr_nextbelow (result->value.real);
3039 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
3042 mpfr_set_emin (emin);
3043 mpfr_set_emax (emax);
3045 /* Only NaN can occur. Do not use range check as it gives an
3046 error for denormal numbers. */
3047 if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
3049 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
3050 gfc_free_expr (result);
3051 return &gfc_bad_expr;
3059 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
3061 gfc_expr *itrunc, *result;
3064 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
3066 return &gfc_bad_expr;
3068 if (e->expr_type != EXPR_CONSTANT)
3071 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
3073 itrunc = gfc_copy_expr (e);
3075 mpfr_round (itrunc->value.real, e->value.real);
3077 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
3079 gfc_free_expr (itrunc);
3081 return range_check (result, name);
3086 gfc_simplify_new_line (gfc_expr *e)
3090 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3091 result->value.character.string = gfc_get_wide_string (2);
3092 result->value.character.length = 1;
3093 result->value.character.string[0] = '\n';
3094 result->value.character.string[1] = '\0'; /* For debugger */
3100 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
3102 return simplify_nint ("NINT", e, k);
3107 gfc_simplify_idnint (gfc_expr *e)
3109 return simplify_nint ("IDNINT", e, NULL);
3114 gfc_simplify_not (gfc_expr *e)
3118 if (e->expr_type != EXPR_CONSTANT)
3121 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3123 mpz_com (result->value.integer, e->value.integer);
3125 return range_check (result, "NOT");
3130 gfc_simplify_null (gfc_expr *mold)
3136 result = gfc_get_expr ();
3137 result->ts.type = BT_UNKNOWN;
3140 result = gfc_copy_expr (mold);
3141 result->expr_type = EXPR_NULL;
3148 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3153 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3156 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3157 if (x->ts.type == BT_INTEGER)
3159 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
3160 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3161 return range_check (result, "OR");
3163 else /* BT_LOGICAL */
3165 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
3166 result->value.logical = x->value.logical || y->value.logical;
3173 gfc_simplify_precision (gfc_expr *e)
3178 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3180 result = gfc_int_expr (gfc_real_kinds[i].precision);
3181 result->where = e->where;
3188 gfc_simplify_radix (gfc_expr *e)
3193 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3197 i = gfc_integer_kinds[i].radix;
3201 i = gfc_real_kinds[i].radix;
3208 result = gfc_int_expr (i);
3209 result->where = e->where;
3216 gfc_simplify_range (gfc_expr *e)
3222 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3227 j = gfc_integer_kinds[i].range;
3232 j = gfc_real_kinds[i].range;
3239 result = gfc_int_expr (j);
3240 result->where = e->where;
3247 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
3249 gfc_expr *result = NULL;
3252 if (e->ts.type == BT_COMPLEX)
3253 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
3255 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
3258 return &gfc_bad_expr;
3260 if (e->expr_type != EXPR_CONSTANT)
3267 result = gfc_int2real (e, kind);
3271 result = gfc_real2real (e, kind);
3275 result = gfc_complex2real (e, kind);
3279 gfc_internal_error ("bad type in REAL");
3283 if (e->ts.type == BT_INTEGER && e->is_boz)
3289 result = gfc_copy_expr (e);
3290 if (!gfc_convert_boz (result, &ts))
3292 gfc_free_expr (result);
3293 return &gfc_bad_expr;
3297 return range_check (result, "REAL");
3302 gfc_simplify_realpart (gfc_expr *e)
3306 if (e->expr_type != EXPR_CONSTANT)
3309 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3310 mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
3312 return range_check (result, "REALPART");
3316 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
3319 int i, j, len, ncop, nlen;
3321 bool have_length = false;
3323 /* If NCOPIES isn't a constant, there's nothing we can do. */
3324 if (n->expr_type != EXPR_CONSTANT)
3327 /* If NCOPIES is negative, it's an error. */
3328 if (mpz_sgn (n->value.integer) < 0)
3330 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3332 return &gfc_bad_expr;
3335 /* If we don't know the character length, we can do no more. */
3336 if (e->ts.cl && e->ts.cl->length
3337 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
3339 len = mpz_get_si (e->ts.cl->length->value.integer);
3342 else if (e->expr_type == EXPR_CONSTANT
3343 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
3345 len = e->value.character.length;
3350 /* If the source length is 0, any value of NCOPIES is valid
3351 and everything behaves as if NCOPIES == 0. */
3354 mpz_set_ui (ncopies, 0);
3356 mpz_set (ncopies, n->value.integer);
3358 /* Check that NCOPIES isn't too large. */
3364 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
3366 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3370 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
3371 e->ts.cl->length->value.integer);
3375 mpz_init_set_si (mlen, len);
3376 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
3380 /* The check itself. */
3381 if (mpz_cmp (ncopies, max) > 0)
3384 mpz_clear (ncopies);
3385 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3387 return &gfc_bad_expr;
3392 mpz_clear (ncopies);
3394 /* For further simplification, we need the character string to be
3396 if (e->expr_type != EXPR_CONSTANT)
3400 (e->ts.cl->length &&
3401 mpz_sgn (e->ts.cl->length->value.integer)) != 0)
3403 const char *res = gfc_extract_int (n, &ncop);
3404 gcc_assert (res == NULL);
3409 len = e->value.character.length;
3412 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3416 result->value.character.string = gfc_get_wide_string (1);
3417 result->value.character.length = 0;
3418 result->value.character.string[0] = '\0';
3422 result->value.character.length = nlen;
3423 result->value.character.string = gfc_get_wide_string (nlen + 1);
3425 for (i = 0; i < ncop; i++)
3426 for (j = 0; j < len; j++)
3427 result->value.character.string[j+i*len]= e->value.character.string[j];
3429 result->value.character.string[nlen] = '\0'; /* For debugger */
3434 /* Test that the expression is an constant array. */
3437 is_constant_array_expr (gfc_expr *e)
3444 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
3447 for (c = e->value.constructor; c; c = c->next)
3448 if (c->expr->expr_type != EXPR_CONSTANT)
3455 /* This one is a bear, but mainly has to do with shuffling elements. */
3458 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3459 gfc_expr *pad, gfc_expr *order_exp)
3461 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3462 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3463 gfc_constructor *head, *tail;
3469 /* Check that argument expression types are OK. */
3470 if (!is_constant_array_expr (source))
3473 if (!is_constant_array_expr (shape_exp))
3476 if (!is_constant_array_expr (pad))
3479 if (!is_constant_array_expr (order_exp))
3482 /* Proceed with simplification, unpacking the array. */
3490 e = gfc_get_array_element (shape_exp, rank);
3494 if (gfc_extract_int (e, &shape[rank]) != NULL)
3496 gfc_error ("Integer too large in shape specification at %L",
3502 if (rank >= GFC_MAX_DIMENSIONS)
3504 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3505 "at %L", &e->where);
3510 if (shape[rank] < 0)
3512 gfc_error ("Shape specification at %L cannot be negative",
3524 gfc_error ("Shape specification at %L cannot be the null array",
3529 /* Now unpack the order array if present. */
3530 if (order_exp == NULL)
3532 for (i = 0; i < rank; i++)
3537 for (i = 0; i < rank; i++)
3540 for (i = 0; i < rank; i++)
3542 e = gfc_get_array_element (order_exp, i);
3545 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3546 "size as SHAPE parameter", &order_exp->where);
3550 if (gfc_extract_int (e, &order[i]) != NULL)
3552 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3558 if (order[i] < 1 || order[i] > rank)
3560 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3570 gfc_error ("Invalid permutation in ORDER parameter at %L",
3582 /* Count the elements in the source and padding arrays. */
3587 gfc_array_size (pad, &size);
3588 npad = mpz_get_ui (size);
3592 gfc_array_size (source, &size);
3593 nsource = mpz_get_ui (size);
3596 /* If it weren't for that pesky permutation we could just loop
3597 through the source and round out any shortage with pad elements.
3598 But no, someone just had to have the compiler do something the
3599 user should be doing. */
3601 for (i = 0; i < rank; i++)
3606 /* Figure out which element to extract. */
3607 mpz_set_ui (index, 0);
3609 for (i = rank - 1; i >= 0; i--)
3611 mpz_add_ui (index, index, x[order[i]]);
3613 mpz_mul_ui (index, index, shape[order[i - 1]]);
3616 if (mpz_cmp_ui (index, INT_MAX) > 0)
3617 gfc_internal_error ("Reshaped array too large at %C");
3619 j = mpz_get_ui (index);
3622 e = gfc_get_array_element (source, j);
3629 gfc_error ("PAD parameter required for short SOURCE parameter "
3630 "at %L", &source->where);
3635 e = gfc_get_array_element (pad, j);
3639 head = tail = gfc_get_constructor ();
3642 tail->next = gfc_get_constructor ();
3649 tail->where = e->where;
3652 /* Calculate the next element. */
3656 if (++x[i] < shape[i])
3667 e = gfc_get_expr ();
3668 e->where = source->where;
3669 e->expr_type = EXPR_ARRAY;
3670 e->value.constructor = head;
3671 e->shape = gfc_get_shape (rank);
3673 for (i = 0; i < rank; i++)
3674 mpz_init_set_ui (e->shape[i], shape[i]);
3682 gfc_free_constructor (head);
3684 return &gfc_bad_expr;
3689 gfc_simplify_rrspacing (gfc_expr *x)
3695 if (x->expr_type != EXPR_CONSTANT)
3698 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3700 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3702 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3704 /* Special case x = -0 and 0. */
3705 if (mpfr_sgn (result->value.real) == 0)
3707 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3711 /* | x * 2**(-e) | * 2**p. */
3712 e = - (long int) mpfr_get_exp (x->value.real);
3713 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3715 p = (long int) gfc_real_kinds[i].digits;
3716 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3718 return range_check (result, "RRSPACING");
3723 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3725 int k, neg_flag, power, exp_range;
3726 mpfr_t scale, radix;
3729 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3732 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3734 if (mpfr_sgn (x->value.real) == 0)
3736 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3740 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3742 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3744 /* This check filters out values of i that would overflow an int. */
3745 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3746 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3748 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3749 gfc_free_expr (result);
3750 return &gfc_bad_expr;
3753 /* Compute scale = radix ** power. */
3754 power = mpz_get_si (i->value.integer);
3764 gfc_set_model_kind (x->ts.kind);
3767 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3768 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3771 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3773 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3775 mpfr_clears (scale, radix, NULL);
3777 return range_check (result, "SCALE");
3781 /* Variants of strspn and strcspn that operate on wide characters. */
3784 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
3787 const gfc_char_t *c;
3791 for (c = s2; *c; c++)
3805 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
3808 const gfc_char_t *c;
3812 for (c = s2; *c; c++)
3827 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
3832 size_t indx, len, lenc;
3833 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3836 return &gfc_bad_expr;
3838 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3841 if (b != NULL && b->value.logical != 0)
3846 result = gfc_constant_result (BT_INTEGER, k, &e->where);
3848 len = e->value.character.length;
3849 lenc = c->value.character.length;
3851 if (len == 0 || lenc == 0)
3859 indx = wide_strcspn (e->value.character.string,
3860 c->value.character.string) + 1;
3867 for (indx = len; indx > 0; indx--)
3869 for (i = 0; i < lenc; i++)
3871 if (c->value.character.string[i]
3872 == e->value.character.string[indx - 1])
3880 mpz_set_ui (result->value.integer, indx);
3881 return range_check (result, "SCAN");
3886 gfc_simplify_selected_char_kind (gfc_expr *e)
3891 if (e->expr_type != EXPR_CONSTANT)
3894 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
3895 || gfc_compare_with_Cstring (e, "default", false) == 0)
3897 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
3902 result = gfc_int_expr (kind);
3903 result->where = e->where;
3910 gfc_simplify_selected_int_kind (gfc_expr *e)
3915 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3920 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3921 if (gfc_integer_kinds[i].range >= range
3922 && gfc_integer_kinds[i].kind < kind)
3923 kind = gfc_integer_kinds[i].kind;
3925 if (kind == INT_MAX)
3928 result = gfc_int_expr (kind);
3929 result->where = e->where;
3936 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3938 int range, precision, i, kind, found_precision, found_range;
3945 if (p->expr_type != EXPR_CONSTANT
3946 || gfc_extract_int (p, &precision) != NULL)
3954 if (q->expr_type != EXPR_CONSTANT
3955 || gfc_extract_int (q, &range) != NULL)
3960 found_precision = 0;
3963 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3965 if (gfc_real_kinds[i].precision >= precision)
3966 found_precision = 1;
3968 if (gfc_real_kinds[i].range >= range)
3971 if (gfc_real_kinds[i].precision >= precision
3972 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3973 kind = gfc_real_kinds[i].kind;
3976 if (kind == INT_MAX)
3980 if (!found_precision)
3986 result = gfc_int_expr (kind);
3987 result->where = (p != NULL) ? p->where : q->where;
3994 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3997 mpfr_t exp, absv, log2, pow2, frac;
4000 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4003 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
4005 if (mpfr_sgn (x->value.real) == 0)
4007 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4011 gfc_set_model_kind (x->ts.kind);
4018 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
4019 mpfr_log2 (log2, absv, GFC_RND_MODE);
4021 mpfr_trunc (log2, log2);
4022 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
4024 /* Old exponent value, and fraction. */
4025 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
4027 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
4030 exp2 = (unsigned long) mpz_get_d (i->value.integer);
4031 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
4033 mpfr_clears (absv, log2, pow2, frac, NULL);
4035 return range_check (result, "SET_EXPONENT");
4040 gfc_simplify_shape (gfc_expr *source)
4042 mpz_t shape[GFC_MAX_DIMENSIONS];
4043 gfc_expr *result, *e, *f;
4048 if (source->rank == 0)
4049 return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
4052 if (source->expr_type != EXPR_VARIABLE)
4055 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
4058 ar = gfc_find_array_ref (source);
4060 t = gfc_array_ref_shape (ar, shape);
4062 for (n = 0; n < source->rank; n++)
4064 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
4069 mpz_set (e->value.integer, shape[n]);
4070 mpz_clear (shape[n]);
4074 mpz_set_ui (e->value.integer, n + 1);
4076 f = gfc_simplify_size (source, e, NULL);
4080 gfc_free_expr (result);
4089 gfc_append_constructor (result, e);
4097 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4102 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4105 return &gfc_bad_expr;
4109 if (gfc_array_size (array, &size) == FAILURE)
4114 if (dim->expr_type != EXPR_CONSTANT)
4117 d = mpz_get_ui (dim->value.integer) - 1;
4118 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4122 result = gfc_constant_result (BT_INTEGER, k, &array->where);
4123 mpz_set (result->value.integer, size);
4129 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4133 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4136 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4141 mpz_abs (result->value.integer, x->value.integer);
4142 if (mpz_sgn (y->value.integer) < 0)
4143 mpz_neg (result->value.integer, result->value.integer);
4148 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
4150 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4151 if (mpfr_sgn (y->value.real) < 0)
4152 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
4157 gfc_internal_error ("Bad type in gfc_simplify_sign");
4165 gfc_simplify_sin (gfc_expr *x)
4170 if (x->expr_type != EXPR_CONSTANT)
4173 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4178 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4182 gfc_set_model (x->value.real);
4186 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
4187 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
4188 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
4190 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
4191 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
4192 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
4194 mpfr_clears (xp, xq, NULL);
4198 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4201 return range_check (result, "SIN");
4206 gfc_simplify_sinh (gfc_expr *x)
4210 if (x->expr_type != EXPR_CONSTANT)
4213 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4215 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4217 return range_check (result, "SINH");
4221 /* The argument is always a double precision real that is converted to
4222 single precision. TODO: Rounding! */
4225 gfc_simplify_sngl (gfc_expr *a)
4229 if (a->expr_type != EXPR_CONSTANT)
4232 result = gfc_real2real (a, gfc_default_real_kind);
4233 return range_check (result, "SNGL");
4238 gfc_simplify_spacing (gfc_expr *x)
4244 if (x->expr_type != EXPR_CONSTANT)
4247 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4249 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
4251 /* Special case x = 0 and -0. */
4252 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4253 if (mpfr_sgn (result->value.real) == 0)
4255 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4259 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4260 are the radix, exponent of x, and precision. This excludes the
4261 possibility of subnormal numbers. Fortran 2003 states the result is
4262 b**max(e - p, emin - 1). */
4264 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
4265 en = (long int) gfc_real_kinds[i].min_exponent - 1;
4266 en = en > ep ? en : ep;
4268 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
4269 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
4271 return range_check (result, "SPACING");
4276 gfc_simplify_sqrt (gfc_expr *e)
4279 mpfr_t ac, ad, s, t, w;
4281 if (e->expr_type != EXPR_CONSTANT)
4284 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
4289 if (mpfr_cmp_si (e->value.real, 0) < 0)
4291 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
4296 /* Formula taken from Numerical Recipes to avoid over- and
4299 gfc_set_model (e->value.real);
4306 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
4307 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
4309 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
4310 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
4314 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
4315 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
4317 if (mpfr_cmp (ac, ad) >= 0)
4319 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
4320 mpfr_mul (t, t, t, GFC_RND_MODE);
4321 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4322 mpfr_sqrt (t, t, GFC_RND_MODE);
4323 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4324 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4325 mpfr_sqrt (t, t, GFC_RND_MODE);
4326 mpfr_sqrt (s, ac, GFC_RND_MODE);
4327 mpfr_mul (w, s, t, GFC_RND_MODE);
4331 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
4332 mpfr_mul (t, s, s, GFC_RND_MODE);
4333 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4334 mpfr_sqrt (t, t, GFC_RND_MODE);
4335 mpfr_abs (s, s, GFC_RND_MODE);
4336 mpfr_add (t, t, s, GFC_RND_MODE);
4337 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4338 mpfr_sqrt (t, t, GFC_RND_MODE);
4339 mpfr_sqrt (s, ad, GFC_RND_MODE);
4340 mpfr_mul (w, s, t, GFC_RND_MODE);
4343 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
4345 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4346 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
4347 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
4349 else if (mpfr_cmp_ui (w, 0) != 0
4350 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4351 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
4353 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4354 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
4355 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4357 else if (mpfr_cmp_ui (w, 0) != 0
4358 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4359 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
4361 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4362 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
4363 mpfr_neg (w, w, GFC_RND_MODE);
4364 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4367 gfc_internal_error ("invalid complex argument of SQRT at %L",
4370 mpfr_clears (s, t, ac, ad, w, NULL);
4375 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
4378 return range_check (result, "SQRT");
4381 gfc_free_expr (result);
4382 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
4383 return &gfc_bad_expr;
4388 gfc_simplify_tan (gfc_expr *x)
4393 if (x->expr_type != EXPR_CONSTANT)
4396 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4398 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4400 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
4402 return range_check (result, "TAN");
4407 gfc_simplify_tanh (gfc_expr *x)
4411 if (x->expr_type != EXPR_CONSTANT)
4414 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4416 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
4418 return range_check (result, "TANH");
4424 gfc_simplify_tiny (gfc_expr *e)
4429 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
4431 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
4432 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4439 gfc_simplify_trailz (gfc_expr *e)
4442 unsigned long tz, bs;
4445 if (e->expr_type != EXPR_CONSTANT)
4448 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4449 bs = gfc_integer_kinds[i].bit_size;
4450 tz = mpz_scan1 (e->value.integer, 0);
4452 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
4453 mpz_set_ui (result->value.integer, MIN (tz, bs));
4460 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4463 gfc_expr *mold_element;
4466 size_t result_elt_size;
4469 unsigned char *buffer;
4471 if (!gfc_is_constant_expr (source)
4472 || (gfc_init_expr && !gfc_is_constant_expr (mold))
4473 || !gfc_is_constant_expr (size))
4476 if (source->expr_type == EXPR_FUNCTION)
4479 /* Calculate the size of the source. */
4480 if (source->expr_type == EXPR_ARRAY
4481 && gfc_array_size (source, &tmp) == FAILURE)
4482 gfc_internal_error ("Failure getting length of a constant array.");
4484 source_size = gfc_target_expr_size (source);
4486 /* Create an empty new expression with the appropriate characteristics. */
4487 result = gfc_constant_result (mold->ts.type, mold->ts.kind,
4489 result->ts = mold->ts;
4491 mold_element = mold->expr_type == EXPR_ARRAY
4492 ? mold->value.constructor->expr
4495 /* Set result character length, if needed. Note that this needs to be
4496 set even for array expressions, in order to pass this information into
4497 gfc_target_interpret_expr. */
4498 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
4499 result->value.character.length = mold_element->value.character.length;
4501 /* Set the number of elements in the result, and determine its size. */
4502 result_elt_size = gfc_target_expr_size (mold_element);
4503 if (result_elt_size == 0)
4505 gfc_free_expr (result);
4509 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4513 result->expr_type = EXPR_ARRAY;
4517 result_length = (size_t)mpz_get_ui (size->value.integer);
4520 result_length = source_size / result_elt_size;
4521 if (result_length * result_elt_size < source_size)
4525 result->shape = gfc_get_shape (1);
4526 mpz_init_set_ui (result->shape[0], result_length);
4528 result_size = result_length * result_elt_size;
4533 result_size = result_elt_size;
4536 if (gfc_option.warn_surprising && source_size < result_size)
4537 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4538 "source size %ld < result size %ld", &source->where,
4539 (long) source_size, (long) result_size);
4541 /* Allocate the buffer to store the binary version of the source. */
4542 buffer_size = MAX (source_size, result_size);
4543 buffer = (unsigned char*)alloca (buffer_size);
4544 memset (buffer, 0, buffer_size);
4546 /* Now write source to the buffer. */
4547 gfc_target_encode_expr (source, buffer, buffer_size);
4549 /* And read the buffer back into the new expression. */
4550 gfc_target_interpret_expr (buffer, buffer_size, result);
4557 gfc_simplify_trim (gfc_expr *e)
4560 int count, i, len, lentrim;
4562 if (e->expr_type != EXPR_CONSTANT)
4565 len = e->value.character.length;
4567 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4569 for (count = 0, i = 1; i <= len; ++i)
4571 if (e->value.character.string[len - i] == ' ')
4577 lentrim = len - count;
4579 result->value.character.length = lentrim;
4580 result->value.character.string = gfc_get_wide_string (lentrim + 1);
4582 for (i = 0; i < lentrim; i++)
4583 result->value.character.string[i] = e->value.character.string[i];
4585 result->value.character.string[lentrim] = '\0'; /* For debugger */
4592 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4594 return simplify_bound (array, dim, kind, 1);
4599 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
4603 size_t index, len, lenset;
4605 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
4608 return &gfc_bad_expr;
4610 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4613 if (b != NULL && b->value.logical != 0)
4618 result = gfc_constant_result (BT_INTEGER, k, &s->where);
4620 len = s->value.character.length;
4621 lenset = set->value.character.length;
4625 mpz_set_ui (result->value.integer, 0);
4633 mpz_set_ui (result->value.integer, 1);
4637 index = wide_strspn (s->value.character.string,
4638 set->value.character.string) + 1;
4647 mpz_set_ui (result->value.integer, len);
4650 for (index = len; index > 0; index --)
4652 for (i = 0; i < lenset; i++)
4654 if (s->value.character.string[index - 1]
4655 == set->value.character.string[i])
4663 mpz_set_ui (result->value.integer, index);
4669 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4674 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4677 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4678 if (x->ts.type == BT_INTEGER)
4680 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4681 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4682 return range_check (result, "XOR");
4684 else /* BT_LOGICAL */
4686 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4687 result->value.logical = (x->value.logical && !y->value.logical)
4688 || (!x->value.logical && y->value.logical);
4695 /****************** Constant simplification *****************/
4697 /* Master function to convert one constant to another. While this is
4698 used as a simplification function, it requires the destination type
4699 and kind information which is supplied by a special case in
4703 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4705 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4706 gfc_constructor *head, *c, *tail = NULL;
4720 f = gfc_int2complex;
4740 f = gfc_real2complex;
4751 f = gfc_complex2int;
4754 f = gfc_complex2real;
4757 f = gfc_complex2complex;
4783 f = gfc_hollerith2int;
4787 f = gfc_hollerith2real;
4791 f = gfc_hollerith2complex;
4795 f = gfc_hollerith2character;
4799 f = gfc_hollerith2logical;
4809 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4814 switch (e->expr_type)
4817 result = f (e, kind);
4819 return &gfc_bad_expr;
4823 if (!gfc_is_constant_expr (e))
4828 for (c = e->value.constructor; c; c = c->next)
4831 head = tail = gfc_get_constructor ();
4834 tail->next = gfc_get_constructor ();
4838 tail->where = c->where;
4840 if (c->iterator == NULL)
4841 tail->expr = f (c->expr, kind);
4844 g = gfc_convert_constant (c->expr, type, kind);
4845 if (g == &gfc_bad_expr)
4850 if (tail->expr == NULL)
4852 gfc_free_constructor (head);
4857 result = gfc_get_expr ();
4858 result->ts.type = type;
4859 result->ts.kind = kind;
4860 result->expr_type = EXPR_ARRAY;
4861 result->value.constructor = head;
4862 result->shape = gfc_copy_shape (e->shape, e->rank);
4863 result->where = e->where;
4864 result->rank = e->rank;
4875 /* Function for converting character constants. */
4877 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
4882 if (!gfc_is_constant_expr (e))
4885 if (e->expr_type == EXPR_CONSTANT)
4887 /* Simple case of a scalar. */
4888 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
4890 return &gfc_bad_expr;
4892 result->value.character.length = e->value.character.length;
4893 result->value.character.string
4894 = gfc_get_wide_string (e->value.character.length + 1);
4895 memcpy (result->value.character.string, e->value.character.string,
4896 (e->value.character.length + 1) * sizeof (gfc_char_t));
4898 /* Check we only have values representable in the destination kind. */
4899 for (i = 0; i < result->value.character.length; i++)
4900 if (!gfc_check_character_range (result->value.character.string[i],
4903 gfc_error ("Character '%s' in string at %L cannot be converted "
4904 "into character kind %d",
4905 gfc_print_wide_char (result->value.character.string[i]),
4907 return &gfc_bad_expr;
4912 else if (e->expr_type == EXPR_ARRAY)
4914 /* For an array constructor, we convert each constructor element. */
4915 gfc_constructor *head = NULL, *tail = NULL, *c;
4917 for (c = e->value.constructor; c; c = c->next)
4920 head = tail = gfc_get_constructor ();
4923 tail->next = gfc_get_constructor ();
4927 tail->where = c->where;
4928 tail->expr = gfc_convert_char_constant (c->expr, type, kind);
4929 if (tail->expr == &gfc_bad_expr)
4932 return &gfc_bad_expr;
4935 if (tail->expr == NULL)
4937 gfc_free_constructor (head);
4942 result = gfc_get_expr ();
4943 result->ts.type = type;
4944 result->ts.kind = kind;
4945 result->expr_type = EXPR_ARRAY;
4946 result->value.constructor = head;
4947 result->shape = gfc_copy_shape (e->shape, e->rank);
4948 result->where = e->where;
4949 result->rank = e->rank;
4950 result->ts.cl = e->ts.cl;