1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
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_getmem (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_getmem (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_getmem (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
);
509 else /* BT_LOGICAL */
511 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
512 result
->value
.logical
= x
->value
.logical
&& y
->value
.logical
;
515 return range_check (result
, "AND");
520 gfc_simplify_dnint (gfc_expr
*e
)
524 if (e
->expr_type
!= EXPR_CONSTANT
)
527 result
= gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &e
->where
);
529 mpfr_round (result
->value
.real
, e
->value
.real
);
531 return range_check (result
, "DNINT");
536 gfc_simplify_asin (gfc_expr
*x
)
540 if (x
->expr_type
!= EXPR_CONSTANT
)
543 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
544 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
546 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
548 return &gfc_bad_expr
;
551 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
553 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
555 return range_check (result
, "ASIN");
560 gfc_simplify_asinh (gfc_expr
*x
)
564 if (x
->expr_type
!= EXPR_CONSTANT
)
567 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
569 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
571 return range_check (result
, "ASINH");
576 gfc_simplify_atan (gfc_expr
*x
)
580 if (x
->expr_type
!= EXPR_CONSTANT
)
583 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
585 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
587 return range_check (result
, "ATAN");
592 gfc_simplify_atanh (gfc_expr
*x
)
596 if (x
->expr_type
!= EXPR_CONSTANT
)
599 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
600 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
602 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
604 return &gfc_bad_expr
;
607 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
609 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
611 return range_check (result
, "ATANH");
616 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
620 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
623 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
625 if (mpfr_sgn (y
->value
.real
) == 0 && mpfr_sgn (x
->value
.real
) == 0)
627 gfc_error ("If first argument of ATAN2 %L is zero, then the "
628 "second argument must not be zero", &x
->where
);
629 gfc_free_expr (result
);
630 return &gfc_bad_expr
;
633 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
635 return range_check (result
, "ATAN2");
640 gfc_simplify_bit_size (gfc_expr
*e
)
645 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
646 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
647 mpz_set_ui (result
->value
.integer
, gfc_integer_kinds
[i
].bit_size
);
654 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
658 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
661 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
662 return gfc_logical_expr (0, &e
->where
);
664 return gfc_logical_expr (mpz_tstbit (e
->value
.integer
, b
), &e
->where
);
669 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
671 gfc_expr
*ceil
, *result
;
674 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
676 return &gfc_bad_expr
;
678 if (e
->expr_type
!= EXPR_CONSTANT
)
681 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
683 ceil
= gfc_copy_expr (e
);
685 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
686 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
);
688 gfc_free_expr (ceil
);
690 return range_check (result
, "CEILING");
695 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
701 kind
= get_kind (BT_CHARACTER
, k
, "CHAR", gfc_default_character_kind
);
703 return &gfc_bad_expr
;
705 if (e
->expr_type
!= EXPR_CONSTANT
)
708 ch
= gfc_extract_int (e
, &c
);
711 gfc_internal_error ("gfc_simplify_char: %s", ch
);
713 if (c
< 0 || c
> UCHAR_MAX
)
714 gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
717 result
= gfc_constant_result (BT_CHARACTER
, kind
, &e
->where
);
719 result
->value
.character
.length
= 1;
720 result
->value
.character
.string
= gfc_getmem (2);
722 result
->value
.character
.string
[0] = c
;
723 result
->value
.character
.string
[1] = '\0'; /* For debugger */
729 /* Common subroutine for simplifying CMPLX and DCMPLX. */
732 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
736 result
= gfc_constant_result (BT_COMPLEX
, kind
, &x
->where
);
738 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
743 mpfr_set_z (result
->value
.complex.r
, x
->value
.integer
, GFC_RND_MODE
);
747 mpfr_set (result
->value
.complex.r
, x
->value
.real
, GFC_RND_MODE
);
751 mpfr_set (result
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
752 mpfr_set (result
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
756 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
764 mpfr_set_z (result
->value
.complex.i
, y
->value
.integer
, GFC_RND_MODE
);
768 mpfr_set (result
->value
.complex.i
, y
->value
.real
, GFC_RND_MODE
);
772 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
776 return range_check (result
, name
);
781 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
785 if (x
->expr_type
!= EXPR_CONSTANT
786 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
789 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_real_kind
);
791 return &gfc_bad_expr
;
793 return simplify_cmplx ("CMPLX", x
, y
, kind
);
798 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
802 if (x
->expr_type
!= EXPR_CONSTANT
803 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
806 if (x
->ts
.type
== BT_INTEGER
)
808 if (y
->ts
.type
== BT_INTEGER
)
809 kind
= gfc_default_real_kind
;
815 if (y
->ts
.type
== BT_REAL
)
816 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
821 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
826 gfc_simplify_conjg (gfc_expr
*e
)
830 if (e
->expr_type
!= EXPR_CONSTANT
)
833 result
= gfc_copy_expr (e
);
834 mpfr_neg (result
->value
.complex.i
, result
->value
.complex.i
, GFC_RND_MODE
);
836 return range_check (result
, "CONJG");
841 gfc_simplify_cos (gfc_expr
*x
)
846 if (x
->expr_type
!= EXPR_CONSTANT
)
849 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
854 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
857 gfc_set_model_kind (x
->ts
.kind
);
861 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
862 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
863 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
865 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
866 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
867 mpfr_mul (xp
, xp
, xq
, GFC_RND_MODE
);
868 mpfr_neg (result
->value
.complex.i
, xp
, GFC_RND_MODE
);
874 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
877 return range_check (result
, "COS");
883 gfc_simplify_cosh (gfc_expr
*x
)
887 if (x
->expr_type
!= EXPR_CONSTANT
)
890 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
892 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
894 return range_check (result
, "COSH");
899 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
902 if (x
->expr_type
!= EXPR_CONSTANT
903 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
906 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
911 gfc_simplify_dble (gfc_expr
*e
)
915 if (e
->expr_type
!= EXPR_CONSTANT
)
921 result
= gfc_int2real (e
, gfc_default_double_kind
);
925 result
= gfc_real2real (e
, gfc_default_double_kind
);
929 result
= gfc_complex2real (e
, gfc_default_double_kind
);
933 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e
->where
);
936 return range_check (result
, "DBLE");
941 gfc_simplify_digits (gfc_expr
*x
)
945 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
949 digits
= gfc_integer_kinds
[i
].digits
;
954 digits
= gfc_real_kinds
[i
].digits
;
961 return gfc_int_expr (digits
);
966 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
971 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
974 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
975 result
= gfc_constant_result (x
->ts
.type
, kind
, &x
->where
);
980 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
981 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
983 mpz_set_ui (result
->value
.integer
, 0);
988 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
989 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
992 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
997 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1000 return range_check (result
, "DIM");
1005 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
1007 gfc_expr
*a1
, *a2
, *result
;
1009 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1012 result
= gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &x
->where
);
1014 a1
= gfc_real2real (x
, gfc_default_double_kind
);
1015 a2
= gfc_real2real (y
, gfc_default_double_kind
);
1017 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
1022 return range_check (result
, "DPROD");
1027 gfc_simplify_epsilon (gfc_expr
*e
)
1032 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1034 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
1036 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
1038 return range_check (result
, "EPSILON");
1043 gfc_simplify_exp (gfc_expr
*x
)
1048 if (x
->expr_type
!= EXPR_CONSTANT
)
1051 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1056 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1060 gfc_set_model_kind (x
->ts
.kind
);
1063 mpfr_exp (xq
, x
->value
.complex.r
, GFC_RND_MODE
);
1064 mpfr_cos (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
1065 mpfr_mul (result
->value
.complex.r
, xq
, xp
, GFC_RND_MODE
);
1066 mpfr_sin (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
1067 mpfr_mul (result
->value
.complex.i
, xq
, xp
, GFC_RND_MODE
);
1073 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1076 return range_check (result
, "EXP");
1080 gfc_simplify_exponent (gfc_expr
*x
)
1085 if (x
->expr_type
!= EXPR_CONSTANT
)
1088 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1091 gfc_set_model (x
->value
.real
);
1093 if (mpfr_sgn (x
->value
.real
) == 0)
1095 mpz_set_ui (result
->value
.integer
, 0);
1099 i
= (int) mpfr_get_exp (x
->value
.real
);
1100 mpz_set_si (result
->value
.integer
, i
);
1102 return range_check (result
, "EXPONENT");
1107 gfc_simplify_float (gfc_expr
*a
)
1111 if (a
->expr_type
!= EXPR_CONSTANT
)
1114 result
= gfc_int2real (a
, gfc_default_real_kind
);
1115 return range_check (result
, "FLOAT");
1120 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
1126 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
1128 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1130 if (e
->expr_type
!= EXPR_CONSTANT
)
1133 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1135 gfc_set_model_kind (kind
);
1137 mpfr_floor (floor
, e
->value
.real
);
1139 gfc_mpfr_to_mpz (result
->value
.integer
, floor
);
1143 return range_check (result
, "FLOOR");
1148 gfc_simplify_fraction (gfc_expr
*x
)
1151 mpfr_t absv
, exp
, pow2
;
1153 if (x
->expr_type
!= EXPR_CONSTANT
)
1156 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
1158 gfc_set_model_kind (x
->ts
.kind
);
1160 if (mpfr_sgn (x
->value
.real
) == 0)
1162 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1170 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
1171 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
1173 mpfr_trunc (exp
, exp
);
1174 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
1176 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
1178 mpfr_div (result
->value
.real
, absv
, pow2
, GFC_RND_MODE
);
1184 return range_check (result
, "FRACTION");
1189 gfc_simplify_gamma (gfc_expr
*x
)
1193 if (x
->expr_type
!= EXPR_CONSTANT
)
1196 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1198 gfc_set_model_kind (x
->ts
.kind
);
1200 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1202 return range_check (result
, "GAMMA");
1207 gfc_simplify_huge (gfc_expr
*e
)
1212 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1214 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1219 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
1223 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
1233 /* We use the processor's collating sequence, because all
1234 systems that gfortran currently works on are ASCII. */
1237 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
1242 if (e
->expr_type
!= EXPR_CONSTANT
)
1245 if (e
->value
.character
.length
!= 1)
1247 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
1248 return &gfc_bad_expr
;
1251 index
= (unsigned char) e
->value
.character
.string
[0];
1253 if (gfc_option
.warn_surprising
&& index
> 127)
1254 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1257 if ((result
= int_expr_with_kind (index
, kind
, "IACHAR")) == NULL
)
1258 return &gfc_bad_expr
;
1260 result
->where
= e
->where
;
1262 return range_check (result
, "IACHAR");
1267 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
1271 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1274 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1276 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1278 return range_check (result
, "IAND");
1283 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
1288 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1291 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1293 gfc_error ("Invalid second argument of IBCLR at %L", &y
->where
);
1294 return &gfc_bad_expr
;
1297 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1299 if (pos
>= gfc_integer_kinds
[k
].bit_size
)
1301 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1303 return &gfc_bad_expr
;
1306 result
= gfc_copy_expr (x
);
1308 convert_mpz_to_unsigned (result
->value
.integer
,
1309 gfc_integer_kinds
[k
].bit_size
);
1311 mpz_clrbit (result
->value
.integer
, pos
);
1313 convert_mpz_to_signed (result
->value
.integer
,
1314 gfc_integer_kinds
[k
].bit_size
);
1316 return range_check (result
, "IBCLR");
1321 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
1328 if (x
->expr_type
!= EXPR_CONSTANT
1329 || y
->expr_type
!= EXPR_CONSTANT
1330 || z
->expr_type
!= EXPR_CONSTANT
)
1333 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1335 gfc_error ("Invalid second argument of IBITS at %L", &y
->where
);
1336 return &gfc_bad_expr
;
1339 if (gfc_extract_int (z
, &len
) != NULL
|| len
< 0)
1341 gfc_error ("Invalid third argument of IBITS at %L", &z
->where
);
1342 return &gfc_bad_expr
;
1345 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
1347 bitsize
= gfc_integer_kinds
[k
].bit_size
;
1349 if (pos
+ len
> bitsize
)
1351 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1352 "bit size at %L", &y
->where
);
1353 return &gfc_bad_expr
;
1356 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1358 bits
= gfc_getmem (bitsize
* sizeof (int));
1360 for (i
= 0; i
< bitsize
; i
++)
1363 for (i
= 0; i
< len
; i
++)
1364 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
1366 for (i
= 0; i
< bitsize
; i
++)
1369 mpz_clrbit (result
->value
.integer
, i
);
1370 else if (bits
[i
] == 1)
1371 mpz_setbit (result
->value
.integer
, i
);
1373 gfc_internal_error ("IBITS: Bad bit");
1378 return range_check (result
, "IBITS");
1383 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
1388 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1391 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1393 gfc_error ("Invalid second argument of IBSET at %L", &y
->where
);
1394 return &gfc_bad_expr
;
1397 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1399 if (pos
>= gfc_integer_kinds
[k
].bit_size
)
1401 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1403 return &gfc_bad_expr
;
1406 result
= gfc_copy_expr (x
);
1408 convert_mpz_to_unsigned (result
->value
.integer
,
1409 gfc_integer_kinds
[k
].bit_size
);
1411 mpz_setbit (result
->value
.integer
, pos
);
1413 convert_mpz_to_signed (result
->value
.integer
,
1414 gfc_integer_kinds
[k
].bit_size
);
1416 return range_check (result
, "IBSET");
1421 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
1426 if (e
->expr_type
!= EXPR_CONSTANT
)
1429 if (e
->value
.character
.length
!= 1)
1431 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
1432 return &gfc_bad_expr
;
1435 index
= (unsigned char) e
->value
.character
.string
[0];
1437 if (index
< 0 || index
> UCHAR_MAX
)
1438 gfc_internal_error("Argument of ICHAR at %L out of range", &e
->where
);
1440 if ((result
= int_expr_with_kind (index
, kind
, "ICHAR")) == NULL
)
1441 return &gfc_bad_expr
;
1443 result
->where
= e
->where
;
1444 return range_check (result
, "ICHAR");
1449 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
1453 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1456 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1458 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1460 return range_check (result
, "IEOR");
1465 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
1468 int back
, len
, lensub
;
1469 int i
, j
, k
, count
, index
= 0, start
;
1471 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1474 if (b
!= NULL
&& b
->value
.logical
!= 0)
1479 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
1481 return &gfc_bad_expr
;
1483 result
= gfc_constant_result (BT_INTEGER
, k
, &x
->where
);
1485 len
= x
->value
.character
.length
;
1486 lensub
= y
->value
.character
.length
;
1490 mpz_set_si (result
->value
.integer
, 0);
1498 mpz_set_si (result
->value
.integer
, 1);
1501 else if (lensub
== 1)
1503 for (i
= 0; i
< len
; i
++)
1505 for (j
= 0; j
< lensub
; j
++)
1507 if (y
->value
.character
.string
[j
]
1508 == x
->value
.character
.string
[i
])
1518 for (i
= 0; i
< len
; i
++)
1520 for (j
= 0; j
< lensub
; j
++)
1522 if (y
->value
.character
.string
[j
]
1523 == x
->value
.character
.string
[i
])
1528 for (k
= 0; k
< lensub
; k
++)
1530 if (y
->value
.character
.string
[k
]
1531 == x
->value
.character
.string
[k
+ start
])
1535 if (count
== lensub
)
1550 mpz_set_si (result
->value
.integer
, len
+ 1);
1553 else if (lensub
== 1)
1555 for (i
= 0; i
< len
; i
++)
1557 for (j
= 0; j
< lensub
; j
++)
1559 if (y
->value
.character
.string
[j
]
1560 == x
->value
.character
.string
[len
- i
])
1562 index
= len
- i
+ 1;
1570 for (i
= 0; i
< len
; i
++)
1572 for (j
= 0; j
< lensub
; j
++)
1574 if (y
->value
.character
.string
[j
]
1575 == x
->value
.character
.string
[len
- i
])
1578 if (start
<= len
- lensub
)
1581 for (k
= 0; k
< lensub
; k
++)
1582 if (y
->value
.character
.string
[k
]
1583 == x
->value
.character
.string
[k
+ start
])
1586 if (count
== lensub
)
1603 mpz_set_si (result
->value
.integer
, index
);
1604 return range_check (result
, "INDEX");
1609 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
1611 gfc_expr
*rpart
, *rtrunc
, *result
;
1614 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
1616 return &gfc_bad_expr
;
1618 if (e
->expr_type
!= EXPR_CONSTANT
)
1621 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1626 mpz_set (result
->value
.integer
, e
->value
.integer
);
1630 rtrunc
= gfc_copy_expr (e
);
1631 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1632 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1633 gfc_free_expr (rtrunc
);
1637 rpart
= gfc_complex2real (e
, kind
);
1638 rtrunc
= gfc_copy_expr (rpart
);
1639 mpfr_trunc (rtrunc
->value
.real
, rpart
->value
.real
);
1640 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1641 gfc_free_expr (rpart
);
1642 gfc_free_expr (rtrunc
);
1646 gfc_error ("Argument of INT at %L is not a valid type", &e
->where
);
1647 gfc_free_expr (result
);
1648 return &gfc_bad_expr
;
1651 return range_check (result
, "INT");
1656 gfc_simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
1658 gfc_expr
*rpart
, *rtrunc
, *result
;
1660 if (e
->expr_type
!= EXPR_CONSTANT
)
1663 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1668 mpz_set (result
->value
.integer
, e
->value
.integer
);
1672 rtrunc
= gfc_copy_expr (e
);
1673 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1674 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1675 gfc_free_expr (rtrunc
);
1679 rpart
= gfc_complex2real (e
, kind
);
1680 rtrunc
= gfc_copy_expr (rpart
);
1681 mpfr_trunc (rtrunc
->value
.real
, rpart
->value
.real
);
1682 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1683 gfc_free_expr (rpart
);
1684 gfc_free_expr (rtrunc
);
1688 gfc_error ("Argument of %s at %L is not a valid type", name
, &e
->where
);
1689 gfc_free_expr (result
);
1690 return &gfc_bad_expr
;
1693 return range_check (result
, name
);
1698 gfc_simplify_int2 (gfc_expr
*e
)
1700 return gfc_simplify_intconv (e
, 2, "INT2");
1705 gfc_simplify_int8 (gfc_expr
*e
)
1707 return gfc_simplify_intconv (e
, 8, "INT8");
1712 gfc_simplify_long (gfc_expr
*e
)
1714 return gfc_simplify_intconv (e
, 4, "LONG");
1719 gfc_simplify_ifix (gfc_expr
*e
)
1721 gfc_expr
*rtrunc
, *result
;
1723 if (e
->expr_type
!= EXPR_CONSTANT
)
1726 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1729 rtrunc
= gfc_copy_expr (e
);
1731 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1732 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1734 gfc_free_expr (rtrunc
);
1735 return range_check (result
, "IFIX");
1740 gfc_simplify_idint (gfc_expr
*e
)
1742 gfc_expr
*rtrunc
, *result
;
1744 if (e
->expr_type
!= EXPR_CONSTANT
)
1747 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1750 rtrunc
= gfc_copy_expr (e
);
1752 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1753 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1755 gfc_free_expr (rtrunc
);
1756 return range_check (result
, "IDINT");
1761 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
1765 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1768 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1770 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1771 return range_check (result
, "IOR");
1776 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
1779 int shift
, ashift
, isize
, k
, *bits
, i
;
1781 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1784 if (gfc_extract_int (s
, &shift
) != NULL
)
1786 gfc_error ("Invalid second argument of ISHFT at %L", &s
->where
);
1787 return &gfc_bad_expr
;
1790 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
1792 isize
= gfc_integer_kinds
[k
].bit_size
;
1801 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
1802 "at %L", &s
->where
);
1803 return &gfc_bad_expr
;
1806 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1810 mpz_set (result
->value
.integer
, e
->value
.integer
);
1811 return range_check (result
, "ISHFT");
1814 bits
= gfc_getmem (isize
* sizeof (int));
1816 for (i
= 0; i
< isize
; i
++)
1817 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1821 for (i
= 0; i
< shift
; i
++)
1822 mpz_clrbit (result
->value
.integer
, i
);
1824 for (i
= 0; i
< isize
- shift
; i
++)
1827 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1829 mpz_setbit (result
->value
.integer
, i
+ shift
);
1834 for (i
= isize
- 1; i
>= isize
- ashift
; i
--)
1835 mpz_clrbit (result
->value
.integer
, i
);
1837 for (i
= isize
- 1; i
>= ashift
; i
--)
1840 mpz_clrbit (result
->value
.integer
, i
- ashift
);
1842 mpz_setbit (result
->value
.integer
, i
- ashift
);
1846 convert_mpz_to_signed (result
->value
.integer
, isize
);
1854 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
1857 int shift
, ashift
, isize
, ssize
, delta
, k
;
1860 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1863 if (gfc_extract_int (s
, &shift
) != NULL
)
1865 gfc_error ("Invalid second argument of ISHFTC at %L", &s
->where
);
1866 return &gfc_bad_expr
;
1869 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1870 isize
= gfc_integer_kinds
[k
].bit_size
;
1874 if (sz
->expr_type
!= EXPR_CONSTANT
)
1877 if (gfc_extract_int (sz
, &ssize
) != NULL
|| ssize
<= 0)
1879 gfc_error ("Invalid third argument of ISHFTC at %L", &sz
->where
);
1880 return &gfc_bad_expr
;
1885 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
1886 "BIT_SIZE of first argument at %L", &s
->where
);
1887 return &gfc_bad_expr
;
1901 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1902 "third argument at %L", &s
->where
);
1904 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1905 "BIT_SIZE of first argument at %L", &s
->where
);
1906 return &gfc_bad_expr
;
1909 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1911 mpz_set (result
->value
.integer
, e
->value
.integer
);
1916 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
1918 bits
= gfc_getmem (ssize
* sizeof (int));
1920 for (i
= 0; i
< ssize
; i
++)
1921 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1923 delta
= ssize
- ashift
;
1927 for (i
= 0; i
< delta
; i
++)
1930 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1932 mpz_setbit (result
->value
.integer
, i
+ shift
);
1935 for (i
= delta
; i
< ssize
; i
++)
1938 mpz_clrbit (result
->value
.integer
, i
- delta
);
1940 mpz_setbit (result
->value
.integer
, i
- delta
);
1945 for (i
= 0; i
< ashift
; i
++)
1948 mpz_clrbit (result
->value
.integer
, i
+ delta
);
1950 mpz_setbit (result
->value
.integer
, i
+ delta
);
1953 for (i
= ashift
; i
< ssize
; i
++)
1956 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1958 mpz_setbit (result
->value
.integer
, i
+ shift
);
1962 convert_mpz_to_signed (result
->value
.integer
, isize
);
1970 gfc_simplify_kind (gfc_expr
*e
)
1973 if (e
->ts
.type
== BT_DERIVED
)
1975 gfc_error ("Argument of KIND at %L is a DERIVED type", &e
->where
);
1976 return &gfc_bad_expr
;
1979 return gfc_int_expr (e
->ts
.kind
);
1984 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
1987 gfc_expr
*l
, *u
, *result
;
1990 /* The last dimension of an assumed-size array is special. */
1991 if (d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
1993 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
1994 return gfc_copy_expr (as
->lower
[d
-1]);
1999 /* Then, we need to know the extent of the given dimension. */
2003 if (l
->expr_type
!= EXPR_CONSTANT
|| u
->expr_type
!= EXPR_CONSTANT
)
2006 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
2007 gfc_default_integer_kind
);
2009 return &gfc_bad_expr
;
2011 result
= gfc_constant_result (BT_INTEGER
, k
, &array
->where
);
2013 if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
2017 mpz_set_si (result
->value
.integer
, 0);
2019 mpz_set_si (result
->value
.integer
, 1);
2023 /* Nonzero extent. */
2025 mpz_set (result
->value
.integer
, u
->value
.integer
);
2027 mpz_set (result
->value
.integer
, l
->value
.integer
);
2030 return range_check (result
, upper
? "UBOUND" : "LBOUND");
2035 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
2041 if (array
->expr_type
!= EXPR_VARIABLE
)
2044 /* Follow any component references. */
2045 as
= array
->symtree
->n
.sym
->as
;
2046 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2051 switch (ref
->u
.ar
.type
)
2058 /* We're done because 'as' has already been set in the
2059 previous iteration. */
2070 as
= ref
->u
.c
.component
->as
;
2082 if (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
)
2087 /* Multi-dimensional bounds. */
2088 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
2090 gfc_constructor
*head
, *tail
;
2093 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2094 if (upper
&& as
->type
== AS_ASSUMED_SIZE
)
2096 /* An error message will be emitted in
2097 check_assumed_size_reference (resolve.c). */
2098 return &gfc_bad_expr
;
2101 /* Simplify the bounds for each dimension. */
2102 for (d
= 0; d
< array
->rank
; d
++)
2104 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
);
2105 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
2109 for (j
= 0; j
< d
; j
++)
2110 gfc_free_expr (bounds
[j
]);
2115 /* Allocate the result expression. */
2116 e
= gfc_get_expr ();
2117 e
->where
= array
->where
;
2118 e
->expr_type
= EXPR_ARRAY
;
2119 e
->ts
.type
= BT_INTEGER
;
2120 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
2121 gfc_default_integer_kind
);
2123 return &gfc_bad_expr
;
2126 /* The result is a rank 1 array; its size is the rank of the first
2127 argument to {L,U}BOUND. */
2129 e
->shape
= gfc_get_shape (1);
2130 mpz_init_set_ui (e
->shape
[0], array
->rank
);
2132 /* Create the constructor for this array. */
2134 for (d
= 0; d
< array
->rank
; d
++)
2136 /* Get a new constructor element. */
2138 head
= tail
= gfc_get_constructor ();
2141 tail
->next
= gfc_get_constructor ();
2145 tail
->where
= e
->where
;
2146 tail
->expr
= bounds
[d
];
2148 e
->value
.constructor
= head
;
2154 /* A DIM argument is specified. */
2155 if (dim
->expr_type
!= EXPR_CONSTANT
)
2158 d
= mpz_get_si (dim
->value
.integer
);
2160 if (d
< 1 || d
> as
->rank
2161 || (d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
2163 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
2164 return &gfc_bad_expr
;
2167 return simplify_bound_dim (array
, kind
, d
, upper
, as
);
2173 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2175 return simplify_bound (array
, dim
, kind
, 0);
2180 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
2183 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
2186 return &gfc_bad_expr
;
2188 if (e
->expr_type
== EXPR_CONSTANT
)
2190 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
2191 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
2192 return range_check (result
, "LEN");
2195 if (e
->ts
.cl
!= NULL
&& e
->ts
.cl
->length
!= NULL
2196 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
2197 && e
->ts
.cl
->length
->ts
.type
== BT_INTEGER
)
2199 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
2200 mpz_set (result
->value
.integer
, e
->ts
.cl
->length
->value
.integer
);
2201 return range_check (result
, "LEN");
2209 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
2212 int count
, len
, lentrim
, i
;
2213 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
2216 return &gfc_bad_expr
;
2218 if (e
->expr_type
!= EXPR_CONSTANT
)
2221 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
2222 len
= e
->value
.character
.length
;
2224 for (count
= 0, i
= 1; i
<= len
; i
++)
2225 if (e
->value
.character
.string
[len
- i
] == ' ')
2230 lentrim
= len
- count
;
2232 mpz_set_si (result
->value
.integer
, lentrim
);
2233 return range_check (result
, "LEN_TRIM");
2237 gfc_simplify_lgamma (gfc_expr
*x
__attribute__((unused
)))
2239 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
2243 if (x
->expr_type
!= EXPR_CONSTANT
)
2246 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2248 gfc_set_model_kind (x
->ts
.kind
);
2250 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
2252 return range_check (result
, "LGAMMA");
2260 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
2262 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2265 return gfc_logical_expr (gfc_compare_string (a
, b
) >= 0, &a
->where
);
2270 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
2272 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2275 return gfc_logical_expr (gfc_compare_string (a
, b
) > 0,
2281 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
2283 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2286 return gfc_logical_expr (gfc_compare_string (a
, b
) <= 0, &a
->where
);
2291 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
2293 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2296 return gfc_logical_expr (gfc_compare_string (a
, b
) < 0, &a
->where
);
2301 gfc_simplify_log (gfc_expr
*x
)
2306 if (x
->expr_type
!= EXPR_CONSTANT
)
2309 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2311 gfc_set_model_kind (x
->ts
.kind
);
2316 if (mpfr_sgn (x
->value
.real
) <= 0)
2318 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2319 "to zero", &x
->where
);
2320 gfc_free_expr (result
);
2321 return &gfc_bad_expr
;
2324 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2328 if ((mpfr_sgn (x
->value
.complex.r
) == 0)
2329 && (mpfr_sgn (x
->value
.complex.i
) == 0))
2331 gfc_error ("Complex argument of LOG at %L cannot be zero",
2333 gfc_free_expr (result
);
2334 return &gfc_bad_expr
;
2340 mpfr_atan2 (result
->value
.complex.i
, x
->value
.complex.i
,
2341 x
->value
.complex.r
, GFC_RND_MODE
);
2343 mpfr_mul (xr
, x
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
2344 mpfr_mul (xi
, x
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
2345 mpfr_add (xr
, xr
, xi
, GFC_RND_MODE
);
2346 mpfr_sqrt (xr
, xr
, GFC_RND_MODE
);
2347 mpfr_log (result
->value
.complex.r
, xr
, GFC_RND_MODE
);
2355 gfc_internal_error ("gfc_simplify_log: bad type");
2358 return range_check (result
, "LOG");
2363 gfc_simplify_log10 (gfc_expr
*x
)
2367 if (x
->expr_type
!= EXPR_CONSTANT
)
2370 gfc_set_model_kind (x
->ts
.kind
);
2372 if (mpfr_sgn (x
->value
.real
) <= 0)
2374 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2375 "to zero", &x
->where
);
2376 return &gfc_bad_expr
;
2379 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2381 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2383 return range_check (result
, "LOG10");
2388 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
2393 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
2395 return &gfc_bad_expr
;
2397 if (e
->expr_type
!= EXPR_CONSTANT
)
2400 result
= gfc_constant_result (BT_LOGICAL
, kind
, &e
->where
);
2402 result
->value
.logical
= e
->value
.logical
;
2408 /* This function is special since MAX() can take any number of
2409 arguments. The simplified expression is a rewritten version of the
2410 argument list containing at most one constant element. Other
2411 constant elements are deleted. Because the argument list has
2412 already been checked, this function always succeeds. sign is 1 for
2413 MAX(), -1 for MIN(). */
2416 simplify_min_max (gfc_expr
*expr
, int sign
)
2418 gfc_actual_arglist
*arg
, *last
, *extremum
;
2419 gfc_intrinsic_sym
* specific
;
2423 specific
= expr
->value
.function
.isym
;
2425 arg
= expr
->value
.function
.actual
;
2427 for (; arg
; last
= arg
, arg
= arg
->next
)
2429 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
2432 if (extremum
== NULL
)
2438 switch (arg
->expr
->ts
.type
)
2441 if (mpz_cmp (arg
->expr
->value
.integer
,
2442 extremum
->expr
->value
.integer
) * sign
> 0)
2443 mpz_set (extremum
->expr
->value
.integer
, arg
->expr
->value
.integer
);
2447 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
2449 mpfr_max (extremum
->expr
->value
.real
, extremum
->expr
->value
.real
,
2450 arg
->expr
->value
.real
, GFC_RND_MODE
);
2452 mpfr_min (extremum
->expr
->value
.real
, extremum
->expr
->value
.real
,
2453 arg
->expr
->value
.real
, GFC_RND_MODE
);
2457 #define LENGTH(x) ((x)->expr->value.character.length)
2458 #define STRING(x) ((x)->expr->value.character.string)
2459 if (LENGTH(extremum
) < LENGTH(arg
))
2461 char * tmp
= STRING(extremum
);
2463 STRING(extremum
) = gfc_getmem (LENGTH(arg
) + 1);
2464 memcpy (STRING(extremum
), tmp
, LENGTH(extremum
));
2465 memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
2466 LENGTH(arg
) - LENGTH(extremum
));
2467 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
2468 LENGTH(extremum
) = LENGTH(arg
);
2472 if (gfc_compare_string (arg
->expr
, extremum
->expr
) * sign
> 0)
2474 gfc_free (STRING(extremum
));
2475 STRING(extremum
) = gfc_getmem (LENGTH(extremum
) + 1);
2476 memcpy (STRING(extremum
), STRING(arg
), LENGTH(arg
));
2477 memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
2478 LENGTH(extremum
) - LENGTH(arg
));
2479 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
2487 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2490 /* Delete the extra constant argument. */
2492 expr
->value
.function
.actual
= arg
->next
;
2494 last
->next
= arg
->next
;
2497 gfc_free_actual_arglist (arg
);
2501 /* If there is one value left, replace the function call with the
2503 if (expr
->value
.function
.actual
->next
!= NULL
)
2506 /* Convert to the correct type and kind. */
2507 if (expr
->ts
.type
!= BT_UNKNOWN
)
2508 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2509 expr
->ts
.type
, expr
->ts
.kind
);
2511 if (specific
->ts
.type
!= BT_UNKNOWN
)
2512 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2513 specific
->ts
.type
, specific
->ts
.kind
);
2515 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
2520 gfc_simplify_min (gfc_expr
*e
)
2522 return simplify_min_max (e
, -1);
2527 gfc_simplify_max (gfc_expr
*e
)
2529 return simplify_min_max (e
, 1);
2534 gfc_simplify_maxexponent (gfc_expr
*x
)
2539 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2541 result
= gfc_int_expr (gfc_real_kinds
[i
].max_exponent
);
2542 result
->where
= x
->where
;
2549 gfc_simplify_minexponent (gfc_expr
*x
)
2554 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2556 result
= gfc_int_expr (gfc_real_kinds
[i
].min_exponent
);
2557 result
->where
= x
->where
;
2564 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
2567 mpfr_t quot
, iquot
, term
;
2570 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2573 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2574 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2579 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2581 /* Result is processor-dependent. */
2582 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
2583 gfc_free_expr (result
);
2584 return &gfc_bad_expr
;
2586 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2590 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2592 /* Result is processor-dependent. */
2593 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
2594 gfc_free_expr (result
);
2595 return &gfc_bad_expr
;
2598 gfc_set_model_kind (kind
);
2603 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2604 mpfr_trunc (iquot
, quot
);
2605 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2606 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2614 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2617 return range_check (result
, "MOD");
2622 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
2625 mpfr_t quot
, iquot
, term
;
2628 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2631 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2632 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2637 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2639 /* Result is processor-dependent. This processor just opts
2640 to not handle it at all. */
2641 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
2642 gfc_free_expr (result
);
2643 return &gfc_bad_expr
;
2645 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2650 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2652 /* Result is processor-dependent. */
2653 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
2654 gfc_free_expr (result
);
2655 return &gfc_bad_expr
;
2658 gfc_set_model_kind (kind
);
2663 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2664 mpfr_floor (iquot
, quot
);
2665 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2666 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2674 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2677 return range_check (result
, "MODULO");
2681 /* Exists for the sole purpose of consistency with other intrinsics. */
2683 gfc_simplify_mvbits (gfc_expr
*f ATTRIBUTE_UNUSED
,
2684 gfc_expr
*fp ATTRIBUTE_UNUSED
,
2685 gfc_expr
*l ATTRIBUTE_UNUSED
,
2686 gfc_expr
*to ATTRIBUTE_UNUSED
,
2687 gfc_expr
*tp ATTRIBUTE_UNUSED
)
2694 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
2697 mp_exp_t emin
, emax
;
2700 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
2703 if (mpfr_sgn (s
->value
.real
) == 0)
2705 gfc_error ("Second argument of NEAREST at %L shall not be zero",
2707 return &gfc_bad_expr
;
2710 gfc_set_model_kind (x
->ts
.kind
);
2711 result
= gfc_copy_expr (x
);
2713 /* Save current values of emin and emax. */
2714 emin
= mpfr_get_emin ();
2715 emax
= mpfr_get_emax ();
2717 /* Set emin and emax for the current model number. */
2718 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
2719 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
2720 mpfr_get_prec(result
->value
.real
) + 1);
2721 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
2723 if (mpfr_sgn (s
->value
.real
) > 0)
2725 mpfr_nextabove (result
->value
.real
);
2726 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
2730 mpfr_nextbelow (result
->value
.real
);
2731 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
2734 mpfr_set_emin (emin
);
2735 mpfr_set_emax (emax
);
2737 /* Only NaN can occur. Do not use range check as it gives an
2738 error for denormal numbers. */
2739 if (mpfr_nan_p (result
->value
.real
) && gfc_option
.flag_range_check
)
2741 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
2742 return &gfc_bad_expr
;
2750 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
2752 gfc_expr
*itrunc
, *result
;
2755 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
2757 return &gfc_bad_expr
;
2759 if (e
->expr_type
!= EXPR_CONSTANT
)
2762 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
2764 itrunc
= gfc_copy_expr (e
);
2766 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
2768 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
);
2770 gfc_free_expr (itrunc
);
2772 return range_check (result
, name
);
2777 gfc_simplify_new_line (gfc_expr
*e
)
2781 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
2782 result
->value
.character
.string
= gfc_getmem (2);
2783 result
->value
.character
.length
= 1;
2784 result
->value
.character
.string
[0] = '\n';
2785 result
->value
.character
.string
[1] = '\0'; /* For debugger */
2791 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
2793 return simplify_nint ("NINT", e
, k
);
2798 gfc_simplify_idnint (gfc_expr
*e
)
2800 return simplify_nint ("IDNINT", e
, NULL
);
2805 gfc_simplify_not (gfc_expr
*e
)
2809 if (e
->expr_type
!= EXPR_CONSTANT
)
2812 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2814 mpz_com (result
->value
.integer
, e
->value
.integer
);
2816 return range_check (result
, "NOT");
2821 gfc_simplify_null (gfc_expr
*mold
)
2827 result
= gfc_get_expr ();
2828 result
->ts
.type
= BT_UNKNOWN
;
2831 result
= gfc_copy_expr (mold
);
2832 result
->expr_type
= EXPR_NULL
;
2839 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
2844 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2847 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2848 if (x
->ts
.type
== BT_INTEGER
)
2850 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
2851 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2853 else /* BT_LOGICAL */
2855 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
2856 result
->value
.logical
= x
->value
.logical
|| y
->value
.logical
;
2859 return range_check (result
, "OR");
2864 gfc_simplify_precision (gfc_expr
*e
)
2869 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2871 result
= gfc_int_expr (gfc_real_kinds
[i
].precision
);
2872 result
->where
= e
->where
;
2879 gfc_simplify_radix (gfc_expr
*e
)
2884 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2888 i
= gfc_integer_kinds
[i
].radix
;
2892 i
= gfc_real_kinds
[i
].radix
;
2899 result
= gfc_int_expr (i
);
2900 result
->where
= e
->where
;
2907 gfc_simplify_range (gfc_expr
*e
)
2913 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2918 j
= gfc_integer_kinds
[i
].range
;
2923 j
= gfc_real_kinds
[i
].range
;
2930 result
= gfc_int_expr (j
);
2931 result
->where
= e
->where
;
2938 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
2943 if (e
->ts
.type
== BT_COMPLEX
)
2944 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
2946 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
2949 return &gfc_bad_expr
;
2951 if (e
->expr_type
!= EXPR_CONSTANT
)
2957 result
= gfc_int2real (e
, kind
);
2961 result
= gfc_real2real (e
, kind
);
2965 result
= gfc_complex2real (e
, kind
);
2969 gfc_internal_error ("bad type in REAL");
2973 return range_check (result
, "REAL");
2978 gfc_simplify_realpart (gfc_expr
*e
)
2982 if (e
->expr_type
!= EXPR_CONSTANT
)
2985 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
2986 mpfr_set (result
->value
.real
, e
->value
.complex.r
, GFC_RND_MODE
);
2988 return range_check (result
, "REALPART");
2992 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
2995 int i
, j
, len
, ncop
, nlen
;
2997 bool have_length
= false;
2999 /* If NCOPIES isn't a constant, there's nothing we can do. */
3000 if (n
->expr_type
!= EXPR_CONSTANT
)
3003 /* If NCOPIES is negative, it's an error. */
3004 if (mpz_sgn (n
->value
.integer
) < 0)
3006 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3008 return &gfc_bad_expr
;
3011 /* If we don't know the character length, we can do no more. */
3012 if (e
->ts
.cl
&& e
->ts
.cl
->length
3013 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
3015 len
= mpz_get_si (e
->ts
.cl
->length
->value
.integer
);
3018 else if (e
->expr_type
== EXPR_CONSTANT
3019 && (e
->ts
.cl
== NULL
|| e
->ts
.cl
->length
== NULL
))
3021 len
= e
->value
.character
.length
;
3026 /* If the source length is 0, any value of NCOPIES is valid
3027 and everything behaves as if NCOPIES == 0. */
3030 mpz_set_ui (ncopies
, 0);
3032 mpz_set (ncopies
, n
->value
.integer
);
3034 /* Check that NCOPIES isn't too large. */
3040 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
3042 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
3046 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
3047 e
->ts
.cl
->length
->value
.integer
);
3051 mpz_init_set_si (mlen
, len
);
3052 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
3056 /* The check itself. */
3057 if (mpz_cmp (ncopies
, max
) > 0)
3060 mpz_clear (ncopies
);
3061 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3063 return &gfc_bad_expr
;
3068 mpz_clear (ncopies
);
3070 /* For further simplification, we need the character string to be
3072 if (e
->expr_type
!= EXPR_CONSTANT
)
3075 if (len
|| mpz_sgn (e
->ts
.cl
->length
->value
.integer
) != 0)
3077 const char *res
= gfc_extract_int (n
, &ncop
);
3078 gcc_assert (res
== NULL
);
3083 len
= e
->value
.character
.length
;
3086 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
3090 result
->value
.character
.string
= gfc_getmem (1);
3091 result
->value
.character
.length
= 0;
3092 result
->value
.character
.string
[0] = '\0';
3096 result
->value
.character
.length
= nlen
;
3097 result
->value
.character
.string
= gfc_getmem (nlen
+ 1);
3099 for (i
= 0; i
< ncop
; i
++)
3100 for (j
= 0; j
< len
; j
++)
3101 result
->value
.character
.string
[j
+ i
* len
]
3102 = e
->value
.character
.string
[j
];
3104 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
3109 /* This one is a bear, but mainly has to do with shuffling elements. */
3112 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
3113 gfc_expr
*pad
, gfc_expr
*order_exp
)
3115 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
3116 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
3117 gfc_constructor
*head
, *tail
;
3123 /* Unpack the shape array. */
3124 if (source
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (source
))
3127 if (shape_exp
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (shape_exp
))
3131 && (pad
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (pad
)))
3134 if (order_exp
!= NULL
3135 && (order_exp
->expr_type
!= EXPR_ARRAY
3136 || !gfc_is_constant_expr (order_exp
)))
3145 e
= gfc_get_array_element (shape_exp
, rank
);
3149 if (gfc_extract_int (e
, &shape
[rank
]) != NULL
)
3151 gfc_error ("Integer too large in shape specification at %L",
3159 if (rank
>= GFC_MAX_DIMENSIONS
)
3161 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3162 "at %L", &e
->where
);
3167 if (shape
[rank
] < 0)
3169 gfc_error ("Shape specification at %L cannot be negative",
3179 gfc_error ("Shape specification at %L cannot be the null array",
3184 /* Now unpack the order array if present. */
3185 if (order_exp
== NULL
)
3187 for (i
= 0; i
< rank
; i
++)
3192 for (i
= 0; i
< rank
; i
++)
3195 for (i
= 0; i
< rank
; i
++)
3197 e
= gfc_get_array_element (order_exp
, i
);
3200 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3201 "size as SHAPE parameter", &order_exp
->where
);
3205 if (gfc_extract_int (e
, &order
[i
]) != NULL
)
3207 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3215 if (order
[i
] < 1 || order
[i
] > rank
)
3217 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3226 gfc_error ("Invalid permutation in ORDER parameter at %L",
3235 /* Count the elements in the source and padding arrays. */
3240 gfc_array_size (pad
, &size
);
3241 npad
= mpz_get_ui (size
);
3245 gfc_array_size (source
, &size
);
3246 nsource
= mpz_get_ui (size
);
3249 /* If it weren't for that pesky permutation we could just loop
3250 through the source and round out any shortage with pad elements.
3251 But no, someone just had to have the compiler do something the
3252 user should be doing. */
3254 for (i
= 0; i
< rank
; i
++)
3259 /* Figure out which element to extract. */
3260 mpz_set_ui (index
, 0);
3262 for (i
= rank
- 1; i
>= 0; i
--)
3264 mpz_add_ui (index
, index
, x
[order
[i
]]);
3266 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
3269 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
3270 gfc_internal_error ("Reshaped array too large at %L", &e
->where
);
3272 j
= mpz_get_ui (index
);
3275 e
= gfc_get_array_element (source
, j
);
3282 gfc_error ("PAD parameter required for short SOURCE parameter "
3283 "at %L", &source
->where
);
3288 e
= gfc_get_array_element (pad
, j
);
3292 head
= tail
= gfc_get_constructor ();
3295 tail
->next
= gfc_get_constructor ();
3302 tail
->where
= e
->where
;
3305 /* Calculate the next element. */
3309 if (++x
[i
] < shape
[i
])
3320 e
= gfc_get_expr ();
3321 e
->where
= source
->where
;
3322 e
->expr_type
= EXPR_ARRAY
;
3323 e
->value
.constructor
= head
;
3324 e
->shape
= gfc_get_shape (rank
);
3326 for (i
= 0; i
< rank
; i
++)
3327 mpz_init_set_ui (e
->shape
[i
], shape
[i
]);
3335 gfc_free_constructor (head
);
3337 return &gfc_bad_expr
;
3342 gfc_simplify_rrspacing (gfc_expr
*x
)
3348 if (x
->expr_type
!= EXPR_CONSTANT
)
3351 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3353 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3355 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3357 /* Special case x = -0 and 0. */
3358 if (mpfr_sgn (result
->value
.real
) == 0)
3360 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3364 /* | x * 2**(-e) | * 2**p. */
3365 e
= - (long int) mpfr_get_exp (x
->value
.real
);
3366 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
3368 p
= (long int) gfc_real_kinds
[i
].digits
;
3369 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
3371 return range_check (result
, "RRSPACING");
3376 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
3378 int k
, neg_flag
, power
, exp_range
;
3379 mpfr_t scale
, radix
;
3382 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3385 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3387 if (mpfr_sgn (x
->value
.real
) == 0)
3389 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3393 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3395 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
3397 /* This check filters out values of i that would overflow an int. */
3398 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
3399 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
3401 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
3402 return &gfc_bad_expr
;
3405 /* Compute scale = radix ** power. */
3406 power
= mpz_get_si (i
->value
.integer
);
3416 gfc_set_model_kind (x
->ts
.kind
);
3419 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
3420 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
3423 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3425 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3430 return range_check (result
, "SCALE");
3435 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
3440 size_t indx
, len
, lenc
;
3441 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
3444 return &gfc_bad_expr
;
3446 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
)
3449 if (b
!= NULL
&& b
->value
.logical
!= 0)
3454 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
3456 len
= e
->value
.character
.length
;
3457 lenc
= c
->value
.character
.length
;
3459 if (len
== 0 || lenc
== 0)
3467 indx
= strcspn (e
->value
.character
.string
, c
->value
.character
.string
)
3475 for (indx
= len
; indx
> 0; indx
--)
3477 for (i
= 0; i
< lenc
; i
++)
3479 if (c
->value
.character
.string
[i
]
3480 == e
->value
.character
.string
[indx
- 1])
3488 mpz_set_ui (result
->value
.integer
, indx
);
3489 return range_check (result
, "SCAN");
3494 gfc_simplify_selected_int_kind (gfc_expr
*e
)
3499 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
3504 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
3505 if (gfc_integer_kinds
[i
].range
>= range
3506 && gfc_integer_kinds
[i
].kind
< kind
)
3507 kind
= gfc_integer_kinds
[i
].kind
;
3509 if (kind
== INT_MAX
)
3512 result
= gfc_int_expr (kind
);
3513 result
->where
= e
->where
;
3520 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
)
3522 int range
, precision
, i
, kind
, found_precision
, found_range
;
3529 if (p
->expr_type
!= EXPR_CONSTANT
3530 || gfc_extract_int (p
, &precision
) != NULL
)
3538 if (q
->expr_type
!= EXPR_CONSTANT
3539 || gfc_extract_int (q
, &range
) != NULL
)
3544 found_precision
= 0;
3547 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
3549 if (gfc_real_kinds
[i
].precision
>= precision
)
3550 found_precision
= 1;
3552 if (gfc_real_kinds
[i
].range
>= range
)
3555 if (gfc_real_kinds
[i
].precision
>= precision
3556 && gfc_real_kinds
[i
].range
>= range
&& gfc_real_kinds
[i
].kind
< kind
)
3557 kind
= gfc_real_kinds
[i
].kind
;
3560 if (kind
== INT_MAX
)
3564 if (!found_precision
)
3570 result
= gfc_int_expr (kind
);
3571 result
->where
= (p
!= NULL
) ? p
->where
: q
->where
;
3578 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
3581 mpfr_t exp
, absv
, log2
, pow2
, frac
;
3584 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3587 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3589 gfc_set_model_kind (x
->ts
.kind
);
3591 if (mpfr_sgn (x
->value
.real
) == 0)
3593 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3603 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3604 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3606 mpfr_trunc (log2
, log2
);
3607 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
3609 /* Old exponent value, and fraction. */
3610 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3612 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
3615 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
3616 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
3623 return range_check (result
, "SET_EXPONENT");
3628 gfc_simplify_shape (gfc_expr
*source
)
3630 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3631 gfc_expr
*result
, *e
, *f
;
3636 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3639 result
= gfc_start_constructor (BT_INTEGER
, gfc_default_integer_kind
,
3642 ar
= gfc_find_array_ref (source
);
3644 t
= gfc_array_ref_shape (ar
, shape
);
3646 for (n
= 0; n
< source
->rank
; n
++)
3648 e
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3653 mpz_set (e
->value
.integer
, shape
[n
]);
3654 mpz_clear (shape
[n
]);
3658 mpz_set_ui (e
->value
.integer
, n
+ 1);
3660 f
= gfc_simplify_size (source
, e
, NULL
);
3664 gfc_free_expr (result
);
3673 gfc_append_constructor (result
, e
);
3681 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3686 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
3689 return &gfc_bad_expr
;
3693 if (gfc_array_size (array
, &size
) == FAILURE
)
3698 if (dim
->expr_type
!= EXPR_CONSTANT
)
3701 d
= mpz_get_ui (dim
->value
.integer
) - 1;
3702 if (gfc_array_dimen_size (array
, d
, &size
) == FAILURE
)
3706 result
= gfc_constant_result (BT_INTEGER
, k
, &array
->where
);
3707 mpz_set (result
->value
.integer
, size
);
3713 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
3717 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3720 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3725 mpz_abs (result
->value
.integer
, x
->value
.integer
);
3726 if (mpz_sgn (y
->value
.integer
) < 0)
3727 mpz_neg (result
->value
.integer
, result
->value
.integer
);
3732 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3734 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3735 if (mpfr_sgn (y
->value
.real
) < 0)
3736 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
3741 gfc_internal_error ("Bad type in gfc_simplify_sign");
3749 gfc_simplify_sin (gfc_expr
*x
)
3754 if (x
->expr_type
!= EXPR_CONSTANT
)
3757 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3762 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3766 gfc_set_model (x
->value
.real
);
3770 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3771 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3772 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
3774 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3775 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3776 mpfr_mul (result
->value
.complex.i
, xp
, xq
, GFC_RND_MODE
);
3783 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3786 return range_check (result
, "SIN");
3791 gfc_simplify_sinh (gfc_expr
*x
)
3795 if (x
->expr_type
!= EXPR_CONSTANT
)
3798 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3800 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3802 return range_check (result
, "SINH");
3806 /* The argument is always a double precision real that is converted to
3807 single precision. TODO: Rounding! */
3810 gfc_simplify_sngl (gfc_expr
*a
)
3814 if (a
->expr_type
!= EXPR_CONSTANT
)
3817 result
= gfc_real2real (a
, gfc_default_real_kind
);
3818 return range_check (result
, "SNGL");
3823 gfc_simplify_spacing (gfc_expr
*x
)
3829 if (x
->expr_type
!= EXPR_CONSTANT
)
3832 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3834 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3836 /* Special case x = 0 and -0. */
3837 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3838 if (mpfr_sgn (result
->value
.real
) == 0)
3840 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3844 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3845 are the radix, exponent of x, and precision. This excludes the
3846 possibility of subnormal numbers. Fortran 2003 states the result is
3847 b**max(e - p, emin - 1). */
3849 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
3850 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
3851 en
= en
> ep
? en
: ep
;
3853 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
3854 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
3856 return range_check (result
, "SPACING");
3861 gfc_simplify_sqrt (gfc_expr
*e
)
3864 mpfr_t ac
, ad
, s
, t
, w
;
3866 if (e
->expr_type
!= EXPR_CONSTANT
)
3869 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3874 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
3876 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
3881 /* Formula taken from Numerical Recipes to avoid over- and
3884 gfc_set_model (e
->value
.real
);
3891 if (mpfr_cmp_ui (e
->value
.complex.r
, 0) == 0
3892 && mpfr_cmp_ui (e
->value
.complex.i
, 0) == 0)
3894 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
3895 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
3899 mpfr_abs (ac
, e
->value
.complex.r
, GFC_RND_MODE
);
3900 mpfr_abs (ad
, e
->value
.complex.i
, GFC_RND_MODE
);
3902 if (mpfr_cmp (ac
, ad
) >= 0)
3904 mpfr_div (t
, e
->value
.complex.i
, e
->value
.complex.r
, GFC_RND_MODE
);
3905 mpfr_mul (t
, t
, t
, GFC_RND_MODE
);
3906 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3907 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3908 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3909 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3910 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3911 mpfr_sqrt (s
, ac
, GFC_RND_MODE
);
3912 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3916 mpfr_div (s
, e
->value
.complex.r
, e
->value
.complex.i
, GFC_RND_MODE
);
3917 mpfr_mul (t
, s
, s
, GFC_RND_MODE
);
3918 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3919 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3920 mpfr_abs (s
, s
, GFC_RND_MODE
);
3921 mpfr_add (t
, t
, s
, GFC_RND_MODE
);
3922 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3923 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3924 mpfr_sqrt (s
, ad
, GFC_RND_MODE
);
3925 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3928 if (mpfr_cmp_ui (w
, 0) != 0 && mpfr_cmp_ui (e
->value
.complex.r
, 0) >= 0)
3930 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3931 mpfr_div (result
->value
.complex.i
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3932 mpfr_set (result
->value
.complex.r
, w
, GFC_RND_MODE
);
3934 else if (mpfr_cmp_ui (w
, 0) != 0
3935 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3936 && mpfr_cmp_ui (e
->value
.complex.i
, 0) >= 0)
3938 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3939 mpfr_div (result
->value
.complex.r
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3940 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3942 else if (mpfr_cmp_ui (w
, 0) != 0
3943 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3944 && mpfr_cmp_ui (e
->value
.complex.i
, 0) < 0)
3946 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3947 mpfr_div (result
->value
.complex.r
, ad
, t
, GFC_RND_MODE
);
3948 mpfr_neg (w
, w
, GFC_RND_MODE
);
3949 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3952 gfc_internal_error ("invalid complex argument of SQRT at %L",
3964 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
3967 return range_check (result
, "SQRT");
3970 gfc_free_expr (result
);
3971 gfc_error ("Argument of SQRT at %L has a negative value", &e
->where
);
3972 return &gfc_bad_expr
;
3977 gfc_simplify_tan (gfc_expr
*x
)
3982 if (x
->expr_type
!= EXPR_CONSTANT
)
3985 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3987 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3989 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3991 return range_check (result
, "TAN");
3996 gfc_simplify_tanh (gfc_expr
*x
)
4000 if (x
->expr_type
!= EXPR_CONSTANT
)
4003 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4005 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4007 return range_check (result
, "TANH");
4013 gfc_simplify_tiny (gfc_expr
*e
)
4018 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
4020 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
4021 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
4028 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
4031 gfc_expr
*mold_element
;
4034 size_t result_elt_size
;
4037 unsigned char *buffer
;
4039 if (!gfc_is_constant_expr (source
)
4040 || !gfc_is_constant_expr (size
))
4043 if (source
->expr_type
== EXPR_FUNCTION
)
4046 /* Calculate the size of the source. */
4047 if (source
->expr_type
== EXPR_ARRAY
4048 && gfc_array_size (source
, &tmp
) == FAILURE
)
4049 gfc_internal_error ("Failure getting length of a constant array.");
4051 source_size
= gfc_target_expr_size (source
);
4053 /* Create an empty new expression with the appropriate characteristics. */
4054 result
= gfc_constant_result (mold
->ts
.type
, mold
->ts
.kind
,
4056 result
->ts
= mold
->ts
;
4058 mold_element
= mold
->expr_type
== EXPR_ARRAY
4059 ? mold
->value
.constructor
->expr
4062 /* Set result character length, if needed. Note that this needs to be
4063 set even for array expressions, in order to pass this information into
4064 gfc_target_interpret_expr. */
4065 if (result
->ts
.type
== BT_CHARACTER
)
4066 result
->value
.character
.length
= mold_element
->value
.character
.length
;
4068 /* Set the number of elements in the result, and determine its size. */
4069 result_elt_size
= gfc_target_expr_size (mold_element
);
4070 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
4074 result
->expr_type
= EXPR_ARRAY
;
4078 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
4081 result_length
= source_size
/ result_elt_size
;
4082 if (result_length
* result_elt_size
< source_size
)
4086 result
->shape
= gfc_get_shape (1);
4087 mpz_init_set_ui (result
->shape
[0], result_length
);
4089 result_size
= result_length
* result_elt_size
;
4094 result_size
= result_elt_size
;
4097 if (gfc_option
.warn_surprising
&& source_size
< result_size
)
4098 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4099 "source size %ld < result size %ld", &source
->where
,
4100 (long) source_size
, (long) result_size
);
4102 /* Allocate the buffer to store the binary version of the source. */
4103 buffer_size
= MAX (source_size
, result_size
);
4104 buffer
= (unsigned char*)alloca (buffer_size
);
4106 /* Now write source to the buffer. */
4107 gfc_target_encode_expr (source
, buffer
, buffer_size
);
4109 /* And read the buffer back into the new expression. */
4110 gfc_target_interpret_expr (buffer
, buffer_size
, result
);
4117 gfc_simplify_trim (gfc_expr
*e
)
4120 int count
, i
, len
, lentrim
;
4122 if (e
->expr_type
!= EXPR_CONSTANT
)
4125 len
= e
->value
.character
.length
;
4127 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
4129 for (count
= 0, i
= 1; i
<= len
; ++i
)
4131 if (e
->value
.character
.string
[len
- i
] == ' ')
4137 lentrim
= len
- count
;
4139 result
->value
.character
.length
= lentrim
;
4140 result
->value
.character
.string
= gfc_getmem (lentrim
+ 1);
4142 for (i
= 0; i
< lentrim
; i
++)
4143 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
4145 result
->value
.character
.string
[lentrim
] = '\0'; /* For debugger */
4152 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4154 return simplify_bound (array
, dim
, kind
, 1);
4159 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
4163 size_t index
, len
, lenset
;
4165 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
4168 return &gfc_bad_expr
;
4170 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
)
4173 if (b
!= NULL
&& b
->value
.logical
!= 0)
4178 result
= gfc_constant_result (BT_INTEGER
, k
, &s
->where
);
4180 len
= s
->value
.character
.length
;
4181 lenset
= set
->value
.character
.length
;
4185 mpz_set_ui (result
->value
.integer
, 0);
4193 mpz_set_ui (result
->value
.integer
, 1);
4197 index
= strspn (s
->value
.character
.string
, set
->value
.character
.string
)
4207 mpz_set_ui (result
->value
.integer
, len
);
4210 for (index
= len
; index
> 0; index
--)
4212 for (i
= 0; i
< lenset
; i
++)
4214 if (s
->value
.character
.string
[index
- 1]
4215 == set
->value
.character
.string
[i
])
4223 mpz_set_ui (result
->value
.integer
, index
);
4229 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
4234 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4237 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4238 if (x
->ts
.type
== BT_INTEGER
)
4240 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
4241 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4243 else /* BT_LOGICAL */
4245 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
4246 result
->value
.logical
= (x
->value
.logical
&& !y
->value
.logical
)
4247 || (!x
->value
.logical
&& y
->value
.logical
);
4250 return range_check (result
, "XOR");
4254 /****************** Constant simplification *****************/
4256 /* Master function to convert one constant to another. While this is
4257 used as a simplification function, it requires the destination type
4258 and kind information which is supplied by a special case in
4262 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
4264 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
4265 gfc_constructor
*head
, *c
, *tail
= NULL
;
4279 f
= gfc_int2complex
;
4299 f
= gfc_real2complex
;
4310 f
= gfc_complex2int
;
4313 f
= gfc_complex2real
;
4316 f
= gfc_complex2complex
;
4342 f
= gfc_hollerith2int
;
4346 f
= gfc_hollerith2real
;
4350 f
= gfc_hollerith2complex
;
4354 f
= gfc_hollerith2character
;
4358 f
= gfc_hollerith2logical
;
4368 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4373 switch (e
->expr_type
)
4376 result
= f (e
, kind
);
4378 return &gfc_bad_expr
;
4382 if (!gfc_is_constant_expr (e
))
4387 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
4390 head
= tail
= gfc_get_constructor ();
4393 tail
->next
= gfc_get_constructor ();
4397 tail
->where
= c
->where
;
4399 if (c
->iterator
== NULL
)
4400 tail
->expr
= f (c
->expr
, kind
);
4403 g
= gfc_convert_constant (c
->expr
, type
, kind
);
4404 if (g
== &gfc_bad_expr
)
4409 if (tail
->expr
== NULL
)
4411 gfc_free_constructor (head
);
4416 result
= gfc_get_expr ();
4417 result
->ts
.type
= type
;
4418 result
->ts
.kind
= kind
;
4419 result
->expr_type
= EXPR_ARRAY
;
4420 result
->value
.constructor
= head
;
4421 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4422 result
->where
= e
->where
;
4423 result
->rank
= e
->rank
;