1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
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)
73 switch (gfc_range_check (result))
79 gfc_error ("Result of %s overflows its kind at %L", name,
84 gfc_error ("Result of %s underflows its kind at %L", name,
89 gfc_error ("Result of %s is NaN at %L", name, &result->where);
93 gfc_error ("Result of %s gives range error for its kind at %L", name,
98 gfc_free_expr (result);
103 /* A helper function that gets an optional and possibly missing
104 kind parameter. Returns the kind, -1 if something went wrong. */
107 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
114 if (k->expr_type != EXPR_CONSTANT)
116 gfc_error ("KIND parameter of %s at %L must be an initialization "
117 "expression", name, &k->where);
121 if (gfc_extract_int (k, &kind) != NULL
122 || gfc_validate_kind (type, kind, true) < 0)
124 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
132 /* Helper function to get an integer constant with a kind number given
133 by an integer constant expression. */
135 int_expr_with_kind (int i, gfc_expr *kind, const char *name)
137 gfc_expr *res = gfc_int_expr (i);
138 res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind);
139 if (res->ts.kind == -1)
146 /* Converts an mpz_t signed variable into an unsigned one, assuming
147 two's complement representations and a binary width of bitsize.
148 The conversion is a no-op unless x is negative; otherwise, it can
149 be accomplished by masking out the high bits. */
152 convert_mpz_to_unsigned (mpz_t x, int bitsize)
158 /* Confirm that no bits above the signed range are unset. */
159 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
161 mpz_init_set_ui (mask, 1);
162 mpz_mul_2exp (mask, mask, bitsize);
163 mpz_sub_ui (mask, mask, 1);
165 mpz_and (x, x, mask);
171 /* Confirm that no bits above the signed range are set. */
172 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
177 /* Converts an mpz_t unsigned variable into a signed one, assuming
178 two's complement representations and a binary width of bitsize.
179 If the bitsize-1 bit is set, this is taken as a sign bit and
180 the number is converted to the corresponding negative number. */
183 convert_mpz_to_signed (mpz_t x, int bitsize)
187 /* Confirm that no bits above the unsigned range are set. */
188 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
190 if (mpz_tstbit (x, bitsize - 1) == 1)
192 mpz_init_set_ui (mask, 1);
193 mpz_mul_2exp (mask, mask, bitsize);
194 mpz_sub_ui (mask, mask, 1);
196 /* We negate the number by hand, zeroing the high bits, that is
197 make it the corresponding positive number, and then have it
198 negated by GMP, giving the correct representation of the
201 mpz_add_ui (x, x, 1);
202 mpz_and (x, x, mask);
211 /********************** Simplification functions *****************************/
214 gfc_simplify_abs (gfc_expr *e)
218 if (e->expr_type != EXPR_CONSTANT)
224 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
226 mpz_abs (result->value.integer, e->value.integer);
228 result = range_check (result, "IABS");
232 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
234 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
236 result = range_check (result, "ABS");
240 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
242 gfc_set_model_kind (e->ts.kind);
244 mpfr_hypot (result->value.real, e->value.complex.r,
245 e->value.complex.i, GFC_RND_MODE);
246 result = range_check (result, "CABS");
250 gfc_internal_error ("gfc_simplify_abs(): Bad type");
256 /* We use the processor's collating sequence, because all
257 systems that gfortran currently works on are ASCII. */
260 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
266 if (e->expr_type != EXPR_CONSTANT)
269 kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind);
271 return &gfc_bad_expr;
273 ch = gfc_extract_int (e, &c);
276 gfc_internal_error ("gfc_simplify_achar: %s", ch);
278 if (gfc_option.warn_surprising && (c < 0 || c > 127))
279 gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
282 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
284 result->value.character.string = gfc_getmem (2);
286 result->value.character.length = 1;
287 result->value.character.string[0] = c;
288 result->value.character.string[1] = '\0'; /* For debugger */
294 gfc_simplify_acos (gfc_expr *x)
298 if (x->expr_type != EXPR_CONSTANT)
301 if (mpfr_cmp_si (x->value.real, 1) > 0
302 || mpfr_cmp_si (x->value.real, -1) < 0)
304 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
306 return &gfc_bad_expr;
309 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
311 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
313 return range_check (result, "ACOS");
317 gfc_simplify_acosh (gfc_expr *x)
321 if (x->expr_type != EXPR_CONSTANT)
324 if (mpfr_cmp_si (x->value.real, 1) < 0)
326 gfc_error ("Argument of ACOSH at %L must not be less than 1",
328 return &gfc_bad_expr;
331 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
333 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
335 return range_check (result, "ACOSH");
339 gfc_simplify_adjustl (gfc_expr *e)
345 if (e->expr_type != EXPR_CONSTANT)
348 len = e->value.character.length;
350 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
352 result->value.character.length = len;
353 result->value.character.string = gfc_getmem (len + 1);
355 for (count = 0, i = 0; i < len; ++i)
357 ch = e->value.character.string[i];
363 for (i = 0; i < len - count; ++i)
364 result->value.character.string[i] = e->value.character.string[count + i];
366 for (i = len - count; i < len; ++i)
367 result->value.character.string[i] = ' ';
369 result->value.character.string[len] = '\0'; /* For debugger */
376 gfc_simplify_adjustr (gfc_expr *e)
382 if (e->expr_type != EXPR_CONSTANT)
385 len = e->value.character.length;
387 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
389 result->value.character.length = len;
390 result->value.character.string = gfc_getmem (len + 1);
392 for (count = 0, i = len - 1; i >= 0; --i)
394 ch = e->value.character.string[i];
400 for (i = 0; i < count; ++i)
401 result->value.character.string[i] = ' ';
403 for (i = count; i < len; ++i)
404 result->value.character.string[i] = e->value.character.string[i - count];
406 result->value.character.string[len] = '\0'; /* For debugger */
413 gfc_simplify_aimag (gfc_expr *e)
417 if (e->expr_type != EXPR_CONSTANT)
420 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
421 mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
423 return range_check (result, "AIMAG");
428 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
430 gfc_expr *rtrunc, *result;
433 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
435 return &gfc_bad_expr;
437 if (e->expr_type != EXPR_CONSTANT)
440 rtrunc = gfc_copy_expr (e);
442 mpfr_trunc (rtrunc->value.real, e->value.real);
444 result = gfc_real2real (rtrunc, kind);
445 gfc_free_expr (rtrunc);
447 return range_check (result, "AINT");
452 gfc_simplify_dint (gfc_expr *e)
454 gfc_expr *rtrunc, *result;
456 if (e->expr_type != EXPR_CONSTANT)
459 rtrunc = gfc_copy_expr (e);
461 mpfr_trunc (rtrunc->value.real, e->value.real);
463 result = gfc_real2real (rtrunc, gfc_default_double_kind);
464 gfc_free_expr (rtrunc);
466 return range_check (result, "DINT");
471 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
476 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
478 return &gfc_bad_expr;
480 if (e->expr_type != EXPR_CONSTANT)
483 result = gfc_constant_result (e->ts.type, kind, &e->where);
485 mpfr_round (result->value.real, e->value.real);
487 return range_check (result, "ANINT");
492 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
497 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
500 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
501 if (x->ts.type == BT_INTEGER)
503 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
504 mpz_and (result->value.integer, x->value.integer, y->value.integer);
506 else /* BT_LOGICAL */
508 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
509 result->value.logical = x->value.logical && y->value.logical;
512 return range_check (result, "AND");
517 gfc_simplify_dnint (gfc_expr *e)
521 if (e->expr_type != EXPR_CONSTANT)
524 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
526 mpfr_round (result->value.real, e->value.real);
528 return range_check (result, "DNINT");
533 gfc_simplify_asin (gfc_expr *x)
537 if (x->expr_type != EXPR_CONSTANT)
540 if (mpfr_cmp_si (x->value.real, 1) > 0
541 || mpfr_cmp_si (x->value.real, -1) < 0)
543 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
545 return &gfc_bad_expr;
548 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
550 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
552 return range_check (result, "ASIN");
557 gfc_simplify_asinh (gfc_expr *x)
561 if (x->expr_type != EXPR_CONSTANT)
564 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
566 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
568 return range_check (result, "ASINH");
573 gfc_simplify_atan (gfc_expr *x)
577 if (x->expr_type != EXPR_CONSTANT)
580 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
582 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
584 return range_check (result, "ATAN");
589 gfc_simplify_atanh (gfc_expr *x)
593 if (x->expr_type != EXPR_CONSTANT)
596 if (mpfr_cmp_si (x->value.real, 1) >= 0
597 || mpfr_cmp_si (x->value.real, -1) <= 0)
599 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
601 return &gfc_bad_expr;
604 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
606 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
608 return range_check (result, "ATANH");
613 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
617 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
620 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
622 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
624 gfc_error ("If first argument of ATAN2 %L is zero, then the "
625 "second argument must not be zero", &x->where);
626 gfc_free_expr (result);
627 return &gfc_bad_expr;
630 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
632 return range_check (result, "ATAN2");
637 gfc_simplify_bit_size (gfc_expr *e)
642 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
643 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
644 mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
651 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
655 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
658 if (gfc_extract_int (bit, &b) != NULL || b < 0)
659 return gfc_logical_expr (0, &e->where);
661 return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
666 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
668 gfc_expr *ceil, *result;
671 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
673 return &gfc_bad_expr;
675 if (e->expr_type != EXPR_CONSTANT)
678 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
680 ceil = gfc_copy_expr (e);
682 mpfr_ceil (ceil->value.real, e->value.real);
683 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
685 gfc_free_expr (ceil);
687 return range_check (result, "CEILING");
692 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
698 kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
700 return &gfc_bad_expr;
702 if (e->expr_type != EXPR_CONSTANT)
705 ch = gfc_extract_int (e, &c);
708 gfc_internal_error ("gfc_simplify_char: %s", ch);
710 if (c < 0 || c > UCHAR_MAX)
711 gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
714 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
716 result->value.character.length = 1;
717 result->value.character.string = gfc_getmem (2);
719 result->value.character.string[0] = c;
720 result->value.character.string[1] = '\0'; /* For debugger */
726 /* Common subroutine for simplifying CMPLX and DCMPLX. */
729 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
733 result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
735 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
740 mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
744 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
748 mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
749 mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
753 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
761 mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
765 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
769 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
773 return range_check (result, name);
778 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
782 if (x->expr_type != EXPR_CONSTANT
783 || (y != NULL && y->expr_type != EXPR_CONSTANT))
786 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
788 return &gfc_bad_expr;
790 return simplify_cmplx ("CMPLX", x, y, kind);
795 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
799 if (x->expr_type != EXPR_CONSTANT
800 || (y != NULL && y->expr_type != EXPR_CONSTANT))
803 if (x->ts.type == BT_INTEGER)
805 if (y->ts.type == BT_INTEGER)
806 kind = gfc_default_real_kind;
812 if (y->ts.type == BT_REAL)
813 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
818 return simplify_cmplx ("COMPLEX", x, y, kind);
823 gfc_simplify_conjg (gfc_expr *e)
827 if (e->expr_type != EXPR_CONSTANT)
830 result = gfc_copy_expr (e);
831 mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
833 return range_check (result, "CONJG");
838 gfc_simplify_cos (gfc_expr *x)
843 if (x->expr_type != EXPR_CONSTANT)
846 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
851 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
854 gfc_set_model_kind (x->ts.kind);
858 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
859 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
860 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
862 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
863 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
864 mpfr_mul (xp, xp, xq, GFC_RND_MODE);
865 mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
871 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
874 return range_check (result, "COS");
880 gfc_simplify_cosh (gfc_expr *x)
884 if (x->expr_type != EXPR_CONSTANT)
887 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
889 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
891 return range_check (result, "COSH");
896 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
899 if (x->expr_type != EXPR_CONSTANT
900 || (y != NULL && y->expr_type != EXPR_CONSTANT))
903 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
908 gfc_simplify_dble (gfc_expr *e)
912 if (e->expr_type != EXPR_CONSTANT)
918 result = gfc_int2real (e, gfc_default_double_kind);
922 result = gfc_real2real (e, gfc_default_double_kind);
926 result = gfc_complex2real (e, gfc_default_double_kind);
930 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
933 return range_check (result, "DBLE");
938 gfc_simplify_digits (gfc_expr *x)
942 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
946 digits = gfc_integer_kinds[i].digits;
951 digits = gfc_real_kinds[i].digits;
958 return gfc_int_expr (digits);
963 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
968 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
971 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
972 result = gfc_constant_result (x->ts.type, kind, &x->where);
977 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
978 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
980 mpz_set_ui (result->value.integer, 0);
985 if (mpfr_cmp (x->value.real, y->value.real) > 0)
986 mpfr_sub (result->value.real, x->value.real, y->value.real,
989 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
994 gfc_internal_error ("gfc_simplify_dim(): Bad type");
997 return range_check (result, "DIM");
1002 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1004 gfc_expr *a1, *a2, *result;
1006 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1009 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1011 a1 = gfc_real2real (x, gfc_default_double_kind);
1012 a2 = gfc_real2real (y, gfc_default_double_kind);
1014 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1019 return range_check (result, "DPROD");
1024 gfc_simplify_epsilon (gfc_expr *e)
1029 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1031 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1033 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1035 return range_check (result, "EPSILON");
1040 gfc_simplify_exp (gfc_expr *x)
1045 if (x->expr_type != EXPR_CONSTANT)
1048 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1053 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1057 gfc_set_model_kind (x->ts.kind);
1060 mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1061 mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1062 mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1063 mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1064 mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1070 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1073 return range_check (result, "EXP");
1077 gfc_simplify_exponent (gfc_expr *x)
1082 if (x->expr_type != EXPR_CONSTANT)
1085 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1088 gfc_set_model (x->value.real);
1090 if (mpfr_sgn (x->value.real) == 0)
1092 mpz_set_ui (result->value.integer, 0);
1096 i = (int) mpfr_get_exp (x->value.real);
1097 mpz_set_si (result->value.integer, i);
1099 return range_check (result, "EXPONENT");
1104 gfc_simplify_float (gfc_expr *a)
1108 if (a->expr_type != EXPR_CONSTANT)
1111 result = gfc_int2real (a, gfc_default_real_kind);
1112 return range_check (result, "FLOAT");
1117 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1123 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1125 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1127 if (e->expr_type != EXPR_CONSTANT)
1130 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1132 gfc_set_model_kind (kind);
1134 mpfr_floor (floor, e->value.real);
1136 gfc_mpfr_to_mpz (result->value.integer, floor);
1140 return range_check (result, "FLOOR");
1145 gfc_simplify_fraction (gfc_expr *x)
1148 mpfr_t absv, exp, pow2;
1150 if (x->expr_type != EXPR_CONSTANT)
1153 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1155 gfc_set_model_kind (x->ts.kind);
1157 if (mpfr_sgn (x->value.real) == 0)
1159 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1167 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1168 mpfr_log2 (exp, absv, GFC_RND_MODE);
1170 mpfr_trunc (exp, exp);
1171 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1173 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1175 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1181 return range_check (result, "FRACTION");
1186 gfc_simplify_gamma (gfc_expr *x)
1190 if (x->expr_type != EXPR_CONSTANT)
1193 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1195 gfc_set_model_kind (x->ts.kind);
1197 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1199 return range_check (result, "GAMMA");
1204 gfc_simplify_huge (gfc_expr *e)
1209 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1211 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1216 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1220 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1230 /* We use the processor's collating sequence, because all
1231 systems that gfortran currently works on are ASCII. */
1234 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
1239 if (e->expr_type != EXPR_CONSTANT)
1242 if (e->value.character.length != 1)
1244 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1245 return &gfc_bad_expr;
1248 index = (unsigned char) e->value.character.string[0];
1250 if (gfc_option.warn_surprising && index > 127)
1251 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1254 if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
1255 return &gfc_bad_expr;
1257 result->where = e->where;
1259 return range_check (result, "IACHAR");
1264 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1268 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1271 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1273 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1275 return range_check (result, "IAND");
1280 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1285 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1288 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1290 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1291 return &gfc_bad_expr;
1294 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1296 if (pos >= gfc_integer_kinds[k].bit_size)
1298 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1300 return &gfc_bad_expr;
1303 result = gfc_copy_expr (x);
1305 convert_mpz_to_unsigned (result->value.integer,
1306 gfc_integer_kinds[k].bit_size);
1308 mpz_clrbit (result->value.integer, pos);
1310 convert_mpz_to_signed (result->value.integer,
1311 gfc_integer_kinds[k].bit_size);
1313 return range_check (result, "IBCLR");
1318 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1325 if (x->expr_type != EXPR_CONSTANT
1326 || y->expr_type != EXPR_CONSTANT
1327 || z->expr_type != EXPR_CONSTANT)
1330 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1332 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1333 return &gfc_bad_expr;
1336 if (gfc_extract_int (z, &len) != NULL || len < 0)
1338 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1339 return &gfc_bad_expr;
1342 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1344 bitsize = gfc_integer_kinds[k].bit_size;
1346 if (pos + len > bitsize)
1348 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1349 "bit size at %L", &y->where);
1350 return &gfc_bad_expr;
1353 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1355 bits = gfc_getmem (bitsize * sizeof (int));
1357 for (i = 0; i < bitsize; i++)
1360 for (i = 0; i < len; i++)
1361 bits[i] = mpz_tstbit (x->value.integer, i + pos);
1363 for (i = 0; i < bitsize; i++)
1366 mpz_clrbit (result->value.integer, i);
1367 else if (bits[i] == 1)
1368 mpz_setbit (result->value.integer, i);
1370 gfc_internal_error ("IBITS: Bad bit");
1375 return range_check (result, "IBITS");
1380 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1385 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1388 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1390 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1391 return &gfc_bad_expr;
1394 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1396 if (pos >= gfc_integer_kinds[k].bit_size)
1398 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1400 return &gfc_bad_expr;
1403 result = gfc_copy_expr (x);
1405 convert_mpz_to_unsigned (result->value.integer,
1406 gfc_integer_kinds[k].bit_size);
1408 mpz_setbit (result->value.integer, pos);
1410 convert_mpz_to_signed (result->value.integer,
1411 gfc_integer_kinds[k].bit_size);
1413 return range_check (result, "IBSET");
1418 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
1423 if (e->expr_type != EXPR_CONSTANT)
1426 if (e->value.character.length != 1)
1428 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1429 return &gfc_bad_expr;
1432 index = (unsigned char) e->value.character.string[0];
1434 if (index < 0 || index > UCHAR_MAX)
1435 gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
1437 if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
1438 return &gfc_bad_expr;
1440 result->where = e->where;
1441 return range_check (result, "ICHAR");
1446 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
1450 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1453 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1455 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1457 return range_check (result, "IEOR");
1462 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
1465 int back, len, lensub;
1466 int i, j, k, count, index = 0, start;
1468 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1471 if (b != NULL && b->value.logical != 0)
1476 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
1478 return &gfc_bad_expr;
1480 result = gfc_constant_result (BT_INTEGER, k, &x->where);
1482 len = x->value.character.length;
1483 lensub = y->value.character.length;
1487 mpz_set_si (result->value.integer, 0);
1495 mpz_set_si (result->value.integer, 1);
1498 else if (lensub == 1)
1500 for (i = 0; i < len; i++)
1502 for (j = 0; j < lensub; j++)
1504 if (y->value.character.string[j]
1505 == x->value.character.string[i])
1515 for (i = 0; i < len; i++)
1517 for (j = 0; j < lensub; j++)
1519 if (y->value.character.string[j]
1520 == x->value.character.string[i])
1525 for (k = 0; k < lensub; k++)
1527 if (y->value.character.string[k]
1528 == x->value.character.string[k + start])
1532 if (count == lensub)
1547 mpz_set_si (result->value.integer, len + 1);
1550 else if (lensub == 1)
1552 for (i = 0; i < len; i++)
1554 for (j = 0; j < lensub; j++)
1556 if (y->value.character.string[j]
1557 == x->value.character.string[len - i])
1559 index = len - i + 1;
1567 for (i = 0; i < len; i++)
1569 for (j = 0; j < lensub; j++)
1571 if (y->value.character.string[j]
1572 == x->value.character.string[len - i])
1575 if (start <= len - lensub)
1578 for (k = 0; k < lensub; k++)
1579 if (y->value.character.string[k]
1580 == x->value.character.string[k + start])
1583 if (count == lensub)
1600 mpz_set_si (result->value.integer, index);
1601 return range_check (result, "INDEX");
1606 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
1608 gfc_expr *rpart, *rtrunc, *result;
1611 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1613 return &gfc_bad_expr;
1615 if (e->expr_type != EXPR_CONSTANT)
1618 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1623 mpz_set (result->value.integer, e->value.integer);
1627 rtrunc = gfc_copy_expr (e);
1628 mpfr_trunc (rtrunc->value.real, e->value.real);
1629 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1630 gfc_free_expr (rtrunc);
1634 rpart = gfc_complex2real (e, kind);
1635 rtrunc = gfc_copy_expr (rpart);
1636 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1637 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1638 gfc_free_expr (rpart);
1639 gfc_free_expr (rtrunc);
1643 gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1644 gfc_free_expr (result);
1645 return &gfc_bad_expr;
1648 return range_check (result, "INT");
1653 gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
1655 gfc_expr *rpart, *rtrunc, *result;
1657 if (e->expr_type != EXPR_CONSTANT)
1660 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1665 mpz_set (result->value.integer, e->value.integer);
1669 rtrunc = gfc_copy_expr (e);
1670 mpfr_trunc (rtrunc->value.real, e->value.real);
1671 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1672 gfc_free_expr (rtrunc);
1676 rpart = gfc_complex2real (e, kind);
1677 rtrunc = gfc_copy_expr (rpart);
1678 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1679 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1680 gfc_free_expr (rpart);
1681 gfc_free_expr (rtrunc);
1685 gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
1686 gfc_free_expr (result);
1687 return &gfc_bad_expr;
1690 return range_check (result, name);
1695 gfc_simplify_int2 (gfc_expr *e)
1697 return gfc_simplify_intconv (e, 2, "INT2");
1702 gfc_simplify_int8 (gfc_expr *e)
1704 return gfc_simplify_intconv (e, 8, "INT8");
1709 gfc_simplify_long (gfc_expr *e)
1711 return gfc_simplify_intconv (e, 4, "LONG");
1716 gfc_simplify_ifix (gfc_expr *e)
1718 gfc_expr *rtrunc, *result;
1720 if (e->expr_type != EXPR_CONSTANT)
1723 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1726 rtrunc = gfc_copy_expr (e);
1728 mpfr_trunc (rtrunc->value.real, e->value.real);
1729 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1731 gfc_free_expr (rtrunc);
1732 return range_check (result, "IFIX");
1737 gfc_simplify_idint (gfc_expr *e)
1739 gfc_expr *rtrunc, *result;
1741 if (e->expr_type != EXPR_CONSTANT)
1744 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1747 rtrunc = gfc_copy_expr (e);
1749 mpfr_trunc (rtrunc->value.real, e->value.real);
1750 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1752 gfc_free_expr (rtrunc);
1753 return range_check (result, "IDINT");
1758 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
1762 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1765 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1767 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1768 return range_check (result, "IOR");
1773 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
1776 int shift, ashift, isize, k, *bits, i;
1778 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1781 if (gfc_extract_int (s, &shift) != NULL)
1783 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
1784 return &gfc_bad_expr;
1787 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
1789 isize = gfc_integer_kinds[k].bit_size;
1798 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
1799 "at %L", &s->where);
1800 return &gfc_bad_expr;
1803 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1807 mpz_set (result->value.integer, e->value.integer);
1808 return range_check (result, "ISHFT");
1811 bits = gfc_getmem (isize * sizeof (int));
1813 for (i = 0; i < isize; i++)
1814 bits[i] = mpz_tstbit (e->value.integer, i);
1818 for (i = 0; i < shift; i++)
1819 mpz_clrbit (result->value.integer, i);
1821 for (i = 0; i < isize - shift; i++)
1824 mpz_clrbit (result->value.integer, i + shift);
1826 mpz_setbit (result->value.integer, i + shift);
1831 for (i = isize - 1; i >= isize - ashift; i--)
1832 mpz_clrbit (result->value.integer, i);
1834 for (i = isize - 1; i >= ashift; i--)
1837 mpz_clrbit (result->value.integer, i - ashift);
1839 mpz_setbit (result->value.integer, i - ashift);
1843 convert_mpz_to_signed (result->value.integer, isize);
1851 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
1854 int shift, ashift, isize, ssize, delta, k;
1857 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1860 if (gfc_extract_int (s, &shift) != NULL)
1862 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
1863 return &gfc_bad_expr;
1866 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1867 isize = gfc_integer_kinds[k].bit_size;
1871 if (sz->expr_type != EXPR_CONSTANT)
1874 if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
1876 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
1877 return &gfc_bad_expr;
1882 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
1883 "BIT_SIZE of first argument at %L", &s->where);
1884 return &gfc_bad_expr;
1898 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1899 "third argument at %L", &s->where);
1901 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1902 "BIT_SIZE of first argument at %L", &s->where);
1903 return &gfc_bad_expr;
1906 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1908 mpz_set (result->value.integer, e->value.integer);
1913 convert_mpz_to_unsigned (result->value.integer, isize);
1915 bits = gfc_getmem (ssize * sizeof (int));
1917 for (i = 0; i < ssize; i++)
1918 bits[i] = mpz_tstbit (e->value.integer, i);
1920 delta = ssize - ashift;
1924 for (i = 0; i < delta; i++)
1927 mpz_clrbit (result->value.integer, i + shift);
1929 mpz_setbit (result->value.integer, i + shift);
1932 for (i = delta; i < ssize; i++)
1935 mpz_clrbit (result->value.integer, i - delta);
1937 mpz_setbit (result->value.integer, i - delta);
1942 for (i = 0; i < ashift; i++)
1945 mpz_clrbit (result->value.integer, i + delta);
1947 mpz_setbit (result->value.integer, i + delta);
1950 for (i = ashift; i < ssize; i++)
1953 mpz_clrbit (result->value.integer, i + shift);
1955 mpz_setbit (result->value.integer, i + shift);
1959 convert_mpz_to_signed (result->value.integer, isize);
1967 gfc_simplify_kind (gfc_expr *e)
1970 if (e->ts.type == BT_DERIVED)
1972 gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
1973 return &gfc_bad_expr;
1976 return gfc_int_expr (e->ts.kind);
1981 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
1984 gfc_expr *l, *u, *result;
1987 /* The last dimension of an assumed-size array is special. */
1988 if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
1990 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
1991 return gfc_copy_expr (as->lower[d-1]);
1996 /* Then, we need to know the extent of the given dimension. */
2000 if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
2003 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2004 gfc_default_integer_kind);
2006 return &gfc_bad_expr;
2008 result = gfc_constant_result (BT_INTEGER, k, &array->where);
2010 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2014 mpz_set_si (result->value.integer, 0);
2016 mpz_set_si (result->value.integer, 1);
2020 /* Nonzero extent. */
2022 mpz_set (result->value.integer, u->value.integer);
2024 mpz_set (result->value.integer, l->value.integer);
2027 return range_check (result, upper ? "UBOUND" : "LBOUND");
2032 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2038 if (array->expr_type != EXPR_VARIABLE)
2041 /* Follow any component references. */
2042 as = array->symtree->n.sym->as;
2043 for (ref = array->ref; ref; ref = ref->next)
2048 switch (ref->u.ar.type)
2055 /* We're done because 'as' has already been set in the
2056 previous iteration. */
2067 as = ref->u.c.component->as;
2079 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2084 /* Multi-dimensional bounds. */
2085 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2087 gfc_constructor *head, *tail;
2090 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2091 if (upper && as->type == AS_ASSUMED_SIZE)
2093 /* An error message will be emitted in
2094 check_assumed_size_reference (resolve.c). */
2095 return &gfc_bad_expr;
2098 /* Simplify the bounds for each dimension. */
2099 for (d = 0; d < array->rank; d++)
2101 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
2102 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2106 for (j = 0; j < d; j++)
2107 gfc_free_expr (bounds[j]);
2112 /* Allocate the result expression. */
2113 e = gfc_get_expr ();
2114 e->where = array->where;
2115 e->expr_type = EXPR_ARRAY;
2116 e->ts.type = BT_INTEGER;
2117 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2118 gfc_default_integer_kind);
2120 return &gfc_bad_expr;
2123 /* The result is a rank 1 array; its size is the rank of the first
2124 argument to {L,U}BOUND. */
2126 e->shape = gfc_get_shape (1);
2127 mpz_init_set_ui (e->shape[0], array->rank);
2129 /* Create the constructor for this array. */
2131 for (d = 0; d < array->rank; d++)
2133 /* Get a new constructor element. */
2135 head = tail = gfc_get_constructor ();
2138 tail->next = gfc_get_constructor ();
2142 tail->where = e->where;
2143 tail->expr = bounds[d];
2145 e->value.constructor = head;
2151 /* A DIM argument is specified. */
2152 if (dim->expr_type != EXPR_CONSTANT)
2155 d = mpz_get_si (dim->value.integer);
2157 if (d < 1 || d > as->rank
2158 || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2160 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2161 return &gfc_bad_expr;
2164 return simplify_bound_dim (array, kind, d, upper, as);
2170 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2172 return simplify_bound (array, dim, kind, 0);
2177 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
2180 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
2183 return &gfc_bad_expr;
2185 if (e->expr_type == EXPR_CONSTANT)
2187 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2188 mpz_set_si (result->value.integer, e->value.character.length);
2189 return range_check (result, "LEN");
2192 if (e->ts.cl != NULL && e->ts.cl->length != NULL
2193 && e->ts.cl->length->expr_type == EXPR_CONSTANT
2194 && e->ts.cl->length->ts.type == BT_INTEGER)
2196 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2197 mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2198 return range_check (result, "LEN");
2206 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
2209 int count, len, lentrim, i;
2210 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
2213 return &gfc_bad_expr;
2215 if (e->expr_type != EXPR_CONSTANT)
2218 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2219 len = e->value.character.length;
2221 for (count = 0, i = 1; i <= len; i++)
2222 if (e->value.character.string[len - i] == ' ')
2227 lentrim = len - count;
2229 mpz_set_si (result->value.integer, lentrim);
2230 return range_check (result, "LEN_TRIM");
2234 gfc_simplify_lgamma (gfc_expr *x __attribute__((unused)))
2236 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
2239 if (x->expr_type != EXPR_CONSTANT)
2242 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2244 gfc_set_model_kind (x->ts.kind);
2246 mpfr_lgamma (result->value.real, x->value.real, GFC_RND_MODE);
2248 return range_check (result, "LGAMMA");
2256 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
2258 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2261 return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
2266 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
2268 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2271 return gfc_logical_expr (gfc_compare_string (a, b) > 0,
2277 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
2279 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2282 return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
2287 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
2289 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2292 return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
2297 gfc_simplify_log (gfc_expr *x)
2302 if (x->expr_type != EXPR_CONSTANT)
2305 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2307 gfc_set_model_kind (x->ts.kind);
2312 if (mpfr_sgn (x->value.real) <= 0)
2314 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2315 "to zero", &x->where);
2316 gfc_free_expr (result);
2317 return &gfc_bad_expr;
2320 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
2324 if ((mpfr_sgn (x->value.complex.r) == 0)
2325 && (mpfr_sgn (x->value.complex.i) == 0))
2327 gfc_error ("Complex argument of LOG at %L cannot be zero",
2329 gfc_free_expr (result);
2330 return &gfc_bad_expr;
2336 mpfr_atan2 (result->value.complex.i, x->value.complex.i,
2337 x->value.complex.r, GFC_RND_MODE);
2339 mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2340 mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2341 mpfr_add (xr, xr, xi, GFC_RND_MODE);
2342 mpfr_sqrt (xr, xr, GFC_RND_MODE);
2343 mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2351 gfc_internal_error ("gfc_simplify_log: bad type");
2354 return range_check (result, "LOG");
2359 gfc_simplify_log10 (gfc_expr *x)
2363 if (x->expr_type != EXPR_CONSTANT)
2366 gfc_set_model_kind (x->ts.kind);
2368 if (mpfr_sgn (x->value.real) <= 0)
2370 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2371 "to zero", &x->where);
2372 return &gfc_bad_expr;
2375 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2377 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2379 return range_check (result, "LOG10");
2384 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
2389 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2391 return &gfc_bad_expr;
2393 if (e->expr_type != EXPR_CONSTANT)
2396 result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2398 result->value.logical = e->value.logical;
2404 /* This function is special since MAX() can take any number of
2405 arguments. The simplified expression is a rewritten version of the
2406 argument list containing at most one constant element. Other
2407 constant elements are deleted. Because the argument list has
2408 already been checked, this function always succeeds. sign is 1 for
2409 MAX(), -1 for MIN(). */
2412 simplify_min_max (gfc_expr *expr, int sign)
2414 gfc_actual_arglist *arg, *last, *extremum;
2415 gfc_intrinsic_sym * specific;
2419 specific = expr->value.function.isym;
2421 arg = expr->value.function.actual;
2423 for (; arg; last = arg, arg = arg->next)
2425 if (arg->expr->expr_type != EXPR_CONSTANT)
2428 if (extremum == NULL)
2434 switch (arg->expr->ts.type)
2437 if (mpz_cmp (arg->expr->value.integer,
2438 extremum->expr->value.integer) * sign > 0)
2439 mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2443 if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real)
2445 mpfr_set (extremum->expr->value.real, arg->expr->value.real,
2450 #define LENGTH(x) ((x)->expr->value.character.length)
2451 #define STRING(x) ((x)->expr->value.character.string)
2452 if (LENGTH(extremum) < LENGTH(arg))
2454 char * tmp = STRING(extremum);
2456 STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
2457 memcpy (STRING(extremum), tmp, LENGTH(extremum));
2458 memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2459 LENGTH(arg) - LENGTH(extremum));
2460 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
2461 LENGTH(extremum) = LENGTH(arg);
2465 if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
2467 gfc_free (STRING(extremum));
2468 STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
2469 memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
2470 memset (&STRING(extremum)[LENGTH(arg)], ' ',
2471 LENGTH(extremum) - LENGTH(arg));
2472 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
2480 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2483 /* Delete the extra constant argument. */
2485 expr->value.function.actual = arg->next;
2487 last->next = arg->next;
2490 gfc_free_actual_arglist (arg);
2494 /* If there is one value left, replace the function call with the
2496 if (expr->value.function.actual->next != NULL)
2499 /* Convert to the correct type and kind. */
2500 if (expr->ts.type != BT_UNKNOWN)
2501 return gfc_convert_constant (expr->value.function.actual->expr,
2502 expr->ts.type, expr->ts.kind);
2504 if (specific->ts.type != BT_UNKNOWN)
2505 return gfc_convert_constant (expr->value.function.actual->expr,
2506 specific->ts.type, specific->ts.kind);
2508 return gfc_copy_expr (expr->value.function.actual->expr);
2513 gfc_simplify_min (gfc_expr *e)
2515 return simplify_min_max (e, -1);
2520 gfc_simplify_max (gfc_expr *e)
2522 return simplify_min_max (e, 1);
2527 gfc_simplify_maxexponent (gfc_expr *x)
2532 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2534 result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2535 result->where = x->where;
2542 gfc_simplify_minexponent (gfc_expr *x)
2547 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2549 result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2550 result->where = x->where;
2557 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2560 mpfr_t quot, iquot, term;
2563 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2566 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2567 result = gfc_constant_result (a->ts.type, kind, &a->where);
2572 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2574 /* Result is processor-dependent. */
2575 gfc_error ("Second argument MOD at %L is zero", &a->where);
2576 gfc_free_expr (result);
2577 return &gfc_bad_expr;
2579 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2583 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2585 /* Result is processor-dependent. */
2586 gfc_error ("Second argument of MOD at %L is zero", &p->where);
2587 gfc_free_expr (result);
2588 return &gfc_bad_expr;
2591 gfc_set_model_kind (kind);
2596 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2597 mpfr_trunc (iquot, quot);
2598 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2599 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2607 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2610 return range_check (result, "MOD");
2615 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2618 mpfr_t quot, iquot, term;
2621 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2624 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2625 result = gfc_constant_result (a->ts.type, kind, &a->where);
2630 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2632 /* Result is processor-dependent. This processor just opts
2633 to not handle it at all. */
2634 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2635 gfc_free_expr (result);
2636 return &gfc_bad_expr;
2638 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2643 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2645 /* Result is processor-dependent. */
2646 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2647 gfc_free_expr (result);
2648 return &gfc_bad_expr;
2651 gfc_set_model_kind (kind);
2656 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2657 mpfr_floor (iquot, quot);
2658 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2659 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2667 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2670 return range_check (result, "MODULO");
2674 /* Exists for the sole purpose of consistency with other intrinsics. */
2676 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
2677 gfc_expr *fp ATTRIBUTE_UNUSED,
2678 gfc_expr *l ATTRIBUTE_UNUSED,
2679 gfc_expr *to ATTRIBUTE_UNUSED,
2680 gfc_expr *tp ATTRIBUTE_UNUSED)
2687 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
2693 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2696 if (mpfr_sgn (s->value.real) == 0)
2698 gfc_error ("Second argument of NEAREST at %L shall not be zero",
2700 return &gfc_bad_expr;
2703 gfc_set_model_kind (x->ts.kind);
2704 result = gfc_copy_expr (x);
2706 sgn = mpfr_sgn (s->value.real);
2708 mpfr_set_inf (tmp, sgn);
2709 mpfr_nexttoward (result->value.real, tmp);
2712 return range_check (result, "NEAREST");
2717 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
2719 gfc_expr *itrunc, *result;
2722 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2724 return &gfc_bad_expr;
2726 if (e->expr_type != EXPR_CONSTANT)
2729 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2731 itrunc = gfc_copy_expr (e);
2733 mpfr_round (itrunc->value.real, e->value.real);
2735 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
2737 gfc_free_expr (itrunc);
2739 return range_check (result, name);
2744 gfc_simplify_new_line (gfc_expr *e)
2748 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2749 result->value.character.string = gfc_getmem (2);
2750 result->value.character.length = 1;
2751 result->value.character.string[0] = '\n';
2752 result->value.character.string[1] = '\0'; /* For debugger */
2758 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
2760 return simplify_nint ("NINT", e, k);
2765 gfc_simplify_idnint (gfc_expr *e)
2767 return simplify_nint ("IDNINT", e, NULL);
2772 gfc_simplify_not (gfc_expr *e)
2776 if (e->expr_type != EXPR_CONSTANT)
2779 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2781 mpz_com (result->value.integer, e->value.integer);
2783 return range_check (result, "NOT");
2788 gfc_simplify_null (gfc_expr *mold)
2794 result = gfc_get_expr ();
2795 result->ts.type = BT_UNKNOWN;
2798 result = gfc_copy_expr (mold);
2799 result->expr_type = EXPR_NULL;
2806 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
2811 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2814 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2815 if (x->ts.type == BT_INTEGER)
2817 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
2818 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2820 else /* BT_LOGICAL */
2822 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
2823 result->value.logical = x->value.logical || y->value.logical;
2826 return range_check (result, "OR");
2831 gfc_simplify_precision (gfc_expr *e)
2836 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2838 result = gfc_int_expr (gfc_real_kinds[i].precision);
2839 result->where = e->where;
2846 gfc_simplify_radix (gfc_expr *e)
2851 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2855 i = gfc_integer_kinds[i].radix;
2859 i = gfc_real_kinds[i].radix;
2866 result = gfc_int_expr (i);
2867 result->where = e->where;
2874 gfc_simplify_range (gfc_expr *e)
2880 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2885 j = gfc_integer_kinds[i].range;
2890 j = gfc_real_kinds[i].range;
2897 result = gfc_int_expr (j);
2898 result->where = e->where;
2905 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
2910 if (e->ts.type == BT_COMPLEX)
2911 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
2913 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
2916 return &gfc_bad_expr;
2918 if (e->expr_type != EXPR_CONSTANT)
2924 result = gfc_int2real (e, kind);
2928 result = gfc_real2real (e, kind);
2932 result = gfc_complex2real (e, kind);
2936 gfc_internal_error ("bad type in REAL");
2940 return range_check (result, "REAL");
2945 gfc_simplify_realpart (gfc_expr *e)
2949 if (e->expr_type != EXPR_CONSTANT)
2952 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
2953 mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
2955 return range_check (result, "REALPART");
2959 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
2962 int i, j, len, ncop, nlen;
2964 bool have_length = false;
2966 /* If NCOPIES isn't a constant, there's nothing we can do. */
2967 if (n->expr_type != EXPR_CONSTANT)
2970 /* If NCOPIES is negative, it's an error. */
2971 if (mpz_sgn (n->value.integer) < 0)
2973 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
2975 return &gfc_bad_expr;
2978 /* If we don't know the character length, we can do no more. */
2979 if (e->ts.cl && e->ts.cl->length
2980 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
2982 len = mpz_get_si (e->ts.cl->length->value.integer);
2985 else if (e->expr_type == EXPR_CONSTANT
2986 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
2988 len = e->value.character.length;
2993 /* If the source length is 0, any value of NCOPIES is valid
2994 and everything behaves as if NCOPIES == 0. */
2997 mpz_set_ui (ncopies, 0);
2999 mpz_set (ncopies, n->value.integer);
3001 /* Check that NCOPIES isn't too large. */
3007 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
3009 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3013 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
3014 e->ts.cl->length->value.integer);
3018 mpz_init_set_si (mlen, len);
3019 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
3023 /* The check itself. */
3024 if (mpz_cmp (ncopies, max) > 0)
3027 mpz_clear (ncopies);
3028 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3030 return &gfc_bad_expr;
3035 mpz_clear (ncopies);
3037 /* For further simplification, we need the character string to be
3039 if (e->expr_type != EXPR_CONSTANT)
3042 if (len || mpz_sgn (e->ts.cl->length->value.integer) != 0)
3044 const char *res = gfc_extract_int (n, &ncop);
3045 gcc_assert (res == NULL);
3050 len = e->value.character.length;
3053 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3057 result->value.character.string = gfc_getmem (1);
3058 result->value.character.length = 0;
3059 result->value.character.string[0] = '\0';
3063 result->value.character.length = nlen;
3064 result->value.character.string = gfc_getmem (nlen + 1);
3066 for (i = 0; i < ncop; i++)
3067 for (j = 0; j < len; j++)
3068 result->value.character.string[j + i * len]
3069 = e->value.character.string[j];
3071 result->value.character.string[nlen] = '\0'; /* For debugger */
3076 /* This one is a bear, but mainly has to do with shuffling elements. */
3079 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3080 gfc_expr *pad, gfc_expr *order_exp)
3082 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3083 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3084 gfc_constructor *head, *tail;
3090 /* Unpack the shape array. */
3091 if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
3094 if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
3098 && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
3101 if (order_exp != NULL
3102 && (order_exp->expr_type != EXPR_ARRAY
3103 || !gfc_is_constant_expr (order_exp)))
3112 e = gfc_get_array_element (shape_exp, rank);
3116 if (gfc_extract_int (e, &shape[rank]) != NULL)
3118 gfc_error ("Integer too large in shape specification at %L",
3126 if (rank >= GFC_MAX_DIMENSIONS)
3128 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3129 "at %L", &e->where);
3134 if (shape[rank] < 0)
3136 gfc_error ("Shape specification at %L cannot be negative",
3146 gfc_error ("Shape specification at %L cannot be the null array",
3151 /* Now unpack the order array if present. */
3152 if (order_exp == NULL)
3154 for (i = 0; i < rank; i++)
3159 for (i = 0; i < rank; i++)
3162 for (i = 0; i < rank; i++)
3164 e = gfc_get_array_element (order_exp, i);
3167 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3168 "size as SHAPE parameter", &order_exp->where);
3172 if (gfc_extract_int (e, &order[i]) != NULL)
3174 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3182 if (order[i] < 1 || order[i] > rank)
3184 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3193 gfc_error ("Invalid permutation in ORDER parameter at %L",
3202 /* Count the elements in the source and padding arrays. */
3207 gfc_array_size (pad, &size);
3208 npad = mpz_get_ui (size);
3212 gfc_array_size (source, &size);
3213 nsource = mpz_get_ui (size);
3216 /* If it weren't for that pesky permutation we could just loop
3217 through the source and round out any shortage with pad elements.
3218 But no, someone just had to have the compiler do something the
3219 user should be doing. */
3221 for (i = 0; i < rank; i++)
3226 /* Figure out which element to extract. */
3227 mpz_set_ui (index, 0);
3229 for (i = rank - 1; i >= 0; i--)
3231 mpz_add_ui (index, index, x[order[i]]);
3233 mpz_mul_ui (index, index, shape[order[i - 1]]);
3236 if (mpz_cmp_ui (index, INT_MAX) > 0)
3237 gfc_internal_error ("Reshaped array too large at %L", &e->where);
3239 j = mpz_get_ui (index);
3242 e = gfc_get_array_element (source, j);
3249 gfc_error ("PAD parameter required for short SOURCE parameter "
3250 "at %L", &source->where);
3255 e = gfc_get_array_element (pad, j);
3259 head = tail = gfc_get_constructor ();
3262 tail->next = gfc_get_constructor ();
3269 tail->where = e->where;
3272 /* Calculate the next element. */
3276 if (++x[i] < shape[i])
3287 e = gfc_get_expr ();
3288 e->where = source->where;
3289 e->expr_type = EXPR_ARRAY;
3290 e->value.constructor = head;
3291 e->shape = gfc_get_shape (rank);
3293 for (i = 0; i < rank; i++)
3294 mpz_init_set_ui (e->shape[i], shape[i]);
3302 gfc_free_constructor (head);
3304 return &gfc_bad_expr;
3309 gfc_simplify_rrspacing (gfc_expr *x)
3315 if (x->expr_type != EXPR_CONSTANT)
3318 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3320 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3322 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3324 /* Special case x = -0 and 0. */
3325 if (mpfr_sgn (result->value.real) == 0)
3327 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3331 /* | x * 2**(-e) | * 2**p. */
3332 e = - (long int) mpfr_get_exp (x->value.real);
3333 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3335 p = (long int) gfc_real_kinds[i].digits;
3336 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3338 return range_check (result, "RRSPACING");
3343 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3345 int k, neg_flag, power, exp_range;
3346 mpfr_t scale, radix;
3349 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3352 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3354 if (mpfr_sgn (x->value.real) == 0)
3356 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3360 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3362 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3364 /* This check filters out values of i that would overflow an int. */
3365 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3366 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3368 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3369 return &gfc_bad_expr;
3372 /* Compute scale = radix ** power. */
3373 power = mpz_get_si (i->value.integer);
3383 gfc_set_model_kind (x->ts.kind);
3386 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3387 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3390 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3392 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3397 return range_check (result, "SCALE");
3402 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
3407 size_t indx, len, lenc;
3408 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3411 return &gfc_bad_expr;
3413 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3416 if (b != NULL && b->value.logical != 0)
3421 result = gfc_constant_result (BT_INTEGER, k, &e->where);
3423 len = e->value.character.length;
3424 lenc = c->value.character.length;
3426 if (len == 0 || lenc == 0)
3434 indx = strcspn (e->value.character.string, c->value.character.string)
3442 for (indx = len; indx > 0; indx--)
3444 for (i = 0; i < lenc; i++)
3446 if (c->value.character.string[i]
3447 == e->value.character.string[indx - 1])
3455 mpz_set_ui (result->value.integer, indx);
3456 return range_check (result, "SCAN");
3461 gfc_simplify_selected_int_kind (gfc_expr *e)
3466 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3471 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3472 if (gfc_integer_kinds[i].range >= range
3473 && gfc_integer_kinds[i].kind < kind)
3474 kind = gfc_integer_kinds[i].kind;
3476 if (kind == INT_MAX)
3479 result = gfc_int_expr (kind);
3480 result->where = e->where;
3487 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3489 int range, precision, i, kind, found_precision, found_range;
3496 if (p->expr_type != EXPR_CONSTANT
3497 || gfc_extract_int (p, &precision) != NULL)
3505 if (q->expr_type != EXPR_CONSTANT
3506 || gfc_extract_int (q, &range) != NULL)
3511 found_precision = 0;
3514 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3516 if (gfc_real_kinds[i].precision >= precision)
3517 found_precision = 1;
3519 if (gfc_real_kinds[i].range >= range)
3522 if (gfc_real_kinds[i].precision >= precision
3523 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3524 kind = gfc_real_kinds[i].kind;
3527 if (kind == INT_MAX)
3531 if (!found_precision)
3537 result = gfc_int_expr (kind);
3538 result->where = (p != NULL) ? p->where : q->where;
3545 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3548 mpfr_t exp, absv, log2, pow2, frac;
3551 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3554 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3556 gfc_set_model_kind (x->ts.kind);
3558 if (mpfr_sgn (x->value.real) == 0)
3560 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3570 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3571 mpfr_log2 (log2, absv, GFC_RND_MODE);
3573 mpfr_trunc (log2, log2);
3574 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3576 /* Old exponent value, and fraction. */
3577 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3579 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3582 exp2 = (unsigned long) mpz_get_d (i->value.integer);
3583 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3590 return range_check (result, "SET_EXPONENT");
3595 gfc_simplify_shape (gfc_expr *source)
3597 mpz_t shape[GFC_MAX_DIMENSIONS];
3598 gfc_expr *result, *e, *f;
3603 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3606 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3609 ar = gfc_find_array_ref (source);
3611 t = gfc_array_ref_shape (ar, shape);
3613 for (n = 0; n < source->rank; n++)
3615 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3620 mpz_set (e->value.integer, shape[n]);
3621 mpz_clear (shape[n]);
3625 mpz_set_ui (e->value.integer, n + 1);
3627 f = gfc_simplify_size (source, e, NULL);
3631 gfc_free_expr (result);
3640 gfc_append_constructor (result, e);
3648 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3653 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3656 return &gfc_bad_expr;
3660 if (gfc_array_size (array, &size) == FAILURE)
3665 if (dim->expr_type != EXPR_CONSTANT)
3668 d = mpz_get_ui (dim->value.integer) - 1;
3669 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3673 result = gfc_constant_result (BT_INTEGER, k, &array->where);
3674 mpz_set (result->value.integer, size);
3680 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
3684 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3687 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3692 mpz_abs (result->value.integer, x->value.integer);
3693 if (mpz_sgn (y->value.integer) < 0)
3694 mpz_neg (result->value.integer, result->value.integer);
3699 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3701 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3702 if (mpfr_sgn (y->value.real) < 0)
3703 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3708 gfc_internal_error ("Bad type in gfc_simplify_sign");
3716 gfc_simplify_sin (gfc_expr *x)
3721 if (x->expr_type != EXPR_CONSTANT)
3724 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3729 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3733 gfc_set_model (x->value.real);
3737 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
3738 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3739 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3741 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
3742 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3743 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3750 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3753 return range_check (result, "SIN");
3758 gfc_simplify_sinh (gfc_expr *x)
3762 if (x->expr_type != EXPR_CONSTANT)
3765 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3767 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
3769 return range_check (result, "SINH");
3773 /* The argument is always a double precision real that is converted to
3774 single precision. TODO: Rounding! */
3777 gfc_simplify_sngl (gfc_expr *a)
3781 if (a->expr_type != EXPR_CONSTANT)
3784 result = gfc_real2real (a, gfc_default_real_kind);
3785 return range_check (result, "SNGL");
3790 gfc_simplify_spacing (gfc_expr *x)
3796 if (x->expr_type != EXPR_CONSTANT)
3799 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3801 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3803 /* Special case x = 0 and -0. */
3804 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3805 if (mpfr_sgn (result->value.real) == 0)
3807 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3811 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3812 are the radix, exponent of x, and precision. This excludes the
3813 possibility of subnormal numbers. Fortran 2003 states the result is
3814 b**max(e - p, emin - 1). */
3816 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
3817 en = (long int) gfc_real_kinds[i].min_exponent - 1;
3818 en = en > ep ? en : ep;
3820 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3821 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
3823 return range_check (result, "SPACING");
3828 gfc_simplify_sqrt (gfc_expr *e)
3831 mpfr_t ac, ad, s, t, w;
3833 if (e->expr_type != EXPR_CONSTANT)
3836 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3841 if (mpfr_cmp_si (e->value.real, 0) < 0)
3843 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3848 /* Formula taken from Numerical Recipes to avoid over- and
3851 gfc_set_model (e->value.real);
3858 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3859 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3861 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3862 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3866 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3867 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3869 if (mpfr_cmp (ac, ad) >= 0)
3871 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3872 mpfr_mul (t, t, t, GFC_RND_MODE);
3873 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3874 mpfr_sqrt (t, t, GFC_RND_MODE);
3875 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3876 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3877 mpfr_sqrt (t, t, GFC_RND_MODE);
3878 mpfr_sqrt (s, ac, GFC_RND_MODE);
3879 mpfr_mul (w, s, t, GFC_RND_MODE);
3883 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3884 mpfr_mul (t, s, s, GFC_RND_MODE);
3885 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3886 mpfr_sqrt (t, t, GFC_RND_MODE);
3887 mpfr_abs (s, s, GFC_RND_MODE);
3888 mpfr_add (t, t, s, GFC_RND_MODE);
3889 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3890 mpfr_sqrt (t, t, GFC_RND_MODE);
3891 mpfr_sqrt (s, ad, GFC_RND_MODE);
3892 mpfr_mul (w, s, t, GFC_RND_MODE);
3895 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3897 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3898 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3899 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3901 else if (mpfr_cmp_ui (w, 0) != 0
3902 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3903 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3905 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3906 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3907 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3909 else if (mpfr_cmp_ui (w, 0) != 0
3910 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3911 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
3913 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3914 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
3915 mpfr_neg (w, w, GFC_RND_MODE);
3916 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3919 gfc_internal_error ("invalid complex argument of SQRT at %L",
3931 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
3934 return range_check (result, "SQRT");
3937 gfc_free_expr (result);
3938 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
3939 return &gfc_bad_expr;
3944 gfc_simplify_tan (gfc_expr *x)
3949 if (x->expr_type != EXPR_CONSTANT)
3952 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3954 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3956 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
3958 return range_check (result, "TAN");
3963 gfc_simplify_tanh (gfc_expr *x)
3967 if (x->expr_type != EXPR_CONSTANT)
3970 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3972 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
3974 return range_check (result, "TANH");
3980 gfc_simplify_tiny (gfc_expr *e)
3985 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
3987 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3988 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3995 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
3998 gfc_expr *mold_element;
4001 size_t result_elt_size;
4004 unsigned char *buffer;
4006 if (!gfc_is_constant_expr (source)
4007 || !gfc_is_constant_expr (size))
4010 /* Calculate the size of the source. */
4011 if (source->expr_type == EXPR_ARRAY
4012 && gfc_array_size (source, &tmp) == FAILURE)
4013 gfc_internal_error ("Failure getting length of a constant array.");
4015 source_size = gfc_target_expr_size (source);
4017 /* Create an empty new expression with the appropriate characteristics. */
4018 result = gfc_constant_result (mold->ts.type, mold->ts.kind,
4020 result->ts = mold->ts;
4022 mold_element = mold->expr_type == EXPR_ARRAY
4023 ? mold->value.constructor->expr
4026 /* Set result character length, if needed. Note that this needs to be
4027 set even for array expressions, in order to pass this information into
4028 gfc_target_interpret_expr. */
4029 if (result->ts.type == BT_CHARACTER)
4030 result->value.character.length = mold_element->value.character.length;
4032 /* Set the number of elements in the result, and determine its size. */
4033 result_elt_size = gfc_target_expr_size (mold_element);
4034 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4038 result->expr_type = EXPR_ARRAY;
4042 result_length = (size_t)mpz_get_ui (size->value.integer);
4045 result_length = source_size / result_elt_size;
4046 if (result_length * result_elt_size < source_size)
4050 result->shape = gfc_get_shape (1);
4051 mpz_init_set_ui (result->shape[0], result_length);
4053 result_size = result_length * result_elt_size;
4058 result_size = result_elt_size;
4061 /* Allocate the buffer to store the binary version of the source. */
4062 buffer_size = MAX (source_size, result_size);
4063 buffer = (unsigned char*)alloca (buffer_size);
4065 /* Now write source to the buffer. */
4066 gfc_target_encode_expr (source, buffer, buffer_size);
4068 /* And read the buffer back into the new expression. */
4069 gfc_target_interpret_expr (buffer, buffer_size, result);
4076 gfc_simplify_trim (gfc_expr *e)
4079 int count, i, len, lentrim;
4081 if (e->expr_type != EXPR_CONSTANT)
4084 len = e->value.character.length;
4086 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4088 for (count = 0, i = 1; i <= len; ++i)
4090 if (e->value.character.string[len - i] == ' ')
4096 lentrim = len - count;
4098 result->value.character.length = lentrim;
4099 result->value.character.string = gfc_getmem (lentrim + 1);
4101 for (i = 0; i < lentrim; i++)
4102 result->value.character.string[i] = e->value.character.string[i];
4104 result->value.character.string[lentrim] = '\0'; /* For debugger */
4111 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4113 return simplify_bound (array, dim, kind, 1);
4118 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
4122 size_t index, len, lenset;
4124 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
4127 return &gfc_bad_expr;
4129 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4132 if (b != NULL && b->value.logical != 0)
4137 result = gfc_constant_result (BT_INTEGER, k, &s->where);
4139 len = s->value.character.length;
4140 lenset = set->value.character.length;
4144 mpz_set_ui (result->value.integer, 0);
4152 mpz_set_ui (result->value.integer, 1);
4156 index = strspn (s->value.character.string, set->value.character.string)
4166 mpz_set_ui (result->value.integer, len);
4169 for (index = len; index > 0; index --)
4171 for (i = 0; i < lenset; i++)
4173 if (s->value.character.string[index - 1]
4174 == set->value.character.string[i])
4182 mpz_set_ui (result->value.integer, index);
4188 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4193 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4196 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4197 if (x->ts.type == BT_INTEGER)
4199 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4200 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4202 else /* BT_LOGICAL */
4204 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4205 result->value.logical = (x->value.logical && !y->value.logical)
4206 || (!x->value.logical && y->value.logical);
4209 return range_check (result, "XOR");
4213 /****************** Constant simplification *****************/
4215 /* Master function to convert one constant to another. While this is
4216 used as a simplification function, it requires the destination type
4217 and kind information which is supplied by a special case in
4221 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4223 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4224 gfc_constructor *head, *c, *tail = NULL;
4238 f = gfc_int2complex;
4258 f = gfc_real2complex;
4269 f = gfc_complex2int;
4272 f = gfc_complex2real;
4275 f = gfc_complex2complex;
4301 f = gfc_hollerith2int;
4305 f = gfc_hollerith2real;
4309 f = gfc_hollerith2complex;
4313 f = gfc_hollerith2character;
4317 f = gfc_hollerith2logical;
4327 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4332 switch (e->expr_type)
4335 result = f (e, kind);
4337 return &gfc_bad_expr;
4341 if (!gfc_is_constant_expr (e))
4346 for (c = e->value.constructor; c; c = c->next)
4349 head = tail = gfc_get_constructor ();
4352 tail->next = gfc_get_constructor ();
4356 tail->where = c->where;
4358 if (c->iterator == NULL)
4359 tail->expr = f (c->expr, kind);
4362 g = gfc_convert_constant (c->expr, type, kind);
4363 if (g == &gfc_bad_expr)
4368 if (tail->expr == NULL)
4370 gfc_free_constructor (head);
4375 result = gfc_get_expr ();
4376 result->ts.type = type;
4377 result->ts.kind = kind;
4378 result->expr_type = EXPR_ARRAY;
4379 result->value.constructor = head;
4380 result->shape = gfc_copy_shape (e->shape, e->rank);
4381 result->where = e->where;
4382 result->rank = e->rank;