1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
27 #include "intrinsic.h"
28 #include "target-memory.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 /* Range checks an expression node. If all goes well, returns the
68 node, otherwise returns &gfc_bad_expr and frees the node. */
71 range_check (gfc_expr
*result
, const char *name
)
76 switch (gfc_range_check (result
))
82 gfc_error ("Result of %s overflows its kind at %L", name
,
87 gfc_error ("Result of %s underflows its kind at %L", name
,
92 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
96 gfc_error ("Result of %s gives range error for its kind at %L", name
,
101 gfc_free_expr (result
);
102 return &gfc_bad_expr
;
106 /* A helper function that gets an optional and possibly missing
107 kind parameter. Returns the kind, -1 if something went wrong. */
110 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
117 if (k
->expr_type
!= EXPR_CONSTANT
)
119 gfc_error ("KIND parameter of %s at %L must be an initialization "
120 "expression", name
, &k
->where
);
124 if (gfc_extract_int (k
, &kind
) != NULL
125 || gfc_validate_kind (type
, kind
, true) < 0)
127 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
135 /* Helper function to get an integer constant with a kind number given
136 by an integer constant expression. */
138 int_expr_with_kind (int i
, gfc_expr
*kind
, const char *name
)
140 gfc_expr
*res
= gfc_int_expr (i
);
141 res
->ts
.kind
= get_kind (BT_INTEGER
, kind
, name
, gfc_default_integer_kind
);
142 if (res
->ts
.kind
== -1)
149 /* Converts an mpz_t signed variable into an unsigned one, assuming
150 two's complement representations and a binary width of bitsize.
151 The conversion is a no-op unless x is negative; otherwise, it can
152 be accomplished by masking out the high bits. */
155 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
161 /* Confirm that no bits above the signed range are unset. */
162 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
164 mpz_init_set_ui (mask
, 1);
165 mpz_mul_2exp (mask
, mask
, bitsize
);
166 mpz_sub_ui (mask
, mask
, 1);
168 mpz_and (x
, x
, mask
);
174 /* Confirm that no bits above the signed range are set. */
175 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
180 /* Converts an mpz_t unsigned variable into a signed one, assuming
181 two's complement representations and a binary width of bitsize.
182 If the bitsize-1 bit is set, this is taken as a sign bit and
183 the number is converted to the corresponding negative number. */
186 convert_mpz_to_signed (mpz_t x
, int bitsize
)
190 /* Confirm that no bits above the unsigned range are set. */
191 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
193 if (mpz_tstbit (x
, bitsize
- 1) == 1)
195 mpz_init_set_ui (mask
, 1);
196 mpz_mul_2exp (mask
, mask
, bitsize
);
197 mpz_sub_ui (mask
, mask
, 1);
199 /* We negate the number by hand, zeroing the high bits, that is
200 make it the corresponding positive number, and then have it
201 negated by GMP, giving the correct representation of the
204 mpz_add_ui (x
, x
, 1);
205 mpz_and (x
, x
, mask
);
214 /********************** Simplification functions *****************************/
217 gfc_simplify_abs (gfc_expr
*e
)
221 if (e
->expr_type
!= EXPR_CONSTANT
)
227 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
229 mpz_abs (result
->value
.integer
, e
->value
.integer
);
231 result
= range_check (result
, "IABS");
235 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
237 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
239 result
= range_check (result
, "ABS");
243 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
245 gfc_set_model_kind (e
->ts
.kind
);
247 mpfr_hypot (result
->value
.real
, e
->value
.complex.r
,
248 e
->value
.complex.i
, GFC_RND_MODE
);
249 result
= range_check (result
, "CABS");
253 gfc_internal_error ("gfc_simplify_abs(): Bad type");
259 /* We use the processor's collating sequence, because all
260 systems that gfortran currently works on are ASCII. */
263 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
269 if (e
->expr_type
!= EXPR_CONSTANT
)
272 kind
= get_kind (BT_CHARACTER
, k
, "ACHAR", gfc_default_character_kind
);
274 return &gfc_bad_expr
;
276 ch
= gfc_extract_int (e
, &c
);
279 gfc_internal_error ("gfc_simplify_achar: %s", ch
);
281 if (gfc_option
.warn_surprising
&& (c
< 0 || c
> 127))
282 gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
285 result
= gfc_constant_result (BT_CHARACTER
, kind
, &e
->where
);
287 result
->value
.character
.string
= gfc_get_wide_string (2);
289 result
->value
.character
.length
= 1;
290 result
->value
.character
.string
[0] = c
;
291 result
->value
.character
.string
[1] = '\0'; /* For debugger */
297 gfc_simplify_acos (gfc_expr
*x
)
301 if (x
->expr_type
!= EXPR_CONSTANT
)
304 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
305 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
307 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
309 return &gfc_bad_expr
;
312 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
314 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
316 return range_check (result
, "ACOS");
320 gfc_simplify_acosh (gfc_expr
*x
)
324 if (x
->expr_type
!= EXPR_CONSTANT
)
327 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
329 gfc_error ("Argument of ACOSH at %L must not be less than 1",
331 return &gfc_bad_expr
;
334 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
336 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
338 return range_check (result
, "ACOSH");
342 gfc_simplify_adjustl (gfc_expr
*e
)
348 if (e
->expr_type
!= EXPR_CONSTANT
)
351 len
= e
->value
.character
.length
;
353 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
355 result
->value
.character
.length
= len
;
356 result
->value
.character
.string
= gfc_get_wide_string (len
+ 1);
358 for (count
= 0, i
= 0; i
< len
; ++i
)
360 ch
= e
->value
.character
.string
[i
];
366 for (i
= 0; i
< len
- count
; ++i
)
367 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
369 for (i
= len
- count
; i
< len
; ++i
)
370 result
->value
.character
.string
[i
] = ' ';
372 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
379 gfc_simplify_adjustr (gfc_expr
*e
)
385 if (e
->expr_type
!= EXPR_CONSTANT
)
388 len
= e
->value
.character
.length
;
390 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
392 result
->value
.character
.length
= len
;
393 result
->value
.character
.string
= gfc_get_wide_string (len
+ 1);
395 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
397 ch
= e
->value
.character
.string
[i
];
403 for (i
= 0; i
< count
; ++i
)
404 result
->value
.character
.string
[i
] = ' ';
406 for (i
= count
; i
< len
; ++i
)
407 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
409 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
416 gfc_simplify_aimag (gfc_expr
*e
)
420 if (e
->expr_type
!= EXPR_CONSTANT
)
423 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
424 mpfr_set (result
->value
.real
, e
->value
.complex.i
, GFC_RND_MODE
);
426 return range_check (result
, "AIMAG");
431 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
433 gfc_expr
*rtrunc
, *result
;
436 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
438 return &gfc_bad_expr
;
440 if (e
->expr_type
!= EXPR_CONSTANT
)
443 rtrunc
= gfc_copy_expr (e
);
445 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
447 result
= gfc_real2real (rtrunc
, kind
);
448 gfc_free_expr (rtrunc
);
450 return range_check (result
, "AINT");
455 gfc_simplify_dint (gfc_expr
*e
)
457 gfc_expr
*rtrunc
, *result
;
459 if (e
->expr_type
!= EXPR_CONSTANT
)
462 rtrunc
= gfc_copy_expr (e
);
464 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
466 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
467 gfc_free_expr (rtrunc
);
469 return range_check (result
, "DINT");
474 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
479 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
481 return &gfc_bad_expr
;
483 if (e
->expr_type
!= EXPR_CONSTANT
)
486 result
= gfc_constant_result (e
->ts
.type
, kind
, &e
->where
);
488 mpfr_round (result
->value
.real
, e
->value
.real
);
490 return range_check (result
, "ANINT");
495 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
500 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
503 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
504 if (x
->ts
.type
== BT_INTEGER
)
506 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
507 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
508 return range_check (result
, "AND");
510 else /* BT_LOGICAL */
512 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
513 result
->value
.logical
= x
->value
.logical
&& y
->value
.logical
;
521 gfc_simplify_dnint (gfc_expr
*e
)
525 if (e
->expr_type
!= EXPR_CONSTANT
)
528 result
= gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &e
->where
);
530 mpfr_round (result
->value
.real
, e
->value
.real
);
532 return range_check (result
, "DNINT");
537 gfc_simplify_asin (gfc_expr
*x
)
541 if (x
->expr_type
!= EXPR_CONSTANT
)
544 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
545 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
547 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
549 return &gfc_bad_expr
;
552 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
554 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
556 return range_check (result
, "ASIN");
561 gfc_simplify_asinh (gfc_expr
*x
)
565 if (x
->expr_type
!= EXPR_CONSTANT
)
568 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
570 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
572 return range_check (result
, "ASINH");
577 gfc_simplify_atan (gfc_expr
*x
)
581 if (x
->expr_type
!= EXPR_CONSTANT
)
584 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
586 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
588 return range_check (result
, "ATAN");
593 gfc_simplify_atanh (gfc_expr
*x
)
597 if (x
->expr_type
!= EXPR_CONSTANT
)
600 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
601 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
603 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
605 return &gfc_bad_expr
;
608 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
610 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
612 return range_check (result
, "ATANH");
617 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
621 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
624 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
626 if (mpfr_sgn (y
->value
.real
) == 0 && mpfr_sgn (x
->value
.real
) == 0)
628 gfc_error ("If first argument of ATAN2 %L is zero, then the "
629 "second argument must not be zero", &x
->where
);
630 gfc_free_expr (result
);
631 return &gfc_bad_expr
;
634 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
636 return range_check (result
, "ATAN2");
641 gfc_simplify_bessel_j0 (gfc_expr
*x ATTRIBUTE_UNUSED
)
643 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
646 if (x
->expr_type
!= EXPR_CONSTANT
)
649 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
650 gfc_set_model_kind (x
->ts
.kind
);
651 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
653 return range_check (result
, "BESSEL_J0");
661 gfc_simplify_bessel_j1 (gfc_expr
*x ATTRIBUTE_UNUSED
)
663 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
666 if (x
->expr_type
!= EXPR_CONSTANT
)
669 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
670 gfc_set_model_kind (x
->ts
.kind
);
671 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
673 return range_check (result
, "BESSEL_J1");
681 gfc_simplify_bessel_jn (gfc_expr
*order ATTRIBUTE_UNUSED
,
682 gfc_expr
*x ATTRIBUTE_UNUSED
)
684 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
688 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
691 n
= mpz_get_si (order
->value
.integer
);
692 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
693 gfc_set_model_kind (x
->ts
.kind
);
694 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
696 return range_check (result
, "BESSEL_JN");
704 gfc_simplify_bessel_y0 (gfc_expr
*x ATTRIBUTE_UNUSED
)
706 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
709 if (x
->expr_type
!= EXPR_CONSTANT
)
712 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
713 gfc_set_model_kind (x
->ts
.kind
);
714 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
716 return range_check (result
, "BESSEL_Y0");
724 gfc_simplify_bessel_y1 (gfc_expr
*x ATTRIBUTE_UNUSED
)
726 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
729 if (x
->expr_type
!= EXPR_CONSTANT
)
732 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
733 gfc_set_model_kind (x
->ts
.kind
);
734 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
736 return range_check (result
, "BESSEL_Y1");
744 gfc_simplify_bessel_yn (gfc_expr
*order ATTRIBUTE_UNUSED
,
745 gfc_expr
*x ATTRIBUTE_UNUSED
)
747 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
751 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
754 n
= mpz_get_si (order
->value
.integer
);
755 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
756 gfc_set_model_kind (x
->ts
.kind
);
757 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
759 return range_check (result
, "BESSEL_YN");
767 gfc_simplify_bit_size (gfc_expr
*e
)
772 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
773 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
774 mpz_set_ui (result
->value
.integer
, gfc_integer_kinds
[i
].bit_size
);
781 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
785 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
788 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
789 return gfc_logical_expr (0, &e
->where
);
791 return gfc_logical_expr (mpz_tstbit (e
->value
.integer
, b
), &e
->where
);
796 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
798 gfc_expr
*ceil
, *result
;
801 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
803 return &gfc_bad_expr
;
805 if (e
->expr_type
!= EXPR_CONSTANT
)
808 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
810 ceil
= gfc_copy_expr (e
);
812 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
813 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
);
815 gfc_free_expr (ceil
);
817 return range_check (result
, "CEILING");
822 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
828 kind
= get_kind (BT_CHARACTER
, k
, "CHAR", gfc_default_character_kind
);
830 return &gfc_bad_expr
;
832 if (e
->expr_type
!= EXPR_CONSTANT
)
835 ch
= gfc_extract_int (e
, &c
);
838 gfc_internal_error ("gfc_simplify_char: %s", ch
);
840 if (c
< 0 || c
> UCHAR_MAX
)
841 gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
844 result
= gfc_constant_result (BT_CHARACTER
, kind
, &e
->where
);
846 result
->value
.character
.length
= 1;
847 result
->value
.character
.string
= gfc_get_wide_string (2);
849 result
->value
.character
.string
[0] = c
;
850 result
->value
.character
.string
[1] = '\0'; /* For debugger */
856 /* Common subroutine for simplifying CMPLX and DCMPLX. */
859 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
863 result
= gfc_constant_result (BT_COMPLEX
, kind
, &x
->where
);
865 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
871 mpfr_set_z (result
->value
.complex.r
, x
->value
.integer
, GFC_RND_MODE
);
875 mpfr_set (result
->value
.complex.r
, x
->value
.real
, GFC_RND_MODE
);
879 mpfr_set (result
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
880 mpfr_set (result
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
884 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
893 mpfr_set_z (result
->value
.complex.i
, y
->value
.integer
, GFC_RND_MODE
);
897 mpfr_set (result
->value
.complex.i
, y
->value
.real
, GFC_RND_MODE
);
901 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
910 ts
.kind
= result
->ts
.kind
;
912 if (!gfc_convert_boz (x
, &ts
))
913 return &gfc_bad_expr
;
914 mpfr_set (result
->value
.complex.r
, x
->value
.real
, GFC_RND_MODE
);
921 ts
.kind
= result
->ts
.kind
;
923 if (!gfc_convert_boz (y
, &ts
))
924 return &gfc_bad_expr
;
925 mpfr_set (result
->value
.complex.i
, y
->value
.real
, GFC_RND_MODE
);
928 return range_check (result
, name
);
932 /* Function called when we won't simplify an expression like CMPLX (or
933 COMPLEX or DCMPLX) but still want to convert BOZ arguments. */
936 only_convert_cmplx_boz (gfc_expr
*x
, gfc_expr
*y
, int kind
)
944 if (!gfc_convert_boz (x
, &ts
))
945 return &gfc_bad_expr
;
954 if (!gfc_convert_boz (y
, &ts
))
955 return &gfc_bad_expr
;
963 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
967 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_real_kind
);
969 return &gfc_bad_expr
;
971 if (x
->expr_type
!= EXPR_CONSTANT
972 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
973 return only_convert_cmplx_boz (x
, y
, kind
);
975 return simplify_cmplx ("CMPLX", x
, y
, kind
);
980 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
984 if (x
->ts
.type
== BT_INTEGER
)
986 if (y
->ts
.type
== BT_INTEGER
)
987 kind
= gfc_default_real_kind
;
993 if (y
->ts
.type
== BT_REAL
)
994 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
999 if (x
->expr_type
!= EXPR_CONSTANT
1000 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1001 return only_convert_cmplx_boz (x
, y
, kind
);
1003 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1008 gfc_simplify_conjg (gfc_expr
*e
)
1012 if (e
->expr_type
!= EXPR_CONSTANT
)
1015 result
= gfc_copy_expr (e
);
1016 mpfr_neg (result
->value
.complex.i
, result
->value
.complex.i
, GFC_RND_MODE
);
1018 return range_check (result
, "CONJG");
1023 gfc_simplify_cos (gfc_expr
*x
)
1028 if (x
->expr_type
!= EXPR_CONSTANT
)
1031 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1036 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1039 gfc_set_model_kind (x
->ts
.kind
);
1043 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
1044 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
1045 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
1047 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
1048 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
1049 mpfr_mul (xp
, xp
, xq
, GFC_RND_MODE
);
1050 mpfr_neg (result
->value
.complex.i
, xp
, GFC_RND_MODE
);
1056 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1059 return range_check (result
, "COS");
1065 gfc_simplify_cosh (gfc_expr
*x
)
1069 if (x
->expr_type
!= EXPR_CONSTANT
)
1072 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1074 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1076 return range_check (result
, "COSH");
1081 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1084 if (x
->expr_type
!= EXPR_CONSTANT
1085 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1086 return only_convert_cmplx_boz (x
, y
, gfc_default_double_kind
);
1088 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
1093 gfc_simplify_dble (gfc_expr
*e
)
1097 if (e
->expr_type
!= EXPR_CONSTANT
)
1104 result
= gfc_int2real (e
, gfc_default_double_kind
);
1108 result
= gfc_real2real (e
, gfc_default_double_kind
);
1112 result
= gfc_complex2real (e
, gfc_default_double_kind
);
1116 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e
->where
);
1119 if (e
->ts
.type
== BT_INTEGER
&& e
->is_boz
)
1124 ts
.kind
= gfc_default_double_kind
;
1125 result
= gfc_copy_expr (e
);
1126 if (!gfc_convert_boz (result
, &ts
))
1128 gfc_free_expr (result
);
1129 return &gfc_bad_expr
;
1133 return range_check (result
, "DBLE");
1138 gfc_simplify_digits (gfc_expr
*x
)
1142 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1146 digits
= gfc_integer_kinds
[i
].digits
;
1151 digits
= gfc_real_kinds
[i
].digits
;
1158 return gfc_int_expr (digits
);
1163 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
1168 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1171 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1172 result
= gfc_constant_result (x
->ts
.type
, kind
, &x
->where
);
1177 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
1178 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1180 mpz_set_ui (result
->value
.integer
, 0);
1185 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
1186 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
1189 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1194 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1197 return range_check (result
, "DIM");
1202 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
1204 gfc_expr
*a1
, *a2
, *result
;
1206 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1209 result
= gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &x
->where
);
1211 a1
= gfc_real2real (x
, gfc_default_double_kind
);
1212 a2
= gfc_real2real (y
, gfc_default_double_kind
);
1214 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
1219 return range_check (result
, "DPROD");
1224 gfc_simplify_erf (gfc_expr
*x
)
1228 if (x
->expr_type
!= EXPR_CONSTANT
)
1231 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1233 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1235 return range_check (result
, "ERF");
1240 gfc_simplify_erfc (gfc_expr
*x
)
1244 if (x
->expr_type
!= EXPR_CONSTANT
)
1247 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1249 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1251 return range_check (result
, "ERFC");
1256 gfc_simplify_epsilon (gfc_expr
*e
)
1261 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1263 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
1265 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
1267 return range_check (result
, "EPSILON");
1272 gfc_simplify_exp (gfc_expr
*x
)
1277 if (x
->expr_type
!= EXPR_CONSTANT
)
1280 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1285 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1289 gfc_set_model_kind (x
->ts
.kind
);
1292 mpfr_exp (xq
, x
->value
.complex.r
, GFC_RND_MODE
);
1293 mpfr_cos (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
1294 mpfr_mul (result
->value
.complex.r
, xq
, xp
, GFC_RND_MODE
);
1295 mpfr_sin (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
1296 mpfr_mul (result
->value
.complex.i
, xq
, xp
, GFC_RND_MODE
);
1302 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1305 return range_check (result
, "EXP");
1309 gfc_simplify_exponent (gfc_expr
*x
)
1314 if (x
->expr_type
!= EXPR_CONSTANT
)
1317 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1320 gfc_set_model (x
->value
.real
);
1322 if (mpfr_sgn (x
->value
.real
) == 0)
1324 mpz_set_ui (result
->value
.integer
, 0);
1328 i
= (int) mpfr_get_exp (x
->value
.real
);
1329 mpz_set_si (result
->value
.integer
, i
);
1331 return range_check (result
, "EXPONENT");
1336 gfc_simplify_float (gfc_expr
*a
)
1340 if (a
->expr_type
!= EXPR_CONSTANT
)
1349 ts
.kind
= gfc_default_real_kind
;
1351 result
= gfc_copy_expr (a
);
1352 if (!gfc_convert_boz (result
, &ts
))
1354 gfc_free_expr (result
);
1355 return &gfc_bad_expr
;
1359 result
= gfc_int2real (a
, gfc_default_real_kind
);
1360 return range_check (result
, "FLOAT");
1365 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
1371 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
1373 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1375 if (e
->expr_type
!= EXPR_CONSTANT
)
1378 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1380 gfc_set_model_kind (kind
);
1382 mpfr_floor (floor
, e
->value
.real
);
1384 gfc_mpfr_to_mpz (result
->value
.integer
, floor
);
1388 return range_check (result
, "FLOOR");
1393 gfc_simplify_fraction (gfc_expr
*x
)
1396 mpfr_t absv
, exp
, pow2
;
1398 if (x
->expr_type
!= EXPR_CONSTANT
)
1401 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
1403 gfc_set_model_kind (x
->ts
.kind
);
1405 if (mpfr_sgn (x
->value
.real
) == 0)
1407 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1415 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
1416 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
1418 mpfr_trunc (exp
, exp
);
1419 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
1421 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
1423 mpfr_div (result
->value
.real
, absv
, pow2
, GFC_RND_MODE
);
1429 return range_check (result
, "FRACTION");
1434 gfc_simplify_gamma (gfc_expr
*x
)
1438 if (x
->expr_type
!= EXPR_CONSTANT
)
1441 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1443 gfc_set_model_kind (x
->ts
.kind
);
1445 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1447 return range_check (result
, "GAMMA");
1452 gfc_simplify_huge (gfc_expr
*e
)
1457 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1459 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1464 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
1468 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
1480 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
1484 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1487 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1488 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
1489 return range_check (result
, "HYPOT");
1493 /* We use the processor's collating sequence, because all
1494 systems that gfortran currently works on are ASCII. */
1497 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
1502 if (e
->expr_type
!= EXPR_CONSTANT
)
1505 if (e
->value
.character
.length
!= 1)
1507 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
1508 return &gfc_bad_expr
;
1511 index
= e
->value
.character
.string
[0];
1513 if (gfc_option
.warn_surprising
&& index
> 127)
1514 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1517 if ((result
= int_expr_with_kind (index
, kind
, "IACHAR")) == NULL
)
1518 return &gfc_bad_expr
;
1520 result
->where
= e
->where
;
1522 return range_check (result
, "IACHAR");
1527 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
1531 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1534 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1536 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1538 return range_check (result
, "IAND");
1543 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
1548 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1551 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1553 gfc_error ("Invalid second argument of IBCLR at %L", &y
->where
);
1554 return &gfc_bad_expr
;
1557 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1559 if (pos
>= gfc_integer_kinds
[k
].bit_size
)
1561 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1563 return &gfc_bad_expr
;
1566 result
= gfc_copy_expr (x
);
1568 convert_mpz_to_unsigned (result
->value
.integer
,
1569 gfc_integer_kinds
[k
].bit_size
);
1571 mpz_clrbit (result
->value
.integer
, pos
);
1573 convert_mpz_to_signed (result
->value
.integer
,
1574 gfc_integer_kinds
[k
].bit_size
);
1581 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
1588 if (x
->expr_type
!= EXPR_CONSTANT
1589 || y
->expr_type
!= EXPR_CONSTANT
1590 || z
->expr_type
!= EXPR_CONSTANT
)
1593 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1595 gfc_error ("Invalid second argument of IBITS at %L", &y
->where
);
1596 return &gfc_bad_expr
;
1599 if (gfc_extract_int (z
, &len
) != NULL
|| len
< 0)
1601 gfc_error ("Invalid third argument of IBITS at %L", &z
->where
);
1602 return &gfc_bad_expr
;
1605 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
1607 bitsize
= gfc_integer_kinds
[k
].bit_size
;
1609 if (pos
+ len
> bitsize
)
1611 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1612 "bit size at %L", &y
->where
);
1613 return &gfc_bad_expr
;
1616 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1617 convert_mpz_to_unsigned (result
->value
.integer
,
1618 gfc_integer_kinds
[k
].bit_size
);
1620 bits
= gfc_getmem (bitsize
* sizeof (int));
1622 for (i
= 0; i
< bitsize
; i
++)
1625 for (i
= 0; i
< len
; i
++)
1626 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
1628 for (i
= 0; i
< bitsize
; i
++)
1631 mpz_clrbit (result
->value
.integer
, i
);
1632 else if (bits
[i
] == 1)
1633 mpz_setbit (result
->value
.integer
, i
);
1635 gfc_internal_error ("IBITS: Bad bit");
1640 convert_mpz_to_signed (result
->value
.integer
,
1641 gfc_integer_kinds
[k
].bit_size
);
1648 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
1653 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1656 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1658 gfc_error ("Invalid second argument of IBSET at %L", &y
->where
);
1659 return &gfc_bad_expr
;
1662 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1664 if (pos
>= gfc_integer_kinds
[k
].bit_size
)
1666 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1668 return &gfc_bad_expr
;
1671 result
= gfc_copy_expr (x
);
1673 convert_mpz_to_unsigned (result
->value
.integer
,
1674 gfc_integer_kinds
[k
].bit_size
);
1676 mpz_setbit (result
->value
.integer
, pos
);
1678 convert_mpz_to_signed (result
->value
.integer
,
1679 gfc_integer_kinds
[k
].bit_size
);
1686 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
1691 if (e
->expr_type
!= EXPR_CONSTANT
)
1694 if (e
->value
.character
.length
!= 1)
1696 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
1697 return &gfc_bad_expr
;
1700 index
= e
->value
.character
.string
[0];
1701 if (index
> UCHAR_MAX
)
1702 gfc_internal_error("Argument of ICHAR at %L out of range", &e
->where
);
1704 if ((result
= int_expr_with_kind (index
, kind
, "ICHAR")) == NULL
)
1705 return &gfc_bad_expr
;
1707 result
->where
= e
->where
;
1708 return range_check (result
, "ICHAR");
1713 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
1717 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1720 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1722 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1724 return range_check (result
, "IEOR");
1729 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
1732 int back
, len
, lensub
;
1733 int i
, j
, k
, count
, index
= 0, start
;
1735 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
1736 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
1739 if (b
!= NULL
&& b
->value
.logical
!= 0)
1744 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
1746 return &gfc_bad_expr
;
1748 result
= gfc_constant_result (BT_INTEGER
, k
, &x
->where
);
1750 len
= x
->value
.character
.length
;
1751 lensub
= y
->value
.character
.length
;
1755 mpz_set_si (result
->value
.integer
, 0);
1763 mpz_set_si (result
->value
.integer
, 1);
1766 else if (lensub
== 1)
1768 for (i
= 0; i
< len
; i
++)
1770 for (j
= 0; j
< lensub
; j
++)
1772 if (y
->value
.character
.string
[j
]
1773 == x
->value
.character
.string
[i
])
1783 for (i
= 0; i
< len
; i
++)
1785 for (j
= 0; j
< lensub
; j
++)
1787 if (y
->value
.character
.string
[j
]
1788 == x
->value
.character
.string
[i
])
1793 for (k
= 0; k
< lensub
; k
++)
1795 if (y
->value
.character
.string
[k
]
1796 == x
->value
.character
.string
[k
+ start
])
1800 if (count
== lensub
)
1815 mpz_set_si (result
->value
.integer
, len
+ 1);
1818 else if (lensub
== 1)
1820 for (i
= 0; i
< len
; i
++)
1822 for (j
= 0; j
< lensub
; j
++)
1824 if (y
->value
.character
.string
[j
]
1825 == x
->value
.character
.string
[len
- i
])
1827 index
= len
- i
+ 1;
1835 for (i
= 0; i
< len
; i
++)
1837 for (j
= 0; j
< lensub
; j
++)
1839 if (y
->value
.character
.string
[j
]
1840 == x
->value
.character
.string
[len
- i
])
1843 if (start
<= len
- lensub
)
1846 for (k
= 0; k
< lensub
; k
++)
1847 if (y
->value
.character
.string
[k
]
1848 == x
->value
.character
.string
[k
+ start
])
1851 if (count
== lensub
)
1868 mpz_set_si (result
->value
.integer
, index
);
1869 return range_check (result
, "INDEX");
1874 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
1876 gfc_expr
*result
= NULL
;
1879 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
1881 return &gfc_bad_expr
;
1883 if (e
->expr_type
!= EXPR_CONSTANT
)
1889 result
= gfc_int2int (e
, kind
);
1893 result
= gfc_real2int (e
, kind
);
1897 result
= gfc_complex2int (e
, kind
);
1901 gfc_error ("Argument of INT at %L is not a valid type", &e
->where
);
1902 return &gfc_bad_expr
;
1905 return range_check (result
, "INT");
1910 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
1912 gfc_expr
*result
= NULL
;
1914 if (e
->expr_type
!= EXPR_CONSTANT
)
1920 result
= gfc_int2int (e
, kind
);
1924 result
= gfc_real2int (e
, kind
);
1928 result
= gfc_complex2int (e
, kind
);
1932 gfc_error ("Argument of %s at %L is not a valid type", name
, &e
->where
);
1933 return &gfc_bad_expr
;
1936 return range_check (result
, name
);
1941 gfc_simplify_int2 (gfc_expr
*e
)
1943 return simplify_intconv (e
, 2, "INT2");
1948 gfc_simplify_int8 (gfc_expr
*e
)
1950 return simplify_intconv (e
, 8, "INT8");
1955 gfc_simplify_long (gfc_expr
*e
)
1957 return simplify_intconv (e
, 4, "LONG");
1962 gfc_simplify_ifix (gfc_expr
*e
)
1964 gfc_expr
*rtrunc
, *result
;
1966 if (e
->expr_type
!= EXPR_CONSTANT
)
1969 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1972 rtrunc
= gfc_copy_expr (e
);
1974 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1975 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1977 gfc_free_expr (rtrunc
);
1978 return range_check (result
, "IFIX");
1983 gfc_simplify_idint (gfc_expr
*e
)
1985 gfc_expr
*rtrunc
, *result
;
1987 if (e
->expr_type
!= EXPR_CONSTANT
)
1990 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1993 rtrunc
= gfc_copy_expr (e
);
1995 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1996 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1998 gfc_free_expr (rtrunc
);
1999 return range_check (result
, "IDINT");
2004 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
2008 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2011 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2013 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2014 return range_check (result
, "IOR");
2019 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
2022 int shift
, ashift
, isize
, k
, *bits
, i
;
2024 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
2027 if (gfc_extract_int (s
, &shift
) != NULL
)
2029 gfc_error ("Invalid second argument of ISHFT at %L", &s
->where
);
2030 return &gfc_bad_expr
;
2033 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
2035 isize
= gfc_integer_kinds
[k
].bit_size
;
2044 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
2045 "at %L", &s
->where
);
2046 return &gfc_bad_expr
;
2049 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2053 mpz_set (result
->value
.integer
, e
->value
.integer
);
2054 return range_check (result
, "ISHFT");
2057 bits
= gfc_getmem (isize
* sizeof (int));
2059 for (i
= 0; i
< isize
; i
++)
2060 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
2064 for (i
= 0; i
< shift
; i
++)
2065 mpz_clrbit (result
->value
.integer
, i
);
2067 for (i
= 0; i
< isize
- shift
; i
++)
2070 mpz_clrbit (result
->value
.integer
, i
+ shift
);
2072 mpz_setbit (result
->value
.integer
, i
+ shift
);
2077 for (i
= isize
- 1; i
>= isize
- ashift
; i
--)
2078 mpz_clrbit (result
->value
.integer
, i
);
2080 for (i
= isize
- 1; i
>= ashift
; i
--)
2083 mpz_clrbit (result
->value
.integer
, i
- ashift
);
2085 mpz_setbit (result
->value
.integer
, i
- ashift
);
2089 convert_mpz_to_signed (result
->value
.integer
, isize
);
2097 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
2100 int shift
, ashift
, isize
, ssize
, delta
, k
;
2103 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
2106 if (gfc_extract_int (s
, &shift
) != NULL
)
2108 gfc_error ("Invalid second argument of ISHFTC at %L", &s
->where
);
2109 return &gfc_bad_expr
;
2112 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2113 isize
= gfc_integer_kinds
[k
].bit_size
;
2117 if (sz
->expr_type
!= EXPR_CONSTANT
)
2120 if (gfc_extract_int (sz
, &ssize
) != NULL
|| ssize
<= 0)
2122 gfc_error ("Invalid third argument of ISHFTC at %L", &sz
->where
);
2123 return &gfc_bad_expr
;
2128 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
2129 "BIT_SIZE of first argument at %L", &s
->where
);
2130 return &gfc_bad_expr
;
2144 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2145 "third argument at %L", &s
->where
);
2147 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2148 "BIT_SIZE of first argument at %L", &s
->where
);
2149 return &gfc_bad_expr
;
2152 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2154 mpz_set (result
->value
.integer
, e
->value
.integer
);
2159 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
2161 bits
= gfc_getmem (ssize
* sizeof (int));
2163 for (i
= 0; i
< ssize
; i
++)
2164 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
2166 delta
= ssize
- ashift
;
2170 for (i
= 0; i
< delta
; i
++)
2173 mpz_clrbit (result
->value
.integer
, i
+ shift
);
2175 mpz_setbit (result
->value
.integer
, i
+ shift
);
2178 for (i
= delta
; i
< ssize
; i
++)
2181 mpz_clrbit (result
->value
.integer
, i
- delta
);
2183 mpz_setbit (result
->value
.integer
, i
- delta
);
2188 for (i
= 0; i
< ashift
; i
++)
2191 mpz_clrbit (result
->value
.integer
, i
+ delta
);
2193 mpz_setbit (result
->value
.integer
, i
+ delta
);
2196 for (i
= ashift
; i
< ssize
; i
++)
2199 mpz_clrbit (result
->value
.integer
, i
+ shift
);
2201 mpz_setbit (result
->value
.integer
, i
+ shift
);
2205 convert_mpz_to_signed (result
->value
.integer
, isize
);
2213 gfc_simplify_kind (gfc_expr
*e
)
2216 if (e
->ts
.type
== BT_DERIVED
)
2218 gfc_error ("Argument of KIND at %L is a DERIVED type", &e
->where
);
2219 return &gfc_bad_expr
;
2222 return gfc_int_expr (e
->ts
.kind
);
2227 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
2230 gfc_expr
*l
, *u
, *result
;
2233 /* The last dimension of an assumed-size array is special. */
2234 if (d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
2236 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
2237 return gfc_copy_expr (as
->lower
[d
-1]);
2242 /* Then, we need to know the extent of the given dimension. */
2246 if (l
->expr_type
!= EXPR_CONSTANT
|| u
->expr_type
!= EXPR_CONSTANT
)
2249 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
2250 gfc_default_integer_kind
);
2252 return &gfc_bad_expr
;
2254 result
= gfc_constant_result (BT_INTEGER
, k
, &array
->where
);
2256 if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
2260 mpz_set_si (result
->value
.integer
, 0);
2262 mpz_set_si (result
->value
.integer
, 1);
2266 /* Nonzero extent. */
2268 mpz_set (result
->value
.integer
, u
->value
.integer
);
2270 mpz_set (result
->value
.integer
, l
->value
.integer
);
2273 return range_check (result
, upper
? "UBOUND" : "LBOUND");
2278 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
2284 if (array
->expr_type
!= EXPR_VARIABLE
)
2287 /* Follow any component references. */
2288 as
= array
->symtree
->n
.sym
->as
;
2289 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2294 switch (ref
->u
.ar
.type
)
2301 /* We're done because 'as' has already been set in the
2302 previous iteration. */
2313 as
= ref
->u
.c
.component
->as
;
2325 if (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
)
2330 /* Multi-dimensional bounds. */
2331 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
2333 gfc_constructor
*head
, *tail
;
2336 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2337 if (upper
&& as
->type
== AS_ASSUMED_SIZE
)
2339 /* An error message will be emitted in
2340 check_assumed_size_reference (resolve.c). */
2341 return &gfc_bad_expr
;
2344 /* Simplify the bounds for each dimension. */
2345 for (d
= 0; d
< array
->rank
; d
++)
2347 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
);
2348 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
2352 for (j
= 0; j
< d
; j
++)
2353 gfc_free_expr (bounds
[j
]);
2358 /* Allocate the result expression. */
2359 e
= gfc_get_expr ();
2360 e
->where
= array
->where
;
2361 e
->expr_type
= EXPR_ARRAY
;
2362 e
->ts
.type
= BT_INTEGER
;
2363 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
2364 gfc_default_integer_kind
);
2368 return &gfc_bad_expr
;
2372 /* The result is a rank 1 array; its size is the rank of the first
2373 argument to {L,U}BOUND. */
2375 e
->shape
= gfc_get_shape (1);
2376 mpz_init_set_ui (e
->shape
[0], array
->rank
);
2378 /* Create the constructor for this array. */
2380 for (d
= 0; d
< array
->rank
; d
++)
2382 /* Get a new constructor element. */
2384 head
= tail
= gfc_get_constructor ();
2387 tail
->next
= gfc_get_constructor ();
2391 tail
->where
= e
->where
;
2392 tail
->expr
= bounds
[d
];
2394 e
->value
.constructor
= head
;
2400 /* A DIM argument is specified. */
2401 if (dim
->expr_type
!= EXPR_CONSTANT
)
2404 d
= mpz_get_si (dim
->value
.integer
);
2406 if (d
< 1 || d
> as
->rank
2407 || (d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
2409 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
2410 return &gfc_bad_expr
;
2413 return simplify_bound_dim (array
, kind
, d
, upper
, as
);
2419 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2421 return simplify_bound (array
, dim
, kind
, 0);
2426 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
2429 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
2432 return &gfc_bad_expr
;
2434 if (e
->expr_type
== EXPR_CONSTANT
)
2436 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
2437 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
2438 return range_check (result
, "LEN");
2441 if (e
->ts
.cl
!= NULL
&& e
->ts
.cl
->length
!= NULL
2442 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
2443 && e
->ts
.cl
->length
->ts
.type
== BT_INTEGER
)
2445 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
2446 mpz_set (result
->value
.integer
, e
->ts
.cl
->length
->value
.integer
);
2447 return range_check (result
, "LEN");
2455 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
2458 int count
, len
, lentrim
, i
;
2459 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
2462 return &gfc_bad_expr
;
2464 if (e
->expr_type
!= EXPR_CONSTANT
)
2467 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
2468 len
= e
->value
.character
.length
;
2470 for (count
= 0, i
= 1; i
<= len
; i
++)
2471 if (e
->value
.character
.string
[len
- i
] == ' ')
2476 lentrim
= len
- count
;
2478 mpz_set_si (result
->value
.integer
, lentrim
);
2479 return range_check (result
, "LEN_TRIM");
2483 gfc_simplify_lgamma (gfc_expr
*x ATTRIBUTE_UNUSED
)
2485 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
2489 if (x
->expr_type
!= EXPR_CONSTANT
)
2492 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2494 gfc_set_model_kind (x
->ts
.kind
);
2496 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
2498 return range_check (result
, "LGAMMA");
2506 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
2508 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2511 return gfc_logical_expr (gfc_compare_string (a
, b
) >= 0, &a
->where
);
2516 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
2518 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2521 return gfc_logical_expr (gfc_compare_string (a
, b
) > 0,
2527 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
2529 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2532 return gfc_logical_expr (gfc_compare_string (a
, b
) <= 0, &a
->where
);
2537 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
2539 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2542 return gfc_logical_expr (gfc_compare_string (a
, b
) < 0, &a
->where
);
2547 gfc_simplify_log (gfc_expr
*x
)
2552 if (x
->expr_type
!= EXPR_CONSTANT
)
2555 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2557 gfc_set_model_kind (x
->ts
.kind
);
2562 if (mpfr_sgn (x
->value
.real
) <= 0)
2564 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2565 "to zero", &x
->where
);
2566 gfc_free_expr (result
);
2567 return &gfc_bad_expr
;
2570 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2574 if ((mpfr_sgn (x
->value
.complex.r
) == 0)
2575 && (mpfr_sgn (x
->value
.complex.i
) == 0))
2577 gfc_error ("Complex argument of LOG at %L cannot be zero",
2579 gfc_free_expr (result
);
2580 return &gfc_bad_expr
;
2586 mpfr_atan2 (result
->value
.complex.i
, x
->value
.complex.i
,
2587 x
->value
.complex.r
, GFC_RND_MODE
);
2589 mpfr_mul (xr
, x
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
2590 mpfr_mul (xi
, x
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
2591 mpfr_add (xr
, xr
, xi
, GFC_RND_MODE
);
2592 mpfr_sqrt (xr
, xr
, GFC_RND_MODE
);
2593 mpfr_log (result
->value
.complex.r
, xr
, GFC_RND_MODE
);
2601 gfc_internal_error ("gfc_simplify_log: bad type");
2604 return range_check (result
, "LOG");
2609 gfc_simplify_log10 (gfc_expr
*x
)
2613 if (x
->expr_type
!= EXPR_CONSTANT
)
2616 gfc_set_model_kind (x
->ts
.kind
);
2618 if (mpfr_sgn (x
->value
.real
) <= 0)
2620 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2621 "to zero", &x
->where
);
2622 return &gfc_bad_expr
;
2625 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2627 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2629 return range_check (result
, "LOG10");
2634 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
2639 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
2641 return &gfc_bad_expr
;
2643 if (e
->expr_type
!= EXPR_CONSTANT
)
2646 result
= gfc_constant_result (BT_LOGICAL
, kind
, &e
->where
);
2648 result
->value
.logical
= e
->value
.logical
;
2654 /* This function is special since MAX() can take any number of
2655 arguments. The simplified expression is a rewritten version of the
2656 argument list containing at most one constant element. Other
2657 constant elements are deleted. Because the argument list has
2658 already been checked, this function always succeeds. sign is 1 for
2659 MAX(), -1 for MIN(). */
2662 simplify_min_max (gfc_expr
*expr
, int sign
)
2664 gfc_actual_arglist
*arg
, *last
, *extremum
;
2665 gfc_intrinsic_sym
* specific
;
2669 specific
= expr
->value
.function
.isym
;
2671 arg
= expr
->value
.function
.actual
;
2673 for (; arg
; last
= arg
, arg
= arg
->next
)
2675 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
2678 if (extremum
== NULL
)
2684 switch (arg
->expr
->ts
.type
)
2687 if (mpz_cmp (arg
->expr
->value
.integer
,
2688 extremum
->expr
->value
.integer
) * sign
> 0)
2689 mpz_set (extremum
->expr
->value
.integer
, arg
->expr
->value
.integer
);
2693 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
2695 mpfr_max (extremum
->expr
->value
.real
, extremum
->expr
->value
.real
,
2696 arg
->expr
->value
.real
, GFC_RND_MODE
);
2698 mpfr_min (extremum
->expr
->value
.real
, extremum
->expr
->value
.real
,
2699 arg
->expr
->value
.real
, GFC_RND_MODE
);
2703 #define LENGTH(x) ((x)->expr->value.character.length)
2704 #define STRING(x) ((x)->expr->value.character.string)
2705 if (LENGTH(extremum
) < LENGTH(arg
))
2707 gfc_char_t
*tmp
= STRING(extremum
);
2709 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
2710 memcpy (STRING(extremum
), tmp
,
2711 LENGTH(extremum
) * sizeof (gfc_char_t
));
2712 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
2713 LENGTH(arg
) - LENGTH(extremum
));
2714 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
2715 LENGTH(extremum
) = LENGTH(arg
);
2719 if (gfc_compare_string (arg
->expr
, extremum
->expr
) * sign
> 0)
2721 gfc_free (STRING(extremum
));
2722 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
2723 memcpy (STRING(extremum
), STRING(arg
),
2724 LENGTH(arg
) * sizeof (gfc_char_t
));
2725 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
2726 LENGTH(extremum
) - LENGTH(arg
));
2727 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
2735 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2738 /* Delete the extra constant argument. */
2740 expr
->value
.function
.actual
= arg
->next
;
2742 last
->next
= arg
->next
;
2745 gfc_free_actual_arglist (arg
);
2749 /* If there is one value left, replace the function call with the
2751 if (expr
->value
.function
.actual
->next
!= NULL
)
2754 /* Convert to the correct type and kind. */
2755 if (expr
->ts
.type
!= BT_UNKNOWN
)
2756 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2757 expr
->ts
.type
, expr
->ts
.kind
);
2759 if (specific
->ts
.type
!= BT_UNKNOWN
)
2760 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2761 specific
->ts
.type
, specific
->ts
.kind
);
2763 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
2768 gfc_simplify_min (gfc_expr
*e
)
2770 return simplify_min_max (e
, -1);
2775 gfc_simplify_max (gfc_expr
*e
)
2777 return simplify_min_max (e
, 1);
2782 gfc_simplify_maxexponent (gfc_expr
*x
)
2787 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2789 result
= gfc_int_expr (gfc_real_kinds
[i
].max_exponent
);
2790 result
->where
= x
->where
;
2797 gfc_simplify_minexponent (gfc_expr
*x
)
2802 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2804 result
= gfc_int_expr (gfc_real_kinds
[i
].min_exponent
);
2805 result
->where
= x
->where
;
2812 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
2815 mpfr_t quot
, iquot
, term
;
2818 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2821 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2822 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2827 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2829 /* Result is processor-dependent. */
2830 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
2831 gfc_free_expr (result
);
2832 return &gfc_bad_expr
;
2834 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2838 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2840 /* Result is processor-dependent. */
2841 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
2842 gfc_free_expr (result
);
2843 return &gfc_bad_expr
;
2846 gfc_set_model_kind (kind
);
2851 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2852 mpfr_trunc (iquot
, quot
);
2853 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2854 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2862 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2865 return range_check (result
, "MOD");
2870 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
2873 mpfr_t quot
, iquot
, term
;
2876 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2879 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2880 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2885 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2887 /* Result is processor-dependent. This processor just opts
2888 to not handle it at all. */
2889 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
2890 gfc_free_expr (result
);
2891 return &gfc_bad_expr
;
2893 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2898 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2900 /* Result is processor-dependent. */
2901 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
2902 gfc_free_expr (result
);
2903 return &gfc_bad_expr
;
2906 gfc_set_model_kind (kind
);
2911 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2912 mpfr_floor (iquot
, quot
);
2913 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2914 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2922 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2925 return range_check (result
, "MODULO");
2929 /* Exists for the sole purpose of consistency with other intrinsics. */
2931 gfc_simplify_mvbits (gfc_expr
*f ATTRIBUTE_UNUSED
,
2932 gfc_expr
*fp ATTRIBUTE_UNUSED
,
2933 gfc_expr
*l ATTRIBUTE_UNUSED
,
2934 gfc_expr
*to ATTRIBUTE_UNUSED
,
2935 gfc_expr
*tp ATTRIBUTE_UNUSED
)
2942 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
2945 mp_exp_t emin
, emax
;
2948 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
2951 if (mpfr_sgn (s
->value
.real
) == 0)
2953 gfc_error ("Second argument of NEAREST at %L shall not be zero",
2955 return &gfc_bad_expr
;
2958 gfc_set_model_kind (x
->ts
.kind
);
2959 result
= gfc_copy_expr (x
);
2961 /* Save current values of emin and emax. */
2962 emin
= mpfr_get_emin ();
2963 emax
= mpfr_get_emax ();
2965 /* Set emin and emax for the current model number. */
2966 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
2967 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
2968 mpfr_get_prec(result
->value
.real
) + 1);
2969 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
2971 if (mpfr_sgn (s
->value
.real
) > 0)
2973 mpfr_nextabove (result
->value
.real
);
2974 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
2978 mpfr_nextbelow (result
->value
.real
);
2979 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
2982 mpfr_set_emin (emin
);
2983 mpfr_set_emax (emax
);
2985 /* Only NaN can occur. Do not use range check as it gives an
2986 error for denormal numbers. */
2987 if (mpfr_nan_p (result
->value
.real
) && gfc_option
.flag_range_check
)
2989 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
2990 gfc_free_expr (result
);
2991 return &gfc_bad_expr
;
2999 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
3001 gfc_expr
*itrunc
, *result
;
3004 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
3006 return &gfc_bad_expr
;
3008 if (e
->expr_type
!= EXPR_CONSTANT
)
3011 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
3013 itrunc
= gfc_copy_expr (e
);
3015 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
3017 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
);
3019 gfc_free_expr (itrunc
);
3021 return range_check (result
, name
);
3026 gfc_simplify_new_line (gfc_expr
*e
)
3030 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
3031 result
->value
.character
.string
= gfc_get_wide_string (2);
3032 result
->value
.character
.length
= 1;
3033 result
->value
.character
.string
[0] = '\n';
3034 result
->value
.character
.string
[1] = '\0'; /* For debugger */
3040 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
3042 return simplify_nint ("NINT", e
, k
);
3047 gfc_simplify_idnint (gfc_expr
*e
)
3049 return simplify_nint ("IDNINT", e
, NULL
);
3054 gfc_simplify_not (gfc_expr
*e
)
3058 if (e
->expr_type
!= EXPR_CONSTANT
)
3061 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3063 mpz_com (result
->value
.integer
, e
->value
.integer
);
3065 return range_check (result
, "NOT");
3070 gfc_simplify_null (gfc_expr
*mold
)
3076 result
= gfc_get_expr ();
3077 result
->ts
.type
= BT_UNKNOWN
;
3080 result
= gfc_copy_expr (mold
);
3081 result
->expr_type
= EXPR_NULL
;
3088 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
3093 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3096 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
3097 if (x
->ts
.type
== BT_INTEGER
)
3099 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
3100 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3101 return range_check (result
, "OR");
3103 else /* BT_LOGICAL */
3105 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
3106 result
->value
.logical
= x
->value
.logical
|| y
->value
.logical
;
3113 gfc_simplify_precision (gfc_expr
*e
)
3118 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3120 result
= gfc_int_expr (gfc_real_kinds
[i
].precision
);
3121 result
->where
= e
->where
;
3128 gfc_simplify_radix (gfc_expr
*e
)
3133 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3137 i
= gfc_integer_kinds
[i
].radix
;
3141 i
= gfc_real_kinds
[i
].radix
;
3148 result
= gfc_int_expr (i
);
3149 result
->where
= e
->where
;
3156 gfc_simplify_range (gfc_expr
*e
)
3162 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3167 j
= gfc_integer_kinds
[i
].range
;
3172 j
= gfc_real_kinds
[i
].range
;
3179 result
= gfc_int_expr (j
);
3180 result
->where
= e
->where
;
3187 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
3192 if (e
->ts
.type
== BT_COMPLEX
)
3193 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
3195 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
3198 return &gfc_bad_expr
;
3200 if (e
->expr_type
!= EXPR_CONSTANT
)
3207 result
= gfc_int2real (e
, kind
);
3211 result
= gfc_real2real (e
, kind
);
3215 result
= gfc_complex2real (e
, kind
);
3219 gfc_internal_error ("bad type in REAL");
3223 if (e
->ts
.type
== BT_INTEGER
&& e
->is_boz
)
3229 result
= gfc_copy_expr (e
);
3230 if (!gfc_convert_boz (result
, &ts
))
3232 gfc_free_expr (result
);
3233 return &gfc_bad_expr
;
3237 return range_check (result
, "REAL");
3242 gfc_simplify_realpart (gfc_expr
*e
)
3246 if (e
->expr_type
!= EXPR_CONSTANT
)
3249 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
3250 mpfr_set (result
->value
.real
, e
->value
.complex.r
, GFC_RND_MODE
);
3252 return range_check (result
, "REALPART");
3256 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
3259 int i
, j
, len
, ncop
, nlen
;
3261 bool have_length
= false;
3263 /* If NCOPIES isn't a constant, there's nothing we can do. */
3264 if (n
->expr_type
!= EXPR_CONSTANT
)
3267 /* If NCOPIES is negative, it's an error. */
3268 if (mpz_sgn (n
->value
.integer
) < 0)
3270 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3272 return &gfc_bad_expr
;
3275 /* If we don't know the character length, we can do no more. */
3276 if (e
->ts
.cl
&& e
->ts
.cl
->length
3277 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
3279 len
= mpz_get_si (e
->ts
.cl
->length
->value
.integer
);
3282 else if (e
->expr_type
== EXPR_CONSTANT
3283 && (e
->ts
.cl
== NULL
|| e
->ts
.cl
->length
== NULL
))
3285 len
= e
->value
.character
.length
;
3290 /* If the source length is 0, any value of NCOPIES is valid
3291 and everything behaves as if NCOPIES == 0. */
3294 mpz_set_ui (ncopies
, 0);
3296 mpz_set (ncopies
, n
->value
.integer
);
3298 /* Check that NCOPIES isn't too large. */
3304 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
3306 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
3310 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
3311 e
->ts
.cl
->length
->value
.integer
);
3315 mpz_init_set_si (mlen
, len
);
3316 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
3320 /* The check itself. */
3321 if (mpz_cmp (ncopies
, max
) > 0)
3324 mpz_clear (ncopies
);
3325 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3327 return &gfc_bad_expr
;
3332 mpz_clear (ncopies
);
3334 /* For further simplification, we need the character string to be
3336 if (e
->expr_type
!= EXPR_CONSTANT
)
3340 (e
->ts
.cl
->length
&&
3341 mpz_sgn (e
->ts
.cl
->length
->value
.integer
)) != 0)
3343 const char *res
= gfc_extract_int (n
, &ncop
);
3344 gcc_assert (res
== NULL
);
3349 len
= e
->value
.character
.length
;
3352 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
3356 result
->value
.character
.string
= gfc_get_wide_string (1);
3357 result
->value
.character
.length
= 0;
3358 result
->value
.character
.string
[0] = '\0';
3362 result
->value
.character
.length
= nlen
;
3363 result
->value
.character
.string
= gfc_get_wide_string (nlen
+ 1);
3365 for (i
= 0; i
< ncop
; i
++)
3366 for (j
= 0; j
< len
; j
++)
3367 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
3369 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
3374 /* Test that the expression is an constant array. */
3377 is_constant_array_expr (gfc_expr
*e
)
3384 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
3387 if (e
->value
.constructor
== NULL
)
3390 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
3391 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
3398 /* This one is a bear, but mainly has to do with shuffling elements. */
3401 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
3402 gfc_expr
*pad
, gfc_expr
*order_exp
)
3404 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
3405 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
3406 gfc_constructor
*head
, *tail
;
3412 /* Check that argument expression types are OK. */
3413 if (!is_constant_array_expr (source
))
3416 if (!is_constant_array_expr (shape_exp
))
3419 if (!is_constant_array_expr (pad
))
3422 if (!is_constant_array_expr (order_exp
))
3425 /* Proceed with simplification, unpacking the array. */
3433 e
= gfc_get_array_element (shape_exp
, rank
);
3437 if (gfc_extract_int (e
, &shape
[rank
]) != NULL
)
3439 gfc_error ("Integer too large in shape specification at %L",
3445 if (rank
>= GFC_MAX_DIMENSIONS
)
3447 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3448 "at %L", &e
->where
);
3453 if (shape
[rank
] < 0)
3455 gfc_error ("Shape specification at %L cannot be negative",
3467 gfc_error ("Shape specification at %L cannot be the null array",
3472 /* Now unpack the order array if present. */
3473 if (order_exp
== NULL
)
3475 for (i
= 0; i
< rank
; i
++)
3480 for (i
= 0; i
< rank
; i
++)
3483 for (i
= 0; i
< rank
; i
++)
3485 e
= gfc_get_array_element (order_exp
, i
);
3488 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3489 "size as SHAPE parameter", &order_exp
->where
);
3493 if (gfc_extract_int (e
, &order
[i
]) != NULL
)
3495 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3501 if (order
[i
] < 1 || order
[i
] > rank
)
3503 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3513 gfc_error ("Invalid permutation in ORDER parameter at %L",
3525 /* Count the elements in the source and padding arrays. */
3530 gfc_array_size (pad
, &size
);
3531 npad
= mpz_get_ui (size
);
3535 gfc_array_size (source
, &size
);
3536 nsource
= mpz_get_ui (size
);
3539 /* If it weren't for that pesky permutation we could just loop
3540 through the source and round out any shortage with pad elements.
3541 But no, someone just had to have the compiler do something the
3542 user should be doing. */
3544 for (i
= 0; i
< rank
; i
++)
3549 /* Figure out which element to extract. */
3550 mpz_set_ui (index
, 0);
3552 for (i
= rank
- 1; i
>= 0; i
--)
3554 mpz_add_ui (index
, index
, x
[order
[i
]]);
3556 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
3559 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
3560 gfc_internal_error ("Reshaped array too large at %C");
3562 j
= mpz_get_ui (index
);
3565 e
= gfc_get_array_element (source
, j
);
3572 gfc_error ("PAD parameter required for short SOURCE parameter "
3573 "at %L", &source
->where
);
3578 e
= gfc_get_array_element (pad
, j
);
3582 head
= tail
= gfc_get_constructor ();
3585 tail
->next
= gfc_get_constructor ();
3592 tail
->where
= e
->where
;
3595 /* Calculate the next element. */
3599 if (++x
[i
] < shape
[i
])
3610 e
= gfc_get_expr ();
3611 e
->where
= source
->where
;
3612 e
->expr_type
= EXPR_ARRAY
;
3613 e
->value
.constructor
= head
;
3614 e
->shape
= gfc_get_shape (rank
);
3616 for (i
= 0; i
< rank
; i
++)
3617 mpz_init_set_ui (e
->shape
[i
], shape
[i
]);
3625 gfc_free_constructor (head
);
3627 return &gfc_bad_expr
;
3632 gfc_simplify_rrspacing (gfc_expr
*x
)
3638 if (x
->expr_type
!= EXPR_CONSTANT
)
3641 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3643 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3645 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3647 /* Special case x = -0 and 0. */
3648 if (mpfr_sgn (result
->value
.real
) == 0)
3650 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3654 /* | x * 2**(-e) | * 2**p. */
3655 e
= - (long int) mpfr_get_exp (x
->value
.real
);
3656 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
3658 p
= (long int) gfc_real_kinds
[i
].digits
;
3659 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
3661 return range_check (result
, "RRSPACING");
3666 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
3668 int k
, neg_flag
, power
, exp_range
;
3669 mpfr_t scale
, radix
;
3672 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3675 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3677 if (mpfr_sgn (x
->value
.real
) == 0)
3679 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3683 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3685 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
3687 /* This check filters out values of i that would overflow an int. */
3688 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
3689 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
3691 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
3692 gfc_free_expr (result
);
3693 return &gfc_bad_expr
;
3696 /* Compute scale = radix ** power. */
3697 power
= mpz_get_si (i
->value
.integer
);
3707 gfc_set_model_kind (x
->ts
.kind
);
3710 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
3711 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
3714 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3716 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3721 return range_check (result
, "SCALE");
3725 /* Variants of strspn and strcspn that operate on wide characters. */
3728 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
3731 const gfc_char_t
*c
;
3735 for (c
= s2
; *c
; c
++)
3749 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
3752 const gfc_char_t
*c
;
3756 for (c
= s2
; *c
; c
++)
3771 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
3776 size_t indx
, len
, lenc
;
3777 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
3780 return &gfc_bad_expr
;
3782 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
)
3785 if (b
!= NULL
&& b
->value
.logical
!= 0)
3790 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
3792 len
= e
->value
.character
.length
;
3793 lenc
= c
->value
.character
.length
;
3795 if (len
== 0 || lenc
== 0)
3803 indx
= wide_strcspn (e
->value
.character
.string
,
3804 c
->value
.character
.string
) + 1;
3811 for (indx
= len
; indx
> 0; indx
--)
3813 for (i
= 0; i
< lenc
; i
++)
3815 if (c
->value
.character
.string
[i
]
3816 == e
->value
.character
.string
[indx
- 1])
3824 mpz_set_ui (result
->value
.integer
, indx
);
3825 return range_check (result
, "SCAN");
3830 gfc_simplify_selected_char_kind (gfc_expr
*e
)
3835 if (e
->expr_type
!= EXPR_CONSTANT
)
3838 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
3839 || gfc_compare_with_Cstring (e
, "default", false) == 0)
3844 result
= gfc_int_expr (kind
);
3845 result
->where
= e
->where
;
3852 gfc_simplify_selected_int_kind (gfc_expr
*e
)
3857 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
3862 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
3863 if (gfc_integer_kinds
[i
].range
>= range
3864 && gfc_integer_kinds
[i
].kind
< kind
)
3865 kind
= gfc_integer_kinds
[i
].kind
;
3867 if (kind
== INT_MAX
)
3870 result
= gfc_int_expr (kind
);
3871 result
->where
= e
->where
;
3878 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
)
3880 int range
, precision
, i
, kind
, found_precision
, found_range
;
3887 if (p
->expr_type
!= EXPR_CONSTANT
3888 || gfc_extract_int (p
, &precision
) != NULL
)
3896 if (q
->expr_type
!= EXPR_CONSTANT
3897 || gfc_extract_int (q
, &range
) != NULL
)
3902 found_precision
= 0;
3905 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
3907 if (gfc_real_kinds
[i
].precision
>= precision
)
3908 found_precision
= 1;
3910 if (gfc_real_kinds
[i
].range
>= range
)
3913 if (gfc_real_kinds
[i
].precision
>= precision
3914 && gfc_real_kinds
[i
].range
>= range
&& gfc_real_kinds
[i
].kind
< kind
)
3915 kind
= gfc_real_kinds
[i
].kind
;
3918 if (kind
== INT_MAX
)
3922 if (!found_precision
)
3928 result
= gfc_int_expr (kind
);
3929 result
->where
= (p
!= NULL
) ? p
->where
: q
->where
;
3936 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
3939 mpfr_t exp
, absv
, log2
, pow2
, frac
;
3942 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3945 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3947 gfc_set_model_kind (x
->ts
.kind
);
3949 if (mpfr_sgn (x
->value
.real
) == 0)
3951 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3961 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3962 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3964 mpfr_trunc (log2
, log2
);
3965 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
3967 /* Old exponent value, and fraction. */
3968 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3970 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
3973 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
3974 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
3981 return range_check (result
, "SET_EXPONENT");
3986 gfc_simplify_shape (gfc_expr
*source
)
3988 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3989 gfc_expr
*result
, *e
, *f
;
3994 if (source
->rank
== 0)
3995 return gfc_start_constructor (BT_INTEGER
, gfc_default_integer_kind
,
3998 if (source
->expr_type
!= EXPR_VARIABLE
)
4001 result
= gfc_start_constructor (BT_INTEGER
, gfc_default_integer_kind
,
4004 ar
= gfc_find_array_ref (source
);
4006 t
= gfc_array_ref_shape (ar
, shape
);
4008 for (n
= 0; n
< source
->rank
; n
++)
4010 e
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
4015 mpz_set (e
->value
.integer
, shape
[n
]);
4016 mpz_clear (shape
[n
]);
4020 mpz_set_ui (e
->value
.integer
, n
+ 1);
4022 f
= gfc_simplify_size (source
, e
, NULL
);
4026 gfc_free_expr (result
);
4035 gfc_append_constructor (result
, e
);
4043 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4048 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
4051 return &gfc_bad_expr
;
4055 if (gfc_array_size (array
, &size
) == FAILURE
)
4060 if (dim
->expr_type
!= EXPR_CONSTANT
)
4063 d
= mpz_get_ui (dim
->value
.integer
) - 1;
4064 if (gfc_array_dimen_size (array
, d
, &size
) == FAILURE
)
4068 result
= gfc_constant_result (BT_INTEGER
, k
, &array
->where
);
4069 mpz_set (result
->value
.integer
, size
);
4075 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
4079 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4082 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4087 mpz_abs (result
->value
.integer
, x
->value
.integer
);
4088 if (mpz_sgn (y
->value
.integer
) < 0)
4089 mpz_neg (result
->value
.integer
, result
->value
.integer
);
4094 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
4096 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4097 if (mpfr_sgn (y
->value
.real
) < 0)
4098 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4103 gfc_internal_error ("Bad type in gfc_simplify_sign");
4111 gfc_simplify_sin (gfc_expr
*x
)
4116 if (x
->expr_type
!= EXPR_CONSTANT
)
4119 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4124 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4128 gfc_set_model (x
->value
.real
);
4132 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
4133 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
4134 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
4136 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
4137 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
4138 mpfr_mul (result
->value
.complex.i
, xp
, xq
, GFC_RND_MODE
);
4145 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4148 return range_check (result
, "SIN");
4153 gfc_simplify_sinh (gfc_expr
*x
)
4157 if (x
->expr_type
!= EXPR_CONSTANT
)
4160 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4162 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4164 return range_check (result
, "SINH");
4168 /* The argument is always a double precision real that is converted to
4169 single precision. TODO: Rounding! */
4172 gfc_simplify_sngl (gfc_expr
*a
)
4176 if (a
->expr_type
!= EXPR_CONSTANT
)
4179 result
= gfc_real2real (a
, gfc_default_real_kind
);
4180 return range_check (result
, "SNGL");
4185 gfc_simplify_spacing (gfc_expr
*x
)
4191 if (x
->expr_type
!= EXPR_CONSTANT
)
4194 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
4196 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
4198 /* Special case x = 0 and -0. */
4199 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4200 if (mpfr_sgn (result
->value
.real
) == 0)
4202 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
4206 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4207 are the radix, exponent of x, and precision. This excludes the
4208 possibility of subnormal numbers. Fortran 2003 states the result is
4209 b**max(e - p, emin - 1). */
4211 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
4212 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
4213 en
= en
> ep
? en
: ep
;
4215 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
4216 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
4218 return range_check (result
, "SPACING");
4223 gfc_simplify_sqrt (gfc_expr
*e
)
4226 mpfr_t ac
, ad
, s
, t
, w
;
4228 if (e
->expr_type
!= EXPR_CONSTANT
)
4231 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4236 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
4238 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
4243 /* Formula taken from Numerical Recipes to avoid over- and
4246 gfc_set_model (e
->value
.real
);
4253 if (mpfr_cmp_ui (e
->value
.complex.r
, 0) == 0
4254 && mpfr_cmp_ui (e
->value
.complex.i
, 0) == 0)
4256 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
4257 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
4261 mpfr_abs (ac
, e
->value
.complex.r
, GFC_RND_MODE
);
4262 mpfr_abs (ad
, e
->value
.complex.i
, GFC_RND_MODE
);
4264 if (mpfr_cmp (ac
, ad
) >= 0)
4266 mpfr_div (t
, e
->value
.complex.i
, e
->value
.complex.r
, GFC_RND_MODE
);
4267 mpfr_mul (t
, t
, t
, GFC_RND_MODE
);
4268 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
4269 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
4270 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
4271 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
4272 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
4273 mpfr_sqrt (s
, ac
, GFC_RND_MODE
);
4274 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
4278 mpfr_div (s
, e
->value
.complex.r
, e
->value
.complex.i
, GFC_RND_MODE
);
4279 mpfr_mul (t
, s
, s
, GFC_RND_MODE
);
4280 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
4281 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
4282 mpfr_abs (s
, s
, GFC_RND_MODE
);
4283 mpfr_add (t
, t
, s
, GFC_RND_MODE
);
4284 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
4285 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
4286 mpfr_sqrt (s
, ad
, GFC_RND_MODE
);
4287 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
4290 if (mpfr_cmp_ui (w
, 0) != 0 && mpfr_cmp_ui (e
->value
.complex.r
, 0) >= 0)
4292 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
4293 mpfr_div (result
->value
.complex.i
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
4294 mpfr_set (result
->value
.complex.r
, w
, GFC_RND_MODE
);
4296 else if (mpfr_cmp_ui (w
, 0) != 0
4297 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
4298 && mpfr_cmp_ui (e
->value
.complex.i
, 0) >= 0)
4300 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
4301 mpfr_div (result
->value
.complex.r
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
4302 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
4304 else if (mpfr_cmp_ui (w
, 0) != 0
4305 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
4306 && mpfr_cmp_ui (e
->value
.complex.i
, 0) < 0)
4308 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
4309 mpfr_div (result
->value
.complex.r
, ad
, t
, GFC_RND_MODE
);
4310 mpfr_neg (w
, w
, GFC_RND_MODE
);
4311 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
4314 gfc_internal_error ("invalid complex argument of SQRT at %L",
4326 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
4329 return range_check (result
, "SQRT");
4332 gfc_free_expr (result
);
4333 gfc_error ("Argument of SQRT at %L has a negative value", &e
->where
);
4334 return &gfc_bad_expr
;
4339 gfc_simplify_tan (gfc_expr
*x
)
4344 if (x
->expr_type
!= EXPR_CONSTANT
)
4347 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4349 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4351 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4353 return range_check (result
, "TAN");
4358 gfc_simplify_tanh (gfc_expr
*x
)
4362 if (x
->expr_type
!= EXPR_CONSTANT
)
4365 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4367 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4369 return range_check (result
, "TANH");
4375 gfc_simplify_tiny (gfc_expr
*e
)
4380 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
4382 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
4383 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
4390 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
4393 gfc_expr
*mold_element
;
4396 size_t result_elt_size
;
4399 unsigned char *buffer
;
4401 if (!gfc_is_constant_expr (source
)
4402 || (gfc_init_expr
&& !gfc_is_constant_expr (mold
))
4403 || !gfc_is_constant_expr (size
))
4406 if (source
->expr_type
== EXPR_FUNCTION
)
4409 /* Calculate the size of the source. */
4410 if (source
->expr_type
== EXPR_ARRAY
4411 && gfc_array_size (source
, &tmp
) == FAILURE
)
4412 gfc_internal_error ("Failure getting length of a constant array.");
4414 source_size
= gfc_target_expr_size (source
);
4416 /* Create an empty new expression with the appropriate characteristics. */
4417 result
= gfc_constant_result (mold
->ts
.type
, mold
->ts
.kind
,
4419 result
->ts
= mold
->ts
;
4421 mold_element
= mold
->expr_type
== EXPR_ARRAY
4422 ? mold
->value
.constructor
->expr
4425 /* Set result character length, if needed. Note that this needs to be
4426 set even for array expressions, in order to pass this information into
4427 gfc_target_interpret_expr. */
4428 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
4429 result
->value
.character
.length
= mold_element
->value
.character
.length
;
4431 /* Set the number of elements in the result, and determine its size. */
4432 result_elt_size
= gfc_target_expr_size (mold_element
);
4433 if (result_elt_size
== 0)
4435 gfc_free_expr (result
);
4439 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
4443 result
->expr_type
= EXPR_ARRAY
;
4447 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
4450 result_length
= source_size
/ result_elt_size
;
4451 if (result_length
* result_elt_size
< source_size
)
4455 result
->shape
= gfc_get_shape (1);
4456 mpz_init_set_ui (result
->shape
[0], result_length
);
4458 result_size
= result_length
* result_elt_size
;
4463 result_size
= result_elt_size
;
4466 if (gfc_option
.warn_surprising
&& source_size
< result_size
)
4467 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4468 "source size %ld < result size %ld", &source
->where
,
4469 (long) source_size
, (long) result_size
);
4471 /* Allocate the buffer to store the binary version of the source. */
4472 buffer_size
= MAX (source_size
, result_size
);
4473 buffer
= (unsigned char*)alloca (buffer_size
);
4475 /* Now write source to the buffer. */
4476 gfc_target_encode_expr (source
, buffer
, buffer_size
);
4478 /* And read the buffer back into the new expression. */
4479 gfc_target_interpret_expr (buffer
, buffer_size
, result
);
4486 gfc_simplify_trim (gfc_expr
*e
)
4489 int count
, i
, len
, lentrim
;
4491 if (e
->expr_type
!= EXPR_CONSTANT
)
4494 len
= e
->value
.character
.length
;
4496 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
4498 for (count
= 0, i
= 1; i
<= len
; ++i
)
4500 if (e
->value
.character
.string
[len
- i
] == ' ')
4506 lentrim
= len
- count
;
4508 result
->value
.character
.length
= lentrim
;
4509 result
->value
.character
.string
= gfc_get_wide_string (lentrim
+ 1);
4511 for (i
= 0; i
< lentrim
; i
++)
4512 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
4514 result
->value
.character
.string
[lentrim
] = '\0'; /* For debugger */
4521 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4523 return simplify_bound (array
, dim
, kind
, 1);
4528 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
4532 size_t index
, len
, lenset
;
4534 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
4537 return &gfc_bad_expr
;
4539 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
)
4542 if (b
!= NULL
&& b
->value
.logical
!= 0)
4547 result
= gfc_constant_result (BT_INTEGER
, k
, &s
->where
);
4549 len
= s
->value
.character
.length
;
4550 lenset
= set
->value
.character
.length
;
4554 mpz_set_ui (result
->value
.integer
, 0);
4562 mpz_set_ui (result
->value
.integer
, 1);
4566 index
= wide_strspn (s
->value
.character
.string
,
4567 set
->value
.character
.string
) + 1;
4576 mpz_set_ui (result
->value
.integer
, len
);
4579 for (index
= len
; index
> 0; index
--)
4581 for (i
= 0; i
< lenset
; i
++)
4583 if (s
->value
.character
.string
[index
- 1]
4584 == set
->value
.character
.string
[i
])
4592 mpz_set_ui (result
->value
.integer
, index
);
4598 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
4603 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4606 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4607 if (x
->ts
.type
== BT_INTEGER
)
4609 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
4610 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4611 return range_check (result
, "XOR");
4613 else /* BT_LOGICAL */
4615 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
4616 result
->value
.logical
= (x
->value
.logical
&& !y
->value
.logical
)
4617 || (!x
->value
.logical
&& y
->value
.logical
);
4624 /****************** Constant simplification *****************/
4626 /* Master function to convert one constant to another. While this is
4627 used as a simplification function, it requires the destination type
4628 and kind information which is supplied by a special case in
4632 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
4634 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
4635 gfc_constructor
*head
, *c
, *tail
= NULL
;
4649 f
= gfc_int2complex
;
4669 f
= gfc_real2complex
;
4680 f
= gfc_complex2int
;
4683 f
= gfc_complex2real
;
4686 f
= gfc_complex2complex
;
4712 f
= gfc_hollerith2int
;
4716 f
= gfc_hollerith2real
;
4720 f
= gfc_hollerith2complex
;
4724 f
= gfc_hollerith2character
;
4728 f
= gfc_hollerith2logical
;
4738 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4743 switch (e
->expr_type
)
4746 result
= f (e
, kind
);
4748 return &gfc_bad_expr
;
4752 if (!gfc_is_constant_expr (e
))
4757 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
4760 head
= tail
= gfc_get_constructor ();
4763 tail
->next
= gfc_get_constructor ();
4767 tail
->where
= c
->where
;
4769 if (c
->iterator
== NULL
)
4770 tail
->expr
= f (c
->expr
, kind
);
4773 g
= gfc_convert_constant (c
->expr
, type
, kind
);
4774 if (g
== &gfc_bad_expr
)
4779 if (tail
->expr
== NULL
)
4781 gfc_free_constructor (head
);
4786 result
= gfc_get_expr ();
4787 result
->ts
.type
= type
;
4788 result
->ts
.kind
= kind
;
4789 result
->expr_type
= EXPR_ARRAY
;
4790 result
->value
.constructor
= head
;
4791 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4792 result
->where
= e
->where
;
4793 result
->rank
= e
->rank
;