1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
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
)
378 if (e
->expr_type
!= EXPR_CONSTANT
)
381 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
382 mpfr_set (result
->value
.real
, e
->value
.complex.i
, GFC_RND_MODE
);
384 return range_check (result
, "AIMAG");
389 gfc_simplify_aint (gfc_expr
* e
, gfc_expr
* k
)
391 gfc_expr
*rtrunc
, *result
;
394 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
396 return &gfc_bad_expr
;
398 if (e
->expr_type
!= EXPR_CONSTANT
)
401 rtrunc
= gfc_copy_expr (e
);
403 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
405 result
= gfc_real2real (rtrunc
, kind
);
406 gfc_free_expr (rtrunc
);
408 return range_check (result
, "AINT");
413 gfc_simplify_dint (gfc_expr
* e
)
415 gfc_expr
*rtrunc
, *result
;
417 if (e
->expr_type
!= EXPR_CONSTANT
)
420 rtrunc
= gfc_copy_expr (e
);
422 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
424 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
425 gfc_free_expr (rtrunc
);
427 return range_check (result
, "DINT");
432 gfc_simplify_anint (gfc_expr
* e
, gfc_expr
* k
)
437 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
439 return &gfc_bad_expr
;
441 if (e
->expr_type
!= EXPR_CONSTANT
)
444 result
= gfc_constant_result (e
->ts
.type
, kind
, &e
->where
);
446 mpfr_round (result
->value
.real
, e
->value
.real
);
448 return range_check (result
, "ANINT");
453 gfc_simplify_and (gfc_expr
* x
, gfc_expr
* y
)
458 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
461 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
462 if (x
->ts
.type
== BT_INTEGER
)
464 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
465 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
467 else /* BT_LOGICAL */
469 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
470 result
->value
.logical
= x
->value
.logical
&& y
->value
.logical
;
473 return range_check (result
, "AND");
478 gfc_simplify_dnint (gfc_expr
* e
)
482 if (e
->expr_type
!= EXPR_CONSTANT
)
485 result
= gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &e
->where
);
487 mpfr_round (result
->value
.real
, e
->value
.real
);
489 return range_check (result
, "DNINT");
494 gfc_simplify_asin (gfc_expr
* x
)
498 if (x
->expr_type
!= EXPR_CONSTANT
)
501 if (mpfr_cmp_si (x
->value
.real
, 1) > 0 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
503 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
505 return &gfc_bad_expr
;
508 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
510 mpfr_asin(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
512 return range_check (result
, "ASIN");
517 gfc_simplify_asinh (gfc_expr
* x
)
521 if (x
->expr_type
!= EXPR_CONSTANT
)
524 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
526 mpfr_asinh(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
528 return range_check (result
, "ASINH");
533 gfc_simplify_atan (gfc_expr
* x
)
537 if (x
->expr_type
!= EXPR_CONSTANT
)
540 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
542 mpfr_atan(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
544 return range_check (result
, "ATAN");
549 gfc_simplify_atanh (gfc_expr
* x
)
553 if (x
->expr_type
!= EXPR_CONSTANT
)
556 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0 ||
557 mpfr_cmp_si (x
->value
.real
, -1) <= 0)
559 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
561 return &gfc_bad_expr
;
564 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
566 mpfr_atanh(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
568 return range_check (result
, "ATANH");
573 gfc_simplify_atan2 (gfc_expr
* y
, gfc_expr
* x
)
577 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
580 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
582 if (mpfr_sgn (y
->value
.real
) == 0 && mpfr_sgn (x
->value
.real
) == 0)
585 ("If first argument of ATAN2 %L is zero, then the second argument "
586 "must not be zero", &x
->where
);
587 gfc_free_expr (result
);
588 return &gfc_bad_expr
;
591 arctangent2 (y
->value
.real
, x
->value
.real
, result
->value
.real
);
593 return range_check (result
, "ATAN2");
598 gfc_simplify_bit_size (gfc_expr
* e
)
603 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
604 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
605 mpz_set_ui (result
->value
.integer
, gfc_integer_kinds
[i
].bit_size
);
612 gfc_simplify_btest (gfc_expr
* e
, gfc_expr
* bit
)
616 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
619 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
620 return gfc_logical_expr (0, &e
->where
);
622 return gfc_logical_expr (mpz_tstbit (e
->value
.integer
, b
), &e
->where
);
627 gfc_simplify_ceiling (gfc_expr
* e
, gfc_expr
* k
)
629 gfc_expr
*ceil
, *result
;
632 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
634 return &gfc_bad_expr
;
636 if (e
->expr_type
!= EXPR_CONSTANT
)
639 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
641 ceil
= gfc_copy_expr (e
);
643 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
644 gfc_mpfr_to_mpz(result
->value
.integer
, ceil
->value
.real
);
646 gfc_free_expr (ceil
);
648 return range_check (result
, "CEILING");
653 gfc_simplify_char (gfc_expr
* e
, gfc_expr
* k
)
658 kind
= get_kind (BT_CHARACTER
, k
, "CHAR", gfc_default_character_kind
);
660 return &gfc_bad_expr
;
662 if (e
->expr_type
!= EXPR_CONSTANT
)
665 if (gfc_extract_int (e
, &c
) != NULL
|| c
< 0 || c
> UCHAR_MAX
)
667 gfc_error ("Bad character in CHAR function at %L", &e
->where
);
668 return &gfc_bad_expr
;
671 result
= gfc_constant_result (BT_CHARACTER
, kind
, &e
->where
);
673 result
->value
.character
.length
= 1;
674 result
->value
.character
.string
= gfc_getmem (2);
676 result
->value
.character
.string
[0] = c
;
677 result
->value
.character
.string
[1] = '\0'; /* For debugger */
683 /* Common subroutine for simplifying CMPLX and DCMPLX. */
686 simplify_cmplx (const char *name
, gfc_expr
* x
, gfc_expr
* y
, int kind
)
690 result
= gfc_constant_result (BT_COMPLEX
, kind
, &x
->where
);
692 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
697 mpfr_set_z (result
->value
.complex.r
, x
->value
.integer
, GFC_RND_MODE
);
701 mpfr_set (result
->value
.complex.r
, x
->value
.real
, GFC_RND_MODE
);
705 mpfr_set (result
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
706 mpfr_set (result
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
710 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
718 mpfr_set_z (result
->value
.complex.i
, y
->value
.integer
, GFC_RND_MODE
);
722 mpfr_set (result
->value
.complex.i
, y
->value
.real
, GFC_RND_MODE
);
726 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
730 return range_check (result
, name
);
735 gfc_simplify_cmplx (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* k
)
739 if (x
->expr_type
!= EXPR_CONSTANT
740 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
743 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_real_kind
);
745 return &gfc_bad_expr
;
747 return simplify_cmplx ("CMPLX", x
, y
, kind
);
752 gfc_simplify_complex (gfc_expr
* x
, gfc_expr
* y
)
756 if (x
->expr_type
!= EXPR_CONSTANT
757 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
760 if (x
->ts
.type
== BT_INTEGER
)
762 if (y
->ts
.type
== BT_INTEGER
)
763 kind
= gfc_default_real_kind
;
769 if (y
->ts
.type
== BT_REAL
)
770 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
775 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
780 gfc_simplify_conjg (gfc_expr
* e
)
784 if (e
->expr_type
!= EXPR_CONSTANT
)
787 result
= gfc_copy_expr (e
);
788 mpfr_neg (result
->value
.complex.i
, result
->value
.complex.i
, GFC_RND_MODE
);
790 return range_check (result
, "CONJG");
795 gfc_simplify_cos (gfc_expr
* x
)
800 if (x
->expr_type
!= EXPR_CONSTANT
)
803 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
808 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
811 gfc_set_model_kind (x
->ts
.kind
);
815 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
816 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
817 mpfr_mul(result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
819 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
820 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
821 mpfr_mul (xp
, xp
, xq
, GFC_RND_MODE
);
822 mpfr_neg (result
->value
.complex.i
, xp
, GFC_RND_MODE
);
828 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
831 return range_check (result
, "COS");
837 gfc_simplify_cosh (gfc_expr
* x
)
841 if (x
->expr_type
!= EXPR_CONSTANT
)
844 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
846 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
848 return range_check (result
, "COSH");
853 gfc_simplify_dcmplx (gfc_expr
* x
, gfc_expr
* y
)
856 if (x
->expr_type
!= EXPR_CONSTANT
857 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
860 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
865 gfc_simplify_dble (gfc_expr
* e
)
869 if (e
->expr_type
!= EXPR_CONSTANT
)
875 result
= gfc_int2real (e
, gfc_default_double_kind
);
879 result
= gfc_real2real (e
, gfc_default_double_kind
);
883 result
= gfc_complex2real (e
, gfc_default_double_kind
);
887 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e
->where
);
890 return range_check (result
, "DBLE");
895 gfc_simplify_digits (gfc_expr
* x
)
899 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
903 digits
= gfc_integer_kinds
[i
].digits
;
908 digits
= gfc_real_kinds
[i
].digits
;
915 return gfc_int_expr (digits
);
920 gfc_simplify_dim (gfc_expr
* x
, gfc_expr
* y
)
925 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
928 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
929 result
= gfc_constant_result (x
->ts
.type
, kind
, &x
->where
);
934 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
935 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
937 mpz_set_ui (result
->value
.integer
, 0);
942 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
943 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
945 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
950 gfc_internal_error ("gfc_simplify_dim(): Bad type");
953 return range_check (result
, "DIM");
958 gfc_simplify_dprod (gfc_expr
* x
, gfc_expr
* y
)
960 gfc_expr
*a1
, *a2
, *result
;
962 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
966 gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &x
->where
);
968 a1
= gfc_real2real (x
, gfc_default_double_kind
);
969 a2
= gfc_real2real (y
, gfc_default_double_kind
);
971 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
976 return range_check (result
, "DPROD");
981 gfc_simplify_epsilon (gfc_expr
* e
)
986 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
988 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
990 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
992 return range_check (result
, "EPSILON");
997 gfc_simplify_exp (gfc_expr
* x
)
1002 if (x
->expr_type
!= EXPR_CONSTANT
)
1005 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1010 mpfr_exp(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1014 gfc_set_model_kind (x
->ts
.kind
);
1017 mpfr_exp (xq
, x
->value
.complex.r
, GFC_RND_MODE
);
1018 mpfr_cos (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
1019 mpfr_mul (result
->value
.complex.r
, xq
, xp
, GFC_RND_MODE
);
1020 mpfr_sin (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
1021 mpfr_mul (result
->value
.complex.i
, xq
, xp
, GFC_RND_MODE
);
1027 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1030 return range_check (result
, "EXP");
1033 /* FIXME: MPFR should be able to do this better */
1035 gfc_simplify_exponent (gfc_expr
* x
)
1041 if (x
->expr_type
!= EXPR_CONSTANT
)
1044 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1047 gfc_set_model (x
->value
.real
);
1049 if (mpfr_sgn (x
->value
.real
) == 0)
1051 mpz_set_ui (result
->value
.integer
, 0);
1057 mpfr_abs (tmp
, x
->value
.real
, GFC_RND_MODE
);
1058 mpfr_log2 (tmp
, tmp
, GFC_RND_MODE
);
1060 gfc_mpfr_to_mpz (result
->value
.integer
, tmp
);
1062 /* The model number for tiny(x) is b**(emin - 1) where b is the base and emin
1063 is the smallest exponent value. So, we need to add 1 if x is tiny(x). */
1064 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1065 if (mpfr_cmp (x
->value
.real
, gfc_real_kinds
[i
].tiny
) == 0)
1066 mpz_add_ui (result
->value
.integer
,result
->value
.integer
, 1);
1070 return range_check (result
, "EXPONENT");
1075 gfc_simplify_float (gfc_expr
* a
)
1079 if (a
->expr_type
!= EXPR_CONSTANT
)
1082 result
= gfc_int2real (a
, gfc_default_real_kind
);
1083 return range_check (result
, "FLOAT");
1088 gfc_simplify_floor (gfc_expr
* e
, gfc_expr
* k
)
1094 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
1096 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1098 if (e
->expr_type
!= EXPR_CONSTANT
)
1101 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1103 gfc_set_model_kind (kind
);
1105 mpfr_floor (floor
, e
->value
.real
);
1107 gfc_mpfr_to_mpz (result
->value
.integer
, floor
);
1111 return range_check (result
, "FLOOR");
1116 gfc_simplify_fraction (gfc_expr
* x
)
1119 mpfr_t absv
, exp
, pow2
;
1121 if (x
->expr_type
!= EXPR_CONSTANT
)
1124 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
1126 gfc_set_model_kind (x
->ts
.kind
);
1128 if (mpfr_sgn (x
->value
.real
) == 0)
1130 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1138 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
1139 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
1141 mpfr_trunc (exp
, exp
);
1142 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
1144 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
1146 mpfr_div (result
->value
.real
, absv
, pow2
, GFC_RND_MODE
);
1152 return range_check (result
, "FRACTION");
1157 gfc_simplify_huge (gfc_expr
* e
)
1162 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1164 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1169 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
1173 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
1185 gfc_simplify_iachar (gfc_expr
* e
)
1190 if (e
->expr_type
!= EXPR_CONSTANT
)
1193 if (e
->value
.character
.length
!= 1)
1195 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
1196 return &gfc_bad_expr
;
1199 index
= xascii_table
[(int) e
->value
.character
.string
[0] & 0xFF];
1201 result
= gfc_int_expr (index
);
1202 result
->where
= e
->where
;
1204 return range_check (result
, "IACHAR");
1209 gfc_simplify_iand (gfc_expr
* x
, gfc_expr
* y
)
1213 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1216 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1218 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1220 return range_check (result
, "IAND");
1225 gfc_simplify_ibclr (gfc_expr
* x
, gfc_expr
* y
)
1230 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1233 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1235 gfc_error ("Invalid second argument of IBCLR at %L", &y
->where
);
1236 return &gfc_bad_expr
;
1239 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1241 if (pos
> gfc_integer_kinds
[k
].bit_size
)
1243 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1245 return &gfc_bad_expr
;
1248 result
= gfc_copy_expr (x
);
1250 mpz_clrbit (result
->value
.integer
, pos
);
1251 return range_check (result
, "IBCLR");
1256 gfc_simplify_ibits (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
1263 if (x
->expr_type
!= EXPR_CONSTANT
1264 || y
->expr_type
!= EXPR_CONSTANT
1265 || z
->expr_type
!= EXPR_CONSTANT
)
1268 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1270 gfc_error ("Invalid second argument of IBITS at %L", &y
->where
);
1271 return &gfc_bad_expr
;
1274 if (gfc_extract_int (z
, &len
) != NULL
|| len
< 0)
1276 gfc_error ("Invalid third argument of IBITS at %L", &z
->where
);
1277 return &gfc_bad_expr
;
1280 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
1282 bitsize
= gfc_integer_kinds
[k
].bit_size
;
1284 if (pos
+ len
> bitsize
)
1287 ("Sum of second and third arguments of IBITS exceeds bit size "
1288 "at %L", &y
->where
);
1289 return &gfc_bad_expr
;
1292 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1294 bits
= gfc_getmem (bitsize
* sizeof (int));
1296 for (i
= 0; i
< bitsize
; i
++)
1299 for (i
= 0; i
< len
; i
++)
1300 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
1302 for (i
= 0; i
< bitsize
; i
++)
1306 mpz_clrbit (result
->value
.integer
, i
);
1308 else if (bits
[i
] == 1)
1310 mpz_setbit (result
->value
.integer
, i
);
1314 gfc_internal_error ("IBITS: Bad bit");
1320 return range_check (result
, "IBITS");
1325 gfc_simplify_ibset (gfc_expr
* x
, gfc_expr
* y
)
1330 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1333 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1335 gfc_error ("Invalid second argument of IBSET at %L", &y
->where
);
1336 return &gfc_bad_expr
;
1339 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1341 if (pos
> gfc_integer_kinds
[k
].bit_size
)
1343 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1345 return &gfc_bad_expr
;
1348 result
= gfc_copy_expr (x
);
1350 mpz_setbit (result
->value
.integer
, pos
);
1352 twos_complement (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
1354 return range_check (result
, "IBSET");
1359 gfc_simplify_ichar (gfc_expr
* e
)
1364 if (e
->expr_type
!= EXPR_CONSTANT
)
1367 if (e
->value
.character
.length
!= 1)
1369 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
1370 return &gfc_bad_expr
;
1373 index
= (unsigned char) e
->value
.character
.string
[0];
1375 if (index
< 0 || index
> UCHAR_MAX
)
1377 gfc_error ("Argument of ICHAR at %L out of range of this processor",
1379 return &gfc_bad_expr
;
1382 result
= gfc_int_expr (index
);
1383 result
->where
= e
->where
;
1384 return range_check (result
, "ICHAR");
1389 gfc_simplify_ieor (gfc_expr
* x
, gfc_expr
* y
)
1393 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1396 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1398 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1400 return range_check (result
, "IEOR");
1405 gfc_simplify_index (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* b
)
1408 int back
, len
, lensub
;
1409 int i
, j
, k
, count
, index
= 0, start
;
1411 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1414 if (b
!= NULL
&& b
->value
.logical
!= 0)
1419 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1422 len
= x
->value
.character
.length
;
1423 lensub
= y
->value
.character
.length
;
1427 mpz_set_si (result
->value
.integer
, 0);
1436 mpz_set_si (result
->value
.integer
, 1);
1439 else if (lensub
== 1)
1441 for (i
= 0; i
< len
; i
++)
1443 for (j
= 0; j
< lensub
; j
++)
1445 if (y
->value
.character
.string
[j
] ==
1446 x
->value
.character
.string
[i
])
1456 for (i
= 0; i
< len
; i
++)
1458 for (j
= 0; j
< lensub
; j
++)
1460 if (y
->value
.character
.string
[j
] ==
1461 x
->value
.character
.string
[i
])
1466 for (k
= 0; k
< lensub
; k
++)
1468 if (y
->value
.character
.string
[k
] ==
1469 x
->value
.character
.string
[k
+ start
])
1473 if (count
== lensub
)
1489 mpz_set_si (result
->value
.integer
, len
+ 1);
1492 else if (lensub
== 1)
1494 for (i
= 0; i
< len
; i
++)
1496 for (j
= 0; j
< lensub
; j
++)
1498 if (y
->value
.character
.string
[j
] ==
1499 x
->value
.character
.string
[len
- i
])
1501 index
= len
- i
+ 1;
1509 for (i
= 0; i
< len
; i
++)
1511 for (j
= 0; j
< lensub
; j
++)
1513 if (y
->value
.character
.string
[j
] ==
1514 x
->value
.character
.string
[len
- i
])
1517 if (start
<= len
- lensub
)
1520 for (k
= 0; k
< lensub
; k
++)
1521 if (y
->value
.character
.string
[k
] ==
1522 x
->value
.character
.string
[k
+ start
])
1525 if (count
== lensub
)
1542 mpz_set_si (result
->value
.integer
, index
);
1543 return range_check (result
, "INDEX");
1548 gfc_simplify_int (gfc_expr
* e
, gfc_expr
* k
)
1550 gfc_expr
*rpart
, *rtrunc
, *result
;
1553 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
1555 return &gfc_bad_expr
;
1557 if (e
->expr_type
!= EXPR_CONSTANT
)
1560 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1565 mpz_set (result
->value
.integer
, e
->value
.integer
);
1569 rtrunc
= gfc_copy_expr (e
);
1570 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1571 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1572 gfc_free_expr (rtrunc
);
1576 rpart
= gfc_complex2real (e
, kind
);
1577 rtrunc
= gfc_copy_expr (rpart
);
1578 mpfr_trunc (rtrunc
->value
.real
, rpart
->value
.real
);
1579 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1580 gfc_free_expr (rpart
);
1581 gfc_free_expr (rtrunc
);
1585 gfc_error ("Argument of INT at %L is not a valid type", &e
->where
);
1586 gfc_free_expr (result
);
1587 return &gfc_bad_expr
;
1590 return range_check (result
, "INT");
1595 gfc_simplify_ifix (gfc_expr
* e
)
1597 gfc_expr
*rtrunc
, *result
;
1599 if (e
->expr_type
!= EXPR_CONSTANT
)
1602 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1605 rtrunc
= gfc_copy_expr (e
);
1607 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1608 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1610 gfc_free_expr (rtrunc
);
1611 return range_check (result
, "IFIX");
1616 gfc_simplify_idint (gfc_expr
* e
)
1618 gfc_expr
*rtrunc
, *result
;
1620 if (e
->expr_type
!= EXPR_CONSTANT
)
1623 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1626 rtrunc
= gfc_copy_expr (e
);
1628 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1629 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1631 gfc_free_expr (rtrunc
);
1632 return range_check (result
, "IDINT");
1637 gfc_simplify_ior (gfc_expr
* x
, gfc_expr
* y
)
1641 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1644 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1646 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1647 return range_check (result
, "IOR");
1652 gfc_simplify_ishft (gfc_expr
* e
, gfc_expr
* s
)
1655 int shift
, ashift
, isize
, k
, *bits
, i
;
1657 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1660 if (gfc_extract_int (s
, &shift
) != NULL
)
1662 gfc_error ("Invalid second argument of ISHFT at %L", &s
->where
);
1663 return &gfc_bad_expr
;
1666 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
1668 isize
= gfc_integer_kinds
[k
].bit_size
;
1678 ("Magnitude of second argument of ISHFT exceeds bit size at %L",
1680 return &gfc_bad_expr
;
1683 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1687 mpz_set (result
->value
.integer
, e
->value
.integer
);
1688 return range_check (result
, "ISHFT");
1691 bits
= gfc_getmem (isize
* sizeof (int));
1693 for (i
= 0; i
< isize
; i
++)
1694 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1698 for (i
= 0; i
< shift
; i
++)
1699 mpz_clrbit (result
->value
.integer
, i
);
1701 for (i
= 0; i
< isize
- shift
; i
++)
1704 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1706 mpz_setbit (result
->value
.integer
, i
+ shift
);
1711 for (i
= isize
- 1; i
>= isize
- ashift
; i
--)
1712 mpz_clrbit (result
->value
.integer
, i
);
1714 for (i
= isize
- 1; i
>= ashift
; i
--)
1717 mpz_clrbit (result
->value
.integer
, i
- ashift
);
1719 mpz_setbit (result
->value
.integer
, i
- ashift
);
1723 twos_complement (result
->value
.integer
, isize
);
1731 gfc_simplify_ishftc (gfc_expr
* e
, gfc_expr
* s
, gfc_expr
* sz
)
1734 int shift
, ashift
, isize
, delta
, k
;
1737 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1740 if (gfc_extract_int (s
, &shift
) != NULL
)
1742 gfc_error ("Invalid second argument of ISHFTC at %L", &s
->where
);
1743 return &gfc_bad_expr
;
1746 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1750 if (gfc_extract_int (sz
, &isize
) != NULL
|| isize
< 0)
1752 gfc_error ("Invalid third argument of ISHFTC at %L", &sz
->where
);
1753 return &gfc_bad_expr
;
1757 isize
= gfc_integer_kinds
[k
].bit_size
;
1767 ("Magnitude of second argument of ISHFTC exceeds third argument "
1768 "at %L", &s
->where
);
1769 return &gfc_bad_expr
;
1772 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1776 mpz_set (result
->value
.integer
, e
->value
.integer
);
1780 bits
= gfc_getmem (isize
* sizeof (int));
1782 for (i
= 0; i
< isize
; i
++)
1783 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1785 delta
= isize
- ashift
;
1789 for (i
= 0; i
< delta
; i
++)
1792 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1794 mpz_setbit (result
->value
.integer
, i
+ shift
);
1797 for (i
= delta
; i
< isize
; i
++)
1800 mpz_clrbit (result
->value
.integer
, i
- delta
);
1802 mpz_setbit (result
->value
.integer
, i
- delta
);
1807 for (i
= 0; i
< ashift
; i
++)
1810 mpz_clrbit (result
->value
.integer
, i
+ delta
);
1812 mpz_setbit (result
->value
.integer
, i
+ delta
);
1815 for (i
= ashift
; i
< isize
; i
++)
1818 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1820 mpz_setbit (result
->value
.integer
, i
+ shift
);
1824 twos_complement (result
->value
.integer
, isize
);
1832 gfc_simplify_kind (gfc_expr
* e
)
1835 if (e
->ts
.type
== BT_DERIVED
)
1837 gfc_error ("Argument of KIND at %L is a DERIVED type", &e
->where
);
1838 return &gfc_bad_expr
;
1841 return gfc_int_expr (e
->ts
.kind
);
1846 simplify_bound (gfc_expr
* array
, gfc_expr
* dim
, int upper
)
1853 if (array
->expr_type
!= EXPR_VARIABLE
)
1857 /* TODO: Simplify constant multi-dimensional bounds. */
1860 if (dim
->expr_type
!= EXPR_CONSTANT
)
1863 /* Follow any component references. */
1864 as
= array
->symtree
->n
.sym
->as
;
1865 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1870 switch (ref
->u
.ar
.type
)
1877 /* We're done because 'as' has already been set in the
1878 previous iteration. */
1889 as
= ref
->u
.c
.component
->as
;
1900 if (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
)
1903 d
= mpz_get_si (dim
->value
.integer
);
1905 if (d
< 1 || d
> as
->rank
1906 || (d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
1908 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
1909 return &gfc_bad_expr
;
1912 e
= upper
? as
->upper
[d
-1] : as
->lower
[d
-1];
1914 if (e
->expr_type
!= EXPR_CONSTANT
)
1917 return gfc_copy_expr (e
);
1922 gfc_simplify_lbound (gfc_expr
* array
, gfc_expr
* dim
)
1924 return simplify_bound (array
, dim
, 0);
1929 gfc_simplify_len (gfc_expr
* e
)
1933 if (e
->expr_type
== EXPR_CONSTANT
)
1935 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1937 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
1938 return range_check (result
, "LEN");
1941 if (e
->ts
.cl
!= NULL
&& e
->ts
.cl
->length
!= NULL
1942 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1944 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1946 mpz_set (result
->value
.integer
, e
->ts
.cl
->length
->value
.integer
);
1947 return range_check (result
, "LEN");
1955 gfc_simplify_len_trim (gfc_expr
* e
)
1958 int count
, len
, lentrim
, i
;
1960 if (e
->expr_type
!= EXPR_CONSTANT
)
1963 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1966 len
= e
->value
.character
.length
;
1968 for (count
= 0, i
= 1; i
<= len
; i
++)
1969 if (e
->value
.character
.string
[len
- i
] == ' ')
1974 lentrim
= len
- count
;
1976 mpz_set_si (result
->value
.integer
, lentrim
);
1977 return range_check (result
, "LEN_TRIM");
1982 gfc_simplify_lge (gfc_expr
* a
, gfc_expr
* b
)
1985 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1988 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) >= 0,
1994 gfc_simplify_lgt (gfc_expr
* a
, gfc_expr
* b
)
1997 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2000 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) > 0,
2006 gfc_simplify_lle (gfc_expr
* a
, gfc_expr
* b
)
2009 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2012 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) <= 0,
2018 gfc_simplify_llt (gfc_expr
* a
, gfc_expr
* b
)
2021 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2024 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) < 0,
2030 gfc_simplify_log (gfc_expr
* x
)
2035 if (x
->expr_type
!= EXPR_CONSTANT
)
2038 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2040 gfc_set_model_kind (x
->ts
.kind
);
2045 if (mpfr_sgn (x
->value
.real
) <= 0)
2048 ("Argument of LOG at %L cannot be less than or equal to zero",
2050 gfc_free_expr (result
);
2051 return &gfc_bad_expr
;
2054 mpfr_log(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2058 if ((mpfr_sgn (x
->value
.complex.r
) == 0)
2059 && (mpfr_sgn (x
->value
.complex.i
) == 0))
2061 gfc_error ("Complex argument of LOG at %L cannot be zero",
2063 gfc_free_expr (result
);
2064 return &gfc_bad_expr
;
2070 arctangent2 (x
->value
.complex.i
, x
->value
.complex.r
,
2071 result
->value
.complex.i
);
2073 mpfr_mul (xr
, x
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
2074 mpfr_mul (xi
, x
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
2075 mpfr_add (xr
, xr
, xi
, GFC_RND_MODE
);
2076 mpfr_sqrt (xr
, xr
, GFC_RND_MODE
);
2077 mpfr_log (result
->value
.complex.r
, xr
, GFC_RND_MODE
);
2085 gfc_internal_error ("gfc_simplify_log: bad type");
2088 return range_check (result
, "LOG");
2093 gfc_simplify_log10 (gfc_expr
* x
)
2097 if (x
->expr_type
!= EXPR_CONSTANT
)
2100 gfc_set_model_kind (x
->ts
.kind
);
2102 if (mpfr_sgn (x
->value
.real
) <= 0)
2105 ("Argument of LOG10 at %L cannot be less than or equal to zero",
2107 return &gfc_bad_expr
;
2110 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2112 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2114 return range_check (result
, "LOG10");
2119 gfc_simplify_logical (gfc_expr
* e
, gfc_expr
* k
)
2124 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
2126 return &gfc_bad_expr
;
2128 if (e
->expr_type
!= EXPR_CONSTANT
)
2131 result
= gfc_constant_result (BT_LOGICAL
, kind
, &e
->where
);
2133 result
->value
.logical
= e
->value
.logical
;
2139 /* This function is special since MAX() can take any number of
2140 arguments. The simplified expression is a rewritten version of the
2141 argument list containing at most one constant element. Other
2142 constant elements are deleted. Because the argument list has
2143 already been checked, this function always succeeds. sign is 1 for
2144 MAX(), -1 for MIN(). */
2147 simplify_min_max (gfc_expr
* expr
, int sign
)
2149 gfc_actual_arglist
*arg
, *last
, *extremum
;
2150 gfc_intrinsic_sym
* specific
;
2154 specific
= expr
->value
.function
.isym
;
2156 arg
= expr
->value
.function
.actual
;
2158 for (; arg
; last
= arg
, arg
= arg
->next
)
2160 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
2163 if (extremum
== NULL
)
2169 switch (arg
->expr
->ts
.type
)
2172 if (mpz_cmp (arg
->expr
->value
.integer
,
2173 extremum
->expr
->value
.integer
) * sign
> 0)
2174 mpz_set (extremum
->expr
->value
.integer
, arg
->expr
->value
.integer
);
2179 if (mpfr_cmp (arg
->expr
->value
.real
, extremum
->expr
->value
.real
) *
2181 mpfr_set (extremum
->expr
->value
.real
, arg
->expr
->value
.real
,
2187 gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
2190 /* Delete the extra constant argument. */
2192 expr
->value
.function
.actual
= arg
->next
;
2194 last
->next
= arg
->next
;
2197 gfc_free_actual_arglist (arg
);
2201 /* If there is one value left, replace the function call with the
2203 if (expr
->value
.function
.actual
->next
!= NULL
)
2206 /* Convert to the correct type and kind. */
2207 if (expr
->ts
.type
!= BT_UNKNOWN
)
2208 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2209 expr
->ts
.type
, expr
->ts
.kind
);
2211 if (specific
->ts
.type
!= BT_UNKNOWN
)
2212 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2213 specific
->ts
.type
, specific
->ts
.kind
);
2215 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
2220 gfc_simplify_min (gfc_expr
* e
)
2222 return simplify_min_max (e
, -1);
2227 gfc_simplify_max (gfc_expr
* e
)
2229 return simplify_min_max (e
, 1);
2234 gfc_simplify_maxexponent (gfc_expr
* x
)
2239 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2241 result
= gfc_int_expr (gfc_real_kinds
[i
].max_exponent
);
2242 result
->where
= x
->where
;
2249 gfc_simplify_minexponent (gfc_expr
* x
)
2254 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2256 result
= gfc_int_expr (gfc_real_kinds
[i
].min_exponent
);
2257 result
->where
= x
->where
;
2264 gfc_simplify_mod (gfc_expr
* a
, gfc_expr
* p
)
2267 mpfr_t quot
, iquot
, term
;
2270 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2273 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2274 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2279 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2281 /* Result is processor-dependent. */
2282 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
2283 gfc_free_expr (result
);
2284 return &gfc_bad_expr
;
2286 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2290 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2292 /* Result is processor-dependent. */
2293 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
2294 gfc_free_expr (result
);
2295 return &gfc_bad_expr
;
2298 gfc_set_model_kind (kind
);
2303 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2304 mpfr_trunc (iquot
, quot
);
2305 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2306 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2314 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2317 return range_check (result
, "MOD");
2322 gfc_simplify_modulo (gfc_expr
* a
, gfc_expr
* p
)
2325 mpfr_t quot
, iquot
, term
;
2328 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2331 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2332 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2337 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2339 /* Result is processor-dependent. This processor just opts
2340 to not handle it at all. */
2341 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
2342 gfc_free_expr (result
);
2343 return &gfc_bad_expr
;
2345 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2350 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2352 /* Result is processor-dependent. */
2353 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
2354 gfc_free_expr (result
);
2355 return &gfc_bad_expr
;
2358 gfc_set_model_kind (kind
);
2363 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2364 mpfr_floor (iquot
, quot
);
2365 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2366 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2374 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2377 return range_check (result
, "MODULO");
2381 /* Exists for the sole purpose of consistency with other intrinsics. */
2383 gfc_simplify_mvbits (gfc_expr
* f ATTRIBUTE_UNUSED
,
2384 gfc_expr
* fp ATTRIBUTE_UNUSED
,
2385 gfc_expr
* l ATTRIBUTE_UNUSED
,
2386 gfc_expr
* to ATTRIBUTE_UNUSED
,
2387 gfc_expr
* tp ATTRIBUTE_UNUSED
)
2394 gfc_simplify_nearest (gfc_expr
* x
, gfc_expr
* s
)
2400 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
2403 gfc_set_model_kind (x
->ts
.kind
);
2404 result
= gfc_copy_expr (x
);
2406 direction
= mpfr_sgn (s
->value
.real
);
2410 gfc_error ("Second argument of NEAREST at %L may not be zero",
2413 return &gfc_bad_expr
;
2416 /* TODO: Use mpfr_nextabove and mpfr_nextbelow once we move to a
2417 newer version of mpfr. */
2419 sgn
= mpfr_sgn (x
->value
.real
);
2423 int k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
2426 mpfr_add (result
->value
.real
,
2427 x
->value
.real
, gfc_real_kinds
[k
].subnormal
, GFC_RND_MODE
);
2429 mpfr_sub (result
->value
.real
,
2430 x
->value
.real
, gfc_real_kinds
[k
].subnormal
, GFC_RND_MODE
);
2436 direction
= -direction
;
2437 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
2441 mpfr_add_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2444 /* In this case the exponent can shrink, which makes us skip
2445 over one number because we subtract one ulp with the
2446 larger exponent. Thus we need to compensate for this. */
2447 mpfr_init_set (tmp
, result
->value
.real
, GFC_RND_MODE
);
2449 mpfr_sub_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2450 mpfr_add_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2452 /* If we're back to where we started, the spacing is one
2453 ulp, and we get the correct result by subtracting. */
2454 if (mpfr_cmp (tmp
, result
->value
.real
) == 0)
2455 mpfr_sub_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2461 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
2464 return range_check (result
, "NEAREST");
2469 simplify_nint (const char *name
, gfc_expr
* e
, gfc_expr
* k
)
2471 gfc_expr
*itrunc
, *result
;
2474 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
2476 return &gfc_bad_expr
;
2478 if (e
->expr_type
!= EXPR_CONSTANT
)
2481 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
2483 itrunc
= gfc_copy_expr (e
);
2485 mpfr_round(itrunc
->value
.real
, e
->value
.real
);
2487 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
);
2489 gfc_free_expr (itrunc
);
2491 return range_check (result
, name
);
2496 gfc_simplify_nint (gfc_expr
* e
, gfc_expr
* k
)
2498 return simplify_nint ("NINT", e
, k
);
2503 gfc_simplify_idnint (gfc_expr
* e
)
2505 return simplify_nint ("IDNINT", e
, NULL
);
2510 gfc_simplify_not (gfc_expr
* e
)
2515 if (e
->expr_type
!= EXPR_CONSTANT
)
2518 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2520 mpz_com (result
->value
.integer
, e
->value
.integer
);
2522 /* Because of how GMP handles numbers, the result must be ANDed with
2523 the max_int mask. For radices <> 2, this will require change. */
2525 i
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
2527 mpz_and (result
->value
.integer
, result
->value
.integer
,
2528 gfc_integer_kinds
[i
].max_int
);
2530 twos_complement (result
->value
.integer
, gfc_integer_kinds
[i
].bit_size
);
2532 return range_check (result
, "NOT");
2537 gfc_simplify_null (gfc_expr
* mold
)
2543 result
= gfc_get_expr ();
2544 result
->ts
.type
= BT_UNKNOWN
;
2547 result
= gfc_copy_expr (mold
);
2548 result
->expr_type
= EXPR_NULL
;
2555 gfc_simplify_or (gfc_expr
* x
, gfc_expr
* y
)
2560 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2563 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2564 if (x
->ts
.type
== BT_INTEGER
)
2566 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
2567 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2569 else /* BT_LOGICAL */
2571 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
2572 result
->value
.logical
= x
->value
.logical
|| y
->value
.logical
;
2575 return range_check (result
, "OR");
2580 gfc_simplify_precision (gfc_expr
* e
)
2585 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2587 result
= gfc_int_expr (gfc_real_kinds
[i
].precision
);
2588 result
->where
= e
->where
;
2595 gfc_simplify_radix (gfc_expr
* e
)
2600 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2604 i
= gfc_integer_kinds
[i
].radix
;
2608 i
= gfc_real_kinds
[i
].radix
;
2615 result
= gfc_int_expr (i
);
2616 result
->where
= e
->where
;
2623 gfc_simplify_range (gfc_expr
* e
)
2629 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2634 j
= gfc_integer_kinds
[i
].range
;
2639 j
= gfc_real_kinds
[i
].range
;
2646 result
= gfc_int_expr (j
);
2647 result
->where
= e
->where
;
2654 gfc_simplify_real (gfc_expr
* e
, gfc_expr
* k
)
2659 if (e
->ts
.type
== BT_COMPLEX
)
2660 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
2662 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
2665 return &gfc_bad_expr
;
2667 if (e
->expr_type
!= EXPR_CONSTANT
)
2673 result
= gfc_int2real (e
, kind
);
2677 result
= gfc_real2real (e
, kind
);
2681 result
= gfc_complex2real (e
, kind
);
2685 gfc_internal_error ("bad type in REAL");
2689 return range_check (result
, "REAL");
2694 gfc_simplify_realpart (gfc_expr
* e
)
2698 if (e
->expr_type
!= EXPR_CONSTANT
)
2701 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
2702 mpfr_set (result
->value
.real
, e
->value
.complex.r
, GFC_RND_MODE
);
2704 return range_check (result
, "REALPART");
2708 gfc_simplify_repeat (gfc_expr
* e
, gfc_expr
* n
)
2711 int i
, j
, len
, ncopies
, nlen
;
2713 if (e
->expr_type
!= EXPR_CONSTANT
|| n
->expr_type
!= EXPR_CONSTANT
)
2716 if (n
!= NULL
&& (gfc_extract_int (n
, &ncopies
) != NULL
|| ncopies
< 0))
2718 gfc_error ("Invalid second argument of REPEAT at %L", &n
->where
);
2719 return &gfc_bad_expr
;
2722 len
= e
->value
.character
.length
;
2723 nlen
= ncopies
* len
;
2725 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
2729 result
->value
.character
.string
= gfc_getmem (1);
2730 result
->value
.character
.length
= 0;
2731 result
->value
.character
.string
[0] = '\0';
2735 result
->value
.character
.length
= nlen
;
2736 result
->value
.character
.string
= gfc_getmem (nlen
+ 1);
2738 for (i
= 0; i
< ncopies
; i
++)
2739 for (j
= 0; j
< len
; j
++)
2740 result
->value
.character
.string
[j
+ i
* len
] =
2741 e
->value
.character
.string
[j
];
2743 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
2748 /* This one is a bear, but mainly has to do with shuffling elements. */
2751 gfc_simplify_reshape (gfc_expr
* source
, gfc_expr
* shape_exp
,
2752 gfc_expr
* pad
, gfc_expr
* order_exp
)
2755 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
2756 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
2757 gfc_constructor
*head
, *tail
;
2763 /* Unpack the shape array. */
2764 if (source
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (source
))
2767 if (shape_exp
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (shape_exp
))
2771 && (pad
->expr_type
!= EXPR_ARRAY
2772 || !gfc_is_constant_expr (pad
)))
2775 if (order_exp
!= NULL
2776 && (order_exp
->expr_type
!= EXPR_ARRAY
2777 || !gfc_is_constant_expr (order_exp
)))
2786 e
= gfc_get_array_element (shape_exp
, rank
);
2790 if (gfc_extract_int (e
, &shape
[rank
]) != NULL
)
2792 gfc_error ("Integer too large in shape specification at %L",
2800 if (rank
>= GFC_MAX_DIMENSIONS
)
2802 gfc_error ("Too many dimensions in shape specification for RESHAPE "
2803 "at %L", &e
->where
);
2808 if (shape
[rank
] < 0)
2810 gfc_error ("Shape specification at %L cannot be negative",
2820 gfc_error ("Shape specification at %L cannot be the null array",
2825 /* Now unpack the order array if present. */
2826 if (order_exp
== NULL
)
2828 for (i
= 0; i
< rank
; i
++)
2835 for (i
= 0; i
< rank
; i
++)
2838 for (i
= 0; i
< rank
; i
++)
2840 e
= gfc_get_array_element (order_exp
, i
);
2844 ("ORDER parameter of RESHAPE at %L is not the same size "
2845 "as SHAPE parameter", &order_exp
->where
);
2849 if (gfc_extract_int (e
, &order
[i
]) != NULL
)
2851 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
2859 if (order
[i
] < 1 || order
[i
] > rank
)
2861 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
2870 gfc_error ("Invalid permutation in ORDER parameter at %L",
2879 /* Count the elements in the source and padding arrays. */
2884 gfc_array_size (pad
, &size
);
2885 npad
= mpz_get_ui (size
);
2889 gfc_array_size (source
, &size
);
2890 nsource
= mpz_get_ui (size
);
2893 /* If it weren't for that pesky permutation we could just loop
2894 through the source and round out any shortage with pad elements.
2895 But no, someone just had to have the compiler do something the
2896 user should be doing. */
2898 for (i
= 0; i
< rank
; i
++)
2903 /* Figure out which element to extract. */
2904 mpz_set_ui (index
, 0);
2906 for (i
= rank
- 1; i
>= 0; i
--)
2908 mpz_add_ui (index
, index
, x
[order
[i
]]);
2910 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
2913 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
2914 gfc_internal_error ("Reshaped array too large at %L", &e
->where
);
2916 j
= mpz_get_ui (index
);
2919 e
= gfc_get_array_element (source
, j
);
2927 ("PAD parameter required for short SOURCE parameter at %L",
2933 e
= gfc_get_array_element (pad
, j
);
2937 head
= tail
= gfc_get_constructor ();
2940 tail
->next
= gfc_get_constructor ();
2947 tail
->where
= e
->where
;
2950 /* Calculate the next element. */
2954 if (++x
[i
] < shape
[i
])
2965 e
= gfc_get_expr ();
2966 e
->where
= source
->where
;
2967 e
->expr_type
= EXPR_ARRAY
;
2968 e
->value
.constructor
= head
;
2969 e
->shape
= gfc_get_shape (rank
);
2971 for (i
= 0; i
< rank
; i
++)
2972 mpz_init_set_ui (e
->shape
[i
], shape
[i
]);
2980 gfc_free_constructor (head
);
2982 return &gfc_bad_expr
;
2987 gfc_simplify_rrspacing (gfc_expr
* x
)
2990 mpfr_t absv
, log2
, exp
, frac
, pow2
;
2993 if (x
->expr_type
!= EXPR_CONSTANT
)
2996 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2998 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3000 p
= gfc_real_kinds
[i
].digits
;
3002 gfc_set_model_kind (x
->ts
.kind
);
3004 if (mpfr_sgn (x
->value
.real
) == 0)
3006 mpfr_ui_div (result
->value
.real
, 1, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3015 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3016 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3018 mpfr_trunc (log2
, log2
);
3019 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
3021 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3022 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
3024 mpfr_mul_2exp (result
->value
.real
, frac
, (unsigned long)p
, GFC_RND_MODE
);
3031 return range_check (result
, "RRSPACING");
3036 gfc_simplify_scale (gfc_expr
* x
, gfc_expr
* i
)
3038 int k
, neg_flag
, power
, exp_range
;
3039 mpfr_t scale
, radix
;
3042 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3045 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3047 if (mpfr_sgn (x
->value
.real
) == 0)
3049 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3053 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3055 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
3057 /* This check filters out values of i that would overflow an int. */
3058 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
3059 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
3061 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
3062 return &gfc_bad_expr
;
3065 /* Compute scale = radix ** power. */
3066 power
= mpz_get_si (i
->value
.integer
);
3076 gfc_set_model_kind (x
->ts
.kind
);
3079 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
3080 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
3083 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3085 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3090 return range_check (result
, "SCALE");
3095 gfc_simplify_scan (gfc_expr
* e
, gfc_expr
* c
, gfc_expr
* b
)
3100 size_t indx
, len
, lenc
;
3102 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
)
3105 if (b
!= NULL
&& b
->value
.logical
!= 0)
3110 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3113 len
= e
->value
.character
.length
;
3114 lenc
= c
->value
.character
.length
;
3116 if (len
== 0 || lenc
== 0)
3125 strcspn (e
->value
.character
.string
, c
->value
.character
.string
) + 1;
3132 for (indx
= len
; indx
> 0; indx
--)
3134 for (i
= 0; i
< lenc
; i
++)
3136 if (c
->value
.character
.string
[i
]
3137 == e
->value
.character
.string
[indx
- 1])
3145 mpz_set_ui (result
->value
.integer
, indx
);
3146 return range_check (result
, "SCAN");
3151 gfc_simplify_selected_int_kind (gfc_expr
* e
)
3156 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
3161 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
3162 if (gfc_integer_kinds
[i
].range
>= range
3163 && gfc_integer_kinds
[i
].kind
< kind
)
3164 kind
= gfc_integer_kinds
[i
].kind
;
3166 if (kind
== INT_MAX
)
3169 result
= gfc_int_expr (kind
);
3170 result
->where
= e
->where
;
3177 gfc_simplify_selected_real_kind (gfc_expr
* p
, gfc_expr
* q
)
3179 int range
, precision
, i
, kind
, found_precision
, found_range
;
3186 if (p
->expr_type
!= EXPR_CONSTANT
3187 || gfc_extract_int (p
, &precision
) != NULL
)
3195 if (q
->expr_type
!= EXPR_CONSTANT
3196 || gfc_extract_int (q
, &range
) != NULL
)
3201 found_precision
= 0;
3204 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
3206 if (gfc_real_kinds
[i
].precision
>= precision
)
3207 found_precision
= 1;
3209 if (gfc_real_kinds
[i
].range
>= range
)
3212 if (gfc_real_kinds
[i
].precision
>= precision
3213 && gfc_real_kinds
[i
].range
>= range
&& gfc_real_kinds
[i
].kind
< kind
)
3214 kind
= gfc_real_kinds
[i
].kind
;
3217 if (kind
== INT_MAX
)
3221 if (!found_precision
)
3227 result
= gfc_int_expr (kind
);
3228 result
->where
= (p
!= NULL
) ? p
->where
: q
->where
;
3235 gfc_simplify_set_exponent (gfc_expr
* x
, gfc_expr
* i
)
3238 mpfr_t exp
, absv
, log2
, pow2
, frac
;
3241 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3244 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3246 gfc_set_model_kind (x
->ts
.kind
);
3248 if (mpfr_sgn (x
->value
.real
) == 0)
3250 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3260 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3261 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3263 mpfr_trunc (log2
, log2
);
3264 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
3266 /* Old exponent value, and fraction. */
3267 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3269 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
3272 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
3273 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
3280 return range_check (result
, "SET_EXPONENT");
3285 gfc_simplify_shape (gfc_expr
* source
)
3287 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3288 gfc_expr
*result
, *e
, *f
;
3293 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3296 result
= gfc_start_constructor (BT_INTEGER
, gfc_default_integer_kind
,
3299 ar
= gfc_find_array_ref (source
);
3301 t
= gfc_array_ref_shape (ar
, shape
);
3303 for (n
= 0; n
< source
->rank
; n
++)
3305 e
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3310 mpz_set (e
->value
.integer
, shape
[n
]);
3311 mpz_clear (shape
[n
]);
3315 mpz_set_ui (e
->value
.integer
, n
+ 1);
3317 f
= gfc_simplify_size (source
, e
);
3321 gfc_free_expr (result
);
3330 gfc_append_constructor (result
, e
);
3338 gfc_simplify_size (gfc_expr
* array
, gfc_expr
* dim
)
3346 if (gfc_array_size (array
, &size
) == FAILURE
)
3351 if (dim
->expr_type
!= EXPR_CONSTANT
)
3354 d
= mpz_get_ui (dim
->value
.integer
) - 1;
3355 if (gfc_array_dimen_size (array
, d
, &size
) == FAILURE
)
3359 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3362 mpz_set (result
->value
.integer
, size
);
3369 gfc_simplify_sign (gfc_expr
* x
, gfc_expr
* y
)
3373 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3376 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3381 mpz_abs (result
->value
.integer
, x
->value
.integer
);
3382 if (mpz_sgn (y
->value
.integer
) < 0)
3383 mpz_neg (result
->value
.integer
, result
->value
.integer
);
3388 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3390 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3391 if (mpfr_sgn (y
->value
.real
) < 0)
3392 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
3397 gfc_internal_error ("Bad type in gfc_simplify_sign");
3405 gfc_simplify_sin (gfc_expr
* x
)
3410 if (x
->expr_type
!= EXPR_CONSTANT
)
3413 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3418 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3422 gfc_set_model (x
->value
.real
);
3426 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3427 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3428 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
3430 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3431 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3432 mpfr_mul (result
->value
.complex.i
, xp
, xq
, GFC_RND_MODE
);
3439 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3442 return range_check (result
, "SIN");
3447 gfc_simplify_sinh (gfc_expr
* x
)
3451 if (x
->expr_type
!= EXPR_CONSTANT
)
3454 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3456 mpfr_sinh(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3458 return range_check (result
, "SINH");
3462 /* The argument is always a double precision real that is converted to
3463 single precision. TODO: Rounding! */
3466 gfc_simplify_sngl (gfc_expr
* a
)
3470 if (a
->expr_type
!= EXPR_CONSTANT
)
3473 result
= gfc_real2real (a
, gfc_default_real_kind
);
3474 return range_check (result
, "SNGL");
3479 gfc_simplify_spacing (gfc_expr
* x
)
3486 if (x
->expr_type
!= EXPR_CONSTANT
)
3489 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3491 p
= gfc_real_kinds
[i
].digits
;
3493 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3495 gfc_set_model_kind (x
->ts
.kind
);
3497 if (mpfr_sgn (x
->value
.real
) == 0)
3499 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3506 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3507 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3508 mpfr_trunc (log2
, log2
);
3510 mpfr_add_ui (log2
, log2
, 1, GFC_RND_MODE
);
3512 /* FIXME: We should be using mpfr_get_si here, but this function is
3513 not available with the version of mpfr distributed with gmp (as of
3514 2004-09-17). Replace once mpfr has been imported into the gcc cvs
3516 diff
= (long)mpfr_get_d (log2
, GFC_RND_MODE
) - (long)p
;
3517 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
3518 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, diff
, GFC_RND_MODE
);
3523 if (mpfr_cmp (result
->value
.real
, gfc_real_kinds
[i
].tiny
) < 0)
3524 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3526 return range_check (result
, "SPACING");
3531 gfc_simplify_sqrt (gfc_expr
* e
)
3534 mpfr_t ac
, ad
, s
, t
, w
;
3536 if (e
->expr_type
!= EXPR_CONSTANT
)
3539 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3544 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
3546 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
3551 /* Formula taken from Numerical Recipes to avoid over- and
3554 gfc_set_model (e
->value
.real
);
3561 if (mpfr_cmp_ui (e
->value
.complex.r
, 0) == 0
3562 && mpfr_cmp_ui (e
->value
.complex.i
, 0) == 0)
3565 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
3566 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
3570 mpfr_abs (ac
, e
->value
.complex.r
, GFC_RND_MODE
);
3571 mpfr_abs (ad
, e
->value
.complex.i
, GFC_RND_MODE
);
3573 if (mpfr_cmp (ac
, ad
) >= 0)
3575 mpfr_div (t
, e
->value
.complex.i
, e
->value
.complex.r
, GFC_RND_MODE
);
3576 mpfr_mul (t
, t
, t
, GFC_RND_MODE
);
3577 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3578 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3579 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3580 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3581 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3582 mpfr_sqrt (s
, ac
, GFC_RND_MODE
);
3583 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3587 mpfr_div (s
, e
->value
.complex.r
, e
->value
.complex.i
, GFC_RND_MODE
);
3588 mpfr_mul (t
, s
, s
, GFC_RND_MODE
);
3589 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3590 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3591 mpfr_abs (s
, s
, GFC_RND_MODE
);
3592 mpfr_add (t
, t
, s
, GFC_RND_MODE
);
3593 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3594 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3595 mpfr_sqrt (s
, ad
, GFC_RND_MODE
);
3596 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3599 if (mpfr_cmp_ui (w
, 0) != 0 && mpfr_cmp_ui (e
->value
.complex.r
, 0) >= 0)
3601 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3602 mpfr_div (result
->value
.complex.i
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3603 mpfr_set (result
->value
.complex.r
, w
, GFC_RND_MODE
);
3605 else if (mpfr_cmp_ui (w
, 0) != 0
3606 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3607 && mpfr_cmp_ui (e
->value
.complex.i
, 0) >= 0)
3609 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3610 mpfr_div (result
->value
.complex.r
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3611 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3613 else if (mpfr_cmp_ui (w
, 0) != 0
3614 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3615 && mpfr_cmp_ui (e
->value
.complex.i
, 0) < 0)
3617 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3618 mpfr_div (result
->value
.complex.r
, ad
, t
, GFC_RND_MODE
);
3619 mpfr_neg (w
, w
, GFC_RND_MODE
);
3620 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3623 gfc_internal_error ("invalid complex argument of SQRT at %L",
3635 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
3638 return range_check (result
, "SQRT");
3641 gfc_free_expr (result
);
3642 gfc_error ("Argument of SQRT at %L has a negative value", &e
->where
);
3643 return &gfc_bad_expr
;
3648 gfc_simplify_tan (gfc_expr
* x
)
3653 if (x
->expr_type
!= EXPR_CONSTANT
)
3656 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3658 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3660 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3662 return range_check (result
, "TAN");
3667 gfc_simplify_tanh (gfc_expr
* x
)
3671 if (x
->expr_type
!= EXPR_CONSTANT
)
3674 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3676 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3678 return range_check (result
, "TANH");
3684 gfc_simplify_tiny (gfc_expr
* e
)
3689 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
3691 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
3692 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3699 gfc_simplify_trim (gfc_expr
* e
)
3702 int count
, i
, len
, lentrim
;
3704 if (e
->expr_type
!= EXPR_CONSTANT
)
3707 len
= e
->value
.character
.length
;
3709 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
3711 for (count
= 0, i
= 1; i
<= len
; ++i
)
3713 if (e
->value
.character
.string
[len
- i
] == ' ')
3719 lentrim
= len
- count
;
3721 result
->value
.character
.length
= lentrim
;
3722 result
->value
.character
.string
= gfc_getmem (lentrim
+ 1);
3724 for (i
= 0; i
< lentrim
; i
++)
3725 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
3727 result
->value
.character
.string
[lentrim
] = '\0'; /* For debugger */
3734 gfc_simplify_ubound (gfc_expr
* array
, gfc_expr
* dim
)
3736 return simplify_bound (array
, dim
, 1);
3741 gfc_simplify_verify (gfc_expr
* s
, gfc_expr
* set
, gfc_expr
* b
)
3745 size_t index
, len
, lenset
;
3748 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
)
3751 if (b
!= NULL
&& b
->value
.logical
!= 0)
3756 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3759 len
= s
->value
.character
.length
;
3760 lenset
= set
->value
.character
.length
;
3764 mpz_set_ui (result
->value
.integer
, 0);
3772 mpz_set_ui (result
->value
.integer
, 1);
3777 strspn (s
->value
.character
.string
, set
->value
.character
.string
) + 1;
3786 mpz_set_ui (result
->value
.integer
, len
);
3789 for (index
= len
; index
> 0; index
--)
3791 for (i
= 0; i
< lenset
; i
++)
3793 if (s
->value
.character
.string
[index
- 1]
3794 == set
->value
.character
.string
[i
])
3802 mpz_set_ui (result
->value
.integer
, index
);
3808 gfc_simplify_xor (gfc_expr
* x
, gfc_expr
* y
)
3813 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3816 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
3817 if (x
->ts
.type
== BT_INTEGER
)
3819 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
3820 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3822 else /* BT_LOGICAL */
3824 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
3825 result
->value
.logical
= (x
->value
.logical
&& ! y
->value
.logical
)
3826 || (! x
->value
.logical
&& y
->value
.logical
);
3829 return range_check (result
, "XOR");
3834 /****************** Constant simplification *****************/
3836 /* Master function to convert one constant to another. While this is
3837 used as a simplification function, it requires the destination type
3838 and kind information which is supplied by a special case in
3842 gfc_convert_constant (gfc_expr
* e
, bt type
, int kind
)
3844 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
3845 gfc_constructor
*head
, *c
, *tail
= NULL
;
3859 f
= gfc_int2complex
;
3879 f
= gfc_real2complex
;
3890 f
= gfc_complex2int
;
3893 f
= gfc_complex2real
;
3896 f
= gfc_complex2complex
;
3922 f
= gfc_hollerith2int
;
3926 f
= gfc_hollerith2real
;
3930 f
= gfc_hollerith2complex
;
3934 f
= gfc_hollerith2character
;
3938 f
= gfc_hollerith2logical
;
3948 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
3953 switch (e
->expr_type
)
3956 result
= f (e
, kind
);
3958 return &gfc_bad_expr
;
3962 if (!gfc_is_constant_expr (e
))
3967 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
3970 head
= tail
= gfc_get_constructor ();
3973 tail
->next
= gfc_get_constructor ();
3977 tail
->where
= c
->where
;
3979 if (c
->iterator
== NULL
)
3980 tail
->expr
= f (c
->expr
, kind
);
3983 g
= gfc_convert_constant (c
->expr
, type
, kind
);
3984 if (g
== &gfc_bad_expr
)
3989 if (tail
->expr
== NULL
)
3991 gfc_free_constructor (head
);
3996 result
= gfc_get_expr ();
3997 result
->ts
.type
= type
;
3998 result
->ts
.kind
= kind
;
3999 result
->expr_type
= EXPR_ARRAY
;
4000 result
->value
.constructor
= head
;
4001 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4002 result
->where
= e
->where
;
4003 result
->rank
= e
->rank
;
4014 /****************** Helper functions ***********************/
4016 /* Given a collating table, create the inverse table. */
4019 invert_table (const int *table
, int *xtable
)
4023 for (i
= 0; i
< 256; i
++)
4026 for (i
= 0; i
< 256; i
++)
4027 xtable
[table
[i
]] = i
;
4032 gfc_simplify_init_1 (void)
4035 invert_table (ascii_table
, xascii_table
);