1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
4 Contributed by Andy Vaught & Katherine Holcomb
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
28 #include "intrinsic.h"
30 gfc_expr gfc_bad_expr
;
33 /* Note that 'simplification' is not just transforming expressions.
34 For functions that are not simplified at compile time, range
35 checking is done if possible.
37 The return convention is that each simplification function returns:
39 A new expression node corresponding to the simplified arguments.
40 The original arguments are destroyed by the caller, and must not
41 be a part of the new expression.
43 NULL pointer indicating that no simplification was possible and
44 the original expression should remain intact. If the
45 simplification function sets the type and/or the function name
46 via the pointer gfc_simple_expression, then this type is
49 An expression pointer to gfc_bad_expr (a static placeholder)
50 indicating that some error has prevented simplification. For
51 example, sqrt(-1.0). The error is generated within the function
52 and should be propagated upwards
54 By the time a simplification function gets control, it has been
55 decided that the function call is really supposed to be the
56 intrinsic. No type checking is strictly necessary, since only
57 valid types will be passed on. On the other hand, a simplification
58 subroutine may have to look at the type of an argument as part of
61 Array arguments are never passed to these subroutines.
63 The functions in this file don't have much comment with them, but
64 everything is reasonably straight-forward. The Standard, chapter 13
65 is the best comment you'll find for this file anyway. */
67 /* Static table for converting non-ascii character sets to ascii.
68 The xascii_table[] is the inverse table. */
70 static int ascii_table
[256] = {
71 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
72 '\b', '\t', '\n', '\v', '\0', '\r', '\0', '\0',
73 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
74 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
75 ' ', '!', '\'', '#', '$', '%', '&', '\'',
76 '(', ')', '*', '+', ',', '-', '.', '/',
77 '0', '1', '2', '3', '4', '5', '6', '7',
78 '8', '9', ':', ';', '<', '=', '>', '?',
79 '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
80 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
81 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
82 'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
83 '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
84 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
85 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
86 'x', 'y', 'z', '{', '|', '}', '~', '\?'
89 static int xascii_table
[256];
92 /* Range checks an expression node. If all goes well, returns the
93 node, otherwise returns &gfc_bad_expr and frees the node. */
96 range_check (gfc_expr
* result
, const char *name
)
98 if (gfc_range_check (result
) == ARITH_OK
)
101 gfc_error ("Result of %s overflows its kind at %L", name
, &result
->where
);
102 gfc_free_expr (result
);
103 return &gfc_bad_expr
;
107 /* A helper function that gets an optional and possibly missing
108 kind parameter. Returns the kind, -1 if something went wrong. */
111 get_kind (bt type
, gfc_expr
* k
, const char *name
, int default_kind
)
118 if (k
->expr_type
!= EXPR_CONSTANT
)
120 gfc_error ("KIND parameter of %s at %L must be an initialization "
121 "expression", name
, &k
->where
);
126 if (gfc_extract_int (k
, &kind
) != NULL
127 || gfc_validate_kind (type
, kind
, true) < 0)
130 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
138 /* Checks if X, which is assumed to represent a two's complement
139 integer of binary width BITSIZE, has the signbit set. If so, makes
140 X the corresponding negative number. */
143 twos_complement (mpz_t x
, int bitsize
)
147 if (mpz_tstbit (x
, bitsize
- 1) == 1)
149 mpz_init_set_ui(mask
, 1);
150 mpz_mul_2exp(mask
, mask
, bitsize
);
151 mpz_sub_ui(mask
, mask
, 1);
153 /* We negate the number by hand, zeroing the high bits, that is
154 make it the corresponding positive number, and then have it
155 negated by GMP, giving the correct representation of the
158 mpz_add_ui (x
, x
, 1);
159 mpz_and (x
, x
, mask
);
168 /********************** Simplification functions *****************************/
171 gfc_simplify_abs (gfc_expr
* e
)
175 if (e
->expr_type
!= EXPR_CONSTANT
)
181 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
183 mpz_abs (result
->value
.integer
, e
->value
.integer
);
185 result
= range_check (result
, "IABS");
189 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
191 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
193 result
= range_check (result
, "ABS");
197 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
199 gfc_set_model_kind (e
->ts
.kind
);
201 mpfr_hypot (result
->value
.real
, e
->value
.complex.r
,
202 e
->value
.complex.i
, GFC_RND_MODE
);
203 result
= range_check (result
, "CABS");
207 gfc_internal_error ("gfc_simplify_abs(): Bad type");
215 gfc_simplify_achar (gfc_expr
* e
)
220 if (e
->expr_type
!= EXPR_CONSTANT
)
223 /* We cannot assume that the native character set is ASCII in this
225 if (gfc_extract_int (e
, &index
) != NULL
|| index
< 0 || index
> 127)
227 gfc_error ("Extended ASCII not implemented: argument of ACHAR at %L "
228 "must be between 0 and 127", &e
->where
);
229 return &gfc_bad_expr
;
232 result
= gfc_constant_result (BT_CHARACTER
, gfc_default_character_kind
,
235 result
->value
.character
.string
= gfc_getmem (2);
237 result
->value
.character
.length
= 1;
238 result
->value
.character
.string
[0] = ascii_table
[index
];
239 result
->value
.character
.string
[1] = '\0'; /* For debugger */
245 gfc_simplify_acos (gfc_expr
* x
)
249 if (x
->expr_type
!= EXPR_CONSTANT
)
252 if (mpfr_cmp_si (x
->value
.real
, 1) > 0 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
254 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
256 return &gfc_bad_expr
;
259 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
261 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
263 return range_check (result
, "ACOS");
268 gfc_simplify_adjustl (gfc_expr
* e
)
274 if (e
->expr_type
!= EXPR_CONSTANT
)
277 len
= e
->value
.character
.length
;
279 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
281 result
->value
.character
.length
= len
;
282 result
->value
.character
.string
= gfc_getmem (len
+ 1);
284 for (count
= 0, i
= 0; i
< len
; ++i
)
286 ch
= e
->value
.character
.string
[i
];
292 for (i
= 0; i
< len
- count
; ++i
)
294 result
->value
.character
.string
[i
] =
295 e
->value
.character
.string
[count
+ i
];
298 for (i
= len
- count
; i
< len
; ++i
)
300 result
->value
.character
.string
[i
] = ' ';
303 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
310 gfc_simplify_adjustr (gfc_expr
* e
)
316 if (e
->expr_type
!= EXPR_CONSTANT
)
319 len
= e
->value
.character
.length
;
321 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
323 result
->value
.character
.length
= len
;
324 result
->value
.character
.string
= gfc_getmem (len
+ 1);
326 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
328 ch
= e
->value
.character
.string
[i
];
334 for (i
= 0; i
< count
; ++i
)
336 result
->value
.character
.string
[i
] = ' ';
339 for (i
= count
; i
< len
; ++i
)
341 result
->value
.character
.string
[i
] =
342 e
->value
.character
.string
[i
- count
];
345 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
352 gfc_simplify_aimag (gfc_expr
* e
)
356 if (e
->expr_type
!= EXPR_CONSTANT
)
359 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
360 mpfr_set (result
->value
.real
, e
->value
.complex.i
, GFC_RND_MODE
);
362 return range_check (result
, "AIMAG");
367 gfc_simplify_aint (gfc_expr
* e
, gfc_expr
* k
)
369 gfc_expr
*rtrunc
, *result
;
372 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
374 return &gfc_bad_expr
;
376 if (e
->expr_type
!= EXPR_CONSTANT
)
379 rtrunc
= gfc_copy_expr (e
);
381 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
383 result
= gfc_real2real (rtrunc
, kind
);
384 gfc_free_expr (rtrunc
);
386 return range_check (result
, "AINT");
391 gfc_simplify_dint (gfc_expr
* e
)
393 gfc_expr
*rtrunc
, *result
;
395 if (e
->expr_type
!= EXPR_CONSTANT
)
398 rtrunc
= gfc_copy_expr (e
);
400 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
402 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
403 gfc_free_expr (rtrunc
);
405 return range_check (result
, "DINT");
410 gfc_simplify_anint (gfc_expr
* e
, gfc_expr
* k
)
412 gfc_expr
*rtrunc
, *result
;
416 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
418 return &gfc_bad_expr
;
420 if (e
->expr_type
!= EXPR_CONSTANT
)
423 result
= gfc_constant_result (e
->ts
.type
, kind
, &e
->where
);
425 rtrunc
= gfc_copy_expr (e
);
427 cmp
= mpfr_cmp_ui (e
->value
.real
, 0);
429 gfc_set_model_kind (kind
);
431 mpfr_set_str (half
, "0.5", 10, GFC_RND_MODE
);
435 mpfr_add (rtrunc
->value
.real
, e
->value
.real
, half
, GFC_RND_MODE
);
436 mpfr_trunc (result
->value
.real
, rtrunc
->value
.real
);
440 mpfr_sub (rtrunc
->value
.real
, e
->value
.real
, half
, GFC_RND_MODE
);
441 mpfr_trunc (result
->value
.real
, rtrunc
->value
.real
);
444 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
446 gfc_free_expr (rtrunc
);
449 return range_check (result
, "ANINT");
454 gfc_simplify_dnint (gfc_expr
* e
)
456 gfc_expr
*rtrunc
, *result
;
460 if (e
->expr_type
!= EXPR_CONSTANT
)
464 gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &e
->where
);
466 rtrunc
= gfc_copy_expr (e
);
468 cmp
= mpfr_cmp_ui (e
->value
.real
, 0);
470 gfc_set_model_kind (gfc_default_double_kind
);
472 mpfr_set_str (half
, "0.5", 10, GFC_RND_MODE
);
476 mpfr_add (rtrunc
->value
.real
, e
->value
.real
, half
, GFC_RND_MODE
);
477 mpfr_trunc (result
->value
.real
, rtrunc
->value
.real
);
481 mpfr_sub (rtrunc
->value
.real
, e
->value
.real
, half
, GFC_RND_MODE
);
482 mpfr_trunc (result
->value
.real
, rtrunc
->value
.real
);
485 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
487 gfc_free_expr (rtrunc
);
490 return range_check (result
, "DNINT");
495 gfc_simplify_asin (gfc_expr
* x
)
499 if (x
->expr_type
!= EXPR_CONSTANT
)
502 if (mpfr_cmp_si (x
->value
.real
, 1) > 0 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
504 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
506 return &gfc_bad_expr
;
509 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
511 mpfr_asin(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
513 return range_check (result
, "ASIN");
518 gfc_simplify_atan (gfc_expr
* x
)
522 if (x
->expr_type
!= EXPR_CONSTANT
)
525 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
527 mpfr_atan(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
529 return range_check (result
, "ATAN");
535 gfc_simplify_atan2 (gfc_expr
* y
, gfc_expr
* x
)
539 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
542 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
544 if (mpfr_sgn (y
->value
.real
) == 0 && mpfr_sgn (x
->value
.real
) == 0)
547 ("If first argument of ATAN2 %L is zero, then the second argument "
548 "must not be zero", &x
->where
);
549 gfc_free_expr (result
);
550 return &gfc_bad_expr
;
553 arctangent2 (y
->value
.real
, x
->value
.real
, result
->value
.real
);
555 return range_check (result
, "ATAN2");
561 gfc_simplify_bit_size (gfc_expr
* e
)
566 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
567 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
568 mpz_set_ui (result
->value
.integer
, gfc_integer_kinds
[i
].bit_size
);
575 gfc_simplify_btest (gfc_expr
* e
, gfc_expr
* bit
)
579 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
582 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
583 return gfc_logical_expr (0, &e
->where
);
585 return gfc_logical_expr (mpz_tstbit (e
->value
.integer
, b
), &e
->where
);
590 gfc_simplify_ceiling (gfc_expr
* e
, gfc_expr
* k
)
592 gfc_expr
*ceil
, *result
;
595 kind
= get_kind (BT_REAL
, k
, "CEILING", gfc_default_real_kind
);
597 return &gfc_bad_expr
;
599 if (e
->expr_type
!= EXPR_CONSTANT
)
602 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
604 ceil
= gfc_copy_expr (e
);
606 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
607 gfc_mpfr_to_mpz(result
->value
.integer
, ceil
->value
.real
);
609 gfc_free_expr (ceil
);
611 return range_check (result
, "CEILING");
616 gfc_simplify_char (gfc_expr
* e
, gfc_expr
* k
)
621 kind
= get_kind (BT_CHARACTER
, k
, "CHAR", gfc_default_character_kind
);
623 return &gfc_bad_expr
;
625 if (e
->expr_type
!= EXPR_CONSTANT
)
628 if (gfc_extract_int (e
, &c
) != NULL
|| c
< 0 || c
> 255)
630 gfc_error ("Bad character in CHAR function at %L", &e
->where
);
631 return &gfc_bad_expr
;
634 result
= gfc_constant_result (BT_CHARACTER
, kind
, &e
->where
);
636 result
->value
.character
.length
= 1;
637 result
->value
.character
.string
= gfc_getmem (2);
639 result
->value
.character
.string
[0] = c
;
640 result
->value
.character
.string
[1] = '\0'; /* For debugger */
646 /* Common subroutine for simplifying CMPLX and DCMPLX. */
649 simplify_cmplx (const char *name
, gfc_expr
* x
, gfc_expr
* y
, int kind
)
653 result
= gfc_constant_result (BT_COMPLEX
, kind
, &x
->where
);
655 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
660 mpfr_set_z (result
->value
.complex.r
, x
->value
.integer
, GFC_RND_MODE
);
664 mpfr_set (result
->value
.complex.r
, x
->value
.real
, GFC_RND_MODE
);
668 mpfr_set (result
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
669 mpfr_set (result
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
673 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
681 mpfr_set_z (result
->value
.complex.i
, y
->value
.integer
, GFC_RND_MODE
);
685 mpfr_set (result
->value
.complex.i
, y
->value
.real
, GFC_RND_MODE
);
689 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
693 return range_check (result
, name
);
698 gfc_simplify_cmplx (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* k
)
702 if (x
->expr_type
!= EXPR_CONSTANT
703 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
706 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_real_kind
);
708 return &gfc_bad_expr
;
710 return simplify_cmplx ("CMPLX", x
, y
, kind
);
715 gfc_simplify_conjg (gfc_expr
* e
)
719 if (e
->expr_type
!= EXPR_CONSTANT
)
722 result
= gfc_copy_expr (e
);
723 mpfr_neg (result
->value
.complex.i
, result
->value
.complex.i
, GFC_RND_MODE
);
725 return range_check (result
, "CONJG");
730 gfc_simplify_cos (gfc_expr
* x
)
735 if (x
->expr_type
!= EXPR_CONSTANT
)
738 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
743 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
746 gfc_set_model_kind (x
->ts
.kind
);
750 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
751 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
752 mpfr_mul(result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
754 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
755 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
756 mpfr_mul (xp
, xp
, xq
, GFC_RND_MODE
);
757 mpfr_neg (result
->value
.complex.i
, xp
, GFC_RND_MODE
);
763 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
766 return range_check (result
, "COS");
772 gfc_simplify_cosh (gfc_expr
* x
)
776 if (x
->expr_type
!= EXPR_CONSTANT
)
779 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
781 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
783 return range_check (result
, "COSH");
788 gfc_simplify_dcmplx (gfc_expr
* x
, gfc_expr
* y
)
791 if (x
->expr_type
!= EXPR_CONSTANT
792 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
795 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
800 gfc_simplify_dble (gfc_expr
* e
)
804 if (e
->expr_type
!= EXPR_CONSTANT
)
810 result
= gfc_int2real (e
, gfc_default_double_kind
);
814 result
= gfc_real2real (e
, gfc_default_double_kind
);
818 result
= gfc_complex2real (e
, gfc_default_double_kind
);
822 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e
->where
);
825 return range_check (result
, "DBLE");
830 gfc_simplify_digits (gfc_expr
* x
)
834 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
838 digits
= gfc_integer_kinds
[i
].digits
;
843 digits
= gfc_real_kinds
[i
].digits
;
850 return gfc_int_expr (digits
);
855 gfc_simplify_dim (gfc_expr
* x
, gfc_expr
* y
)
859 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
862 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
867 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
868 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
870 mpz_set_ui (result
->value
.integer
, 0);
875 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
876 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
878 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
883 gfc_internal_error ("gfc_simplify_dim(): Bad type");
886 return range_check (result
, "DIM");
891 gfc_simplify_dprod (gfc_expr
* x
, gfc_expr
* y
)
893 gfc_expr
*a1
, *a2
, *result
;
895 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
899 gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &x
->where
);
901 a1
= gfc_real2real (x
, gfc_default_double_kind
);
902 a2
= gfc_real2real (y
, gfc_default_double_kind
);
904 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
909 return range_check (result
, "DPROD");
914 gfc_simplify_epsilon (gfc_expr
* e
)
919 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
921 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
923 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
925 return range_check (result
, "EPSILON");
930 gfc_simplify_exp (gfc_expr
* x
)
935 if (x
->expr_type
!= EXPR_CONSTANT
)
938 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
943 mpfr_exp(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
947 gfc_set_model_kind (x
->ts
.kind
);
950 mpfr_exp (xq
, x
->value
.complex.r
, GFC_RND_MODE
);
951 mpfr_cos (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
952 mpfr_mul (result
->value
.complex.r
, xq
, xp
, GFC_RND_MODE
);
953 mpfr_sin (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
954 mpfr_mul (result
->value
.complex.i
, xq
, xp
, GFC_RND_MODE
);
960 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
963 return range_check (result
, "EXP");
966 /* FIXME: MPFR should be able to do this better */
968 gfc_simplify_exponent (gfc_expr
* x
)
973 if (x
->expr_type
!= EXPR_CONSTANT
)
976 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
979 gfc_set_model (x
->value
.real
);
981 if (mpfr_sgn (x
->value
.real
) == 0)
983 mpz_set_ui (result
->value
.integer
, 0);
989 mpfr_abs (tmp
, x
->value
.real
, GFC_RND_MODE
);
990 mpfr_log2 (tmp
, tmp
, GFC_RND_MODE
);
992 gfc_mpfr_to_mpz (result
->value
.integer
, tmp
);
996 return range_check (result
, "EXPONENT");
1001 gfc_simplify_float (gfc_expr
* a
)
1005 if (a
->expr_type
!= EXPR_CONSTANT
)
1008 result
= gfc_int2real (a
, gfc_default_real_kind
);
1009 return range_check (result
, "FLOAT");
1014 gfc_simplify_floor (gfc_expr
* e
, gfc_expr
* k
)
1020 kind
= get_kind (BT_REAL
, k
, "FLOOR", gfc_default_real_kind
);
1022 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1024 if (e
->expr_type
!= EXPR_CONSTANT
)
1027 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1029 gfc_set_model_kind (kind
);
1031 mpfr_floor (floor
, e
->value
.real
);
1033 gfc_mpfr_to_mpz (result
->value
.integer
, floor
);
1037 return range_check (result
, "FLOOR");
1042 gfc_simplify_fraction (gfc_expr
* x
)
1045 mpfr_t absv
, exp
, pow2
;
1047 if (x
->expr_type
!= EXPR_CONSTANT
)
1050 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
1052 gfc_set_model_kind (x
->ts
.kind
);
1054 if (mpfr_sgn (x
->value
.real
) == 0)
1056 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1064 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
1065 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
1067 mpfr_trunc (exp
, exp
);
1068 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
1070 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
1072 mpfr_div (result
->value
.real
, absv
, pow2
, GFC_RND_MODE
);
1078 return range_check (result
, "FRACTION");
1083 gfc_simplify_huge (gfc_expr
* e
)
1088 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1090 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1095 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
1099 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
1111 gfc_simplify_iachar (gfc_expr
* e
)
1116 if (e
->expr_type
!= EXPR_CONSTANT
)
1119 if (e
->value
.character
.length
!= 1)
1121 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
1122 return &gfc_bad_expr
;
1125 index
= xascii_table
[(int) e
->value
.character
.string
[0] & 0xFF];
1127 result
= gfc_int_expr (index
);
1128 result
->where
= e
->where
;
1130 return range_check (result
, "IACHAR");
1135 gfc_simplify_iand (gfc_expr
* x
, gfc_expr
* y
)
1139 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1142 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1144 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1146 return range_check (result
, "IAND");
1151 gfc_simplify_ibclr (gfc_expr
* x
, gfc_expr
* y
)
1156 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1159 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1161 gfc_error ("Invalid second argument of IBCLR at %L", &y
->where
);
1162 return &gfc_bad_expr
;
1165 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1167 if (pos
> gfc_integer_kinds
[k
].bit_size
)
1169 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1171 return &gfc_bad_expr
;
1174 result
= gfc_copy_expr (x
);
1176 mpz_clrbit (result
->value
.integer
, pos
);
1177 return range_check (result
, "IBCLR");
1182 gfc_simplify_ibits (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
1189 if (x
->expr_type
!= EXPR_CONSTANT
1190 || y
->expr_type
!= EXPR_CONSTANT
1191 || z
->expr_type
!= EXPR_CONSTANT
)
1194 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1196 gfc_error ("Invalid second argument of IBITS at %L", &y
->where
);
1197 return &gfc_bad_expr
;
1200 if (gfc_extract_int (z
, &len
) != NULL
|| len
< 0)
1202 gfc_error ("Invalid third argument of IBITS at %L", &z
->where
);
1203 return &gfc_bad_expr
;
1206 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
1208 bitsize
= gfc_integer_kinds
[k
].bit_size
;
1210 if (pos
+ len
> bitsize
)
1213 ("Sum of second and third arguments of IBITS exceeds bit size "
1214 "at %L", &y
->where
);
1215 return &gfc_bad_expr
;
1218 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1220 bits
= gfc_getmem (bitsize
* sizeof (int));
1222 for (i
= 0; i
< bitsize
; i
++)
1225 for (i
= 0; i
< len
; i
++)
1226 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
1228 for (i
= 0; i
< bitsize
; i
++)
1232 mpz_clrbit (result
->value
.integer
, i
);
1234 else if (bits
[i
] == 1)
1236 mpz_setbit (result
->value
.integer
, i
);
1240 gfc_internal_error ("IBITS: Bad bit");
1246 return range_check (result
, "IBITS");
1251 gfc_simplify_ibset (gfc_expr
* x
, gfc_expr
* y
)
1256 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1259 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1261 gfc_error ("Invalid second argument of IBSET at %L", &y
->where
);
1262 return &gfc_bad_expr
;
1265 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1267 if (pos
> gfc_integer_kinds
[k
].bit_size
)
1269 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1271 return &gfc_bad_expr
;
1274 result
= gfc_copy_expr (x
);
1276 mpz_setbit (result
->value
.integer
, pos
);
1277 return range_check (result
, "IBSET");
1282 gfc_simplify_ichar (gfc_expr
* e
)
1287 if (e
->expr_type
!= EXPR_CONSTANT
)
1290 if (e
->value
.character
.length
!= 1)
1292 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
1293 return &gfc_bad_expr
;
1296 index
= (int) e
->value
.character
.string
[0];
1298 if (index
< CHAR_MIN
|| index
> CHAR_MAX
)
1300 gfc_error ("Argument of ICHAR at %L out of range of this processor",
1302 return &gfc_bad_expr
;
1305 result
= gfc_int_expr (index
);
1306 result
->where
= e
->where
;
1307 return range_check (result
, "ICHAR");
1312 gfc_simplify_ieor (gfc_expr
* x
, gfc_expr
* y
)
1316 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1319 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1321 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1323 return range_check (result
, "IEOR");
1328 gfc_simplify_index (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* b
)
1331 int back
, len
, lensub
;
1332 int i
, j
, k
, count
, index
= 0, start
;
1334 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1337 if (b
!= NULL
&& b
->value
.logical
!= 0)
1342 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1345 len
= x
->value
.character
.length
;
1346 lensub
= y
->value
.character
.length
;
1350 mpz_set_si (result
->value
.integer
, 0);
1359 mpz_set_si (result
->value
.integer
, 1);
1362 else if (lensub
== 1)
1364 for (i
= 0; i
< len
; i
++)
1366 for (j
= 0; j
< lensub
; j
++)
1368 if (y
->value
.character
.string
[j
] ==
1369 x
->value
.character
.string
[i
])
1379 for (i
= 0; i
< len
; i
++)
1381 for (j
= 0; j
< lensub
; j
++)
1383 if (y
->value
.character
.string
[j
] ==
1384 x
->value
.character
.string
[i
])
1389 for (k
= 0; k
< lensub
; k
++)
1391 if (y
->value
.character
.string
[k
] ==
1392 x
->value
.character
.string
[k
+ start
])
1396 if (count
== lensub
)
1412 mpz_set_si (result
->value
.integer
, len
+ 1);
1415 else if (lensub
== 1)
1417 for (i
= 0; i
< len
; i
++)
1419 for (j
= 0; j
< lensub
; j
++)
1421 if (y
->value
.character
.string
[j
] ==
1422 x
->value
.character
.string
[len
- i
])
1424 index
= len
- i
+ 1;
1432 for (i
= 0; i
< len
; i
++)
1434 for (j
= 0; j
< lensub
; j
++)
1436 if (y
->value
.character
.string
[j
] ==
1437 x
->value
.character
.string
[len
- i
])
1440 if (start
<= len
- lensub
)
1443 for (k
= 0; k
< lensub
; k
++)
1444 if (y
->value
.character
.string
[k
] ==
1445 x
->value
.character
.string
[k
+ start
])
1448 if (count
== lensub
)
1465 mpz_set_si (result
->value
.integer
, index
);
1466 return range_check (result
, "INDEX");
1471 gfc_simplify_int (gfc_expr
* e
, gfc_expr
* k
)
1473 gfc_expr
*rpart
, *rtrunc
, *result
;
1476 kind
= get_kind (BT_REAL
, k
, "INT", gfc_default_real_kind
);
1478 return &gfc_bad_expr
;
1480 if (e
->expr_type
!= EXPR_CONSTANT
)
1483 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1488 mpz_set (result
->value
.integer
, e
->value
.integer
);
1492 rtrunc
= gfc_copy_expr (e
);
1493 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1494 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1495 gfc_free_expr (rtrunc
);
1499 rpart
= gfc_complex2real (e
, kind
);
1500 rtrunc
= gfc_copy_expr (rpart
);
1501 mpfr_trunc (rtrunc
->value
.real
, rpart
->value
.real
);
1502 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1503 gfc_free_expr (rpart
);
1504 gfc_free_expr (rtrunc
);
1508 gfc_error ("Argument of INT at %L is not a valid type", &e
->where
);
1509 gfc_free_expr (result
);
1510 return &gfc_bad_expr
;
1513 return range_check (result
, "INT");
1518 gfc_simplify_ifix (gfc_expr
* e
)
1520 gfc_expr
*rtrunc
, *result
;
1522 if (e
->expr_type
!= EXPR_CONSTANT
)
1525 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1528 rtrunc
= gfc_copy_expr (e
);
1530 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1531 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1533 gfc_free_expr (rtrunc
);
1534 return range_check (result
, "IFIX");
1539 gfc_simplify_idint (gfc_expr
* e
)
1541 gfc_expr
*rtrunc
, *result
;
1543 if (e
->expr_type
!= EXPR_CONSTANT
)
1546 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1549 rtrunc
= gfc_copy_expr (e
);
1551 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1552 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1554 gfc_free_expr (rtrunc
);
1555 return range_check (result
, "IDINT");
1560 gfc_simplify_ior (gfc_expr
* x
, gfc_expr
* y
)
1564 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1567 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1569 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1570 return range_check (result
, "IOR");
1575 gfc_simplify_ishft (gfc_expr
* e
, gfc_expr
* s
)
1578 int shift
, ashift
, isize
, k
, *bits
, i
;
1580 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1583 if (gfc_extract_int (s
, &shift
) != NULL
)
1585 gfc_error ("Invalid second argument of ISHFT at %L", &s
->where
);
1586 return &gfc_bad_expr
;
1589 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
1591 isize
= gfc_integer_kinds
[k
].bit_size
;
1601 ("Magnitude of second argument of ISHFT exceeds bit size at %L",
1603 return &gfc_bad_expr
;
1606 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1610 mpz_set (result
->value
.integer
, e
->value
.integer
);
1611 return range_check (result
, "ISHFT");
1614 bits
= gfc_getmem (isize
* sizeof (int));
1616 for (i
= 0; i
< isize
; i
++)
1617 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1621 for (i
= 0; i
< shift
; i
++)
1622 mpz_clrbit (result
->value
.integer
, i
);
1624 for (i
= 0; i
< isize
- shift
; i
++)
1627 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1629 mpz_setbit (result
->value
.integer
, i
+ shift
);
1634 for (i
= isize
- 1; i
>= isize
- ashift
; i
--)
1635 mpz_clrbit (result
->value
.integer
, i
);
1637 for (i
= isize
- 1; i
>= ashift
; i
--)
1640 mpz_clrbit (result
->value
.integer
, i
- ashift
);
1642 mpz_setbit (result
->value
.integer
, i
- ashift
);
1646 twos_complement (result
->value
.integer
, isize
);
1654 gfc_simplify_ishftc (gfc_expr
* e
, gfc_expr
* s
, gfc_expr
* sz
)
1657 int shift
, ashift
, isize
, delta
, k
;
1660 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1663 if (gfc_extract_int (s
, &shift
) != NULL
)
1665 gfc_error ("Invalid second argument of ISHFTC at %L", &s
->where
);
1666 return &gfc_bad_expr
;
1669 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1673 if (gfc_extract_int (sz
, &isize
) != NULL
|| isize
< 0)
1675 gfc_error ("Invalid third argument of ISHFTC at %L", &sz
->where
);
1676 return &gfc_bad_expr
;
1680 isize
= gfc_integer_kinds
[k
].bit_size
;
1690 ("Magnitude of second argument of ISHFTC exceeds third argument "
1691 "at %L", &s
->where
);
1692 return &gfc_bad_expr
;
1695 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1699 mpz_set (result
->value
.integer
, e
->value
.integer
);
1703 bits
= gfc_getmem (isize
* sizeof (int));
1705 for (i
= 0; i
< isize
; i
++)
1706 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1708 delta
= isize
- ashift
;
1712 for (i
= 0; i
< delta
; i
++)
1715 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1717 mpz_setbit (result
->value
.integer
, i
+ shift
);
1720 for (i
= delta
; i
< isize
; i
++)
1723 mpz_clrbit (result
->value
.integer
, i
- delta
);
1725 mpz_setbit (result
->value
.integer
, i
- delta
);
1730 for (i
= 0; i
< ashift
; i
++)
1733 mpz_clrbit (result
->value
.integer
, i
+ delta
);
1735 mpz_setbit (result
->value
.integer
, i
+ delta
);
1738 for (i
= ashift
; i
< isize
; i
++)
1741 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1743 mpz_setbit (result
->value
.integer
, i
+ shift
);
1747 twos_complement (result
->value
.integer
, isize
);
1755 gfc_simplify_kind (gfc_expr
* e
)
1758 if (e
->ts
.type
== BT_DERIVED
)
1760 gfc_error ("Argument of KIND at %L is a DERIVED type", &e
->where
);
1761 return &gfc_bad_expr
;
1764 return gfc_int_expr (e
->ts
.kind
);
1769 gfc_simplify_bound (gfc_expr
* array
, gfc_expr
* dim
, int upper
)
1775 if (array
->expr_type
!= EXPR_VARIABLE
)
1781 if (dim
->expr_type
!= EXPR_CONSTANT
)
1784 /* Follow any component references. */
1785 as
= array
->symtree
->n
.sym
->as
;
1787 while (ref
->next
!= NULL
)
1789 if (ref
->type
== REF_COMPONENT
)
1790 as
= ref
->u
.c
.sym
->as
;
1794 if (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
!= AR_FULL
)
1797 i
= mpz_get_si (dim
->value
.integer
);
1799 return gfc_copy_expr (as
->upper
[i
-1]);
1801 return gfc_copy_expr (as
->lower
[i
-1]);
1806 gfc_simplify_lbound (gfc_expr
* array
, gfc_expr
* dim
)
1808 return gfc_simplify_bound (array
, dim
, 0);
1813 gfc_simplify_len (gfc_expr
* e
)
1817 if (e
->expr_type
!= EXPR_CONSTANT
)
1820 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1823 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
1824 return range_check (result
, "LEN");
1829 gfc_simplify_len_trim (gfc_expr
* e
)
1832 int count
, len
, lentrim
, i
;
1834 if (e
->expr_type
!= EXPR_CONSTANT
)
1837 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1840 len
= e
->value
.character
.length
;
1842 for (count
= 0, i
= 1; i
<= len
; i
++)
1843 if (e
->value
.character
.string
[len
- i
] == ' ')
1848 lentrim
= len
- count
;
1850 mpz_set_si (result
->value
.integer
, lentrim
);
1851 return range_check (result
, "LEN_TRIM");
1856 gfc_simplify_lge (gfc_expr
* a
, gfc_expr
* b
)
1859 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1862 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) >= 0,
1868 gfc_simplify_lgt (gfc_expr
* a
, gfc_expr
* b
)
1871 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1874 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) > 0,
1880 gfc_simplify_lle (gfc_expr
* a
, gfc_expr
* b
)
1883 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1886 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) <= 0,
1892 gfc_simplify_llt (gfc_expr
* a
, gfc_expr
* b
)
1895 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1898 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) < 0,
1904 gfc_simplify_log (gfc_expr
* x
)
1909 if (x
->expr_type
!= EXPR_CONSTANT
)
1912 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1914 gfc_set_model_kind (x
->ts
.kind
);
1919 if (mpfr_sgn (x
->value
.real
) <= 0)
1922 ("Argument of LOG at %L cannot be less than or equal to zero",
1924 gfc_free_expr (result
);
1925 return &gfc_bad_expr
;
1928 mpfr_log(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1932 if ((mpfr_sgn (x
->value
.complex.r
) == 0)
1933 && (mpfr_sgn (x
->value
.complex.i
) == 0))
1935 gfc_error ("Complex argument of LOG at %L cannot be zero",
1937 gfc_free_expr (result
);
1938 return &gfc_bad_expr
;
1944 arctangent2 (x
->value
.complex.i
, x
->value
.complex.r
,
1945 result
->value
.complex.i
);
1947 mpfr_mul (xr
, x
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
1948 mpfr_mul (xi
, x
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
1949 mpfr_add (xr
, xr
, xi
, GFC_RND_MODE
);
1950 mpfr_sqrt (xr
, xr
, GFC_RND_MODE
);
1951 mpfr_log (result
->value
.complex.r
, xr
, GFC_RND_MODE
);
1959 gfc_internal_error ("gfc_simplify_log: bad type");
1962 return range_check (result
, "LOG");
1967 gfc_simplify_log10 (gfc_expr
* x
)
1971 if (x
->expr_type
!= EXPR_CONSTANT
)
1974 gfc_set_model_kind (x
->ts
.kind
);
1976 if (mpfr_sgn (x
->value
.real
) <= 0)
1979 ("Argument of LOG10 at %L cannot be less than or equal to zero",
1981 return &gfc_bad_expr
;
1984 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1986 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1988 return range_check (result
, "LOG10");
1993 gfc_simplify_logical (gfc_expr
* e
, gfc_expr
* k
)
1998 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
2000 return &gfc_bad_expr
;
2002 if (e
->expr_type
!= EXPR_CONSTANT
)
2005 result
= gfc_constant_result (BT_LOGICAL
, kind
, &e
->where
);
2007 result
->value
.logical
= e
->value
.logical
;
2013 /* This function is special since MAX() can take any number of
2014 arguments. The simplified expression is a rewritten version of the
2015 argument list containing at most one constant element. Other
2016 constant elements are deleted. Because the argument list has
2017 already been checked, this function always succeeds. sign is 1 for
2018 MAX(), -1 for MIN(). */
2021 simplify_min_max (gfc_expr
* expr
, int sign
)
2023 gfc_actual_arglist
*arg
, *last
, *extremum
;
2024 gfc_intrinsic_sym
* specific
;
2028 specific
= expr
->value
.function
.isym
;
2030 arg
= expr
->value
.function
.actual
;
2032 for (; arg
; last
= arg
, arg
= arg
->next
)
2034 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
2037 if (extremum
== NULL
)
2043 switch (arg
->expr
->ts
.type
)
2046 if (mpz_cmp (arg
->expr
->value
.integer
,
2047 extremum
->expr
->value
.integer
) * sign
> 0)
2048 mpz_set (extremum
->expr
->value
.integer
, arg
->expr
->value
.integer
);
2053 if (mpfr_cmp (arg
->expr
->value
.real
, extremum
->expr
->value
.real
) *
2055 mpfr_set (extremum
->expr
->value
.real
, arg
->expr
->value
.real
,
2061 gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
2064 /* Delete the extra constant argument. */
2066 expr
->value
.function
.actual
= arg
->next
;
2068 last
->next
= arg
->next
;
2071 gfc_free_actual_arglist (arg
);
2075 /* If there is one value left, replace the function call with the
2077 if (expr
->value
.function
.actual
->next
!= NULL
)
2080 /* Convert to the correct type and kind. */
2081 if (expr
->ts
.type
!= BT_UNKNOWN
)
2082 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2083 expr
->ts
.type
, expr
->ts
.kind
);
2085 if (specific
->ts
.type
!= BT_UNKNOWN
)
2086 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2087 specific
->ts
.type
, specific
->ts
.kind
);
2089 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
2094 gfc_simplify_min (gfc_expr
* e
)
2096 return simplify_min_max (e
, -1);
2101 gfc_simplify_max (gfc_expr
* e
)
2103 return simplify_min_max (e
, 1);
2108 gfc_simplify_maxexponent (gfc_expr
* x
)
2113 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2115 result
= gfc_int_expr (gfc_real_kinds
[i
].max_exponent
);
2116 result
->where
= x
->where
;
2123 gfc_simplify_minexponent (gfc_expr
* x
)
2128 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2130 result
= gfc_int_expr (gfc_real_kinds
[i
].min_exponent
);
2131 result
->where
= x
->where
;
2138 gfc_simplify_mod (gfc_expr
* a
, gfc_expr
* p
)
2141 mpfr_t quot
, iquot
, term
;
2143 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2146 result
= gfc_constant_result (a
->ts
.type
, a
->ts
.kind
, &a
->where
);
2151 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2153 /* Result is processor-dependent. */
2154 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
2155 gfc_free_expr (result
);
2156 return &gfc_bad_expr
;
2158 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2162 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2164 /* Result is processor-dependent. */
2165 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
2166 gfc_free_expr (result
);
2167 return &gfc_bad_expr
;
2170 gfc_set_model_kind (a
->ts
.kind
);
2175 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2176 mpfr_trunc (iquot
, quot
);
2177 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2178 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2186 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2189 return range_check (result
, "MOD");
2194 gfc_simplify_modulo (gfc_expr
* a
, gfc_expr
* p
)
2197 mpfr_t quot
, iquot
, term
;
2199 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2202 result
= gfc_constant_result (a
->ts
.type
, a
->ts
.kind
, &a
->where
);
2207 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2209 /* Result is processor-dependent. This processor just opts
2210 to not handle it at all. */
2211 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
2212 gfc_free_expr (result
);
2213 return &gfc_bad_expr
;
2215 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2220 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2222 /* Result is processor-dependent. */
2223 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
2224 gfc_free_expr (result
);
2225 return &gfc_bad_expr
;
2228 gfc_set_model_kind (a
->ts
.kind
);
2233 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2234 mpfr_floor (iquot
, quot
);
2235 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2241 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2245 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2248 return range_check (result
, "MODULO");
2252 /* Exists for the sole purpose of consistency with other intrinsics. */
2254 gfc_simplify_mvbits (gfc_expr
* f ATTRIBUTE_UNUSED
,
2255 gfc_expr
* fp ATTRIBUTE_UNUSED
,
2256 gfc_expr
* l ATTRIBUTE_UNUSED
,
2257 gfc_expr
* to ATTRIBUTE_UNUSED
,
2258 gfc_expr
* tp ATTRIBUTE_UNUSED
)
2265 gfc_simplify_nearest (gfc_expr
* x
, gfc_expr
* s
)
2270 int p
, i
, k
, match_float
;
2272 /* FIXME: This implementation is dopey and probably not quite right,
2273 but it's a start. */
2275 if (x
->expr_type
!= EXPR_CONSTANT
)
2278 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2280 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2282 val
= mpfr_get_d (x
->value
.real
, GFC_RND_MODE
);
2283 p
= gfc_real_kinds
[k
].digits
;
2286 for (i
= 1; i
< p
; ++i
)
2291 /* TODO we should make sure that 'float' matches kind 4 */
2292 match_float
= gfc_real_kinds
[k
].kind
== 4;
2293 if (mpfr_cmp_ui (s
->value
.real
, 0) > 0)
2299 mpfr_set_d (result
->value
.real
, rval
, GFC_RND_MODE
);
2304 mpfr_set_d (result
->value
.real
, val
, GFC_RND_MODE
);
2307 else if (mpfr_cmp_ui (s
->value
.real
, 0) < 0)
2313 mpfr_set_d (result
->value
.real
, rval
, GFC_RND_MODE
);
2318 mpfr_set_d (result
->value
.real
, val
, GFC_RND_MODE
);
2323 gfc_error ("Invalid second argument of NEAREST at %L", &s
->where
);
2325 return &gfc_bad_expr
;
2328 return range_check (result
, "NEAREST");
2333 simplify_nint (const char *name
, gfc_expr
* e
, gfc_expr
* k
)
2335 gfc_expr
*rtrunc
, *itrunc
, *result
;
2339 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
2341 return &gfc_bad_expr
;
2343 if (e
->expr_type
!= EXPR_CONSTANT
)
2346 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
2348 rtrunc
= gfc_copy_expr (e
);
2349 itrunc
= gfc_copy_expr (e
);
2351 cmp
= mpfr_cmp_ui (e
->value
.real
, 0);
2353 gfc_set_model (e
->value
.real
);
2355 mpfr_set_str (half
, "0.5", 10, GFC_RND_MODE
);
2359 mpfr_add (rtrunc
->value
.real
, e
->value
.real
, half
, GFC_RND_MODE
);
2360 mpfr_trunc (itrunc
->value
.real
, rtrunc
->value
.real
);
2364 mpfr_sub (rtrunc
->value
.real
, e
->value
.real
, half
, GFC_RND_MODE
);
2365 mpfr_trunc (itrunc
->value
.real
, rtrunc
->value
.real
);
2368 mpfr_set_ui (itrunc
->value
.real
, 0, GFC_RND_MODE
);
2370 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
);
2372 gfc_free_expr (itrunc
);
2373 gfc_free_expr (rtrunc
);
2376 return range_check (result
, name
);
2381 gfc_simplify_nint (gfc_expr
* e
, gfc_expr
* k
)
2383 return simplify_nint ("NINT", e
, k
);
2388 gfc_simplify_idnint (gfc_expr
* e
)
2390 return simplify_nint ("IDNINT", e
, NULL
);
2395 gfc_simplify_not (gfc_expr
* e
)
2400 if (e
->expr_type
!= EXPR_CONSTANT
)
2403 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2405 mpz_com (result
->value
.integer
, e
->value
.integer
);
2407 /* Because of how GMP handles numbers, the result must be ANDed with
2408 the max_int mask. For radices <> 2, this will require change. */
2410 i
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
2412 mpz_and (result
->value
.integer
, result
->value
.integer
,
2413 gfc_integer_kinds
[i
].max_int
);
2415 return range_check (result
, "NOT");
2420 gfc_simplify_null (gfc_expr
* mold
)
2424 result
= gfc_get_expr ();
2425 result
->expr_type
= EXPR_NULL
;
2428 result
->ts
.type
= BT_UNKNOWN
;
2431 result
->ts
= mold
->ts
;
2432 result
->where
= mold
->where
;
2440 gfc_simplify_precision (gfc_expr
* e
)
2445 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2447 result
= gfc_int_expr (gfc_real_kinds
[i
].precision
);
2448 result
->where
= e
->where
;
2455 gfc_simplify_radix (gfc_expr
* e
)
2460 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2464 i
= gfc_integer_kinds
[i
].radix
;
2468 i
= gfc_real_kinds
[i
].radix
;
2475 result
= gfc_int_expr (i
);
2476 result
->where
= e
->where
;
2483 gfc_simplify_range (gfc_expr
* e
)
2489 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2494 j
= gfc_integer_kinds
[i
].range
;
2499 j
= gfc_real_kinds
[i
].range
;
2506 result
= gfc_int_expr (j
);
2507 result
->where
= e
->where
;
2514 gfc_simplify_real (gfc_expr
* e
, gfc_expr
* k
)
2519 if (e
->ts
.type
== BT_COMPLEX
)
2520 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
2522 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
2525 return &gfc_bad_expr
;
2527 if (e
->expr_type
!= EXPR_CONSTANT
)
2533 result
= gfc_int2real (e
, kind
);
2537 result
= gfc_real2real (e
, kind
);
2541 result
= gfc_complex2real (e
, kind
);
2545 gfc_internal_error ("bad type in REAL");
2549 return range_check (result
, "REAL");
2553 gfc_simplify_repeat (gfc_expr
* e
, gfc_expr
* n
)
2556 int i
, j
, len
, ncopies
, nlen
;
2558 if (e
->expr_type
!= EXPR_CONSTANT
|| n
->expr_type
!= EXPR_CONSTANT
)
2561 if (n
!= NULL
&& (gfc_extract_int (n
, &ncopies
) != NULL
|| ncopies
< 0))
2563 gfc_error ("Invalid second argument of REPEAT at %L", &n
->where
);
2564 return &gfc_bad_expr
;
2567 len
= e
->value
.character
.length
;
2568 nlen
= ncopies
* len
;
2570 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
2574 result
->value
.character
.string
= gfc_getmem (1);
2575 result
->value
.character
.length
= 0;
2576 result
->value
.character
.string
[0] = '\0';
2580 result
->value
.character
.length
= nlen
;
2581 result
->value
.character
.string
= gfc_getmem (nlen
+ 1);
2583 for (i
= 0; i
< ncopies
; i
++)
2584 for (j
= 0; j
< len
; j
++)
2585 result
->value
.character
.string
[j
+ i
* len
] =
2586 e
->value
.character
.string
[j
];
2588 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
2593 /* This one is a bear, but mainly has to do with shuffling elements. */
2596 gfc_simplify_reshape (gfc_expr
* source
, gfc_expr
* shape_exp
,
2597 gfc_expr
* pad
, gfc_expr
* order_exp
)
2600 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
2601 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
2602 gfc_constructor
*head
, *tail
;
2608 /* Unpack the shape array. */
2609 if (source
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (source
))
2612 if (shape_exp
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (shape_exp
))
2616 && (pad
->expr_type
!= EXPR_ARRAY
2617 || !gfc_is_constant_expr (pad
)))
2620 if (order_exp
!= NULL
2621 && (order_exp
->expr_type
!= EXPR_ARRAY
2622 || !gfc_is_constant_expr (order_exp
)))
2631 e
= gfc_get_array_element (shape_exp
, rank
);
2635 if (gfc_extract_int (e
, &shape
[rank
]) != NULL
)
2637 gfc_error ("Integer too large in shape specification at %L",
2645 if (rank
>= GFC_MAX_DIMENSIONS
)
2647 gfc_error ("Too many dimensions in shape specification for RESHAPE "
2648 "at %L", &e
->where
);
2653 if (shape
[rank
] < 0)
2655 gfc_error ("Shape specification at %L cannot be negative",
2665 gfc_error ("Shape specification at %L cannot be the null array",
2670 /* Now unpack the order array if present. */
2671 if (order_exp
== NULL
)
2673 for (i
= 0; i
< rank
; i
++)
2680 for (i
= 0; i
< rank
; i
++)
2683 for (i
= 0; i
< rank
; i
++)
2685 e
= gfc_get_array_element (order_exp
, i
);
2689 ("ORDER parameter of RESHAPE at %L is not the same size "
2690 "as SHAPE parameter", &order_exp
->where
);
2694 if (gfc_extract_int (e
, &order
[i
]) != NULL
)
2696 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
2704 if (order
[i
] < 1 || order
[i
] > rank
)
2706 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
2715 gfc_error ("Invalid permutation in ORDER parameter at %L",
2724 /* Count the elements in the source and padding arrays. */
2729 gfc_array_size (pad
, &size
);
2730 npad
= mpz_get_ui (size
);
2734 gfc_array_size (source
, &size
);
2735 nsource
= mpz_get_ui (size
);
2738 /* If it weren't for that pesky permutation we could just loop
2739 through the source and round out any shortage with pad elements.
2740 But no, someone just had to have the compiler do something the
2741 user should be doing. */
2743 for (i
= 0; i
< rank
; i
++)
2748 /* Figure out which element to extract. */
2749 mpz_set_ui (index
, 0);
2751 for (i
= rank
- 1; i
>= 0; i
--)
2753 mpz_add_ui (index
, index
, x
[order
[i
]]);
2755 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
2758 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
2759 gfc_internal_error ("Reshaped array too large at %L", &e
->where
);
2761 j
= mpz_get_ui (index
);
2764 e
= gfc_get_array_element (source
, j
);
2772 ("PAD parameter required for short SOURCE parameter at %L",
2778 e
= gfc_get_array_element (pad
, j
);
2782 head
= tail
= gfc_get_constructor ();
2785 tail
->next
= gfc_get_constructor ();
2792 tail
->where
= e
->where
;
2795 /* Calculate the next element. */
2799 if (++x
[i
] < shape
[i
])
2810 e
= gfc_get_expr ();
2811 e
->where
= source
->where
;
2812 e
->expr_type
= EXPR_ARRAY
;
2813 e
->value
.constructor
= head
;
2814 e
->shape
= gfc_get_shape (rank
);
2816 for (i
= 0; i
< rank
; i
++)
2817 mpz_init_set_ui (e
->shape
[i
], shape
[i
]);
2819 e
->ts
= head
->expr
->ts
;
2825 gfc_free_constructor (head
);
2827 return &gfc_bad_expr
;
2832 gfc_simplify_rrspacing (gfc_expr
* x
)
2835 mpfr_t absv
, log2
, exp
, frac
, pow2
;
2838 if (x
->expr_type
!= EXPR_CONSTANT
)
2841 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2843 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
2845 p
= gfc_real_kinds
[i
].digits
;
2847 gfc_set_model_kind (x
->ts
.kind
);
2849 if (mpfr_sgn (x
->value
.real
) == 0)
2851 mpfr_ui_div (result
->value
.real
, 1, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
2860 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
2861 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
2863 mpfr_trunc (log2
, log2
);
2864 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
2866 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
2867 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
2869 mpfr_mul_2exp (result
->value
.real
, frac
, (unsigned long)p
, GFC_RND_MODE
);
2876 return range_check (result
, "RRSPACING");
2881 gfc_simplify_scale (gfc_expr
* x
, gfc_expr
* i
)
2883 int k
, neg_flag
, power
, exp_range
;
2884 mpfr_t scale
, radix
;
2887 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
2890 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
2892 if (mpfr_sgn (x
->value
.real
) == 0)
2894 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2898 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2900 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
2902 /* This check filters out values of i that would overflow an int. */
2903 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
2904 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
2906 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
2907 return &gfc_bad_expr
;
2910 /* Compute scale = radix ** power. */
2911 power
= mpz_get_si (i
->value
.integer
);
2921 gfc_set_model_kind (x
->ts
.kind
);
2924 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
2925 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
2928 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
2930 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
2935 return range_check (result
, "SCALE");
2940 gfc_simplify_scan (gfc_expr
* e
, gfc_expr
* c
, gfc_expr
* b
)
2945 size_t indx
, len
, lenc
;
2947 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
)
2950 if (b
!= NULL
&& b
->value
.logical
!= 0)
2955 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
2958 len
= e
->value
.character
.length
;
2959 lenc
= c
->value
.character
.length
;
2961 if (len
== 0 || lenc
== 0)
2970 strcspn (e
->value
.character
.string
, c
->value
.character
.string
) + 1;
2977 for (indx
= len
; indx
> 0; indx
--)
2979 for (i
= 0; i
< lenc
; i
++)
2981 if (c
->value
.character
.string
[i
]
2982 == e
->value
.character
.string
[indx
- 1])
2990 mpz_set_ui (result
->value
.integer
, indx
);
2991 return range_check (result
, "SCAN");
2996 gfc_simplify_selected_int_kind (gfc_expr
* e
)
3001 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
3006 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
3007 if (gfc_integer_kinds
[i
].range
>= range
3008 && gfc_integer_kinds
[i
].kind
< kind
)
3009 kind
= gfc_integer_kinds
[i
].kind
;
3011 if (kind
== INT_MAX
)
3014 result
= gfc_int_expr (kind
);
3015 result
->where
= e
->where
;
3022 gfc_simplify_selected_real_kind (gfc_expr
* p
, gfc_expr
* q
)
3024 int range
, precision
, i
, kind
, found_precision
, found_range
;
3031 if (p
->expr_type
!= EXPR_CONSTANT
3032 || gfc_extract_int (p
, &precision
) != NULL
)
3040 if (q
->expr_type
!= EXPR_CONSTANT
3041 || gfc_extract_int (q
, &range
) != NULL
)
3046 found_precision
= 0;
3049 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
3051 if (gfc_real_kinds
[i
].precision
>= precision
)
3052 found_precision
= 1;
3054 if (gfc_real_kinds
[i
].range
>= range
)
3057 if (gfc_real_kinds
[i
].precision
>= precision
3058 && gfc_real_kinds
[i
].range
>= range
&& gfc_real_kinds
[i
].kind
< kind
)
3059 kind
= gfc_real_kinds
[i
].kind
;
3062 if (kind
== INT_MAX
)
3066 if (!found_precision
)
3072 result
= gfc_int_expr (kind
);
3073 result
->where
= (p
!= NULL
) ? p
->where
: q
->where
;
3080 gfc_simplify_set_exponent (gfc_expr
* x
, gfc_expr
* i
)
3083 mpfr_t exp
, absv
, log2
, pow2
, frac
;
3086 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3089 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3091 gfc_set_model_kind (x
->ts
.kind
);
3093 if (mpfr_sgn (x
->value
.real
) == 0)
3095 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3105 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3106 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3108 mpfr_trunc (log2
, log2
);
3109 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
3111 /* Old exponent value, and fraction. */
3112 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3114 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
3117 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
3118 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
3125 return range_check (result
, "SET_EXPONENT");
3130 gfc_simplify_shape (gfc_expr
* source
)
3132 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3133 gfc_expr
*result
, *e
, *f
;
3138 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3141 result
= gfc_start_constructor (BT_INTEGER
, gfc_default_integer_kind
,
3144 ar
= gfc_find_array_ref (source
);
3146 t
= gfc_array_ref_shape (ar
, shape
);
3148 for (n
= 0; n
< source
->rank
; n
++)
3150 e
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3155 mpz_set (e
->value
.integer
, shape
[n
]);
3156 mpz_clear (shape
[n
]);
3160 mpz_set_ui (e
->value
.integer
, n
+ 1);
3162 f
= gfc_simplify_size (source
, e
);
3166 gfc_free_expr (result
);
3175 gfc_append_constructor (result
, e
);
3183 gfc_simplify_size (gfc_expr
* array
, gfc_expr
* dim
)
3191 if (gfc_array_size (array
, &size
) == FAILURE
)
3196 if (dim
->expr_type
!= EXPR_CONSTANT
)
3199 d
= mpz_get_ui (dim
->value
.integer
) - 1;
3200 if (gfc_array_dimen_size (array
, d
, &size
) == FAILURE
)
3204 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3207 mpz_set (result
->value
.integer
, size
);
3214 gfc_simplify_sign (gfc_expr
* x
, gfc_expr
* y
)
3218 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3221 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3226 mpz_abs (result
->value
.integer
, x
->value
.integer
);
3227 if (mpz_sgn (y
->value
.integer
) < 0)
3228 mpz_neg (result
->value
.integer
, result
->value
.integer
);
3233 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3235 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3236 if (mpfr_sgn (y
->value
.real
) < 0)
3237 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
3242 gfc_internal_error ("Bad type in gfc_simplify_sign");
3250 gfc_simplify_sin (gfc_expr
* x
)
3255 if (x
->expr_type
!= EXPR_CONSTANT
)
3258 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3263 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3267 gfc_set_model (x
->value
.real
);
3271 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3272 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3273 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
3275 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3276 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3277 mpfr_mul (result
->value
.complex.i
, xp
, xq
, GFC_RND_MODE
);
3284 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3287 return range_check (result
, "SIN");
3292 gfc_simplify_sinh (gfc_expr
* x
)
3296 if (x
->expr_type
!= EXPR_CONSTANT
)
3299 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3301 mpfr_sinh(result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3303 return range_check (result
, "SINH");
3307 /* The argument is always a double precision real that is converted to
3308 single precision. TODO: Rounding! */
3311 gfc_simplify_sngl (gfc_expr
* a
)
3315 if (a
->expr_type
!= EXPR_CONSTANT
)
3318 result
= gfc_real2real (a
, gfc_default_real_kind
);
3319 return range_check (result
, "SNGL");
3324 gfc_simplify_spacing (gfc_expr
* x
)
3331 if (x
->expr_type
!= EXPR_CONSTANT
)
3334 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3336 p
= gfc_real_kinds
[i
].digits
;
3338 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3340 gfc_set_model_kind (x
->ts
.kind
);
3342 if (mpfr_sgn (x
->value
.real
) == 0)
3344 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3351 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3352 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3353 mpfr_trunc (log2
, log2
);
3355 mpfr_add_ui (log2
, log2
, 1, GFC_RND_MODE
);
3357 /* FIXME: We should be using mpfr_get_si here, but this function is
3358 not available with the version of mpfr distributed with gmp (as of
3359 2004-09-17). Replace once mpfr has been imported into the gcc cvs
3361 diff
= (long)mpfr_get_d (log2
, GFC_RND_MODE
) - (long)p
;
3362 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
3363 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, diff
, GFC_RND_MODE
);
3368 if (mpfr_cmp (result
->value
.real
, gfc_real_kinds
[i
].tiny
) < 0)
3369 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3371 return range_check (result
, "SPACING");
3376 gfc_simplify_sqrt (gfc_expr
* e
)
3379 mpfr_t ac
, ad
, s
, t
, w
;
3381 if (e
->expr_type
!= EXPR_CONSTANT
)
3384 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3389 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
3391 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
3396 /* Formula taken from Numerical Recipes to avoid over- and
3399 gfc_set_model (e
->value
.real
);
3406 if (mpfr_cmp_ui (e
->value
.complex.r
, 0) == 0
3407 && mpfr_cmp_ui (e
->value
.complex.i
, 0) == 0)
3410 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
3411 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
3415 mpfr_abs (ac
, e
->value
.complex.r
, GFC_RND_MODE
);
3416 mpfr_abs (ad
, e
->value
.complex.i
, GFC_RND_MODE
);
3418 if (mpfr_cmp (ac
, ad
) >= 0)
3420 mpfr_div (t
, e
->value
.complex.i
, e
->value
.complex.r
, GFC_RND_MODE
);
3421 mpfr_mul (t
, t
, t
, GFC_RND_MODE
);
3422 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3423 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3424 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3425 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3426 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3427 mpfr_sqrt (s
, ac
, GFC_RND_MODE
);
3428 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3432 mpfr_div (s
, e
->value
.complex.r
, e
->value
.complex.i
, GFC_RND_MODE
);
3433 mpfr_mul (t
, s
, s
, GFC_RND_MODE
);
3434 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3435 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3436 mpfr_abs (s
, s
, GFC_RND_MODE
);
3437 mpfr_add (t
, t
, s
, GFC_RND_MODE
);
3438 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3439 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3440 mpfr_sqrt (s
, ad
, GFC_RND_MODE
);
3441 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3444 if (mpfr_cmp_ui (w
, 0) != 0 && mpfr_cmp_ui (e
->value
.complex.r
, 0) >= 0)
3446 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3447 mpfr_div (result
->value
.complex.i
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3448 mpfr_set (result
->value
.complex.r
, w
, GFC_RND_MODE
);
3450 else if (mpfr_cmp_ui (w
, 0) != 0
3451 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3452 && mpfr_cmp_ui (e
->value
.complex.i
, 0) >= 0)
3454 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3455 mpfr_div (result
->value
.complex.r
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3456 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3458 else if (mpfr_cmp_ui (w
, 0) != 0
3459 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3460 && mpfr_cmp_ui (e
->value
.complex.i
, 0) < 0)
3462 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3463 mpfr_div (result
->value
.complex.r
, ad
, t
, GFC_RND_MODE
);
3464 mpfr_neg (w
, w
, GFC_RND_MODE
);
3465 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3468 gfc_internal_error ("invalid complex argument of SQRT at %L",
3480 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
3483 return range_check (result
, "SQRT");
3486 gfc_free_expr (result
);
3487 gfc_error ("Argument of SQRT at %L has a negative value", &e
->where
);
3488 return &gfc_bad_expr
;
3493 gfc_simplify_tan (gfc_expr
* x
)
3498 if (x
->expr_type
!= EXPR_CONSTANT
)
3501 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3503 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3505 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3507 return range_check (result
, "TAN");
3512 gfc_simplify_tanh (gfc_expr
* x
)
3516 if (x
->expr_type
!= EXPR_CONSTANT
)
3519 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3521 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3523 return range_check (result
, "TANH");
3529 gfc_simplify_tiny (gfc_expr
* e
)
3534 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
3536 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
3537 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3544 gfc_simplify_trim (gfc_expr
* e
)
3547 int count
, i
, len
, lentrim
;
3549 if (e
->expr_type
!= EXPR_CONSTANT
)
3552 len
= e
->value
.character
.length
;
3554 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
3556 for (count
= 0, i
= 1; i
<= len
; ++i
)
3558 if (e
->value
.character
.string
[len
- i
] == ' ')
3564 lentrim
= len
- count
;
3566 result
->value
.character
.length
= lentrim
;
3567 result
->value
.character
.string
= gfc_getmem (lentrim
+ 1);
3569 for (i
= 0; i
< lentrim
; i
++)
3570 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
3572 result
->value
.character
.string
[lentrim
] = '\0'; /* For debugger */
3579 gfc_simplify_ubound (gfc_expr
* array
, gfc_expr
* dim
)
3581 return gfc_simplify_bound (array
, dim
, 1);
3586 gfc_simplify_verify (gfc_expr
* s
, gfc_expr
* set
, gfc_expr
* b
)
3590 size_t index
, len
, lenset
;
3593 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
)
3596 if (b
!= NULL
&& b
->value
.logical
!= 0)
3601 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3604 len
= s
->value
.character
.length
;
3605 lenset
= set
->value
.character
.length
;
3609 mpz_set_ui (result
->value
.integer
, 0);
3617 mpz_set_ui (result
->value
.integer
, len
);
3622 strspn (s
->value
.character
.string
, set
->value
.character
.string
) + 1;
3631 mpz_set_ui (result
->value
.integer
, 1);
3634 for (index
= len
; index
> 0; index
--)
3636 for (i
= 0; i
< lenset
; i
++)
3638 if (s
->value
.character
.string
[index
- 1]
3639 == set
->value
.character
.string
[i
])
3647 mpz_set_ui (result
->value
.integer
, index
);
3651 /****************** Constant simplification *****************/
3653 /* Master function to convert one constant to another. While this is
3654 used as a simplification function, it requires the destination type
3655 and kind information which is supplied by a special case in
3659 gfc_convert_constant (gfc_expr
* e
, bt type
, int kind
)
3661 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
3662 gfc_constructor
*head
, *c
, *tail
= NULL
;
3676 f
= gfc_int2complex
;
3693 f
= gfc_real2complex
;
3704 f
= gfc_complex2int
;
3707 f
= gfc_complex2real
;
3710 f
= gfc_complex2complex
;
3719 if (type
!= BT_LOGICAL
)
3726 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
3731 switch (e
->expr_type
)
3734 result
= f (e
, kind
);
3736 return &gfc_bad_expr
;
3740 if (!gfc_is_constant_expr (e
))
3745 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
3748 head
= tail
= gfc_get_constructor ();
3751 tail
->next
= gfc_get_constructor ();
3755 tail
->where
= c
->where
;
3757 if (c
->iterator
== NULL
)
3758 tail
->expr
= f (c
->expr
, kind
);
3761 g
= gfc_convert_constant (c
->expr
, type
, kind
);
3762 if (g
== &gfc_bad_expr
)
3767 if (tail
->expr
== NULL
)
3769 gfc_free_constructor (head
);
3774 result
= gfc_get_expr ();
3775 result
->ts
.type
= type
;
3776 result
->ts
.kind
= kind
;
3777 result
->expr_type
= EXPR_ARRAY
;
3778 result
->value
.constructor
= head
;
3779 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
3780 result
->where
= e
->where
;
3781 result
->rank
= e
->rank
;
3792 /****************** Helper functions ***********************/
3794 /* Given a collating table, create the inverse table. */
3797 invert_table (const int *table
, int *xtable
)
3801 for (i
= 0; i
< 256; i
++)
3804 for (i
= 0; i
< 256; i
++)
3805 xtable
[table
[i
]] = i
;
3810 gfc_simplify_init_1 (void)
3813 invert_table (ascii_table
, xascii_table
);