]>
gcc.gnu.org Git - gcc.git/blob - gcc/fortran/simplify.c
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
31 #include "intrinsic.h"
33 static mpf_t mpf_zero
, mpf_half
, mpf_one
;
34 static mpz_t mpz_zero
;
36 gfc_expr gfc_bad_expr
;
39 /* Note that 'simplification' is not just transforming expressions.
40 For functions that are not simplified at compile time, range
41 checking is done if possible.
43 The return convention is that each simplification function returns:
45 A new expression node corresponding to the simplified arguments.
46 The original arguments are destroyed by the caller, and must not
47 be a part of the new expression.
49 NULL pointer indicating that no simplification was possible and
50 the original expression should remain intact. If the
51 simplification function sets the type and/or the function name
52 via the pointer gfc_simple_expression, then this type is
55 An expression pointer to gfc_bad_expr (a static placeholder)
56 indicating that some error has prevented simplification. For
57 example, sqrt(-1.0). The error is generated within the function
58 and should be propagated upwards
60 By the time a simplification function gets control, it has been
61 decided that the function call is really supposed to be the
62 intrinsic. No type checking is strictly necessary, since only
63 valid types will be passed on. On the other hand, a simplification
64 subroutine may have to look at the type of an argument as part of
67 Array arguments are never passed to these subroutines.
69 The functions in this file don't have much comment with them, but
70 everything is reasonably straight-forward. The Standard, chapter 13
71 is the best comment you'll find for this file anyway. */
73 /* Static table for converting non-ascii character sets to ascii.
74 The xascii_table[] is the inverse table. */
76 static int ascii_table
[256] = {
77 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
78 '\b', '\t', '\n', '\v', '\0', '\r', '\0', '\0',
79 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
80 '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0',
81 ' ', '!', '\'', '#', '$', '%', '&', '\'',
82 '(', ')', '*', '+', ',', '-', '.', '/',
83 '0', '1', '2', '3', '4', '5', '6', '7',
84 '8', '9', ':', ';', '<', '=', '>', '?',
85 '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
86 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
87 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
88 'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
89 '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
90 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
91 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
92 'x', 'y', 'z', '{', '|', '}', '~', '\?'
95 static int xascii_table
[256];
98 /* Range checks an expression node. If all goes well, returns the
99 node, otherwise returns &gfc_bad_expr and frees the node. */
102 range_check (gfc_expr
* result
, const char *name
)
105 if (gfc_range_check (result
) == ARITH_OK
)
108 gfc_error ("Result of %s overflows its kind at %L", name
, &result
->where
);
109 gfc_free_expr (result
);
110 return &gfc_bad_expr
;
114 /* A helper function that gets an optional and possibly missing
115 kind parameter. Returns the kind, -1 if something went wrong. */
118 get_kind (bt type
, gfc_expr
* k
, const char *name
, int default_kind
)
125 if (k
->expr_type
!= EXPR_CONSTANT
)
127 gfc_error ("KIND parameter of %s at %L must be an initialization "
128 "expression", name
, &k
->where
);
133 if (gfc_extract_int (k
, &kind
) != NULL
134 || gfc_validate_kind (type
, kind
) == -1)
137 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
145 /********************** Simplification functions *****************************/
148 gfc_simplify_abs (gfc_expr
* e
)
153 if (e
->expr_type
!= EXPR_CONSTANT
)
159 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
161 mpz_abs (result
->value
.integer
, e
->value
.integer
);
163 result
= range_check (result
, "IABS");
167 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
169 mpf_abs (result
->value
.real
, e
->value
.real
);
171 result
= range_check (result
, "ABS");
175 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
178 mpf_mul (a
, e
->value
.complex.r
, e
->value
.complex.r
);
181 mpf_mul (b
, e
->value
.complex.i
, e
->value
.complex.i
);
184 mpf_sqrt (result
->value
.real
, a
);
189 result
= range_check (result
, "CABS");
193 gfc_internal_error ("gfc_simplify_abs(): Bad type");
201 gfc_simplify_achar (gfc_expr
* e
)
206 if (e
->expr_type
!= EXPR_CONSTANT
)
209 /* We cannot assume that the native character set is ASCII in this
211 if (gfc_extract_int (e
, &index
) != NULL
|| index
< 0 || index
> 127)
213 gfc_error ("Extended ASCII not implemented: argument of ACHAR at %L "
214 "must be between 0 and 127", &e
->where
);
215 return &gfc_bad_expr
;
218 result
= gfc_constant_result (BT_CHARACTER
, gfc_default_character_kind (),
221 result
->value
.character
.string
= gfc_getmem (2);
223 result
->value
.character
.length
= 1;
224 result
->value
.character
.string
[0] = ascii_table
[index
];
225 result
->value
.character
.string
[1] = '\0'; /* For debugger */
231 gfc_simplify_acos (gfc_expr
* x
)
234 mpf_t negative
, square
, term
;
236 if (x
->expr_type
!= EXPR_CONSTANT
)
239 if (mpf_cmp_si (x
->value
.real
, 1) > 0 || mpf_cmp_si (x
->value
.real
, -1) < 0)
241 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
243 return &gfc_bad_expr
;
246 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
248 if (mpf_cmp_si (x
->value
.real
, 1) == 0)
250 mpf_set_ui (result
->value
.real
, 0);
251 return range_check (result
, "ACOS");
254 if (mpf_cmp_si (x
->value
.real
, -1) == 0)
256 mpf_set (result
->value
.real
, pi
);
257 return range_check (result
, "ACOS");
264 mpf_pow_ui (square
, x
->value
.real
, 2);
265 mpf_ui_sub (term
, 1, square
);
266 mpf_sqrt (term
, term
);
267 mpf_div (term
, x
->value
.real
, term
);
268 mpf_neg (term
, term
);
269 arctangent (&term
, &negative
);
270 mpf_add (result
->value
.real
, half_pi
, negative
);
272 mpf_clear (negative
);
276 return range_check (result
, "ACOS");
281 gfc_simplify_adjustl (gfc_expr
* e
)
287 if (e
->expr_type
!= EXPR_CONSTANT
)
290 len
= e
->value
.character
.length
;
292 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
294 result
->value
.character
.length
= len
;
295 result
->value
.character
.string
= gfc_getmem (len
+ 1);
297 for (count
= 0, i
= 0; i
< len
; ++i
)
299 ch
= e
->value
.character
.string
[i
];
305 for (i
= 0; i
< len
- count
; ++i
)
307 result
->value
.character
.string
[i
] =
308 e
->value
.character
.string
[count
+ i
];
311 for (i
= len
- count
; i
< len
; ++i
)
313 result
->value
.character
.string
[i
] = ' ';
316 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
323 gfc_simplify_adjustr (gfc_expr
* e
)
329 if (e
->expr_type
!= EXPR_CONSTANT
)
332 len
= e
->value
.character
.length
;
334 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
336 result
->value
.character
.length
= len
;
337 result
->value
.character
.string
= gfc_getmem (len
+ 1);
339 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
341 ch
= e
->value
.character
.string
[i
];
347 for (i
= 0; i
< count
; ++i
)
349 result
->value
.character
.string
[i
] = ' ';
352 for (i
= count
; i
< len
; ++i
)
354 result
->value
.character
.string
[i
] =
355 e
->value
.character
.string
[i
- count
];
358 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
365 gfc_simplify_aimag (gfc_expr
* e
)
369 if (e
->expr_type
!= EXPR_CONSTANT
)
372 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
373 mpf_set (result
->value
.real
, e
->value
.complex.i
);
375 return range_check (result
, "AIMAG");
380 gfc_simplify_aint (gfc_expr
* e
, gfc_expr
* k
)
382 gfc_expr
*rtrunc
, *result
;
385 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
387 return &gfc_bad_expr
;
389 if (e
->expr_type
!= EXPR_CONSTANT
)
392 rtrunc
= gfc_copy_expr (e
);
394 mpf_trunc (rtrunc
->value
.real
, e
->value
.real
);
396 result
= gfc_real2real (rtrunc
, kind
);
397 gfc_free_expr (rtrunc
);
399 return range_check (result
, "AINT");
404 gfc_simplify_dint (gfc_expr
* e
)
406 gfc_expr
*rtrunc
, *result
;
408 if (e
->expr_type
!= EXPR_CONSTANT
)
411 rtrunc
= gfc_copy_expr (e
);
413 mpf_trunc (rtrunc
->value
.real
, e
->value
.real
);
415 result
= gfc_real2real (rtrunc
, gfc_default_double_kind ());
416 gfc_free_expr (rtrunc
);
418 return range_check (result
, "DINT");
424 gfc_simplify_anint (gfc_expr
* e
, gfc_expr
* k
)
426 gfc_expr
*rtrunc
, *result
;
429 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
431 return &gfc_bad_expr
;
433 if (e
->expr_type
!= EXPR_CONSTANT
)
436 result
= gfc_constant_result (e
->ts
.type
, kind
, &e
->where
);
438 rtrunc
= gfc_copy_expr (e
);
440 cmp
= mpf_cmp_ui (e
->value
.real
, 0);
444 mpf_add (rtrunc
->value
.real
, e
->value
.real
, mpf_half
);
445 mpf_trunc (result
->value
.real
, rtrunc
->value
.real
);
449 mpf_sub (rtrunc
->value
.real
, e
->value
.real
, mpf_half
);
450 mpf_trunc (result
->value
.real
, rtrunc
->value
.real
);
453 mpf_set_ui (result
->value
.real
, 0);
455 gfc_free_expr (rtrunc
);
457 return range_check (result
, "ANINT");
462 gfc_simplify_dnint (gfc_expr
* e
)
464 gfc_expr
*rtrunc
, *result
;
467 if (e
->expr_type
!= EXPR_CONSTANT
)
471 gfc_constant_result (BT_REAL
, gfc_default_double_kind (), &e
->where
);
473 rtrunc
= gfc_copy_expr (e
);
475 cmp
= mpf_cmp_ui (e
->value
.real
, 0);
479 mpf_add (rtrunc
->value
.real
, e
->value
.real
, mpf_half
);
480 mpf_trunc (result
->value
.real
, rtrunc
->value
.real
);
484 mpf_sub (rtrunc
->value
.real
, e
->value
.real
, mpf_half
);
485 mpf_trunc (result
->value
.real
, rtrunc
->value
.real
);
488 mpf_set_ui (result
->value
.real
, 0);
490 gfc_free_expr (rtrunc
);
492 return range_check (result
, "DNINT");
497 gfc_simplify_asin (gfc_expr
* x
)
500 mpf_t negative
, square
, term
;
502 if (x
->expr_type
!= EXPR_CONSTANT
)
505 if (mpf_cmp_si (x
->value
.real
, 1) > 0 || mpf_cmp_si (x
->value
.real
, -1) < 0)
507 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
509 return &gfc_bad_expr
;
512 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
514 if (mpf_cmp_si (x
->value
.real
, 1) == 0)
516 mpf_set (result
->value
.real
, half_pi
);
517 return range_check (result
, "ASIN");
520 if (mpf_cmp_si (x
->value
.real
, -1) == 0)
523 mpf_neg (negative
, half_pi
);
524 mpf_set (result
->value
.real
, negative
);
525 mpf_clear (negative
);
526 return range_check (result
, "ASIN");
532 mpf_pow_ui (square
, x
->value
.real
, 2);
533 mpf_ui_sub (term
, 1, square
);
534 mpf_sqrt (term
, term
);
535 mpf_div (term
, x
->value
.real
, term
);
536 arctangent (&term
, &result
->value
.real
);
541 return range_check (result
, "ASIN");
546 gfc_simplify_atan (gfc_expr
* x
)
550 if (x
->expr_type
!= EXPR_CONSTANT
)
553 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
555 arctangent (&x
->value
.real
, &result
->value
.real
);
557 return range_check (result
, "ATAN");
563 gfc_simplify_atan2 (gfc_expr
* y
, gfc_expr
* x
)
567 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
570 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
573 if (mpf_sgn (y
->value
.real
) == 0 && mpf_sgn (x
->value
.real
) == 0)
576 ("If first argument of ATAN2 %L is zero, the second argument "
577 "must not be zero", &x
->where
);
578 gfc_free_expr (result
);
579 return &gfc_bad_expr
;
582 arctangent2 (&y
->value
.real
, &x
->value
.real
, &result
->value
.real
);
584 return range_check (result
, "ATAN2");
590 gfc_simplify_bit_size (gfc_expr
* e
)
595 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
);
597 gfc_internal_error ("In gfc_simplify_bit_size(): Bad kind");
599 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
600 mpz_set_ui (result
->value
.integer
, gfc_integer_kinds
[i
].bit_size
);
607 gfc_simplify_btest (gfc_expr
* e
, gfc_expr
* bit
)
611 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
614 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
615 return gfc_logical_expr (0, &e
->where
);
617 return gfc_logical_expr (mpz_tstbit (e
->value
.integer
, b
), &e
->where
);
622 gfc_simplify_ceiling (gfc_expr
* e
, gfc_expr
* k
)
624 gfc_expr
*ceil
, *result
;
627 kind
= get_kind (BT_REAL
, k
, "CEILING", gfc_default_real_kind ());
629 return &gfc_bad_expr
;
631 if (e
->expr_type
!= EXPR_CONSTANT
)
634 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
636 ceil
= gfc_copy_expr (e
);
638 mpf_ceil (ceil
->value
.real
, e
->value
.real
);
639 mpz_set_f (result
->value
.integer
, ceil
->value
.real
);
641 gfc_free_expr (ceil
);
643 return range_check (result
, "CEILING");
648 gfc_simplify_char (gfc_expr
* e
, gfc_expr
* k
)
653 kind
= get_kind (BT_CHARACTER
, k
, "CHAR", gfc_default_character_kind ());
655 return &gfc_bad_expr
;
657 if (e
->expr_type
!= EXPR_CONSTANT
)
660 if (gfc_extract_int (e
, &c
) != NULL
|| c
< 0 || c
> 255)
662 gfc_error ("Bad character in CHAR function at %L", &e
->where
);
663 return &gfc_bad_expr
;
666 result
= gfc_constant_result (BT_CHARACTER
, kind
, &e
->where
);
668 result
->value
.character
.length
= 1;
669 result
->value
.character
.string
= gfc_getmem (2);
671 result
->value
.character
.string
[0] = c
;
672 result
->value
.character
.string
[1] = '\0'; /* For debugger */
678 /* Common subroutine for simplifying CMPLX and DCMPLX. */
681 simplify_cmplx (const char *name
, gfc_expr
* x
, gfc_expr
* y
, int kind
)
685 result
= gfc_constant_result (BT_COMPLEX
, kind
, &x
->where
);
687 mpf_set_ui (result
->value
.complex.i
, 0);
692 mpf_set_z (result
->value
.complex.r
, x
->value
.integer
);
696 mpf_set (result
->value
.complex.r
, x
->value
.real
);
700 mpf_set (result
->value
.complex.r
, x
->value
.complex.r
);
701 mpf_set (result
->value
.complex.i
, x
->value
.complex.i
);
705 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
713 mpf_set_z (result
->value
.complex.i
, y
->value
.integer
);
717 mpf_set (result
->value
.complex.i
, y
->value
.real
);
721 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
725 return range_check (result
, name
);
730 gfc_simplify_cmplx (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* k
)
734 if (x
->expr_type
!= EXPR_CONSTANT
735 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
738 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_real_kind ());
740 return &gfc_bad_expr
;
742 return simplify_cmplx ("CMPLX", x
, y
, kind
);
747 gfc_simplify_conjg (gfc_expr
* e
)
751 if (e
->expr_type
!= EXPR_CONSTANT
)
754 result
= gfc_copy_expr (e
);
755 mpf_neg (result
->value
.complex.i
, result
->value
.complex.i
);
757 return range_check (result
, "CONJG");
762 gfc_simplify_cos (gfc_expr
* x
)
767 if (x
->expr_type
!= EXPR_CONSTANT
)
770 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
775 cosine (&x
->value
.real
, &result
->value
.real
);
781 cosine (&x
->value
.complex.r
, &xp
);
782 hypercos (&x
->value
.complex.i
, &xq
);
783 mpf_mul (result
->value
.complex.r
, xp
, xq
);
785 sine (&x
->value
.complex.r
, &xp
);
786 hypersine (&x
->value
.complex.i
, &xq
);
787 mpf_mul (xp
, xp
, xq
);
788 mpf_neg (result
->value
.complex.i
, xp
);
794 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
797 return range_check (result
, "COS");
803 gfc_simplify_cosh (gfc_expr
* x
)
807 if (x
->expr_type
!= EXPR_CONSTANT
)
810 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
812 hypercos (&x
->value
.real
, &result
->value
.real
);
814 return range_check (result
, "COSH");
819 gfc_simplify_dcmplx (gfc_expr
* x
, gfc_expr
* y
)
822 if (x
->expr_type
!= EXPR_CONSTANT
823 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
826 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind ());
831 gfc_simplify_dble (gfc_expr
* e
)
835 if (e
->expr_type
!= EXPR_CONSTANT
)
841 result
= gfc_int2real (e
, gfc_default_double_kind ());
845 result
= gfc_real2real (e
, gfc_default_double_kind ());
849 result
= gfc_complex2real (e
, gfc_default_double_kind ());
853 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e
->where
);
856 return range_check (result
, "DBLE");
861 gfc_simplify_digits (gfc_expr
* x
)
865 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
);
872 digits
= gfc_integer_kinds
[i
].digits
;
877 digits
= gfc_real_kinds
[i
].digits
;
882 gfc_internal_error ("gfc_simplify_digits(): Bad type");
885 return gfc_int_expr (digits
);
890 gfc_simplify_dim (gfc_expr
* x
, gfc_expr
* y
)
894 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
897 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
902 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
903 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
905 mpz_set (result
->value
.integer
, mpz_zero
);
910 if (mpf_cmp (x
->value
.real
, y
->value
.real
) > 0)
911 mpf_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
);
913 mpf_set (result
->value
.real
, mpf_zero
);
918 gfc_internal_error ("gfc_simplify_dim(): Bad type");
921 return range_check (result
, "DIM");
926 gfc_simplify_dprod (gfc_expr
* x
, gfc_expr
* y
)
928 gfc_expr
*mult1
, *mult2
, *result
;
930 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
934 gfc_constant_result (BT_REAL
, gfc_default_double_kind (), &x
->where
);
936 mult1
= gfc_real2real (x
, gfc_default_double_kind ());
937 mult2
= gfc_real2real (y
, gfc_default_double_kind ());
939 mpf_mul (result
->value
.real
, mult1
->value
.real
, mult2
->value
.real
);
941 gfc_free_expr (mult1
);
942 gfc_free_expr (mult2
);
944 return range_check (result
, "DPROD");
949 gfc_simplify_epsilon (gfc_expr
* e
)
954 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
);
956 gfc_internal_error ("gfc_simplify_epsilon(): Bad kind");
958 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
960 mpf_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
);
962 return range_check (result
, "EPSILON");
967 gfc_simplify_exp (gfc_expr
* x
)
971 double ln2
, absval
, rhuge
;
973 if (x
->expr_type
!= EXPR_CONSTANT
)
976 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
978 /* Exactitude doesn't matter here */
980 rhuge
= ln2
* mpz_get_d (gfc_integer_kinds
[0].huge
);
985 absval
= mpf_get_d (x
->value
.real
);
990 /* Underflow (set arg to zero) if x is negative and its
991 magnitude is greater than the maximum C long int times
992 ln2, because the exponential method in arith.c will fail
994 if (mpf_cmp_ui (x
->value
.real
, 0) < 0)
998 ("Argument of EXP at %L is negative and too large, "
999 "setting result to zero", &x
->where
);
1000 mpf_set_ui (result
->value
.real
, 0);
1001 return range_check (result
, "EXP");
1003 /* Overflow if magnitude of x is greater than C long int
1007 gfc_error ("Argument of EXP at %L too large", &x
->where
);
1008 gfc_free_expr (result
);
1009 return &gfc_bad_expr
;
1012 exponential (&x
->value
.real
, &result
->value
.real
);
1016 /* Using Euler's formula. */
1017 absval
= mpf_get_d (x
->value
.complex.r
);
1022 if (mpf_cmp_ui (x
->value
.complex.r
, 0) < 0)
1026 ("Real part of argument of EXP at %L is negative "
1027 "and too large, setting result to zero", &x
->where
);
1029 mpf_set_ui (result
->value
.complex.r
, 0);
1030 mpf_set_ui (result
->value
.complex.i
, 0);
1031 return range_check (result
, "EXP");
1035 gfc_error ("Real part of argument of EXP at %L too large",
1037 gfc_free_expr (result
);
1038 return &gfc_bad_expr
;
1043 exponential (&x
->value
.complex.r
, &xq
);
1044 cosine (&x
->value
.complex.i
, &xp
);
1045 mpf_mul (result
->value
.complex.r
, xq
, xp
);
1046 sine (&x
->value
.complex.i
, &xp
);
1047 mpf_mul (result
->value
.complex.i
, xq
, xp
);
1053 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1056 return range_check (result
, "EXP");
1061 gfc_simplify_exponent (gfc_expr
* x
)
1063 mpf_t i2
, absv
, ln2
, lnx
;
1066 if (x
->expr_type
!= EXPR_CONSTANT
)
1069 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind (),
1072 if (mpf_cmp (x
->value
.real
, mpf_zero
) == 0)
1074 mpz_set_ui (result
->value
.integer
, 0);
1078 mpf_init_set_ui (i2
, 2);
1083 natural_logarithm (&i2
, &ln2
);
1085 mpf_abs (absv
, x
->value
.real
);
1086 natural_logarithm (&absv
, &lnx
);
1088 mpf_div (lnx
, lnx
, ln2
);
1089 mpf_trunc (lnx
, lnx
);
1090 mpf_add_ui (lnx
, lnx
, 1);
1091 mpz_set_f (result
->value
.integer
, lnx
);
1098 return range_check (result
, "EXPONENT");
1103 gfc_simplify_float (gfc_expr
* a
)
1107 if (a
->expr_type
!= EXPR_CONSTANT
)
1110 result
= gfc_int2real (a
, gfc_default_real_kind ());
1111 return range_check (result
, "FLOAT");
1116 gfc_simplify_floor (gfc_expr
* e
, gfc_expr
* k
)
1122 kind
= get_kind (BT_REAL
, k
, "FLOOR", gfc_default_real_kind ());
1124 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1126 if (e
->expr_type
!= EXPR_CONSTANT
)
1129 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1132 mpf_floor (floor
, e
->value
.real
);
1133 mpz_set_f (result
->value
.integer
, floor
);
1136 return range_check (result
, "FLOOR");
1141 gfc_simplify_fraction (gfc_expr
* x
)
1144 mpf_t i2
, absv
, ln2
, lnx
, pow2
;
1147 if (x
->expr_type
!= EXPR_CONSTANT
)
1150 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
1152 if (mpf_cmp (x
->value
.real
, mpf_zero
) == 0)
1154 mpf_set (result
->value
.real
, mpf_zero
);
1158 mpf_init_set_ui (i2
, 2);
1164 natural_logarithm (&i2
, &ln2
);
1166 mpf_abs (absv
, x
->value
.real
);
1167 natural_logarithm (&absv
, &lnx
);
1169 mpf_div (lnx
, lnx
, ln2
);
1170 mpf_trunc (lnx
, lnx
);
1171 mpf_add_ui (lnx
, lnx
, 1);
1173 exp2
= (unsigned long) mpf_get_d (lnx
);
1174 mpf_pow_ui (pow2
, i2
, exp2
);
1176 mpf_div (result
->value
.real
, absv
, pow2
);
1184 return range_check (result
, "FRACTION");
1189 gfc_simplify_huge (gfc_expr
* e
)
1194 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
);
1198 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1203 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
1207 mpf_set (result
->value
.real
, gfc_real_kinds
[i
].huge
);
1212 gfc_internal_error ("gfc_simplify_huge(): Bad type");
1220 gfc_simplify_iachar (gfc_expr
* e
)
1225 if (e
->expr_type
!= EXPR_CONSTANT
)
1228 if (e
->value
.character
.length
!= 1)
1230 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
1231 return &gfc_bad_expr
;
1234 index
= xascii_table
[(int) e
->value
.character
.string
[0] & 0xFF];
1236 result
= gfc_int_expr (index
);
1237 result
->where
= e
->where
;
1239 return range_check (result
, "IACHAR");
1244 gfc_simplify_iand (gfc_expr
* x
, gfc_expr
* y
)
1248 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1251 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1253 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1255 return range_check (result
, "IAND");
1260 gfc_simplify_ibclr (gfc_expr
* x
, gfc_expr
* y
)
1265 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1268 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1270 gfc_error ("Invalid second argument of IBCLR at %L", &y
->where
);
1271 return &gfc_bad_expr
;
1274 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
);
1276 gfc_internal_error ("gfc_simplify_ibclr(): Bad kind");
1278 if (pos
> gfc_integer_kinds
[k
].bit_size
)
1280 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1282 return &gfc_bad_expr
;
1285 result
= gfc_copy_expr (x
);
1287 mpz_clrbit (result
->value
.integer
, pos
);
1288 return range_check (result
, "IBCLR");
1293 gfc_simplify_ibits (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* z
)
1300 if (x
->expr_type
!= EXPR_CONSTANT
1301 || y
->expr_type
!= EXPR_CONSTANT
1302 || z
->expr_type
!= EXPR_CONSTANT
)
1305 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1307 gfc_error ("Invalid second argument of IBITS at %L", &y
->where
);
1308 return &gfc_bad_expr
;
1311 if (gfc_extract_int (z
, &len
) != NULL
|| len
< 0)
1313 gfc_error ("Invalid third argument of IBITS at %L", &z
->where
);
1314 return &gfc_bad_expr
;
1317 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
);
1319 gfc_internal_error ("gfc_simplify_ibits(): Bad kind");
1321 bitsize
= gfc_integer_kinds
[k
].bit_size
;
1323 if (pos
+ len
> bitsize
)
1326 ("Sum of second and third arguments of IBITS exceeds bit size "
1327 "at %L", &y
->where
);
1328 return &gfc_bad_expr
;
1331 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1333 bits
= gfc_getmem (bitsize
* sizeof (int));
1335 for (i
= 0; i
< bitsize
; i
++)
1338 for (i
= 0; i
< len
; i
++)
1339 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
1341 for (i
= 0; i
< bitsize
; i
++)
1345 mpz_clrbit (result
->value
.integer
, i
);
1347 else if (bits
[i
] == 1)
1349 mpz_setbit (result
->value
.integer
, i
);
1353 gfc_internal_error ("IBITS: Bad bit");
1359 return range_check (result
, "IBITS");
1364 gfc_simplify_ibset (gfc_expr
* x
, gfc_expr
* y
)
1369 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1372 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1374 gfc_error ("Invalid second argument of IBSET at %L", &y
->where
);
1375 return &gfc_bad_expr
;
1378 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
);
1380 gfc_internal_error ("gfc_simplify_ibset(): Bad kind");
1382 if (pos
> gfc_integer_kinds
[k
].bit_size
)
1384 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1386 return &gfc_bad_expr
;
1389 result
= gfc_copy_expr (x
);
1391 mpz_setbit (result
->value
.integer
, pos
);
1392 return range_check (result
, "IBSET");
1397 gfc_simplify_ichar (gfc_expr
* e
)
1402 if (e
->expr_type
!= EXPR_CONSTANT
)
1405 if (e
->value
.character
.length
!= 1)
1407 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
1408 return &gfc_bad_expr
;
1411 index
= (int) e
->value
.character
.string
[0];
1413 if (index
< CHAR_MIN
|| index
> CHAR_MAX
)
1415 gfc_error ("Argument of ICHAR at %L out of range of this processor",
1417 return &gfc_bad_expr
;
1420 result
= gfc_int_expr (index
);
1421 result
->where
= e
->where
;
1422 return range_check (result
, "ICHAR");
1427 gfc_simplify_ieor (gfc_expr
* x
, gfc_expr
* y
)
1431 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1434 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1436 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1438 return range_check (result
, "IEOR");
1443 gfc_simplify_index (gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* b
)
1446 int back
, len
, lensub
;
1447 int i
, j
, k
, count
, index
= 0, start
;
1449 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1452 if (b
!= NULL
&& b
->value
.logical
!= 0)
1457 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind (),
1460 len
= x
->value
.character
.length
;
1461 lensub
= y
->value
.character
.length
;
1465 mpz_set_si (result
->value
.integer
, 0);
1474 mpz_set_si (result
->value
.integer
, 1);
1477 else if (lensub
== 1)
1479 for (i
= 0; i
< len
; i
++)
1481 for (j
= 0; j
< lensub
; j
++)
1483 if (y
->value
.character
.string
[j
] ==
1484 x
->value
.character
.string
[i
])
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
[i
])
1504 for (k
= 0; k
< lensub
; k
++)
1506 if (y
->value
.character
.string
[k
] ==
1507 x
->value
.character
.string
[k
+ start
])
1511 if (count
== lensub
)
1527 mpz_set_si (result
->value
.integer
, len
+ 1);
1530 else if (lensub
== 1)
1532 for (i
= 0; i
< len
; i
++)
1534 for (j
= 0; j
< lensub
; j
++)
1536 if (y
->value
.character
.string
[j
] ==
1537 x
->value
.character
.string
[len
- i
])
1539 index
= len
- i
+ 1;
1547 for (i
= 0; i
< len
; i
++)
1549 for (j
= 0; j
< lensub
; j
++)
1551 if (y
->value
.character
.string
[j
] ==
1552 x
->value
.character
.string
[len
- i
])
1555 if (start
<= len
- lensub
)
1558 for (k
= 0; k
< lensub
; k
++)
1559 if (y
->value
.character
.string
[k
] ==
1560 x
->value
.character
.string
[k
+ start
])
1563 if (count
== lensub
)
1580 mpz_set_si (result
->value
.integer
, index
);
1581 return range_check (result
, "INDEX");
1586 gfc_simplify_int (gfc_expr
* e
, gfc_expr
* k
)
1588 gfc_expr
*rpart
, *rtrunc
, *result
;
1591 kind
= get_kind (BT_REAL
, k
, "INT", gfc_default_real_kind ());
1593 return &gfc_bad_expr
;
1595 if (e
->expr_type
!= EXPR_CONSTANT
)
1598 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1603 mpz_set (result
->value
.integer
, e
->value
.integer
);
1607 rtrunc
= gfc_copy_expr (e
);
1608 mpf_trunc (rtrunc
->value
.real
, e
->value
.real
);
1609 mpz_set_f (result
->value
.integer
, rtrunc
->value
.real
);
1610 gfc_free_expr (rtrunc
);
1614 rpart
= gfc_complex2real (e
, kind
);
1615 rtrunc
= gfc_copy_expr (rpart
);
1616 mpf_trunc (rtrunc
->value
.real
, rpart
->value
.real
);
1617 mpz_set_f (result
->value
.integer
, rtrunc
->value
.real
);
1618 gfc_free_expr (rpart
);
1619 gfc_free_expr (rtrunc
);
1623 gfc_error ("Argument of INT at %L is not a valid type", &e
->where
);
1624 gfc_free_expr (result
);
1625 return &gfc_bad_expr
;
1628 return range_check (result
, "INT");
1633 gfc_simplify_ifix (gfc_expr
* e
)
1635 gfc_expr
*rtrunc
, *result
;
1637 if (e
->expr_type
!= EXPR_CONSTANT
)
1640 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind (),
1643 rtrunc
= gfc_copy_expr (e
);
1645 mpf_trunc (rtrunc
->value
.real
, e
->value
.real
);
1646 mpz_set_f (result
->value
.integer
, rtrunc
->value
.real
);
1648 gfc_free_expr (rtrunc
);
1649 return range_check (result
, "IFIX");
1654 gfc_simplify_idint (gfc_expr
* e
)
1656 gfc_expr
*rtrunc
, *result
;
1658 if (e
->expr_type
!= EXPR_CONSTANT
)
1661 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind (),
1664 rtrunc
= gfc_copy_expr (e
);
1666 mpf_trunc (rtrunc
->value
.real
, e
->value
.real
);
1667 mpz_set_f (result
->value
.integer
, rtrunc
->value
.real
);
1669 gfc_free_expr (rtrunc
);
1670 return range_check (result
, "IDINT");
1675 gfc_simplify_ior (gfc_expr
* x
, gfc_expr
* y
)
1679 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1682 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1684 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1685 return range_check (result
, "IOR");
1690 gfc_simplify_ishft (gfc_expr
* e
, gfc_expr
* s
)
1693 int shift
, ashift
, isize
, k
;
1696 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1699 if (gfc_extract_int (s
, &shift
) != NULL
)
1701 gfc_error ("Invalid second argument of ISHFT at %L", &s
->where
);
1702 return &gfc_bad_expr
;
1705 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
);
1707 gfc_internal_error ("gfc_simplify_ishft(): Bad kind");
1709 isize
= gfc_integer_kinds
[k
].bit_size
;
1719 ("Magnitude of second argument of ISHFT exceeds bit size at %L",
1721 return &gfc_bad_expr
;
1724 e_int
= mpz_get_si (e
->value
.integer
);
1725 if (e_int
> INT_MAX
|| e_int
< INT_MIN
)
1726 gfc_internal_error ("ISHFT: unable to extract integer");
1728 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1732 mpz_set (result
->value
.integer
, e
->value
.integer
);
1733 return range_check (result
, "ISHFT");
1737 mpz_set_si (result
->value
.integer
, e_int
<< shift
);
1739 mpz_set_si (result
->value
.integer
, e_int
>> ashift
);
1741 return range_check (result
, "ISHFT");
1746 gfc_simplify_ishftc (gfc_expr
* e
, gfc_expr
* s
, gfc_expr
* sz
)
1749 int shift
, ashift
, isize
, delta
, k
;
1752 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1755 if (gfc_extract_int (s
, &shift
) != NULL
)
1757 gfc_error ("Invalid second argument of ISHFTC at %L", &s
->where
);
1758 return &gfc_bad_expr
;
1761 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
);
1763 gfc_internal_error ("gfc_simplify_ishftc(): Bad kind");
1767 if (gfc_extract_int (sz
, &isize
) != NULL
|| isize
< 0)
1769 gfc_error ("Invalid third argument of ISHFTC at %L", &sz
->where
);
1770 return &gfc_bad_expr
;
1774 isize
= gfc_integer_kinds
[k
].bit_size
;
1784 ("Magnitude of second argument of ISHFTC exceeds third argument "
1785 "at %L", &s
->where
);
1786 return &gfc_bad_expr
;
1789 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1791 bits
= gfc_getmem (isize
* sizeof (int));
1793 for (i
= 0; i
< isize
; i
++)
1794 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1796 delta
= isize
- ashift
;
1800 mpz_set (result
->value
.integer
, e
->value
.integer
);
1802 return range_check (result
, "ISHFTC");
1807 for (i
= 0; i
< delta
; i
++)
1810 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1812 mpz_setbit (result
->value
.integer
, i
+ shift
);
1815 for (i
= delta
; i
< isize
; i
++)
1818 mpz_clrbit (result
->value
.integer
, i
- delta
);
1820 mpz_setbit (result
->value
.integer
, i
- delta
);
1824 return range_check (result
, "ISHFTC");
1828 for (i
= 0; i
< ashift
; i
++)
1831 mpz_clrbit (result
->value
.integer
, i
+ delta
);
1833 mpz_setbit (result
->value
.integer
, i
+ delta
);
1836 for (i
= ashift
; i
< isize
; i
++)
1839 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1841 mpz_setbit (result
->value
.integer
, i
+ shift
);
1845 return range_check (result
, "ISHFTC");
1851 gfc_simplify_kind (gfc_expr
* e
)
1854 if (e
->ts
.type
== BT_DERIVED
)
1856 gfc_error ("Argument of KIND at %L is a DERIVED type", &e
->where
);
1857 return &gfc_bad_expr
;
1860 return gfc_int_expr (e
->ts
.kind
);
1865 gfc_simplify_bound (gfc_expr
* array
, gfc_expr
* dim
, int upper
)
1871 if (array
->expr_type
!= EXPR_VARIABLE
)
1877 if (dim
->expr_type
!= EXPR_CONSTANT
)
1880 /* Follow any component references. */
1881 as
= array
->symtree
->n
.sym
->as
;
1883 while (ref
->next
!= NULL
)
1885 if (ref
->type
== REF_COMPONENT
)
1886 as
= ref
->u
.c
.sym
->as
;
1890 if (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
!= AR_FULL
)
1893 i
= mpz_get_si (dim
->value
.integer
);
1895 return gfc_copy_expr (as
->upper
[i
-1]);
1897 return gfc_copy_expr (as
->lower
[i
-1]);
1902 gfc_simplify_lbound (gfc_expr
* array
, gfc_expr
* dim
)
1904 return gfc_simplify_bound (array
, dim
, 0);
1909 gfc_simplify_len (gfc_expr
* e
)
1913 if (e
->expr_type
!= EXPR_CONSTANT
)
1916 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind (),
1919 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
1920 return range_check (result
, "LEN");
1925 gfc_simplify_len_trim (gfc_expr
* e
)
1928 int count
, len
, lentrim
, i
;
1930 if (e
->expr_type
!= EXPR_CONSTANT
)
1933 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind (),
1936 len
= e
->value
.character
.length
;
1938 for (count
= 0, i
= 1; i
<= len
; i
++)
1939 if (e
->value
.character
.string
[len
- i
] == ' ')
1944 lentrim
= len
- count
;
1946 mpz_set_si (result
->value
.integer
, lentrim
);
1947 return range_check (result
, "LEN_TRIM");
1952 gfc_simplify_lge (gfc_expr
* a
, gfc_expr
* b
)
1955 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1958 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) >= 0,
1964 gfc_simplify_lgt (gfc_expr
* a
, gfc_expr
* b
)
1967 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1970 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) > 0,
1976 gfc_simplify_lle (gfc_expr
* a
, gfc_expr
* b
)
1979 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1982 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) <= 0,
1988 gfc_simplify_llt (gfc_expr
* a
, gfc_expr
* b
)
1991 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
1994 return gfc_logical_expr (gfc_compare_string (a
, b
, xascii_table
) < 0,
2000 gfc_simplify_log (gfc_expr
* x
)
2005 if (x
->expr_type
!= EXPR_CONSTANT
)
2008 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2013 if (mpf_cmp (x
->value
.real
, mpf_zero
) <= 0)
2016 ("Argument of LOG at %L cannot be less than or equal to zero",
2018 gfc_free_expr (result
);
2019 return &gfc_bad_expr
;
2022 natural_logarithm (&x
->value
.real
, &result
->value
.real
);
2026 if ((mpf_cmp (x
->value
.complex.r
, mpf_zero
) == 0)
2027 && (mpf_cmp (x
->value
.complex.i
, mpf_zero
) == 0))
2029 gfc_error ("Complex argument of LOG at %L cannot be zero",
2031 gfc_free_expr (result
);
2032 return &gfc_bad_expr
;
2038 arctangent2 (&x
->value
.complex.i
, &x
->value
.complex.r
,
2039 &result
->value
.complex.i
);
2041 mpf_mul (xr
, x
->value
.complex.r
, x
->value
.complex.r
);
2042 mpf_mul (xi
, x
->value
.complex.i
, x
->value
.complex.i
);
2043 mpf_add (xr
, xr
, xi
);
2045 natural_logarithm (&xr
, &result
->value
.complex.r
);
2053 gfc_internal_error ("gfc_simplify_log: bad type");
2056 return range_check (result
, "LOG");
2061 gfc_simplify_log10 (gfc_expr
* x
)
2065 if (x
->expr_type
!= EXPR_CONSTANT
)
2068 if (mpf_cmp (x
->value
.real
, mpf_zero
) <= 0)
2071 ("Argument of LOG10 at %L cannot be less than or equal to zero",
2073 return &gfc_bad_expr
;
2076 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2078 common_logarithm (&x
->value
.real
, &result
->value
.real
);
2080 return range_check (result
, "LOG10");
2085 gfc_simplify_logical (gfc_expr
* e
, gfc_expr
* k
)
2090 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind ());
2092 return &gfc_bad_expr
;
2094 if (e
->expr_type
!= EXPR_CONSTANT
)
2097 result
= gfc_constant_result (BT_LOGICAL
, kind
, &e
->where
);
2099 result
->value
.logical
= e
->value
.logical
;
2105 /* This function is special since MAX() can take any number of
2106 arguments. The simplified expression is a rewritten version of the
2107 argument list containing at most one constant element. Other
2108 constant elements are deleted. Because the argument list has
2109 already been checked, this function always succeeds. sign is 1 for
2110 MAX(), -1 for MIN(). */
2113 simplify_min_max (gfc_expr
* expr
, int sign
)
2115 gfc_actual_arglist
*arg
, *last
, *extremum
;
2116 gfc_intrinsic_sym
* specific
;
2120 specific
= expr
->value
.function
.isym
;
2122 arg
= expr
->value
.function
.actual
;
2124 for (; arg
; last
= arg
, arg
= arg
->next
)
2126 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
2129 if (extremum
== NULL
)
2135 switch (arg
->expr
->ts
.type
)
2138 if (mpz_cmp (arg
->expr
->value
.integer
,
2139 extremum
->expr
->value
.integer
) * sign
> 0)
2140 mpz_set (extremum
->expr
->value
.integer
, arg
->expr
->value
.integer
);
2145 if (mpf_cmp (arg
->expr
->value
.real
, extremum
->expr
->value
.real
) *
2147 mpf_set (extremum
->expr
->value
.real
, arg
->expr
->value
.real
);
2152 gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
2155 /* Delete the extra constant argument. */
2157 expr
->value
.function
.actual
= arg
->next
;
2159 last
->next
= arg
->next
;
2162 gfc_free_actual_arglist (arg
);
2166 /* If there is one value left, replace the function call with the
2168 if (expr
->value
.function
.actual
->next
!= NULL
)
2171 /* Convert to the correct type and kind. */
2172 if (expr
->ts
.type
!= BT_UNKNOWN
)
2173 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2174 expr
->ts
.type
, expr
->ts
.kind
);
2176 if (specific
->ts
.type
!= BT_UNKNOWN
)
2177 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2178 specific
->ts
.type
, specific
->ts
.kind
);
2180 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
2185 gfc_simplify_min (gfc_expr
* e
)
2188 return simplify_min_max (e
, -1);
2193 gfc_simplify_max (gfc_expr
* e
)
2196 return simplify_min_max (e
, 1);
2201 gfc_simplify_maxexponent (gfc_expr
* x
)
2206 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
);
2208 gfc_internal_error ("gfc_simplify_maxexponent(): Bad kind");
2210 result
= gfc_int_expr (gfc_real_kinds
[i
].max_exponent
);
2211 result
->where
= x
->where
;
2218 gfc_simplify_minexponent (gfc_expr
* x
)
2223 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
);
2225 gfc_internal_error ("gfc_simplify_minexponent(): Bad kind");
2227 result
= gfc_int_expr (gfc_real_kinds
[i
].min_exponent
);
2228 result
->where
= x
->where
;
2235 gfc_simplify_mod (gfc_expr
* a
, gfc_expr
* p
)
2238 mpf_t quot
, iquot
, term
;
2240 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2243 result
= gfc_constant_result (a
->ts
.type
, a
->ts
.kind
, &a
->where
);
2248 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2250 /* Result is processor-dependent. */
2251 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
2252 gfc_free_expr (result
);
2253 return &gfc_bad_expr
;
2255 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2259 if (mpf_cmp_ui (p
->value
.real
, 0) == 0)
2261 /* Result is processor-dependent. */
2262 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
2263 gfc_free_expr (result
);
2264 return &gfc_bad_expr
;
2271 mpf_div (quot
, a
->value
.real
, p
->value
.real
);
2272 mpf_trunc (iquot
, quot
);
2273 mpf_mul (term
, iquot
, p
->value
.real
);
2274 mpf_sub (result
->value
.real
, a
->value
.real
, term
);
2282 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2285 return range_check (result
, "MOD");
2290 gfc_simplify_modulo (gfc_expr
* a
, gfc_expr
* p
)
2293 mpf_t quot
, iquot
, term
;
2295 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2298 result
= gfc_constant_result (a
->ts
.type
, a
->ts
.kind
, &a
->where
);
2303 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2305 /* Result is processor-dependent. This processor just opts
2306 to not handle it at all. */
2307 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
2308 gfc_free_expr (result
);
2309 return &gfc_bad_expr
;
2311 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2316 if (mpf_cmp_ui (p
->value
.real
, 0) == 0)
2318 /* Result is processor-dependent. */
2319 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
2320 gfc_free_expr (result
);
2321 return &gfc_bad_expr
;
2328 mpf_div (quot
, a
->value
.real
, p
->value
.real
);
2329 mpf_floor (iquot
, quot
);
2330 mpf_mul (term
, iquot
, p
->value
.real
);
2336 mpf_sub (result
->value
.real
, a
->value
.real
, term
);
2340 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2343 return range_check (result
, "MODULO");
2347 /* Exists for the sole purpose of consistency with other intrinsics. */
2349 gfc_simplify_mvbits (gfc_expr
* f ATTRIBUTE_UNUSED
,
2350 gfc_expr
* fp ATTRIBUTE_UNUSED
,
2351 gfc_expr
* l ATTRIBUTE_UNUSED
,
2352 gfc_expr
* to ATTRIBUTE_UNUSED
,
2353 gfc_expr
* tp ATTRIBUTE_UNUSED
)
2360 gfc_simplify_nearest (gfc_expr
* x
, gfc_expr
* s
)
2365 int p
, i
, k
, match_float
;
2367 /* FIXME: This implementation is dopey and probably not quite right,
2368 but it's a start. */
2370 if (x
->expr_type
!= EXPR_CONSTANT
)
2373 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
);
2375 gfc_internal_error ("gfc_simplify_precision(): Bad kind");
2377 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2379 val
= mpf_get_d (x
->value
.real
);
2380 p
= gfc_real_kinds
[k
].digits
;
2383 for (i
= 1; i
< p
; ++i
)
2388 /* TODO we should make sure that 'float' matches kind 4 */
2389 match_float
= gfc_real_kinds
[k
].kind
== 4;
2390 if (mpf_cmp_ui (s
->value
.real
, 0) > 0)
2396 mpf_set_d (result
->value
.real
, rval
);
2401 mpf_set_d (result
->value
.real
, val
);
2404 else if (mpf_cmp_ui (s
->value
.real
, 0) < 0)
2410 mpf_set_d (result
->value
.real
, rval
);
2415 mpf_set_d (result
->value
.real
, val
);
2420 gfc_error ("Invalid second argument of NEAREST at %L", &s
->where
);
2422 return &gfc_bad_expr
;
2425 return range_check (result
, "NEAREST");
2431 simplify_nint (const char *name
, gfc_expr
* e
, gfc_expr
* k
)
2433 gfc_expr
*rtrunc
, *itrunc
, *result
;
2436 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind ());
2438 return &gfc_bad_expr
;
2440 if (e
->expr_type
!= EXPR_CONSTANT
)
2443 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
2445 rtrunc
= gfc_copy_expr (e
);
2446 itrunc
= gfc_copy_expr (e
);
2448 cmp
= mpf_cmp_ui (e
->value
.real
, 0);
2452 mpf_add (rtrunc
->value
.real
, e
->value
.real
, mpf_half
);
2453 mpf_trunc (itrunc
->value
.real
, rtrunc
->value
.real
);
2457 mpf_sub (rtrunc
->value
.real
, e
->value
.real
, mpf_half
);
2458 mpf_trunc (itrunc
->value
.real
, rtrunc
->value
.real
);
2461 mpf_set_ui (itrunc
->value
.real
, 0);
2463 mpz_set_f (result
->value
.integer
, itrunc
->value
.real
);
2465 gfc_free_expr (itrunc
);
2466 gfc_free_expr (rtrunc
);
2468 return range_check (result
, name
);
2473 gfc_simplify_nint (gfc_expr
* e
, gfc_expr
* k
)
2476 return simplify_nint ("NINT", e
, k
);
2481 gfc_simplify_idnint (gfc_expr
* e
)
2484 return simplify_nint ("IDNINT", e
, NULL
);
2489 gfc_simplify_not (gfc_expr
* e
)
2494 if (e
->expr_type
!= EXPR_CONSTANT
)
2497 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2499 mpz_com (result
->value
.integer
, e
->value
.integer
);
2501 /* Because of how GMP handles numbers, the result must be ANDed with
2502 the max_int mask. For radices <> 2, this will require change. */
2504 i
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
);
2506 gfc_internal_error ("gfc_simplify_not(): Bad kind");
2508 mpz_and (result
->value
.integer
, result
->value
.integer
,
2509 gfc_integer_kinds
[i
].max_int
);
2511 return range_check (result
, "NOT");
2516 gfc_simplify_null (gfc_expr
* mold
)
2520 result
= gfc_get_expr ();
2521 result
->expr_type
= EXPR_NULL
;
2524 result
->ts
.type
= BT_UNKNOWN
;
2527 result
->ts
= mold
->ts
;
2528 result
->where
= mold
->where
;
2536 gfc_simplify_precision (gfc_expr
* e
)
2541 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
);
2543 gfc_internal_error ("gfc_simplify_precision(): Bad kind");
2545 result
= gfc_int_expr (gfc_real_kinds
[i
].precision
);
2546 result
->where
= e
->where
;
2553 gfc_simplify_radix (gfc_expr
* e
)
2558 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
);
2565 i
= gfc_integer_kinds
[i
].radix
;
2569 i
= gfc_real_kinds
[i
].radix
;
2574 gfc_internal_error ("gfc_simplify_radix(): Bad type");
2577 result
= gfc_int_expr (i
);
2578 result
->where
= e
->where
;
2585 gfc_simplify_range (gfc_expr
* e
)
2591 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
);
2598 j
= gfc_integer_kinds
[i
].range
;
2603 j
= gfc_real_kinds
[i
].range
;
2608 gfc_internal_error ("gfc_simplify_range(): Bad kind");
2611 result
= gfc_int_expr (j
);
2612 result
->where
= e
->where
;
2619 gfc_simplify_real (gfc_expr
* e
, gfc_expr
* k
)
2624 if (e
->ts
.type
== BT_COMPLEX
)
2625 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
2627 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind ());
2630 return &gfc_bad_expr
;
2632 if (e
->expr_type
!= EXPR_CONSTANT
)
2638 result
= gfc_int2real (e
, kind
);
2642 result
= gfc_real2real (e
, kind
);
2646 result
= gfc_complex2real (e
, kind
);
2650 gfc_internal_error ("bad type in REAL");
2654 return range_check (result
, "REAL");
2658 gfc_simplify_repeat (gfc_expr
* e
, gfc_expr
* n
)
2661 int i
, j
, len
, ncopies
, nlen
;
2663 if (e
->expr_type
!= EXPR_CONSTANT
|| n
->expr_type
!= EXPR_CONSTANT
)
2666 if (n
!= NULL
&& (gfc_extract_int (n
, &ncopies
) != NULL
|| ncopies
< 0))
2668 gfc_error ("Invalid second argument of REPEAT at %L", &n
->where
);
2669 return &gfc_bad_expr
;
2672 len
= e
->value
.character
.length
;
2673 nlen
= ncopies
* len
;
2675 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
2679 result
->value
.character
.string
= gfc_getmem (1);
2680 result
->value
.character
.length
= 0;
2681 result
->value
.character
.string
[0] = '\0';
2685 result
->value
.character
.length
= nlen
;
2686 result
->value
.character
.string
= gfc_getmem (nlen
+ 1);
2688 for (i
= 0; i
< ncopies
; i
++)
2689 for (j
= 0; j
< len
; j
++)
2690 result
->value
.character
.string
[j
+ i
* len
] =
2691 e
->value
.character
.string
[j
];
2693 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
2698 /* This one is a bear, but mainly has to do with shuffling elements. */
2701 gfc_simplify_reshape (gfc_expr
* source
, gfc_expr
* shape_exp
,
2702 gfc_expr
* pad
, gfc_expr
* order_exp
)
2705 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
2706 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
2707 gfc_constructor
*head
, *tail
;
2713 /* Unpack the shape array. */
2714 if (source
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (source
))
2717 if (shape_exp
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (shape_exp
))
2721 && (pad
->expr_type
!= EXPR_ARRAY
2722 || !gfc_is_constant_expr (pad
)))
2725 if (order_exp
!= NULL
2726 && (order_exp
->expr_type
!= EXPR_ARRAY
2727 || !gfc_is_constant_expr (order_exp
)))
2736 e
= gfc_get_array_element (shape_exp
, rank
);
2740 if (gfc_extract_int (e
, &shape
[rank
]) != NULL
)
2742 gfc_error ("Integer too large in shape specification at %L",
2750 if (rank
>= GFC_MAX_DIMENSIONS
)
2752 gfc_error ("Too many dimensions in shape specification for RESHAPE "
2753 "at %L", &e
->where
);
2758 if (shape
[rank
] < 0)
2760 gfc_error ("Shape specification at %L cannot be negative",
2770 gfc_error ("Shape specification at %L cannot be the null array",
2775 /* Now unpack the order array if present. */
2776 if (order_exp
== NULL
)
2778 for (i
= 0; i
< rank
; i
++)
2785 for (i
= 0; i
< rank
; i
++)
2788 for (i
= 0; i
< rank
; i
++)
2790 e
= gfc_get_array_element (order_exp
, i
);
2794 ("ORDER parameter of RESHAPE at %L is not the same size "
2795 "as SHAPE parameter", &order_exp
->where
);
2799 if (gfc_extract_int (e
, &order
[i
]) != NULL
)
2801 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
2809 if (order
[i
] < 1 || order
[i
] > rank
)
2811 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
2820 gfc_error ("Invalid permutation in ORDER parameter at %L",
2829 /* Count the elements in the source and padding arrays. */
2834 gfc_array_size (pad
, &size
);
2835 npad
= mpz_get_ui (size
);
2839 gfc_array_size (source
, &size
);
2840 nsource
= mpz_get_ui (size
);
2843 /* If it weren't for that pesky permutation we could just loop
2844 through the source and round out any shortage with pad elements.
2845 But no, someone just had to have the compiler do something the
2846 user should be doing. */
2848 for (i
= 0; i
< rank
; i
++)
2853 /* Figure out which element to extract. */
2854 mpz_set_ui (index
, 0);
2856 for (i
= rank
- 1; i
>= 0; i
--)
2858 mpz_add_ui (index
, index
, x
[order
[i
]]);
2860 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
2863 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
2864 gfc_internal_error ("Reshaped array too large at %L", &e
->where
);
2866 j
= mpz_get_ui (index
);
2869 e
= gfc_get_array_element (source
, j
);
2877 ("PAD parameter required for short SOURCE parameter at %L",
2883 e
= gfc_get_array_element (pad
, j
);
2887 head
= tail
= gfc_get_constructor ();
2890 tail
->next
= gfc_get_constructor ();
2897 tail
->where
= e
->where
;
2900 /* Calculate the next element. */
2904 if (++x
[i
] < shape
[i
])
2915 e
= gfc_get_expr ();
2916 e
->where
= source
->where
;
2917 e
->expr_type
= EXPR_ARRAY
;
2918 e
->value
.constructor
= head
;
2919 e
->shape
= gfc_get_shape (rank
);
2921 for (i
= 0; i
< rank
; i
++)
2922 mpz_init_set_ui (e
->shape
[i
], shape
[order
[i
]]);
2924 e
->ts
= head
->expr
->ts
;
2930 gfc_free_constructor (head
);
2932 return &gfc_bad_expr
;
2937 gfc_simplify_rrspacing (gfc_expr
* x
)
2940 mpf_t i2
, absv
, ln2
, lnx
, frac
, pow2
;
2944 if (x
->expr_type
!= EXPR_CONSTANT
)
2947 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
);
2949 gfc_internal_error ("gfc_simplify_rrspacing(): Bad kind");
2951 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
2953 p
= gfc_real_kinds
[i
].digits
;
2955 if (mpf_cmp (x
->value
.real
, mpf_zero
) == 0)
2957 mpf_ui_div (result
->value
.real
, 1, gfc_real_kinds
[i
].tiny
);
2961 mpf_init_set_ui (i2
, 2);
2968 natural_logarithm (&i2
, &ln2
);
2970 mpf_abs (absv
, x
->value
.real
);
2971 natural_logarithm (&absv
, &lnx
);
2973 mpf_div (lnx
, lnx
, ln2
);
2974 mpf_trunc (lnx
, lnx
);
2975 mpf_add_ui (lnx
, lnx
, 1);
2977 exp2
= (unsigned long) mpf_get_d (lnx
);
2978 mpf_pow_ui (pow2
, i2
, exp2
);
2979 mpf_div (frac
, absv
, pow2
);
2981 exp2
= (unsigned long) p
;
2982 mpf_mul_2exp (result
->value
.real
, frac
, exp2
);
2991 return range_check (result
, "RRSPACING");
2996 gfc_simplify_scale (gfc_expr
* x
, gfc_expr
* i
)
2998 int k
, neg_flag
, power
, exp_range
;
3002 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3005 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3007 if (mpf_sgn (x
->value
.real
) == 0)
3009 mpf_set_ui (result
->value
.real
, 0);
3013 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
);
3015 gfc_internal_error ("gfc_simplify_scale(): Bad kind");
3017 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
3019 /* This check filters out values of i that would overflow an int. */
3020 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
3021 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
3023 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
3024 return &gfc_bad_expr
;
3027 /* Compute scale = radix ** power. */
3028 power
= mpz_get_si (i
->value
.integer
);
3038 mpf_init_set_ui (radix
, gfc_real_kinds
[k
].radix
);
3040 mpf_pow_ui (scale
, radix
, power
);
3043 mpf_div (result
->value
.real
, x
->value
.real
, scale
);
3045 mpf_mul (result
->value
.real
, x
->value
.real
, scale
);
3050 return range_check (result
, "SCALE");
3055 gfc_simplify_scan (gfc_expr
* e
, gfc_expr
* c
, gfc_expr
* b
)
3060 size_t indx
, len
, lenc
;
3062 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
)
3065 if (b
!= NULL
&& b
->value
.logical
!= 0)
3070 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind (),
3073 len
= e
->value
.character
.length
;
3074 lenc
= c
->value
.character
.length
;
3076 if (len
== 0 || lenc
== 0)
3085 strcspn (e
->value
.character
.string
, c
->value
.character
.string
) + 1;
3092 for (indx
= len
; indx
> 0; indx
--)
3094 for (i
= 0; i
< lenc
; i
++)
3096 if (c
->value
.character
.string
[i
]
3097 == e
->value
.character
.string
[indx
- 1])
3105 mpz_set_ui (result
->value
.integer
, indx
);
3106 return range_check (result
, "SCAN");
3111 gfc_simplify_selected_int_kind (gfc_expr
* e
)
3116 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
3121 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
3122 if (gfc_integer_kinds
[i
].range
>= range
3123 && gfc_integer_kinds
[i
].kind
< kind
)
3124 kind
= gfc_integer_kinds
[i
].kind
;
3126 if (kind
== INT_MAX
)
3129 result
= gfc_int_expr (kind
);
3130 result
->where
= e
->where
;
3137 gfc_simplify_selected_real_kind (gfc_expr
* p
, gfc_expr
* q
)
3139 int range
, precision
, i
, kind
, found_precision
, found_range
;
3146 if (p
->expr_type
!= EXPR_CONSTANT
3147 || gfc_extract_int (p
, &precision
) != NULL
)
3155 if (q
->expr_type
!= EXPR_CONSTANT
3156 || gfc_extract_int (q
, &range
) != NULL
)
3161 found_precision
= 0;
3164 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
3166 if (gfc_real_kinds
[i
].precision
>= precision
)
3167 found_precision
= 1;
3169 if (gfc_real_kinds
[i
].range
>= range
)
3172 if (gfc_real_kinds
[i
].precision
>= precision
3173 && gfc_real_kinds
[i
].range
>= range
&& gfc_real_kinds
[i
].kind
< kind
)
3174 kind
= gfc_real_kinds
[i
].kind
;
3177 if (kind
== INT_MAX
)
3181 if (!found_precision
)
3187 result
= gfc_int_expr (kind
);
3188 result
->where
= (p
!= NULL
) ? p
->where
: q
->where
;
3195 gfc_simplify_set_exponent (gfc_expr
* x
, gfc_expr
* i
)
3198 mpf_t i2
, ln2
, absv
, lnx
, pow2
, frac
;
3201 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3204 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3206 if (mpf_cmp (x
->value
.real
, mpf_zero
) == 0)
3208 mpf_set (result
->value
.real
, mpf_zero
);
3212 mpf_init_set_ui (i2
, 2);
3219 natural_logarithm (&i2
, &ln2
);
3221 mpf_abs (absv
, x
->value
.real
);
3222 natural_logarithm (&absv
, &lnx
);
3224 mpf_div (lnx
, lnx
, ln2
);
3225 mpf_trunc (lnx
, lnx
);
3226 mpf_add_ui (lnx
, lnx
, 1);
3228 /* Old exponent value, and fraction. */
3229 exp2
= (unsigned long) mpf_get_d (lnx
);
3230 mpf_pow_ui (pow2
, i2
, exp2
);
3232 mpf_div (frac
, absv
, pow2
);
3235 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
3236 mpf_mul_2exp (result
->value
.real
, frac
, exp2
);
3245 return range_check (result
, "SET_EXPONENT");
3250 gfc_simplify_shape (gfc_expr
* source
)
3252 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3253 gfc_expr
*result
, *e
, *f
;
3258 result
= gfc_start_constructor (BT_INTEGER
, gfc_default_integer_kind (),
3261 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3264 ar
= gfc_find_array_ref (source
);
3266 t
= gfc_array_ref_shape (ar
, shape
);
3268 for (n
= 0; n
< source
->rank
; n
++)
3270 e
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind (),
3275 mpz_set (e
->value
.integer
, shape
[n
]);
3276 mpz_clear (shape
[n
]);
3280 mpz_set_ui (e
->value
.integer
, n
+ 1);
3282 f
= gfc_simplify_size (source
, e
);
3286 gfc_free_expr (result
);
3295 gfc_append_constructor (result
, e
);
3303 gfc_simplify_size (gfc_expr
* array
, gfc_expr
* dim
)
3311 if (gfc_array_size (array
, &size
) == FAILURE
)
3316 if (dim
->expr_type
!= EXPR_CONSTANT
)
3319 d
= mpz_get_ui (dim
->value
.integer
) - 1;
3320 if (gfc_array_dimen_size (array
, d
, &size
) == FAILURE
)
3324 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind (),
3327 mpz_set (result
->value
.integer
, size
);
3334 gfc_simplify_sign (gfc_expr
* x
, gfc_expr
* y
)
3338 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3341 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3346 mpz_abs (result
->value
.integer
, x
->value
.integer
);
3347 if (mpz_sgn (y
->value
.integer
) < 0)
3348 mpz_neg (result
->value
.integer
, result
->value
.integer
);
3353 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3355 mpf_abs (result
->value
.real
, x
->value
.real
);
3356 if (mpf_sgn (y
->value
.integer
) < 0)
3357 mpf_neg (result
->value
.real
, result
->value
.real
);
3362 gfc_internal_error ("Bad type in gfc_simplify_sign");
3370 gfc_simplify_sin (gfc_expr
* x
)
3375 if (x
->expr_type
!= EXPR_CONSTANT
)
3378 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3383 sine (&x
->value
.real
, &result
->value
.real
);
3390 sine (&x
->value
.complex.r
, &xp
);
3391 hypercos (&x
->value
.complex.i
, &xq
);
3392 mpf_mul (result
->value
.complex.r
, xp
, xq
);
3394 cosine (&x
->value
.complex.r
, &xp
);
3395 hypersine (&x
->value
.complex.i
, &xq
);
3396 mpf_mul (result
->value
.complex.i
, xp
, xq
);
3403 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3406 return range_check (result
, "SIN");
3411 gfc_simplify_sinh (gfc_expr
* x
)
3415 if (x
->expr_type
!= EXPR_CONSTANT
)
3418 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3420 hypersine (&x
->value
.real
, &result
->value
.real
);
3422 return range_check (result
, "SINH");
3426 /* The argument is always a double precision real that is converted to
3427 single precision. TODO: Rounding! */
3430 gfc_simplify_sngl (gfc_expr
* a
)
3434 if (a
->expr_type
!= EXPR_CONSTANT
)
3437 result
= gfc_real2real (a
, gfc_default_real_kind ());
3438 return range_check (result
, "SNGL");
3443 gfc_simplify_spacing (gfc_expr
* x
)
3446 mpf_t i1
, i2
, ln2
, absv
, lnx
;
3451 if (x
->expr_type
!= EXPR_CONSTANT
)
3454 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
);
3456 gfc_internal_error ("gfc_simplify_spacing(): Bad kind");
3458 p
= gfc_real_kinds
[i
].digits
;
3460 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3462 if (mpf_cmp (x
->value
.real
, mpf_zero
) == 0)
3464 mpf_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
);
3468 mpf_init_set_ui (i1
, 1);
3469 mpf_init_set_ui (i2
, 2);
3474 natural_logarithm (&i2
, &ln2
);
3476 mpf_abs (absv
, x
->value
.real
);
3477 natural_logarithm (&absv
, &lnx
);
3479 mpf_div (lnx
, lnx
, ln2
);
3480 mpf_trunc (lnx
, lnx
);
3481 mpf_add_ui (lnx
, lnx
, 1);
3483 diff
= (long) mpf_get_d (lnx
) - (long) p
;
3486 exp2
= (unsigned) diff
;
3487 mpf_mul_2exp (result
->value
.real
, i1
, exp2
);
3492 exp2
= (unsigned) diff
;
3493 mpf_div_2exp (result
->value
.real
, i1
, exp2
);
3502 if (mpf_cmp (result
->value
.real
, gfc_real_kinds
[i
].tiny
) < 0)
3503 mpf_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
);
3505 return range_check (result
, "SPACING");
3510 gfc_simplify_sqrt (gfc_expr
* e
)
3513 mpf_t ac
, ad
, s
, t
, w
;
3515 if (e
->expr_type
!= EXPR_CONSTANT
)
3518 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3523 if (mpf_cmp_si (e
->value
.real
, 0) < 0)
3525 mpf_sqrt (result
->value
.real
, e
->value
.real
);
3530 /* Formula taken from Numerical Recipes to avoid over- and
3539 if (mpf_cmp_ui (e
->value
.complex.r
, 0) == 0
3540 && mpf_cmp_ui (e
->value
.complex.i
, 0) == 0)
3543 mpf_set_ui (result
->value
.complex.r
, 0);
3544 mpf_set_ui (result
->value
.complex.i
, 0);
3548 mpf_abs (ac
, e
->value
.complex.r
);
3549 mpf_abs (ad
, e
->value
.complex.i
);
3551 if (mpf_cmp (ac
, ad
) >= 0)
3553 mpf_div (t
, e
->value
.complex.i
, e
->value
.complex.r
);
3555 mpf_add_ui (t
, t
, 1);
3557 mpf_add_ui (t
, t
, 1);
3558 mpf_div_ui (t
, t
, 2);
3565 mpf_div (s
, e
->value
.complex.r
, e
->value
.complex.i
);
3567 mpf_add_ui (t
, t
, 1);
3571 mpf_div_ui (t
, t
, 2);
3577 if (mpf_cmp_ui (w
, 0) != 0 && mpf_cmp_ui (e
->value
.complex.r
, 0) >= 0)
3579 mpf_mul_ui (t
, w
, 2);
3580 mpf_div (result
->value
.complex.i
, e
->value
.complex.i
, t
);
3581 mpf_set (result
->value
.complex.r
, w
);
3583 else if (mpf_cmp_ui (w
, 0) != 0
3584 && mpf_cmp_ui (e
->value
.complex.r
, 0) < 0
3585 && mpf_cmp_ui (e
->value
.complex.i
, 0) >= 0)
3587 mpf_mul_ui (t
, w
, 2);
3588 mpf_div (result
->value
.complex.r
, e
->value
.complex.i
, t
);
3589 mpf_set (result
->value
.complex.i
, w
);
3591 else if (mpf_cmp_ui (w
, 0) != 0
3592 && mpf_cmp_ui (e
->value
.complex.r
, 0) < 0
3593 && mpf_cmp_ui (e
->value
.complex.i
, 0) < 0)
3595 mpf_mul_ui (t
, w
, 2);
3596 mpf_div (result
->value
.complex.r
, ad
, t
);
3598 mpf_set (result
->value
.complex.i
, w
);
3601 gfc_internal_error ("invalid complex argument of SQRT at %L",
3613 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
3616 return range_check (result
, "SQRT");
3619 gfc_free_expr (result
);
3620 gfc_error ("Argument of SQRT at %L has a negative value", &e
->where
);
3621 return &gfc_bad_expr
;
3626 gfc_simplify_tan (gfc_expr
* x
)
3629 mpf_t mpf_sin
, mpf_cos
, mag_cos
;
3632 if (x
->expr_type
!= EXPR_CONSTANT
)
3635 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
);
3637 gfc_internal_error ("gfc_simplify_tan(): Bad kind");
3639 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3644 sine (&x
->value
.real
, &mpf_sin
);
3645 cosine (&x
->value
.real
, &mpf_cos
);
3646 mpf_abs (mag_cos
, mpf_cos
);
3647 if (mpf_cmp_ui (mag_cos
, 0) == 0)
3649 gfc_error ("Tangent undefined at %L", &x
->where
);
3650 mpf_clear (mpf_sin
);
3651 mpf_clear (mpf_cos
);
3652 mpf_clear (mag_cos
);
3653 gfc_free_expr (result
);
3654 return &gfc_bad_expr
;
3656 else if (mpf_cmp (mag_cos
, gfc_real_kinds
[i
].tiny
) < 0)
3658 gfc_error ("Tangent cannot be accurately evaluated at %L", &x
->where
);
3659 mpf_clear (mpf_sin
);
3660 mpf_clear (mpf_cos
);
3661 mpf_clear (mag_cos
);
3662 gfc_free_expr (result
);
3663 return &gfc_bad_expr
;
3667 mpf_div (result
->value
.real
, mpf_sin
, mpf_cos
);
3668 mpf_clear (mpf_sin
);
3669 mpf_clear (mpf_cos
);
3670 mpf_clear (mag_cos
);
3673 return range_check (result
, "TAN");
3678 gfc_simplify_tanh (gfc_expr
* x
)
3683 if (x
->expr_type
!= EXPR_CONSTANT
)
3686 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3691 hypersine (&x
->value
.real
, &xq
);
3692 hypercos (&x
->value
.real
, &xp
);
3694 mpf_div (result
->value
.real
, xq
, xp
);
3699 return range_check (result
, "TANH");
3705 gfc_simplify_tiny (gfc_expr
* e
)
3710 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
);
3712 gfc_internal_error ("gfc_simplify_error(): Bad kind");
3714 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
3715 mpf_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
);
3722 gfc_simplify_trim (gfc_expr
* e
)
3725 int count
, i
, len
, lentrim
;
3727 if (e
->expr_type
!= EXPR_CONSTANT
)
3730 len
= e
->value
.character
.length
;
3732 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
3734 for (count
= 0, i
= 1; i
<= len
; ++i
)
3736 if (e
->value
.character
.string
[len
- i
] == ' ')
3742 lentrim
= len
- count
;
3744 result
->value
.character
.length
= lentrim
;
3745 result
->value
.character
.string
= gfc_getmem (lentrim
+ 1);
3747 for (i
= 0; i
< lentrim
; i
++)
3748 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
3750 result
->value
.character
.string
[lentrim
] = '\0'; /* For debugger */
3757 gfc_simplify_ubound (gfc_expr
* array
, gfc_expr
* dim
)
3759 return gfc_simplify_bound (array
, dim
, 1);
3764 gfc_simplify_verify (gfc_expr
* s
, gfc_expr
* set
, gfc_expr
* b
)
3768 size_t index
, len
, lenset
;
3771 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
)
3774 if (b
!= NULL
&& b
->value
.logical
!= 0)
3779 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind (),
3782 len
= s
->value
.character
.length
;
3783 lenset
= set
->value
.character
.length
;
3787 mpz_set_ui (result
->value
.integer
, 0);
3795 mpz_set_ui (result
->value
.integer
, len
);
3800 strspn (s
->value
.character
.string
, set
->value
.character
.string
) + 1;
3809 mpz_set_ui (result
->value
.integer
, 1);
3812 for (index
= len
; index
> 0; index
--)
3814 for (i
= 0; i
< lenset
; i
++)
3816 if (s
->value
.character
.string
[index
- 1]
3817 == set
->value
.character
.string
[i
])
3825 mpz_set_ui (result
->value
.integer
, index
);
3829 /****************** Constant simplification *****************/
3831 /* Master function to convert one constant to another. While this is
3832 used as a simplification function, it requires the destination type
3833 and kind information which is supplied by a special case in
3837 gfc_convert_constant (gfc_expr
* e
, bt type
, int kind
)
3839 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
3840 gfc_constructor
*head
, *c
, *tail
= NULL
;
3854 f
= gfc_int2complex
;
3871 f
= gfc_real2complex
;
3882 f
= gfc_complex2int
;
3885 f
= gfc_complex2real
;
3888 f
= gfc_complex2complex
;
3897 if (type
!= BT_LOGICAL
)
3904 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
3909 switch (e
->expr_type
)
3912 result
= f (e
, kind
);
3914 return &gfc_bad_expr
;
3918 if (!gfc_is_constant_expr (e
))
3923 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
3926 head
= tail
= gfc_get_constructor ();
3929 tail
->next
= gfc_get_constructor ();
3933 tail
->where
= c
->where
;
3935 if (c
->iterator
== NULL
)
3936 tail
->expr
= f (c
->expr
, kind
);
3939 g
= gfc_convert_constant (c
->expr
, type
, kind
);
3940 if (g
== &gfc_bad_expr
)
3945 if (tail
->expr
== NULL
)
3947 gfc_free_constructor (head
);
3952 result
= gfc_get_expr ();
3953 result
->ts
.type
= type
;
3954 result
->ts
.kind
= kind
;
3955 result
->expr_type
= EXPR_ARRAY
;
3956 result
->value
.constructor
= head
;
3957 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
3958 result
->where
= e
->where
;
3959 result
->rank
= e
->rank
;
3970 /****************** Helper functions ***********************/
3972 /* Given a collating table, create the inverse table. */
3975 invert_table (const int *table
, int *xtable
)
3979 for (i
= 0; i
< 256; i
++)
3982 for (i
= 0; i
< 256; i
++)
3983 xtable
[table
[i
]] = i
;
3988 gfc_simplify_init_1 (void)
3991 mpf_init_set_str (mpf_zero
, "0.0", 10);
3992 mpf_init_set_str (mpf_half
, "0.5", 10);
3993 mpf_init_set_str (mpf_one
, "1.0", 10);
3994 mpz_init_set_str (mpz_zero
, "0", 10);
3996 invert_table (ascii_table
, xascii_table
);
4001 gfc_simplify_done_1 (void)
4004 mpf_clear (mpf_zero
);
4005 mpf_clear (mpf_half
);
4006 mpf_clear (mpf_one
);
4007 mpz_clear (mpz_zero
);
This page took 0.204166 seconds and 6 git commands to generate.