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)
266 if (e->expr_type != EXPR_CONSTANT)
269 ch = gfc_extract_int (e, &c);
272 gfc_internal_error ("gfc_simplify_achar: %s", ch);
274 if (gfc_option.warn_surprising && (c < 0 || c > 127))
275 gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
278 result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
281 result->value.character.string = gfc_getmem (2);
283 result->value.character.length = 1;
284 result->value.character.string[0] = c;
285 result->value.character.string[1] = '\0'; /* For debugger */
291 gfc_simplify_acos (gfc_expr *x)
295 if (x->expr_type != EXPR_CONSTANT)
298 if (mpfr_cmp_si (x->value.real, 1) > 0
299 || mpfr_cmp_si (x->value.real, -1) < 0)
301 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
303 return &gfc_bad_expr;
306 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
308 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
310 return range_check (result, "ACOS");
314 gfc_simplify_acosh (gfc_expr *x)
318 if (x->expr_type != EXPR_CONSTANT)
321 if (mpfr_cmp_si (x->value.real, 1) < 0)
323 gfc_error ("Argument of ACOSH at %L must not be less than 1",
325 return &gfc_bad_expr;
328 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
330 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
332 return range_check (result, "ACOSH");
336 gfc_simplify_adjustl (gfc_expr *e)
342 if (e->expr_type != EXPR_CONSTANT)
345 len = e->value.character.length;
347 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
349 result->value.character.length = len;
350 result->value.character.string = gfc_getmem (len + 1);
352 for (count = 0, i = 0; i < len; ++i)
354 ch = e->value.character.string[i];
360 for (i = 0; i < len - count; ++i)
361 result->value.character.string[i] = e->value.character.string[count + i];
363 for (i = len - count; i < len; ++i)
364 result->value.character.string[i] = ' ';
366 result->value.character.string[len] = '\0'; /* For debugger */
373 gfc_simplify_adjustr (gfc_expr *e)
379 if (e->expr_type != EXPR_CONSTANT)
382 len = e->value.character.length;
384 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
386 result->value.character.length = len;
387 result->value.character.string = gfc_getmem (len + 1);
389 for (count = 0, i = len - 1; i >= 0; --i)
391 ch = e->value.character.string[i];
397 for (i = 0; i < count; ++i)
398 result->value.character.string[i] = ' ';
400 for (i = count; i < len; ++i)
401 result->value.character.string[i] = e->value.character.string[i - count];
403 result->value.character.string[len] = '\0'; /* For debugger */
410 gfc_simplify_aimag (gfc_expr *e)
414 if (e->expr_type != EXPR_CONSTANT)
417 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
418 mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
420 return range_check (result, "AIMAG");
425 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
427 gfc_expr *rtrunc, *result;
430 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
432 return &gfc_bad_expr;
434 if (e->expr_type != EXPR_CONSTANT)
437 rtrunc = gfc_copy_expr (e);
439 mpfr_trunc (rtrunc->value.real, e->value.real);
441 result = gfc_real2real (rtrunc, kind);
442 gfc_free_expr (rtrunc);
444 return range_check (result, "AINT");
449 gfc_simplify_dint (gfc_expr *e)
451 gfc_expr *rtrunc, *result;
453 if (e->expr_type != EXPR_CONSTANT)
456 rtrunc = gfc_copy_expr (e);
458 mpfr_trunc (rtrunc->value.real, e->value.real);
460 result = gfc_real2real (rtrunc, gfc_default_double_kind);
461 gfc_free_expr (rtrunc);
463 return range_check (result, "DINT");
468 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
473 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
475 return &gfc_bad_expr;
477 if (e->expr_type != EXPR_CONSTANT)
480 result = gfc_constant_result (e->ts.type, kind, &e->where);
482 mpfr_round (result->value.real, e->value.real);
484 return range_check (result, "ANINT");
489 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
494 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
497 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
498 if (x->ts.type == BT_INTEGER)
500 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
501 mpz_and (result->value.integer, x->value.integer, y->value.integer);
503 else /* BT_LOGICAL */
505 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
506 result->value.logical = x->value.logical && y->value.logical;
509 return range_check (result, "AND");
514 gfc_simplify_dnint (gfc_expr *e)
518 if (e->expr_type != EXPR_CONSTANT)
521 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
523 mpfr_round (result->value.real, e->value.real);
525 return range_check (result, "DNINT");
530 gfc_simplify_asin (gfc_expr *x)
534 if (x->expr_type != EXPR_CONSTANT)
537 if (mpfr_cmp_si (x->value.real, 1) > 0
538 || mpfr_cmp_si (x->value.real, -1) < 0)
540 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
542 return &gfc_bad_expr;
545 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
547 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
549 return range_check (result, "ASIN");
554 gfc_simplify_asinh (gfc_expr *x)
558 if (x->expr_type != EXPR_CONSTANT)
561 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
563 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
565 return range_check (result, "ASINH");
570 gfc_simplify_atan (gfc_expr *x)
574 if (x->expr_type != EXPR_CONSTANT)
577 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
579 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
581 return range_check (result, "ATAN");
586 gfc_simplify_atanh (gfc_expr *x)
590 if (x->expr_type != EXPR_CONSTANT)
593 if (mpfr_cmp_si (x->value.real, 1) >= 0
594 || mpfr_cmp_si (x->value.real, -1) <= 0)
596 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
598 return &gfc_bad_expr;
601 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
603 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
605 return range_check (result, "ATANH");
610 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
614 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
617 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
619 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
621 gfc_error ("If first argument of ATAN2 %L is zero, then the "
622 "second argument must not be zero", &x->where);
623 gfc_free_expr (result);
624 return &gfc_bad_expr;
627 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
629 return range_check (result, "ATAN2");
634 gfc_simplify_bit_size (gfc_expr *e)
639 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
640 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
641 mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
648 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
652 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
655 if (gfc_extract_int (bit, &b) != NULL || b < 0)
656 return gfc_logical_expr (0, &e->where);
658 return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
663 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
665 gfc_expr *ceil, *result;
668 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
670 return &gfc_bad_expr;
672 if (e->expr_type != EXPR_CONSTANT)
675 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
677 ceil = gfc_copy_expr (e);
679 mpfr_ceil (ceil->value.real, e->value.real);
680 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
682 gfc_free_expr (ceil);
684 return range_check (result, "CEILING");
689 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
695 kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
697 return &gfc_bad_expr;
699 if (e->expr_type != EXPR_CONSTANT)
702 ch = gfc_extract_int (e, &c);
705 gfc_internal_error ("gfc_simplify_char: %s", ch);
707 if (c < 0 || c > UCHAR_MAX)
708 gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
711 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
713 result->value.character.length = 1;
714 result->value.character.string = gfc_getmem (2);
716 result->value.character.string[0] = c;
717 result->value.character.string[1] = '\0'; /* For debugger */
723 /* Common subroutine for simplifying CMPLX and DCMPLX. */
726 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
730 result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
732 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
737 mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
741 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
745 mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
746 mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
750 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
758 mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
762 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
766 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
770 return range_check (result, name);
775 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
779 if (x->expr_type != EXPR_CONSTANT
780 || (y != NULL && y->expr_type != EXPR_CONSTANT))
783 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
785 return &gfc_bad_expr;
787 return simplify_cmplx ("CMPLX", x, y, kind);
792 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
796 if (x->expr_type != EXPR_CONSTANT
797 || (y != NULL && y->expr_type != EXPR_CONSTANT))
800 if (x->ts.type == BT_INTEGER)
802 if (y->ts.type == BT_INTEGER)
803 kind = gfc_default_real_kind;
809 if (y->ts.type == BT_REAL)
810 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
815 return simplify_cmplx ("COMPLEX", x, y, kind);
820 gfc_simplify_conjg (gfc_expr *e)
824 if (e->expr_type != EXPR_CONSTANT)
827 result = gfc_copy_expr (e);
828 mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
830 return range_check (result, "CONJG");
835 gfc_simplify_cos (gfc_expr *x)
840 if (x->expr_type != EXPR_CONSTANT)
843 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
848 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
851 gfc_set_model_kind (x->ts.kind);
855 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
856 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
857 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
859 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
860 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
861 mpfr_mul (xp, xp, xq, GFC_RND_MODE);
862 mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
868 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
871 return range_check (result, "COS");
877 gfc_simplify_cosh (gfc_expr *x)
881 if (x->expr_type != EXPR_CONSTANT)
884 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
886 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
888 return range_check (result, "COSH");
893 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
896 if (x->expr_type != EXPR_CONSTANT
897 || (y != NULL && y->expr_type != EXPR_CONSTANT))
900 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
905 gfc_simplify_dble (gfc_expr *e)
909 if (e->expr_type != EXPR_CONSTANT)
915 result = gfc_int2real (e, gfc_default_double_kind);
919 result = gfc_real2real (e, gfc_default_double_kind);
923 result = gfc_complex2real (e, gfc_default_double_kind);
927 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
930 return range_check (result, "DBLE");
935 gfc_simplify_digits (gfc_expr *x)
939 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
943 digits = gfc_integer_kinds[i].digits;
948 digits = gfc_real_kinds[i].digits;
955 return gfc_int_expr (digits);
960 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
965 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
968 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
969 result = gfc_constant_result (x->ts.type, kind, &x->where);
974 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
975 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
977 mpz_set_ui (result->value.integer, 0);
982 if (mpfr_cmp (x->value.real, y->value.real) > 0)
983 mpfr_sub (result->value.real, x->value.real, y->value.real,
986 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
991 gfc_internal_error ("gfc_simplify_dim(): Bad type");
994 return range_check (result, "DIM");
999 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1001 gfc_expr *a1, *a2, *result;
1003 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1006 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1008 a1 = gfc_real2real (x, gfc_default_double_kind);
1009 a2 = gfc_real2real (y, gfc_default_double_kind);
1011 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1016 return range_check (result, "DPROD");
1021 gfc_simplify_epsilon (gfc_expr *e)
1026 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1028 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1030 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1032 return range_check (result, "EPSILON");
1037 gfc_simplify_exp (gfc_expr *x)
1042 if (x->expr_type != EXPR_CONSTANT)
1045 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1050 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1054 gfc_set_model_kind (x->ts.kind);
1057 mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1058 mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1059 mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1060 mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1061 mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1067 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1070 return range_check (result, "EXP");
1074 gfc_simplify_exponent (gfc_expr *x)
1079 if (x->expr_type != EXPR_CONSTANT)
1082 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1085 gfc_set_model (x->value.real);
1087 if (mpfr_sgn (x->value.real) == 0)
1089 mpz_set_ui (result->value.integer, 0);
1093 i = (int) mpfr_get_exp (x->value.real);
1094 mpz_set_si (result->value.integer, i);
1096 return range_check (result, "EXPONENT");
1101 gfc_simplify_float (gfc_expr *a)
1105 if (a->expr_type != EXPR_CONSTANT)
1108 result = gfc_int2real (a, gfc_default_real_kind);
1109 return range_check (result, "FLOAT");
1114 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1120 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1122 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1124 if (e->expr_type != EXPR_CONSTANT)
1127 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1129 gfc_set_model_kind (kind);
1131 mpfr_floor (floor, e->value.real);
1133 gfc_mpfr_to_mpz (result->value.integer, floor);
1137 return range_check (result, "FLOOR");
1142 gfc_simplify_fraction (gfc_expr *x)
1145 mpfr_t absv, exp, pow2;
1147 if (x->expr_type != EXPR_CONSTANT)
1150 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1152 gfc_set_model_kind (x->ts.kind);
1154 if (mpfr_sgn (x->value.real) == 0)
1156 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1164 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1165 mpfr_log2 (exp, absv, GFC_RND_MODE);
1167 mpfr_trunc (exp, exp);
1168 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1170 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1172 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1178 return range_check (result, "FRACTION");
1183 gfc_simplify_huge (gfc_expr *e)
1188 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1190 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1195 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1199 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1209 /* We use the processor's collating sequence, because all
1210 systems that gfortran currently works on are ASCII. */
1213 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
1218 if (e->expr_type != EXPR_CONSTANT)
1221 if (e->value.character.length != 1)
1223 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1224 return &gfc_bad_expr;
1227 index = (unsigned char) e->value.character.string[0];
1229 if (gfc_option.warn_surprising && index > 127)
1230 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1233 if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
1234 return &gfc_bad_expr;
1236 result->where = e->where;
1238 return range_check (result, "IACHAR");
1243 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1247 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1250 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1252 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1254 return range_check (result, "IAND");
1259 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1264 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1267 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1269 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1270 return &gfc_bad_expr;
1273 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1275 if (pos >= gfc_integer_kinds[k].bit_size)
1277 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1279 return &gfc_bad_expr;
1282 result = gfc_copy_expr (x);
1284 convert_mpz_to_unsigned (result->value.integer,
1285 gfc_integer_kinds[k].bit_size);
1287 mpz_clrbit (result->value.integer, pos);
1289 convert_mpz_to_signed (result->value.integer,
1290 gfc_integer_kinds[k].bit_size);
1292 return range_check (result, "IBCLR");
1297 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1304 if (x->expr_type != EXPR_CONSTANT
1305 || y->expr_type != EXPR_CONSTANT
1306 || z->expr_type != EXPR_CONSTANT)
1309 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1311 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1312 return &gfc_bad_expr;
1315 if (gfc_extract_int (z, &len) != NULL || len < 0)
1317 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1318 return &gfc_bad_expr;
1321 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1323 bitsize = gfc_integer_kinds[k].bit_size;
1325 if (pos + len > bitsize)
1327 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1328 "bit size at %L", &y->where);
1329 return &gfc_bad_expr;
1332 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1334 bits = gfc_getmem (bitsize * sizeof (int));
1336 for (i = 0; i < bitsize; i++)
1339 for (i = 0; i < len; i++)
1340 bits[i] = mpz_tstbit (x->value.integer, i + pos);
1342 for (i = 0; i < bitsize; i++)
1345 mpz_clrbit (result->value.integer, i);
1346 else if (bits[i] == 1)
1347 mpz_setbit (result->value.integer, i);
1349 gfc_internal_error ("IBITS: Bad bit");
1354 return range_check (result, "IBITS");
1359 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1364 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1367 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1369 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1370 return &gfc_bad_expr;
1373 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1375 if (pos >= gfc_integer_kinds[k].bit_size)
1377 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1379 return &gfc_bad_expr;
1382 result = gfc_copy_expr (x);
1384 convert_mpz_to_unsigned (result->value.integer,
1385 gfc_integer_kinds[k].bit_size);
1387 mpz_setbit (result->value.integer, pos);
1389 convert_mpz_to_signed (result->value.integer,
1390 gfc_integer_kinds[k].bit_size);
1392 return range_check (result, "IBSET");
1397 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
1402 if (e->expr_type != EXPR_CONSTANT)
1405 if (e->value.character.length != 1)
1407 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1408 return &gfc_bad_expr;
1411 index = (unsigned char) e->value.character.string[0];
1413 if (index < 0 || index > UCHAR_MAX)
1414 gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
1416 if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
1417 return &gfc_bad_expr;
1419 result->where = e->where;
1420 return range_check (result, "ICHAR");
1425 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
1429 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1432 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1434 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1436 return range_check (result, "IEOR");
1441 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
1444 int back, len, lensub;
1445 int i, j, k, count, index = 0, start;
1447 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1450 if (b != NULL && b->value.logical != 0)
1455 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
1457 return &gfc_bad_expr;
1459 result = gfc_constant_result (BT_INTEGER, k, &x->where);
1461 len = x->value.character.length;
1462 lensub = y->value.character.length;
1466 mpz_set_si (result->value.integer, 0);
1474 mpz_set_si (result->value.integer, 1);
1477 else if (lensub == 1)
1479 for (i = 0; i < len; i++)
1481 for (j = 0; j < lensub; j++)
1483 if (y->value.character.string[j]
1484 == x->value.character.string[i])
1494 for (i = 0; i < len; i++)
1496 for (j = 0; j < lensub; j++)
1498 if (y->value.character.string[j]
1499 == x->value.character.string[i])
1504 for (k = 0; k < lensub; k++)
1506 if (y->value.character.string[k]
1507 == x->value.character.string[k + start])
1511 if (count == lensub)
1526 mpz_set_si (result->value.integer, len + 1);
1529 else if (lensub == 1)
1531 for (i = 0; i < len; i++)
1533 for (j = 0; j < lensub; j++)
1535 if (y->value.character.string[j]
1536 == x->value.character.string[len - i])
1538 index = len - i + 1;
1546 for (i = 0; i < len; i++)
1548 for (j = 0; j < lensub; j++)
1550 if (y->value.character.string[j]
1551 == x->value.character.string[len - i])
1554 if (start <= len - lensub)
1557 for (k = 0; k < lensub; k++)
1558 if (y->value.character.string[k]
1559 == x->value.character.string[k + start])
1562 if (count == lensub)
1579 mpz_set_si (result->value.integer, index);
1580 return range_check (result, "INDEX");
1585 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
1587 gfc_expr *rpart, *rtrunc, *result;
1590 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1592 return &gfc_bad_expr;
1594 if (e->expr_type != EXPR_CONSTANT)
1597 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1602 mpz_set (result->value.integer, e->value.integer);
1606 rtrunc = gfc_copy_expr (e);
1607 mpfr_trunc (rtrunc->value.real, e->value.real);
1608 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1609 gfc_free_expr (rtrunc);
1613 rpart = gfc_complex2real (e, kind);
1614 rtrunc = gfc_copy_expr (rpart);
1615 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1616 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1617 gfc_free_expr (rpart);
1618 gfc_free_expr (rtrunc);
1622 gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1623 gfc_free_expr (result);
1624 return &gfc_bad_expr;
1627 return range_check (result, "INT");
1632 gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
1634 gfc_expr *rpart, *rtrunc, *result;
1636 if (e->expr_type != EXPR_CONSTANT)
1639 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1644 mpz_set (result->value.integer, e->value.integer);
1648 rtrunc = gfc_copy_expr (e);
1649 mpfr_trunc (rtrunc->value.real, e->value.real);
1650 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1651 gfc_free_expr (rtrunc);
1655 rpart = gfc_complex2real (e, kind);
1656 rtrunc = gfc_copy_expr (rpart);
1657 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1658 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1659 gfc_free_expr (rpart);
1660 gfc_free_expr (rtrunc);
1664 gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
1665 gfc_free_expr (result);
1666 return &gfc_bad_expr;
1669 return range_check (result, name);
1674 gfc_simplify_int2 (gfc_expr *e)
1676 return gfc_simplify_intconv (e, 2, "INT2");
1681 gfc_simplify_int8 (gfc_expr *e)
1683 return gfc_simplify_intconv (e, 8, "INT8");
1688 gfc_simplify_long (gfc_expr *e)
1690 return gfc_simplify_intconv (e, 4, "LONG");
1695 gfc_simplify_ifix (gfc_expr *e)
1697 gfc_expr *rtrunc, *result;
1699 if (e->expr_type != EXPR_CONSTANT)
1702 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1705 rtrunc = gfc_copy_expr (e);
1707 mpfr_trunc (rtrunc->value.real, e->value.real);
1708 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1710 gfc_free_expr (rtrunc);
1711 return range_check (result, "IFIX");
1716 gfc_simplify_idint (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, "IDINT");
1737 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
1741 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1744 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1746 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1747 return range_check (result, "IOR");
1752 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
1755 int shift, ashift, isize, k, *bits, i;
1757 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1760 if (gfc_extract_int (s, &shift) != NULL)
1762 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
1763 return &gfc_bad_expr;
1766 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
1768 isize = gfc_integer_kinds[k].bit_size;
1777 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
1778 "at %L", &s->where);
1779 return &gfc_bad_expr;
1782 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1786 mpz_set (result->value.integer, e->value.integer);
1787 return range_check (result, "ISHFT");
1790 bits = gfc_getmem (isize * sizeof (int));
1792 for (i = 0; i < isize; i++)
1793 bits[i] = mpz_tstbit (e->value.integer, i);
1797 for (i = 0; i < shift; i++)
1798 mpz_clrbit (result->value.integer, i);
1800 for (i = 0; i < isize - shift; i++)
1803 mpz_clrbit (result->value.integer, i + shift);
1805 mpz_setbit (result->value.integer, i + shift);
1810 for (i = isize - 1; i >= isize - ashift; i--)
1811 mpz_clrbit (result->value.integer, i);
1813 for (i = isize - 1; i >= ashift; i--)
1816 mpz_clrbit (result->value.integer, i - ashift);
1818 mpz_setbit (result->value.integer, i - ashift);
1822 convert_mpz_to_signed (result->value.integer, isize);
1830 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
1833 int shift, ashift, isize, ssize, delta, k;
1836 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1839 if (gfc_extract_int (s, &shift) != NULL)
1841 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
1842 return &gfc_bad_expr;
1845 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1846 isize = gfc_integer_kinds[k].bit_size;
1850 if (sz->expr_type != EXPR_CONSTANT)
1853 if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
1855 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
1856 return &gfc_bad_expr;
1861 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
1862 "BIT_SIZE of first argument at %L", &s->where);
1863 return &gfc_bad_expr;
1877 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1878 "third argument at %L", &s->where);
1880 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1881 "BIT_SIZE of first argument at %L", &s->where);
1882 return &gfc_bad_expr;
1885 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1887 mpz_set (result->value.integer, e->value.integer);
1892 convert_mpz_to_unsigned (result->value.integer, isize);
1894 bits = gfc_getmem (ssize * sizeof (int));
1896 for (i = 0; i < ssize; i++)
1897 bits[i] = mpz_tstbit (e->value.integer, i);
1899 delta = ssize - ashift;
1903 for (i = 0; i < delta; i++)
1906 mpz_clrbit (result->value.integer, i + shift);
1908 mpz_setbit (result->value.integer, i + shift);
1911 for (i = delta; i < ssize; i++)
1914 mpz_clrbit (result->value.integer, i - delta);
1916 mpz_setbit (result->value.integer, i - delta);
1921 for (i = 0; i < ashift; i++)
1924 mpz_clrbit (result->value.integer, i + delta);
1926 mpz_setbit (result->value.integer, i + delta);
1929 for (i = ashift; i < ssize; i++)
1932 mpz_clrbit (result->value.integer, i + shift);
1934 mpz_setbit (result->value.integer, i + shift);
1938 convert_mpz_to_signed (result->value.integer, isize);
1946 gfc_simplify_kind (gfc_expr *e)
1949 if (e->ts.type == BT_DERIVED)
1951 gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
1952 return &gfc_bad_expr;
1955 return gfc_int_expr (e->ts.kind);
1960 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
1963 gfc_expr *l, *u, *result;
1966 /* The last dimension of an assumed-size array is special. */
1967 if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
1969 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
1970 return gfc_copy_expr (as->lower[d-1]);
1975 /* Then, we need to know the extent of the given dimension. */
1979 if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
1982 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
1983 gfc_default_integer_kind);
1985 return &gfc_bad_expr;
1987 result = gfc_constant_result (BT_INTEGER, k, &array->where);
1989 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
1993 mpz_set_si (result->value.integer, 0);
1995 mpz_set_si (result->value.integer, 1);
1999 /* Nonzero extent. */
2001 mpz_set (result->value.integer, u->value.integer);
2003 mpz_set (result->value.integer, l->value.integer);
2006 return range_check (result, upper ? "UBOUND" : "LBOUND");
2011 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2017 if (array->expr_type != EXPR_VARIABLE)
2020 /* Follow any component references. */
2021 as = array->symtree->n.sym->as;
2022 for (ref = array->ref; ref; ref = ref->next)
2027 switch (ref->u.ar.type)
2034 /* We're done because 'as' has already been set in the
2035 previous iteration. */
2046 as = ref->u.c.component->as;
2058 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2063 /* Multi-dimensional bounds. */
2064 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2066 gfc_constructor *head, *tail;
2069 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2070 if (upper && as->type == AS_ASSUMED_SIZE)
2072 /* An error message will be emitted in
2073 check_assumed_size_reference (resolve.c). */
2074 return &gfc_bad_expr;
2077 /* Simplify the bounds for each dimension. */
2078 for (d = 0; d < array->rank; d++)
2080 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
2081 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2085 for (j = 0; j < d; j++)
2086 gfc_free_expr (bounds[j]);
2091 /* Allocate the result expression. */
2092 e = gfc_get_expr ();
2093 e->where = array->where;
2094 e->expr_type = EXPR_ARRAY;
2095 e->ts.type = BT_INTEGER;
2096 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2097 gfc_default_integer_kind);
2099 return &gfc_bad_expr;
2102 /* The result is a rank 1 array; its size is the rank of the first
2103 argument to {L,U}BOUND. */
2105 e->shape = gfc_get_shape (1);
2106 mpz_init_set_ui (e->shape[0], array->rank);
2108 /* Create the constructor for this array. */
2110 for (d = 0; d < array->rank; d++)
2112 /* Get a new constructor element. */
2114 head = tail = gfc_get_constructor ();
2117 tail->next = gfc_get_constructor ();
2121 tail->where = e->where;
2122 tail->expr = bounds[d];
2124 e->value.constructor = head;
2130 /* A DIM argument is specified. */
2131 if (dim->expr_type != EXPR_CONSTANT)
2134 d = mpz_get_si (dim->value.integer);
2136 if (d < 1 || d > as->rank
2137 || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2139 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2140 return &gfc_bad_expr;
2143 return simplify_bound_dim (array, kind, d, upper, as);
2149 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2151 return simplify_bound (array, dim, kind, 0);
2156 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
2159 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
2162 return &gfc_bad_expr;
2164 if (e->expr_type == EXPR_CONSTANT)
2166 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2167 mpz_set_si (result->value.integer, e->value.character.length);
2168 return range_check (result, "LEN");
2171 if (e->ts.cl != NULL && e->ts.cl->length != NULL
2172 && e->ts.cl->length->expr_type == EXPR_CONSTANT
2173 && e->ts.cl->length->ts.type == BT_INTEGER)
2175 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2176 mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2177 return range_check (result, "LEN");
2185 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
2188 int count, len, lentrim, i;
2189 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
2192 return &gfc_bad_expr;
2194 if (e->expr_type != EXPR_CONSTANT)
2197 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2198 len = e->value.character.length;
2200 for (count = 0, i = 1; i <= len; i++)
2201 if (e->value.character.string[len - i] == ' ')
2206 lentrim = len - count;
2208 mpz_set_si (result->value.integer, lentrim);
2209 return range_check (result, "LEN_TRIM");
2214 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
2216 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2219 return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
2224 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
2226 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2229 return gfc_logical_expr (gfc_compare_string (a, b) > 0,
2235 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
2237 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2240 return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
2245 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
2247 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2250 return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
2255 gfc_simplify_log (gfc_expr *x)
2260 if (x->expr_type != EXPR_CONSTANT)
2263 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2265 gfc_set_model_kind (x->ts.kind);
2270 if (mpfr_sgn (x->value.real) <= 0)
2272 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2273 "to zero", &x->where);
2274 gfc_free_expr (result);
2275 return &gfc_bad_expr;
2278 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
2282 if ((mpfr_sgn (x->value.complex.r) == 0)
2283 && (mpfr_sgn (x->value.complex.i) == 0))
2285 gfc_error ("Complex argument of LOG at %L cannot be zero",
2287 gfc_free_expr (result);
2288 return &gfc_bad_expr;
2294 mpfr_atan2 (result->value.complex.i, x->value.complex.i,
2295 x->value.complex.r, GFC_RND_MODE);
2297 mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2298 mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2299 mpfr_add (xr, xr, xi, GFC_RND_MODE);
2300 mpfr_sqrt (xr, xr, GFC_RND_MODE);
2301 mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2309 gfc_internal_error ("gfc_simplify_log: bad type");
2312 return range_check (result, "LOG");
2317 gfc_simplify_log10 (gfc_expr *x)
2321 if (x->expr_type != EXPR_CONSTANT)
2324 gfc_set_model_kind (x->ts.kind);
2326 if (mpfr_sgn (x->value.real) <= 0)
2328 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2329 "to zero", &x->where);
2330 return &gfc_bad_expr;
2333 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2335 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2337 return range_check (result, "LOG10");
2342 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
2347 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2349 return &gfc_bad_expr;
2351 if (e->expr_type != EXPR_CONSTANT)
2354 result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2356 result->value.logical = e->value.logical;
2362 /* This function is special since MAX() can take any number of
2363 arguments. The simplified expression is a rewritten version of the
2364 argument list containing at most one constant element. Other
2365 constant elements are deleted. Because the argument list has
2366 already been checked, this function always succeeds. sign is 1 for
2367 MAX(), -1 for MIN(). */
2370 simplify_min_max (gfc_expr *expr, int sign)
2372 gfc_actual_arglist *arg, *last, *extremum;
2373 gfc_intrinsic_sym * specific;
2377 specific = expr->value.function.isym;
2379 arg = expr->value.function.actual;
2381 for (; arg; last = arg, arg = arg->next)
2383 if (arg->expr->expr_type != EXPR_CONSTANT)
2386 if (extremum == NULL)
2392 switch (arg->expr->ts.type)
2395 if (mpz_cmp (arg->expr->value.integer,
2396 extremum->expr->value.integer) * sign > 0)
2397 mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2401 if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real)
2403 mpfr_set (extremum->expr->value.real, arg->expr->value.real,
2408 #define LENGTH(x) ((x)->expr->value.character.length)
2409 #define STRING(x) ((x)->expr->value.character.string)
2410 if (LENGTH(extremum) < LENGTH(arg))
2412 char * tmp = STRING(extremum);
2414 STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
2415 memcpy (STRING(extremum), tmp, LENGTH(extremum));
2416 memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2417 LENGTH(arg) - LENGTH(extremum));
2418 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
2419 LENGTH(extremum) = LENGTH(arg);
2423 if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
2425 gfc_free (STRING(extremum));
2426 STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
2427 memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
2428 memset (&STRING(extremum)[LENGTH(arg)], ' ',
2429 LENGTH(extremum) - LENGTH(arg));
2430 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
2438 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2441 /* Delete the extra constant argument. */
2443 expr->value.function.actual = arg->next;
2445 last->next = arg->next;
2448 gfc_free_actual_arglist (arg);
2452 /* If there is one value left, replace the function call with the
2454 if (expr->value.function.actual->next != NULL)
2457 /* Convert to the correct type and kind. */
2458 if (expr->ts.type != BT_UNKNOWN)
2459 return gfc_convert_constant (expr->value.function.actual->expr,
2460 expr->ts.type, expr->ts.kind);
2462 if (specific->ts.type != BT_UNKNOWN)
2463 return gfc_convert_constant (expr->value.function.actual->expr,
2464 specific->ts.type, specific->ts.kind);
2466 return gfc_copy_expr (expr->value.function.actual->expr);
2471 gfc_simplify_min (gfc_expr *e)
2473 return simplify_min_max (e, -1);
2478 gfc_simplify_max (gfc_expr *e)
2480 return simplify_min_max (e, 1);
2485 gfc_simplify_maxexponent (gfc_expr *x)
2490 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2492 result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2493 result->where = x->where;
2500 gfc_simplify_minexponent (gfc_expr *x)
2505 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2507 result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2508 result->where = x->where;
2515 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2518 mpfr_t quot, iquot, term;
2521 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2524 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2525 result = gfc_constant_result (a->ts.type, kind, &a->where);
2530 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2532 /* Result is processor-dependent. */
2533 gfc_error ("Second argument MOD at %L is zero", &a->where);
2534 gfc_free_expr (result);
2535 return &gfc_bad_expr;
2537 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2541 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2543 /* Result is processor-dependent. */
2544 gfc_error ("Second argument of MOD at %L is zero", &p->where);
2545 gfc_free_expr (result);
2546 return &gfc_bad_expr;
2549 gfc_set_model_kind (kind);
2554 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2555 mpfr_trunc (iquot, quot);
2556 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2557 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2565 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2568 return range_check (result, "MOD");
2573 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2576 mpfr_t quot, iquot, term;
2579 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2582 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2583 result = gfc_constant_result (a->ts.type, kind, &a->where);
2588 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2590 /* Result is processor-dependent. This processor just opts
2591 to not handle it at all. */
2592 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2593 gfc_free_expr (result);
2594 return &gfc_bad_expr;
2596 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2601 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2603 /* Result is processor-dependent. */
2604 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2605 gfc_free_expr (result);
2606 return &gfc_bad_expr;
2609 gfc_set_model_kind (kind);
2614 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2615 mpfr_floor (iquot, quot);
2616 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2617 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2625 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2628 return range_check (result, "MODULO");
2632 /* Exists for the sole purpose of consistency with other intrinsics. */
2634 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
2635 gfc_expr *fp ATTRIBUTE_UNUSED,
2636 gfc_expr *l ATTRIBUTE_UNUSED,
2637 gfc_expr *to ATTRIBUTE_UNUSED,
2638 gfc_expr *tp ATTRIBUTE_UNUSED)
2645 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
2651 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2654 if (mpfr_sgn (s->value.real) == 0)
2656 gfc_error ("Second argument of NEAREST at %L shall not be zero",
2658 return &gfc_bad_expr;
2661 gfc_set_model_kind (x->ts.kind);
2662 result = gfc_copy_expr (x);
2664 sgn = mpfr_sgn (s->value.real);
2666 mpfr_set_inf (tmp, sgn);
2667 mpfr_nexttoward (result->value.real, tmp);
2670 return range_check (result, "NEAREST");
2675 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
2677 gfc_expr *itrunc, *result;
2680 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2682 return &gfc_bad_expr;
2684 if (e->expr_type != EXPR_CONSTANT)
2687 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2689 itrunc = gfc_copy_expr (e);
2691 mpfr_round (itrunc->value.real, e->value.real);
2693 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
2695 gfc_free_expr (itrunc);
2697 return range_check (result, name);
2702 gfc_simplify_new_line (gfc_expr *e)
2706 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2707 result->value.character.string = gfc_getmem (2);
2708 result->value.character.length = 1;
2709 result->value.character.string[0] = '\n';
2710 result->value.character.string[1] = '\0'; /* For debugger */
2716 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
2718 return simplify_nint ("NINT", e, k);
2723 gfc_simplify_idnint (gfc_expr *e)
2725 return simplify_nint ("IDNINT", e, NULL);
2730 gfc_simplify_not (gfc_expr *e)
2734 if (e->expr_type != EXPR_CONSTANT)
2737 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2739 mpz_com (result->value.integer, e->value.integer);
2741 return range_check (result, "NOT");
2746 gfc_simplify_null (gfc_expr *mold)
2752 result = gfc_get_expr ();
2753 result->ts.type = BT_UNKNOWN;
2756 result = gfc_copy_expr (mold);
2757 result->expr_type = EXPR_NULL;
2764 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
2769 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2772 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2773 if (x->ts.type == BT_INTEGER)
2775 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
2776 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2778 else /* BT_LOGICAL */
2780 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
2781 result->value.logical = x->value.logical || y->value.logical;
2784 return range_check (result, "OR");
2789 gfc_simplify_precision (gfc_expr *e)
2794 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2796 result = gfc_int_expr (gfc_real_kinds[i].precision);
2797 result->where = e->where;
2804 gfc_simplify_radix (gfc_expr *e)
2809 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2813 i = gfc_integer_kinds[i].radix;
2817 i = gfc_real_kinds[i].radix;
2824 result = gfc_int_expr (i);
2825 result->where = e->where;
2832 gfc_simplify_range (gfc_expr *e)
2838 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2843 j = gfc_integer_kinds[i].range;
2848 j = gfc_real_kinds[i].range;
2855 result = gfc_int_expr (j);
2856 result->where = e->where;
2863 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
2868 if (e->ts.type == BT_COMPLEX)
2869 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
2871 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
2874 return &gfc_bad_expr;
2876 if (e->expr_type != EXPR_CONSTANT)
2882 result = gfc_int2real (e, kind);
2886 result = gfc_real2real (e, kind);
2890 result = gfc_complex2real (e, kind);
2894 gfc_internal_error ("bad type in REAL");
2898 return range_check (result, "REAL");
2903 gfc_simplify_realpart (gfc_expr *e)
2907 if (e->expr_type != EXPR_CONSTANT)
2910 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
2911 mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
2913 return range_check (result, "REALPART");
2917 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
2920 int i, j, len, ncop, nlen;
2922 bool have_length = false;
2924 /* If NCOPIES isn't a constant, there's nothing we can do. */
2925 if (n->expr_type != EXPR_CONSTANT)
2928 /* If NCOPIES is negative, it's an error. */
2929 if (mpz_sgn (n->value.integer) < 0)
2931 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
2933 return &gfc_bad_expr;
2936 /* If we don't know the character length, we can do no more. */
2937 if (e->ts.cl && e->ts.cl->length
2938 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
2940 len = mpz_get_si (e->ts.cl->length->value.integer);
2943 else if (e->expr_type == EXPR_CONSTANT
2944 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
2946 len = e->value.character.length;
2951 /* If the source length is 0, any value of NCOPIES is valid
2952 and everything behaves as if NCOPIES == 0. */
2955 mpz_set_ui (ncopies, 0);
2957 mpz_set (ncopies, n->value.integer);
2959 /* Check that NCOPIES isn't too large. */
2965 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
2967 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
2971 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
2972 e->ts.cl->length->value.integer);
2976 mpz_init_set_si (mlen, len);
2977 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
2981 /* The check itself. */
2982 if (mpz_cmp (ncopies, max) > 0)
2985 mpz_clear (ncopies);
2986 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
2988 return &gfc_bad_expr;
2993 mpz_clear (ncopies);
2995 /* For further simplification, we need the character string to be
2997 if (e->expr_type != EXPR_CONSTANT)
3000 if (len || mpz_sgn (e->ts.cl->length->value.integer) != 0)
3002 const char *res = gfc_extract_int (n, &ncop);
3003 gcc_assert (res == NULL);
3008 len = e->value.character.length;
3011 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3015 result->value.character.string = gfc_getmem (1);
3016 result->value.character.length = 0;
3017 result->value.character.string[0] = '\0';
3021 result->value.character.length = nlen;
3022 result->value.character.string = gfc_getmem (nlen + 1);
3024 for (i = 0; i < ncop; i++)
3025 for (j = 0; j < len; j++)
3026 result->value.character.string[j + i * len]
3027 = e->value.character.string[j];
3029 result->value.character.string[nlen] = '\0'; /* For debugger */
3034 /* This one is a bear, but mainly has to do with shuffling elements. */
3037 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3038 gfc_expr *pad, gfc_expr *order_exp)
3040 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3041 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3042 gfc_constructor *head, *tail;
3048 /* Unpack the shape array. */
3049 if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
3052 if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
3056 && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
3059 if (order_exp != NULL
3060 && (order_exp->expr_type != EXPR_ARRAY
3061 || !gfc_is_constant_expr (order_exp)))
3070 e = gfc_get_array_element (shape_exp, rank);
3074 if (gfc_extract_int (e, &shape[rank]) != NULL)
3076 gfc_error ("Integer too large in shape specification at %L",
3084 if (rank >= GFC_MAX_DIMENSIONS)
3086 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3087 "at %L", &e->where);
3092 if (shape[rank] < 0)
3094 gfc_error ("Shape specification at %L cannot be negative",
3104 gfc_error ("Shape specification at %L cannot be the null array",
3109 /* Now unpack the order array if present. */
3110 if (order_exp == NULL)
3112 for (i = 0; i < rank; i++)
3117 for (i = 0; i < rank; i++)
3120 for (i = 0; i < rank; i++)
3122 e = gfc_get_array_element (order_exp, i);
3125 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3126 "size as SHAPE parameter", &order_exp->where);
3130 if (gfc_extract_int (e, &order[i]) != NULL)
3132 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3140 if (order[i] < 1 || order[i] > rank)
3142 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3151 gfc_error ("Invalid permutation in ORDER parameter at %L",
3160 /* Count the elements in the source and padding arrays. */
3165 gfc_array_size (pad, &size);
3166 npad = mpz_get_ui (size);
3170 gfc_array_size (source, &size);
3171 nsource = mpz_get_ui (size);
3174 /* If it weren't for that pesky permutation we could just loop
3175 through the source and round out any shortage with pad elements.
3176 But no, someone just had to have the compiler do something the
3177 user should be doing. */
3179 for (i = 0; i < rank; i++)
3184 /* Figure out which element to extract. */
3185 mpz_set_ui (index, 0);
3187 for (i = rank - 1; i >= 0; i--)
3189 mpz_add_ui (index, index, x[order[i]]);
3191 mpz_mul_ui (index, index, shape[order[i - 1]]);
3194 if (mpz_cmp_ui (index, INT_MAX) > 0)
3195 gfc_internal_error ("Reshaped array too large at %L", &e->where);
3197 j = mpz_get_ui (index);
3200 e = gfc_get_array_element (source, j);
3207 gfc_error ("PAD parameter required for short SOURCE parameter "
3208 "at %L", &source->where);
3213 e = gfc_get_array_element (pad, j);
3217 head = tail = gfc_get_constructor ();
3220 tail->next = gfc_get_constructor ();
3227 tail->where = e->where;
3230 /* Calculate the next element. */
3234 if (++x[i] < shape[i])
3245 e = gfc_get_expr ();
3246 e->where = source->where;
3247 e->expr_type = EXPR_ARRAY;
3248 e->value.constructor = head;
3249 e->shape = gfc_get_shape (rank);
3251 for (i = 0; i < rank; i++)
3252 mpz_init_set_ui (e->shape[i], shape[i]);
3260 gfc_free_constructor (head);
3262 return &gfc_bad_expr;
3267 gfc_simplify_rrspacing (gfc_expr *x)
3273 if (x->expr_type != EXPR_CONSTANT)
3276 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3278 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3280 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3282 /* Special case x = -0 and 0. */
3283 if (mpfr_sgn (result->value.real) == 0)
3285 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3289 /* | x * 2**(-e) | * 2**p. */
3290 e = - (long int) mpfr_get_exp (x->value.real);
3291 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3293 p = (long int) gfc_real_kinds[i].digits;
3294 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3296 return range_check (result, "RRSPACING");
3301 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3303 int k, neg_flag, power, exp_range;
3304 mpfr_t scale, radix;
3307 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3310 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3312 if (mpfr_sgn (x->value.real) == 0)
3314 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3318 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3320 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3322 /* This check filters out values of i that would overflow an int. */
3323 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3324 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3326 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3327 return &gfc_bad_expr;
3330 /* Compute scale = radix ** power. */
3331 power = mpz_get_si (i->value.integer);
3341 gfc_set_model_kind (x->ts.kind);
3344 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3345 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3348 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3350 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3355 return range_check (result, "SCALE");
3360 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
3365 size_t indx, len, lenc;
3366 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3369 return &gfc_bad_expr;
3371 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3374 if (b != NULL && b->value.logical != 0)
3379 result = gfc_constant_result (BT_INTEGER, k, &e->where);
3381 len = e->value.character.length;
3382 lenc = c->value.character.length;
3384 if (len == 0 || lenc == 0)
3392 indx = strcspn (e->value.character.string, c->value.character.string)
3400 for (indx = len; indx > 0; indx--)
3402 for (i = 0; i < lenc; i++)
3404 if (c->value.character.string[i]
3405 == e->value.character.string[indx - 1])
3413 mpz_set_ui (result->value.integer, indx);
3414 return range_check (result, "SCAN");
3419 gfc_simplify_selected_int_kind (gfc_expr *e)
3424 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3429 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3430 if (gfc_integer_kinds[i].range >= range
3431 && gfc_integer_kinds[i].kind < kind)
3432 kind = gfc_integer_kinds[i].kind;
3434 if (kind == INT_MAX)
3437 result = gfc_int_expr (kind);
3438 result->where = e->where;
3445 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3447 int range, precision, i, kind, found_precision, found_range;
3454 if (p->expr_type != EXPR_CONSTANT
3455 || gfc_extract_int (p, &precision) != NULL)
3463 if (q->expr_type != EXPR_CONSTANT
3464 || gfc_extract_int (q, &range) != NULL)
3469 found_precision = 0;
3472 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3474 if (gfc_real_kinds[i].precision >= precision)
3475 found_precision = 1;
3477 if (gfc_real_kinds[i].range >= range)
3480 if (gfc_real_kinds[i].precision >= precision
3481 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3482 kind = gfc_real_kinds[i].kind;
3485 if (kind == INT_MAX)
3489 if (!found_precision)
3495 result = gfc_int_expr (kind);
3496 result->where = (p != NULL) ? p->where : q->where;
3503 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3506 mpfr_t exp, absv, log2, pow2, frac;
3509 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3512 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3514 gfc_set_model_kind (x->ts.kind);
3516 if (mpfr_sgn (x->value.real) == 0)
3518 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3528 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3529 mpfr_log2 (log2, absv, GFC_RND_MODE);
3531 mpfr_trunc (log2, log2);
3532 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3534 /* Old exponent value, and fraction. */
3535 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3537 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3540 exp2 = (unsigned long) mpz_get_d (i->value.integer);
3541 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3548 return range_check (result, "SET_EXPONENT");
3553 gfc_simplify_shape (gfc_expr *source)
3555 mpz_t shape[GFC_MAX_DIMENSIONS];
3556 gfc_expr *result, *e, *f;
3561 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3564 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3567 ar = gfc_find_array_ref (source);
3569 t = gfc_array_ref_shape (ar, shape);
3571 for (n = 0; n < source->rank; n++)
3573 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3578 mpz_set (e->value.integer, shape[n]);
3579 mpz_clear (shape[n]);
3583 mpz_set_ui (e->value.integer, n + 1);
3585 f = gfc_simplify_size (source, e, NULL);
3589 gfc_free_expr (result);
3598 gfc_append_constructor (result, e);
3606 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3611 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3614 return &gfc_bad_expr;
3618 if (gfc_array_size (array, &size) == FAILURE)
3623 if (dim->expr_type != EXPR_CONSTANT)
3626 d = mpz_get_ui (dim->value.integer) - 1;
3627 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3631 result = gfc_constant_result (BT_INTEGER, k, &array->where);
3632 mpz_set (result->value.integer, size);
3638 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
3642 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3645 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3650 mpz_abs (result->value.integer, x->value.integer);
3651 if (mpz_sgn (y->value.integer) < 0)
3652 mpz_neg (result->value.integer, result->value.integer);
3657 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3659 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3660 if (mpfr_sgn (y->value.real) < 0)
3661 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3666 gfc_internal_error ("Bad type in gfc_simplify_sign");
3674 gfc_simplify_sin (gfc_expr *x)
3679 if (x->expr_type != EXPR_CONSTANT)
3682 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3687 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3691 gfc_set_model (x->value.real);
3695 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
3696 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3697 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3699 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
3700 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3701 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3708 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3711 return range_check (result, "SIN");
3716 gfc_simplify_sinh (gfc_expr *x)
3720 if (x->expr_type != EXPR_CONSTANT)
3723 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3725 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
3727 return range_check (result, "SINH");
3731 /* The argument is always a double precision real that is converted to
3732 single precision. TODO: Rounding! */
3735 gfc_simplify_sngl (gfc_expr *a)
3739 if (a->expr_type != EXPR_CONSTANT)
3742 result = gfc_real2real (a, gfc_default_real_kind);
3743 return range_check (result, "SNGL");
3748 gfc_simplify_spacing (gfc_expr *x)
3754 if (x->expr_type != EXPR_CONSTANT)
3757 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3759 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3761 /* Special case x = 0 and -0. */
3762 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3763 if (mpfr_sgn (result->value.real) == 0)
3765 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3769 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3770 are the radix, exponent of x, and precision. This excludes the
3771 possibility of subnormal numbers. Fortran 2003 states the result is
3772 b**max(e - p, emin - 1). */
3774 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
3775 en = (long int) gfc_real_kinds[i].min_exponent - 1;
3776 en = en > ep ? en : ep;
3778 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3779 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
3781 return range_check (result, "SPACING");
3786 gfc_simplify_sqrt (gfc_expr *e)
3789 mpfr_t ac, ad, s, t, w;
3791 if (e->expr_type != EXPR_CONSTANT)
3794 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3799 if (mpfr_cmp_si (e->value.real, 0) < 0)
3801 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3806 /* Formula taken from Numerical Recipes to avoid over- and
3809 gfc_set_model (e->value.real);
3816 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3817 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3819 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3820 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3824 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3825 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3827 if (mpfr_cmp (ac, ad) >= 0)
3829 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3830 mpfr_mul (t, t, t, GFC_RND_MODE);
3831 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3832 mpfr_sqrt (t, t, GFC_RND_MODE);
3833 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3834 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3835 mpfr_sqrt (t, t, GFC_RND_MODE);
3836 mpfr_sqrt (s, ac, GFC_RND_MODE);
3837 mpfr_mul (w, s, t, GFC_RND_MODE);
3841 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3842 mpfr_mul (t, s, s, GFC_RND_MODE);
3843 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3844 mpfr_sqrt (t, t, GFC_RND_MODE);
3845 mpfr_abs (s, s, GFC_RND_MODE);
3846 mpfr_add (t, t, s, GFC_RND_MODE);
3847 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3848 mpfr_sqrt (t, t, GFC_RND_MODE);
3849 mpfr_sqrt (s, ad, GFC_RND_MODE);
3850 mpfr_mul (w, s, t, GFC_RND_MODE);
3853 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3855 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3856 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3857 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3859 else if (mpfr_cmp_ui (w, 0) != 0
3860 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3861 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3863 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3864 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3865 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3867 else if (mpfr_cmp_ui (w, 0) != 0
3868 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3869 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
3871 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3872 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
3873 mpfr_neg (w, w, GFC_RND_MODE);
3874 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3877 gfc_internal_error ("invalid complex argument of SQRT at %L",
3889 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
3892 return range_check (result, "SQRT");
3895 gfc_free_expr (result);
3896 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
3897 return &gfc_bad_expr;
3902 gfc_simplify_tan (gfc_expr *x)
3907 if (x->expr_type != EXPR_CONSTANT)
3910 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3912 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3914 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
3916 return range_check (result, "TAN");
3921 gfc_simplify_tanh (gfc_expr *x)
3925 if (x->expr_type != EXPR_CONSTANT)
3928 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3930 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
3932 return range_check (result, "TANH");
3938 gfc_simplify_tiny (gfc_expr *e)
3943 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
3945 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3946 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3953 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
3956 gfc_expr *mold_element;
3959 size_t result_elt_size;
3962 unsigned char *buffer;
3964 if (!gfc_is_constant_expr (source)
3965 || !gfc_is_constant_expr (size))
3968 /* Calculate the size of the source. */
3969 if (source->expr_type == EXPR_ARRAY
3970 && gfc_array_size (source, &tmp) == FAILURE)
3971 gfc_internal_error ("Failure getting length of a constant array.");
3973 source_size = gfc_target_expr_size (source);
3975 /* Create an empty new expression with the appropriate characteristics. */
3976 result = gfc_constant_result (mold->ts.type, mold->ts.kind,
3978 result->ts = mold->ts;
3980 mold_element = mold->expr_type == EXPR_ARRAY
3981 ? mold->value.constructor->expr
3984 /* Set result character length, if needed. Note that this needs to be
3985 set even for array expressions, in order to pass this information into
3986 gfc_target_interpret_expr. */
3987 if (result->ts.type == BT_CHARACTER)
3988 result->value.character.length = mold_element->value.character.length;
3990 /* Set the number of elements in the result, and determine its size. */
3991 result_elt_size = gfc_target_expr_size (mold_element);
3992 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
3996 result->expr_type = EXPR_ARRAY;
4000 result_length = (size_t)mpz_get_ui (size->value.integer);
4003 result_length = source_size / result_elt_size;
4004 if (result_length * result_elt_size < source_size)
4008 result->shape = gfc_get_shape (1);
4009 mpz_init_set_ui (result->shape[0], result_length);
4011 result_size = result_length * result_elt_size;
4016 result_size = result_elt_size;
4019 /* Allocate the buffer to store the binary version of the source. */
4020 buffer_size = MAX (source_size, result_size);
4021 buffer = (unsigned char*)alloca (buffer_size);
4023 /* Now write source to the buffer. */
4024 gfc_target_encode_expr (source, buffer, buffer_size);
4026 /* And read the buffer back into the new expression. */
4027 gfc_target_interpret_expr (buffer, buffer_size, result);
4034 gfc_simplify_trim (gfc_expr *e)
4037 int count, i, len, lentrim;
4039 if (e->expr_type != EXPR_CONSTANT)
4042 len = e->value.character.length;
4044 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4046 for (count = 0, i = 1; i <= len; ++i)
4048 if (e->value.character.string[len - i] == ' ')
4054 lentrim = len - count;
4056 result->value.character.length = lentrim;
4057 result->value.character.string = gfc_getmem (lentrim + 1);
4059 for (i = 0; i < lentrim; i++)
4060 result->value.character.string[i] = e->value.character.string[i];
4062 result->value.character.string[lentrim] = '\0'; /* For debugger */
4069 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4071 return simplify_bound (array, dim, kind, 1);
4076 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
4080 size_t index, len, lenset;
4082 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
4085 return &gfc_bad_expr;
4087 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4090 if (b != NULL && b->value.logical != 0)
4095 result = gfc_constant_result (BT_INTEGER, k, &s->where);
4097 len = s->value.character.length;
4098 lenset = set->value.character.length;
4102 mpz_set_ui (result->value.integer, 0);
4110 mpz_set_ui (result->value.integer, 1);
4114 index = strspn (s->value.character.string, set->value.character.string)
4124 mpz_set_ui (result->value.integer, len);
4127 for (index = len; index > 0; index --)
4129 for (i = 0; i < lenset; i++)
4131 if (s->value.character.string[index - 1]
4132 == set->value.character.string[i])
4140 mpz_set_ui (result->value.integer, index);
4146 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4151 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4154 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4155 if (x->ts.type == BT_INTEGER)
4157 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4158 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4160 else /* BT_LOGICAL */
4162 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4163 result->value.logical = (x->value.logical && !y->value.logical)
4164 || (!x->value.logical && y->value.logical);
4167 return range_check (result, "XOR");
4171 /****************** Constant simplification *****************/
4173 /* Master function to convert one constant to another. While this is
4174 used as a simplification function, it requires the destination type
4175 and kind information which is supplied by a special case in
4179 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4181 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4182 gfc_constructor *head, *c, *tail = NULL;
4196 f = gfc_int2complex;
4216 f = gfc_real2complex;
4227 f = gfc_complex2int;
4230 f = gfc_complex2real;
4233 f = gfc_complex2complex;
4259 f = gfc_hollerith2int;
4263 f = gfc_hollerith2real;
4267 f = gfc_hollerith2complex;
4271 f = gfc_hollerith2character;
4275 f = gfc_hollerith2logical;
4285 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4290 switch (e->expr_type)
4293 result = f (e, kind);
4295 return &gfc_bad_expr;
4299 if (!gfc_is_constant_expr (e))
4304 for (c = e->value.constructor; c; c = c->next)
4307 head = tail = gfc_get_constructor ();
4310 tail->next = gfc_get_constructor ();
4314 tail->where = c->where;
4316 if (c->iterator == NULL)
4317 tail->expr = f (c->expr, kind);
4320 g = gfc_convert_constant (c->expr, type, kind);
4321 if (g == &gfc_bad_expr)
4326 if (tail->expr == NULL)
4328 gfc_free_constructor (head);
4333 result = gfc_get_expr ();
4334 result->ts.type = type;
4335 result->ts.kind = kind;
4336 result->expr_type = EXPR_ARRAY;
4337 result->value.constructor = head;
4338 result->shape = gfc_copy_shape (e->shape, e->rank);
4339 result->where = e->where;
4340 result->rank = e->rank;