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);
122 if (gfc_extract_int (k, &kind) != NULL
123 || gfc_validate_kind (type, kind, true) < 0)
126 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
134 /* Converts an mpz_t signed variable into an unsigned one, assuming
135 two's complement representations and a binary width of bitsize.
136 The conversion is a no-op unless x is negative; otherwise, it can
137 be accomplished by masking out the high bits. */
140 convert_mpz_to_unsigned (mpz_t x, int bitsize)
146 /* Confirm that no bits above the signed range are unset. */
147 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
149 mpz_init_set_ui (mask, 1);
150 mpz_mul_2exp (mask, mask, bitsize);
151 mpz_sub_ui (mask, mask, 1);
153 mpz_and (x, x, mask);
159 /* Confirm that no bits above the signed range are set. */
160 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
165 /* Converts an mpz_t unsigned variable into a signed one, assuming
166 two's complement representations and a binary width of bitsize.
167 If the bitsize-1 bit is set, this is taken as a sign bit and
168 the number is converted to the corresponding negative number. */
171 convert_mpz_to_signed (mpz_t x, int bitsize)
175 /* Confirm that no bits above the unsigned range are set. */
176 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
178 if (mpz_tstbit (x, bitsize - 1) == 1)
180 mpz_init_set_ui (mask, 1);
181 mpz_mul_2exp (mask, mask, bitsize);
182 mpz_sub_ui (mask, mask, 1);
184 /* We negate the number by hand, zeroing the high bits, that is
185 make it the corresponding positive number, and then have it
186 negated by GMP, giving the correct representation of the
189 mpz_add_ui (x, x, 1);
190 mpz_and (x, x, mask);
199 /********************** Simplification functions *****************************/
202 gfc_simplify_abs (gfc_expr *e)
206 if (e->expr_type != EXPR_CONSTANT)
212 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
214 mpz_abs (result->value.integer, e->value.integer);
216 result = range_check (result, "IABS");
220 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
222 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
224 result = range_check (result, "ABS");
228 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
230 gfc_set_model_kind (e->ts.kind);
232 mpfr_hypot (result->value.real, e->value.complex.r,
233 e->value.complex.i, GFC_RND_MODE);
234 result = range_check (result, "CABS");
238 gfc_internal_error ("gfc_simplify_abs(): Bad type");
244 /* We use the processor's collating sequence, because all
245 systems that gfortran currently works on are ASCII. */
248 gfc_simplify_achar (gfc_expr *e)
254 if (e->expr_type != EXPR_CONSTANT)
257 ch = gfc_extract_int (e, &c);
260 gfc_internal_error ("gfc_simplify_achar: %s", ch);
262 if (gfc_option.warn_surprising && (c < 0 || c > 127))
263 gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
266 result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
269 result->value.character.string = gfc_getmem (2);
271 result->value.character.length = 1;
272 result->value.character.string[0] = c;
273 result->value.character.string[1] = '\0'; /* For debugger */
279 gfc_simplify_acos (gfc_expr *x)
283 if (x->expr_type != EXPR_CONSTANT)
286 if (mpfr_cmp_si (x->value.real, 1) > 0
287 || mpfr_cmp_si (x->value.real, -1) < 0)
289 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
291 return &gfc_bad_expr;
294 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
296 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
298 return range_check (result, "ACOS");
302 gfc_simplify_acosh (gfc_expr *x)
306 if (x->expr_type != EXPR_CONSTANT)
309 if (mpfr_cmp_si (x->value.real, 1) < 0)
311 gfc_error ("Argument of ACOSH at %L must not be less than 1",
313 return &gfc_bad_expr;
316 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
318 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
320 return range_check (result, "ACOSH");
324 gfc_simplify_adjustl (gfc_expr *e)
330 if (e->expr_type != EXPR_CONSTANT)
333 len = e->value.character.length;
335 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
337 result->value.character.length = len;
338 result->value.character.string = gfc_getmem (len + 1);
340 for (count = 0, i = 0; i < len; ++i)
342 ch = e->value.character.string[i];
348 for (i = 0; i < len - count; ++i)
349 result->value.character.string[i] = e->value.character.string[count + i];
351 for (i = len - count; i < len; ++i)
352 result->value.character.string[i] = ' ';
354 result->value.character.string[len] = '\0'; /* For debugger */
361 gfc_simplify_adjustr (gfc_expr *e)
367 if (e->expr_type != EXPR_CONSTANT)
370 len = e->value.character.length;
372 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
374 result->value.character.length = len;
375 result->value.character.string = gfc_getmem (len + 1);
377 for (count = 0, i = len - 1; i >= 0; --i)
379 ch = e->value.character.string[i];
385 for (i = 0; i < count; ++i)
386 result->value.character.string[i] = ' ';
388 for (i = count; i < len; ++i)
389 result->value.character.string[i] = e->value.character.string[i - count];
391 result->value.character.string[len] = '\0'; /* For debugger */
398 gfc_simplify_aimag (gfc_expr *e)
402 if (e->expr_type != EXPR_CONSTANT)
405 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
406 mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
408 return range_check (result, "AIMAG");
413 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
415 gfc_expr *rtrunc, *result;
418 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
420 return &gfc_bad_expr;
422 if (e->expr_type != EXPR_CONSTANT)
425 rtrunc = gfc_copy_expr (e);
427 mpfr_trunc (rtrunc->value.real, e->value.real);
429 result = gfc_real2real (rtrunc, kind);
430 gfc_free_expr (rtrunc);
432 return range_check (result, "AINT");
437 gfc_simplify_dint (gfc_expr *e)
439 gfc_expr *rtrunc, *result;
441 if (e->expr_type != EXPR_CONSTANT)
444 rtrunc = gfc_copy_expr (e);
446 mpfr_trunc (rtrunc->value.real, e->value.real);
448 result = gfc_real2real (rtrunc, gfc_default_double_kind);
449 gfc_free_expr (rtrunc);
451 return range_check (result, "DINT");
456 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
461 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
463 return &gfc_bad_expr;
465 if (e->expr_type != EXPR_CONSTANT)
468 result = gfc_constant_result (e->ts.type, kind, &e->where);
470 mpfr_round (result->value.real, e->value.real);
472 return range_check (result, "ANINT");
477 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
482 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
485 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
486 if (x->ts.type == BT_INTEGER)
488 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
489 mpz_and (result->value.integer, x->value.integer, y->value.integer);
491 else /* BT_LOGICAL */
493 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
494 result->value.logical = x->value.logical && y->value.logical;
497 return range_check (result, "AND");
502 gfc_simplify_dnint (gfc_expr *e)
506 if (e->expr_type != EXPR_CONSTANT)
509 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
511 mpfr_round (result->value.real, e->value.real);
513 return range_check (result, "DNINT");
518 gfc_simplify_asin (gfc_expr *x)
522 if (x->expr_type != EXPR_CONSTANT)
525 if (mpfr_cmp_si (x->value.real, 1) > 0
526 || mpfr_cmp_si (x->value.real, -1) < 0)
528 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
530 return &gfc_bad_expr;
533 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
535 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
537 return range_check (result, "ASIN");
542 gfc_simplify_asinh (gfc_expr *x)
546 if (x->expr_type != EXPR_CONSTANT)
549 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
551 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
553 return range_check (result, "ASINH");
558 gfc_simplify_atan (gfc_expr *x)
562 if (x->expr_type != EXPR_CONSTANT)
565 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
567 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
569 return range_check (result, "ATAN");
574 gfc_simplify_atanh (gfc_expr *x)
578 if (x->expr_type != EXPR_CONSTANT)
581 if (mpfr_cmp_si (x->value.real, 1) >= 0
582 || mpfr_cmp_si (x->value.real, -1) <= 0)
584 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
586 return &gfc_bad_expr;
589 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
591 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
593 return range_check (result, "ATANH");
598 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
602 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
605 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
607 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
609 gfc_error ("If first argument of ATAN2 %L is zero, then the "
610 "second argument must not be zero", &x->where);
611 gfc_free_expr (result);
612 return &gfc_bad_expr;
615 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
617 return range_check (result, "ATAN2");
622 gfc_simplify_bit_size (gfc_expr *e)
627 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
628 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
629 mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
636 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
640 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
643 if (gfc_extract_int (bit, &b) != NULL || b < 0)
644 return gfc_logical_expr (0, &e->where);
646 return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
651 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
653 gfc_expr *ceil, *result;
656 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
658 return &gfc_bad_expr;
660 if (e->expr_type != EXPR_CONSTANT)
663 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
665 ceil = gfc_copy_expr (e);
667 mpfr_ceil (ceil->value.real, e->value.real);
668 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
670 gfc_free_expr (ceil);
672 return range_check (result, "CEILING");
677 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
683 kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
685 return &gfc_bad_expr;
687 if (e->expr_type != EXPR_CONSTANT)
690 ch = gfc_extract_int (e, &c);
693 gfc_internal_error ("gfc_simplify_char: %s", ch);
695 if (c < 0 || c > UCHAR_MAX)
696 gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
699 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
701 result->value.character.length = 1;
702 result->value.character.string = gfc_getmem (2);
704 result->value.character.string[0] = c;
705 result->value.character.string[1] = '\0'; /* For debugger */
711 /* Common subroutine for simplifying CMPLX and DCMPLX. */
714 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
718 result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
720 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
725 mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
729 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
733 mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
734 mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
738 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
746 mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
750 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
754 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
758 return range_check (result, name);
763 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
767 if (x->expr_type != EXPR_CONSTANT
768 || (y != NULL && y->expr_type != EXPR_CONSTANT))
771 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
773 return &gfc_bad_expr;
775 return simplify_cmplx ("CMPLX", x, y, kind);
780 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
784 if (x->expr_type != EXPR_CONSTANT
785 || (y != NULL && y->expr_type != EXPR_CONSTANT))
788 if (x->ts.type == BT_INTEGER)
790 if (y->ts.type == BT_INTEGER)
791 kind = gfc_default_real_kind;
797 if (y->ts.type == BT_REAL)
798 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
803 return simplify_cmplx ("COMPLEX", x, y, kind);
808 gfc_simplify_conjg (gfc_expr *e)
812 if (e->expr_type != EXPR_CONSTANT)
815 result = gfc_copy_expr (e);
816 mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
818 return range_check (result, "CONJG");
823 gfc_simplify_cos (gfc_expr *x)
828 if (x->expr_type != EXPR_CONSTANT)
831 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
836 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
839 gfc_set_model_kind (x->ts.kind);
843 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
844 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
845 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
847 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
848 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
849 mpfr_mul (xp, xp, xq, GFC_RND_MODE);
850 mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
856 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
859 return range_check (result, "COS");
865 gfc_simplify_cosh (gfc_expr *x)
869 if (x->expr_type != EXPR_CONSTANT)
872 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
874 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
876 return range_check (result, "COSH");
881 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
884 if (x->expr_type != EXPR_CONSTANT
885 || (y != NULL && y->expr_type != EXPR_CONSTANT))
888 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
893 gfc_simplify_dble (gfc_expr *e)
897 if (e->expr_type != EXPR_CONSTANT)
903 result = gfc_int2real (e, gfc_default_double_kind);
907 result = gfc_real2real (e, gfc_default_double_kind);
911 result = gfc_complex2real (e, gfc_default_double_kind);
915 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
918 return range_check (result, "DBLE");
923 gfc_simplify_digits (gfc_expr *x)
927 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
931 digits = gfc_integer_kinds[i].digits;
936 digits = gfc_real_kinds[i].digits;
943 return gfc_int_expr (digits);
948 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
953 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
956 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
957 result = gfc_constant_result (x->ts.type, kind, &x->where);
962 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
963 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
965 mpz_set_ui (result->value.integer, 0);
970 if (mpfr_cmp (x->value.real, y->value.real) > 0)
971 mpfr_sub (result->value.real, x->value.real, y->value.real,
974 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
979 gfc_internal_error ("gfc_simplify_dim(): Bad type");
982 return range_check (result, "DIM");
987 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
989 gfc_expr *a1, *a2, *result;
991 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
994 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
996 a1 = gfc_real2real (x, gfc_default_double_kind);
997 a2 = gfc_real2real (y, gfc_default_double_kind);
999 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1004 return range_check (result, "DPROD");
1009 gfc_simplify_epsilon (gfc_expr *e)
1014 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1016 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1018 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1020 return range_check (result, "EPSILON");
1025 gfc_simplify_exp (gfc_expr *x)
1030 if (x->expr_type != EXPR_CONSTANT)
1033 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1038 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1042 gfc_set_model_kind (x->ts.kind);
1045 mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1046 mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1047 mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1048 mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1049 mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1055 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1058 return range_check (result, "EXP");
1062 gfc_simplify_exponent (gfc_expr *x)
1067 if (x->expr_type != EXPR_CONSTANT)
1070 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1073 gfc_set_model (x->value.real);
1075 if (mpfr_sgn (x->value.real) == 0)
1077 mpz_set_ui (result->value.integer, 0);
1081 i = (int) mpfr_get_exp (x->value.real);
1082 mpz_set_si (result->value.integer, i);
1084 return range_check (result, "EXPONENT");
1089 gfc_simplify_float (gfc_expr *a)
1093 if (a->expr_type != EXPR_CONSTANT)
1096 result = gfc_int2real (a, gfc_default_real_kind);
1097 return range_check (result, "FLOAT");
1102 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1108 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1110 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1112 if (e->expr_type != EXPR_CONSTANT)
1115 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1117 gfc_set_model_kind (kind);
1119 mpfr_floor (floor, e->value.real);
1121 gfc_mpfr_to_mpz (result->value.integer, floor);
1125 return range_check (result, "FLOOR");
1130 gfc_simplify_fraction (gfc_expr *x)
1133 mpfr_t absv, exp, pow2;
1135 if (x->expr_type != EXPR_CONSTANT)
1138 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1140 gfc_set_model_kind (x->ts.kind);
1142 if (mpfr_sgn (x->value.real) == 0)
1144 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1152 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1153 mpfr_log2 (exp, absv, GFC_RND_MODE);
1155 mpfr_trunc (exp, exp);
1156 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1158 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1160 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1166 return range_check (result, "FRACTION");
1171 gfc_simplify_huge (gfc_expr *e)
1176 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1178 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1183 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1187 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1197 /* We use the processor's collating sequence, because all
1198 systems that gfortran currently works on are ASCII. */
1201 gfc_simplify_iachar (gfc_expr *e)
1206 if (e->expr_type != EXPR_CONSTANT)
1209 if (e->value.character.length != 1)
1211 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1212 return &gfc_bad_expr;
1215 index = (unsigned char) e->value.character.string[0];
1217 if (gfc_option.warn_surprising && index > 127)
1218 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1221 result = gfc_int_expr (index);
1222 result->where = e->where;
1224 return range_check (result, "IACHAR");
1229 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1233 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1236 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1238 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1240 return range_check (result, "IAND");
1245 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1250 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1253 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1255 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1256 return &gfc_bad_expr;
1259 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1261 if (pos >= gfc_integer_kinds[k].bit_size)
1263 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1265 return &gfc_bad_expr;
1268 result = gfc_copy_expr (x);
1270 convert_mpz_to_unsigned (result->value.integer,
1271 gfc_integer_kinds[k].bit_size);
1273 mpz_clrbit (result->value.integer, pos);
1275 convert_mpz_to_signed (result->value.integer,
1276 gfc_integer_kinds[k].bit_size);
1278 return range_check (result, "IBCLR");
1283 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1290 if (x->expr_type != EXPR_CONSTANT
1291 || y->expr_type != EXPR_CONSTANT
1292 || z->expr_type != EXPR_CONSTANT)
1295 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1297 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1298 return &gfc_bad_expr;
1301 if (gfc_extract_int (z, &len) != NULL || len < 0)
1303 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1304 return &gfc_bad_expr;
1307 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1309 bitsize = gfc_integer_kinds[k].bit_size;
1311 if (pos + len > bitsize)
1313 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1314 "bit size at %L", &y->where);
1315 return &gfc_bad_expr;
1318 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1320 bits = gfc_getmem (bitsize * sizeof (int));
1322 for (i = 0; i < bitsize; i++)
1325 for (i = 0; i < len; i++)
1326 bits[i] = mpz_tstbit (x->value.integer, i + pos);
1328 for (i = 0; i < bitsize; i++)
1331 mpz_clrbit (result->value.integer, i);
1332 else if (bits[i] == 1)
1333 mpz_setbit (result->value.integer, i);
1335 gfc_internal_error ("IBITS: Bad bit");
1340 return range_check (result, "IBITS");
1345 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1350 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1353 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1355 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1356 return &gfc_bad_expr;
1359 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1361 if (pos >= gfc_integer_kinds[k].bit_size)
1363 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1365 return &gfc_bad_expr;
1368 result = gfc_copy_expr (x);
1370 convert_mpz_to_unsigned (result->value.integer,
1371 gfc_integer_kinds[k].bit_size);
1373 mpz_setbit (result->value.integer, pos);
1375 convert_mpz_to_signed (result->value.integer,
1376 gfc_integer_kinds[k].bit_size);
1378 return range_check (result, "IBSET");
1383 gfc_simplify_ichar (gfc_expr *e)
1388 if (e->expr_type != EXPR_CONSTANT)
1391 if (e->value.character.length != 1)
1393 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1394 return &gfc_bad_expr;
1397 index = (unsigned char) e->value.character.string[0];
1399 if (index < 0 || index > UCHAR_MAX)
1400 gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
1402 result = gfc_int_expr (index);
1403 result->where = e->where;
1404 return range_check (result, "ICHAR");
1409 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
1413 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1416 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1418 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1420 return range_check (result, "IEOR");
1425 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b)
1428 int back, len, lensub;
1429 int i, j, k, count, index = 0, start;
1431 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1434 if (b != NULL && b->value.logical != 0)
1439 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1442 len = x->value.character.length;
1443 lensub = y->value.character.length;
1447 mpz_set_si (result->value.integer, 0);
1455 mpz_set_si (result->value.integer, 1);
1458 else if (lensub == 1)
1460 for (i = 0; i < len; i++)
1462 for (j = 0; j < lensub; j++)
1464 if (y->value.character.string[j]
1465 == x->value.character.string[i])
1475 for (i = 0; i < len; i++)
1477 for (j = 0; j < lensub; j++)
1479 if (y->value.character.string[j]
1480 == x->value.character.string[i])
1485 for (k = 0; k < lensub; k++)
1487 if (y->value.character.string[k]
1488 == x->value.character.string[k + start])
1492 if (count == lensub)
1507 mpz_set_si (result->value.integer, len + 1);
1510 else if (lensub == 1)
1512 for (i = 0; i < len; i++)
1514 for (j = 0; j < lensub; j++)
1516 if (y->value.character.string[j]
1517 == x->value.character.string[len - i])
1519 index = len - i + 1;
1527 for (i = 0; i < len; i++)
1529 for (j = 0; j < lensub; j++)
1531 if (y->value.character.string[j]
1532 == x->value.character.string[len - i])
1535 if (start <= len - lensub)
1538 for (k = 0; k < lensub; k++)
1539 if (y->value.character.string[k]
1540 == x->value.character.string[k + start])
1543 if (count == lensub)
1560 mpz_set_si (result->value.integer, index);
1561 return range_check (result, "INDEX");
1566 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
1568 gfc_expr *rpart, *rtrunc, *result;
1571 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1573 return &gfc_bad_expr;
1575 if (e->expr_type != EXPR_CONSTANT)
1578 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1583 mpz_set (result->value.integer, e->value.integer);
1587 rtrunc = gfc_copy_expr (e);
1588 mpfr_trunc (rtrunc->value.real, e->value.real);
1589 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1590 gfc_free_expr (rtrunc);
1594 rpart = gfc_complex2real (e, kind);
1595 rtrunc = gfc_copy_expr (rpart);
1596 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1597 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1598 gfc_free_expr (rpart);
1599 gfc_free_expr (rtrunc);
1603 gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1604 gfc_free_expr (result);
1605 return &gfc_bad_expr;
1608 return range_check (result, "INT");
1613 gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
1615 gfc_expr *rpart, *rtrunc, *result;
1617 if (e->expr_type != EXPR_CONSTANT)
1620 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1625 mpz_set (result->value.integer, e->value.integer);
1629 rtrunc = gfc_copy_expr (e);
1630 mpfr_trunc (rtrunc->value.real, e->value.real);
1631 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1632 gfc_free_expr (rtrunc);
1636 rpart = gfc_complex2real (e, kind);
1637 rtrunc = gfc_copy_expr (rpart);
1638 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1639 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1640 gfc_free_expr (rpart);
1641 gfc_free_expr (rtrunc);
1645 gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
1646 gfc_free_expr (result);
1647 return &gfc_bad_expr;
1650 return range_check (result, name);
1655 gfc_simplify_int2 (gfc_expr *e)
1657 return gfc_simplify_intconv (e, 2, "INT2");
1662 gfc_simplify_int8 (gfc_expr *e)
1664 return gfc_simplify_intconv (e, 8, "INT8");
1669 gfc_simplify_long (gfc_expr *e)
1671 return gfc_simplify_intconv (e, 4, "LONG");
1676 gfc_simplify_ifix (gfc_expr *e)
1678 gfc_expr *rtrunc, *result;
1680 if (e->expr_type != EXPR_CONSTANT)
1683 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1686 rtrunc = gfc_copy_expr (e);
1688 mpfr_trunc (rtrunc->value.real, e->value.real);
1689 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1691 gfc_free_expr (rtrunc);
1692 return range_check (result, "IFIX");
1697 gfc_simplify_idint (gfc_expr *e)
1699 gfc_expr *rtrunc, *result;
1701 if (e->expr_type != EXPR_CONSTANT)
1704 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1707 rtrunc = gfc_copy_expr (e);
1709 mpfr_trunc (rtrunc->value.real, e->value.real);
1710 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1712 gfc_free_expr (rtrunc);
1713 return range_check (result, "IDINT");
1718 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
1722 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1725 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1727 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1728 return range_check (result, "IOR");
1733 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
1736 int shift, ashift, isize, k, *bits, i;
1738 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1741 if (gfc_extract_int (s, &shift) != NULL)
1743 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
1744 return &gfc_bad_expr;
1747 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
1749 isize = gfc_integer_kinds[k].bit_size;
1758 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
1759 "at %L", &s->where);
1760 return &gfc_bad_expr;
1763 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1767 mpz_set (result->value.integer, e->value.integer);
1768 return range_check (result, "ISHFT");
1771 bits = gfc_getmem (isize * sizeof (int));
1773 for (i = 0; i < isize; i++)
1774 bits[i] = mpz_tstbit (e->value.integer, i);
1778 for (i = 0; i < shift; i++)
1779 mpz_clrbit (result->value.integer, i);
1781 for (i = 0; i < isize - shift; i++)
1784 mpz_clrbit (result->value.integer, i + shift);
1786 mpz_setbit (result->value.integer, i + shift);
1791 for (i = isize - 1; i >= isize - ashift; i--)
1792 mpz_clrbit (result->value.integer, i);
1794 for (i = isize - 1; i >= ashift; i--)
1797 mpz_clrbit (result->value.integer, i - ashift);
1799 mpz_setbit (result->value.integer, i - ashift);
1803 convert_mpz_to_signed (result->value.integer, isize);
1811 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
1814 int shift, ashift, isize, ssize, delta, k;
1817 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1820 if (gfc_extract_int (s, &shift) != NULL)
1822 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
1823 return &gfc_bad_expr;
1826 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1827 isize = gfc_integer_kinds[k].bit_size;
1831 if (sz->expr_type != EXPR_CONSTANT)
1834 if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
1836 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
1837 return &gfc_bad_expr;
1842 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
1843 "BIT_SIZE of first argument at %L", &s->where);
1844 return &gfc_bad_expr;
1858 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1859 "third argument at %L", &s->where);
1861 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1862 "BIT_SIZE of first argument at %L", &s->where);
1863 return &gfc_bad_expr;
1866 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1868 mpz_set (result->value.integer, e->value.integer);
1873 convert_mpz_to_unsigned (result->value.integer, isize);
1875 bits = gfc_getmem (ssize * sizeof (int));
1877 for (i = 0; i < ssize; i++)
1878 bits[i] = mpz_tstbit (e->value.integer, i);
1880 delta = ssize - ashift;
1884 for (i = 0; i < delta; i++)
1887 mpz_clrbit (result->value.integer, i + shift);
1889 mpz_setbit (result->value.integer, i + shift);
1892 for (i = delta; i < ssize; i++)
1895 mpz_clrbit (result->value.integer, i - delta);
1897 mpz_setbit (result->value.integer, i - delta);
1902 for (i = 0; i < ashift; i++)
1905 mpz_clrbit (result->value.integer, i + delta);
1907 mpz_setbit (result->value.integer, i + delta);
1910 for (i = ashift; i < ssize; i++)
1913 mpz_clrbit (result->value.integer, i + shift);
1915 mpz_setbit (result->value.integer, i + shift);
1919 convert_mpz_to_signed (result->value.integer, isize);
1927 gfc_simplify_kind (gfc_expr *e)
1930 if (e->ts.type == BT_DERIVED)
1932 gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
1933 return &gfc_bad_expr;
1936 return gfc_int_expr (e->ts.kind);
1941 simplify_bound_dim (gfc_expr *array, int d, int upper, gfc_array_spec *as)
1943 gfc_expr *l, *u, *result;
1945 /* The last dimension of an assumed-size array is special. */
1946 if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
1948 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
1949 return gfc_copy_expr (as->lower[d-1]);
1954 /* Then, we need to know the extent of the given dimension. */
1958 if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
1961 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1964 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
1968 mpz_set_si (result->value.integer, 0);
1970 mpz_set_si (result->value.integer, 1);
1974 /* Nonzero extent. */
1976 mpz_set (result->value.integer, u->value.integer);
1978 mpz_set (result->value.integer, l->value.integer);
1981 return range_check (result, upper ? "UBOUND" : "LBOUND");
1986 simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
1992 if (array->expr_type != EXPR_VARIABLE)
1995 /* Follow any component references. */
1996 as = array->symtree->n.sym->as;
1997 for (ref = array->ref; ref; ref = ref->next)
2002 switch (ref->u.ar.type)
2009 /* We're done because 'as' has already been set in the
2010 previous iteration. */
2021 as = ref->u.c.component->as;
2033 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2038 /* Multi-dimensional bounds. */
2039 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2041 gfc_constructor *head, *tail;
2043 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2044 if (upper && as->type == AS_ASSUMED_SIZE)
2046 /* An error message will be emitted in
2047 check_assumed_size_reference (resolve.c). */
2048 return &gfc_bad_expr;
2051 /* Simplify the bounds for each dimension. */
2052 for (d = 0; d < array->rank; d++)
2054 bounds[d] = simplify_bound_dim (array, d + 1, upper, as);
2055 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2059 for (j = 0; j < d; j++)
2060 gfc_free_expr (bounds[j]);
2065 /* Allocate the result expression. */
2066 e = gfc_get_expr ();
2067 e->where = array->where;
2068 e->expr_type = EXPR_ARRAY;
2069 e->ts.type = BT_INTEGER;
2070 e->ts.kind = gfc_default_integer_kind;
2072 /* The result is a rank 1 array; its size is the rank of the first
2073 argument to {L,U}BOUND. */
2075 e->shape = gfc_get_shape (1);
2076 mpz_init_set_ui (e->shape[0], array->rank);
2078 /* Create the constructor for this array. */
2080 for (d = 0; d < array->rank; d++)
2082 /* Get a new constructor element. */
2084 head = tail = gfc_get_constructor ();
2087 tail->next = gfc_get_constructor ();
2091 tail->where = e->where;
2092 tail->expr = bounds[d];
2094 e->value.constructor = head;
2100 /* A DIM argument is specified. */
2101 if (dim->expr_type != EXPR_CONSTANT)
2104 d = mpz_get_si (dim->value.integer);
2106 if (d < 1 || d > as->rank
2107 || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2109 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2110 return &gfc_bad_expr;
2113 return simplify_bound_dim (array, d, upper, as);
2119 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim)
2121 return simplify_bound (array, dim, 0);
2126 gfc_simplify_len (gfc_expr *e)
2130 if (e->expr_type == EXPR_CONSTANT)
2132 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2134 mpz_set_si (result->value.integer, e->value.character.length);
2135 return range_check (result, "LEN");
2138 if (e->ts.cl != NULL && e->ts.cl->length != NULL
2139 && e->ts.cl->length->expr_type == EXPR_CONSTANT
2140 && e->ts.cl->length->ts.type == BT_INTEGER)
2142 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2144 mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2145 return range_check (result, "LEN");
2153 gfc_simplify_len_trim (gfc_expr *e)
2156 int count, len, lentrim, i;
2158 if (e->expr_type != EXPR_CONSTANT)
2161 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2164 len = e->value.character.length;
2166 for (count = 0, i = 1; i <= len; i++)
2167 if (e->value.character.string[len - i] == ' ')
2172 lentrim = len - count;
2174 mpz_set_si (result->value.integer, lentrim);
2175 return range_check (result, "LEN_TRIM");
2180 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
2182 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2185 return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
2190 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
2192 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2195 return gfc_logical_expr (gfc_compare_string (a, b) > 0,
2201 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
2203 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2206 return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
2211 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
2213 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2216 return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
2221 gfc_simplify_log (gfc_expr *x)
2226 if (x->expr_type != EXPR_CONSTANT)
2229 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2231 gfc_set_model_kind (x->ts.kind);
2236 if (mpfr_sgn (x->value.real) <= 0)
2238 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2239 "to zero", &x->where);
2240 gfc_free_expr (result);
2241 return &gfc_bad_expr;
2244 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
2248 if ((mpfr_sgn (x->value.complex.r) == 0)
2249 && (mpfr_sgn (x->value.complex.i) == 0))
2251 gfc_error ("Complex argument of LOG at %L cannot be zero",
2253 gfc_free_expr (result);
2254 return &gfc_bad_expr;
2260 mpfr_atan2 (result->value.complex.i, x->value.complex.i,
2261 x->value.complex.r, GFC_RND_MODE);
2263 mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2264 mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2265 mpfr_add (xr, xr, xi, GFC_RND_MODE);
2266 mpfr_sqrt (xr, xr, GFC_RND_MODE);
2267 mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2275 gfc_internal_error ("gfc_simplify_log: bad type");
2278 return range_check (result, "LOG");
2283 gfc_simplify_log10 (gfc_expr *x)
2287 if (x->expr_type != EXPR_CONSTANT)
2290 gfc_set_model_kind (x->ts.kind);
2292 if (mpfr_sgn (x->value.real) <= 0)
2294 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2295 "to zero", &x->where);
2296 return &gfc_bad_expr;
2299 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2301 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2303 return range_check (result, "LOG10");
2308 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
2313 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2315 return &gfc_bad_expr;
2317 if (e->expr_type != EXPR_CONSTANT)
2320 result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2322 result->value.logical = e->value.logical;
2328 /* This function is special since MAX() can take any number of
2329 arguments. The simplified expression is a rewritten version of the
2330 argument list containing at most one constant element. Other
2331 constant elements are deleted. Because the argument list has
2332 already been checked, this function always succeeds. sign is 1 for
2333 MAX(), -1 for MIN(). */
2336 simplify_min_max (gfc_expr *expr, int sign)
2338 gfc_actual_arglist *arg, *last, *extremum;
2339 gfc_intrinsic_sym * specific;
2343 specific = expr->value.function.isym;
2345 arg = expr->value.function.actual;
2347 for (; arg; last = arg, arg = arg->next)
2349 if (arg->expr->expr_type != EXPR_CONSTANT)
2352 if (extremum == NULL)
2358 switch (arg->expr->ts.type)
2361 if (mpz_cmp (arg->expr->value.integer,
2362 extremum->expr->value.integer) * sign > 0)
2363 mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2367 if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real)
2369 mpfr_set (extremum->expr->value.real, arg->expr->value.real,
2374 #define LENGTH(x) ((x)->expr->value.character.length)
2375 #define STRING(x) ((x)->expr->value.character.string)
2376 if (LENGTH(extremum) < LENGTH(arg))
2378 char * tmp = STRING(extremum);
2380 STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
2381 memcpy (STRING(extremum), tmp, LENGTH(extremum));
2382 memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2383 LENGTH(arg) - LENGTH(extremum));
2384 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
2385 LENGTH(extremum) = LENGTH(arg);
2389 if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
2391 gfc_free (STRING(extremum));
2392 STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
2393 memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
2394 memset (&STRING(extremum)[LENGTH(arg)], ' ',
2395 LENGTH(extremum) - LENGTH(arg));
2396 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
2404 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2407 /* Delete the extra constant argument. */
2409 expr->value.function.actual = arg->next;
2411 last->next = arg->next;
2414 gfc_free_actual_arglist (arg);
2418 /* If there is one value left, replace the function call with the
2420 if (expr->value.function.actual->next != NULL)
2423 /* Convert to the correct type and kind. */
2424 if (expr->ts.type != BT_UNKNOWN)
2425 return gfc_convert_constant (expr->value.function.actual->expr,
2426 expr->ts.type, expr->ts.kind);
2428 if (specific->ts.type != BT_UNKNOWN)
2429 return gfc_convert_constant (expr->value.function.actual->expr,
2430 specific->ts.type, specific->ts.kind);
2432 return gfc_copy_expr (expr->value.function.actual->expr);
2437 gfc_simplify_min (gfc_expr *e)
2439 return simplify_min_max (e, -1);
2444 gfc_simplify_max (gfc_expr *e)
2446 return simplify_min_max (e, 1);
2451 gfc_simplify_maxexponent (gfc_expr *x)
2456 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2458 result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2459 result->where = x->where;
2466 gfc_simplify_minexponent (gfc_expr *x)
2471 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2473 result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2474 result->where = x->where;
2481 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2484 mpfr_t quot, iquot, term;
2487 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2490 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2491 result = gfc_constant_result (a->ts.type, kind, &a->where);
2496 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2498 /* Result is processor-dependent. */
2499 gfc_error ("Second argument MOD at %L is zero", &a->where);
2500 gfc_free_expr (result);
2501 return &gfc_bad_expr;
2503 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2507 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2509 /* Result is processor-dependent. */
2510 gfc_error ("Second argument of MOD at %L is zero", &p->where);
2511 gfc_free_expr (result);
2512 return &gfc_bad_expr;
2515 gfc_set_model_kind (kind);
2520 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2521 mpfr_trunc (iquot, quot);
2522 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2523 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2531 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2534 return range_check (result, "MOD");
2539 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2542 mpfr_t quot, iquot, term;
2545 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2548 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2549 result = gfc_constant_result (a->ts.type, kind, &a->where);
2554 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2556 /* Result is processor-dependent. This processor just opts
2557 to not handle it at all. */
2558 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2559 gfc_free_expr (result);
2560 return &gfc_bad_expr;
2562 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2567 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2569 /* Result is processor-dependent. */
2570 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2571 gfc_free_expr (result);
2572 return &gfc_bad_expr;
2575 gfc_set_model_kind (kind);
2580 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2581 mpfr_floor (iquot, quot);
2582 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2583 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2591 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2594 return range_check (result, "MODULO");
2598 /* Exists for the sole purpose of consistency with other intrinsics. */
2600 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
2601 gfc_expr *fp ATTRIBUTE_UNUSED,
2602 gfc_expr *l ATTRIBUTE_UNUSED,
2603 gfc_expr *to ATTRIBUTE_UNUSED,
2604 gfc_expr *tp ATTRIBUTE_UNUSED)
2611 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
2617 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2620 if (mpfr_sgn (s->value.real) == 0)
2622 gfc_error ("Second argument of NEAREST at %L shall not be zero",
2624 return &gfc_bad_expr;
2627 gfc_set_model_kind (x->ts.kind);
2628 result = gfc_copy_expr (x);
2630 sgn = mpfr_sgn (s->value.real);
2632 mpfr_set_inf (tmp, sgn);
2633 mpfr_nexttoward (result->value.real, tmp);
2636 return range_check (result, "NEAREST");
2641 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
2643 gfc_expr *itrunc, *result;
2646 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2648 return &gfc_bad_expr;
2650 if (e->expr_type != EXPR_CONSTANT)
2653 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2655 itrunc = gfc_copy_expr (e);
2657 mpfr_round (itrunc->value.real, e->value.real);
2659 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
2661 gfc_free_expr (itrunc);
2663 return range_check (result, name);
2668 gfc_simplify_new_line (gfc_expr *e)
2672 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2673 result->value.character.string = gfc_getmem (2);
2674 result->value.character.length = 1;
2675 result->value.character.string[0] = '\n';
2676 result->value.character.string[1] = '\0'; /* For debugger */
2682 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
2684 return simplify_nint ("NINT", e, k);
2689 gfc_simplify_idnint (gfc_expr *e)
2691 return simplify_nint ("IDNINT", e, NULL);
2696 gfc_simplify_not (gfc_expr *e)
2700 if (e->expr_type != EXPR_CONSTANT)
2703 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2705 mpz_com (result->value.integer, e->value.integer);
2707 return range_check (result, "NOT");
2712 gfc_simplify_null (gfc_expr *mold)
2718 result = gfc_get_expr ();
2719 result->ts.type = BT_UNKNOWN;
2722 result = gfc_copy_expr (mold);
2723 result->expr_type = EXPR_NULL;
2730 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
2735 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2738 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2739 if (x->ts.type == BT_INTEGER)
2741 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
2742 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2744 else /* BT_LOGICAL */
2746 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
2747 result->value.logical = x->value.logical || y->value.logical;
2750 return range_check (result, "OR");
2755 gfc_simplify_precision (gfc_expr *e)
2760 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2762 result = gfc_int_expr (gfc_real_kinds[i].precision);
2763 result->where = e->where;
2770 gfc_simplify_radix (gfc_expr *e)
2775 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2779 i = gfc_integer_kinds[i].radix;
2783 i = gfc_real_kinds[i].radix;
2790 result = gfc_int_expr (i);
2791 result->where = e->where;
2798 gfc_simplify_range (gfc_expr *e)
2804 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2809 j = gfc_integer_kinds[i].range;
2814 j = gfc_real_kinds[i].range;
2821 result = gfc_int_expr (j);
2822 result->where = e->where;
2829 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
2834 if (e->ts.type == BT_COMPLEX)
2835 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
2837 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
2840 return &gfc_bad_expr;
2842 if (e->expr_type != EXPR_CONSTANT)
2848 result = gfc_int2real (e, kind);
2852 result = gfc_real2real (e, kind);
2856 result = gfc_complex2real (e, kind);
2860 gfc_internal_error ("bad type in REAL");
2864 return range_check (result, "REAL");
2869 gfc_simplify_realpart (gfc_expr *e)
2873 if (e->expr_type != EXPR_CONSTANT)
2876 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
2877 mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
2879 return range_check (result, "REALPART");
2883 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
2886 int i, j, len, ncop, nlen;
2888 bool have_length = false;
2890 /* If NCOPIES isn't a constant, there's nothing we can do. */
2891 if (n->expr_type != EXPR_CONSTANT)
2894 /* If NCOPIES is negative, it's an error. */
2895 if (mpz_sgn (n->value.integer) < 0)
2897 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
2899 return &gfc_bad_expr;
2902 /* If we don't know the character length, we can do no more. */
2903 if (e->ts.cl && e->ts.cl->length
2904 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
2906 len = mpz_get_si (e->ts.cl->length->value.integer);
2909 else if (e->expr_type == EXPR_CONSTANT
2910 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
2912 len = e->value.character.length;
2917 /* If the source length is 0, any value of NCOPIES is valid
2918 and everything behaves as if NCOPIES == 0. */
2921 mpz_set_ui (ncopies, 0);
2923 mpz_set (ncopies, n->value.integer);
2925 /* Check that NCOPIES isn't too large. */
2931 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
2933 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
2937 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
2938 e->ts.cl->length->value.integer);
2942 mpz_init_set_si (mlen, len);
2943 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
2947 /* The check itself. */
2948 if (mpz_cmp (ncopies, max) > 0)
2951 mpz_clear (ncopies);
2952 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
2954 return &gfc_bad_expr;
2959 mpz_clear (ncopies);
2961 /* For further simplification, we need the character string to be
2963 if (e->expr_type != EXPR_CONSTANT)
2966 if (len || mpz_sgn (e->ts.cl->length->value.integer) != 0)
2968 const char *res = gfc_extract_int (n, &ncop);
2969 gcc_assert (res == NULL);
2974 len = e->value.character.length;
2977 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2981 result->value.character.string = gfc_getmem (1);
2982 result->value.character.length = 0;
2983 result->value.character.string[0] = '\0';
2987 result->value.character.length = nlen;
2988 result->value.character.string = gfc_getmem (nlen + 1);
2990 for (i = 0; i < ncop; i++)
2991 for (j = 0; j < len; j++)
2992 result->value.character.string[j + i * len]
2993 = e->value.character.string[j];
2995 result->value.character.string[nlen] = '\0'; /* For debugger */
3000 /* This one is a bear, but mainly has to do with shuffling elements. */
3003 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3004 gfc_expr *pad, gfc_expr *order_exp)
3006 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3007 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3008 gfc_constructor *head, *tail;
3014 /* Unpack the shape array. */
3015 if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
3018 if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
3022 && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
3025 if (order_exp != NULL
3026 && (order_exp->expr_type != EXPR_ARRAY
3027 || !gfc_is_constant_expr (order_exp)))
3036 e = gfc_get_array_element (shape_exp, rank);
3040 if (gfc_extract_int (e, &shape[rank]) != NULL)
3042 gfc_error ("Integer too large in shape specification at %L",
3050 if (rank >= GFC_MAX_DIMENSIONS)
3052 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3053 "at %L", &e->where);
3058 if (shape[rank] < 0)
3060 gfc_error ("Shape specification at %L cannot be negative",
3070 gfc_error ("Shape specification at %L cannot be the null array",
3075 /* Now unpack the order array if present. */
3076 if (order_exp == NULL)
3078 for (i = 0; i < rank; i++)
3083 for (i = 0; i < rank; i++)
3086 for (i = 0; i < rank; i++)
3088 e = gfc_get_array_element (order_exp, i);
3091 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3092 "size as SHAPE parameter", &order_exp->where);
3096 if (gfc_extract_int (e, &order[i]) != NULL)
3098 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3106 if (order[i] < 1 || order[i] > rank)
3108 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3117 gfc_error ("Invalid permutation in ORDER parameter at %L",
3126 /* Count the elements in the source and padding arrays. */
3131 gfc_array_size (pad, &size);
3132 npad = mpz_get_ui (size);
3136 gfc_array_size (source, &size);
3137 nsource = mpz_get_ui (size);
3140 /* If it weren't for that pesky permutation we could just loop
3141 through the source and round out any shortage with pad elements.
3142 But no, someone just had to have the compiler do something the
3143 user should be doing. */
3145 for (i = 0; i < rank; i++)
3150 /* Figure out which element to extract. */
3151 mpz_set_ui (index, 0);
3153 for (i = rank - 1; i >= 0; i--)
3155 mpz_add_ui (index, index, x[order[i]]);
3157 mpz_mul_ui (index, index, shape[order[i - 1]]);
3160 if (mpz_cmp_ui (index, INT_MAX) > 0)
3161 gfc_internal_error ("Reshaped array too large at %L", &e->where);
3163 j = mpz_get_ui (index);
3166 e = gfc_get_array_element (source, j);
3173 gfc_error ("PAD parameter required for short SOURCE parameter "
3174 "at %L", &source->where);
3179 e = gfc_get_array_element (pad, j);
3183 head = tail = gfc_get_constructor ();
3186 tail->next = gfc_get_constructor ();
3193 tail->where = e->where;
3196 /* Calculate the next element. */
3200 if (++x[i] < shape[i])
3211 e = gfc_get_expr ();
3212 e->where = source->where;
3213 e->expr_type = EXPR_ARRAY;
3214 e->value.constructor = head;
3215 e->shape = gfc_get_shape (rank);
3217 for (i = 0; i < rank; i++)
3218 mpz_init_set_ui (e->shape[i], shape[i]);
3226 gfc_free_constructor (head);
3228 return &gfc_bad_expr;
3233 gfc_simplify_rrspacing (gfc_expr *x)
3239 if (x->expr_type != EXPR_CONSTANT)
3242 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3244 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3246 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3248 /* Special case x = -0 and 0. */
3249 if (mpfr_sgn (result->value.real) == 0)
3251 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3255 /* | x * 2**(-e) | * 2**p. */
3256 e = - (long int) mpfr_get_exp (x->value.real);
3257 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3259 p = (long int) gfc_real_kinds[i].digits;
3260 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3262 return range_check (result, "RRSPACING");
3267 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3269 int k, neg_flag, power, exp_range;
3270 mpfr_t scale, radix;
3273 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3276 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3278 if (mpfr_sgn (x->value.real) == 0)
3280 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3284 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3286 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3288 /* This check filters out values of i that would overflow an int. */
3289 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3290 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3292 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3293 return &gfc_bad_expr;
3296 /* Compute scale = radix ** power. */
3297 power = mpz_get_si (i->value.integer);
3307 gfc_set_model_kind (x->ts.kind);
3310 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3311 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3314 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3316 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3321 return range_check (result, "SCALE");
3326 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
3331 size_t indx, len, lenc;
3333 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3336 if (b != NULL && b->value.logical != 0)
3341 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3344 len = e->value.character.length;
3345 lenc = c->value.character.length;
3347 if (len == 0 || lenc == 0)
3355 indx = strcspn (e->value.character.string, c->value.character.string)
3363 for (indx = len; indx > 0; indx--)
3365 for (i = 0; i < lenc; i++)
3367 if (c->value.character.string[i]
3368 == e->value.character.string[indx - 1])
3376 mpz_set_ui (result->value.integer, indx);
3377 return range_check (result, "SCAN");
3382 gfc_simplify_selected_int_kind (gfc_expr *e)
3387 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3392 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3393 if (gfc_integer_kinds[i].range >= range
3394 && gfc_integer_kinds[i].kind < kind)
3395 kind = gfc_integer_kinds[i].kind;
3397 if (kind == INT_MAX)
3400 result = gfc_int_expr (kind);
3401 result->where = e->where;
3408 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3410 int range, precision, i, kind, found_precision, found_range;
3417 if (p->expr_type != EXPR_CONSTANT
3418 || gfc_extract_int (p, &precision) != NULL)
3426 if (q->expr_type != EXPR_CONSTANT
3427 || gfc_extract_int (q, &range) != NULL)
3432 found_precision = 0;
3435 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3437 if (gfc_real_kinds[i].precision >= precision)
3438 found_precision = 1;
3440 if (gfc_real_kinds[i].range >= range)
3443 if (gfc_real_kinds[i].precision >= precision
3444 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3445 kind = gfc_real_kinds[i].kind;
3448 if (kind == INT_MAX)
3452 if (!found_precision)
3458 result = gfc_int_expr (kind);
3459 result->where = (p != NULL) ? p->where : q->where;
3466 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3469 mpfr_t exp, absv, log2, pow2, frac;
3472 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3475 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3477 gfc_set_model_kind (x->ts.kind);
3479 if (mpfr_sgn (x->value.real) == 0)
3481 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3491 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3492 mpfr_log2 (log2, absv, GFC_RND_MODE);
3494 mpfr_trunc (log2, log2);
3495 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3497 /* Old exponent value, and fraction. */
3498 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3500 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3503 exp2 = (unsigned long) mpz_get_d (i->value.integer);
3504 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3511 return range_check (result, "SET_EXPONENT");
3516 gfc_simplify_shape (gfc_expr *source)
3518 mpz_t shape[GFC_MAX_DIMENSIONS];
3519 gfc_expr *result, *e, *f;
3524 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3527 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3530 ar = gfc_find_array_ref (source);
3532 t = gfc_array_ref_shape (ar, shape);
3534 for (n = 0; n < source->rank; n++)
3536 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3541 mpz_set (e->value.integer, shape[n]);
3542 mpz_clear (shape[n]);
3546 mpz_set_ui (e->value.integer, n + 1);
3548 f = gfc_simplify_size (source, e);
3552 gfc_free_expr (result);
3561 gfc_append_constructor (result, e);
3569 gfc_simplify_size (gfc_expr *array, gfc_expr *dim)
3577 if (gfc_array_size (array, &size) == FAILURE)
3582 if (dim->expr_type != EXPR_CONSTANT)
3585 d = mpz_get_ui (dim->value.integer) - 1;
3586 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3590 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3593 mpz_set (result->value.integer, size);
3600 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
3604 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3607 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3612 mpz_abs (result->value.integer, x->value.integer);
3613 if (mpz_sgn (y->value.integer) < 0)
3614 mpz_neg (result->value.integer, result->value.integer);
3619 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3621 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3622 if (mpfr_sgn (y->value.real) < 0)
3623 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3628 gfc_internal_error ("Bad type in gfc_simplify_sign");
3636 gfc_simplify_sin (gfc_expr *x)
3641 if (x->expr_type != EXPR_CONSTANT)
3644 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3649 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3653 gfc_set_model (x->value.real);
3657 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
3658 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3659 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3661 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
3662 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3663 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3670 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3673 return range_check (result, "SIN");
3678 gfc_simplify_sinh (gfc_expr *x)
3682 if (x->expr_type != EXPR_CONSTANT)
3685 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3687 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
3689 return range_check (result, "SINH");
3693 /* The argument is always a double precision real that is converted to
3694 single precision. TODO: Rounding! */
3697 gfc_simplify_sngl (gfc_expr *a)
3701 if (a->expr_type != EXPR_CONSTANT)
3704 result = gfc_real2real (a, gfc_default_real_kind);
3705 return range_check (result, "SNGL");
3710 gfc_simplify_spacing (gfc_expr *x)
3716 if (x->expr_type != EXPR_CONSTANT)
3719 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3721 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3723 /* Special case x = 0 and -0. */
3724 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3725 if (mpfr_sgn (result->value.real) == 0)
3727 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3731 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3732 are the radix, exponent of x, and precision. This excludes the
3733 possibility of subnormal numbers. Fortran 2003 states the result is
3734 b**max(e - p, emin - 1). */
3736 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
3737 en = (long int) gfc_real_kinds[i].min_exponent - 1;
3738 en = en > ep ? en : ep;
3740 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3741 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
3743 return range_check (result, "SPACING");
3748 gfc_simplify_sqrt (gfc_expr *e)
3751 mpfr_t ac, ad, s, t, w;
3753 if (e->expr_type != EXPR_CONSTANT)
3756 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3761 if (mpfr_cmp_si (e->value.real, 0) < 0)
3763 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3768 /* Formula taken from Numerical Recipes to avoid over- and
3771 gfc_set_model (e->value.real);
3778 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3779 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3781 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3782 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3786 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3787 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3789 if (mpfr_cmp (ac, ad) >= 0)
3791 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3792 mpfr_mul (t, t, t, GFC_RND_MODE);
3793 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3794 mpfr_sqrt (t, t, GFC_RND_MODE);
3795 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3796 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3797 mpfr_sqrt (t, t, GFC_RND_MODE);
3798 mpfr_sqrt (s, ac, GFC_RND_MODE);
3799 mpfr_mul (w, s, t, GFC_RND_MODE);
3803 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3804 mpfr_mul (t, s, s, GFC_RND_MODE);
3805 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3806 mpfr_sqrt (t, t, GFC_RND_MODE);
3807 mpfr_abs (s, s, GFC_RND_MODE);
3808 mpfr_add (t, t, s, GFC_RND_MODE);
3809 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3810 mpfr_sqrt (t, t, GFC_RND_MODE);
3811 mpfr_sqrt (s, ad, GFC_RND_MODE);
3812 mpfr_mul (w, s, t, GFC_RND_MODE);
3815 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3817 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3818 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3819 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3821 else if (mpfr_cmp_ui (w, 0) != 0
3822 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3823 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3825 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3826 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3827 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3829 else if (mpfr_cmp_ui (w, 0) != 0
3830 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3831 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
3833 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3834 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
3835 mpfr_neg (w, w, GFC_RND_MODE);
3836 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3839 gfc_internal_error ("invalid complex argument of SQRT at %L",
3851 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
3854 return range_check (result, "SQRT");
3857 gfc_free_expr (result);
3858 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
3859 return &gfc_bad_expr;
3864 gfc_simplify_tan (gfc_expr *x)
3869 if (x->expr_type != EXPR_CONSTANT)
3872 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3874 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3876 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
3878 return range_check (result, "TAN");
3883 gfc_simplify_tanh (gfc_expr *x)
3887 if (x->expr_type != EXPR_CONSTANT)
3890 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3892 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
3894 return range_check (result, "TANH");
3900 gfc_simplify_tiny (gfc_expr *e)
3905 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
3907 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3908 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3915 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
3918 gfc_expr *mold_element;
3921 size_t result_elt_size;
3924 unsigned char *buffer;
3926 if (!gfc_is_constant_expr (source)
3927 || !gfc_is_constant_expr (size))
3930 /* Calculate the size of the source. */
3931 if (source->expr_type == EXPR_ARRAY
3932 && gfc_array_size (source, &tmp) == FAILURE)
3933 gfc_internal_error ("Failure getting length of a constant array.");
3935 source_size = gfc_target_expr_size (source);
3937 /* Create an empty new expression with the appropriate characteristics. */
3938 result = gfc_constant_result (mold->ts.type, mold->ts.kind,
3940 result->ts = mold->ts;
3942 mold_element = mold->expr_type == EXPR_ARRAY
3943 ? mold->value.constructor->expr
3946 /* Set result character length, if needed. Note that this needs to be
3947 set even for array expressions, in order to pass this information into
3948 gfc_target_interpret_expr. */
3949 if (result->ts.type == BT_CHARACTER)
3950 result->value.character.length = mold_element->value.character.length;
3952 /* Set the number of elements in the result, and determine its size. */
3953 result_elt_size = gfc_target_expr_size (mold_element);
3954 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
3958 result->expr_type = EXPR_ARRAY;
3962 result_length = (size_t)mpz_get_ui (size->value.integer);
3965 result_length = source_size / result_elt_size;
3966 if (result_length * result_elt_size < source_size)
3970 result->shape = gfc_get_shape (1);
3971 mpz_init_set_ui (result->shape[0], result_length);
3973 result_size = result_length * result_elt_size;
3978 result_size = result_elt_size;
3981 /* Allocate the buffer to store the binary version of the source. */
3982 buffer_size = MAX (source_size, result_size);
3983 buffer = (unsigned char*)alloca (buffer_size);
3985 /* Now write source to the buffer. */
3986 gfc_target_encode_expr (source, buffer, buffer_size);
3988 /* And read the buffer back into the new expression. */
3989 gfc_target_interpret_expr (buffer, buffer_size, result);
3996 gfc_simplify_trim (gfc_expr *e)
3999 int count, i, len, lentrim;
4001 if (e->expr_type != EXPR_CONSTANT)
4004 len = e->value.character.length;
4006 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4008 for (count = 0, i = 1; i <= len; ++i)
4010 if (e->value.character.string[len - i] == ' ')
4016 lentrim = len - count;
4018 result->value.character.length = lentrim;
4019 result->value.character.string = gfc_getmem (lentrim + 1);
4021 for (i = 0; i < lentrim; i++)
4022 result->value.character.string[i] = e->value.character.string[i];
4024 result->value.character.string[lentrim] = '\0'; /* For debugger */
4031 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim)
4033 return simplify_bound (array, dim, 1);
4038 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b)
4042 size_t index, len, lenset;
4045 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4048 if (b != NULL && b->value.logical != 0)
4053 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
4056 len = s->value.character.length;
4057 lenset = set->value.character.length;
4061 mpz_set_ui (result->value.integer, 0);
4069 mpz_set_ui (result->value.integer, 1);
4073 index = strspn (s->value.character.string, set->value.character.string)
4083 mpz_set_ui (result->value.integer, len);
4086 for (index = len; index > 0; index --)
4088 for (i = 0; i < lenset; i++)
4090 if (s->value.character.string[index - 1]
4091 == set->value.character.string[i])
4099 mpz_set_ui (result->value.integer, index);
4105 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4110 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4113 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4114 if (x->ts.type == BT_INTEGER)
4116 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4117 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4119 else /* BT_LOGICAL */
4121 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4122 result->value.logical = (x->value.logical && !y->value.logical)
4123 || (!x->value.logical && y->value.logical);
4126 return range_check (result, "XOR");
4130 /****************** Constant simplification *****************/
4132 /* Master function to convert one constant to another. While this is
4133 used as a simplification function, it requires the destination type
4134 and kind information which is supplied by a special case in
4138 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4140 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4141 gfc_constructor *head, *c, *tail = NULL;
4155 f = gfc_int2complex;
4175 f = gfc_real2complex;
4186 f = gfc_complex2int;
4189 f = gfc_complex2real;
4192 f = gfc_complex2complex;
4218 f = gfc_hollerith2int;
4222 f = gfc_hollerith2real;
4226 f = gfc_hollerith2complex;
4230 f = gfc_hollerith2character;
4234 f = gfc_hollerith2logical;
4244 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4249 switch (e->expr_type)
4252 result = f (e, kind);
4254 return &gfc_bad_expr;
4258 if (!gfc_is_constant_expr (e))
4263 for (c = e->value.constructor; c; c = c->next)
4266 head = tail = gfc_get_constructor ();
4269 tail->next = gfc_get_constructor ();
4273 tail->where = c->where;
4275 if (c->iterator == NULL)
4276 tail->expr = f (c->expr, kind);
4279 g = gfc_convert_constant (c->expr, type, kind);
4280 if (g == &gfc_bad_expr)
4285 if (tail->expr == NULL)
4287 gfc_free_constructor (head);
4292 result = gfc_get_expr ();
4293 result->ts.type = type;
4294 result->ts.kind = kind;
4295 result->expr_type = EXPR_ARRAY;
4296 result->value.constructor = head;
4297 result->shape = gfc_copy_shape (e->shape, e->rank);
4298 result->where = e->where;
4299 result->rank = e->rank;