1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
31 #include "intrinsic.h"
33 gfc_expr gfc_bad_expr;
36 /* Note that 'simplification' is not just transforming expressions.
37 For functions that are not simplified at compile time, range
38 checking is done if possible.
40 The return convention is that each simplification function returns:
42 A new expression node corresponding to the simplified arguments.
43 The original arguments are destroyed by the caller, and must not
44 be a part of the new expression.
46 NULL pointer indicating that no simplification was possible and
47 the original expression should remain intact. If the
48 simplification function sets the type and/or the function name
49 via the pointer gfc_simple_expression, then this type is
52 An expression pointer to gfc_bad_expr (a static placeholder)
53 indicating that some error has prevented simplification. For
54 example, sqrt(-1.0). The error is generated within the function
55 and should be propagated upwards
57 By the time a simplification function gets control, it has been
58 decided that the function call is really supposed to be the
59 intrinsic. No type checking is strictly necessary, since only
60 valid types will be passed on. On the other hand, a simplification
61 subroutine may have to look at the type of an argument as part of
64 Array arguments are never passed to these subroutines.
66 The functions in this file don't have much comment with them, but
67 everything is reasonably straight-forward. The Standard, chapter 13
68 is the best comment you'll find for this file anyway. */
70 /* Static table for converting non-ascii character sets to ascii.
71 The xascii_table[] is the inverse table. */
73 static int ascii_table[256] = {
74 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
75 '\b', '\t', '\n', '\v', '\0', '\r', '\0', '\0',
76 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
77 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
78 ' ', '!', '\'', '#', '$', '%', '&', '\'',
79 '(', ')', '*', '+', ',', '-', '.', '/',
80 '0', '1', '2', '3', '4', '5', '6', '7',
81 '8', '9', ':', ';', '<', '=', '>', '?',
82 '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
83 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
84 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
85 'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
86 '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
87 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
88 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
89 'x', 'y', 'z', '{', '|', '}', '~', '\?'
92 static int xascii_table[256];
95 /* Range checks an expression node. If all goes well, returns the
96 node, otherwise returns &gfc_bad_expr and frees the node. */
99 range_check (gfc_expr * result, const char *name)
101 if (gfc_range_check (result) == ARITH_OK)
104 gfc_error ("Result of %s overflows its kind at %L", name, &result->where);
105 gfc_free_expr (result);
106 return &gfc_bad_expr;
110 /* A helper function that gets an optional and possibly missing
111 kind parameter. Returns the kind, -1 if something went wrong. */
114 get_kind (bt type, gfc_expr * k, const char *name, int default_kind)
121 if (k->expr_type != EXPR_CONSTANT)
123 gfc_error ("KIND parameter of %s at %L must be an initialization "
124 "expression", name, &k->where);
129 if (gfc_extract_int (k, &kind) != NULL
130 || gfc_validate_kind (type, kind, true) < 0)
133 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
141 /* Checks if X, which is assumed to represent a two's complement
142 integer of binary width BITSIZE, has the signbit set. If so, makes
143 X the corresponding negative number. */
146 twos_complement (mpz_t x, int bitsize)
149 char mask_s[bitsize + 1];
151 if (mpz_tstbit (x, bitsize - 1) == 1)
153 /* The mpz_init_set_{u|s}i functions take a long argument, but
154 the widest integer the target supports might be wider, so we
155 have to go via an intermediate string. */
156 memset (mask_s, '1', bitsize);
157 mask_s[bitsize] = '\0';
158 mpz_init_set_str (mask, mask_s, 2);
160 /* We negate the number by hand, zeroing the high bits, and then
161 have it negated by GMP. */
163 mpz_add_ui (x, x, 1);
164 mpz_and (x, x, mask);
173 /********************** Simplification functions *****************************/
176 gfc_simplify_abs (gfc_expr * e)
180 if (e->expr_type != EXPR_CONSTANT)
186 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
188 mpz_abs (result->value.integer, e->value.integer);
190 result = range_check (result, "IABS");
194 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
196 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
198 result = range_check (result, "ABS");
202 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
204 gfc_set_model_kind (e->ts.kind);
206 mpfr_hypot (result->value.real, e->value.complex.r,
207 e->value.complex.i, GFC_RND_MODE);
208 result = range_check (result, "CABS");
212 gfc_internal_error ("gfc_simplify_abs(): Bad type");
220 gfc_simplify_achar (gfc_expr * e)
225 if (e->expr_type != EXPR_CONSTANT)
228 /* We cannot assume that the native character set is ASCII in this
230 if (gfc_extract_int (e, &index) != NULL || index < 0 || index > 127)
232 gfc_error ("Extended ASCII not implemented: argument of ACHAR at %L "
233 "must be between 0 and 127", &e->where);
234 return &gfc_bad_expr;
237 result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
240 result->value.character.string = gfc_getmem (2);
242 result->value.character.length = 1;
243 result->value.character.string[0] = ascii_table[index];
244 result->value.character.string[1] = '\0'; /* For debugger */
250 gfc_simplify_acos (gfc_expr * x)
254 if (x->expr_type != EXPR_CONSTANT)
257 if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
259 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
261 return &gfc_bad_expr;
264 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
266 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
268 return range_check (result, "ACOS");
273 gfc_simplify_adjustl (gfc_expr * e)
279 if (e->expr_type != EXPR_CONSTANT)
282 len = e->value.character.length;
284 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
286 result->value.character.length = len;
287 result->value.character.string = gfc_getmem (len + 1);
289 for (count = 0, i = 0; i < len; ++i)
291 ch = e->value.character.string[i];
297 for (i = 0; i < len - count; ++i)
299 result->value.character.string[i] =
300 e->value.character.string[count + i];
303 for (i = len - count; i < len; ++i)
305 result->value.character.string[i] = ' ';
308 result->value.character.string[len] = '\0'; /* For debugger */
315 gfc_simplify_adjustr (gfc_expr * e)
321 if (e->expr_type != EXPR_CONSTANT)
324 len = e->value.character.length;
326 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
328 result->value.character.length = len;
329 result->value.character.string = gfc_getmem (len + 1);
331 for (count = 0, i = len - 1; i >= 0; --i)
333 ch = e->value.character.string[i];
339 for (i = 0; i < count; ++i)
341 result->value.character.string[i] = ' ';
344 for (i = count; i < len; ++i)
346 result->value.character.string[i] =
347 e->value.character.string[i - count];
350 result->value.character.string[len] = '\0'; /* For debugger */
357 gfc_simplify_aimag (gfc_expr * e)
361 if (e->expr_type != EXPR_CONSTANT)
364 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
365 mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
367 return range_check (result, "AIMAG");
372 gfc_simplify_aint (gfc_expr * e, gfc_expr * k)
374 gfc_expr *rtrunc, *result;
377 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
379 return &gfc_bad_expr;
381 if (e->expr_type != EXPR_CONSTANT)
384 rtrunc = gfc_copy_expr (e);
386 mpfr_trunc (rtrunc->value.real, e->value.real);
388 result = gfc_real2real (rtrunc, kind);
389 gfc_free_expr (rtrunc);
391 return range_check (result, "AINT");
396 gfc_simplify_dint (gfc_expr * e)
398 gfc_expr *rtrunc, *result;
400 if (e->expr_type != EXPR_CONSTANT)
403 rtrunc = gfc_copy_expr (e);
405 mpfr_trunc (rtrunc->value.real, e->value.real);
407 result = gfc_real2real (rtrunc, gfc_default_double_kind);
408 gfc_free_expr (rtrunc);
410 return range_check (result, "DINT");
415 gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
417 gfc_expr *rtrunc, *result;
421 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
423 return &gfc_bad_expr;
425 if (e->expr_type != EXPR_CONSTANT)
428 result = gfc_constant_result (e->ts.type, kind, &e->where);
430 rtrunc = gfc_copy_expr (e);
432 cmp = mpfr_cmp_ui (e->value.real, 0);
434 gfc_set_model_kind (kind);
436 mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
440 mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
441 mpfr_trunc (result->value.real, rtrunc->value.real);
445 mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
446 mpfr_trunc (result->value.real, rtrunc->value.real);
449 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
451 gfc_free_expr (rtrunc);
454 return range_check (result, "ANINT");
459 gfc_simplify_dnint (gfc_expr * e)
461 gfc_expr *rtrunc, *result;
465 if (e->expr_type != EXPR_CONSTANT)
469 gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
471 rtrunc = gfc_copy_expr (e);
473 cmp = mpfr_cmp_ui (e->value.real, 0);
475 gfc_set_model_kind (gfc_default_double_kind);
477 mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
481 mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
482 mpfr_trunc (result->value.real, rtrunc->value.real);
486 mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
487 mpfr_trunc (result->value.real, rtrunc->value.real);
490 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
492 gfc_free_expr (rtrunc);
495 return range_check (result, "DNINT");
500 gfc_simplify_asin (gfc_expr * x)
504 if (x->expr_type != EXPR_CONSTANT)
507 if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
509 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
511 return &gfc_bad_expr;
514 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
516 mpfr_asin(result->value.real, x->value.real, GFC_RND_MODE);
518 return range_check (result, "ASIN");
523 gfc_simplify_atan (gfc_expr * x)
527 if (x->expr_type != EXPR_CONSTANT)
530 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
532 mpfr_atan(result->value.real, x->value.real, GFC_RND_MODE);
534 return range_check (result, "ATAN");
540 gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x)
544 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
547 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
549 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
552 ("If first argument of ATAN2 %L is zero, then the second argument "
553 "must not be zero", &x->where);
554 gfc_free_expr (result);
555 return &gfc_bad_expr;
558 arctangent2 (y->value.real, x->value.real, result->value.real);
560 return range_check (result, "ATAN2");
566 gfc_simplify_bit_size (gfc_expr * e)
571 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
572 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
573 mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
580 gfc_simplify_btest (gfc_expr * e, gfc_expr * bit)
584 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
587 if (gfc_extract_int (bit, &b) != NULL || b < 0)
588 return gfc_logical_expr (0, &e->where);
590 return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
595 gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k)
597 gfc_expr *ceil, *result;
600 kind = get_kind (BT_REAL, k, "CEILING", gfc_default_real_kind);
602 return &gfc_bad_expr;
604 if (e->expr_type != EXPR_CONSTANT)
607 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
609 ceil = gfc_copy_expr (e);
611 mpfr_ceil (ceil->value.real, e->value.real);
612 gfc_mpfr_to_mpz(result->value.integer, ceil->value.real);
614 gfc_free_expr (ceil);
616 return range_check (result, "CEILING");
621 gfc_simplify_char (gfc_expr * e, gfc_expr * k)
626 kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
628 return &gfc_bad_expr;
630 if (e->expr_type != EXPR_CONSTANT)
633 if (gfc_extract_int (e, &c) != NULL || c < 0 || c > 255)
635 gfc_error ("Bad character in CHAR function at %L", &e->where);
636 return &gfc_bad_expr;
639 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
641 result->value.character.length = 1;
642 result->value.character.string = gfc_getmem (2);
644 result->value.character.string[0] = c;
645 result->value.character.string[1] = '\0'; /* For debugger */
651 /* Common subroutine for simplifying CMPLX and DCMPLX. */
654 simplify_cmplx (const char *name, gfc_expr * x, gfc_expr * y, int kind)
658 result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
660 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
665 mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
669 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
673 mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
674 mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
678 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
686 mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
690 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
694 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
698 return range_check (result, name);
703 gfc_simplify_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * k)
707 if (x->expr_type != EXPR_CONSTANT
708 || (y != NULL && y->expr_type != EXPR_CONSTANT))
711 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
713 return &gfc_bad_expr;
715 return simplify_cmplx ("CMPLX", x, y, kind);
720 gfc_simplify_conjg (gfc_expr * e)
724 if (e->expr_type != EXPR_CONSTANT)
727 result = gfc_copy_expr (e);
728 mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
730 return range_check (result, "CONJG");
735 gfc_simplify_cos (gfc_expr * x)
740 if (x->expr_type != EXPR_CONSTANT)
743 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
748 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
751 gfc_set_model_kind (x->ts.kind);
755 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
756 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
757 mpfr_mul(result->value.complex.r, xp, xq, GFC_RND_MODE);
759 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
760 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
761 mpfr_mul (xp, xp, xq, GFC_RND_MODE);
762 mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
768 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
771 return range_check (result, "COS");
777 gfc_simplify_cosh (gfc_expr * x)
781 if (x->expr_type != EXPR_CONSTANT)
784 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
786 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
788 return range_check (result, "COSH");
793 gfc_simplify_dcmplx (gfc_expr * x, gfc_expr * y)
796 if (x->expr_type != EXPR_CONSTANT
797 || (y != NULL && y->expr_type != EXPR_CONSTANT))
800 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
805 gfc_simplify_dble (gfc_expr * e)
809 if (e->expr_type != EXPR_CONSTANT)
815 result = gfc_int2real (e, gfc_default_double_kind);
819 result = gfc_real2real (e, gfc_default_double_kind);
823 result = gfc_complex2real (e, gfc_default_double_kind);
827 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
830 return range_check (result, "DBLE");
835 gfc_simplify_digits (gfc_expr * x)
839 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
843 digits = gfc_integer_kinds[i].digits;
848 digits = gfc_real_kinds[i].digits;
855 return gfc_int_expr (digits);
860 gfc_simplify_dim (gfc_expr * x, gfc_expr * y)
864 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
867 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
872 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
873 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
875 mpz_set_ui (result->value.integer, 0);
880 if (mpfr_cmp (x->value.real, y->value.real) > 0)
881 mpfr_sub (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
883 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
888 gfc_internal_error ("gfc_simplify_dim(): Bad type");
891 return range_check (result, "DIM");
896 gfc_simplify_dprod (gfc_expr * x, gfc_expr * y)
898 gfc_expr *a1, *a2, *result;
900 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
904 gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
906 a1 = gfc_real2real (x, gfc_default_double_kind);
907 a2 = gfc_real2real (y, gfc_default_double_kind);
909 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
914 return range_check (result, "DPROD");
919 gfc_simplify_epsilon (gfc_expr * e)
924 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
926 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
928 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
930 return range_check (result, "EPSILON");
935 gfc_simplify_exp (gfc_expr * x)
940 if (x->expr_type != EXPR_CONSTANT)
943 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
948 mpfr_exp(result->value.real, x->value.real, GFC_RND_MODE);
952 gfc_set_model_kind (x->ts.kind);
955 mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
956 mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
957 mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
958 mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
959 mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
965 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
968 return range_check (result, "EXP");
971 /* FIXME: MPFR should be able to do this better */
973 gfc_simplify_exponent (gfc_expr * x)
978 if (x->expr_type != EXPR_CONSTANT)
981 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
984 gfc_set_model (x->value.real);
986 if (mpfr_sgn (x->value.real) == 0)
988 mpz_set_ui (result->value.integer, 0);
994 mpfr_abs (tmp, x->value.real, GFC_RND_MODE);
995 mpfr_log2 (tmp, tmp, GFC_RND_MODE);
997 gfc_mpfr_to_mpz (result->value.integer, tmp);
1001 return range_check (result, "EXPONENT");
1006 gfc_simplify_float (gfc_expr * a)
1010 if (a->expr_type != EXPR_CONSTANT)
1013 result = gfc_int2real (a, gfc_default_real_kind);
1014 return range_check (result, "FLOAT");
1019 gfc_simplify_floor (gfc_expr * e, gfc_expr * k)
1025 kind = get_kind (BT_REAL, k, "FLOOR", gfc_default_real_kind);
1027 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1029 if (e->expr_type != EXPR_CONSTANT)
1032 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1034 gfc_set_model_kind (kind);
1036 mpfr_floor (floor, e->value.real);
1038 gfc_mpfr_to_mpz (result->value.integer, floor);
1042 return range_check (result, "FLOOR");
1047 gfc_simplify_fraction (gfc_expr * x)
1050 mpfr_t absv, exp, pow2;
1052 if (x->expr_type != EXPR_CONSTANT)
1055 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1057 gfc_set_model_kind (x->ts.kind);
1059 if (mpfr_sgn (x->value.real) == 0)
1061 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1069 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1070 mpfr_log2 (exp, absv, GFC_RND_MODE);
1072 mpfr_trunc (exp, exp);
1073 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1075 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1077 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1083 return range_check (result, "FRACTION");
1088 gfc_simplify_huge (gfc_expr * e)
1093 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1095 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1100 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1104 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1116 gfc_simplify_iachar (gfc_expr * e)
1121 if (e->expr_type != EXPR_CONSTANT)
1124 if (e->value.character.length != 1)
1126 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1127 return &gfc_bad_expr;
1130 index = xascii_table[(int) e->value.character.string[0] & 0xFF];
1132 result = gfc_int_expr (index);
1133 result->where = e->where;
1135 return range_check (result, "IACHAR");
1140 gfc_simplify_iand (gfc_expr * x, gfc_expr * y)
1144 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1147 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1149 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1151 return range_check (result, "IAND");
1156 gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y)
1161 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1164 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1166 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1167 return &gfc_bad_expr;
1170 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1172 if (pos > gfc_integer_kinds[k].bit_size)
1174 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1176 return &gfc_bad_expr;
1179 result = gfc_copy_expr (x);
1181 mpz_clrbit (result->value.integer, pos);
1182 return range_check (result, "IBCLR");
1187 gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
1194 if (x->expr_type != EXPR_CONSTANT
1195 || y->expr_type != EXPR_CONSTANT
1196 || z->expr_type != EXPR_CONSTANT)
1199 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1201 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1202 return &gfc_bad_expr;
1205 if (gfc_extract_int (z, &len) != NULL || len < 0)
1207 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1208 return &gfc_bad_expr;
1211 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1213 bitsize = gfc_integer_kinds[k].bit_size;
1215 if (pos + len > bitsize)
1218 ("Sum of second and third arguments of IBITS exceeds bit size "
1219 "at %L", &y->where);
1220 return &gfc_bad_expr;
1223 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1225 bits = gfc_getmem (bitsize * sizeof (int));
1227 for (i = 0; i < bitsize; i++)
1230 for (i = 0; i < len; i++)
1231 bits[i] = mpz_tstbit (x->value.integer, i + pos);
1233 for (i = 0; i < bitsize; i++)
1237 mpz_clrbit (result->value.integer, i);
1239 else if (bits[i] == 1)
1241 mpz_setbit (result->value.integer, i);
1245 gfc_internal_error ("IBITS: Bad bit");
1251 return range_check (result, "IBITS");
1256 gfc_simplify_ibset (gfc_expr * x, gfc_expr * y)
1261 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1264 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1266 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1267 return &gfc_bad_expr;
1270 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1272 if (pos > gfc_integer_kinds[k].bit_size)
1274 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1276 return &gfc_bad_expr;
1279 result = gfc_copy_expr (x);
1281 mpz_setbit (result->value.integer, pos);
1282 return range_check (result, "IBSET");
1287 gfc_simplify_ichar (gfc_expr * e)
1292 if (e->expr_type != EXPR_CONSTANT)
1295 if (e->value.character.length != 1)
1297 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1298 return &gfc_bad_expr;
1301 index = (int) e->value.character.string[0];
1303 if (index < CHAR_MIN || index > CHAR_MAX)
1305 gfc_error ("Argument of ICHAR at %L out of range of this processor",
1307 return &gfc_bad_expr;
1310 result = gfc_int_expr (index);
1311 result->where = e->where;
1312 return range_check (result, "ICHAR");
1317 gfc_simplify_ieor (gfc_expr * x, gfc_expr * y)
1321 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1324 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1326 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1328 return range_check (result, "IEOR");
1333 gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b)
1336 int back, len, lensub;
1337 int i, j, k, count, index = 0, start;
1339 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1342 if (b != NULL && b->value.logical != 0)
1347 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1350 len = x->value.character.length;
1351 lensub = y->value.character.length;
1355 mpz_set_si (result->value.integer, 0);
1364 mpz_set_si (result->value.integer, 1);
1367 else if (lensub == 1)
1369 for (i = 0; i < len; i++)
1371 for (j = 0; j < lensub; j++)
1373 if (y->value.character.string[j] ==
1374 x->value.character.string[i])
1384 for (i = 0; i < len; i++)
1386 for (j = 0; j < lensub; j++)
1388 if (y->value.character.string[j] ==
1389 x->value.character.string[i])
1394 for (k = 0; k < lensub; k++)
1396 if (y->value.character.string[k] ==
1397 x->value.character.string[k + start])
1401 if (count == lensub)
1417 mpz_set_si (result->value.integer, len + 1);
1420 else if (lensub == 1)
1422 for (i = 0; i < len; i++)
1424 for (j = 0; j < lensub; j++)
1426 if (y->value.character.string[j] ==
1427 x->value.character.string[len - i])
1429 index = len - i + 1;
1437 for (i = 0; i < len; i++)
1439 for (j = 0; j < lensub; j++)
1441 if (y->value.character.string[j] ==
1442 x->value.character.string[len - i])
1445 if (start <= len - lensub)
1448 for (k = 0; k < lensub; k++)
1449 if (y->value.character.string[k] ==
1450 x->value.character.string[k + start])
1453 if (count == lensub)
1470 mpz_set_si (result->value.integer, index);
1471 return range_check (result, "INDEX");
1476 gfc_simplify_int (gfc_expr * e, gfc_expr * k)
1478 gfc_expr *rpart, *rtrunc, *result;
1481 kind = get_kind (BT_REAL, k, "INT", gfc_default_real_kind);
1483 return &gfc_bad_expr;
1485 if (e->expr_type != EXPR_CONSTANT)
1488 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1493 mpz_set (result->value.integer, e->value.integer);
1497 rtrunc = gfc_copy_expr (e);
1498 mpfr_trunc (rtrunc->value.real, e->value.real);
1499 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1500 gfc_free_expr (rtrunc);
1504 rpart = gfc_complex2real (e, kind);
1505 rtrunc = gfc_copy_expr (rpart);
1506 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1507 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1508 gfc_free_expr (rpart);
1509 gfc_free_expr (rtrunc);
1513 gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1514 gfc_free_expr (result);
1515 return &gfc_bad_expr;
1518 return range_check (result, "INT");
1523 gfc_simplify_ifix (gfc_expr * e)
1525 gfc_expr *rtrunc, *result;
1527 if (e->expr_type != EXPR_CONSTANT)
1530 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1533 rtrunc = gfc_copy_expr (e);
1535 mpfr_trunc (rtrunc->value.real, e->value.real);
1536 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1538 gfc_free_expr (rtrunc);
1539 return range_check (result, "IFIX");
1544 gfc_simplify_idint (gfc_expr * e)
1546 gfc_expr *rtrunc, *result;
1548 if (e->expr_type != EXPR_CONSTANT)
1551 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1554 rtrunc = gfc_copy_expr (e);
1556 mpfr_trunc (rtrunc->value.real, e->value.real);
1557 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1559 gfc_free_expr (rtrunc);
1560 return range_check (result, "IDINT");
1565 gfc_simplify_ior (gfc_expr * x, gfc_expr * y)
1569 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1572 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1574 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1575 return range_check (result, "IOR");
1580 gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
1583 int shift, ashift, isize, k, *bits, i;
1585 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1588 if (gfc_extract_int (s, &shift) != NULL)
1590 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
1591 return &gfc_bad_expr;
1594 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
1596 isize = gfc_integer_kinds[k].bit_size;
1606 ("Magnitude of second argument of ISHFT exceeds bit size at %L",
1608 return &gfc_bad_expr;
1611 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1615 mpz_set (result->value.integer, e->value.integer);
1616 return range_check (result, "ISHFT");
1619 bits = gfc_getmem (isize * sizeof (int));
1621 for (i = 0; i < isize; i++)
1622 bits[i] = mpz_tstbit (e->value.integer, i);
1626 for (i = 0; i < shift; i++)
1627 mpz_clrbit (result->value.integer, i);
1629 for (i = 0; i < isize - shift; i++)
1632 mpz_clrbit (result->value.integer, i + shift);
1634 mpz_setbit (result->value.integer, i + shift);
1639 for (i = isize - 1; i >= isize - ashift; i--)
1640 mpz_clrbit (result->value.integer, i);
1642 for (i = isize - 1; i >= ashift; i--)
1645 mpz_clrbit (result->value.integer, i - ashift);
1647 mpz_setbit (result->value.integer, i - ashift);
1651 twos_complement (result->value.integer, isize);
1659 gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
1662 int shift, ashift, isize, delta, k;
1665 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1668 if (gfc_extract_int (s, &shift) != NULL)
1670 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
1671 return &gfc_bad_expr;
1674 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1678 if (gfc_extract_int (sz, &isize) != NULL || isize < 0)
1680 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
1681 return &gfc_bad_expr;
1685 isize = gfc_integer_kinds[k].bit_size;
1695 ("Magnitude of second argument of ISHFTC exceeds third argument "
1696 "at %L", &s->where);
1697 return &gfc_bad_expr;
1700 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1704 mpz_set (result->value.integer, e->value.integer);
1708 bits = gfc_getmem (isize * sizeof (int));
1710 for (i = 0; i < isize; i++)
1711 bits[i] = mpz_tstbit (e->value.integer, i);
1713 delta = isize - ashift;
1717 for (i = 0; i < delta; i++)
1720 mpz_clrbit (result->value.integer, i + shift);
1722 mpz_setbit (result->value.integer, i + shift);
1725 for (i = delta; i < isize; i++)
1728 mpz_clrbit (result->value.integer, i - delta);
1730 mpz_setbit (result->value.integer, i - delta);
1735 for (i = 0; i < ashift; i++)
1738 mpz_clrbit (result->value.integer, i + delta);
1740 mpz_setbit (result->value.integer, i + delta);
1743 for (i = ashift; i < isize; i++)
1746 mpz_clrbit (result->value.integer, i + shift);
1748 mpz_setbit (result->value.integer, i + shift);
1752 twos_complement (result->value.integer, isize);
1760 gfc_simplify_kind (gfc_expr * e)
1763 if (e->ts.type == BT_DERIVED)
1765 gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
1766 return &gfc_bad_expr;
1769 return gfc_int_expr (e->ts.kind);
1774 gfc_simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
1780 if (array->expr_type != EXPR_VARIABLE)
1786 if (dim->expr_type != EXPR_CONSTANT)
1789 /* Follow any component references. */
1790 as = array->symtree->n.sym->as;
1792 while (ref->next != NULL)
1794 if (ref->type == REF_COMPONENT)
1795 as = ref->u.c.sym->as;
1799 if (ref->type != REF_ARRAY || ref->u.ar.type != AR_FULL)
1802 i = mpz_get_si (dim->value.integer);
1804 return gfc_copy_expr (as->upper[i-1]);
1806 return gfc_copy_expr (as->lower[i-1]);
1811 gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim)
1813 return gfc_simplify_bound (array, dim, 0);
1818 gfc_simplify_len (gfc_expr * e)
1822 if (e->expr_type != EXPR_CONSTANT)
1825 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1828 mpz_set_si (result->value.integer, e->value.character.length);
1829 return range_check (result, "LEN");
1834 gfc_simplify_len_trim (gfc_expr * e)
1837 int count, len, lentrim, i;
1839 if (e->expr_type != EXPR_CONSTANT)
1842 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1845 len = e->value.character.length;
1847 for (count = 0, i = 1; i <= len; i++)
1848 if (e->value.character.string[len - i] == ' ')
1853 lentrim = len - count;
1855 mpz_set_si (result->value.integer, lentrim);
1856 return range_check (result, "LEN_TRIM");
1861 gfc_simplify_lge (gfc_expr * a, gfc_expr * b)
1864 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
1867 return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) >= 0,
1873 gfc_simplify_lgt (gfc_expr * a, gfc_expr * b)
1876 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
1879 return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) > 0,
1885 gfc_simplify_lle (gfc_expr * a, gfc_expr * b)
1888 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
1891 return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) <= 0,
1897 gfc_simplify_llt (gfc_expr * a, gfc_expr * b)
1900 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
1903 return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) < 0,
1909 gfc_simplify_log (gfc_expr * x)
1914 if (x->expr_type != EXPR_CONSTANT)
1917 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1919 gfc_set_model_kind (x->ts.kind);
1924 if (mpfr_sgn (x->value.real) <= 0)
1927 ("Argument of LOG at %L cannot be less than or equal to zero",
1929 gfc_free_expr (result);
1930 return &gfc_bad_expr;
1933 mpfr_log(result->value.real, x->value.real, GFC_RND_MODE);
1937 if ((mpfr_sgn (x->value.complex.r) == 0)
1938 && (mpfr_sgn (x->value.complex.i) == 0))
1940 gfc_error ("Complex argument of LOG at %L cannot be zero",
1942 gfc_free_expr (result);
1943 return &gfc_bad_expr;
1949 arctangent2 (x->value.complex.i, x->value.complex.r,
1950 result->value.complex.i);
1952 mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
1953 mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
1954 mpfr_add (xr, xr, xi, GFC_RND_MODE);
1955 mpfr_sqrt (xr, xr, GFC_RND_MODE);
1956 mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
1964 gfc_internal_error ("gfc_simplify_log: bad type");
1967 return range_check (result, "LOG");
1972 gfc_simplify_log10 (gfc_expr * x)
1976 if (x->expr_type != EXPR_CONSTANT)
1979 gfc_set_model_kind (x->ts.kind);
1981 if (mpfr_sgn (x->value.real) <= 0)
1984 ("Argument of LOG10 at %L cannot be less than or equal to zero",
1986 return &gfc_bad_expr;
1989 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1991 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
1993 return range_check (result, "LOG10");
1998 gfc_simplify_logical (gfc_expr * e, gfc_expr * k)
2003 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2005 return &gfc_bad_expr;
2007 if (e->expr_type != EXPR_CONSTANT)
2010 result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2012 result->value.logical = e->value.logical;
2018 /* This function is special since MAX() can take any number of
2019 arguments. The simplified expression is a rewritten version of the
2020 argument list containing at most one constant element. Other
2021 constant elements are deleted. Because the argument list has
2022 already been checked, this function always succeeds. sign is 1 for
2023 MAX(), -1 for MIN(). */
2026 simplify_min_max (gfc_expr * expr, int sign)
2028 gfc_actual_arglist *arg, *last, *extremum;
2029 gfc_intrinsic_sym * specific;
2033 specific = expr->value.function.isym;
2035 arg = expr->value.function.actual;
2037 for (; arg; last = arg, arg = arg->next)
2039 if (arg->expr->expr_type != EXPR_CONSTANT)
2042 if (extremum == NULL)
2048 switch (arg->expr->ts.type)
2051 if (mpz_cmp (arg->expr->value.integer,
2052 extremum->expr->value.integer) * sign > 0)
2053 mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2058 if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real) *
2060 mpfr_set (extremum->expr->value.real, arg->expr->value.real,
2066 gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
2069 /* Delete the extra constant argument. */
2071 expr->value.function.actual = arg->next;
2073 last->next = arg->next;
2076 gfc_free_actual_arglist (arg);
2080 /* If there is one value left, replace the function call with the
2082 if (expr->value.function.actual->next != NULL)
2085 /* Convert to the correct type and kind. */
2086 if (expr->ts.type != BT_UNKNOWN)
2087 return gfc_convert_constant (expr->value.function.actual->expr,
2088 expr->ts.type, expr->ts.kind);
2090 if (specific->ts.type != BT_UNKNOWN)
2091 return gfc_convert_constant (expr->value.function.actual->expr,
2092 specific->ts.type, specific->ts.kind);
2094 return gfc_copy_expr (expr->value.function.actual->expr);
2099 gfc_simplify_min (gfc_expr * e)
2101 return simplify_min_max (e, -1);
2106 gfc_simplify_max (gfc_expr * e)
2108 return simplify_min_max (e, 1);
2113 gfc_simplify_maxexponent (gfc_expr * x)
2118 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2120 result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2121 result->where = x->where;
2128 gfc_simplify_minexponent (gfc_expr * x)
2133 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2135 result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2136 result->where = x->where;
2143 gfc_simplify_mod (gfc_expr * a, gfc_expr * p)
2146 mpfr_t quot, iquot, term;
2148 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2151 result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
2156 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2158 /* Result is processor-dependent. */
2159 gfc_error ("Second argument MOD at %L is zero", &a->where);
2160 gfc_free_expr (result);
2161 return &gfc_bad_expr;
2163 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2167 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2169 /* Result is processor-dependent. */
2170 gfc_error ("Second argument of MOD at %L is zero", &p->where);
2171 gfc_free_expr (result);
2172 return &gfc_bad_expr;
2175 gfc_set_model_kind (a->ts.kind);
2180 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2181 mpfr_trunc (iquot, quot);
2182 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2183 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2191 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2194 return range_check (result, "MOD");
2199 gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
2202 mpfr_t quot, iquot, term;
2204 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2207 result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
2212 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2214 /* Result is processor-dependent. This processor just opts
2215 to not handle it at all. */
2216 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2217 gfc_free_expr (result);
2218 return &gfc_bad_expr;
2220 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2225 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2227 /* Result is processor-dependent. */
2228 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2229 gfc_free_expr (result);
2230 return &gfc_bad_expr;
2233 gfc_set_model_kind (a->ts.kind);
2238 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2239 mpfr_floor (iquot, quot);
2240 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2246 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2250 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2253 return range_check (result, "MODULO");
2257 /* Exists for the sole purpose of consistency with other intrinsics. */
2259 gfc_simplify_mvbits (gfc_expr * f ATTRIBUTE_UNUSED,
2260 gfc_expr * fp ATTRIBUTE_UNUSED,
2261 gfc_expr * l ATTRIBUTE_UNUSED,
2262 gfc_expr * to ATTRIBUTE_UNUSED,
2263 gfc_expr * tp ATTRIBUTE_UNUSED)
2270 gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
2275 int p, i, k, match_float;
2277 /* FIXME: This implementation is dopey and probably not quite right,
2278 but it's a start. */
2280 if (x->expr_type != EXPR_CONSTANT)
2283 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2285 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2287 val = mpfr_get_d (x->value.real, GFC_RND_MODE);
2288 p = gfc_real_kinds[k].digits;
2291 for (i = 1; i < p; ++i)
2296 /* TODO we should make sure that 'float' matches kind 4 */
2297 match_float = gfc_real_kinds[k].kind == 4;
2298 if (mpfr_cmp_ui (s->value.real, 0) > 0)
2304 mpfr_set_d (result->value.real, rval, GFC_RND_MODE);
2309 mpfr_set_d (result->value.real, val, GFC_RND_MODE);
2312 else if (mpfr_cmp_ui (s->value.real, 0) < 0)
2318 mpfr_set_d (result->value.real, rval, GFC_RND_MODE);
2323 mpfr_set_d (result->value.real, val, GFC_RND_MODE);
2328 gfc_error ("Invalid second argument of NEAREST at %L", &s->where);
2330 return &gfc_bad_expr;
2333 return range_check (result, "NEAREST");
2338 simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
2340 gfc_expr *rtrunc, *itrunc, *result;
2344 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2346 return &gfc_bad_expr;
2348 if (e->expr_type != EXPR_CONSTANT)
2351 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2353 rtrunc = gfc_copy_expr (e);
2354 itrunc = gfc_copy_expr (e);
2356 cmp = mpfr_cmp_ui (e->value.real, 0);
2358 gfc_set_model (e->value.real);
2360 mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
2364 mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
2365 mpfr_trunc (itrunc->value.real, rtrunc->value.real);
2369 mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
2370 mpfr_trunc (itrunc->value.real, rtrunc->value.real);
2373 mpfr_set_ui (itrunc->value.real, 0, GFC_RND_MODE);
2375 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
2377 gfc_free_expr (itrunc);
2378 gfc_free_expr (rtrunc);
2381 return range_check (result, name);
2386 gfc_simplify_nint (gfc_expr * e, gfc_expr * k)
2388 return simplify_nint ("NINT", e, k);
2393 gfc_simplify_idnint (gfc_expr * e)
2395 return simplify_nint ("IDNINT", e, NULL);
2400 gfc_simplify_not (gfc_expr * e)
2405 if (e->expr_type != EXPR_CONSTANT)
2408 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2410 mpz_com (result->value.integer, e->value.integer);
2412 /* Because of how GMP handles numbers, the result must be ANDed with
2413 the max_int mask. For radices <> 2, this will require change. */
2415 i = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2417 mpz_and (result->value.integer, result->value.integer,
2418 gfc_integer_kinds[i].max_int);
2420 return range_check (result, "NOT");
2425 gfc_simplify_null (gfc_expr * mold)
2429 result = gfc_get_expr ();
2430 result->expr_type = EXPR_NULL;
2433 result->ts.type = BT_UNKNOWN;
2436 result->ts = mold->ts;
2437 result->where = mold->where;
2445 gfc_simplify_precision (gfc_expr * e)
2450 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2452 result = gfc_int_expr (gfc_real_kinds[i].precision);
2453 result->where = e->where;
2460 gfc_simplify_radix (gfc_expr * e)
2465 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2469 i = gfc_integer_kinds[i].radix;
2473 i = gfc_real_kinds[i].radix;
2480 result = gfc_int_expr (i);
2481 result->where = e->where;
2488 gfc_simplify_range (gfc_expr * e)
2494 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2499 j = gfc_integer_kinds[i].range;
2504 j = gfc_real_kinds[i].range;
2511 result = gfc_int_expr (j);
2512 result->where = e->where;
2519 gfc_simplify_real (gfc_expr * e, gfc_expr * k)
2524 if (e->ts.type == BT_COMPLEX)
2525 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
2527 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
2530 return &gfc_bad_expr;
2532 if (e->expr_type != EXPR_CONSTANT)
2538 result = gfc_int2real (e, kind);
2542 result = gfc_real2real (e, kind);
2546 result = gfc_complex2real (e, kind);
2550 gfc_internal_error ("bad type in REAL");
2554 return range_check (result, "REAL");
2558 gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
2561 int i, j, len, ncopies, nlen;
2563 if (e->expr_type != EXPR_CONSTANT || n->expr_type != EXPR_CONSTANT)
2566 if (n != NULL && (gfc_extract_int (n, &ncopies) != NULL || ncopies < 0))
2568 gfc_error ("Invalid second argument of REPEAT at %L", &n->where);
2569 return &gfc_bad_expr;
2572 len = e->value.character.length;
2573 nlen = ncopies * len;
2575 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2579 result->value.character.string = gfc_getmem (1);
2580 result->value.character.length = 0;
2581 result->value.character.string[0] = '\0';
2585 result->value.character.length = nlen;
2586 result->value.character.string = gfc_getmem (nlen + 1);
2588 for (i = 0; i < ncopies; i++)
2589 for (j = 0; j < len; j++)
2590 result->value.character.string[j + i * len] =
2591 e->value.character.string[j];
2593 result->value.character.string[nlen] = '\0'; /* For debugger */
2598 /* This one is a bear, but mainly has to do with shuffling elements. */
2601 gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
2602 gfc_expr * pad, gfc_expr * order_exp)
2605 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
2606 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
2607 gfc_constructor *head, *tail;
2613 /* Unpack the shape array. */
2614 if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
2617 if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
2621 && (pad->expr_type != EXPR_ARRAY
2622 || !gfc_is_constant_expr (pad)))
2625 if (order_exp != NULL
2626 && (order_exp->expr_type != EXPR_ARRAY
2627 || !gfc_is_constant_expr (order_exp)))
2636 e = gfc_get_array_element (shape_exp, rank);
2640 if (gfc_extract_int (e, &shape[rank]) != NULL)
2642 gfc_error ("Integer too large in shape specification at %L",
2650 if (rank >= GFC_MAX_DIMENSIONS)
2652 gfc_error ("Too many dimensions in shape specification for RESHAPE "
2653 "at %L", &e->where);
2658 if (shape[rank] < 0)
2660 gfc_error ("Shape specification at %L cannot be negative",
2670 gfc_error ("Shape specification at %L cannot be the null array",
2675 /* Now unpack the order array if present. */
2676 if (order_exp == NULL)
2678 for (i = 0; i < rank; i++)
2685 for (i = 0; i < rank; i++)
2688 for (i = 0; i < rank; i++)
2690 e = gfc_get_array_element (order_exp, i);
2694 ("ORDER parameter of RESHAPE at %L is not the same size "
2695 "as SHAPE parameter", &order_exp->where);
2699 if (gfc_extract_int (e, &order[i]) != NULL)
2701 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
2709 if (order[i] < 1 || order[i] > rank)
2711 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
2720 gfc_error ("Invalid permutation in ORDER parameter at %L",
2729 /* Count the elements in the source and padding arrays. */
2734 gfc_array_size (pad, &size);
2735 npad = mpz_get_ui (size);
2739 gfc_array_size (source, &size);
2740 nsource = mpz_get_ui (size);
2743 /* If it weren't for that pesky permutation we could just loop
2744 through the source and round out any shortage with pad elements.
2745 But no, someone just had to have the compiler do something the
2746 user should be doing. */
2748 for (i = 0; i < rank; i++)
2753 /* Figure out which element to extract. */
2754 mpz_set_ui (index, 0);
2756 for (i = rank - 1; i >= 0; i--)
2758 mpz_add_ui (index, index, x[order[i]]);
2760 mpz_mul_ui (index, index, shape[order[i - 1]]);
2763 if (mpz_cmp_ui (index, INT_MAX) > 0)
2764 gfc_internal_error ("Reshaped array too large at %L", &e->where);
2766 j = mpz_get_ui (index);
2769 e = gfc_get_array_element (source, j);
2777 ("PAD parameter required for short SOURCE parameter at %L",
2783 e = gfc_get_array_element (pad, j);
2787 head = tail = gfc_get_constructor ();
2790 tail->next = gfc_get_constructor ();
2797 tail->where = e->where;
2800 /* Calculate the next element. */
2804 if (++x[i] < shape[i])
2815 e = gfc_get_expr ();
2816 e->where = source->where;
2817 e->expr_type = EXPR_ARRAY;
2818 e->value.constructor = head;
2819 e->shape = gfc_get_shape (rank);
2821 for (i = 0; i < rank; i++)
2822 mpz_init_set_ui (e->shape[i], shape[i]);
2824 e->ts = head->expr->ts;
2830 gfc_free_constructor (head);
2832 return &gfc_bad_expr;
2837 gfc_simplify_rrspacing (gfc_expr * x)
2840 mpfr_t absv, log2, exp, frac, pow2;
2843 if (x->expr_type != EXPR_CONSTANT)
2846 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2848 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
2850 p = gfc_real_kinds[i].digits;
2852 gfc_set_model_kind (x->ts.kind);
2854 if (mpfr_sgn (x->value.real) == 0)
2856 mpfr_ui_div (result->value.real, 1, gfc_real_kinds[i].tiny, GFC_RND_MODE);
2865 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
2866 mpfr_log2 (log2, absv, GFC_RND_MODE);
2868 mpfr_trunc (log2, log2);
2869 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
2871 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
2872 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
2874 mpfr_mul_2exp (result->value.real, frac, (unsigned long)p, GFC_RND_MODE);
2881 return range_check (result, "RRSPACING");
2886 gfc_simplify_scale (gfc_expr * x, gfc_expr * i)
2888 int k, neg_flag, power, exp_range;
2889 mpfr_t scale, radix;
2892 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
2895 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
2897 if (mpfr_sgn (x->value.real) == 0)
2899 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2903 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2905 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
2907 /* This check filters out values of i that would overflow an int. */
2908 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
2909 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
2911 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
2912 return &gfc_bad_expr;
2915 /* Compute scale = radix ** power. */
2916 power = mpz_get_si (i->value.integer);
2926 gfc_set_model_kind (x->ts.kind);
2929 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
2930 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
2933 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
2935 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
2940 return range_check (result, "SCALE");
2945 gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
2950 size_t indx, len, lenc;
2952 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
2955 if (b != NULL && b->value.logical != 0)
2960 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
2963 len = e->value.character.length;
2964 lenc = c->value.character.length;
2966 if (len == 0 || lenc == 0)
2975 strcspn (e->value.character.string, c->value.character.string) + 1;
2982 for (indx = len; indx > 0; indx--)
2984 for (i = 0; i < lenc; i++)
2986 if (c->value.character.string[i]
2987 == e->value.character.string[indx - 1])
2995 mpz_set_ui (result->value.integer, indx);
2996 return range_check (result, "SCAN");
3001 gfc_simplify_selected_int_kind (gfc_expr * e)
3006 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3011 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3012 if (gfc_integer_kinds[i].range >= range
3013 && gfc_integer_kinds[i].kind < kind)
3014 kind = gfc_integer_kinds[i].kind;
3016 if (kind == INT_MAX)
3019 result = gfc_int_expr (kind);
3020 result->where = e->where;
3027 gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q)
3029 int range, precision, i, kind, found_precision, found_range;
3036 if (p->expr_type != EXPR_CONSTANT
3037 || gfc_extract_int (p, &precision) != NULL)
3045 if (q->expr_type != EXPR_CONSTANT
3046 || gfc_extract_int (q, &range) != NULL)
3051 found_precision = 0;
3054 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3056 if (gfc_real_kinds[i].precision >= precision)
3057 found_precision = 1;
3059 if (gfc_real_kinds[i].range >= range)
3062 if (gfc_real_kinds[i].precision >= precision
3063 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3064 kind = gfc_real_kinds[i].kind;
3067 if (kind == INT_MAX)
3071 if (!found_precision)
3077 result = gfc_int_expr (kind);
3078 result->where = (p != NULL) ? p->where : q->where;
3085 gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i)
3088 mpfr_t exp, absv, log2, pow2, frac;
3091 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3094 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3096 gfc_set_model_kind (x->ts.kind);
3098 if (mpfr_sgn (x->value.real) == 0)
3100 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3110 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3111 mpfr_log2 (log2, absv, GFC_RND_MODE);
3113 mpfr_trunc (log2, log2);
3114 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3116 /* Old exponent value, and fraction. */
3117 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3119 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3122 exp2 = (unsigned long) mpz_get_d (i->value.integer);
3123 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3130 return range_check (result, "SET_EXPONENT");
3135 gfc_simplify_shape (gfc_expr * source)
3137 mpz_t shape[GFC_MAX_DIMENSIONS];
3138 gfc_expr *result, *e, *f;
3143 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3146 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3149 ar = gfc_find_array_ref (source);
3151 t = gfc_array_ref_shape (ar, shape);
3153 for (n = 0; n < source->rank; n++)
3155 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3160 mpz_set (e->value.integer, shape[n]);
3161 mpz_clear (shape[n]);
3165 mpz_set_ui (e->value.integer, n + 1);
3167 f = gfc_simplify_size (source, e);
3171 gfc_free_expr (result);
3180 gfc_append_constructor (result, e);
3188 gfc_simplify_size (gfc_expr * array, gfc_expr * dim)
3196 if (gfc_array_size (array, &size) == FAILURE)
3201 if (dim->expr_type != EXPR_CONSTANT)
3204 d = mpz_get_ui (dim->value.integer) - 1;
3205 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3209 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3212 mpz_set (result->value.integer, size);
3219 gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
3223 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3226 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3231 mpz_abs (result->value.integer, x->value.integer);
3232 if (mpz_sgn (y->value.integer) < 0)
3233 mpz_neg (result->value.integer, result->value.integer);
3238 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3240 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3241 if (mpfr_sgn (y->value.real) < 0)
3242 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3247 gfc_internal_error ("Bad type in gfc_simplify_sign");
3255 gfc_simplify_sin (gfc_expr * x)
3260 if (x->expr_type != EXPR_CONSTANT)
3263 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3268 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3272 gfc_set_model (x->value.real);
3276 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
3277 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3278 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3280 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
3281 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3282 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3289 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3292 return range_check (result, "SIN");
3297 gfc_simplify_sinh (gfc_expr * x)
3301 if (x->expr_type != EXPR_CONSTANT)
3304 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3306 mpfr_sinh(result->value.real, x->value.real, GFC_RND_MODE);
3308 return range_check (result, "SINH");
3312 /* The argument is always a double precision real that is converted to
3313 single precision. TODO: Rounding! */
3316 gfc_simplify_sngl (gfc_expr * a)
3320 if (a->expr_type != EXPR_CONSTANT)
3323 result = gfc_real2real (a, gfc_default_real_kind);
3324 return range_check (result, "SNGL");
3329 gfc_simplify_spacing (gfc_expr * x)
3336 if (x->expr_type != EXPR_CONSTANT)
3339 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3341 p = gfc_real_kinds[i].digits;
3343 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3345 gfc_set_model_kind (x->ts.kind);
3347 if (mpfr_sgn (x->value.real) == 0)
3349 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3356 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3357 mpfr_log2 (log2, absv, GFC_RND_MODE);
3358 mpfr_trunc (log2, log2);
3360 mpfr_add_ui (log2, log2, 1, GFC_RND_MODE);
3362 /* FIXME: We should be using mpfr_get_si here, but this function is
3363 not available with the version of mpfr distributed with gmp (as of
3364 2004-09-17). Replace once mpfr has been imported into the gcc cvs
3366 diff = (long)mpfr_get_d (log2, GFC_RND_MODE) - (long)p;
3367 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3368 mpfr_mul_2si (result->value.real, result->value.real, diff, GFC_RND_MODE);
3373 if (mpfr_cmp (result->value.real, gfc_real_kinds[i].tiny) < 0)
3374 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3376 return range_check (result, "SPACING");
3381 gfc_simplify_sqrt (gfc_expr * e)
3384 mpfr_t ac, ad, s, t, w;
3386 if (e->expr_type != EXPR_CONSTANT)
3389 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3394 if (mpfr_cmp_si (e->value.real, 0) < 0)
3396 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3401 /* Formula taken from Numerical Recipes to avoid over- and
3404 gfc_set_model (e->value.real);
3411 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3412 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3415 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3416 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3420 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3421 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3423 if (mpfr_cmp (ac, ad) >= 0)
3425 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3426 mpfr_mul (t, t, t, GFC_RND_MODE);
3427 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3428 mpfr_sqrt (t, t, GFC_RND_MODE);
3429 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3430 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3431 mpfr_sqrt (t, t, GFC_RND_MODE);
3432 mpfr_sqrt (s, ac, GFC_RND_MODE);
3433 mpfr_mul (w, s, t, GFC_RND_MODE);
3437 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3438 mpfr_mul (t, s, s, GFC_RND_MODE);
3439 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3440 mpfr_sqrt (t, t, GFC_RND_MODE);
3441 mpfr_abs (s, s, GFC_RND_MODE);
3442 mpfr_add (t, t, s, GFC_RND_MODE);
3443 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3444 mpfr_sqrt (t, t, GFC_RND_MODE);
3445 mpfr_sqrt (s, ad, GFC_RND_MODE);
3446 mpfr_mul (w, s, t, GFC_RND_MODE);
3449 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3451 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3452 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3453 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3455 else if (mpfr_cmp_ui (w, 0) != 0
3456 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3457 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3459 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3460 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3461 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3463 else if (mpfr_cmp_ui (w, 0) != 0
3464 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3465 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
3467 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3468 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
3469 mpfr_neg (w, w, GFC_RND_MODE);
3470 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3473 gfc_internal_error ("invalid complex argument of SQRT at %L",
3485 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
3488 return range_check (result, "SQRT");
3491 gfc_free_expr (result);
3492 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
3493 return &gfc_bad_expr;
3498 gfc_simplify_tan (gfc_expr * x)
3503 if (x->expr_type != EXPR_CONSTANT)
3506 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3508 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3510 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
3512 return range_check (result, "TAN");
3517 gfc_simplify_tanh (gfc_expr * x)
3521 if (x->expr_type != EXPR_CONSTANT)
3524 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3526 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
3528 return range_check (result, "TANH");
3534 gfc_simplify_tiny (gfc_expr * e)
3539 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
3541 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3542 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3549 gfc_simplify_trim (gfc_expr * e)
3552 int count, i, len, lentrim;
3554 if (e->expr_type != EXPR_CONSTANT)
3557 len = e->value.character.length;
3559 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3561 for (count = 0, i = 1; i <= len; ++i)
3563 if (e->value.character.string[len - i] == ' ')
3569 lentrim = len - count;
3571 result->value.character.length = lentrim;
3572 result->value.character.string = gfc_getmem (lentrim + 1);
3574 for (i = 0; i < lentrim; i++)
3575 result->value.character.string[i] = e->value.character.string[i];
3577 result->value.character.string[lentrim] = '\0'; /* For debugger */
3584 gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim)
3586 return gfc_simplify_bound (array, dim, 1);
3591 gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
3595 size_t index, len, lenset;
3598 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
3601 if (b != NULL && b->value.logical != 0)
3606 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3609 len = s->value.character.length;
3610 lenset = set->value.character.length;
3614 mpz_set_ui (result->value.integer, 0);
3622 mpz_set_ui (result->value.integer, len);
3627 strspn (s->value.character.string, set->value.character.string) + 1;
3636 mpz_set_ui (result->value.integer, 1);
3639 for (index = len; index > 0; index --)
3641 for (i = 0; i < lenset; i++)
3643 if (s->value.character.string[index - 1]
3644 == set->value.character.string[i])
3652 mpz_set_ui (result->value.integer, index);
3656 /****************** Constant simplification *****************/
3658 /* Master function to convert one constant to another. While this is
3659 used as a simplification function, it requires the destination type
3660 and kind information which is supplied by a special case in
3664 gfc_convert_constant (gfc_expr * e, bt type, int kind)
3666 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
3667 gfc_constructor *head, *c, *tail = NULL;
3681 f = gfc_int2complex;
3698 f = gfc_real2complex;
3709 f = gfc_complex2int;
3712 f = gfc_complex2real;
3715 f = gfc_complex2complex;
3724 if (type != BT_LOGICAL)
3731 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
3736 switch (e->expr_type)
3739 result = f (e, kind);
3741 return &gfc_bad_expr;
3745 if (!gfc_is_constant_expr (e))
3750 for (c = e->value.constructor; c; c = c->next)
3753 head = tail = gfc_get_constructor ();
3756 tail->next = gfc_get_constructor ();
3760 tail->where = c->where;
3762 if (c->iterator == NULL)
3763 tail->expr = f (c->expr, kind);
3766 g = gfc_convert_constant (c->expr, type, kind);
3767 if (g == &gfc_bad_expr)
3772 if (tail->expr == NULL)
3774 gfc_free_constructor (head);
3779 result = gfc_get_expr ();
3780 result->ts.type = type;
3781 result->ts.kind = kind;
3782 result->expr_type = EXPR_ARRAY;
3783 result->value.constructor = head;
3784 result->shape = gfc_copy_shape (e->shape, e->rank);
3785 result->where = e->where;
3786 result->rank = e->rank;
3797 /****************** Helper functions ***********************/
3799 /* Given a collating table, create the inverse table. */
3802 invert_table (const int *table, int *xtable)
3806 for (i = 0; i < 256; i++)
3809 for (i = 0; i < 256; i++)
3810 xtable[table[i]] = i;
3815 gfc_simplify_init_1 (void)
3818 invert_table (ascii_table, xascii_table);