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
)
1936 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1939 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
1940 return range_check (result
, "LEN");
1945 gfc_simplify_len_trim (gfc_expr
* e
)
1948 int count
, len
, lentrim
, i
;
1950 if (e
->expr_type
!= EXPR_CONSTANT
)
1953 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1956 len
= e
->value
.character
.length
;
1958 for (count
= 0, i
= 1; i
<= len
; i
++)
1959 if (e
->value
.character
.string
[len
- i
] == ' ')
1964 lentrim
= len
- count
;
1966 mpz_set_si (result
->value
.integer
, lentrim
);
1967 return range_check (result
, "LEN_TRIM");
1972 gfc_simplify_lge (gfc_expr
* a
, gfc_expr
* b
)
1975 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1978 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) >= 0,
1984 gfc_simplify_lgt (gfc_expr
* a
, gfc_expr
* b
)
1987 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1990 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) > 0,
1996 gfc_simplify_lle (gfc_expr
* a
, gfc_expr
* b
)
1999 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2002 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) <= 0,
2008 gfc_simplify_llt (gfc_expr
* a
, gfc_expr
* b
)
2011 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2014 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) < 0,
2020 gfc_simplify_log (gfc_expr
* x
)
2025 if (x
->expr_type
!= EXPR_CONSTANT
)
2028 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2030 gfc_set_model_kind (x
->ts
.kind
);
2035 if (mpfr_sgn (x
->value
.real
) <= 0)
2038 ("Argument of LOG at %L cannot be less than or equal to zero",
2040 gfc_free_expr (result
);
2041 return &gfc_bad_expr
;
2044 mpfr_log(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2048 if ((mpfr_sgn (x
->value
.complex.r
) == 0)
2049 && (mpfr_sgn (x
->value
.complex.i
) == 0))
2051 gfc_error ("Complex argument of LOG at %L cannot be zero",
2053 gfc_free_expr (result
);
2054 return &gfc_bad_expr
;
2060 arctangent2 (x
->value
.complex.i
, x
->value
.complex.r
,
2061 result
->value
.complex.i
);
2063 mpfr_mul (xr
, x
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
2064 mpfr_mul (xi
, x
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
2065 mpfr_add (xr
, xr
, xi
, GFC_RND_MODE
);
2066 mpfr_sqrt (xr
, xr
, GFC_RND_MODE
);
2067 mpfr_log (result
->value
.complex.r
, xr
, GFC_RND_MODE
);
2075 gfc_internal_error ("gfc_simplify_log: bad type");
2078 return range_check (result
, "LOG");
2083 gfc_simplify_log10 (gfc_expr
* x
)
2087 if (x
->expr_type
!= EXPR_CONSTANT
)
2090 gfc_set_model_kind (x
->ts
.kind
);
2092 if (mpfr_sgn (x
->value
.real
) <= 0)
2095 ("Argument of LOG10 at %L cannot be less than or equal to zero",
2097 return &gfc_bad_expr
;
2100 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2102 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2104 return range_check (result
, "LOG10");
2109 gfc_simplify_logical (gfc_expr
* e
, gfc_expr
* k
)
2114 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
2116 return &gfc_bad_expr
;
2118 if (e
->expr_type
!= EXPR_CONSTANT
)
2121 result
= gfc_constant_result (BT_LOGICAL
, kind
, &e
->where
);
2123 result
->value
.logical
= e
->value
.logical
;
2129 /* This function is special since MAX() can take any number of
2130 arguments. The simplified expression is a rewritten version of the
2131 argument list containing at most one constant element. Other
2132 constant elements are deleted. Because the argument list has
2133 already been checked, this function always succeeds. sign is 1 for
2134 MAX(), -1 for MIN(). */
2137 simplify_min_max (gfc_expr
* expr
, int sign
)
2139 gfc_actual_arglist
*arg
, *last
, *extremum
;
2140 gfc_intrinsic_sym
* specific
;
2144 specific
= expr
->value
.function
.isym
;
2146 arg
= expr
->value
.function
.actual
;
2148 for (; arg
; last
= arg
, arg
= arg
->next
)
2150 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
2153 if (extremum
== NULL
)
2159 switch (arg
->expr
->ts
.type
)
2162 if (mpz_cmp (arg
->expr
->value
.integer
,
2163 extremum
->expr
->value
.integer
) * sign
> 0)
2164 mpz_set (extremum
->expr
->value
.integer
, arg
->expr
->value
.integer
);
2169 if (mpfr_cmp (arg
->expr
->value
.real
, extremum
->expr
->value
.real
) *
2171 mpfr_set (extremum
->expr
->value
.real
, arg
->expr
->value
.real
,
2177 gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
2180 /* Delete the extra constant argument. */
2182 expr
->value
.function
.actual
= arg
->next
;
2184 last
->next
= arg
->next
;
2187 gfc_free_actual_arglist (arg
);
2191 /* If there is one value left, replace the function call with the
2193 if (expr
->value
.function
.actual
->next
!= NULL
)
2196 /* Convert to the correct type and kind. */
2197 if (expr
->ts
.type
!= BT_UNKNOWN
)
2198 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2199 expr
->ts
.type
, expr
->ts
.kind
);
2201 if (specific
->ts
.type
!= BT_UNKNOWN
)
2202 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2203 specific
->ts
.type
, specific
->ts
.kind
);
2205 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
2210 gfc_simplify_min (gfc_expr
* e
)
2212 return simplify_min_max (e
, -1);
2217 gfc_simplify_max (gfc_expr
* e
)
2219 return simplify_min_max (e
, 1);
2224 gfc_simplify_maxexponent (gfc_expr
* x
)
2229 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2231 result
= gfc_int_expr (gfc_real_kinds
[i
].max_exponent
);
2232 result
->where
= x
->where
;
2239 gfc_simplify_minexponent (gfc_expr
* x
)
2244 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2246 result
= gfc_int_expr (gfc_real_kinds
[i
].min_exponent
);
2247 result
->where
= x
->where
;
2254 gfc_simplify_mod (gfc_expr
* a
, gfc_expr
* p
)
2257 mpfr_t quot
, iquot
, term
;
2260 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2263 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2264 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2269 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2271 /* Result is processor-dependent. */
2272 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
2273 gfc_free_expr (result
);
2274 return &gfc_bad_expr
;
2276 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2280 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2282 /* Result is processor-dependent. */
2283 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
2284 gfc_free_expr (result
);
2285 return &gfc_bad_expr
;
2288 gfc_set_model_kind (kind
);
2293 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2294 mpfr_trunc (iquot
, quot
);
2295 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2296 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2304 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2307 return range_check (result
, "MOD");
2312 gfc_simplify_modulo (gfc_expr
* a
, gfc_expr
* p
)
2315 mpfr_t quot
, iquot
, term
;
2318 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2321 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2322 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2327 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2329 /* Result is processor-dependent. This processor just opts
2330 to not handle it at all. */
2331 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
2332 gfc_free_expr (result
);
2333 return &gfc_bad_expr
;
2335 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2340 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2342 /* Result is processor-dependent. */
2343 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
2344 gfc_free_expr (result
);
2345 return &gfc_bad_expr
;
2348 gfc_set_model_kind (kind
);
2353 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2354 mpfr_floor (iquot
, quot
);
2355 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2356 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2364 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2367 return range_check (result
, "MODULO");
2371 /* Exists for the sole purpose of consistency with other intrinsics. */
2373 gfc_simplify_mvbits (gfc_expr
* f ATTRIBUTE_UNUSED
,
2374 gfc_expr
* fp ATTRIBUTE_UNUSED
,
2375 gfc_expr
* l ATTRIBUTE_UNUSED
,
2376 gfc_expr
* to ATTRIBUTE_UNUSED
,
2377 gfc_expr
* tp ATTRIBUTE_UNUSED
)
2384 gfc_simplify_nearest (gfc_expr
* x
, gfc_expr
* s
)
2390 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
2393 gfc_set_model_kind (x
->ts
.kind
);
2394 result
= gfc_copy_expr (x
);
2396 direction
= mpfr_sgn (s
->value
.real
);
2400 gfc_error ("Second argument of NEAREST at %L may not be zero",
2403 return &gfc_bad_expr
;
2406 /* TODO: Use mpfr_nextabove and mpfr_nextbelow once we move to a
2407 newer version of mpfr. */
2409 sgn
= mpfr_sgn (x
->value
.real
);
2413 int k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
2416 mpfr_add (result
->value
.real
,
2417 x
->value
.real
, gfc_real_kinds
[k
].subnormal
, GFC_RND_MODE
);
2419 mpfr_sub (result
->value
.real
,
2420 x
->value
.real
, gfc_real_kinds
[k
].subnormal
, GFC_RND_MODE
);
2426 direction
= -direction
;
2427 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
2431 mpfr_add_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2434 /* In this case the exponent can shrink, which makes us skip
2435 over one number because we subtract one ulp with the
2436 larger exponent. Thus we need to compensate for this. */
2437 mpfr_init_set (tmp
, result
->value
.real
, GFC_RND_MODE
);
2439 mpfr_sub_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2440 mpfr_add_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2442 /* If we're back to where we started, the spacing is one
2443 ulp, and we get the correct result by subtracting. */
2444 if (mpfr_cmp (tmp
, result
->value
.real
) == 0)
2445 mpfr_sub_one_ulp (result
->value
.real
, GFC_RND_MODE
);
2451 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
2454 return range_check (result
, "NEAREST");
2459 simplify_nint (const char *name
, gfc_expr
* e
, gfc_expr
* k
)
2461 gfc_expr
*itrunc
, *result
;
2464 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
2466 return &gfc_bad_expr
;
2468 if (e
->expr_type
!= EXPR_CONSTANT
)
2471 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
2473 itrunc
= gfc_copy_expr (e
);
2475 mpfr_round(itrunc
->value
.real
, e
->value
.real
);
2477 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
);
2479 gfc_free_expr (itrunc
);
2481 return range_check (result
, name
);
2486 gfc_simplify_nint (gfc_expr
* e
, gfc_expr
* k
)
2488 return simplify_nint ("NINT", e
, k
);
2493 gfc_simplify_idnint (gfc_expr
* e
)
2495 return simplify_nint ("IDNINT", e
, NULL
);
2500 gfc_simplify_not (gfc_expr
* e
)
2505 if (e
->expr_type
!= EXPR_CONSTANT
)
2508 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2510 mpz_com (result
->value
.integer
, e
->value
.integer
);
2512 /* Because of how GMP handles numbers, the result must be ANDed with
2513 the max_int mask. For radices <> 2, this will require change. */
2515 i
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
2517 mpz_and (result
->value
.integer
, result
->value
.integer
,
2518 gfc_integer_kinds
[i
].max_int
);
2520 twos_complement (result
->value
.integer
, gfc_integer_kinds
[i
].bit_size
);
2522 return range_check (result
, "NOT");
2527 gfc_simplify_null (gfc_expr
* mold
)
2533 result
= gfc_get_expr ();
2534 result
->ts
.type
= BT_UNKNOWN
;
2537 result
= gfc_copy_expr (mold
);
2538 result
->expr_type
= EXPR_NULL
;
2545 gfc_simplify_or (gfc_expr
* x
, gfc_expr
* y
)
2550 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2553 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2554 if (x
->ts
.type
== BT_INTEGER
)
2556 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
2557 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2559 else /* BT_LOGICAL */
2561 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
2562 result
->value
.logical
= x
->value
.logical
|| y
->value
.logical
;
2565 return range_check (result
, "OR");
2570 gfc_simplify_precision (gfc_expr
* e
)
2575 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2577 result
= gfc_int_expr (gfc_real_kinds
[i
].precision
);
2578 result
->where
= e
->where
;
2585 gfc_simplify_radix (gfc_expr
* e
)
2590 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2594 i
= gfc_integer_kinds
[i
].radix
;
2598 i
= gfc_real_kinds
[i
].radix
;
2605 result
= gfc_int_expr (i
);
2606 result
->where
= e
->where
;
2613 gfc_simplify_range (gfc_expr
* e
)
2619 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2624 j
= gfc_integer_kinds
[i
].range
;
2629 j
= gfc_real_kinds
[i
].range
;
2636 result
= gfc_int_expr (j
);
2637 result
->where
= e
->where
;
2644 gfc_simplify_real (gfc_expr
* e
, gfc_expr
* k
)
2649 if (e
->ts
.type
== BT_COMPLEX
)
2650 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
2652 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
2655 return &gfc_bad_expr
;
2657 if (e
->expr_type
!= EXPR_CONSTANT
)
2663 result
= gfc_int2real (e
, kind
);
2667 result
= gfc_real2real (e
, kind
);
2671 result
= gfc_complex2real (e
, kind
);
2675 gfc_internal_error ("bad type in REAL");
2679 return range_check (result
, "REAL");
2684 gfc_simplify_realpart (gfc_expr
* e
)
2688 if (e
->expr_type
!= EXPR_CONSTANT
)
2691 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
2692 mpfr_set (result
->value
.real
, e
->value
.complex.r
, GFC_RND_MODE
);
2694 return range_check (result
, "REALPART");
2698 gfc_simplify_repeat (gfc_expr
* e
, gfc_expr
* n
)
2701 int i
, j
, len
, ncopies
, nlen
;
2703 if (e
->expr_type
!= EXPR_CONSTANT
|| n
->expr_type
!= EXPR_CONSTANT
)
2706 if (n
!= NULL
&& (gfc_extract_int (n
, &ncopies
) != NULL
|| ncopies
< 0))
2708 gfc_error ("Invalid second argument of REPEAT at %L", &n
->where
);
2709 return &gfc_bad_expr
;
2712 len
= e
->value
.character
.length
;
2713 nlen
= ncopies
* len
;
2715 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
2719 result
->value
.character
.string
= gfc_getmem (1);
2720 result
->value
.character
.length
= 0;
2721 result
->value
.character
.string
[0] = '\0';
2725 result
->value
.character
.length
= nlen
;
2726 result
->value
.character
.string
= gfc_getmem (nlen
+ 1);
2728 for (i
= 0; i
< ncopies
; i
++)
2729 for (j
= 0; j
< len
; j
++)
2730 result
->value
.character
.string
[j
+ i
* len
] =
2731 e
->value
.character
.string
[j
];
2733 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
2738 /* This one is a bear, but mainly has to do with shuffling elements. */
2741 gfc_simplify_reshape (gfc_expr
* source
, gfc_expr
* shape_exp
,
2742 gfc_expr
* pad
, gfc_expr
* order_exp
)
2745 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
2746 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
2747 gfc_constructor
*head
, *tail
;
2753 /* Unpack the shape array. */
2754 if (source
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (source
))
2757 if (shape_exp
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (shape_exp
))
2761 && (pad
->expr_type
!= EXPR_ARRAY
2762 || !gfc_is_constant_expr (pad
)))
2765 if (order_exp
!= NULL
2766 && (order_exp
->expr_type
!= EXPR_ARRAY
2767 || !gfc_is_constant_expr (order_exp
)))
2776 e
= gfc_get_array_element (shape_exp
, rank
);
2780 if (gfc_extract_int (e
, &shape
[rank
]) != NULL
)
2782 gfc_error ("Integer too large in shape specification at %L",
2790 if (rank
>= GFC_MAX_DIMENSIONS
)
2792 gfc_error ("Too many dimensions in shape specification for RESHAPE "
2793 "at %L", &e
->where
);
2798 if (shape
[rank
] < 0)
2800 gfc_error ("Shape specification at %L cannot be negative",
2810 gfc_error ("Shape specification at %L cannot be the null array",
2815 /* Now unpack the order array if present. */
2816 if (order_exp
== NULL
)
2818 for (i
= 0; i
< rank
; i
++)
2825 for (i
= 0; i
< rank
; i
++)
2828 for (i
= 0; i
< rank
; i
++)
2830 e
= gfc_get_array_element (order_exp
, i
);
2834 ("ORDER parameter of RESHAPE at %L is not the same size "
2835 "as SHAPE parameter", &order_exp
->where
);
2839 if (gfc_extract_int (e
, &order
[i
]) != NULL
)
2841 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
2849 if (order
[i
] < 1 || order
[i
] > rank
)
2851 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
2860 gfc_error ("Invalid permutation in ORDER parameter at %L",
2869 /* Count the elements in the source and padding arrays. */
2874 gfc_array_size (pad
, &size
);
2875 npad
= mpz_get_ui (size
);
2879 gfc_array_size (source
, &size
);
2880 nsource
= mpz_get_ui (size
);
2883 /* If it weren't for that pesky permutation we could just loop
2884 through the source and round out any shortage with pad elements.
2885 But no, someone just had to have the compiler do something the
2886 user should be doing. */
2888 for (i
= 0; i
< rank
; i
++)
2893 /* Figure out which element to extract. */
2894 mpz_set_ui (index
, 0);
2896 for (i
= rank
- 1; i
>= 0; i
--)
2898 mpz_add_ui (index
, index
, x
[order
[i
]]);
2900 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
2903 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
2904 gfc_internal_error ("Reshaped array too large at %L", &e
->where
);
2906 j
= mpz_get_ui (index
);
2909 e
= gfc_get_array_element (source
, j
);
2917 ("PAD parameter required for short SOURCE parameter at %L",
2923 e
= gfc_get_array_element (pad
, j
);
2927 head
= tail
= gfc_get_constructor ();
2930 tail
->next
= gfc_get_constructor ();
2937 tail
->where
= e
->where
;
2940 /* Calculate the next element. */
2944 if (++x
[i
] < shape
[i
])
2955 e
= gfc_get_expr ();
2956 e
->where
= source
->where
;
2957 e
->expr_type
= EXPR_ARRAY
;
2958 e
->value
.constructor
= head
;
2959 e
->shape
= gfc_get_shape (rank
);
2961 for (i
= 0; i
< rank
; i
++)
2962 mpz_init_set_ui (e
->shape
[i
], shape
[i
]);
2970 gfc_free_constructor (head
);
2972 return &gfc_bad_expr
;
2977 gfc_simplify_rrspacing (gfc_expr
* x
)
2980 mpfr_t absv
, log2
, exp
, frac
, pow2
;
2983 if (x
->expr_type
!= EXPR_CONSTANT
)
2986 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2988 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
2990 p
= gfc_real_kinds
[i
].digits
;
2992 gfc_set_model_kind (x
->ts
.kind
);
2994 if (mpfr_sgn (x
->value
.real
) == 0)
2996 mpfr_ui_div (result
->value
.real
, 1, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3005 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3006 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3008 mpfr_trunc (log2
, log2
);
3009 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
3011 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3012 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
3014 mpfr_mul_2exp (result
->value
.real
, frac
, (unsigned long)p
, GFC_RND_MODE
);
3021 return range_check (result
, "RRSPACING");
3026 gfc_simplify_scale (gfc_expr
* x
, gfc_expr
* i
)
3028 int k
, neg_flag
, power
, exp_range
;
3029 mpfr_t scale
, radix
;
3032 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3035 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3037 if (mpfr_sgn (x
->value
.real
) == 0)
3039 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3043 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3045 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
3047 /* This check filters out values of i that would overflow an int. */
3048 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
3049 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
3051 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
3052 return &gfc_bad_expr
;
3055 /* Compute scale = radix ** power. */
3056 power
= mpz_get_si (i
->value
.integer
);
3066 gfc_set_model_kind (x
->ts
.kind
);
3069 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
3070 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
3073 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3075 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3080 return range_check (result
, "SCALE");
3085 gfc_simplify_scan (gfc_expr
* e
, gfc_expr
* c
, gfc_expr
* b
)
3090 size_t indx
, len
, lenc
;
3092 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
)
3095 if (b
!= NULL
&& b
->value
.logical
!= 0)
3100 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3103 len
= e
->value
.character
.length
;
3104 lenc
= c
->value
.character
.length
;
3106 if (len
== 0 || lenc
== 0)
3115 strcspn (e
->value
.character
.string
, c
->value
.character
.string
) + 1;
3122 for (indx
= len
; indx
> 0; indx
--)
3124 for (i
= 0; i
< lenc
; i
++)
3126 if (c
->value
.character
.string
[i
]
3127 == e
->value
.character
.string
[indx
- 1])
3135 mpz_set_ui (result
->value
.integer
, indx
);
3136 return range_check (result
, "SCAN");
3141 gfc_simplify_selected_int_kind (gfc_expr
* e
)
3146 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
3151 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
3152 if (gfc_integer_kinds
[i
].range
>= range
3153 && gfc_integer_kinds
[i
].kind
< kind
)
3154 kind
= gfc_integer_kinds
[i
].kind
;
3156 if (kind
== INT_MAX
)
3159 result
= gfc_int_expr (kind
);
3160 result
->where
= e
->where
;
3167 gfc_simplify_selected_real_kind (gfc_expr
* p
, gfc_expr
* q
)
3169 int range
, precision
, i
, kind
, found_precision
, found_range
;
3176 if (p
->expr_type
!= EXPR_CONSTANT
3177 || gfc_extract_int (p
, &precision
) != NULL
)
3185 if (q
->expr_type
!= EXPR_CONSTANT
3186 || gfc_extract_int (q
, &range
) != NULL
)
3191 found_precision
= 0;
3194 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
3196 if (gfc_real_kinds
[i
].precision
>= precision
)
3197 found_precision
= 1;
3199 if (gfc_real_kinds
[i
].range
>= range
)
3202 if (gfc_real_kinds
[i
].precision
>= precision
3203 && gfc_real_kinds
[i
].range
>= range
&& gfc_real_kinds
[i
].kind
< kind
)
3204 kind
= gfc_real_kinds
[i
].kind
;
3207 if (kind
== INT_MAX
)
3211 if (!found_precision
)
3217 result
= gfc_int_expr (kind
);
3218 result
->where
= (p
!= NULL
) ? p
->where
: q
->where
;
3225 gfc_simplify_set_exponent (gfc_expr
* x
, gfc_expr
* i
)
3228 mpfr_t exp
, absv
, log2
, pow2
, frac
;
3231 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3234 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3236 gfc_set_model_kind (x
->ts
.kind
);
3238 if (mpfr_sgn (x
->value
.real
) == 0)
3240 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3250 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3251 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3253 mpfr_trunc (log2
, log2
);
3254 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
3256 /* Old exponent value, and fraction. */
3257 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3259 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
3262 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
3263 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
3270 return range_check (result
, "SET_EXPONENT");
3275 gfc_simplify_shape (gfc_expr
* source
)
3277 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3278 gfc_expr
*result
, *e
, *f
;
3283 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3286 result
= gfc_start_constructor (BT_INTEGER
, gfc_default_integer_kind
,
3289 ar
= gfc_find_array_ref (source
);
3291 t
= gfc_array_ref_shape (ar
, shape
);
3293 for (n
= 0; n
< source
->rank
; n
++)
3295 e
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3300 mpz_set (e
->value
.integer
, shape
[n
]);
3301 mpz_clear (shape
[n
]);
3305 mpz_set_ui (e
->value
.integer
, n
+ 1);
3307 f
= gfc_simplify_size (source
, e
);
3311 gfc_free_expr (result
);
3320 gfc_append_constructor (result
, e
);
3328 gfc_simplify_size (gfc_expr
* array
, gfc_expr
* dim
)
3336 if (gfc_array_size (array
, &size
) == FAILURE
)
3341 if (dim
->expr_type
!= EXPR_CONSTANT
)
3344 d
= mpz_get_ui (dim
->value
.integer
) - 1;
3345 if (gfc_array_dimen_size (array
, d
, &size
) == FAILURE
)
3349 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3352 mpz_set (result
->value
.integer
, size
);
3359 gfc_simplify_sign (gfc_expr
* x
, gfc_expr
* y
)
3363 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3366 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3371 mpz_abs (result
->value
.integer
, x
->value
.integer
);
3372 if (mpz_sgn (y
->value
.integer
) < 0)
3373 mpz_neg (result
->value
.integer
, result
->value
.integer
);
3378 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3380 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3381 if (mpfr_sgn (y
->value
.real
) < 0)
3382 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
3387 gfc_internal_error ("Bad type in gfc_simplify_sign");
3395 gfc_simplify_sin (gfc_expr
* x
)
3400 if (x
->expr_type
!= EXPR_CONSTANT
)
3403 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3408 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3412 gfc_set_model (x
->value
.real
);
3416 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3417 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3418 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
3420 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3421 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3422 mpfr_mul (result
->value
.complex.i
, xp
, xq
, GFC_RND_MODE
);
3429 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3432 return range_check (result
, "SIN");
3437 gfc_simplify_sinh (gfc_expr
* x
)
3441 if (x
->expr_type
!= EXPR_CONSTANT
)
3444 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3446 mpfr_sinh(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3448 return range_check (result
, "SINH");
3452 /* The argument is always a double precision real that is converted to
3453 single precision. TODO: Rounding! */
3456 gfc_simplify_sngl (gfc_expr
* a
)
3460 if (a
->expr_type
!= EXPR_CONSTANT
)
3463 result
= gfc_real2real (a
, gfc_default_real_kind
);
3464 return range_check (result
, "SNGL");
3469 gfc_simplify_spacing (gfc_expr
* x
)
3476 if (x
->expr_type
!= EXPR_CONSTANT
)
3479 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3481 p
= gfc_real_kinds
[i
].digits
;
3483 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3485 gfc_set_model_kind (x
->ts
.kind
);
3487 if (mpfr_sgn (x
->value
.real
) == 0)
3489 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3496 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3497 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3498 mpfr_trunc (log2
, log2
);
3500 mpfr_add_ui (log2
, log2
, 1, GFC_RND_MODE
);
3502 /* FIXME: We should be using mpfr_get_si here, but this function is
3503 not available with the version of mpfr distributed with gmp (as of
3504 2004-09-17). Replace once mpfr has been imported into the gcc cvs
3506 diff
= (long)mpfr_get_d (log2
, GFC_RND_MODE
) - (long)p
;
3507 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
3508 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, diff
, GFC_RND_MODE
);
3513 if (mpfr_cmp (result
->value
.real
, gfc_real_kinds
[i
].tiny
) < 0)
3514 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3516 return range_check (result
, "SPACING");
3521 gfc_simplify_sqrt (gfc_expr
* e
)
3524 mpfr_t ac
, ad
, s
, t
, w
;
3526 if (e
->expr_type
!= EXPR_CONSTANT
)
3529 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3534 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
3536 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
3541 /* Formula taken from Numerical Recipes to avoid over- and
3544 gfc_set_model (e
->value
.real
);
3551 if (mpfr_cmp_ui (e
->value
.complex.r
, 0) == 0
3552 && mpfr_cmp_ui (e
->value
.complex.i
, 0) == 0)
3555 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
3556 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
3560 mpfr_abs (ac
, e
->value
.complex.r
, GFC_RND_MODE
);
3561 mpfr_abs (ad
, e
->value
.complex.i
, GFC_RND_MODE
);
3563 if (mpfr_cmp (ac
, ad
) >= 0)
3565 mpfr_div (t
, e
->value
.complex.i
, e
->value
.complex.r
, GFC_RND_MODE
);
3566 mpfr_mul (t
, t
, t
, GFC_RND_MODE
);
3567 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3568 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3569 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3570 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3571 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3572 mpfr_sqrt (s
, ac
, GFC_RND_MODE
);
3573 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3577 mpfr_div (s
, e
->value
.complex.r
, e
->value
.complex.i
, GFC_RND_MODE
);
3578 mpfr_mul (t
, s
, s
, GFC_RND_MODE
);
3579 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3580 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3581 mpfr_abs (s
, s
, GFC_RND_MODE
);
3582 mpfr_add (t
, t
, s
, GFC_RND_MODE
);
3583 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3584 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3585 mpfr_sqrt (s
, ad
, GFC_RND_MODE
);
3586 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3589 if (mpfr_cmp_ui (w
, 0) != 0 && mpfr_cmp_ui (e
->value
.complex.r
, 0) >= 0)
3591 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3592 mpfr_div (result
->value
.complex.i
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3593 mpfr_set (result
->value
.complex.r
, w
, GFC_RND_MODE
);
3595 else if (mpfr_cmp_ui (w
, 0) != 0
3596 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3597 && mpfr_cmp_ui (e
->value
.complex.i
, 0) >= 0)
3599 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3600 mpfr_div (result
->value
.complex.r
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3601 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3603 else if (mpfr_cmp_ui (w
, 0) != 0
3604 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3605 && mpfr_cmp_ui (e
->value
.complex.i
, 0) < 0)
3607 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3608 mpfr_div (result
->value
.complex.r
, ad
, t
, GFC_RND_MODE
);
3609 mpfr_neg (w
, w
, GFC_RND_MODE
);
3610 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3613 gfc_internal_error ("invalid complex argument of SQRT at %L",
3625 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
3628 return range_check (result
, "SQRT");
3631 gfc_free_expr (result
);
3632 gfc_error ("Argument of SQRT at %L has a negative value", &e
->where
);
3633 return &gfc_bad_expr
;
3638 gfc_simplify_tan (gfc_expr
* x
)
3643 if (x
->expr_type
!= EXPR_CONSTANT
)
3646 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3648 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3650 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3652 return range_check (result
, "TAN");
3657 gfc_simplify_tanh (gfc_expr
* x
)
3661 if (x
->expr_type
!= EXPR_CONSTANT
)
3664 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3666 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3668 return range_check (result
, "TANH");
3674 gfc_simplify_tiny (gfc_expr
* e
)
3679 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
3681 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
3682 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3689 gfc_simplify_trim (gfc_expr
* e
)
3692 int count
, i
, len
, lentrim
;
3694 if (e
->expr_type
!= EXPR_CONSTANT
)
3697 len
= e
->value
.character
.length
;
3699 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
3701 for (count
= 0, i
= 1; i
<= len
; ++i
)
3703 if (e
->value
.character
.string
[len
- i
] == ' ')
3709 lentrim
= len
- count
;
3711 result
->value
.character
.length
= lentrim
;
3712 result
->value
.character
.string
= gfc_getmem (lentrim
+ 1);
3714 for (i
= 0; i
< lentrim
; i
++)
3715 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
3717 result
->value
.character
.string
[lentrim
] = '\0'; /* For debugger */
3724 gfc_simplify_ubound (gfc_expr
* array
, gfc_expr
* dim
)
3726 return simplify_bound (array
, dim
, 1);
3731 gfc_simplify_verify (gfc_expr
* s
, gfc_expr
* set
, gfc_expr
* b
)
3735 size_t index
, len
, lenset
;
3738 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
)
3741 if (b
!= NULL
&& b
->value
.logical
!= 0)
3746 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3749 len
= s
->value
.character
.length
;
3750 lenset
= set
->value
.character
.length
;
3754 mpz_set_ui (result
->value
.integer
, 0);
3762 mpz_set_ui (result
->value
.integer
, len
);
3767 strspn (s
->value
.character
.string
, set
->value
.character
.string
) + 1;
3776 mpz_set_ui (result
->value
.integer
, 1);
3779 for (index
= len
; index
> 0; index
--)
3781 for (i
= 0; i
< lenset
; i
++)
3783 if (s
->value
.character
.string
[index
- 1]
3784 == set
->value
.character
.string
[i
])
3792 mpz_set_ui (result
->value
.integer
, index
);
3798 gfc_simplify_xor (gfc_expr
* x
, gfc_expr
* y
)
3803 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3806 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
3807 if (x
->ts
.type
== BT_INTEGER
)
3809 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
3810 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3812 else /* BT_LOGICAL */
3814 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
3815 result
->value
.logical
= (x
->value
.logical
&& ! y
->value
.logical
)
3816 || (! x
->value
.logical
&& y
->value
.logical
);
3819 return range_check (result
, "XOR");
3824 /****************** Constant simplification *****************/
3826 /* Master function to convert one constant to another. While this is
3827 used as a simplification function, it requires the destination type
3828 and kind information which is supplied by a special case in
3832 gfc_convert_constant (gfc_expr
* e
, bt type
, int kind
)
3834 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
3835 gfc_constructor
*head
, *c
, *tail
= NULL
;
3849 f
= gfc_int2complex
;
3869 f
= gfc_real2complex
;
3880 f
= gfc_complex2int
;
3883 f
= gfc_complex2real
;
3886 f
= gfc_complex2complex
;
3912 f
= gfc_hollerith2int
;
3916 f
= gfc_hollerith2real
;
3920 f
= gfc_hollerith2complex
;
3924 f
= gfc_hollerith2character
;
3928 f
= gfc_hollerith2logical
;
3938 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
3943 switch (e
->expr_type
)
3946 result
= f (e
, kind
);
3948 return &gfc_bad_expr
;
3952 if (!gfc_is_constant_expr (e
))
3957 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
3960 head
= tail
= gfc_get_constructor ();
3963 tail
->next
= gfc_get_constructor ();
3967 tail
->where
= c
->where
;
3969 if (c
->iterator
== NULL
)
3970 tail
->expr
= f (c
->expr
, kind
);
3973 g
= gfc_convert_constant (c
->expr
, type
, kind
);
3974 if (g
== &gfc_bad_expr
)
3979 if (tail
->expr
== NULL
)
3981 gfc_free_constructor (head
);
3986 result
= gfc_get_expr ();
3987 result
->ts
.type
= type
;
3988 result
->ts
.kind
= kind
;
3989 result
->expr_type
= EXPR_ARRAY
;
3990 result
->value
.constructor
= head
;
3991 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
3992 result
->where
= e
->where
;
3993 result
->rank
= e
->rank
;
4004 /****************** Helper functions ***********************/
4006 /* Given a collating table, create the inverse table. */
4009 invert_table (const int *table
, int *xtable
)
4013 for (i
= 0; i
< 256; i
++)
4016 for (i
= 0; i
< 256; i
++)
4017 xtable
[table
[i
]] = i
;
4022 gfc_simplify_init_1 (void)
4025 invert_table (ascii_table
, xascii_table
);