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
)
73 switch (gfc_range_check (result
))
79 gfc_error ("Result of %s overflows its kind at %L", name
,
84 gfc_error ("Result of %s underflows its kind at %L", name
,
89 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
93 gfc_error ("Result of %s gives range error for its kind at %L", name
,
98 gfc_free_expr (result
);
103 /* A helper function that gets an optional and possibly missing
104 kind parameter. Returns the kind, -1 if something went wrong. */
107 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
114 if (k
->expr_type
!= EXPR_CONSTANT
)
116 gfc_error ("KIND parameter of %s at %L must be an initialization "
117 "expression", name
, &k
->where
);
121 if (gfc_extract_int (k
, &kind
) != NULL
122 || gfc_validate_kind (type
, kind
, true) < 0)
124 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
132 /* Helper function to get an integer constant with a kind number given
133 by an integer constant expression. */
135 int_expr_with_kind (int i
, gfc_expr
*kind
, const char *name
)
137 gfc_expr
*res
= gfc_int_expr (i
);
138 res
->ts
.kind
= get_kind (BT_INTEGER
, kind
, name
, gfc_default_integer_kind
);
139 if (res
->ts
.kind
== -1)
146 /* Converts an mpz_t signed variable into an unsigned one, assuming
147 two's complement representations and a binary width of bitsize.
148 The conversion is a no-op unless x is negative; otherwise, it can
149 be accomplished by masking out the high bits. */
152 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
158 /* Confirm that no bits above the signed range are unset. */
159 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
161 mpz_init_set_ui (mask
, 1);
162 mpz_mul_2exp (mask
, mask
, bitsize
);
163 mpz_sub_ui (mask
, mask
, 1);
165 mpz_and (x
, x
, mask
);
171 /* Confirm that no bits above the signed range are set. */
172 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
177 /* Converts an mpz_t unsigned variable into a signed one, assuming
178 two's complement representations and a binary width of bitsize.
179 If the bitsize-1 bit is set, this is taken as a sign bit and
180 the number is converted to the corresponding negative number. */
183 convert_mpz_to_signed (mpz_t x
, int bitsize
)
187 /* Confirm that no bits above the unsigned range are set. */
188 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
190 if (mpz_tstbit (x
, bitsize
- 1) == 1)
192 mpz_init_set_ui (mask
, 1);
193 mpz_mul_2exp (mask
, mask
, bitsize
);
194 mpz_sub_ui (mask
, mask
, 1);
196 /* We negate the number by hand, zeroing the high bits, that is
197 make it the corresponding positive number, and then have it
198 negated by GMP, giving the correct representation of the
201 mpz_add_ui (x
, x
, 1);
202 mpz_and (x
, x
, mask
);
211 /********************** Simplification functions *****************************/
214 gfc_simplify_abs (gfc_expr
*e
)
218 if (e
->expr_type
!= EXPR_CONSTANT
)
224 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
226 mpz_abs (result
->value
.integer
, e
->value
.integer
);
228 result
= range_check (result
, "IABS");
232 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
234 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
236 result
= range_check (result
, "ABS");
240 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
242 gfc_set_model_kind (e
->ts
.kind
);
244 mpfr_hypot (result
->value
.real
, e
->value
.complex.r
,
245 e
->value
.complex.i
, GFC_RND_MODE
);
246 result
= range_check (result
, "CABS");
250 gfc_internal_error ("gfc_simplify_abs(): Bad type");
256 /* We use the processor's collating sequence, because all
257 systems that gfortran currently works on are ASCII. */
260 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
266 if (e
->expr_type
!= EXPR_CONSTANT
)
269 kind
= get_kind (BT_CHARACTER
, k
, "ACHAR", gfc_default_character_kind
);
271 return &gfc_bad_expr
;
273 ch
= gfc_extract_int (e
, &c
);
276 gfc_internal_error ("gfc_simplify_achar: %s", ch
);
278 if (gfc_option
.warn_surprising
&& (c
< 0 || c
> 127))
279 gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
282 result
= gfc_constant_result (BT_CHARACTER
, kind
, &e
->where
);
284 result
->value
.character
.string
= gfc_getmem (2);
286 result
->value
.character
.length
= 1;
287 result
->value
.character
.string
[0] = c
;
288 result
->value
.character
.string
[1] = '\0'; /* For debugger */
294 gfc_simplify_acos (gfc_expr
*x
)
298 if (x
->expr_type
!= EXPR_CONSTANT
)
301 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
302 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
304 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
306 return &gfc_bad_expr
;
309 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
311 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
313 return range_check (result
, "ACOS");
317 gfc_simplify_acosh (gfc_expr
*x
)
321 if (x
->expr_type
!= EXPR_CONSTANT
)
324 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
326 gfc_error ("Argument of ACOSH at %L must not be less than 1",
328 return &gfc_bad_expr
;
331 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
333 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
335 return range_check (result
, "ACOSH");
339 gfc_simplify_adjustl (gfc_expr
*e
)
345 if (e
->expr_type
!= EXPR_CONSTANT
)
348 len
= e
->value
.character
.length
;
350 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
352 result
->value
.character
.length
= len
;
353 result
->value
.character
.string
= gfc_getmem (len
+ 1);
355 for (count
= 0, i
= 0; i
< len
; ++i
)
357 ch
= e
->value
.character
.string
[i
];
363 for (i
= 0; i
< len
- count
; ++i
)
364 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
366 for (i
= len
- count
; i
< len
; ++i
)
367 result
->value
.character
.string
[i
] = ' ';
369 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
376 gfc_simplify_adjustr (gfc_expr
*e
)
382 if (e
->expr_type
!= EXPR_CONSTANT
)
385 len
= e
->value
.character
.length
;
387 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
389 result
->value
.character
.length
= len
;
390 result
->value
.character
.string
= gfc_getmem (len
+ 1);
392 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
394 ch
= e
->value
.character
.string
[i
];
400 for (i
= 0; i
< count
; ++i
)
401 result
->value
.character
.string
[i
] = ' ';
403 for (i
= count
; i
< len
; ++i
)
404 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
406 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
413 gfc_simplify_aimag (gfc_expr
*e
)
417 if (e
->expr_type
!= EXPR_CONSTANT
)
420 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
421 mpfr_set (result
->value
.real
, e
->value
.complex.i
, GFC_RND_MODE
);
423 return range_check (result
, "AIMAG");
428 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
430 gfc_expr
*rtrunc
, *result
;
433 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
435 return &gfc_bad_expr
;
437 if (e
->expr_type
!= EXPR_CONSTANT
)
440 rtrunc
= gfc_copy_expr (e
);
442 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
444 result
= gfc_real2real (rtrunc
, kind
);
445 gfc_free_expr (rtrunc
);
447 return range_check (result
, "AINT");
452 gfc_simplify_dint (gfc_expr
*e
)
454 gfc_expr
*rtrunc
, *result
;
456 if (e
->expr_type
!= EXPR_CONSTANT
)
459 rtrunc
= gfc_copy_expr (e
);
461 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
463 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
464 gfc_free_expr (rtrunc
);
466 return range_check (result
, "DINT");
471 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
476 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
478 return &gfc_bad_expr
;
480 if (e
->expr_type
!= EXPR_CONSTANT
)
483 result
= gfc_constant_result (e
->ts
.type
, kind
, &e
->where
);
485 mpfr_round (result
->value
.real
, e
->value
.real
);
487 return range_check (result
, "ANINT");
492 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
497 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
500 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
501 if (x
->ts
.type
== BT_INTEGER
)
503 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
504 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
506 else /* BT_LOGICAL */
508 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
509 result
->value
.logical
= x
->value
.logical
&& y
->value
.logical
;
512 return range_check (result
, "AND");
517 gfc_simplify_dnint (gfc_expr
*e
)
521 if (e
->expr_type
!= EXPR_CONSTANT
)
524 result
= gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &e
->where
);
526 mpfr_round (result
->value
.real
, e
->value
.real
);
528 return range_check (result
, "DNINT");
533 gfc_simplify_asin (gfc_expr
*x
)
537 if (x
->expr_type
!= EXPR_CONSTANT
)
540 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
541 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
543 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
545 return &gfc_bad_expr
;
548 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
550 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
552 return range_check (result
, "ASIN");
557 gfc_simplify_asinh (gfc_expr
*x
)
561 if (x
->expr_type
!= EXPR_CONSTANT
)
564 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
566 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
568 return range_check (result
, "ASINH");
573 gfc_simplify_atan (gfc_expr
*x
)
577 if (x
->expr_type
!= EXPR_CONSTANT
)
580 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
582 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
584 return range_check (result
, "ATAN");
589 gfc_simplify_atanh (gfc_expr
*x
)
593 if (x
->expr_type
!= EXPR_CONSTANT
)
596 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
597 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
599 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
601 return &gfc_bad_expr
;
604 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
606 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
608 return range_check (result
, "ATANH");
613 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
617 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
620 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
622 if (mpfr_sgn (y
->value
.real
) == 0 && mpfr_sgn (x
->value
.real
) == 0)
624 gfc_error ("If first argument of ATAN2 %L is zero, then the "
625 "second argument must not be zero", &x
->where
);
626 gfc_free_expr (result
);
627 return &gfc_bad_expr
;
630 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
632 return range_check (result
, "ATAN2");
637 gfc_simplify_bit_size (gfc_expr
*e
)
642 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
643 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
644 mpz_set_ui (result
->value
.integer
, gfc_integer_kinds
[i
].bit_size
);
651 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
655 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
658 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
659 return gfc_logical_expr (0, &e
->where
);
661 return gfc_logical_expr (mpz_tstbit (e
->value
.integer
, b
), &e
->where
);
666 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
668 gfc_expr
*ceil
, *result
;
671 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
673 return &gfc_bad_expr
;
675 if (e
->expr_type
!= EXPR_CONSTANT
)
678 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
680 ceil
= gfc_copy_expr (e
);
682 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
683 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
);
685 gfc_free_expr (ceil
);
687 return range_check (result
, "CEILING");
692 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
698 kind
= get_kind (BT_CHARACTER
, k
, "CHAR", gfc_default_character_kind
);
700 return &gfc_bad_expr
;
702 if (e
->expr_type
!= EXPR_CONSTANT
)
705 ch
= gfc_extract_int (e
, &c
);
708 gfc_internal_error ("gfc_simplify_char: %s", ch
);
710 if (c
< 0 || c
> UCHAR_MAX
)
711 gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
714 result
= gfc_constant_result (BT_CHARACTER
, kind
, &e
->where
);
716 result
->value
.character
.length
= 1;
717 result
->value
.character
.string
= gfc_getmem (2);
719 result
->value
.character
.string
[0] = c
;
720 result
->value
.character
.string
[1] = '\0'; /* For debugger */
726 /* Common subroutine for simplifying CMPLX and DCMPLX. */
729 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
733 result
= gfc_constant_result (BT_COMPLEX
, kind
, &x
->where
);
735 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
740 mpfr_set_z (result
->value
.complex.r
, x
->value
.integer
, GFC_RND_MODE
);
744 mpfr_set (result
->value
.complex.r
, x
->value
.real
, GFC_RND_MODE
);
748 mpfr_set (result
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
749 mpfr_set (result
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
753 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
761 mpfr_set_z (result
->value
.complex.i
, y
->value
.integer
, GFC_RND_MODE
);
765 mpfr_set (result
->value
.complex.i
, y
->value
.real
, GFC_RND_MODE
);
769 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
773 return range_check (result
, name
);
778 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
782 if (x
->expr_type
!= EXPR_CONSTANT
783 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
786 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_real_kind
);
788 return &gfc_bad_expr
;
790 return simplify_cmplx ("CMPLX", x
, y
, kind
);
795 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
799 if (x
->expr_type
!= EXPR_CONSTANT
800 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
803 if (x
->ts
.type
== BT_INTEGER
)
805 if (y
->ts
.type
== BT_INTEGER
)
806 kind
= gfc_default_real_kind
;
812 if (y
->ts
.type
== BT_REAL
)
813 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
818 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
823 gfc_simplify_conjg (gfc_expr
*e
)
827 if (e
->expr_type
!= EXPR_CONSTANT
)
830 result
= gfc_copy_expr (e
);
831 mpfr_neg (result
->value
.complex.i
, result
->value
.complex.i
, GFC_RND_MODE
);
833 return range_check (result
, "CONJG");
838 gfc_simplify_cos (gfc_expr
*x
)
843 if (x
->expr_type
!= EXPR_CONSTANT
)
846 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
851 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
854 gfc_set_model_kind (x
->ts
.kind
);
858 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
859 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
860 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
862 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
863 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
864 mpfr_mul (xp
, xp
, xq
, GFC_RND_MODE
);
865 mpfr_neg (result
->value
.complex.i
, xp
, GFC_RND_MODE
);
871 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
874 return range_check (result
, "COS");
880 gfc_simplify_cosh (gfc_expr
*x
)
884 if (x
->expr_type
!= EXPR_CONSTANT
)
887 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
889 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
891 return range_check (result
, "COSH");
896 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
899 if (x
->expr_type
!= EXPR_CONSTANT
900 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
903 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
908 gfc_simplify_dble (gfc_expr
*e
)
912 if (e
->expr_type
!= EXPR_CONSTANT
)
918 result
= gfc_int2real (e
, gfc_default_double_kind
);
922 result
= gfc_real2real (e
, gfc_default_double_kind
);
926 result
= gfc_complex2real (e
, gfc_default_double_kind
);
930 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e
->where
);
933 return range_check (result
, "DBLE");
938 gfc_simplify_digits (gfc_expr
*x
)
942 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
946 digits
= gfc_integer_kinds
[i
].digits
;
951 digits
= gfc_real_kinds
[i
].digits
;
958 return gfc_int_expr (digits
);
963 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
968 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
971 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
972 result
= gfc_constant_result (x
->ts
.type
, kind
, &x
->where
);
977 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
978 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
980 mpz_set_ui (result
->value
.integer
, 0);
985 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
986 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
989 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
994 gfc_internal_error ("gfc_simplify_dim(): Bad type");
997 return range_check (result
, "DIM");
1002 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
1004 gfc_expr
*a1
, *a2
, *result
;
1006 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1009 result
= gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &x
->where
);
1011 a1
= gfc_real2real (x
, gfc_default_double_kind
);
1012 a2
= gfc_real2real (y
, gfc_default_double_kind
);
1014 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
1019 return range_check (result
, "DPROD");
1024 gfc_simplify_epsilon (gfc_expr
*e
)
1029 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1031 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
1033 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
1035 return range_check (result
, "EPSILON");
1040 gfc_simplify_exp (gfc_expr
*x
)
1045 if (x
->expr_type
!= EXPR_CONSTANT
)
1048 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1053 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1057 gfc_set_model_kind (x
->ts
.kind
);
1060 mpfr_exp (xq
, x
->value
.complex.r
, GFC_RND_MODE
);
1061 mpfr_cos (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
1062 mpfr_mul (result
->value
.complex.r
, xq
, xp
, GFC_RND_MODE
);
1063 mpfr_sin (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
1064 mpfr_mul (result
->value
.complex.i
, xq
, xp
, GFC_RND_MODE
);
1070 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1073 return range_check (result
, "EXP");
1077 gfc_simplify_exponent (gfc_expr
*x
)
1082 if (x
->expr_type
!= EXPR_CONSTANT
)
1085 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1088 gfc_set_model (x
->value
.real
);
1090 if (mpfr_sgn (x
->value
.real
) == 0)
1092 mpz_set_ui (result
->value
.integer
, 0);
1096 i
= (int) mpfr_get_exp (x
->value
.real
);
1097 mpz_set_si (result
->value
.integer
, i
);
1099 return range_check (result
, "EXPONENT");
1104 gfc_simplify_float (gfc_expr
*a
)
1108 if (a
->expr_type
!= EXPR_CONSTANT
)
1111 result
= gfc_int2real (a
, gfc_default_real_kind
);
1112 return range_check (result
, "FLOAT");
1117 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
1123 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
1125 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1127 if (e
->expr_type
!= EXPR_CONSTANT
)
1130 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1132 gfc_set_model_kind (kind
);
1134 mpfr_floor (floor
, e
->value
.real
);
1136 gfc_mpfr_to_mpz (result
->value
.integer
, floor
);
1140 return range_check (result
, "FLOOR");
1145 gfc_simplify_fraction (gfc_expr
*x
)
1148 mpfr_t absv
, exp
, pow2
;
1150 if (x
->expr_type
!= EXPR_CONSTANT
)
1153 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
1155 gfc_set_model_kind (x
->ts
.kind
);
1157 if (mpfr_sgn (x
->value
.real
) == 0)
1159 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1167 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
1168 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
1170 mpfr_trunc (exp
, exp
);
1171 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
1173 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
1175 mpfr_div (result
->value
.real
, absv
, pow2
, GFC_RND_MODE
);
1181 return range_check (result
, "FRACTION");
1186 gfc_simplify_huge (gfc_expr
*e
)
1191 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1193 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1198 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
1202 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
1212 /* We use the processor's collating sequence, because all
1213 systems that gfortran currently works on are ASCII. */
1216 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
1221 if (e
->expr_type
!= EXPR_CONSTANT
)
1224 if (e
->value
.character
.length
!= 1)
1226 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
1227 return &gfc_bad_expr
;
1230 index
= (unsigned char) e
->value
.character
.string
[0];
1232 if (gfc_option
.warn_surprising
&& index
> 127)
1233 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1236 if ((result
= int_expr_with_kind (index
, kind
, "IACHAR")) == NULL
)
1237 return &gfc_bad_expr
;
1239 result
->where
= e
->where
;
1241 return range_check (result
, "IACHAR");
1246 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
1250 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1253 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1255 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1257 return range_check (result
, "IAND");
1262 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
1267 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1270 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1272 gfc_error ("Invalid second argument of IBCLR at %L", &y
->where
);
1273 return &gfc_bad_expr
;
1276 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1278 if (pos
>= gfc_integer_kinds
[k
].bit_size
)
1280 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1282 return &gfc_bad_expr
;
1285 result
= gfc_copy_expr (x
);
1287 convert_mpz_to_unsigned (result
->value
.integer
,
1288 gfc_integer_kinds
[k
].bit_size
);
1290 mpz_clrbit (result
->value
.integer
, pos
);
1292 convert_mpz_to_signed (result
->value
.integer
,
1293 gfc_integer_kinds
[k
].bit_size
);
1295 return range_check (result
, "IBCLR");
1300 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
1307 if (x
->expr_type
!= EXPR_CONSTANT
1308 || y
->expr_type
!= EXPR_CONSTANT
1309 || z
->expr_type
!= EXPR_CONSTANT
)
1312 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1314 gfc_error ("Invalid second argument of IBITS at %L", &y
->where
);
1315 return &gfc_bad_expr
;
1318 if (gfc_extract_int (z
, &len
) != NULL
|| len
< 0)
1320 gfc_error ("Invalid third argument of IBITS at %L", &z
->where
);
1321 return &gfc_bad_expr
;
1324 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
1326 bitsize
= gfc_integer_kinds
[k
].bit_size
;
1328 if (pos
+ len
> bitsize
)
1330 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1331 "bit size at %L", &y
->where
);
1332 return &gfc_bad_expr
;
1335 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1337 bits
= gfc_getmem (bitsize
* sizeof (int));
1339 for (i
= 0; i
< bitsize
; i
++)
1342 for (i
= 0; i
< len
; i
++)
1343 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
1345 for (i
= 0; i
< bitsize
; i
++)
1348 mpz_clrbit (result
->value
.integer
, i
);
1349 else if (bits
[i
] == 1)
1350 mpz_setbit (result
->value
.integer
, i
);
1352 gfc_internal_error ("IBITS: Bad bit");
1357 return range_check (result
, "IBITS");
1362 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
1367 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1370 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1372 gfc_error ("Invalid second argument of IBSET at %L", &y
->where
);
1373 return &gfc_bad_expr
;
1376 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1378 if (pos
>= gfc_integer_kinds
[k
].bit_size
)
1380 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1382 return &gfc_bad_expr
;
1385 result
= gfc_copy_expr (x
);
1387 convert_mpz_to_unsigned (result
->value
.integer
,
1388 gfc_integer_kinds
[k
].bit_size
);
1390 mpz_setbit (result
->value
.integer
, pos
);
1392 convert_mpz_to_signed (result
->value
.integer
,
1393 gfc_integer_kinds
[k
].bit_size
);
1395 return range_check (result
, "IBSET");
1400 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
1405 if (e
->expr_type
!= EXPR_CONSTANT
)
1408 if (e
->value
.character
.length
!= 1)
1410 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
1411 return &gfc_bad_expr
;
1414 index
= (unsigned char) e
->value
.character
.string
[0];
1416 if (index
< 0 || index
> UCHAR_MAX
)
1417 gfc_internal_error("Argument of ICHAR at %L out of range", &e
->where
);
1419 if ((result
= int_expr_with_kind (index
, kind
, "ICHAR")) == NULL
)
1420 return &gfc_bad_expr
;
1422 result
->where
= e
->where
;
1423 return range_check (result
, "ICHAR");
1428 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
1432 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1435 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1437 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1439 return range_check (result
, "IEOR");
1444 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
1447 int back
, len
, lensub
;
1448 int i
, j
, k
, count
, index
= 0, start
;
1450 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1453 if (b
!= NULL
&& b
->value
.logical
!= 0)
1458 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
1460 return &gfc_bad_expr
;
1462 result
= gfc_constant_result (BT_INTEGER
, k
, &x
->where
);
1464 len
= x
->value
.character
.length
;
1465 lensub
= y
->value
.character
.length
;
1469 mpz_set_si (result
->value
.integer
, 0);
1477 mpz_set_si (result
->value
.integer
, 1);
1480 else if (lensub
== 1)
1482 for (i
= 0; i
< len
; i
++)
1484 for (j
= 0; j
< lensub
; j
++)
1486 if (y
->value
.character
.string
[j
]
1487 == x
->value
.character
.string
[i
])
1497 for (i
= 0; i
< len
; i
++)
1499 for (j
= 0; j
< lensub
; j
++)
1501 if (y
->value
.character
.string
[j
]
1502 == x
->value
.character
.string
[i
])
1507 for (k
= 0; k
< lensub
; k
++)
1509 if (y
->value
.character
.string
[k
]
1510 == x
->value
.character
.string
[k
+ start
])
1514 if (count
== lensub
)
1529 mpz_set_si (result
->value
.integer
, len
+ 1);
1532 else if (lensub
== 1)
1534 for (i
= 0; i
< len
; i
++)
1536 for (j
= 0; j
< lensub
; j
++)
1538 if (y
->value
.character
.string
[j
]
1539 == x
->value
.character
.string
[len
- i
])
1541 index
= len
- i
+ 1;
1549 for (i
= 0; i
< len
; i
++)
1551 for (j
= 0; j
< lensub
; j
++)
1553 if (y
->value
.character
.string
[j
]
1554 == x
->value
.character
.string
[len
- i
])
1557 if (start
<= len
- lensub
)
1560 for (k
= 0; k
< lensub
; k
++)
1561 if (y
->value
.character
.string
[k
]
1562 == x
->value
.character
.string
[k
+ start
])
1565 if (count
== lensub
)
1582 mpz_set_si (result
->value
.integer
, index
);
1583 return range_check (result
, "INDEX");
1588 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
1590 gfc_expr
*rpart
, *rtrunc
, *result
;
1593 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
1595 return &gfc_bad_expr
;
1597 if (e
->expr_type
!= EXPR_CONSTANT
)
1600 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1605 mpz_set (result
->value
.integer
, e
->value
.integer
);
1609 rtrunc
= gfc_copy_expr (e
);
1610 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1611 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1612 gfc_free_expr (rtrunc
);
1616 rpart
= gfc_complex2real (e
, kind
);
1617 rtrunc
= gfc_copy_expr (rpart
);
1618 mpfr_trunc (rtrunc
->value
.real
, rpart
->value
.real
);
1619 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1620 gfc_free_expr (rpart
);
1621 gfc_free_expr (rtrunc
);
1625 gfc_error ("Argument of INT at %L is not a valid type", &e
->where
);
1626 gfc_free_expr (result
);
1627 return &gfc_bad_expr
;
1630 return range_check (result
, "INT");
1635 gfc_simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
1637 gfc_expr
*rpart
, *rtrunc
, *result
;
1639 if (e
->expr_type
!= EXPR_CONSTANT
)
1642 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1647 mpz_set (result
->value
.integer
, e
->value
.integer
);
1651 rtrunc
= gfc_copy_expr (e
);
1652 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1653 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1654 gfc_free_expr (rtrunc
);
1658 rpart
= gfc_complex2real (e
, kind
);
1659 rtrunc
= gfc_copy_expr (rpart
);
1660 mpfr_trunc (rtrunc
->value
.real
, rpart
->value
.real
);
1661 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1662 gfc_free_expr (rpart
);
1663 gfc_free_expr (rtrunc
);
1667 gfc_error ("Argument of %s at %L is not a valid type", name
, &e
->where
);
1668 gfc_free_expr (result
);
1669 return &gfc_bad_expr
;
1672 return range_check (result
, name
);
1677 gfc_simplify_int2 (gfc_expr
*e
)
1679 return gfc_simplify_intconv (e
, 2, "INT2");
1684 gfc_simplify_int8 (gfc_expr
*e
)
1686 return gfc_simplify_intconv (e
, 8, "INT8");
1691 gfc_simplify_long (gfc_expr
*e
)
1693 return gfc_simplify_intconv (e
, 4, "LONG");
1698 gfc_simplify_ifix (gfc_expr
*e
)
1700 gfc_expr
*rtrunc
, *result
;
1702 if (e
->expr_type
!= EXPR_CONSTANT
)
1705 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1708 rtrunc
= gfc_copy_expr (e
);
1710 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1711 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1713 gfc_free_expr (rtrunc
);
1714 return range_check (result
, "IFIX");
1719 gfc_simplify_idint (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
, "IDINT");
1740 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
1744 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1747 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1749 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1750 return range_check (result
, "IOR");
1755 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
1758 int shift
, ashift
, isize
, k
, *bits
, i
;
1760 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1763 if (gfc_extract_int (s
, &shift
) != NULL
)
1765 gfc_error ("Invalid second argument of ISHFT at %L", &s
->where
);
1766 return &gfc_bad_expr
;
1769 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
1771 isize
= gfc_integer_kinds
[k
].bit_size
;
1780 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
1781 "at %L", &s
->where
);
1782 return &gfc_bad_expr
;
1785 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1789 mpz_set (result
->value
.integer
, e
->value
.integer
);
1790 return range_check (result
, "ISHFT");
1793 bits
= gfc_getmem (isize
* sizeof (int));
1795 for (i
= 0; i
< isize
; i
++)
1796 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1800 for (i
= 0; i
< shift
; i
++)
1801 mpz_clrbit (result
->value
.integer
, i
);
1803 for (i
= 0; i
< isize
- shift
; i
++)
1806 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1808 mpz_setbit (result
->value
.integer
, i
+ shift
);
1813 for (i
= isize
- 1; i
>= isize
- ashift
; i
--)
1814 mpz_clrbit (result
->value
.integer
, i
);
1816 for (i
= isize
- 1; i
>= ashift
; i
--)
1819 mpz_clrbit (result
->value
.integer
, i
- ashift
);
1821 mpz_setbit (result
->value
.integer
, i
- ashift
);
1825 convert_mpz_to_signed (result
->value
.integer
, isize
);
1833 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
1836 int shift
, ashift
, isize
, ssize
, delta
, k
;
1839 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1842 if (gfc_extract_int (s
, &shift
) != NULL
)
1844 gfc_error ("Invalid second argument of ISHFTC at %L", &s
->where
);
1845 return &gfc_bad_expr
;
1848 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1849 isize
= gfc_integer_kinds
[k
].bit_size
;
1853 if (sz
->expr_type
!= EXPR_CONSTANT
)
1856 if (gfc_extract_int (sz
, &ssize
) != NULL
|| ssize
<= 0)
1858 gfc_error ("Invalid third argument of ISHFTC at %L", &sz
->where
);
1859 return &gfc_bad_expr
;
1864 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
1865 "BIT_SIZE of first argument at %L", &s
->where
);
1866 return &gfc_bad_expr
;
1880 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1881 "third argument at %L", &s
->where
);
1883 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1884 "BIT_SIZE of first argument at %L", &s
->where
);
1885 return &gfc_bad_expr
;
1888 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1890 mpz_set (result
->value
.integer
, e
->value
.integer
);
1895 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
1897 bits
= gfc_getmem (ssize
* sizeof (int));
1899 for (i
= 0; i
< ssize
; i
++)
1900 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1902 delta
= ssize
- ashift
;
1906 for (i
= 0; i
< delta
; i
++)
1909 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1911 mpz_setbit (result
->value
.integer
, i
+ shift
);
1914 for (i
= delta
; i
< ssize
; i
++)
1917 mpz_clrbit (result
->value
.integer
, i
- delta
);
1919 mpz_setbit (result
->value
.integer
, i
- delta
);
1924 for (i
= 0; i
< ashift
; i
++)
1927 mpz_clrbit (result
->value
.integer
, i
+ delta
);
1929 mpz_setbit (result
->value
.integer
, i
+ delta
);
1932 for (i
= ashift
; i
< ssize
; i
++)
1935 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1937 mpz_setbit (result
->value
.integer
, i
+ shift
);
1941 convert_mpz_to_signed (result
->value
.integer
, isize
);
1949 gfc_simplify_kind (gfc_expr
*e
)
1952 if (e
->ts
.type
== BT_DERIVED
)
1954 gfc_error ("Argument of KIND at %L is a DERIVED type", &e
->where
);
1955 return &gfc_bad_expr
;
1958 return gfc_int_expr (e
->ts
.kind
);
1963 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
1966 gfc_expr
*l
, *u
, *result
;
1969 /* The last dimension of an assumed-size array is special. */
1970 if (d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
1972 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
1973 return gfc_copy_expr (as
->lower
[d
-1]);
1978 /* Then, we need to know the extent of the given dimension. */
1982 if (l
->expr_type
!= EXPR_CONSTANT
|| u
->expr_type
!= EXPR_CONSTANT
)
1985 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
1986 gfc_default_integer_kind
);
1988 return &gfc_bad_expr
;
1990 result
= gfc_constant_result (BT_INTEGER
, k
, &array
->where
);
1992 if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
1996 mpz_set_si (result
->value
.integer
, 0);
1998 mpz_set_si (result
->value
.integer
, 1);
2002 /* Nonzero extent. */
2004 mpz_set (result
->value
.integer
, u
->value
.integer
);
2006 mpz_set (result
->value
.integer
, l
->value
.integer
);
2009 return range_check (result
, upper
? "UBOUND" : "LBOUND");
2014 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
2020 if (array
->expr_type
!= EXPR_VARIABLE
)
2023 /* Follow any component references. */
2024 as
= array
->symtree
->n
.sym
->as
;
2025 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2030 switch (ref
->u
.ar
.type
)
2037 /* We're done because 'as' has already been set in the
2038 previous iteration. */
2049 as
= ref
->u
.c
.component
->as
;
2061 if (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
)
2066 /* Multi-dimensional bounds. */
2067 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
2069 gfc_constructor
*head
, *tail
;
2072 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2073 if (upper
&& as
->type
== AS_ASSUMED_SIZE
)
2075 /* An error message will be emitted in
2076 check_assumed_size_reference (resolve.c). */
2077 return &gfc_bad_expr
;
2080 /* Simplify the bounds for each dimension. */
2081 for (d
= 0; d
< array
->rank
; d
++)
2083 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
);
2084 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
2088 for (j
= 0; j
< d
; j
++)
2089 gfc_free_expr (bounds
[j
]);
2094 /* Allocate the result expression. */
2095 e
= gfc_get_expr ();
2096 e
->where
= array
->where
;
2097 e
->expr_type
= EXPR_ARRAY
;
2098 e
->ts
.type
= BT_INTEGER
;
2099 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
2100 gfc_default_integer_kind
);
2102 return &gfc_bad_expr
;
2105 /* The result is a rank 1 array; its size is the rank of the first
2106 argument to {L,U}BOUND. */
2108 e
->shape
= gfc_get_shape (1);
2109 mpz_init_set_ui (e
->shape
[0], array
->rank
);
2111 /* Create the constructor for this array. */
2113 for (d
= 0; d
< array
->rank
; d
++)
2115 /* Get a new constructor element. */
2117 head
= tail
= gfc_get_constructor ();
2120 tail
->next
= gfc_get_constructor ();
2124 tail
->where
= e
->where
;
2125 tail
->expr
= bounds
[d
];
2127 e
->value
.constructor
= head
;
2133 /* A DIM argument is specified. */
2134 if (dim
->expr_type
!= EXPR_CONSTANT
)
2137 d
= mpz_get_si (dim
->value
.integer
);
2139 if (d
< 1 || d
> as
->rank
2140 || (d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
2142 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
2143 return &gfc_bad_expr
;
2146 return simplify_bound_dim (array
, kind
, d
, upper
, as
);
2152 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
2154 return simplify_bound (array
, dim
, kind
, 0);
2159 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
2162 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
2165 return &gfc_bad_expr
;
2167 if (e
->expr_type
== EXPR_CONSTANT
)
2169 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
2170 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
2171 return range_check (result
, "LEN");
2174 if (e
->ts
.cl
!= NULL
&& e
->ts
.cl
->length
!= NULL
2175 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
2176 && e
->ts
.cl
->length
->ts
.type
== BT_INTEGER
)
2178 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
2179 mpz_set (result
->value
.integer
, e
->ts
.cl
->length
->value
.integer
);
2180 return range_check (result
, "LEN");
2188 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
2191 int count
, len
, lentrim
, i
;
2192 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
2195 return &gfc_bad_expr
;
2197 if (e
->expr_type
!= EXPR_CONSTANT
)
2200 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
2201 len
= e
->value
.character
.length
;
2203 for (count
= 0, i
= 1; i
<= len
; i
++)
2204 if (e
->value
.character
.string
[len
- i
] == ' ')
2209 lentrim
= len
- count
;
2211 mpz_set_si (result
->value
.integer
, lentrim
);
2212 return range_check (result
, "LEN_TRIM");
2217 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
2219 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2222 return gfc_logical_expr (gfc_compare_string (a
, b
) >= 0, &a
->where
);
2227 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
2229 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2232 return gfc_logical_expr (gfc_compare_string (a
, b
) > 0,
2238 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
2240 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2243 return gfc_logical_expr (gfc_compare_string (a
, b
) <= 0, &a
->where
);
2248 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
2250 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2253 return gfc_logical_expr (gfc_compare_string (a
, b
) < 0, &a
->where
);
2258 gfc_simplify_log (gfc_expr
*x
)
2263 if (x
->expr_type
!= EXPR_CONSTANT
)
2266 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2268 gfc_set_model_kind (x
->ts
.kind
);
2273 if (mpfr_sgn (x
->value
.real
) <= 0)
2275 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2276 "to zero", &x
->where
);
2277 gfc_free_expr (result
);
2278 return &gfc_bad_expr
;
2281 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2285 if ((mpfr_sgn (x
->value
.complex.r
) == 0)
2286 && (mpfr_sgn (x
->value
.complex.i
) == 0))
2288 gfc_error ("Complex argument of LOG at %L cannot be zero",
2290 gfc_free_expr (result
);
2291 return &gfc_bad_expr
;
2297 mpfr_atan2 (result
->value
.complex.i
, x
->value
.complex.i
,
2298 x
->value
.complex.r
, GFC_RND_MODE
);
2300 mpfr_mul (xr
, x
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
2301 mpfr_mul (xi
, x
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
2302 mpfr_add (xr
, xr
, xi
, GFC_RND_MODE
);
2303 mpfr_sqrt (xr
, xr
, GFC_RND_MODE
);
2304 mpfr_log (result
->value
.complex.r
, xr
, GFC_RND_MODE
);
2312 gfc_internal_error ("gfc_simplify_log: bad type");
2315 return range_check (result
, "LOG");
2320 gfc_simplify_log10 (gfc_expr
*x
)
2324 if (x
->expr_type
!= EXPR_CONSTANT
)
2327 gfc_set_model_kind (x
->ts
.kind
);
2329 if (mpfr_sgn (x
->value
.real
) <= 0)
2331 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2332 "to zero", &x
->where
);
2333 return &gfc_bad_expr
;
2336 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2338 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2340 return range_check (result
, "LOG10");
2345 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
2350 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
2352 return &gfc_bad_expr
;
2354 if (e
->expr_type
!= EXPR_CONSTANT
)
2357 result
= gfc_constant_result (BT_LOGICAL
, kind
, &e
->where
);
2359 result
->value
.logical
= e
->value
.logical
;
2365 /* This function is special since MAX() can take any number of
2366 arguments. The simplified expression is a rewritten version of the
2367 argument list containing at most one constant element. Other
2368 constant elements are deleted. Because the argument list has
2369 already been checked, this function always succeeds. sign is 1 for
2370 MAX(), -1 for MIN(). */
2373 simplify_min_max (gfc_expr
*expr
, int sign
)
2375 gfc_actual_arglist
*arg
, *last
, *extremum
;
2376 gfc_intrinsic_sym
* specific
;
2380 specific
= expr
->value
.function
.isym
;
2382 arg
= expr
->value
.function
.actual
;
2384 for (; arg
; last
= arg
, arg
= arg
->next
)
2386 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
2389 if (extremum
== NULL
)
2395 switch (arg
->expr
->ts
.type
)
2398 if (mpz_cmp (arg
->expr
->value
.integer
,
2399 extremum
->expr
->value
.integer
) * sign
> 0)
2400 mpz_set (extremum
->expr
->value
.integer
, arg
->expr
->value
.integer
);
2404 if (mpfr_cmp (arg
->expr
->value
.real
, extremum
->expr
->value
.real
)
2406 mpfr_set (extremum
->expr
->value
.real
, arg
->expr
->value
.real
,
2411 #define LENGTH(x) ((x)->expr->value.character.length)
2412 #define STRING(x) ((x)->expr->value.character.string)
2413 if (LENGTH(extremum
) < LENGTH(arg
))
2415 char * tmp
= STRING(extremum
);
2417 STRING(extremum
) = gfc_getmem (LENGTH(arg
) + 1);
2418 memcpy (STRING(extremum
), tmp
, LENGTH(extremum
));
2419 memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
2420 LENGTH(arg
) - LENGTH(extremum
));
2421 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
2422 LENGTH(extremum
) = LENGTH(arg
);
2426 if (gfc_compare_string (arg
->expr
, extremum
->expr
) * sign
> 0)
2428 gfc_free (STRING(extremum
));
2429 STRING(extremum
) = gfc_getmem (LENGTH(extremum
) + 1);
2430 memcpy (STRING(extremum
), STRING(arg
), LENGTH(arg
));
2431 memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
2432 LENGTH(extremum
) - LENGTH(arg
));
2433 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
2441 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2444 /* Delete the extra constant argument. */
2446 expr
->value
.function
.actual
= arg
->next
;
2448 last
->next
= arg
->next
;
2451 gfc_free_actual_arglist (arg
);
2455 /* If there is one value left, replace the function call with the
2457 if (expr
->value
.function
.actual
->next
!= NULL
)
2460 /* Convert to the correct type and kind. */
2461 if (expr
->ts
.type
!= BT_UNKNOWN
)
2462 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2463 expr
->ts
.type
, expr
->ts
.kind
);
2465 if (specific
->ts
.type
!= BT_UNKNOWN
)
2466 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2467 specific
->ts
.type
, specific
->ts
.kind
);
2469 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
2474 gfc_simplify_min (gfc_expr
*e
)
2476 return simplify_min_max (e
, -1);
2481 gfc_simplify_max (gfc_expr
*e
)
2483 return simplify_min_max (e
, 1);
2488 gfc_simplify_maxexponent (gfc_expr
*x
)
2493 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2495 result
= gfc_int_expr (gfc_real_kinds
[i
].max_exponent
);
2496 result
->where
= x
->where
;
2503 gfc_simplify_minexponent (gfc_expr
*x
)
2508 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2510 result
= gfc_int_expr (gfc_real_kinds
[i
].min_exponent
);
2511 result
->where
= x
->where
;
2518 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
2521 mpfr_t quot
, iquot
, term
;
2524 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2527 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2528 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2533 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2535 /* Result is processor-dependent. */
2536 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
2537 gfc_free_expr (result
);
2538 return &gfc_bad_expr
;
2540 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2544 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2546 /* Result is processor-dependent. */
2547 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
2548 gfc_free_expr (result
);
2549 return &gfc_bad_expr
;
2552 gfc_set_model_kind (kind
);
2557 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2558 mpfr_trunc (iquot
, quot
);
2559 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2560 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2568 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2571 return range_check (result
, "MOD");
2576 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
2579 mpfr_t quot
, iquot
, term
;
2582 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2585 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2586 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2591 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2593 /* Result is processor-dependent. This processor just opts
2594 to not handle it at all. */
2595 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
2596 gfc_free_expr (result
);
2597 return &gfc_bad_expr
;
2599 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2604 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2606 /* Result is processor-dependent. */
2607 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
2608 gfc_free_expr (result
);
2609 return &gfc_bad_expr
;
2612 gfc_set_model_kind (kind
);
2617 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2618 mpfr_floor (iquot
, quot
);
2619 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2620 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2628 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2631 return range_check (result
, "MODULO");
2635 /* Exists for the sole purpose of consistency with other intrinsics. */
2637 gfc_simplify_mvbits (gfc_expr
*f ATTRIBUTE_UNUSED
,
2638 gfc_expr
*fp ATTRIBUTE_UNUSED
,
2639 gfc_expr
*l ATTRIBUTE_UNUSED
,
2640 gfc_expr
*to ATTRIBUTE_UNUSED
,
2641 gfc_expr
*tp ATTRIBUTE_UNUSED
)
2648 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
2654 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
2657 if (mpfr_sgn (s
->value
.real
) == 0)
2659 gfc_error ("Second argument of NEAREST at %L shall not be zero",
2661 return &gfc_bad_expr
;
2664 gfc_set_model_kind (x
->ts
.kind
);
2665 result
= gfc_copy_expr (x
);
2667 sgn
= mpfr_sgn (s
->value
.real
);
2669 mpfr_set_inf (tmp
, sgn
);
2670 mpfr_nexttoward (result
->value
.real
, tmp
);
2673 return range_check (result
, "NEAREST");
2678 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
2680 gfc_expr
*itrunc
, *result
;
2683 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
2685 return &gfc_bad_expr
;
2687 if (e
->expr_type
!= EXPR_CONSTANT
)
2690 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
2692 itrunc
= gfc_copy_expr (e
);
2694 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
2696 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
);
2698 gfc_free_expr (itrunc
);
2700 return range_check (result
, name
);
2705 gfc_simplify_new_line (gfc_expr
*e
)
2709 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
2710 result
->value
.character
.string
= gfc_getmem (2);
2711 result
->value
.character
.length
= 1;
2712 result
->value
.character
.string
[0] = '\n';
2713 result
->value
.character
.string
[1] = '\0'; /* For debugger */
2719 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
2721 return simplify_nint ("NINT", e
, k
);
2726 gfc_simplify_idnint (gfc_expr
*e
)
2728 return simplify_nint ("IDNINT", e
, NULL
);
2733 gfc_simplify_not (gfc_expr
*e
)
2737 if (e
->expr_type
!= EXPR_CONSTANT
)
2740 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2742 mpz_com (result
->value
.integer
, e
->value
.integer
);
2744 return range_check (result
, "NOT");
2749 gfc_simplify_null (gfc_expr
*mold
)
2755 result
= gfc_get_expr ();
2756 result
->ts
.type
= BT_UNKNOWN
;
2759 result
= gfc_copy_expr (mold
);
2760 result
->expr_type
= EXPR_NULL
;
2767 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
2772 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2775 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2776 if (x
->ts
.type
== BT_INTEGER
)
2778 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
2779 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2781 else /* BT_LOGICAL */
2783 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
2784 result
->value
.logical
= x
->value
.logical
|| y
->value
.logical
;
2787 return range_check (result
, "OR");
2792 gfc_simplify_precision (gfc_expr
*e
)
2797 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2799 result
= gfc_int_expr (gfc_real_kinds
[i
].precision
);
2800 result
->where
= e
->where
;
2807 gfc_simplify_radix (gfc_expr
*e
)
2812 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2816 i
= gfc_integer_kinds
[i
].radix
;
2820 i
= gfc_real_kinds
[i
].radix
;
2827 result
= gfc_int_expr (i
);
2828 result
->where
= e
->where
;
2835 gfc_simplify_range (gfc_expr
*e
)
2841 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2846 j
= gfc_integer_kinds
[i
].range
;
2851 j
= gfc_real_kinds
[i
].range
;
2858 result
= gfc_int_expr (j
);
2859 result
->where
= e
->where
;
2866 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
2871 if (e
->ts
.type
== BT_COMPLEX
)
2872 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
2874 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
2877 return &gfc_bad_expr
;
2879 if (e
->expr_type
!= EXPR_CONSTANT
)
2885 result
= gfc_int2real (e
, kind
);
2889 result
= gfc_real2real (e
, kind
);
2893 result
= gfc_complex2real (e
, kind
);
2897 gfc_internal_error ("bad type in REAL");
2901 return range_check (result
, "REAL");
2906 gfc_simplify_realpart (gfc_expr
*e
)
2910 if (e
->expr_type
!= EXPR_CONSTANT
)
2913 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
2914 mpfr_set (result
->value
.real
, e
->value
.complex.r
, GFC_RND_MODE
);
2916 return range_check (result
, "REALPART");
2920 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
2923 int i
, j
, len
, ncop
, nlen
;
2925 bool have_length
= false;
2927 /* If NCOPIES isn't a constant, there's nothing we can do. */
2928 if (n
->expr_type
!= EXPR_CONSTANT
)
2931 /* If NCOPIES is negative, it's an error. */
2932 if (mpz_sgn (n
->value
.integer
) < 0)
2934 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
2936 return &gfc_bad_expr
;
2939 /* If we don't know the character length, we can do no more. */
2940 if (e
->ts
.cl
&& e
->ts
.cl
->length
2941 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2943 len
= mpz_get_si (e
->ts
.cl
->length
->value
.integer
);
2946 else if (e
->expr_type
== EXPR_CONSTANT
2947 && (e
->ts
.cl
== NULL
|| e
->ts
.cl
->length
== NULL
))
2949 len
= e
->value
.character
.length
;
2954 /* If the source length is 0, any value of NCOPIES is valid
2955 and everything behaves as if NCOPIES == 0. */
2958 mpz_set_ui (ncopies
, 0);
2960 mpz_set (ncopies
, n
->value
.integer
);
2962 /* Check that NCOPIES isn't too large. */
2968 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
2970 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
2974 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
2975 e
->ts
.cl
->length
->value
.integer
);
2979 mpz_init_set_si (mlen
, len
);
2980 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
2984 /* The check itself. */
2985 if (mpz_cmp (ncopies
, max
) > 0)
2988 mpz_clear (ncopies
);
2989 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
2991 return &gfc_bad_expr
;
2996 mpz_clear (ncopies
);
2998 /* For further simplification, we need the character string to be
3000 if (e
->expr_type
!= EXPR_CONSTANT
)
3003 if (len
|| mpz_sgn (e
->ts
.cl
->length
->value
.integer
) != 0)
3005 const char *res
= gfc_extract_int (n
, &ncop
);
3006 gcc_assert (res
== NULL
);
3011 len
= e
->value
.character
.length
;
3014 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
3018 result
->value
.character
.string
= gfc_getmem (1);
3019 result
->value
.character
.length
= 0;
3020 result
->value
.character
.string
[0] = '\0';
3024 result
->value
.character
.length
= nlen
;
3025 result
->value
.character
.string
= gfc_getmem (nlen
+ 1);
3027 for (i
= 0; i
< ncop
; i
++)
3028 for (j
= 0; j
< len
; j
++)
3029 result
->value
.character
.string
[j
+ i
* len
]
3030 = e
->value
.character
.string
[j
];
3032 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
3037 /* This one is a bear, but mainly has to do with shuffling elements. */
3040 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
3041 gfc_expr
*pad
, gfc_expr
*order_exp
)
3043 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
3044 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
3045 gfc_constructor
*head
, *tail
;
3051 /* Unpack the shape array. */
3052 if (source
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (source
))
3055 if (shape_exp
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (shape_exp
))
3059 && (pad
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (pad
)))
3062 if (order_exp
!= NULL
3063 && (order_exp
->expr_type
!= EXPR_ARRAY
3064 || !gfc_is_constant_expr (order_exp
)))
3073 e
= gfc_get_array_element (shape_exp
, rank
);
3077 if (gfc_extract_int (e
, &shape
[rank
]) != NULL
)
3079 gfc_error ("Integer too large in shape specification at %L",
3087 if (rank
>= GFC_MAX_DIMENSIONS
)
3089 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3090 "at %L", &e
->where
);
3095 if (shape
[rank
] < 0)
3097 gfc_error ("Shape specification at %L cannot be negative",
3107 gfc_error ("Shape specification at %L cannot be the null array",
3112 /* Now unpack the order array if present. */
3113 if (order_exp
== NULL
)
3115 for (i
= 0; i
< rank
; i
++)
3120 for (i
= 0; i
< rank
; i
++)
3123 for (i
= 0; i
< rank
; i
++)
3125 e
= gfc_get_array_element (order_exp
, i
);
3128 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3129 "size as SHAPE parameter", &order_exp
->where
);
3133 if (gfc_extract_int (e
, &order
[i
]) != NULL
)
3135 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3143 if (order
[i
] < 1 || order
[i
] > rank
)
3145 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3154 gfc_error ("Invalid permutation in ORDER parameter at %L",
3163 /* Count the elements in the source and padding arrays. */
3168 gfc_array_size (pad
, &size
);
3169 npad
= mpz_get_ui (size
);
3173 gfc_array_size (source
, &size
);
3174 nsource
= mpz_get_ui (size
);
3177 /* If it weren't for that pesky permutation we could just loop
3178 through the source and round out any shortage with pad elements.
3179 But no, someone just had to have the compiler do something the
3180 user should be doing. */
3182 for (i
= 0; i
< rank
; i
++)
3187 /* Figure out which element to extract. */
3188 mpz_set_ui (index
, 0);
3190 for (i
= rank
- 1; i
>= 0; i
--)
3192 mpz_add_ui (index
, index
, x
[order
[i
]]);
3194 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
3197 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
3198 gfc_internal_error ("Reshaped array too large at %L", &e
->where
);
3200 j
= mpz_get_ui (index
);
3203 e
= gfc_get_array_element (source
, j
);
3210 gfc_error ("PAD parameter required for short SOURCE parameter "
3211 "at %L", &source
->where
);
3216 e
= gfc_get_array_element (pad
, j
);
3220 head
= tail
= gfc_get_constructor ();
3223 tail
->next
= gfc_get_constructor ();
3230 tail
->where
= e
->where
;
3233 /* Calculate the next element. */
3237 if (++x
[i
] < shape
[i
])
3248 e
= gfc_get_expr ();
3249 e
->where
= source
->where
;
3250 e
->expr_type
= EXPR_ARRAY
;
3251 e
->value
.constructor
= head
;
3252 e
->shape
= gfc_get_shape (rank
);
3254 for (i
= 0; i
< rank
; i
++)
3255 mpz_init_set_ui (e
->shape
[i
], shape
[i
]);
3263 gfc_free_constructor (head
);
3265 return &gfc_bad_expr
;
3270 gfc_simplify_rrspacing (gfc_expr
*x
)
3276 if (x
->expr_type
!= EXPR_CONSTANT
)
3279 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3281 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3283 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3285 /* Special case x = -0 and 0. */
3286 if (mpfr_sgn (result
->value
.real
) == 0)
3288 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3292 /* | x * 2**(-e) | * 2**p. */
3293 e
= - (long int) mpfr_get_exp (x
->value
.real
);
3294 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
3296 p
= (long int) gfc_real_kinds
[i
].digits
;
3297 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
3299 return range_check (result
, "RRSPACING");
3304 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
3306 int k
, neg_flag
, power
, exp_range
;
3307 mpfr_t scale
, radix
;
3310 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3313 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3315 if (mpfr_sgn (x
->value
.real
) == 0)
3317 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3321 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3323 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
3325 /* This check filters out values of i that would overflow an int. */
3326 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
3327 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
3329 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
3330 return &gfc_bad_expr
;
3333 /* Compute scale = radix ** power. */
3334 power
= mpz_get_si (i
->value
.integer
);
3344 gfc_set_model_kind (x
->ts
.kind
);
3347 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
3348 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
3351 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3353 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3358 return range_check (result
, "SCALE");
3363 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
3368 size_t indx
, len
, lenc
;
3369 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
3372 return &gfc_bad_expr
;
3374 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
)
3377 if (b
!= NULL
&& b
->value
.logical
!= 0)
3382 result
= gfc_constant_result (BT_INTEGER
, k
, &e
->where
);
3384 len
= e
->value
.character
.length
;
3385 lenc
= c
->value
.character
.length
;
3387 if (len
== 0 || lenc
== 0)
3395 indx
= strcspn (e
->value
.character
.string
, c
->value
.character
.string
)
3403 for (indx
= len
; indx
> 0; indx
--)
3405 for (i
= 0; i
< lenc
; i
++)
3407 if (c
->value
.character
.string
[i
]
3408 == e
->value
.character
.string
[indx
- 1])
3416 mpz_set_ui (result
->value
.integer
, indx
);
3417 return range_check (result
, "SCAN");
3422 gfc_simplify_selected_int_kind (gfc_expr
*e
)
3427 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
3432 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
3433 if (gfc_integer_kinds
[i
].range
>= range
3434 && gfc_integer_kinds
[i
].kind
< kind
)
3435 kind
= gfc_integer_kinds
[i
].kind
;
3437 if (kind
== INT_MAX
)
3440 result
= gfc_int_expr (kind
);
3441 result
->where
= e
->where
;
3448 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
)
3450 int range
, precision
, i
, kind
, found_precision
, found_range
;
3457 if (p
->expr_type
!= EXPR_CONSTANT
3458 || gfc_extract_int (p
, &precision
) != NULL
)
3466 if (q
->expr_type
!= EXPR_CONSTANT
3467 || gfc_extract_int (q
, &range
) != NULL
)
3472 found_precision
= 0;
3475 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
3477 if (gfc_real_kinds
[i
].precision
>= precision
)
3478 found_precision
= 1;
3480 if (gfc_real_kinds
[i
].range
>= range
)
3483 if (gfc_real_kinds
[i
].precision
>= precision
3484 && gfc_real_kinds
[i
].range
>= range
&& gfc_real_kinds
[i
].kind
< kind
)
3485 kind
= gfc_real_kinds
[i
].kind
;
3488 if (kind
== INT_MAX
)
3492 if (!found_precision
)
3498 result
= gfc_int_expr (kind
);
3499 result
->where
= (p
!= NULL
) ? p
->where
: q
->where
;
3506 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
3509 mpfr_t exp
, absv
, log2
, pow2
, frac
;
3512 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3515 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3517 gfc_set_model_kind (x
->ts
.kind
);
3519 if (mpfr_sgn (x
->value
.real
) == 0)
3521 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3531 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3532 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3534 mpfr_trunc (log2
, log2
);
3535 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
3537 /* Old exponent value, and fraction. */
3538 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3540 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
3543 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
3544 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
3551 return range_check (result
, "SET_EXPONENT");
3556 gfc_simplify_shape (gfc_expr
*source
)
3558 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3559 gfc_expr
*result
, *e
, *f
;
3564 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3567 result
= gfc_start_constructor (BT_INTEGER
, gfc_default_integer_kind
,
3570 ar
= gfc_find_array_ref (source
);
3572 t
= gfc_array_ref_shape (ar
, shape
);
3574 for (n
= 0; n
< source
->rank
; n
++)
3576 e
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3581 mpz_set (e
->value
.integer
, shape
[n
]);
3582 mpz_clear (shape
[n
]);
3586 mpz_set_ui (e
->value
.integer
, n
+ 1);
3588 f
= gfc_simplify_size (source
, e
, NULL
);
3592 gfc_free_expr (result
);
3601 gfc_append_constructor (result
, e
);
3609 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3614 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
3617 return &gfc_bad_expr
;
3621 if (gfc_array_size (array
, &size
) == FAILURE
)
3626 if (dim
->expr_type
!= EXPR_CONSTANT
)
3629 d
= mpz_get_ui (dim
->value
.integer
) - 1;
3630 if (gfc_array_dimen_size (array
, d
, &size
) == FAILURE
)
3634 result
= gfc_constant_result (BT_INTEGER
, k
, &array
->where
);
3635 mpz_set (result
->value
.integer
, size
);
3641 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
3645 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3648 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3653 mpz_abs (result
->value
.integer
, x
->value
.integer
);
3654 if (mpz_sgn (y
->value
.integer
) < 0)
3655 mpz_neg (result
->value
.integer
, result
->value
.integer
);
3660 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3662 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3663 if (mpfr_sgn (y
->value
.real
) < 0)
3664 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
3669 gfc_internal_error ("Bad type in gfc_simplify_sign");
3677 gfc_simplify_sin (gfc_expr
*x
)
3682 if (x
->expr_type
!= EXPR_CONSTANT
)
3685 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3690 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3694 gfc_set_model (x
->value
.real
);
3698 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3699 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3700 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
3702 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3703 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3704 mpfr_mul (result
->value
.complex.i
, xp
, xq
, GFC_RND_MODE
);
3711 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3714 return range_check (result
, "SIN");
3719 gfc_simplify_sinh (gfc_expr
*x
)
3723 if (x
->expr_type
!= EXPR_CONSTANT
)
3726 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3728 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3730 return range_check (result
, "SINH");
3734 /* The argument is always a double precision real that is converted to
3735 single precision. TODO: Rounding! */
3738 gfc_simplify_sngl (gfc_expr
*a
)
3742 if (a
->expr_type
!= EXPR_CONSTANT
)
3745 result
= gfc_real2real (a
, gfc_default_real_kind
);
3746 return range_check (result
, "SNGL");
3751 gfc_simplify_spacing (gfc_expr
*x
)
3757 if (x
->expr_type
!= EXPR_CONSTANT
)
3760 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3762 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3764 /* Special case x = 0 and -0. */
3765 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3766 if (mpfr_sgn (result
->value
.real
) == 0)
3768 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3772 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3773 are the radix, exponent of x, and precision. This excludes the
3774 possibility of subnormal numbers. Fortran 2003 states the result is
3775 b**max(e - p, emin - 1). */
3777 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
3778 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
3779 en
= en
> ep
? en
: ep
;
3781 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
3782 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
3784 return range_check (result
, "SPACING");
3789 gfc_simplify_sqrt (gfc_expr
*e
)
3792 mpfr_t ac
, ad
, s
, t
, w
;
3794 if (e
->expr_type
!= EXPR_CONSTANT
)
3797 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3802 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
3804 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
3809 /* Formula taken from Numerical Recipes to avoid over- and
3812 gfc_set_model (e
->value
.real
);
3819 if (mpfr_cmp_ui (e
->value
.complex.r
, 0) == 0
3820 && mpfr_cmp_ui (e
->value
.complex.i
, 0) == 0)
3822 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
3823 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
3827 mpfr_abs (ac
, e
->value
.complex.r
, GFC_RND_MODE
);
3828 mpfr_abs (ad
, e
->value
.complex.i
, GFC_RND_MODE
);
3830 if (mpfr_cmp (ac
, ad
) >= 0)
3832 mpfr_div (t
, e
->value
.complex.i
, e
->value
.complex.r
, GFC_RND_MODE
);
3833 mpfr_mul (t
, t
, t
, GFC_RND_MODE
);
3834 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3835 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3836 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3837 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3838 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3839 mpfr_sqrt (s
, ac
, GFC_RND_MODE
);
3840 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3844 mpfr_div (s
, e
->value
.complex.r
, e
->value
.complex.i
, GFC_RND_MODE
);
3845 mpfr_mul (t
, s
, s
, GFC_RND_MODE
);
3846 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3847 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3848 mpfr_abs (s
, s
, GFC_RND_MODE
);
3849 mpfr_add (t
, t
, s
, GFC_RND_MODE
);
3850 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3851 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3852 mpfr_sqrt (s
, ad
, GFC_RND_MODE
);
3853 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3856 if (mpfr_cmp_ui (w
, 0) != 0 && mpfr_cmp_ui (e
->value
.complex.r
, 0) >= 0)
3858 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3859 mpfr_div (result
->value
.complex.i
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3860 mpfr_set (result
->value
.complex.r
, w
, GFC_RND_MODE
);
3862 else if (mpfr_cmp_ui (w
, 0) != 0
3863 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3864 && mpfr_cmp_ui (e
->value
.complex.i
, 0) >= 0)
3866 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3867 mpfr_div (result
->value
.complex.r
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3868 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3870 else if (mpfr_cmp_ui (w
, 0) != 0
3871 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3872 && mpfr_cmp_ui (e
->value
.complex.i
, 0) < 0)
3874 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3875 mpfr_div (result
->value
.complex.r
, ad
, t
, GFC_RND_MODE
);
3876 mpfr_neg (w
, w
, GFC_RND_MODE
);
3877 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3880 gfc_internal_error ("invalid complex argument of SQRT at %L",
3892 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
3895 return range_check (result
, "SQRT");
3898 gfc_free_expr (result
);
3899 gfc_error ("Argument of SQRT at %L has a negative value", &e
->where
);
3900 return &gfc_bad_expr
;
3905 gfc_simplify_tan (gfc_expr
*x
)
3910 if (x
->expr_type
!= EXPR_CONSTANT
)
3913 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3915 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3917 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3919 return range_check (result
, "TAN");
3924 gfc_simplify_tanh (gfc_expr
*x
)
3928 if (x
->expr_type
!= EXPR_CONSTANT
)
3931 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3933 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3935 return range_check (result
, "TANH");
3941 gfc_simplify_tiny (gfc_expr
*e
)
3946 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
3948 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
3949 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3956 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
3959 gfc_expr
*mold_element
;
3962 size_t result_elt_size
;
3965 unsigned char *buffer
;
3967 if (!gfc_is_constant_expr (source
)
3968 || !gfc_is_constant_expr (size
))
3971 /* Calculate the size of the source. */
3972 if (source
->expr_type
== EXPR_ARRAY
3973 && gfc_array_size (source
, &tmp
) == FAILURE
)
3974 gfc_internal_error ("Failure getting length of a constant array.");
3976 source_size
= gfc_target_expr_size (source
);
3978 /* Create an empty new expression with the appropriate characteristics. */
3979 result
= gfc_constant_result (mold
->ts
.type
, mold
->ts
.kind
,
3981 result
->ts
= mold
->ts
;
3983 mold_element
= mold
->expr_type
== EXPR_ARRAY
3984 ? mold
->value
.constructor
->expr
3987 /* Set result character length, if needed. Note that this needs to be
3988 set even for array expressions, in order to pass this information into
3989 gfc_target_interpret_expr. */
3990 if (result
->ts
.type
== BT_CHARACTER
)
3991 result
->value
.character
.length
= mold_element
->value
.character
.length
;
3993 /* Set the number of elements in the result, and determine its size. */
3994 result_elt_size
= gfc_target_expr_size (mold_element
);
3995 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
3999 result
->expr_type
= EXPR_ARRAY
;
4003 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
4006 result_length
= source_size
/ result_elt_size
;
4007 if (result_length
* result_elt_size
< source_size
)
4011 result
->shape
= gfc_get_shape (1);
4012 mpz_init_set_ui (result
->shape
[0], result_length
);
4014 result_size
= result_length
* result_elt_size
;
4019 result_size
= result_elt_size
;
4022 /* Allocate the buffer to store the binary version of the source. */
4023 buffer_size
= MAX (source_size
, result_size
);
4024 buffer
= (unsigned char*)alloca (buffer_size
);
4026 /* Now write source to the buffer. */
4027 gfc_target_encode_expr (source
, buffer
, buffer_size
);
4029 /* And read the buffer back into the new expression. */
4030 gfc_target_interpret_expr (buffer
, buffer_size
, result
);
4037 gfc_simplify_trim (gfc_expr
*e
)
4040 int count
, i
, len
, lentrim
;
4042 if (e
->expr_type
!= EXPR_CONSTANT
)
4045 len
= e
->value
.character
.length
;
4047 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
4049 for (count
= 0, i
= 1; i
<= len
; ++i
)
4051 if (e
->value
.character
.string
[len
- i
] == ' ')
4057 lentrim
= len
- count
;
4059 result
->value
.character
.length
= lentrim
;
4060 result
->value
.character
.string
= gfc_getmem (lentrim
+ 1);
4062 for (i
= 0; i
< lentrim
; i
++)
4063 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
4065 result
->value
.character
.string
[lentrim
] = '\0'; /* For debugger */
4072 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4074 return simplify_bound (array
, dim
, kind
, 1);
4079 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
4083 size_t index
, len
, lenset
;
4085 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
4088 return &gfc_bad_expr
;
4090 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
)
4093 if (b
!= NULL
&& b
->value
.logical
!= 0)
4098 result
= gfc_constant_result (BT_INTEGER
, k
, &s
->where
);
4100 len
= s
->value
.character
.length
;
4101 lenset
= set
->value
.character
.length
;
4105 mpz_set_ui (result
->value
.integer
, 0);
4113 mpz_set_ui (result
->value
.integer
, 1);
4117 index
= strspn (s
->value
.character
.string
, set
->value
.character
.string
)
4127 mpz_set_ui (result
->value
.integer
, len
);
4130 for (index
= len
; index
> 0; index
--)
4132 for (i
= 0; i
< lenset
; i
++)
4134 if (s
->value
.character
.string
[index
- 1]
4135 == set
->value
.character
.string
[i
])
4143 mpz_set_ui (result
->value
.integer
, index
);
4149 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
4154 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4157 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4158 if (x
->ts
.type
== BT_INTEGER
)
4160 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
4161 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4163 else /* BT_LOGICAL */
4165 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
4166 result
->value
.logical
= (x
->value
.logical
&& !y
->value
.logical
)
4167 || (!x
->value
.logical
&& y
->value
.logical
);
4170 return range_check (result
, "XOR");
4174 /****************** Constant simplification *****************/
4176 /* Master function to convert one constant to another. While this is
4177 used as a simplification function, it requires the destination type
4178 and kind information which is supplied by a special case in
4182 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
4184 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
4185 gfc_constructor
*head
, *c
, *tail
= NULL
;
4199 f
= gfc_int2complex
;
4219 f
= gfc_real2complex
;
4230 f
= gfc_complex2int
;
4233 f
= gfc_complex2real
;
4236 f
= gfc_complex2complex
;
4262 f
= gfc_hollerith2int
;
4266 f
= gfc_hollerith2real
;
4270 f
= gfc_hollerith2complex
;
4274 f
= gfc_hollerith2character
;
4278 f
= gfc_hollerith2logical
;
4288 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4293 switch (e
->expr_type
)
4296 result
= f (e
, kind
);
4298 return &gfc_bad_expr
;
4302 if (!gfc_is_constant_expr (e
))
4307 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
4310 head
= tail
= gfc_get_constructor ();
4313 tail
->next
= gfc_get_constructor ();
4317 tail
->where
= c
->where
;
4319 if (c
->iterator
== NULL
)
4320 tail
->expr
= f (c
->expr
, kind
);
4323 g
= gfc_convert_constant (c
->expr
, type
, kind
);
4324 if (g
== &gfc_bad_expr
)
4329 if (tail
->expr
== NULL
)
4331 gfc_free_constructor (head
);
4336 result
= gfc_get_expr ();
4337 result
->ts
.type
= type
;
4338 result
->ts
.kind
= kind
;
4339 result
->expr_type
= EXPR_ARRAY
;
4340 result
->value
.constructor
= head
;
4341 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4342 result
->where
= e
->where
;
4343 result
->rank
= e
->rank
;