1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 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
28 #include "intrinsic.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 /* Static table for converting non-ascii character sets to ascii.
68 The xascii_table[] is the inverse table. */
70 static int ascii_table
[256] = {
71 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
72 '\b', '\t', '\n', '\v', '\0', '\r', '\0', '\0',
73 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
74 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
75 ' ', '!', '\'', '#', '$', '%', '&', '\'',
76 '(', ')', '*', '+', ',', '-', '.', '/',
77 '0', '1', '2', '3', '4', '5', '6', '7',
78 '8', '9', ':', ';', '<', '=', '>', '?',
79 '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
80 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
81 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
82 'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
83 '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
84 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
85 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
86 'x', 'y', 'z', '{', '|', '}', '~', '\?'
89 static int xascii_table
[256];
92 /* Range checks an expression node. If all goes well, returns the
93 node, otherwise returns &gfc_bad_expr and frees the node. */
96 range_check (gfc_expr
* result
, const char *name
)
98 if (gfc_range_check (result
) == ARITH_OK
)
101 gfc_error ("Result of %s overflows its kind at %L", name
, &result
->where
);
102 gfc_free_expr (result
);
103 return &gfc_bad_expr
;
107 /* A helper function that gets an optional and possibly missing
108 kind parameter. Returns the kind, -1 if something went wrong. */
111 get_kind (bt type
, gfc_expr
* k
, const char *name
, int default_kind
)
118 if (k
->expr_type
!= EXPR_CONSTANT
)
120 gfc_error ("KIND parameter of %s at %L must be an initialization "
121 "expression", name
, &k
->where
);
126 if (gfc_extract_int (k
, &kind
) != NULL
127 || gfc_validate_kind (type
, kind
, true) < 0)
130 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
138 /* Checks if X, which is assumed to represent a two's complement
139 integer of binary width BITSIZE, has the signbit set. If so, makes
140 X the corresponding negative number. */
143 twos_complement (mpz_t x
, int bitsize
)
147 if (mpz_tstbit (x
, bitsize
- 1) == 1)
149 mpz_init_set_ui(mask
, 1);
150 mpz_mul_2exp(mask
, mask
, bitsize
);
151 mpz_sub_ui(mask
, mask
, 1);
153 /* We negate the number by hand, zeroing the high bits, that is
154 make it the corresponding positive number, and then have it
155 negated by GMP, giving the correct representation of the
158 mpz_add_ui (x
, x
, 1);
159 mpz_and (x
, x
, mask
);
168 /********************** Simplification functions *****************************/
171 gfc_simplify_abs (gfc_expr
* e
)
175 if (e
->expr_type
!= EXPR_CONSTANT
)
181 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
183 mpz_abs (result
->value
.integer
, e
->value
.integer
);
185 result
= range_check (result
, "IABS");
189 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
191 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
193 result
= range_check (result
, "ABS");
197 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
199 gfc_set_model_kind (e
->ts
.kind
);
201 mpfr_hypot (result
->value
.real
, e
->value
.complex.r
,
202 e
->value
.complex.i
, GFC_RND_MODE
);
203 result
= range_check (result
, "CABS");
207 gfc_internal_error ("gfc_simplify_abs(): Bad type");
215 gfc_simplify_achar (gfc_expr
* e
)
220 if (e
->expr_type
!= EXPR_CONSTANT
)
223 /* We cannot assume that the native character set is ASCII in this
225 if (gfc_extract_int (e
, &index
) != NULL
|| index
< 0 || index
> 127)
227 gfc_error ("Extended ASCII not implemented: argument of ACHAR at %L "
228 "must be between 0 and 127", &e
->where
);
229 return &gfc_bad_expr
;
232 result
= gfc_constant_result (BT_CHARACTER
, gfc_default_character_kind
,
235 result
->value
.character
.string
= gfc_getmem (2);
237 result
->value
.character
.length
= 1;
238 result
->value
.character
.string
[0] = ascii_table
[index
];
239 result
->value
.character
.string
[1] = '\0'; /* For debugger */
245 gfc_simplify_acos (gfc_expr
* x
)
249 if (x
->expr_type
!= EXPR_CONSTANT
)
252 if (mpfr_cmp_si (x
->value
.real
, 1) > 0 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
254 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
256 return &gfc_bad_expr
;
259 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
261 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
263 return range_check (result
, "ACOS");
268 gfc_simplify_adjustl (gfc_expr
* e
)
274 if (e
->expr_type
!= EXPR_CONSTANT
)
277 len
= e
->value
.character
.length
;
279 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
281 result
->value
.character
.length
= len
;
282 result
->value
.character
.string
= gfc_getmem (len
+ 1);
284 for (count
= 0, i
= 0; i
< len
; ++i
)
286 ch
= e
->value
.character
.string
[i
];
292 for (i
= 0; i
< len
- count
; ++i
)
294 result
->value
.character
.string
[i
] =
295 e
->value
.character
.string
[count
+ i
];
298 for (i
= len
- count
; i
< len
; ++i
)
300 result
->value
.character
.string
[i
] = ' ';
303 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
310 gfc_simplify_adjustr (gfc_expr
* e
)
316 if (e
->expr_type
!= EXPR_CONSTANT
)
319 len
= e
->value
.character
.length
;
321 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
323 result
->value
.character
.length
= len
;
324 result
->value
.character
.string
= gfc_getmem (len
+ 1);
326 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
328 ch
= e
->value
.character
.string
[i
];
334 for (i
= 0; i
< count
; ++i
)
336 result
->value
.character
.string
[i
] = ' ';
339 for (i
= count
; i
< len
; ++i
)
341 result
->value
.character
.string
[i
] =
342 e
->value
.character
.string
[i
- count
];
345 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
352 gfc_simplify_aimag (gfc_expr
* e
)
356 if (e
->expr_type
!= EXPR_CONSTANT
)
359 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
360 mpfr_set (result
->value
.real
, e
->value
.complex.i
, GFC_RND_MODE
);
362 return range_check (result
, "AIMAG");
367 gfc_simplify_aint (gfc_expr
* e
, gfc_expr
* k
)
369 gfc_expr
*rtrunc
, *result
;
372 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
374 return &gfc_bad_expr
;
376 if (e
->expr_type
!= EXPR_CONSTANT
)
379 rtrunc
= gfc_copy_expr (e
);
381 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
383 result
= gfc_real2real (rtrunc
, kind
);
384 gfc_free_expr (rtrunc
);
386 return range_check (result
, "AINT");
391 gfc_simplify_dint (gfc_expr
* e
)
393 gfc_expr
*rtrunc
, *result
;
395 if (e
->expr_type
!= EXPR_CONSTANT
)
398 rtrunc
= gfc_copy_expr (e
);
400 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
402 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
403 gfc_free_expr (rtrunc
);
405 return range_check (result
, "DINT");
410 gfc_simplify_anint (gfc_expr
* e
, gfc_expr
* k
)
415 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
417 return &gfc_bad_expr
;
419 if (e
->expr_type
!= EXPR_CONSTANT
)
422 result
= gfc_constant_result (e
->ts
.type
, kind
, &e
->where
);
424 mpfr_round (result
->value
.real
, e
->value
.real
);
426 return range_check (result
, "ANINT");
431 gfc_simplify_dnint (gfc_expr
* e
)
435 if (e
->expr_type
!= EXPR_CONSTANT
)
438 result
= gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &e
->where
);
440 mpfr_round (result
->value
.real
, e
->value
.real
);
442 return range_check (result
, "DNINT");
447 gfc_simplify_asin (gfc_expr
* x
)
451 if (x
->expr_type
!= EXPR_CONSTANT
)
454 if (mpfr_cmp_si (x
->value
.real
, 1) > 0 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
456 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
458 return &gfc_bad_expr
;
461 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
463 mpfr_asin(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
465 return range_check (result
, "ASIN");
470 gfc_simplify_atan (gfc_expr
* x
)
474 if (x
->expr_type
!= EXPR_CONSTANT
)
477 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
479 mpfr_atan(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
481 return range_check (result
, "ATAN");
487 gfc_simplify_atan2 (gfc_expr
* y
, gfc_expr
* x
)
491 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
494 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
496 if (mpfr_sgn (y
->value
.real
) == 0 && mpfr_sgn (x
->value
.real
) == 0)
499 ("If first argument of ATAN2 %L is zero, then the second argument "
500 "must not be zero", &x
->where
);
501 gfc_free_expr (result
);
502 return &gfc_bad_expr
;
505 arctangent2 (y
->value
.real
, x
->value
.real
, result
->value
.real
);
507 return range_check (result
, "ATAN2");
513 gfc_simplify_bit_size (gfc_expr
* e
)
518 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
519 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
520 mpz_set_ui (result
->value
.integer
, gfc_integer_kinds
[i
].bit_size
);
527 gfc_simplify_btest (gfc_expr
* e
, gfc_expr
* bit
)
531 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
534 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
535 return gfc_logical_expr (0, &e
->where
);
537 return gfc_logical_expr (mpz_tstbit (e
->value
.integer
, b
), &e
->where
);
542 gfc_simplify_ceiling (gfc_expr
* e
, gfc_expr
* k
)
544 gfc_expr
*ceil
, *result
;
547 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
549 return &gfc_bad_expr
;
551 if (e
->expr_type
!= EXPR_CONSTANT
)
554 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
556 ceil
= gfc_copy_expr (e
);
558 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
559 gfc_mpfr_to_mpz(result
->value
.integer
, ceil
->value
.real
);
561 gfc_free_expr (ceil
);
563 return range_check (result
, "CEILING");
568 gfc_simplify_char (gfc_expr
* e
, gfc_expr
* k
)
573 kind
= get_kind (BT_CHARACTER
, k
, "CHAR", gfc_default_character_kind
);
575 return &gfc_bad_expr
;
577 if (e
->expr_type
!= EXPR_CONSTANT
)
580 if (gfc_extract_int (e
, &c
) != NULL
|| c
< 0 || c
> 255)
582 gfc_error ("Bad character in CHAR function at %L", &e
->where
);
583 return &gfc_bad_expr
;
586 result
= gfc_constant_result (BT_CHARACTER
, kind
, &e
->where
);
588 result
->value
.character
.length
= 1;
589 result
->value
.character
.string
= gfc_getmem (2);
591 result
->value
.character
.string
[0] = c
;
592 result
->value
.character
.string
[1] = '\0'; /* For debugger */
598 /* Common subroutine for simplifying CMPLX and DCMPLX. */
601 simplify_cmplx (const char *name
, gfc_expr
* x
, gfc_expr
* y
, int kind
)
605 result
= gfc_constant_result (BT_COMPLEX
, kind
, &x
->where
);
607 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
612 mpfr_set_z (result
->value
.complex.r
, x
->value
.integer
, GFC_RND_MODE
);
616 mpfr_set (result
->value
.complex.r
, x
->value
.real
, GFC_RND_MODE
);
620 mpfr_set (result
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
621 mpfr_set (result
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
625 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
633 mpfr_set_z (result
->value
.complex.i
, y
->value
.integer
, GFC_RND_MODE
);
637 mpfr_set (result
->value
.complex.i
, y
->value
.real
, GFC_RND_MODE
);
641 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
645 return range_check (result
, name
);
650 gfc_simplify_cmplx (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* k
)
654 if (x
->expr_type
!= EXPR_CONSTANT
655 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
658 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_real_kind
);
660 return &gfc_bad_expr
;
662 return simplify_cmplx ("CMPLX", x
, y
, kind
);
667 gfc_simplify_conjg (gfc_expr
* e
)
671 if (e
->expr_type
!= EXPR_CONSTANT
)
674 result
= gfc_copy_expr (e
);
675 mpfr_neg (result
->value
.complex.i
, result
->value
.complex.i
, GFC_RND_MODE
);
677 return range_check (result
, "CONJG");
682 gfc_simplify_cos (gfc_expr
* x
)
687 if (x
->expr_type
!= EXPR_CONSTANT
)
690 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
695 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
698 gfc_set_model_kind (x
->ts
.kind
);
702 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
703 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
704 mpfr_mul(result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
706 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
707 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
708 mpfr_mul (xp
, xp
, xq
, GFC_RND_MODE
);
709 mpfr_neg (result
->value
.complex.i
, xp
, GFC_RND_MODE
);
715 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
718 return range_check (result
, "COS");
724 gfc_simplify_cosh (gfc_expr
* x
)
728 if (x
->expr_type
!= EXPR_CONSTANT
)
731 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
733 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
735 return range_check (result
, "COSH");
740 gfc_simplify_dcmplx (gfc_expr
* x
, gfc_expr
* y
)
743 if (x
->expr_type
!= EXPR_CONSTANT
744 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
747 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
752 gfc_simplify_dble (gfc_expr
* e
)
756 if (e
->expr_type
!= EXPR_CONSTANT
)
762 result
= gfc_int2real (e
, gfc_default_double_kind
);
766 result
= gfc_real2real (e
, gfc_default_double_kind
);
770 result
= gfc_complex2real (e
, gfc_default_double_kind
);
774 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e
->where
);
777 return range_check (result
, "DBLE");
782 gfc_simplify_digits (gfc_expr
* x
)
786 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
790 digits
= gfc_integer_kinds
[i
].digits
;
795 digits
= gfc_real_kinds
[i
].digits
;
802 return gfc_int_expr (digits
);
807 gfc_simplify_dim (gfc_expr
* x
, gfc_expr
* y
)
811 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
814 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
819 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
820 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
822 mpz_set_ui (result
->value
.integer
, 0);
827 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
828 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
830 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
835 gfc_internal_error ("gfc_simplify_dim(): Bad type");
838 return range_check (result
, "DIM");
843 gfc_simplify_dprod (gfc_expr
* x
, gfc_expr
* y
)
845 gfc_expr
*a1
, *a2
, *result
;
847 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
851 gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &x
->where
);
853 a1
= gfc_real2real (x
, gfc_default_double_kind
);
854 a2
= gfc_real2real (y
, gfc_default_double_kind
);
856 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
861 return range_check (result
, "DPROD");
866 gfc_simplify_epsilon (gfc_expr
* e
)
871 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
873 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
875 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
877 return range_check (result
, "EPSILON");
882 gfc_simplify_exp (gfc_expr
* x
)
887 if (x
->expr_type
!= EXPR_CONSTANT
)
890 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
895 mpfr_exp(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
899 gfc_set_model_kind (x
->ts
.kind
);
902 mpfr_exp (xq
, x
->value
.complex.r
, GFC_RND_MODE
);
903 mpfr_cos (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
904 mpfr_mul (result
->value
.complex.r
, xq
, xp
, GFC_RND_MODE
);
905 mpfr_sin (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
906 mpfr_mul (result
->value
.complex.i
, xq
, xp
, GFC_RND_MODE
);
912 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
915 return range_check (result
, "EXP");
918 /* FIXME: MPFR should be able to do this better */
920 gfc_simplify_exponent (gfc_expr
* x
)
926 if (x
->expr_type
!= EXPR_CONSTANT
)
929 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
932 gfc_set_model (x
->value
.real
);
934 if (mpfr_sgn (x
->value
.real
) == 0)
936 mpz_set_ui (result
->value
.integer
, 0);
942 mpfr_abs (tmp
, x
->value
.real
, GFC_RND_MODE
);
943 mpfr_log2 (tmp
, tmp
, GFC_RND_MODE
);
945 gfc_mpfr_to_mpz (result
->value
.integer
, tmp
);
947 /* The model number for tiny(x) is b**(emin - 1) where b is the base and emin
948 is the smallest exponent value. So, we need to add 1 if x is tiny(x). */
949 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
950 if (mpfr_cmp (x
->value
.real
, gfc_real_kinds
[i
].tiny
) == 0)
951 mpz_add_ui (result
->value
.integer
,result
->value
.integer
, 1);
955 return range_check (result
, "EXPONENT");
960 gfc_simplify_float (gfc_expr
* a
)
964 if (a
->expr_type
!= EXPR_CONSTANT
)
967 result
= gfc_int2real (a
, gfc_default_real_kind
);
968 return range_check (result
, "FLOAT");
973 gfc_simplify_floor (gfc_expr
* e
, gfc_expr
* k
)
979 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
981 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
983 if (e
->expr_type
!= EXPR_CONSTANT
)
986 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
988 gfc_set_model_kind (kind
);
990 mpfr_floor (floor
, e
->value
.real
);
992 gfc_mpfr_to_mpz (result
->value
.integer
, floor
);
996 return range_check (result
, "FLOOR");
1001 gfc_simplify_fraction (gfc_expr
* x
)
1004 mpfr_t absv
, exp
, pow2
;
1006 if (x
->expr_type
!= EXPR_CONSTANT
)
1009 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
1011 gfc_set_model_kind (x
->ts
.kind
);
1013 if (mpfr_sgn (x
->value
.real
) == 0)
1015 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1023 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
1024 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
1026 mpfr_trunc (exp
, exp
);
1027 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
1029 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
1031 mpfr_div (result
->value
.real
, absv
, pow2
, GFC_RND_MODE
);
1037 return range_check (result
, "FRACTION");
1042 gfc_simplify_huge (gfc_expr
* e
)
1047 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1049 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1054 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
1058 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
1070 gfc_simplify_iachar (gfc_expr
* e
)
1075 if (e
->expr_type
!= EXPR_CONSTANT
)
1078 if (e
->value
.character
.length
!= 1)
1080 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
1081 return &gfc_bad_expr
;
1084 index
= xascii_table
[(int) e
->value
.character
.string
[0] & 0xFF];
1086 result
= gfc_int_expr (index
);
1087 result
->where
= e
->where
;
1089 return range_check (result
, "IACHAR");
1094 gfc_simplify_iand (gfc_expr
* x
, gfc_expr
* y
)
1098 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1101 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1103 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1105 return range_check (result
, "IAND");
1110 gfc_simplify_ibclr (gfc_expr
* x
, gfc_expr
* y
)
1115 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1118 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1120 gfc_error ("Invalid second argument of IBCLR at %L", &y
->where
);
1121 return &gfc_bad_expr
;
1124 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1126 if (pos
> gfc_integer_kinds
[k
].bit_size
)
1128 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1130 return &gfc_bad_expr
;
1133 result
= gfc_copy_expr (x
);
1135 mpz_clrbit (result
->value
.integer
, pos
);
1136 return range_check (result
, "IBCLR");
1141 gfc_simplify_ibits (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
1148 if (x
->expr_type
!= EXPR_CONSTANT
1149 || y
->expr_type
!= EXPR_CONSTANT
1150 || z
->expr_type
!= EXPR_CONSTANT
)
1153 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1155 gfc_error ("Invalid second argument of IBITS at %L", &y
->where
);
1156 return &gfc_bad_expr
;
1159 if (gfc_extract_int (z
, &len
) != NULL
|| len
< 0)
1161 gfc_error ("Invalid third argument of IBITS at %L", &z
->where
);
1162 return &gfc_bad_expr
;
1165 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
1167 bitsize
= gfc_integer_kinds
[k
].bit_size
;
1169 if (pos
+ len
> bitsize
)
1172 ("Sum of second and third arguments of IBITS exceeds bit size "
1173 "at %L", &y
->where
);
1174 return &gfc_bad_expr
;
1177 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1179 bits
= gfc_getmem (bitsize
* sizeof (int));
1181 for (i
= 0; i
< bitsize
; i
++)
1184 for (i
= 0; i
< len
; i
++)
1185 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
1187 for (i
= 0; i
< bitsize
; i
++)
1191 mpz_clrbit (result
->value
.integer
, i
);
1193 else if (bits
[i
] == 1)
1195 mpz_setbit (result
->value
.integer
, i
);
1199 gfc_internal_error ("IBITS: Bad bit");
1205 return range_check (result
, "IBITS");
1210 gfc_simplify_ibset (gfc_expr
* x
, gfc_expr
* y
)
1215 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1218 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1220 gfc_error ("Invalid second argument of IBSET at %L", &y
->where
);
1221 return &gfc_bad_expr
;
1224 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1226 if (pos
> gfc_integer_kinds
[k
].bit_size
)
1228 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1230 return &gfc_bad_expr
;
1233 result
= gfc_copy_expr (x
);
1235 mpz_setbit (result
->value
.integer
, pos
);
1236 return range_check (result
, "IBSET");
1241 gfc_simplify_ichar (gfc_expr
* e
)
1246 if (e
->expr_type
!= EXPR_CONSTANT
)
1249 if (e
->value
.character
.length
!= 1)
1251 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
1252 return &gfc_bad_expr
;
1255 index
= (int) e
->value
.character
.string
[0];
1257 if (index
< CHAR_MIN
|| index
> CHAR_MAX
)
1259 gfc_error ("Argument of ICHAR at %L out of range of this processor",
1261 return &gfc_bad_expr
;
1264 result
= gfc_int_expr (index
);
1265 result
->where
= e
->where
;
1266 return range_check (result
, "ICHAR");
1271 gfc_simplify_ieor (gfc_expr
* x
, gfc_expr
* y
)
1275 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1278 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1280 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1282 return range_check (result
, "IEOR");
1287 gfc_simplify_index (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* b
)
1290 int back
, len
, lensub
;
1291 int i
, j
, k
, count
, index
= 0, start
;
1293 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1296 if (b
!= NULL
&& b
->value
.logical
!= 0)
1301 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1304 len
= x
->value
.character
.length
;
1305 lensub
= y
->value
.character
.length
;
1309 mpz_set_si (result
->value
.integer
, 0);
1318 mpz_set_si (result
->value
.integer
, 1);
1321 else if (lensub
== 1)
1323 for (i
= 0; i
< len
; i
++)
1325 for (j
= 0; j
< lensub
; j
++)
1327 if (y
->value
.character
.string
[j
] ==
1328 x
->value
.character
.string
[i
])
1338 for (i
= 0; i
< len
; i
++)
1340 for (j
= 0; j
< lensub
; j
++)
1342 if (y
->value
.character
.string
[j
] ==
1343 x
->value
.character
.string
[i
])
1348 for (k
= 0; k
< lensub
; k
++)
1350 if (y
->value
.character
.string
[k
] ==
1351 x
->value
.character
.string
[k
+ start
])
1355 if (count
== lensub
)
1371 mpz_set_si (result
->value
.integer
, len
+ 1);
1374 else if (lensub
== 1)
1376 for (i
= 0; i
< len
; i
++)
1378 for (j
= 0; j
< lensub
; j
++)
1380 if (y
->value
.character
.string
[j
] ==
1381 x
->value
.character
.string
[len
- i
])
1383 index
= len
- i
+ 1;
1391 for (i
= 0; i
< len
; i
++)
1393 for (j
= 0; j
< lensub
; j
++)
1395 if (y
->value
.character
.string
[j
] ==
1396 x
->value
.character
.string
[len
- i
])
1399 if (start
<= len
- lensub
)
1402 for (k
= 0; k
< lensub
; k
++)
1403 if (y
->value
.character
.string
[k
] ==
1404 x
->value
.character
.string
[k
+ start
])
1407 if (count
== lensub
)
1424 mpz_set_si (result
->value
.integer
, index
);
1425 return range_check (result
, "INDEX");
1430 gfc_simplify_int (gfc_expr
* e
, gfc_expr
* k
)
1432 gfc_expr
*rpart
, *rtrunc
, *result
;
1435 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
1437 return &gfc_bad_expr
;
1439 if (e
->expr_type
!= EXPR_CONSTANT
)
1442 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1447 mpz_set (result
->value
.integer
, e
->value
.integer
);
1451 rtrunc
= gfc_copy_expr (e
);
1452 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1453 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1454 gfc_free_expr (rtrunc
);
1458 rpart
= gfc_complex2real (e
, kind
);
1459 rtrunc
= gfc_copy_expr (rpart
);
1460 mpfr_trunc (rtrunc
->value
.real
, rpart
->value
.real
);
1461 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1462 gfc_free_expr (rpart
);
1463 gfc_free_expr (rtrunc
);
1467 gfc_error ("Argument of INT at %L is not a valid type", &e
->where
);
1468 gfc_free_expr (result
);
1469 return &gfc_bad_expr
;
1472 return range_check (result
, "INT");
1477 gfc_simplify_ifix (gfc_expr
* e
)
1479 gfc_expr
*rtrunc
, *result
;
1481 if (e
->expr_type
!= EXPR_CONSTANT
)
1484 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1487 rtrunc
= gfc_copy_expr (e
);
1489 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1490 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1492 gfc_free_expr (rtrunc
);
1493 return range_check (result
, "IFIX");
1498 gfc_simplify_idint (gfc_expr
* e
)
1500 gfc_expr
*rtrunc
, *result
;
1502 if (e
->expr_type
!= EXPR_CONSTANT
)
1505 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1508 rtrunc
= gfc_copy_expr (e
);
1510 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1511 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1513 gfc_free_expr (rtrunc
);
1514 return range_check (result
, "IDINT");
1519 gfc_simplify_ior (gfc_expr
* x
, gfc_expr
* y
)
1523 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1526 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1528 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1529 return range_check (result
, "IOR");
1534 gfc_simplify_ishft (gfc_expr
* e
, gfc_expr
* s
)
1537 int shift
, ashift
, isize
, k
, *bits
, i
;
1539 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1542 if (gfc_extract_int (s
, &shift
) != NULL
)
1544 gfc_error ("Invalid second argument of ISHFT at %L", &s
->where
);
1545 return &gfc_bad_expr
;
1548 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
1550 isize
= gfc_integer_kinds
[k
].bit_size
;
1560 ("Magnitude of second argument of ISHFT exceeds bit size at %L",
1562 return &gfc_bad_expr
;
1565 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1569 mpz_set (result
->value
.integer
, e
->value
.integer
);
1570 return range_check (result
, "ISHFT");
1573 bits
= gfc_getmem (isize
* sizeof (int));
1575 for (i
= 0; i
< isize
; i
++)
1576 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1580 for (i
= 0; i
< shift
; i
++)
1581 mpz_clrbit (result
->value
.integer
, i
);
1583 for (i
= 0; i
< isize
- shift
; i
++)
1586 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1588 mpz_setbit (result
->value
.integer
, i
+ shift
);
1593 for (i
= isize
- 1; i
>= isize
- ashift
; i
--)
1594 mpz_clrbit (result
->value
.integer
, i
);
1596 for (i
= isize
- 1; i
>= ashift
; i
--)
1599 mpz_clrbit (result
->value
.integer
, i
- ashift
);
1601 mpz_setbit (result
->value
.integer
, i
- ashift
);
1605 twos_complement (result
->value
.integer
, isize
);
1613 gfc_simplify_ishftc (gfc_expr
* e
, gfc_expr
* s
, gfc_expr
* sz
)
1616 int shift
, ashift
, isize
, delta
, k
;
1619 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1622 if (gfc_extract_int (s
, &shift
) != NULL
)
1624 gfc_error ("Invalid second argument of ISHFTC at %L", &s
->where
);
1625 return &gfc_bad_expr
;
1628 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1632 if (gfc_extract_int (sz
, &isize
) != NULL
|| isize
< 0)
1634 gfc_error ("Invalid third argument of ISHFTC at %L", &sz
->where
);
1635 return &gfc_bad_expr
;
1639 isize
= gfc_integer_kinds
[k
].bit_size
;
1649 ("Magnitude of second argument of ISHFTC exceeds third argument "
1650 "at %L", &s
->where
);
1651 return &gfc_bad_expr
;
1654 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1658 mpz_set (result
->value
.integer
, e
->value
.integer
);
1662 bits
= gfc_getmem (isize
* sizeof (int));
1664 for (i
= 0; i
< isize
; i
++)
1665 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1667 delta
= isize
- ashift
;
1671 for (i
= 0; i
< delta
; i
++)
1674 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1676 mpz_setbit (result
->value
.integer
, i
+ shift
);
1679 for (i
= delta
; i
< isize
; i
++)
1682 mpz_clrbit (result
->value
.integer
, i
- delta
);
1684 mpz_setbit (result
->value
.integer
, i
- delta
);
1689 for (i
= 0; i
< ashift
; i
++)
1692 mpz_clrbit (result
->value
.integer
, i
+ delta
);
1694 mpz_setbit (result
->value
.integer
, i
+ delta
);
1697 for (i
= ashift
; i
< isize
; i
++)
1700 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1702 mpz_setbit (result
->value
.integer
, i
+ shift
);
1706 twos_complement (result
->value
.integer
, isize
);
1714 gfc_simplify_kind (gfc_expr
* e
)
1717 if (e
->ts
.type
== BT_DERIVED
)
1719 gfc_error ("Argument of KIND at %L is a DERIVED type", &e
->where
);
1720 return &gfc_bad_expr
;
1723 return gfc_int_expr (e
->ts
.kind
);
1728 simplify_bound (gfc_expr
* array
, gfc_expr
* dim
, int upper
)
1735 if (array
->expr_type
!= EXPR_VARIABLE
)
1739 /* TODO: Simplify constant multi-dimensional bounds. */
1742 if (dim
->expr_type
!= EXPR_CONSTANT
)
1745 /* Follow any component references. */
1746 as
= array
->symtree
->n
.sym
->as
;
1747 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1752 switch (ref
->u
.ar
.type
)
1759 /* We're done because 'as' has already been set in the
1760 previous iteration. */
1771 as
= ref
->u
.c
.component
->as
;
1782 if (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
)
1785 d
= mpz_get_si (dim
->value
.integer
);
1787 if (d
< 1 || d
> as
->rank
1788 || (d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
1790 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
1791 return &gfc_bad_expr
;
1794 e
= upper
? as
->upper
[d
-1] : as
->lower
[d
-1];
1796 if (e
->expr_type
!= EXPR_CONSTANT
)
1799 return gfc_copy_expr (e
);
1804 gfc_simplify_lbound (gfc_expr
* array
, gfc_expr
* dim
)
1806 return simplify_bound (array
, dim
, 0);
1811 gfc_simplify_len (gfc_expr
* e
)
1815 if (e
->expr_type
!= EXPR_CONSTANT
)
1818 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1821 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
1822 return range_check (result
, "LEN");
1827 gfc_simplify_len_trim (gfc_expr
* e
)
1830 int count
, len
, lentrim
, i
;
1832 if (e
->expr_type
!= EXPR_CONSTANT
)
1835 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1838 len
= e
->value
.character
.length
;
1840 for (count
= 0, i
= 1; i
<= len
; i
++)
1841 if (e
->value
.character
.string
[len
- i
] == ' ')
1846 lentrim
= len
- count
;
1848 mpz_set_si (result
->value
.integer
, lentrim
);
1849 return range_check (result
, "LEN_TRIM");
1854 gfc_simplify_lge (gfc_expr
* a
, gfc_expr
* b
)
1857 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1860 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) >= 0,
1866 gfc_simplify_lgt (gfc_expr
* a
, gfc_expr
* b
)
1869 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1872 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) > 0,
1878 gfc_simplify_lle (gfc_expr
* a
, gfc_expr
* b
)
1881 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1884 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) <= 0,
1890 gfc_simplify_llt (gfc_expr
* a
, gfc_expr
* b
)
1893 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1896 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) < 0,
1902 gfc_simplify_log (gfc_expr
* x
)
1907 if (x
->expr_type
!= EXPR_CONSTANT
)
1910 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1912 gfc_set_model_kind (x
->ts
.kind
);
1917 if (mpfr_sgn (x
->value
.real
) <= 0)
1920 ("Argument of LOG at %L cannot be less than or equal to zero",
1922 gfc_free_expr (result
);
1923 return &gfc_bad_expr
;
1926 mpfr_log(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1930 if ((mpfr_sgn (x
->value
.complex.r
) == 0)
1931 && (mpfr_sgn (x
->value
.complex.i
) == 0))
1933 gfc_error ("Complex argument of LOG at %L cannot be zero",
1935 gfc_free_expr (result
);
1936 return &gfc_bad_expr
;
1942 arctangent2 (x
->value
.complex.i
, x
->value
.complex.r
,
1943 result
->value
.complex.i
);
1945 mpfr_mul (xr
, x
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
1946 mpfr_mul (xi
, x
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
1947 mpfr_add (xr
, xr
, xi
, GFC_RND_MODE
);
1948 mpfr_sqrt (xr
, xr
, GFC_RND_MODE
);
1949 mpfr_log (result
->value
.complex.r
, xr
, GFC_RND_MODE
);
1957 gfc_internal_error ("gfc_simplify_log: bad type");
1960 return range_check (result
, "LOG");
1965 gfc_simplify_log10 (gfc_expr
* x
)
1969 if (x
->expr_type
!= EXPR_CONSTANT
)
1972 gfc_set_model_kind (x
->ts
.kind
);
1974 if (mpfr_sgn (x
->value
.real
) <= 0)
1977 ("Argument of LOG10 at %L cannot be less than or equal to zero",
1979 return &gfc_bad_expr
;
1982 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1984 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1986 return range_check (result
, "LOG10");
1991 gfc_simplify_logical (gfc_expr
* e
, gfc_expr
* k
)
1996 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
1998 return &gfc_bad_expr
;
2000 if (e
->expr_type
!= EXPR_CONSTANT
)
2003 result
= gfc_constant_result (BT_LOGICAL
, kind
, &e
->where
);
2005 result
->value
.logical
= e
->value
.logical
;
2011 /* This function is special since MAX() can take any number of
2012 arguments. The simplified expression is a rewritten version of the
2013 argument list containing at most one constant element. Other
2014 constant elements are deleted. Because the argument list has
2015 already been checked, this function always succeeds. sign is 1 for
2016 MAX(), -1 for MIN(). */
2019 simplify_min_max (gfc_expr
* expr
, int sign
)
2021 gfc_actual_arglist
*arg
, *last
, *extremum
;
2022 gfc_intrinsic_sym
* specific
;
2026 specific
= expr
->value
.function
.isym
;
2028 arg
= expr
->value
.function
.actual
;
2030 for (; arg
; last
= arg
, arg
= arg
->next
)
2032 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
2035 if (extremum
== NULL
)
2041 switch (arg
->expr
->ts
.type
)
2044 if (mpz_cmp (arg
->expr
->value
.integer
,
2045 extremum
->expr
->value
.integer
) * sign
> 0)
2046 mpz_set (extremum
->expr
->value
.integer
, arg
->expr
->value
.integer
);
2051 if (mpfr_cmp (arg
->expr
->value
.real
, extremum
->expr
->value
.real
) *
2053 mpfr_set (extremum
->expr
->value
.real
, arg
->expr
->value
.real
,
2059 gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
2062 /* Delete the extra constant argument. */
2064 expr
->value
.function
.actual
= arg
->next
;
2066 last
->next
= arg
->next
;
2069 gfc_free_actual_arglist (arg
);
2073 /* If there is one value left, replace the function call with the
2075 if (expr
->value
.function
.actual
->next
!= NULL
)
2078 /* Convert to the correct type and kind. */
2079 if (expr
->ts
.type
!= BT_UNKNOWN
)
2080 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2081 expr
->ts
.type
, expr
->ts
.kind
);
2083 if (specific
->ts
.type
!= BT_UNKNOWN
)
2084 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2085 specific
->ts
.type
, specific
->ts
.kind
);
2087 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
2092 gfc_simplify_min (gfc_expr
* e
)
2094 return simplify_min_max (e
, -1);
2099 gfc_simplify_max (gfc_expr
* e
)
2101 return simplify_min_max (e
, 1);
2106 gfc_simplify_maxexponent (gfc_expr
* x
)
2111 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2113 result
= gfc_int_expr (gfc_real_kinds
[i
].max_exponent
);
2114 result
->where
= x
->where
;
2121 gfc_simplify_minexponent (gfc_expr
* x
)
2126 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2128 result
= gfc_int_expr (gfc_real_kinds
[i
].min_exponent
);
2129 result
->where
= x
->where
;
2136 gfc_simplify_mod (gfc_expr
* a
, gfc_expr
* p
)
2139 mpfr_t quot
, iquot
, term
;
2141 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2144 result
= gfc_constant_result (a
->ts
.type
, a
->ts
.kind
, &a
->where
);
2149 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2151 /* Result is processor-dependent. */
2152 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
2153 gfc_free_expr (result
);
2154 return &gfc_bad_expr
;
2156 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2160 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2162 /* Result is processor-dependent. */
2163 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
2164 gfc_free_expr (result
);
2165 return &gfc_bad_expr
;
2168 gfc_set_model_kind (a
->ts
.kind
);
2173 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2174 mpfr_trunc (iquot
, quot
);
2175 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2176 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2184 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2187 return range_check (result
, "MOD");
2192 gfc_simplify_modulo (gfc_expr
* a
, gfc_expr
* p
)
2195 mpfr_t quot
, iquot
, term
;
2197 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2200 result
= gfc_constant_result (a
->ts
.type
, a
->ts
.kind
, &a
->where
);
2205 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2207 /* Result is processor-dependent. This processor just opts
2208 to not handle it at all. */
2209 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
2210 gfc_free_expr (result
);
2211 return &gfc_bad_expr
;
2213 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2218 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2220 /* Result is processor-dependent. */
2221 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
2222 gfc_free_expr (result
);
2223 return &gfc_bad_expr
;
2226 gfc_set_model_kind (a
->ts
.kind
);
2231 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2232 mpfr_floor (iquot
, quot
);
2233 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2239 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2243 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2246 return range_check (result
, "MODULO");
2250 /* Exists for the sole purpose of consistency with other intrinsics. */
2252 gfc_simplify_mvbits (gfc_expr
* f ATTRIBUTE_UNUSED
,
2253 gfc_expr
* fp ATTRIBUTE_UNUSED
,
2254 gfc_expr
* l ATTRIBUTE_UNUSED
,
2255 gfc_expr
* to ATTRIBUTE_UNUSED
,
2256 gfc_expr
* tp ATTRIBUTE_UNUSED
)
2263 gfc_simplify_nearest (gfc_expr
* x
, gfc_expr
* s
)
2269 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
2272 gfc_set_model_kind (x
->ts
.kind
);
2273 result
= gfc_copy_expr (x
);
2275 direction
= mpfr_sgn (s
->value
.real
);
2279 gfc_error ("Second argument of NEAREST at %L may not be zero",
2282 return &gfc_bad_expr
;
2285 /* TODO: Use mpfr_nextabove and mpfr_nextbelow once we move to a
2286 newer version of mpfr. */
2288 sgn
= mpfr_sgn (x
->value
.real
);
2292 int k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
2295 mpfr_add (result
->value
.real
,
2296 x
->value
.real
, gfc_real_kinds
[k
].tiny
, GFC_RND_MODE
);
2298 mpfr_sub (result
->value
.real
,
2299 x
->value
.real
, gfc_real_kinds
[k
].tiny
, GFC_RND_MODE
);
2302 /* FIXME: This gives an arithmetic error because we compare
2303 against tiny when range-checking. Also, it doesn't give the
2305 /* TINY is the smallest model number, we want the smallest
2306 machine representable number. Therefore we have to shift the
2307 value to the right by the number of digits - 1. */
2308 mpfr_div_2ui (result
->value
.real
, result
->value
.real
,
2309 gfc_real_kinds
[k
].precision
- 1, GFC_RND_MODE
);
2316 direction
= -direction
;
2317 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
2321 mpfr_add_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2324 /* In this case the exponent can shrink, which makes us skip
2325 over one number because we subtract one ulp with the
2326 larger exponent. Thus we need to compensate for this. */
2327 mpfr_init_set (tmp
, result
->value
.real
, GFC_RND_MODE
);
2329 mpfr_sub_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2330 mpfr_add_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2332 /* If we're back to where we started, the spacing is one
2333 ulp, and we get the correct result by subtracting. */
2334 if (mpfr_cmp (tmp
, result
->value
.real
) == 0)
2335 mpfr_sub_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2341 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
2344 return range_check (result
, "NEAREST");
2349 simplify_nint (const char *name
, gfc_expr
* e
, gfc_expr
* k
)
2351 gfc_expr
*itrunc
, *result
;
2354 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
2356 return &gfc_bad_expr
;
2358 if (e
->expr_type
!= EXPR_CONSTANT
)
2361 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
2363 itrunc
= gfc_copy_expr (e
);
2365 mpfr_round(itrunc
->value
.real
, e
->value
.real
);
2367 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
);
2369 gfc_free_expr (itrunc
);
2371 return range_check (result
, name
);
2376 gfc_simplify_nint (gfc_expr
* e
, gfc_expr
* k
)
2378 return simplify_nint ("NINT", e
, k
);
2383 gfc_simplify_idnint (gfc_expr
* e
)
2385 return simplify_nint ("IDNINT", e
, NULL
);
2390 gfc_simplify_not (gfc_expr
* e
)
2395 if (e
->expr_type
!= EXPR_CONSTANT
)
2398 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2400 mpz_com (result
->value
.integer
, e
->value
.integer
);
2402 /* Because of how GMP handles numbers, the result must be ANDed with
2403 the max_int mask. For radices <> 2, this will require change. */
2405 i
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
2407 mpz_and (result
->value
.integer
, result
->value
.integer
,
2408 gfc_integer_kinds
[i
].max_int
);
2410 return range_check (result
, "NOT");
2415 gfc_simplify_null (gfc_expr
* mold
)
2419 result
= gfc_get_expr ();
2420 result
->expr_type
= EXPR_NULL
;
2423 result
->ts
.type
= BT_UNKNOWN
;
2426 result
->ts
= mold
->ts
;
2427 result
->where
= mold
->where
;
2435 gfc_simplify_precision (gfc_expr
* e
)
2440 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2442 result
= gfc_int_expr (gfc_real_kinds
[i
].precision
);
2443 result
->where
= e
->where
;
2450 gfc_simplify_radix (gfc_expr
* e
)
2455 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2459 i
= gfc_integer_kinds
[i
].radix
;
2463 i
= gfc_real_kinds
[i
].radix
;
2470 result
= gfc_int_expr (i
);
2471 result
->where
= e
->where
;
2478 gfc_simplify_range (gfc_expr
* e
)
2484 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2489 j
= gfc_integer_kinds
[i
].range
;
2494 j
= gfc_real_kinds
[i
].range
;
2501 result
= gfc_int_expr (j
);
2502 result
->where
= e
->where
;
2509 gfc_simplify_real (gfc_expr
* e
, gfc_expr
* k
)
2514 if (e
->ts
.type
== BT_COMPLEX
)
2515 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
2517 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
2520 return &gfc_bad_expr
;
2522 if (e
->expr_type
!= EXPR_CONSTANT
)
2528 result
= gfc_int2real (e
, kind
);
2532 result
= gfc_real2real (e
, kind
);
2536 result
= gfc_complex2real (e
, kind
);
2540 gfc_internal_error ("bad type in REAL");
2544 return range_check (result
, "REAL");
2548 gfc_simplify_repeat (gfc_expr
* e
, gfc_expr
* n
)
2551 int i
, j
, len
, ncopies
, nlen
;
2553 if (e
->expr_type
!= EXPR_CONSTANT
|| n
->expr_type
!= EXPR_CONSTANT
)
2556 if (n
!= NULL
&& (gfc_extract_int (n
, &ncopies
) != NULL
|| ncopies
< 0))
2558 gfc_error ("Invalid second argument of REPEAT at %L", &n
->where
);
2559 return &gfc_bad_expr
;
2562 len
= e
->value
.character
.length
;
2563 nlen
= ncopies
* len
;
2565 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
2569 result
->value
.character
.string
= gfc_getmem (1);
2570 result
->value
.character
.length
= 0;
2571 result
->value
.character
.string
[0] = '\0';
2575 result
->value
.character
.length
= nlen
;
2576 result
->value
.character
.string
= gfc_getmem (nlen
+ 1);
2578 for (i
= 0; i
< ncopies
; i
++)
2579 for (j
= 0; j
< len
; j
++)
2580 result
->value
.character
.string
[j
+ i
* len
] =
2581 e
->value
.character
.string
[j
];
2583 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
2588 /* This one is a bear, but mainly has to do with shuffling elements. */
2591 gfc_simplify_reshape (gfc_expr
* source
, gfc_expr
* shape_exp
,
2592 gfc_expr
* pad
, gfc_expr
* order_exp
)
2595 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
2596 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
2597 gfc_constructor
*head
, *tail
;
2603 /* Unpack the shape array. */
2604 if (source
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (source
))
2607 if (shape_exp
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (shape_exp
))
2611 && (pad
->expr_type
!= EXPR_ARRAY
2612 || !gfc_is_constant_expr (pad
)))
2615 if (order_exp
!= NULL
2616 && (order_exp
->expr_type
!= EXPR_ARRAY
2617 || !gfc_is_constant_expr (order_exp
)))
2626 e
= gfc_get_array_element (shape_exp
, rank
);
2630 if (gfc_extract_int (e
, &shape
[rank
]) != NULL
)
2632 gfc_error ("Integer too large in shape specification at %L",
2640 if (rank
>= GFC_MAX_DIMENSIONS
)
2642 gfc_error ("Too many dimensions in shape specification for RESHAPE "
2643 "at %L", &e
->where
);
2648 if (shape
[rank
] < 0)
2650 gfc_error ("Shape specification at %L cannot be negative",
2660 gfc_error ("Shape specification at %L cannot be the null array",
2665 /* Now unpack the order array if present. */
2666 if (order_exp
== NULL
)
2668 for (i
= 0; i
< rank
; i
++)
2675 for (i
= 0; i
< rank
; i
++)
2678 for (i
= 0; i
< rank
; i
++)
2680 e
= gfc_get_array_element (order_exp
, i
);
2684 ("ORDER parameter of RESHAPE at %L is not the same size "
2685 "as SHAPE parameter", &order_exp
->where
);
2689 if (gfc_extract_int (e
, &order
[i
]) != NULL
)
2691 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
2699 if (order
[i
] < 1 || order
[i
] > rank
)
2701 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
2710 gfc_error ("Invalid permutation in ORDER parameter at %L",
2719 /* Count the elements in the source and padding arrays. */
2724 gfc_array_size (pad
, &size
);
2725 npad
= mpz_get_ui (size
);
2729 gfc_array_size (source
, &size
);
2730 nsource
= mpz_get_ui (size
);
2733 /* If it weren't for that pesky permutation we could just loop
2734 through the source and round out any shortage with pad elements.
2735 But no, someone just had to have the compiler do something the
2736 user should be doing. */
2738 for (i
= 0; i
< rank
; i
++)
2743 /* Figure out which element to extract. */
2744 mpz_set_ui (index
, 0);
2746 for (i
= rank
- 1; i
>= 0; i
--)
2748 mpz_add_ui (index
, index
, x
[order
[i
]]);
2750 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
2753 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
2754 gfc_internal_error ("Reshaped array too large at %L", &e
->where
);
2756 j
= mpz_get_ui (index
);
2759 e
= gfc_get_array_element (source
, j
);
2767 ("PAD parameter required for short SOURCE parameter at %L",
2773 e
= gfc_get_array_element (pad
, j
);
2777 head
= tail
= gfc_get_constructor ();
2780 tail
->next
= gfc_get_constructor ();
2787 tail
->where
= e
->where
;
2790 /* Calculate the next element. */
2794 if (++x
[i
] < shape
[i
])
2805 e
= gfc_get_expr ();
2806 e
->where
= source
->where
;
2807 e
->expr_type
= EXPR_ARRAY
;
2808 e
->value
.constructor
= head
;
2809 e
->shape
= gfc_get_shape (rank
);
2811 for (i
= 0; i
< rank
; i
++)
2812 mpz_init_set_ui (e
->shape
[i
], shape
[i
]);
2814 e
->ts
= head
->expr
->ts
;
2820 gfc_free_constructor (head
);
2822 return &gfc_bad_expr
;
2827 gfc_simplify_rrspacing (gfc_expr
* x
)
2830 mpfr_t absv
, log2
, exp
, frac
, pow2
;
2833 if (x
->expr_type
!= EXPR_CONSTANT
)
2836 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2838 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
2840 p
= gfc_real_kinds
[i
].digits
;
2842 gfc_set_model_kind (x
->ts
.kind
);
2844 if (mpfr_sgn (x
->value
.real
) == 0)
2846 mpfr_ui_div (result
->value
.real
, 1, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
2855 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
2856 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
2858 mpfr_trunc (log2
, log2
);
2859 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
2861 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
2862 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
2864 mpfr_mul_2exp (result
->value
.real
, frac
, (unsigned long)p
, GFC_RND_MODE
);
2871 return range_check (result
, "RRSPACING");
2876 gfc_simplify_scale (gfc_expr
* x
, gfc_expr
* i
)
2878 int k
, neg_flag
, power
, exp_range
;
2879 mpfr_t scale
, radix
;
2882 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
2885 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
2887 if (mpfr_sgn (x
->value
.real
) == 0)
2889 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2893 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2895 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
2897 /* This check filters out values of i that would overflow an int. */
2898 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
2899 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
2901 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
2902 return &gfc_bad_expr
;
2905 /* Compute scale = radix ** power. */
2906 power
= mpz_get_si (i
->value
.integer
);
2916 gfc_set_model_kind (x
->ts
.kind
);
2919 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
2920 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
2923 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
2925 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
2930 return range_check (result
, "SCALE");
2935 gfc_simplify_scan (gfc_expr
* e
, gfc_expr
* c
, gfc_expr
* b
)
2940 size_t indx
, len
, lenc
;
2942 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
)
2945 if (b
!= NULL
&& b
->value
.logical
!= 0)
2950 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
2953 len
= e
->value
.character
.length
;
2954 lenc
= c
->value
.character
.length
;
2956 if (len
== 0 || lenc
== 0)
2965 strcspn (e
->value
.character
.string
, c
->value
.character
.string
) + 1;
2972 for (indx
= len
; indx
> 0; indx
--)
2974 for (i
= 0; i
< lenc
; i
++)
2976 if (c
->value
.character
.string
[i
]
2977 == e
->value
.character
.string
[indx
- 1])
2985 mpz_set_ui (result
->value
.integer
, indx
);
2986 return range_check (result
, "SCAN");
2991 gfc_simplify_selected_int_kind (gfc_expr
* e
)
2996 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
3001 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
3002 if (gfc_integer_kinds
[i
].range
>= range
3003 && gfc_integer_kinds
[i
].kind
< kind
)
3004 kind
= gfc_integer_kinds
[i
].kind
;
3006 if (kind
== INT_MAX
)
3009 result
= gfc_int_expr (kind
);
3010 result
->where
= e
->where
;
3017 gfc_simplify_selected_real_kind (gfc_expr
* p
, gfc_expr
* q
)
3019 int range
, precision
, i
, kind
, found_precision
, found_range
;
3026 if (p
->expr_type
!= EXPR_CONSTANT
3027 || gfc_extract_int (p
, &precision
) != NULL
)
3035 if (q
->expr_type
!= EXPR_CONSTANT
3036 || gfc_extract_int (q
, &range
) != NULL
)
3041 found_precision
= 0;
3044 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
3046 if (gfc_real_kinds
[i
].precision
>= precision
)
3047 found_precision
= 1;
3049 if (gfc_real_kinds
[i
].range
>= range
)
3052 if (gfc_real_kinds
[i
].precision
>= precision
3053 && gfc_real_kinds
[i
].range
>= range
&& gfc_real_kinds
[i
].kind
< kind
)
3054 kind
= gfc_real_kinds
[i
].kind
;
3057 if (kind
== INT_MAX
)
3061 if (!found_precision
)
3067 result
= gfc_int_expr (kind
);
3068 result
->where
= (p
!= NULL
) ? p
->where
: q
->where
;
3075 gfc_simplify_set_exponent (gfc_expr
* x
, gfc_expr
* i
)
3078 mpfr_t exp
, absv
, log2
, pow2
, frac
;
3081 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3084 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3086 gfc_set_model_kind (x
->ts
.kind
);
3088 if (mpfr_sgn (x
->value
.real
) == 0)
3090 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3100 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3101 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3103 mpfr_trunc (log2
, log2
);
3104 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
3106 /* Old exponent value, and fraction. */
3107 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3109 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
3112 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
3113 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
3120 return range_check (result
, "SET_EXPONENT");
3125 gfc_simplify_shape (gfc_expr
* source
)
3127 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3128 gfc_expr
*result
, *e
, *f
;
3133 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3136 result
= gfc_start_constructor (BT_INTEGER
, gfc_default_integer_kind
,
3139 ar
= gfc_find_array_ref (source
);
3141 t
= gfc_array_ref_shape (ar
, shape
);
3143 for (n
= 0; n
< source
->rank
; n
++)
3145 e
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3150 mpz_set (e
->value
.integer
, shape
[n
]);
3151 mpz_clear (shape
[n
]);
3155 mpz_set_ui (e
->value
.integer
, n
+ 1);
3157 f
= gfc_simplify_size (source
, e
);
3161 gfc_free_expr (result
);
3170 gfc_append_constructor (result
, e
);
3178 gfc_simplify_size (gfc_expr
* array
, gfc_expr
* dim
)
3186 if (gfc_array_size (array
, &size
) == FAILURE
)
3191 if (dim
->expr_type
!= EXPR_CONSTANT
)
3194 d
= mpz_get_ui (dim
->value
.integer
) - 1;
3195 if (gfc_array_dimen_size (array
, d
, &size
) == FAILURE
)
3199 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3202 mpz_set (result
->value
.integer
, size
);
3209 gfc_simplify_sign (gfc_expr
* x
, gfc_expr
* y
)
3213 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3216 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3221 mpz_abs (result
->value
.integer
, x
->value
.integer
);
3222 if (mpz_sgn (y
->value
.integer
) < 0)
3223 mpz_neg (result
->value
.integer
, result
->value
.integer
);
3228 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3230 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3231 if (mpfr_sgn (y
->value
.real
) < 0)
3232 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
3237 gfc_internal_error ("Bad type in gfc_simplify_sign");
3245 gfc_simplify_sin (gfc_expr
* x
)
3250 if (x
->expr_type
!= EXPR_CONSTANT
)
3253 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3258 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3262 gfc_set_model (x
->value
.real
);
3266 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3267 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3268 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
3270 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3271 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3272 mpfr_mul (result
->value
.complex.i
, xp
, xq
, GFC_RND_MODE
);
3279 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3282 return range_check (result
, "SIN");
3287 gfc_simplify_sinh (gfc_expr
* x
)
3291 if (x
->expr_type
!= EXPR_CONSTANT
)
3294 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3296 mpfr_sinh(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3298 return range_check (result
, "SINH");
3302 /* The argument is always a double precision real that is converted to
3303 single precision. TODO: Rounding! */
3306 gfc_simplify_sngl (gfc_expr
* a
)
3310 if (a
->expr_type
!= EXPR_CONSTANT
)
3313 result
= gfc_real2real (a
, gfc_default_real_kind
);
3314 return range_check (result
, "SNGL");
3319 gfc_simplify_spacing (gfc_expr
* x
)
3326 if (x
->expr_type
!= EXPR_CONSTANT
)
3329 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3331 p
= gfc_real_kinds
[i
].digits
;
3333 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3335 gfc_set_model_kind (x
->ts
.kind
);
3337 if (mpfr_sgn (x
->value
.real
) == 0)
3339 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3346 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3347 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3348 mpfr_trunc (log2
, log2
);
3350 mpfr_add_ui (log2
, log2
, 1, GFC_RND_MODE
);
3352 /* FIXME: We should be using mpfr_get_si here, but this function is
3353 not available with the version of mpfr distributed with gmp (as of
3354 2004-09-17). Replace once mpfr has been imported into the gcc cvs
3356 diff
= (long)mpfr_get_d (log2
, GFC_RND_MODE
) - (long)p
;
3357 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
3358 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, diff
, GFC_RND_MODE
);
3363 if (mpfr_cmp (result
->value
.real
, gfc_real_kinds
[i
].tiny
) < 0)
3364 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3366 return range_check (result
, "SPACING");
3371 gfc_simplify_sqrt (gfc_expr
* e
)
3374 mpfr_t ac
, ad
, s
, t
, w
;
3376 if (e
->expr_type
!= EXPR_CONSTANT
)
3379 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3384 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
3386 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
3391 /* Formula taken from Numerical Recipes to avoid over- and
3394 gfc_set_model (e
->value
.real
);
3401 if (mpfr_cmp_ui (e
->value
.complex.r
, 0) == 0
3402 && mpfr_cmp_ui (e
->value
.complex.i
, 0) == 0)
3405 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
3406 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
3410 mpfr_abs (ac
, e
->value
.complex.r
, GFC_RND_MODE
);
3411 mpfr_abs (ad
, e
->value
.complex.i
, GFC_RND_MODE
);
3413 if (mpfr_cmp (ac
, ad
) >= 0)
3415 mpfr_div (t
, e
->value
.complex.i
, e
->value
.complex.r
, GFC_RND_MODE
);
3416 mpfr_mul (t
, t
, t
, GFC_RND_MODE
);
3417 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3418 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3419 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3420 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3421 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3422 mpfr_sqrt (s
, ac
, GFC_RND_MODE
);
3423 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3427 mpfr_div (s
, e
->value
.complex.r
, e
->value
.complex.i
, GFC_RND_MODE
);
3428 mpfr_mul (t
, s
, s
, GFC_RND_MODE
);
3429 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3430 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3431 mpfr_abs (s
, s
, GFC_RND_MODE
);
3432 mpfr_add (t
, t
, s
, GFC_RND_MODE
);
3433 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3434 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3435 mpfr_sqrt (s
, ad
, GFC_RND_MODE
);
3436 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3439 if (mpfr_cmp_ui (w
, 0) != 0 && mpfr_cmp_ui (e
->value
.complex.r
, 0) >= 0)
3441 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3442 mpfr_div (result
->value
.complex.i
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3443 mpfr_set (result
->value
.complex.r
, w
, GFC_RND_MODE
);
3445 else if (mpfr_cmp_ui (w
, 0) != 0
3446 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3447 && mpfr_cmp_ui (e
->value
.complex.i
, 0) >= 0)
3449 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3450 mpfr_div (result
->value
.complex.r
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3451 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3453 else if (mpfr_cmp_ui (w
, 0) != 0
3454 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3455 && mpfr_cmp_ui (e
->value
.complex.i
, 0) < 0)
3457 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3458 mpfr_div (result
->value
.complex.r
, ad
, t
, GFC_RND_MODE
);
3459 mpfr_neg (w
, w
, GFC_RND_MODE
);
3460 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3463 gfc_internal_error ("invalid complex argument of SQRT at %L",
3475 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
3478 return range_check (result
, "SQRT");
3481 gfc_free_expr (result
);
3482 gfc_error ("Argument of SQRT at %L has a negative value", &e
->where
);
3483 return &gfc_bad_expr
;
3488 gfc_simplify_tan (gfc_expr
* x
)
3493 if (x
->expr_type
!= EXPR_CONSTANT
)
3496 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3498 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3500 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3502 return range_check (result
, "TAN");
3507 gfc_simplify_tanh (gfc_expr
* x
)
3511 if (x
->expr_type
!= EXPR_CONSTANT
)
3514 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3516 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3518 return range_check (result
, "TANH");
3524 gfc_simplify_tiny (gfc_expr
* e
)
3529 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
3531 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
3532 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3539 gfc_simplify_trim (gfc_expr
* e
)
3542 int count
, i
, len
, lentrim
;
3544 if (e
->expr_type
!= EXPR_CONSTANT
)
3547 len
= e
->value
.character
.length
;
3549 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
3551 for (count
= 0, i
= 1; i
<= len
; ++i
)
3553 if (e
->value
.character
.string
[len
- i
] == ' ')
3559 lentrim
= len
- count
;
3561 result
->value
.character
.length
= lentrim
;
3562 result
->value
.character
.string
= gfc_getmem (lentrim
+ 1);
3564 for (i
= 0; i
< lentrim
; i
++)
3565 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
3567 result
->value
.character
.string
[lentrim
] = '\0'; /* For debugger */
3574 gfc_simplify_ubound (gfc_expr
* array
, gfc_expr
* dim
)
3576 return simplify_bound (array
, dim
, 1);
3581 gfc_simplify_verify (gfc_expr
* s
, gfc_expr
* set
, gfc_expr
* b
)
3585 size_t index
, len
, lenset
;
3588 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
)
3591 if (b
!= NULL
&& b
->value
.logical
!= 0)
3596 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3599 len
= s
->value
.character
.length
;
3600 lenset
= set
->value
.character
.length
;
3604 mpz_set_ui (result
->value
.integer
, 0);
3612 mpz_set_ui (result
->value
.integer
, len
);
3617 strspn (s
->value
.character
.string
, set
->value
.character
.string
) + 1;
3626 mpz_set_ui (result
->value
.integer
, 1);
3629 for (index
= len
; index
> 0; index
--)
3631 for (i
= 0; i
< lenset
; i
++)
3633 if (s
->value
.character
.string
[index
- 1]
3634 == set
->value
.character
.string
[i
])
3642 mpz_set_ui (result
->value
.integer
, index
);
3646 /****************** Constant simplification *****************/
3648 /* Master function to convert one constant to another. While this is
3649 used as a simplification function, it requires the destination type
3650 and kind information which is supplied by a special case in
3654 gfc_convert_constant (gfc_expr
* e
, bt type
, int kind
)
3656 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
3657 gfc_constructor
*head
, *c
, *tail
= NULL
;
3671 f
= gfc_int2complex
;
3688 f
= gfc_real2complex
;
3699 f
= gfc_complex2int
;
3702 f
= gfc_complex2real
;
3705 f
= gfc_complex2complex
;
3714 if (type
!= BT_LOGICAL
)
3721 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
3726 switch (e
->expr_type
)
3729 result
= f (e
, kind
);
3731 return &gfc_bad_expr
;
3735 if (!gfc_is_constant_expr (e
))
3740 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
3743 head
= tail
= gfc_get_constructor ();
3746 tail
->next
= gfc_get_constructor ();
3750 tail
->where
= c
->where
;
3752 if (c
->iterator
== NULL
)
3753 tail
->expr
= f (c
->expr
, kind
);
3756 g
= gfc_convert_constant (c
->expr
, type
, kind
);
3757 if (g
== &gfc_bad_expr
)
3762 if (tail
->expr
== NULL
)
3764 gfc_free_constructor (head
);
3769 result
= gfc_get_expr ();
3770 result
->ts
.type
= type
;
3771 result
->ts
.kind
= kind
;
3772 result
->expr_type
= EXPR_ARRAY
;
3773 result
->value
.constructor
= head
;
3774 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
3775 result
->where
= e
->where
;
3776 result
->rank
= e
->rank
;
3787 /****************** Helper functions ***********************/
3789 /* Given a collating table, create the inverse table. */
3792 invert_table (const int *table
, int *xtable
)
3796 for (i
= 0; i
< 256; i
++)
3799 for (i
= 0; i
< 256; i
++)
3800 xtable
[table
[i
]] = i
;
3805 gfc_simplify_init_1 (void)
3808 invert_table (ascii_table
, xascii_table
);