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, 51 Franklin Street, Fifth Floor, 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");
267 gfc_simplify_acosh (gfc_expr
* x
)
271 if (x
->expr_type
!= EXPR_CONSTANT
)
274 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
276 gfc_error ("Argument of ACOSH at %L must not be less than 1",
278 return &gfc_bad_expr
;
281 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
283 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
285 return range_check (result
, "ACOSH");
289 gfc_simplify_adjustl (gfc_expr
* e
)
295 if (e
->expr_type
!= EXPR_CONSTANT
)
298 len
= e
->value
.character
.length
;
300 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
302 result
->value
.character
.length
= len
;
303 result
->value
.character
.string
= gfc_getmem (len
+ 1);
305 for (count
= 0, i
= 0; i
< len
; ++i
)
307 ch
= e
->value
.character
.string
[i
];
313 for (i
= 0; i
< len
- count
; ++i
)
315 result
->value
.character
.string
[i
] =
316 e
->value
.character
.string
[count
+ i
];
319 for (i
= len
- count
; i
< len
; ++i
)
321 result
->value
.character
.string
[i
] = ' ';
324 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
331 gfc_simplify_adjustr (gfc_expr
* e
)
337 if (e
->expr_type
!= EXPR_CONSTANT
)
340 len
= e
->value
.character
.length
;
342 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
344 result
->value
.character
.length
= len
;
345 result
->value
.character
.string
= gfc_getmem (len
+ 1);
347 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
349 ch
= e
->value
.character
.string
[i
];
355 for (i
= 0; i
< count
; ++i
)
357 result
->value
.character
.string
[i
] = ' ';
360 for (i
= count
; i
< len
; ++i
)
362 result
->value
.character
.string
[i
] =
363 e
->value
.character
.string
[i
- count
];
366 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
373 gfc_simplify_aimag (gfc_expr
* e
)
377 if (e
->expr_type
!= EXPR_CONSTANT
)
380 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
381 mpfr_set (result
->value
.real
, e
->value
.complex.i
, GFC_RND_MODE
);
383 return range_check (result
, "AIMAG");
388 gfc_simplify_aint (gfc_expr
* e
, gfc_expr
* k
)
390 gfc_expr
*rtrunc
, *result
;
393 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
395 return &gfc_bad_expr
;
397 if (e
->expr_type
!= EXPR_CONSTANT
)
400 rtrunc
= gfc_copy_expr (e
);
402 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
404 result
= gfc_real2real (rtrunc
, kind
);
405 gfc_free_expr (rtrunc
);
407 return range_check (result
, "AINT");
412 gfc_simplify_dint (gfc_expr
* e
)
414 gfc_expr
*rtrunc
, *result
;
416 if (e
->expr_type
!= EXPR_CONSTANT
)
419 rtrunc
= gfc_copy_expr (e
);
421 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
423 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
424 gfc_free_expr (rtrunc
);
426 return range_check (result
, "DINT");
431 gfc_simplify_anint (gfc_expr
* e
, gfc_expr
* k
)
436 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
438 return &gfc_bad_expr
;
440 if (e
->expr_type
!= EXPR_CONSTANT
)
443 result
= gfc_constant_result (e
->ts
.type
, kind
, &e
->where
);
445 mpfr_round (result
->value
.real
, e
->value
.real
);
447 return range_check (result
, "ANINT");
452 gfc_simplify_dnint (gfc_expr
* e
)
456 if (e
->expr_type
!= EXPR_CONSTANT
)
459 result
= gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &e
->where
);
461 mpfr_round (result
->value
.real
, e
->value
.real
);
463 return range_check (result
, "DNINT");
468 gfc_simplify_asin (gfc_expr
* x
)
472 if (x
->expr_type
!= EXPR_CONSTANT
)
475 if (mpfr_cmp_si (x
->value
.real
, 1) > 0 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
477 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
479 return &gfc_bad_expr
;
482 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
484 mpfr_asin(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
486 return range_check (result
, "ASIN");
491 gfc_simplify_asinh (gfc_expr
* x
)
495 if (x
->expr_type
!= EXPR_CONSTANT
)
498 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
500 mpfr_asinh(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
502 return range_check (result
, "ASINH");
507 gfc_simplify_atan (gfc_expr
* x
)
511 if (x
->expr_type
!= EXPR_CONSTANT
)
514 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
516 mpfr_atan(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
518 return range_check (result
, "ATAN");
523 gfc_simplify_atanh (gfc_expr
* x
)
527 if (x
->expr_type
!= EXPR_CONSTANT
)
530 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0 ||
531 mpfr_cmp_si (x
->value
.real
, -1) <= 0)
533 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
535 return &gfc_bad_expr
;
538 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
540 mpfr_atanh(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
542 return range_check (result
, "ATANH");
547 gfc_simplify_atan2 (gfc_expr
* y
, gfc_expr
* x
)
551 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
554 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
556 if (mpfr_sgn (y
->value
.real
) == 0 && mpfr_sgn (x
->value
.real
) == 0)
559 ("If first argument of ATAN2 %L is zero, then the second argument "
560 "must not be zero", &x
->where
);
561 gfc_free_expr (result
);
562 return &gfc_bad_expr
;
565 arctangent2 (y
->value
.real
, x
->value
.real
, result
->value
.real
);
567 return range_check (result
, "ATAN2");
572 gfc_simplify_bit_size (gfc_expr
* e
)
577 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
578 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
579 mpz_set_ui (result
->value
.integer
, gfc_integer_kinds
[i
].bit_size
);
586 gfc_simplify_btest (gfc_expr
* e
, gfc_expr
* bit
)
590 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
593 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
594 return gfc_logical_expr (0, &e
->where
);
596 return gfc_logical_expr (mpz_tstbit (e
->value
.integer
, b
), &e
->where
);
601 gfc_simplify_ceiling (gfc_expr
* e
, gfc_expr
* k
)
603 gfc_expr
*ceil
, *result
;
606 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
608 return &gfc_bad_expr
;
610 if (e
->expr_type
!= EXPR_CONSTANT
)
613 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
615 ceil
= gfc_copy_expr (e
);
617 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
618 gfc_mpfr_to_mpz(result
->value
.integer
, ceil
->value
.real
);
620 gfc_free_expr (ceil
);
622 return range_check (result
, "CEILING");
627 gfc_simplify_char (gfc_expr
* e
, gfc_expr
* k
)
632 kind
= get_kind (BT_CHARACTER
, k
, "CHAR", gfc_default_character_kind
);
634 return &gfc_bad_expr
;
636 if (e
->expr_type
!= EXPR_CONSTANT
)
639 if (gfc_extract_int (e
, &c
) != NULL
|| c
< 0 || c
> 255)
641 gfc_error ("Bad character in CHAR function at %L", &e
->where
);
642 return &gfc_bad_expr
;
645 result
= gfc_constant_result (BT_CHARACTER
, kind
, &e
->where
);
647 result
->value
.character
.length
= 1;
648 result
->value
.character
.string
= gfc_getmem (2);
650 result
->value
.character
.string
[0] = c
;
651 result
->value
.character
.string
[1] = '\0'; /* For debugger */
657 /* Common subroutine for simplifying CMPLX and DCMPLX. */
660 simplify_cmplx (const char *name
, gfc_expr
* x
, gfc_expr
* y
, int kind
)
664 result
= gfc_constant_result (BT_COMPLEX
, kind
, &x
->where
);
666 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
671 mpfr_set_z (result
->value
.complex.r
, x
->value
.integer
, GFC_RND_MODE
);
675 mpfr_set (result
->value
.complex.r
, x
->value
.real
, GFC_RND_MODE
);
679 mpfr_set (result
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
680 mpfr_set (result
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
684 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
692 mpfr_set_z (result
->value
.complex.i
, y
->value
.integer
, GFC_RND_MODE
);
696 mpfr_set (result
->value
.complex.i
, y
->value
.real
, GFC_RND_MODE
);
700 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
704 return range_check (result
, name
);
709 gfc_simplify_cmplx (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* k
)
713 if (x
->expr_type
!= EXPR_CONSTANT
714 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
717 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_real_kind
);
719 return &gfc_bad_expr
;
721 return simplify_cmplx ("CMPLX", x
, y
, kind
);
726 gfc_simplify_conjg (gfc_expr
* e
)
730 if (e
->expr_type
!= EXPR_CONSTANT
)
733 result
= gfc_copy_expr (e
);
734 mpfr_neg (result
->value
.complex.i
, result
->value
.complex.i
, GFC_RND_MODE
);
736 return range_check (result
, "CONJG");
741 gfc_simplify_cos (gfc_expr
* x
)
746 if (x
->expr_type
!= EXPR_CONSTANT
)
749 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
754 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
757 gfc_set_model_kind (x
->ts
.kind
);
761 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
762 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
763 mpfr_mul(result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
765 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
766 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
767 mpfr_mul (xp
, xp
, xq
, GFC_RND_MODE
);
768 mpfr_neg (result
->value
.complex.i
, xp
, GFC_RND_MODE
);
774 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
777 return range_check (result
, "COS");
783 gfc_simplify_cosh (gfc_expr
* x
)
787 if (x
->expr_type
!= EXPR_CONSTANT
)
790 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
792 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
794 return range_check (result
, "COSH");
799 gfc_simplify_dcmplx (gfc_expr
* x
, gfc_expr
* y
)
802 if (x
->expr_type
!= EXPR_CONSTANT
803 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
806 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
811 gfc_simplify_dble (gfc_expr
* e
)
815 if (e
->expr_type
!= EXPR_CONSTANT
)
821 result
= gfc_int2real (e
, gfc_default_double_kind
);
825 result
= gfc_real2real (e
, gfc_default_double_kind
);
829 result
= gfc_complex2real (e
, gfc_default_double_kind
);
833 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e
->where
);
836 return range_check (result
, "DBLE");
841 gfc_simplify_digits (gfc_expr
* x
)
845 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
849 digits
= gfc_integer_kinds
[i
].digits
;
854 digits
= gfc_real_kinds
[i
].digits
;
861 return gfc_int_expr (digits
);
866 gfc_simplify_dim (gfc_expr
* x
, gfc_expr
* y
)
870 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
873 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
878 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
879 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
881 mpz_set_ui (result
->value
.integer
, 0);
886 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
887 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
889 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
894 gfc_internal_error ("gfc_simplify_dim(): Bad type");
897 return range_check (result
, "DIM");
902 gfc_simplify_dprod (gfc_expr
* x
, gfc_expr
* y
)
904 gfc_expr
*a1
, *a2
, *result
;
906 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
910 gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &x
->where
);
912 a1
= gfc_real2real (x
, gfc_default_double_kind
);
913 a2
= gfc_real2real (y
, gfc_default_double_kind
);
915 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
920 return range_check (result
, "DPROD");
925 gfc_simplify_epsilon (gfc_expr
* e
)
930 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
932 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
934 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
936 return range_check (result
, "EPSILON");
941 gfc_simplify_exp (gfc_expr
* x
)
946 if (x
->expr_type
!= EXPR_CONSTANT
)
949 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
954 mpfr_exp(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
958 gfc_set_model_kind (x
->ts
.kind
);
961 mpfr_exp (xq
, x
->value
.complex.r
, GFC_RND_MODE
);
962 mpfr_cos (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
963 mpfr_mul (result
->value
.complex.r
, xq
, xp
, GFC_RND_MODE
);
964 mpfr_sin (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
965 mpfr_mul (result
->value
.complex.i
, xq
, xp
, GFC_RND_MODE
);
971 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
974 return range_check (result
, "EXP");
977 /* FIXME: MPFR should be able to do this better */
979 gfc_simplify_exponent (gfc_expr
* x
)
985 if (x
->expr_type
!= EXPR_CONSTANT
)
988 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
991 gfc_set_model (x
->value
.real
);
993 if (mpfr_sgn (x
->value
.real
) == 0)
995 mpz_set_ui (result
->value
.integer
, 0);
1001 mpfr_abs (tmp
, x
->value
.real
, GFC_RND_MODE
);
1002 mpfr_log2 (tmp
, tmp
, GFC_RND_MODE
);
1004 gfc_mpfr_to_mpz (result
->value
.integer
, tmp
);
1006 /* The model number for tiny(x) is b**(emin - 1) where b is the base and emin
1007 is the smallest exponent value. So, we need to add 1 if x is tiny(x). */
1008 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1009 if (mpfr_cmp (x
->value
.real
, gfc_real_kinds
[i
].tiny
) == 0)
1010 mpz_add_ui (result
->value
.integer
,result
->value
.integer
, 1);
1014 return range_check (result
, "EXPONENT");
1019 gfc_simplify_float (gfc_expr
* a
)
1023 if (a
->expr_type
!= EXPR_CONSTANT
)
1026 result
= gfc_int2real (a
, gfc_default_real_kind
);
1027 return range_check (result
, "FLOAT");
1032 gfc_simplify_floor (gfc_expr
* e
, gfc_expr
* k
)
1038 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
1040 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1042 if (e
->expr_type
!= EXPR_CONSTANT
)
1045 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1047 gfc_set_model_kind (kind
);
1049 mpfr_floor (floor
, e
->value
.real
);
1051 gfc_mpfr_to_mpz (result
->value
.integer
, floor
);
1055 return range_check (result
, "FLOOR");
1060 gfc_simplify_fraction (gfc_expr
* x
)
1063 mpfr_t absv
, exp
, pow2
;
1065 if (x
->expr_type
!= EXPR_CONSTANT
)
1068 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
1070 gfc_set_model_kind (x
->ts
.kind
);
1072 if (mpfr_sgn (x
->value
.real
) == 0)
1074 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1082 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
1083 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
1085 mpfr_trunc (exp
, exp
);
1086 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
1088 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
1090 mpfr_div (result
->value
.real
, absv
, pow2
, GFC_RND_MODE
);
1096 return range_check (result
, "FRACTION");
1101 gfc_simplify_huge (gfc_expr
* e
)
1106 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1108 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1113 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
1117 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
1129 gfc_simplify_iachar (gfc_expr
* e
)
1134 if (e
->expr_type
!= EXPR_CONSTANT
)
1137 if (e
->value
.character
.length
!= 1)
1139 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
1140 return &gfc_bad_expr
;
1143 index
= xascii_table
[(int) e
->value
.character
.string
[0] & 0xFF];
1145 result
= gfc_int_expr (index
);
1146 result
->where
= e
->where
;
1148 return range_check (result
, "IACHAR");
1153 gfc_simplify_iand (gfc_expr
* x
, gfc_expr
* y
)
1157 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1160 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1162 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1164 return range_check (result
, "IAND");
1169 gfc_simplify_ibclr (gfc_expr
* x
, gfc_expr
* y
)
1174 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1177 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1179 gfc_error ("Invalid second argument of IBCLR at %L", &y
->where
);
1180 return &gfc_bad_expr
;
1183 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1185 if (pos
> gfc_integer_kinds
[k
].bit_size
)
1187 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1189 return &gfc_bad_expr
;
1192 result
= gfc_copy_expr (x
);
1194 mpz_clrbit (result
->value
.integer
, pos
);
1195 return range_check (result
, "IBCLR");
1200 gfc_simplify_ibits (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
1207 if (x
->expr_type
!= EXPR_CONSTANT
1208 || y
->expr_type
!= EXPR_CONSTANT
1209 || z
->expr_type
!= EXPR_CONSTANT
)
1212 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1214 gfc_error ("Invalid second argument of IBITS at %L", &y
->where
);
1215 return &gfc_bad_expr
;
1218 if (gfc_extract_int (z
, &len
) != NULL
|| len
< 0)
1220 gfc_error ("Invalid third argument of IBITS at %L", &z
->where
);
1221 return &gfc_bad_expr
;
1224 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
1226 bitsize
= gfc_integer_kinds
[k
].bit_size
;
1228 if (pos
+ len
> bitsize
)
1231 ("Sum of second and third arguments of IBITS exceeds bit size "
1232 "at %L", &y
->where
);
1233 return &gfc_bad_expr
;
1236 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1238 bits
= gfc_getmem (bitsize
* sizeof (int));
1240 for (i
= 0; i
< bitsize
; i
++)
1243 for (i
= 0; i
< len
; i
++)
1244 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
1246 for (i
= 0; i
< bitsize
; i
++)
1250 mpz_clrbit (result
->value
.integer
, i
);
1252 else if (bits
[i
] == 1)
1254 mpz_setbit (result
->value
.integer
, i
);
1258 gfc_internal_error ("IBITS: Bad bit");
1264 return range_check (result
, "IBITS");
1269 gfc_simplify_ibset (gfc_expr
* x
, gfc_expr
* y
)
1274 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1277 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1279 gfc_error ("Invalid second argument of IBSET at %L", &y
->where
);
1280 return &gfc_bad_expr
;
1283 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1285 if (pos
> gfc_integer_kinds
[k
].bit_size
)
1287 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1289 return &gfc_bad_expr
;
1292 result
= gfc_copy_expr (x
);
1294 mpz_setbit (result
->value
.integer
, pos
);
1295 return range_check (result
, "IBSET");
1300 gfc_simplify_ichar (gfc_expr
* e
)
1305 if (e
->expr_type
!= EXPR_CONSTANT
)
1308 if (e
->value
.character
.length
!= 1)
1310 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
1311 return &gfc_bad_expr
;
1314 index
= (int) e
->value
.character
.string
[0];
1316 if (index
< CHAR_MIN
|| index
> CHAR_MAX
)
1318 gfc_error ("Argument of ICHAR at %L out of range of this processor",
1320 return &gfc_bad_expr
;
1323 result
= gfc_int_expr (index
);
1324 result
->where
= e
->where
;
1325 return range_check (result
, "ICHAR");
1330 gfc_simplify_ieor (gfc_expr
* x
, gfc_expr
* y
)
1334 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1337 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1339 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1341 return range_check (result
, "IEOR");
1346 gfc_simplify_index (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* b
)
1349 int back
, len
, lensub
;
1350 int i
, j
, k
, count
, index
= 0, start
;
1352 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1355 if (b
!= NULL
&& b
->value
.logical
!= 0)
1360 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1363 len
= x
->value
.character
.length
;
1364 lensub
= y
->value
.character
.length
;
1368 mpz_set_si (result
->value
.integer
, 0);
1377 mpz_set_si (result
->value
.integer
, 1);
1380 else if (lensub
== 1)
1382 for (i
= 0; i
< len
; i
++)
1384 for (j
= 0; j
< lensub
; j
++)
1386 if (y
->value
.character
.string
[j
] ==
1387 x
->value
.character
.string
[i
])
1397 for (i
= 0; i
< len
; i
++)
1399 for (j
= 0; j
< lensub
; j
++)
1401 if (y
->value
.character
.string
[j
] ==
1402 x
->value
.character
.string
[i
])
1407 for (k
= 0; k
< lensub
; k
++)
1409 if (y
->value
.character
.string
[k
] ==
1410 x
->value
.character
.string
[k
+ start
])
1414 if (count
== lensub
)
1430 mpz_set_si (result
->value
.integer
, len
+ 1);
1433 else if (lensub
== 1)
1435 for (i
= 0; i
< len
; i
++)
1437 for (j
= 0; j
< lensub
; j
++)
1439 if (y
->value
.character
.string
[j
] ==
1440 x
->value
.character
.string
[len
- i
])
1442 index
= len
- i
+ 1;
1450 for (i
= 0; i
< len
; i
++)
1452 for (j
= 0; j
< lensub
; j
++)
1454 if (y
->value
.character
.string
[j
] ==
1455 x
->value
.character
.string
[len
- i
])
1458 if (start
<= len
- lensub
)
1461 for (k
= 0; k
< lensub
; k
++)
1462 if (y
->value
.character
.string
[k
] ==
1463 x
->value
.character
.string
[k
+ start
])
1466 if (count
== lensub
)
1483 mpz_set_si (result
->value
.integer
, index
);
1484 return range_check (result
, "INDEX");
1489 gfc_simplify_int (gfc_expr
* e
, gfc_expr
* k
)
1491 gfc_expr
*rpart
, *rtrunc
, *result
;
1494 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
1496 return &gfc_bad_expr
;
1498 if (e
->expr_type
!= EXPR_CONSTANT
)
1501 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1506 mpz_set (result
->value
.integer
, e
->value
.integer
);
1510 rtrunc
= gfc_copy_expr (e
);
1511 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1512 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1513 gfc_free_expr (rtrunc
);
1517 rpart
= gfc_complex2real (e
, kind
);
1518 rtrunc
= gfc_copy_expr (rpart
);
1519 mpfr_trunc (rtrunc
->value
.real
, rpart
->value
.real
);
1520 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1521 gfc_free_expr (rpart
);
1522 gfc_free_expr (rtrunc
);
1526 gfc_error ("Argument of INT at %L is not a valid type", &e
->where
);
1527 gfc_free_expr (result
);
1528 return &gfc_bad_expr
;
1531 return range_check (result
, "INT");
1536 gfc_simplify_ifix (gfc_expr
* e
)
1538 gfc_expr
*rtrunc
, *result
;
1540 if (e
->expr_type
!= EXPR_CONSTANT
)
1543 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1546 rtrunc
= gfc_copy_expr (e
);
1548 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1549 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1551 gfc_free_expr (rtrunc
);
1552 return range_check (result
, "IFIX");
1557 gfc_simplify_idint (gfc_expr
* e
)
1559 gfc_expr
*rtrunc
, *result
;
1561 if (e
->expr_type
!= EXPR_CONSTANT
)
1564 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1567 rtrunc
= gfc_copy_expr (e
);
1569 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1570 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1572 gfc_free_expr (rtrunc
);
1573 return range_check (result
, "IDINT");
1578 gfc_simplify_ior (gfc_expr
* x
, gfc_expr
* y
)
1582 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1585 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1587 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1588 return range_check (result
, "IOR");
1593 gfc_simplify_ishft (gfc_expr
* e
, gfc_expr
* s
)
1596 int shift
, ashift
, isize
, k
, *bits
, i
;
1598 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1601 if (gfc_extract_int (s
, &shift
) != NULL
)
1603 gfc_error ("Invalid second argument of ISHFT at %L", &s
->where
);
1604 return &gfc_bad_expr
;
1607 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
1609 isize
= gfc_integer_kinds
[k
].bit_size
;
1619 ("Magnitude of second argument of ISHFT exceeds bit size at %L",
1621 return &gfc_bad_expr
;
1624 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1628 mpz_set (result
->value
.integer
, e
->value
.integer
);
1629 return range_check (result
, "ISHFT");
1632 bits
= gfc_getmem (isize
* sizeof (int));
1634 for (i
= 0; i
< isize
; i
++)
1635 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1639 for (i
= 0; i
< shift
; i
++)
1640 mpz_clrbit (result
->value
.integer
, i
);
1642 for (i
= 0; i
< isize
- shift
; i
++)
1645 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1647 mpz_setbit (result
->value
.integer
, i
+ shift
);
1652 for (i
= isize
- 1; i
>= isize
- ashift
; i
--)
1653 mpz_clrbit (result
->value
.integer
, i
);
1655 for (i
= isize
- 1; i
>= ashift
; i
--)
1658 mpz_clrbit (result
->value
.integer
, i
- ashift
);
1660 mpz_setbit (result
->value
.integer
, i
- ashift
);
1664 twos_complement (result
->value
.integer
, isize
);
1672 gfc_simplify_ishftc (gfc_expr
* e
, gfc_expr
* s
, gfc_expr
* sz
)
1675 int shift
, ashift
, isize
, delta
, k
;
1678 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1681 if (gfc_extract_int (s
, &shift
) != NULL
)
1683 gfc_error ("Invalid second argument of ISHFTC at %L", &s
->where
);
1684 return &gfc_bad_expr
;
1687 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1691 if (gfc_extract_int (sz
, &isize
) != NULL
|| isize
< 0)
1693 gfc_error ("Invalid third argument of ISHFTC at %L", &sz
->where
);
1694 return &gfc_bad_expr
;
1698 isize
= gfc_integer_kinds
[k
].bit_size
;
1708 ("Magnitude of second argument of ISHFTC exceeds third argument "
1709 "at %L", &s
->where
);
1710 return &gfc_bad_expr
;
1713 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1717 mpz_set (result
->value
.integer
, e
->value
.integer
);
1721 bits
= gfc_getmem (isize
* sizeof (int));
1723 for (i
= 0; i
< isize
; i
++)
1724 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1726 delta
= isize
- ashift
;
1730 for (i
= 0; i
< delta
; i
++)
1733 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1735 mpz_setbit (result
->value
.integer
, i
+ shift
);
1738 for (i
= delta
; i
< isize
; i
++)
1741 mpz_clrbit (result
->value
.integer
, i
- delta
);
1743 mpz_setbit (result
->value
.integer
, i
- delta
);
1748 for (i
= 0; i
< ashift
; i
++)
1751 mpz_clrbit (result
->value
.integer
, i
+ delta
);
1753 mpz_setbit (result
->value
.integer
, i
+ delta
);
1756 for (i
= ashift
; i
< isize
; i
++)
1759 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1761 mpz_setbit (result
->value
.integer
, i
+ shift
);
1765 twos_complement (result
->value
.integer
, isize
);
1773 gfc_simplify_kind (gfc_expr
* e
)
1776 if (e
->ts
.type
== BT_DERIVED
)
1778 gfc_error ("Argument of KIND at %L is a DERIVED type", &e
->where
);
1779 return &gfc_bad_expr
;
1782 return gfc_int_expr (e
->ts
.kind
);
1787 simplify_bound (gfc_expr
* array
, gfc_expr
* dim
, int upper
)
1794 if (array
->expr_type
!= EXPR_VARIABLE
)
1798 /* TODO: Simplify constant multi-dimensional bounds. */
1801 if (dim
->expr_type
!= EXPR_CONSTANT
)
1804 /* Follow any component references. */
1805 as
= array
->symtree
->n
.sym
->as
;
1806 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1811 switch (ref
->u
.ar
.type
)
1818 /* We're done because 'as' has already been set in the
1819 previous iteration. */
1830 as
= ref
->u
.c
.component
->as
;
1841 if (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
)
1844 d
= mpz_get_si (dim
->value
.integer
);
1846 if (d
< 1 || d
> as
->rank
1847 || (d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
1849 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
1850 return &gfc_bad_expr
;
1853 e
= upper
? as
->upper
[d
-1] : as
->lower
[d
-1];
1855 if (e
->expr_type
!= EXPR_CONSTANT
)
1858 return gfc_copy_expr (e
);
1863 gfc_simplify_lbound (gfc_expr
* array
, gfc_expr
* dim
)
1865 return simplify_bound (array
, dim
, 0);
1870 gfc_simplify_len (gfc_expr
* e
)
1874 if (e
->expr_type
!= EXPR_CONSTANT
)
1877 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1880 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
1881 return range_check (result
, "LEN");
1886 gfc_simplify_len_trim (gfc_expr
* e
)
1889 int count
, len
, lentrim
, i
;
1891 if (e
->expr_type
!= EXPR_CONSTANT
)
1894 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1897 len
= e
->value
.character
.length
;
1899 for (count
= 0, i
= 1; i
<= len
; i
++)
1900 if (e
->value
.character
.string
[len
- i
] == ' ')
1905 lentrim
= len
- count
;
1907 mpz_set_si (result
->value
.integer
, lentrim
);
1908 return range_check (result
, "LEN_TRIM");
1913 gfc_simplify_lge (gfc_expr
* a
, gfc_expr
* b
)
1916 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1919 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) >= 0,
1925 gfc_simplify_lgt (gfc_expr
* a
, gfc_expr
* b
)
1928 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1931 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) > 0,
1937 gfc_simplify_lle (gfc_expr
* a
, gfc_expr
* b
)
1940 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1943 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) <= 0,
1949 gfc_simplify_llt (gfc_expr
* a
, gfc_expr
* b
)
1952 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1955 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) < 0,
1961 gfc_simplify_log (gfc_expr
* x
)
1966 if (x
->expr_type
!= EXPR_CONSTANT
)
1969 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1971 gfc_set_model_kind (x
->ts
.kind
);
1976 if (mpfr_sgn (x
->value
.real
) <= 0)
1979 ("Argument of LOG at %L cannot be less than or equal to zero",
1981 gfc_free_expr (result
);
1982 return &gfc_bad_expr
;
1985 mpfr_log(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1989 if ((mpfr_sgn (x
->value
.complex.r
) == 0)
1990 && (mpfr_sgn (x
->value
.complex.i
) == 0))
1992 gfc_error ("Complex argument of LOG at %L cannot be zero",
1994 gfc_free_expr (result
);
1995 return &gfc_bad_expr
;
2001 arctangent2 (x
->value
.complex.i
, x
->value
.complex.r
,
2002 result
->value
.complex.i
);
2004 mpfr_mul (xr
, x
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
2005 mpfr_mul (xi
, x
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
2006 mpfr_add (xr
, xr
, xi
, GFC_RND_MODE
);
2007 mpfr_sqrt (xr
, xr
, GFC_RND_MODE
);
2008 mpfr_log (result
->value
.complex.r
, xr
, GFC_RND_MODE
);
2016 gfc_internal_error ("gfc_simplify_log: bad type");
2019 return range_check (result
, "LOG");
2024 gfc_simplify_log10 (gfc_expr
* x
)
2028 if (x
->expr_type
!= EXPR_CONSTANT
)
2031 gfc_set_model_kind (x
->ts
.kind
);
2033 if (mpfr_sgn (x
->value
.real
) <= 0)
2036 ("Argument of LOG10 at %L cannot be less than or equal to zero",
2038 return &gfc_bad_expr
;
2041 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2043 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2045 return range_check (result
, "LOG10");
2050 gfc_simplify_logical (gfc_expr
* e
, gfc_expr
* k
)
2055 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
2057 return &gfc_bad_expr
;
2059 if (e
->expr_type
!= EXPR_CONSTANT
)
2062 result
= gfc_constant_result (BT_LOGICAL
, kind
, &e
->where
);
2064 result
->value
.logical
= e
->value
.logical
;
2070 /* This function is special since MAX() can take any number of
2071 arguments. The simplified expression is a rewritten version of the
2072 argument list containing at most one constant element. Other
2073 constant elements are deleted. Because the argument list has
2074 already been checked, this function always succeeds. sign is 1 for
2075 MAX(), -1 for MIN(). */
2078 simplify_min_max (gfc_expr
* expr
, int sign
)
2080 gfc_actual_arglist
*arg
, *last
, *extremum
;
2081 gfc_intrinsic_sym
* specific
;
2085 specific
= expr
->value
.function
.isym
;
2087 arg
= expr
->value
.function
.actual
;
2089 for (; arg
; last
= arg
, arg
= arg
->next
)
2091 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
2094 if (extremum
== NULL
)
2100 switch (arg
->expr
->ts
.type
)
2103 if (mpz_cmp (arg
->expr
->value
.integer
,
2104 extremum
->expr
->value
.integer
) * sign
> 0)
2105 mpz_set (extremum
->expr
->value
.integer
, arg
->expr
->value
.integer
);
2110 if (mpfr_cmp (arg
->expr
->value
.real
, extremum
->expr
->value
.real
) *
2112 mpfr_set (extremum
->expr
->value
.real
, arg
->expr
->value
.real
,
2118 gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
2121 /* Delete the extra constant argument. */
2123 expr
->value
.function
.actual
= arg
->next
;
2125 last
->next
= arg
->next
;
2128 gfc_free_actual_arglist (arg
);
2132 /* If there is one value left, replace the function call with the
2134 if (expr
->value
.function
.actual
->next
!= NULL
)
2137 /* Convert to the correct type and kind. */
2138 if (expr
->ts
.type
!= BT_UNKNOWN
)
2139 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2140 expr
->ts
.type
, expr
->ts
.kind
);
2142 if (specific
->ts
.type
!= BT_UNKNOWN
)
2143 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2144 specific
->ts
.type
, specific
->ts
.kind
);
2146 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
2151 gfc_simplify_min (gfc_expr
* e
)
2153 return simplify_min_max (e
, -1);
2158 gfc_simplify_max (gfc_expr
* e
)
2160 return simplify_min_max (e
, 1);
2165 gfc_simplify_maxexponent (gfc_expr
* x
)
2170 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2172 result
= gfc_int_expr (gfc_real_kinds
[i
].max_exponent
);
2173 result
->where
= x
->where
;
2180 gfc_simplify_minexponent (gfc_expr
* x
)
2185 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2187 result
= gfc_int_expr (gfc_real_kinds
[i
].min_exponent
);
2188 result
->where
= x
->where
;
2195 gfc_simplify_mod (gfc_expr
* a
, gfc_expr
* p
)
2198 mpfr_t quot
, iquot
, term
;
2200 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2203 result
= gfc_constant_result (a
->ts
.type
, a
->ts
.kind
, &a
->where
);
2208 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2210 /* Result is processor-dependent. */
2211 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
2212 gfc_free_expr (result
);
2213 return &gfc_bad_expr
;
2215 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2219 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2221 /* Result is processor-dependent. */
2222 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
2223 gfc_free_expr (result
);
2224 return &gfc_bad_expr
;
2227 gfc_set_model_kind (a
->ts
.kind
);
2232 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2233 mpfr_trunc (iquot
, quot
);
2234 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2235 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2243 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2246 return range_check (result
, "MOD");
2251 gfc_simplify_modulo (gfc_expr
* a
, gfc_expr
* p
)
2254 mpfr_t quot
, iquot
, term
;
2256 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2259 result
= gfc_constant_result (a
->ts
.type
, a
->ts
.kind
, &a
->where
);
2264 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2266 /* Result is processor-dependent. This processor just opts
2267 to not handle it at all. */
2268 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
2269 gfc_free_expr (result
);
2270 return &gfc_bad_expr
;
2272 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2277 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2279 /* Result is processor-dependent. */
2280 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
2281 gfc_free_expr (result
);
2282 return &gfc_bad_expr
;
2285 gfc_set_model_kind (a
->ts
.kind
);
2290 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2291 mpfr_floor (iquot
, quot
);
2292 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2293 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2301 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2304 return range_check (result
, "MODULO");
2308 /* Exists for the sole purpose of consistency with other intrinsics. */
2310 gfc_simplify_mvbits (gfc_expr
* f ATTRIBUTE_UNUSED
,
2311 gfc_expr
* fp ATTRIBUTE_UNUSED
,
2312 gfc_expr
* l ATTRIBUTE_UNUSED
,
2313 gfc_expr
* to ATTRIBUTE_UNUSED
,
2314 gfc_expr
* tp ATTRIBUTE_UNUSED
)
2321 gfc_simplify_nearest (gfc_expr
* x
, gfc_expr
* s
)
2327 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
2330 gfc_set_model_kind (x
->ts
.kind
);
2331 result
= gfc_copy_expr (x
);
2333 direction
= mpfr_sgn (s
->value
.real
);
2337 gfc_error ("Second argument of NEAREST at %L may not be zero",
2340 return &gfc_bad_expr
;
2343 /* TODO: Use mpfr_nextabove and mpfr_nextbelow once we move to a
2344 newer version of mpfr. */
2346 sgn
= mpfr_sgn (x
->value
.real
);
2350 int k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
2353 mpfr_add (result
->value
.real
,
2354 x
->value
.real
, gfc_real_kinds
[k
].subnormal
, GFC_RND_MODE
);
2356 mpfr_sub (result
->value
.real
,
2357 x
->value
.real
, gfc_real_kinds
[k
].subnormal
, GFC_RND_MODE
);
2363 direction
= -direction
;
2364 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
2368 mpfr_add_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2371 /* In this case the exponent can shrink, which makes us skip
2372 over one number because we subtract one ulp with the
2373 larger exponent. Thus we need to compensate for this. */
2374 mpfr_init_set (tmp
, result
->value
.real
, GFC_RND_MODE
);
2376 mpfr_sub_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2377 mpfr_add_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2379 /* If we're back to where we started, the spacing is one
2380 ulp, and we get the correct result by subtracting. */
2381 if (mpfr_cmp (tmp
, result
->value
.real
) == 0)
2382 mpfr_sub_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2388 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
2391 return range_check (result
, "NEAREST");
2396 simplify_nint (const char *name
, gfc_expr
* e
, gfc_expr
* k
)
2398 gfc_expr
*itrunc
, *result
;
2401 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
2403 return &gfc_bad_expr
;
2405 if (e
->expr_type
!= EXPR_CONSTANT
)
2408 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
2410 itrunc
= gfc_copy_expr (e
);
2412 mpfr_round(itrunc
->value
.real
, e
->value
.real
);
2414 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
);
2416 gfc_free_expr (itrunc
);
2418 return range_check (result
, name
);
2423 gfc_simplify_nint (gfc_expr
* e
, gfc_expr
* k
)
2425 return simplify_nint ("NINT", e
, k
);
2430 gfc_simplify_idnint (gfc_expr
* e
)
2432 return simplify_nint ("IDNINT", e
, NULL
);
2437 gfc_simplify_not (gfc_expr
* e
)
2442 if (e
->expr_type
!= EXPR_CONSTANT
)
2445 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2447 mpz_com (result
->value
.integer
, e
->value
.integer
);
2449 /* Because of how GMP handles numbers, the result must be ANDed with
2450 the max_int mask. For radices <> 2, this will require change. */
2452 i
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
2454 mpz_and (result
->value
.integer
, result
->value
.integer
,
2455 gfc_integer_kinds
[i
].max_int
);
2457 return range_check (result
, "NOT");
2462 gfc_simplify_null (gfc_expr
* mold
)
2466 result
= gfc_get_expr ();
2467 result
->expr_type
= EXPR_NULL
;
2470 result
->ts
.type
= BT_UNKNOWN
;
2473 result
->ts
= mold
->ts
;
2474 result
->where
= mold
->where
;
2482 gfc_simplify_precision (gfc_expr
* e
)
2487 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2489 result
= gfc_int_expr (gfc_real_kinds
[i
].precision
);
2490 result
->where
= e
->where
;
2497 gfc_simplify_radix (gfc_expr
* e
)
2502 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2506 i
= gfc_integer_kinds
[i
].radix
;
2510 i
= gfc_real_kinds
[i
].radix
;
2517 result
= gfc_int_expr (i
);
2518 result
->where
= e
->where
;
2525 gfc_simplify_range (gfc_expr
* e
)
2531 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2536 j
= gfc_integer_kinds
[i
].range
;
2541 j
= gfc_real_kinds
[i
].range
;
2548 result
= gfc_int_expr (j
);
2549 result
->where
= e
->where
;
2556 gfc_simplify_real (gfc_expr
* e
, gfc_expr
* k
)
2561 if (e
->ts
.type
== BT_COMPLEX
)
2562 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
2564 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
2567 return &gfc_bad_expr
;
2569 if (e
->expr_type
!= EXPR_CONSTANT
)
2575 result
= gfc_int2real (e
, kind
);
2579 result
= gfc_real2real (e
, kind
);
2583 result
= gfc_complex2real (e
, kind
);
2587 gfc_internal_error ("bad type in REAL");
2591 return range_check (result
, "REAL");
2595 gfc_simplify_repeat (gfc_expr
* e
, gfc_expr
* n
)
2598 int i
, j
, len
, ncopies
, nlen
;
2600 if (e
->expr_type
!= EXPR_CONSTANT
|| n
->expr_type
!= EXPR_CONSTANT
)
2603 if (n
!= NULL
&& (gfc_extract_int (n
, &ncopies
) != NULL
|| ncopies
< 0))
2605 gfc_error ("Invalid second argument of REPEAT at %L", &n
->where
);
2606 return &gfc_bad_expr
;
2609 len
= e
->value
.character
.length
;
2610 nlen
= ncopies
* len
;
2612 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
2616 result
->value
.character
.string
= gfc_getmem (1);
2617 result
->value
.character
.length
= 0;
2618 result
->value
.character
.string
[0] = '\0';
2622 result
->value
.character
.length
= nlen
;
2623 result
->value
.character
.string
= gfc_getmem (nlen
+ 1);
2625 for (i
= 0; i
< ncopies
; i
++)
2626 for (j
= 0; j
< len
; j
++)
2627 result
->value
.character
.string
[j
+ i
* len
] =
2628 e
->value
.character
.string
[j
];
2630 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
2635 /* This one is a bear, but mainly has to do with shuffling elements. */
2638 gfc_simplify_reshape (gfc_expr
* source
, gfc_expr
* shape_exp
,
2639 gfc_expr
* pad
, gfc_expr
* order_exp
)
2642 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
2643 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
2644 gfc_constructor
*head
, *tail
;
2650 /* Unpack the shape array. */
2651 if (source
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (source
))
2654 if (shape_exp
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (shape_exp
))
2658 && (pad
->expr_type
!= EXPR_ARRAY
2659 || !gfc_is_constant_expr (pad
)))
2662 if (order_exp
!= NULL
2663 && (order_exp
->expr_type
!= EXPR_ARRAY
2664 || !gfc_is_constant_expr (order_exp
)))
2673 e
= gfc_get_array_element (shape_exp
, rank
);
2677 if (gfc_extract_int (e
, &shape
[rank
]) != NULL
)
2679 gfc_error ("Integer too large in shape specification at %L",
2687 if (rank
>= GFC_MAX_DIMENSIONS
)
2689 gfc_error ("Too many dimensions in shape specification for RESHAPE "
2690 "at %L", &e
->where
);
2695 if (shape
[rank
] < 0)
2697 gfc_error ("Shape specification at %L cannot be negative",
2707 gfc_error ("Shape specification at %L cannot be the null array",
2712 /* Now unpack the order array if present. */
2713 if (order_exp
== NULL
)
2715 for (i
= 0; i
< rank
; i
++)
2722 for (i
= 0; i
< rank
; i
++)
2725 for (i
= 0; i
< rank
; i
++)
2727 e
= gfc_get_array_element (order_exp
, i
);
2731 ("ORDER parameter of RESHAPE at %L is not the same size "
2732 "as SHAPE parameter", &order_exp
->where
);
2736 if (gfc_extract_int (e
, &order
[i
]) != NULL
)
2738 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
2746 if (order
[i
] < 1 || order
[i
] > rank
)
2748 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
2757 gfc_error ("Invalid permutation in ORDER parameter at %L",
2766 /* Count the elements in the source and padding arrays. */
2771 gfc_array_size (pad
, &size
);
2772 npad
= mpz_get_ui (size
);
2776 gfc_array_size (source
, &size
);
2777 nsource
= mpz_get_ui (size
);
2780 /* If it weren't for that pesky permutation we could just loop
2781 through the source and round out any shortage with pad elements.
2782 But no, someone just had to have the compiler do something the
2783 user should be doing. */
2785 for (i
= 0; i
< rank
; i
++)
2790 /* Figure out which element to extract. */
2791 mpz_set_ui (index
, 0);
2793 for (i
= rank
- 1; i
>= 0; i
--)
2795 mpz_add_ui (index
, index
, x
[order
[i
]]);
2797 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
2800 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
2801 gfc_internal_error ("Reshaped array too large at %L", &e
->where
);
2803 j
= mpz_get_ui (index
);
2806 e
= gfc_get_array_element (source
, j
);
2814 ("PAD parameter required for short SOURCE parameter at %L",
2820 e
= gfc_get_array_element (pad
, j
);
2824 head
= tail
= gfc_get_constructor ();
2827 tail
->next
= gfc_get_constructor ();
2834 tail
->where
= e
->where
;
2837 /* Calculate the next element. */
2841 if (++x
[i
] < shape
[i
])
2852 e
= gfc_get_expr ();
2853 e
->where
= source
->where
;
2854 e
->expr_type
= EXPR_ARRAY
;
2855 e
->value
.constructor
= head
;
2856 e
->shape
= gfc_get_shape (rank
);
2858 for (i
= 0; i
< rank
; i
++)
2859 mpz_init_set_ui (e
->shape
[i
], shape
[i
]);
2861 e
->ts
= head
->expr
->ts
;
2867 gfc_free_constructor (head
);
2869 return &gfc_bad_expr
;
2874 gfc_simplify_rrspacing (gfc_expr
* x
)
2877 mpfr_t absv
, log2
, exp
, frac
, pow2
;
2880 if (x
->expr_type
!= EXPR_CONSTANT
)
2883 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2885 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
2887 p
= gfc_real_kinds
[i
].digits
;
2889 gfc_set_model_kind (x
->ts
.kind
);
2891 if (mpfr_sgn (x
->value
.real
) == 0)
2893 mpfr_ui_div (result
->value
.real
, 1, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
2902 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
2903 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
2905 mpfr_trunc (log2
, log2
);
2906 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
2908 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
2909 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
2911 mpfr_mul_2exp (result
->value
.real
, frac
, (unsigned long)p
, GFC_RND_MODE
);
2918 return range_check (result
, "RRSPACING");
2923 gfc_simplify_scale (gfc_expr
* x
, gfc_expr
* i
)
2925 int k
, neg_flag
, power
, exp_range
;
2926 mpfr_t scale
, radix
;
2929 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
2932 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
2934 if (mpfr_sgn (x
->value
.real
) == 0)
2936 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2940 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2942 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
2944 /* This check filters out values of i that would overflow an int. */
2945 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
2946 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
2948 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
2949 return &gfc_bad_expr
;
2952 /* Compute scale = radix ** power. */
2953 power
= mpz_get_si (i
->value
.integer
);
2963 gfc_set_model_kind (x
->ts
.kind
);
2966 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
2967 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
2970 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
2972 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
2977 return range_check (result
, "SCALE");
2982 gfc_simplify_scan (gfc_expr
* e
, gfc_expr
* c
, gfc_expr
* b
)
2987 size_t indx
, len
, lenc
;
2989 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
)
2992 if (b
!= NULL
&& b
->value
.logical
!= 0)
2997 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3000 len
= e
->value
.character
.length
;
3001 lenc
= c
->value
.character
.length
;
3003 if (len
== 0 || lenc
== 0)
3012 strcspn (e
->value
.character
.string
, c
->value
.character
.string
) + 1;
3019 for (indx
= len
; indx
> 0; indx
--)
3021 for (i
= 0; i
< lenc
; i
++)
3023 if (c
->value
.character
.string
[i
]
3024 == e
->value
.character
.string
[indx
- 1])
3032 mpz_set_ui (result
->value
.integer
, indx
);
3033 return range_check (result
, "SCAN");
3038 gfc_simplify_selected_int_kind (gfc_expr
* e
)
3043 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
3048 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
3049 if (gfc_integer_kinds
[i
].range
>= range
3050 && gfc_integer_kinds
[i
].kind
< kind
)
3051 kind
= gfc_integer_kinds
[i
].kind
;
3053 if (kind
== INT_MAX
)
3056 result
= gfc_int_expr (kind
);
3057 result
->where
= e
->where
;
3064 gfc_simplify_selected_real_kind (gfc_expr
* p
, gfc_expr
* q
)
3066 int range
, precision
, i
, kind
, found_precision
, found_range
;
3073 if (p
->expr_type
!= EXPR_CONSTANT
3074 || gfc_extract_int (p
, &precision
) != NULL
)
3082 if (q
->expr_type
!= EXPR_CONSTANT
3083 || gfc_extract_int (q
, &range
) != NULL
)
3088 found_precision
= 0;
3091 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
3093 if (gfc_real_kinds
[i
].precision
>= precision
)
3094 found_precision
= 1;
3096 if (gfc_real_kinds
[i
].range
>= range
)
3099 if (gfc_real_kinds
[i
].precision
>= precision
3100 && gfc_real_kinds
[i
].range
>= range
&& gfc_real_kinds
[i
].kind
< kind
)
3101 kind
= gfc_real_kinds
[i
].kind
;
3104 if (kind
== INT_MAX
)
3108 if (!found_precision
)
3114 result
= gfc_int_expr (kind
);
3115 result
->where
= (p
!= NULL
) ? p
->where
: q
->where
;
3122 gfc_simplify_set_exponent (gfc_expr
* x
, gfc_expr
* i
)
3125 mpfr_t exp
, absv
, log2
, pow2
, frac
;
3128 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3131 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3133 gfc_set_model_kind (x
->ts
.kind
);
3135 if (mpfr_sgn (x
->value
.real
) == 0)
3137 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3147 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3148 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3150 mpfr_trunc (log2
, log2
);
3151 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
3153 /* Old exponent value, and fraction. */
3154 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3156 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
3159 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
3160 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
3167 return range_check (result
, "SET_EXPONENT");
3172 gfc_simplify_shape (gfc_expr
* source
)
3174 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3175 gfc_expr
*result
, *e
, *f
;
3180 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3183 result
= gfc_start_constructor (BT_INTEGER
, gfc_default_integer_kind
,
3186 ar
= gfc_find_array_ref (source
);
3188 t
= gfc_array_ref_shape (ar
, shape
);
3190 for (n
= 0; n
< source
->rank
; n
++)
3192 e
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3197 mpz_set (e
->value
.integer
, shape
[n
]);
3198 mpz_clear (shape
[n
]);
3202 mpz_set_ui (e
->value
.integer
, n
+ 1);
3204 f
= gfc_simplify_size (source
, e
);
3208 gfc_free_expr (result
);
3217 gfc_append_constructor (result
, e
);
3225 gfc_simplify_size (gfc_expr
* array
, gfc_expr
* dim
)
3233 if (gfc_array_size (array
, &size
) == FAILURE
)
3238 if (dim
->expr_type
!= EXPR_CONSTANT
)
3241 d
= mpz_get_ui (dim
->value
.integer
) - 1;
3242 if (gfc_array_dimen_size (array
, d
, &size
) == FAILURE
)
3246 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3249 mpz_set (result
->value
.integer
, size
);
3256 gfc_simplify_sign (gfc_expr
* x
, gfc_expr
* y
)
3260 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3263 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3268 mpz_abs (result
->value
.integer
, x
->value
.integer
);
3269 if (mpz_sgn (y
->value
.integer
) < 0)
3270 mpz_neg (result
->value
.integer
, result
->value
.integer
);
3275 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3277 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3278 if (mpfr_sgn (y
->value
.real
) < 0)
3279 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
3284 gfc_internal_error ("Bad type in gfc_simplify_sign");
3292 gfc_simplify_sin (gfc_expr
* x
)
3297 if (x
->expr_type
!= EXPR_CONSTANT
)
3300 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3305 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3309 gfc_set_model (x
->value
.real
);
3313 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3314 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3315 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
3317 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3318 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3319 mpfr_mul (result
->value
.complex.i
, xp
, xq
, GFC_RND_MODE
);
3326 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3329 return range_check (result
, "SIN");
3334 gfc_simplify_sinh (gfc_expr
* x
)
3338 if (x
->expr_type
!= EXPR_CONSTANT
)
3341 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3343 mpfr_sinh(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3345 return range_check (result
, "SINH");
3349 /* The argument is always a double precision real that is converted to
3350 single precision. TODO: Rounding! */
3353 gfc_simplify_sngl (gfc_expr
* a
)
3357 if (a
->expr_type
!= EXPR_CONSTANT
)
3360 result
= gfc_real2real (a
, gfc_default_real_kind
);
3361 return range_check (result
, "SNGL");
3366 gfc_simplify_spacing (gfc_expr
* x
)
3373 if (x
->expr_type
!= EXPR_CONSTANT
)
3376 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3378 p
= gfc_real_kinds
[i
].digits
;
3380 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3382 gfc_set_model_kind (x
->ts
.kind
);
3384 if (mpfr_sgn (x
->value
.real
) == 0)
3386 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3393 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3394 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3395 mpfr_trunc (log2
, log2
);
3397 mpfr_add_ui (log2
, log2
, 1, GFC_RND_MODE
);
3399 /* FIXME: We should be using mpfr_get_si here, but this function is
3400 not available with the version of mpfr distributed with gmp (as of
3401 2004-09-17). Replace once mpfr has been imported into the gcc cvs
3403 diff
= (long)mpfr_get_d (log2
, GFC_RND_MODE
) - (long)p
;
3404 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
3405 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, diff
, GFC_RND_MODE
);
3410 if (mpfr_cmp (result
->value
.real
, gfc_real_kinds
[i
].tiny
) < 0)
3411 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3413 return range_check (result
, "SPACING");
3418 gfc_simplify_sqrt (gfc_expr
* e
)
3421 mpfr_t ac
, ad
, s
, t
, w
;
3423 if (e
->expr_type
!= EXPR_CONSTANT
)
3426 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3431 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
3433 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
3438 /* Formula taken from Numerical Recipes to avoid over- and
3441 gfc_set_model (e
->value
.real
);
3448 if (mpfr_cmp_ui (e
->value
.complex.r
, 0) == 0
3449 && mpfr_cmp_ui (e
->value
.complex.i
, 0) == 0)
3452 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
3453 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
3457 mpfr_abs (ac
, e
->value
.complex.r
, GFC_RND_MODE
);
3458 mpfr_abs (ad
, e
->value
.complex.i
, GFC_RND_MODE
);
3460 if (mpfr_cmp (ac
, ad
) >= 0)
3462 mpfr_div (t
, e
->value
.complex.i
, e
->value
.complex.r
, GFC_RND_MODE
);
3463 mpfr_mul (t
, t
, t
, GFC_RND_MODE
);
3464 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3465 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3466 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3467 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3468 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3469 mpfr_sqrt (s
, ac
, GFC_RND_MODE
);
3470 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3474 mpfr_div (s
, e
->value
.complex.r
, e
->value
.complex.i
, GFC_RND_MODE
);
3475 mpfr_mul (t
, s
, s
, GFC_RND_MODE
);
3476 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3477 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3478 mpfr_abs (s
, s
, GFC_RND_MODE
);
3479 mpfr_add (t
, t
, s
, GFC_RND_MODE
);
3480 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3481 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3482 mpfr_sqrt (s
, ad
, GFC_RND_MODE
);
3483 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3486 if (mpfr_cmp_ui (w
, 0) != 0 && mpfr_cmp_ui (e
->value
.complex.r
, 0) >= 0)
3488 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3489 mpfr_div (result
->value
.complex.i
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3490 mpfr_set (result
->value
.complex.r
, w
, GFC_RND_MODE
);
3492 else if (mpfr_cmp_ui (w
, 0) != 0
3493 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3494 && mpfr_cmp_ui (e
->value
.complex.i
, 0) >= 0)
3496 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3497 mpfr_div (result
->value
.complex.r
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3498 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3500 else if (mpfr_cmp_ui (w
, 0) != 0
3501 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3502 && mpfr_cmp_ui (e
->value
.complex.i
, 0) < 0)
3504 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3505 mpfr_div (result
->value
.complex.r
, ad
, t
, GFC_RND_MODE
);
3506 mpfr_neg (w
, w
, GFC_RND_MODE
);
3507 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3510 gfc_internal_error ("invalid complex argument of SQRT at %L",
3522 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
3525 return range_check (result
, "SQRT");
3528 gfc_free_expr (result
);
3529 gfc_error ("Argument of SQRT at %L has a negative value", &e
->where
);
3530 return &gfc_bad_expr
;
3535 gfc_simplify_tan (gfc_expr
* x
)
3540 if (x
->expr_type
!= EXPR_CONSTANT
)
3543 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3545 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3547 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3549 return range_check (result
, "TAN");
3554 gfc_simplify_tanh (gfc_expr
* x
)
3558 if (x
->expr_type
!= EXPR_CONSTANT
)
3561 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3563 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3565 return range_check (result
, "TANH");
3571 gfc_simplify_tiny (gfc_expr
* e
)
3576 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
3578 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
3579 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3586 gfc_simplify_trim (gfc_expr
* e
)
3589 int count
, i
, len
, lentrim
;
3591 if (e
->expr_type
!= EXPR_CONSTANT
)
3594 len
= e
->value
.character
.length
;
3596 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
3598 for (count
= 0, i
= 1; i
<= len
; ++i
)
3600 if (e
->value
.character
.string
[len
- i
] == ' ')
3606 lentrim
= len
- count
;
3608 result
->value
.character
.length
= lentrim
;
3609 result
->value
.character
.string
= gfc_getmem (lentrim
+ 1);
3611 for (i
= 0; i
< lentrim
; i
++)
3612 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
3614 result
->value
.character
.string
[lentrim
] = '\0'; /* For debugger */
3621 gfc_simplify_ubound (gfc_expr
* array
, gfc_expr
* dim
)
3623 return simplify_bound (array
, dim
, 1);
3628 gfc_simplify_verify (gfc_expr
* s
, gfc_expr
* set
, gfc_expr
* b
)
3632 size_t index
, len
, lenset
;
3635 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
)
3638 if (b
!= NULL
&& b
->value
.logical
!= 0)
3643 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3646 len
= s
->value
.character
.length
;
3647 lenset
= set
->value
.character
.length
;
3651 mpz_set_ui (result
->value
.integer
, 0);
3659 mpz_set_ui (result
->value
.integer
, len
);
3664 strspn (s
->value
.character
.string
, set
->value
.character
.string
) + 1;
3673 mpz_set_ui (result
->value
.integer
, 1);
3676 for (index
= len
; index
> 0; index
--)
3678 for (i
= 0; i
< lenset
; i
++)
3680 if (s
->value
.character
.string
[index
- 1]
3681 == set
->value
.character
.string
[i
])
3689 mpz_set_ui (result
->value
.integer
, index
);
3693 /****************** Constant simplification *****************/
3695 /* Master function to convert one constant to another. While this is
3696 used as a simplification function, it requires the destination type
3697 and kind information which is supplied by a special case in
3701 gfc_convert_constant (gfc_expr
* e
, bt type
, int kind
)
3703 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
3704 gfc_constructor
*head
, *c
, *tail
= NULL
;
3718 f
= gfc_int2complex
;
3738 f
= gfc_real2complex
;
3749 f
= gfc_complex2int
;
3752 f
= gfc_complex2real
;
3755 f
= gfc_complex2complex
;
3781 f
= gfc_hollerith2int
;
3785 f
= gfc_hollerith2real
;
3789 f
= gfc_hollerith2complex
;
3793 f
= gfc_hollerith2character
;
3797 f
= gfc_hollerith2logical
;
3807 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
3812 switch (e
->expr_type
)
3815 result
= f (e
, kind
);
3817 return &gfc_bad_expr
;
3821 if (!gfc_is_constant_expr (e
))
3826 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
3829 head
= tail
= gfc_get_constructor ();
3832 tail
->next
= gfc_get_constructor ();
3836 tail
->where
= c
->where
;
3838 if (c
->iterator
== NULL
)
3839 tail
->expr
= f (c
->expr
, kind
);
3842 g
= gfc_convert_constant (c
->expr
, type
, kind
);
3843 if (g
== &gfc_bad_expr
)
3848 if (tail
->expr
== NULL
)
3850 gfc_free_constructor (head
);
3855 result
= gfc_get_expr ();
3856 result
->ts
.type
= type
;
3857 result
->ts
.kind
= kind
;
3858 result
->expr_type
= EXPR_ARRAY
;
3859 result
->value
.constructor
= head
;
3860 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
3861 result
->where
= e
->where
;
3862 result
->rank
= e
->rank
;
3873 /****************** Helper functions ***********************/
3875 /* Given a collating table, create the inverse table. */
3878 invert_table (const int *table
, int *xtable
)
3882 for (i
= 0; i
< 256; i
++)
3885 for (i
= 0; i
< 256; i
++)
3886 xtable
[table
[i
]] = i
;
3891 gfc_simplify_init_1 (void)
3894 invert_table (ascii_table
, xascii_table
);