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 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
28 #include "intrinsic.h"
30 gfc_expr gfc_bad_expr
;
33 /* Note that 'simplification' is not just transforming expressions.
34 For functions that are not simplified at compile time, range
35 checking is done if possible.
37 The return convention is that each simplification function returns:
39 A new expression node corresponding to the simplified arguments.
40 The original arguments are destroyed by the caller, and must not
41 be a part of the new expression.
43 NULL pointer indicating that no simplification was possible and
44 the original expression should remain intact. If the
45 simplification function sets the type and/or the function name
46 via the pointer gfc_simple_expression, then this type is
49 An expression pointer to gfc_bad_expr (a static placeholder)
50 indicating that some error has prevented simplification. For
51 example, sqrt(-1.0). The error is generated within the function
52 and should be propagated upwards
54 By the time a simplification function gets control, it has been
55 decided that the function call is really supposed to be the
56 intrinsic. No type checking is strictly necessary, since only
57 valid types will be passed on. On the other hand, a simplification
58 subroutine may have to look at the type of an argument as part of
61 Array arguments are never passed to these subroutines.
63 The functions in this file don't have much comment with them, but
64 everything is reasonably straight-forward. The Standard, chapter 13
65 is the best comment you'll find for this file anyway. */
67 /* 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
);
122 if (gfc_extract_int (k
, &kind
) != NULL
123 || gfc_validate_kind (type
, kind
, true) < 0)
126 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
134 /* Converts an mpz_t signed variable into an unsigned one, assuming
135 two's complement representations and a binary width of bitsize.
136 The conversion is a no-op unless x is negative; otherwise, it can
137 be accomplished by masking out the high bits. */
140 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
146 /* Confirm that no bits above the signed range are unset. */
147 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
149 mpz_init_set_ui (mask
, 1);
150 mpz_mul_2exp (mask
, mask
, bitsize
);
151 mpz_sub_ui (mask
, mask
, 1);
153 mpz_and (x
, x
, mask
);
159 /* Confirm that no bits above the signed range are set. */
160 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
165 /* Converts an mpz_t unsigned variable into a signed one, assuming
166 two's complement representations and a binary width of bitsize.
167 If the bitsize-1 bit is set, this is taken as a sign bit and
168 the number is converted to the corresponding negative number. */
171 convert_mpz_to_signed (mpz_t x
, int bitsize
)
175 /* Confirm that no bits above the unsigned range are set. */
176 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
178 if (mpz_tstbit (x
, bitsize
- 1) == 1)
180 mpz_init_set_ui (mask
, 1);
181 mpz_mul_2exp (mask
, mask
, bitsize
);
182 mpz_sub_ui (mask
, mask
, 1);
184 /* We negate the number by hand, zeroing the high bits, that is
185 make it the corresponding positive number, and then have it
186 negated by GMP, giving the correct representation of the
189 mpz_add_ui (x
, x
, 1);
190 mpz_and (x
, x
, mask
);
199 /********************** Simplification functions *****************************/
202 gfc_simplify_abs (gfc_expr
*e
)
206 if (e
->expr_type
!= EXPR_CONSTANT
)
212 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
214 mpz_abs (result
->value
.integer
, e
->value
.integer
);
216 result
= range_check (result
, "IABS");
220 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
222 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
224 result
= range_check (result
, "ABS");
228 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
230 gfc_set_model_kind (e
->ts
.kind
);
232 mpfr_hypot (result
->value
.real
, e
->value
.complex.r
,
233 e
->value
.complex.i
, GFC_RND_MODE
);
234 result
= range_check (result
, "CABS");
238 gfc_internal_error ("gfc_simplify_abs(): Bad type");
244 /* We use the processor's collating sequence, because all
245 systems that gfortran currently works on are ASCII. */
248 gfc_simplify_achar (gfc_expr
*e
)
254 if (e
->expr_type
!= EXPR_CONSTANT
)
257 ch
= gfc_extract_int (e
, &c
);
260 gfc_internal_error ("gfc_simplify_achar: %s", ch
);
262 if (gfc_option
.warn_surprising
&& (c
< 0 || c
> 127))
263 gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
266 result
= gfc_constant_result (BT_CHARACTER
, gfc_default_character_kind
,
269 result
->value
.character
.string
= gfc_getmem (2);
271 result
->value
.character
.length
= 1;
272 result
->value
.character
.string
[0] = c
;
273 result
->value
.character
.string
[1] = '\0'; /* For debugger */
279 gfc_simplify_acos (gfc_expr
*x
)
283 if (x
->expr_type
!= EXPR_CONSTANT
)
286 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
287 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
289 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
291 return &gfc_bad_expr
;
294 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
296 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
298 return range_check (result
, "ACOS");
302 gfc_simplify_acosh (gfc_expr
*x
)
306 if (x
->expr_type
!= EXPR_CONSTANT
)
309 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
311 gfc_error ("Argument of ACOSH at %L must not be less than 1",
313 return &gfc_bad_expr
;
316 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
318 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
320 return range_check (result
, "ACOSH");
324 gfc_simplify_adjustl (gfc_expr
*e
)
330 if (e
->expr_type
!= EXPR_CONSTANT
)
333 len
= e
->value
.character
.length
;
335 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
337 result
->value
.character
.length
= len
;
338 result
->value
.character
.string
= gfc_getmem (len
+ 1);
340 for (count
= 0, i
= 0; i
< len
; ++i
)
342 ch
= e
->value
.character
.string
[i
];
348 for (i
= 0; i
< len
- count
; ++i
)
349 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
351 for (i
= len
- count
; i
< len
; ++i
)
352 result
->value
.character
.string
[i
] = ' ';
354 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
361 gfc_simplify_adjustr (gfc_expr
*e
)
367 if (e
->expr_type
!= EXPR_CONSTANT
)
370 len
= e
->value
.character
.length
;
372 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
374 result
->value
.character
.length
= len
;
375 result
->value
.character
.string
= gfc_getmem (len
+ 1);
377 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
379 ch
= e
->value
.character
.string
[i
];
385 for (i
= 0; i
< count
; ++i
)
386 result
->value
.character
.string
[i
] = ' ';
388 for (i
= count
; i
< len
; ++i
)
389 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
391 result
->value
.character
.string
[len
] = '\0'; /* For debugger */
398 gfc_simplify_aimag (gfc_expr
*e
)
402 if (e
->expr_type
!= EXPR_CONSTANT
)
405 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
406 mpfr_set (result
->value
.real
, e
->value
.complex.i
, GFC_RND_MODE
);
408 return range_check (result
, "AIMAG");
413 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
415 gfc_expr
*rtrunc
, *result
;
418 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
420 return &gfc_bad_expr
;
422 if (e
->expr_type
!= EXPR_CONSTANT
)
425 rtrunc
= gfc_copy_expr (e
);
427 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
429 result
= gfc_real2real (rtrunc
, kind
);
430 gfc_free_expr (rtrunc
);
432 return range_check (result
, "AINT");
437 gfc_simplify_dint (gfc_expr
*e
)
439 gfc_expr
*rtrunc
, *result
;
441 if (e
->expr_type
!= EXPR_CONSTANT
)
444 rtrunc
= gfc_copy_expr (e
);
446 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
448 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
449 gfc_free_expr (rtrunc
);
451 return range_check (result
, "DINT");
456 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
461 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
463 return &gfc_bad_expr
;
465 if (e
->expr_type
!= EXPR_CONSTANT
)
468 result
= gfc_constant_result (e
->ts
.type
, kind
, &e
->where
);
470 mpfr_round (result
->value
.real
, e
->value
.real
);
472 return range_check (result
, "ANINT");
477 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
482 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
485 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
486 if (x
->ts
.type
== BT_INTEGER
)
488 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
489 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
491 else /* BT_LOGICAL */
493 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
494 result
->value
.logical
= x
->value
.logical
&& y
->value
.logical
;
497 return range_check (result
, "AND");
502 gfc_simplify_dnint (gfc_expr
*e
)
506 if (e
->expr_type
!= EXPR_CONSTANT
)
509 result
= gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &e
->where
);
511 mpfr_round (result
->value
.real
, e
->value
.real
);
513 return range_check (result
, "DNINT");
518 gfc_simplify_asin (gfc_expr
*x
)
522 if (x
->expr_type
!= EXPR_CONSTANT
)
525 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
526 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
528 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
530 return &gfc_bad_expr
;
533 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
535 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
537 return range_check (result
, "ASIN");
542 gfc_simplify_asinh (gfc_expr
*x
)
546 if (x
->expr_type
!= EXPR_CONSTANT
)
549 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
551 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
553 return range_check (result
, "ASINH");
558 gfc_simplify_atan (gfc_expr
*x
)
562 if (x
->expr_type
!= EXPR_CONSTANT
)
565 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
567 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
569 return range_check (result
, "ATAN");
574 gfc_simplify_atanh (gfc_expr
*x
)
578 if (x
->expr_type
!= EXPR_CONSTANT
)
581 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
582 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
584 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
586 return &gfc_bad_expr
;
589 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
591 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
593 return range_check (result
, "ATANH");
598 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
602 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
605 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
607 if (mpfr_sgn (y
->value
.real
) == 0 && mpfr_sgn (x
->value
.real
) == 0)
609 gfc_error ("If first argument of ATAN2 %L is zero, then the "
610 "second argument must not be zero", &x
->where
);
611 gfc_free_expr (result
);
612 return &gfc_bad_expr
;
615 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
617 return range_check (result
, "ATAN2");
622 gfc_simplify_bit_size (gfc_expr
*e
)
627 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
628 result
= gfc_constant_result (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
629 mpz_set_ui (result
->value
.integer
, gfc_integer_kinds
[i
].bit_size
);
636 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
640 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
643 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
644 return gfc_logical_expr (0, &e
->where
);
646 return gfc_logical_expr (mpz_tstbit (e
->value
.integer
, b
), &e
->where
);
651 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
653 gfc_expr
*ceil
, *result
;
656 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
658 return &gfc_bad_expr
;
660 if (e
->expr_type
!= EXPR_CONSTANT
)
663 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
665 ceil
= gfc_copy_expr (e
);
667 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
668 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
);
670 gfc_free_expr (ceil
);
672 return range_check (result
, "CEILING");
677 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
683 kind
= get_kind (BT_CHARACTER
, k
, "CHAR", gfc_default_character_kind
);
685 return &gfc_bad_expr
;
687 if (e
->expr_type
!= EXPR_CONSTANT
)
690 ch
= gfc_extract_int (e
, &c
);
693 gfc_internal_error ("gfc_simplify_char: %s", ch
);
695 if (c
< 0 || c
> UCHAR_MAX
)
696 gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
699 result
= gfc_constant_result (BT_CHARACTER
, kind
, &e
->where
);
701 result
->value
.character
.length
= 1;
702 result
->value
.character
.string
= gfc_getmem (2);
704 result
->value
.character
.string
[0] = c
;
705 result
->value
.character
.string
[1] = '\0'; /* For debugger */
711 /* Common subroutine for simplifying CMPLX and DCMPLX. */
714 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
718 result
= gfc_constant_result (BT_COMPLEX
, kind
, &x
->where
);
720 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
725 mpfr_set_z (result
->value
.complex.r
, x
->value
.integer
, GFC_RND_MODE
);
729 mpfr_set (result
->value
.complex.r
, x
->value
.real
, GFC_RND_MODE
);
733 mpfr_set (result
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
734 mpfr_set (result
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
738 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
746 mpfr_set_z (result
->value
.complex.i
, y
->value
.integer
, GFC_RND_MODE
);
750 mpfr_set (result
->value
.complex.i
, y
->value
.real
, GFC_RND_MODE
);
754 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
758 return range_check (result
, name
);
763 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
767 if (x
->expr_type
!= EXPR_CONSTANT
768 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
771 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_real_kind
);
773 return &gfc_bad_expr
;
775 return simplify_cmplx ("CMPLX", x
, y
, kind
);
780 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
784 if (x
->expr_type
!= EXPR_CONSTANT
785 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
788 if (x
->ts
.type
== BT_INTEGER
)
790 if (y
->ts
.type
== BT_INTEGER
)
791 kind
= gfc_default_real_kind
;
797 if (y
->ts
.type
== BT_REAL
)
798 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
803 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
808 gfc_simplify_conjg (gfc_expr
*e
)
812 if (e
->expr_type
!= EXPR_CONSTANT
)
815 result
= gfc_copy_expr (e
);
816 mpfr_neg (result
->value
.complex.i
, result
->value
.complex.i
, GFC_RND_MODE
);
818 return range_check (result
, "CONJG");
823 gfc_simplify_cos (gfc_expr
*x
)
828 if (x
->expr_type
!= EXPR_CONSTANT
)
831 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
836 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
839 gfc_set_model_kind (x
->ts
.kind
);
843 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
844 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
845 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
847 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
848 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
849 mpfr_mul (xp
, xp
, xq
, GFC_RND_MODE
);
850 mpfr_neg (result
->value
.complex.i
, xp
, GFC_RND_MODE
);
856 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
859 return range_check (result
, "COS");
865 gfc_simplify_cosh (gfc_expr
*x
)
869 if (x
->expr_type
!= EXPR_CONSTANT
)
872 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
874 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
876 return range_check (result
, "COSH");
881 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
884 if (x
->expr_type
!= EXPR_CONSTANT
885 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
888 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
893 gfc_simplify_dble (gfc_expr
*e
)
897 if (e
->expr_type
!= EXPR_CONSTANT
)
903 result
= gfc_int2real (e
, gfc_default_double_kind
);
907 result
= gfc_real2real (e
, gfc_default_double_kind
);
911 result
= gfc_complex2real (e
, gfc_default_double_kind
);
915 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e
->where
);
918 return range_check (result
, "DBLE");
923 gfc_simplify_digits (gfc_expr
*x
)
927 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
931 digits
= gfc_integer_kinds
[i
].digits
;
936 digits
= gfc_real_kinds
[i
].digits
;
943 return gfc_int_expr (digits
);
948 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
953 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
956 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
957 result
= gfc_constant_result (x
->ts
.type
, kind
, &x
->where
);
962 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
963 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
965 mpz_set_ui (result
->value
.integer
, 0);
970 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
971 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
974 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
979 gfc_internal_error ("gfc_simplify_dim(): Bad type");
982 return range_check (result
, "DIM");
987 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
989 gfc_expr
*a1
, *a2
, *result
;
991 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
994 result
= gfc_constant_result (BT_REAL
, gfc_default_double_kind
, &x
->where
);
996 a1
= gfc_real2real (x
, gfc_default_double_kind
);
997 a2
= gfc_real2real (y
, gfc_default_double_kind
);
999 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
1004 return range_check (result
, "DPROD");
1009 gfc_simplify_epsilon (gfc_expr
*e
)
1014 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1016 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
1018 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
1020 return range_check (result
, "EPSILON");
1025 gfc_simplify_exp (gfc_expr
*x
)
1030 if (x
->expr_type
!= EXPR_CONSTANT
)
1033 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1038 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1042 gfc_set_model_kind (x
->ts
.kind
);
1045 mpfr_exp (xq
, x
->value
.complex.r
, GFC_RND_MODE
);
1046 mpfr_cos (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
1047 mpfr_mul (result
->value
.complex.r
, xq
, xp
, GFC_RND_MODE
);
1048 mpfr_sin (xp
, x
->value
.complex.i
, GFC_RND_MODE
);
1049 mpfr_mul (result
->value
.complex.i
, xq
, xp
, GFC_RND_MODE
);
1055 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1058 return range_check (result
, "EXP");
1062 gfc_simplify_exponent (gfc_expr
*x
)
1067 if (x
->expr_type
!= EXPR_CONSTANT
)
1070 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1073 gfc_set_model (x
->value
.real
);
1075 if (mpfr_sgn (x
->value
.real
) == 0)
1077 mpz_set_ui (result
->value
.integer
, 0);
1081 i
= (int) mpfr_get_exp (x
->value
.real
);
1082 mpz_set_si (result
->value
.integer
, i
);
1084 return range_check (result
, "EXPONENT");
1089 gfc_simplify_float (gfc_expr
*a
)
1093 if (a
->expr_type
!= EXPR_CONSTANT
)
1096 result
= gfc_int2real (a
, gfc_default_real_kind
);
1097 return range_check (result
, "FLOAT");
1102 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
1108 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
1110 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1112 if (e
->expr_type
!= EXPR_CONSTANT
)
1115 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1117 gfc_set_model_kind (kind
);
1119 mpfr_floor (floor
, e
->value
.real
);
1121 gfc_mpfr_to_mpz (result
->value
.integer
, floor
);
1125 return range_check (result
, "FLOOR");
1130 gfc_simplify_fraction (gfc_expr
*x
)
1133 mpfr_t absv
, exp
, pow2
;
1135 if (x
->expr_type
!= EXPR_CONSTANT
)
1138 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
1140 gfc_set_model_kind (x
->ts
.kind
);
1142 if (mpfr_sgn (x
->value
.real
) == 0)
1144 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1152 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
1153 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
1155 mpfr_trunc (exp
, exp
);
1156 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
1158 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
1160 mpfr_div (result
->value
.real
, absv
, pow2
, GFC_RND_MODE
);
1166 return range_check (result
, "FRACTION");
1171 gfc_simplify_huge (gfc_expr
*e
)
1176 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1178 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1183 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
1187 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
1197 /* We use the processor's collating sequence, because all
1198 systems that gfortran currently works on are ASCII. */
1201 gfc_simplify_iachar (gfc_expr
*e
)
1206 if (e
->expr_type
!= EXPR_CONSTANT
)
1209 if (e
->value
.character
.length
!= 1)
1211 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
1212 return &gfc_bad_expr
;
1215 index
= (unsigned char) e
->value
.character
.string
[0];
1217 if (gfc_option
.warn_surprising
&& index
> 127)
1218 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1221 result
= gfc_int_expr (index
);
1222 result
->where
= e
->where
;
1224 return range_check (result
, "IACHAR");
1229 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
1233 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1236 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1238 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1240 return range_check (result
, "IAND");
1245 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
1250 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1253 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1255 gfc_error ("Invalid second argument of IBCLR at %L", &y
->where
);
1256 return &gfc_bad_expr
;
1259 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1261 if (pos
>= gfc_integer_kinds
[k
].bit_size
)
1263 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1265 return &gfc_bad_expr
;
1268 result
= gfc_copy_expr (x
);
1270 convert_mpz_to_unsigned (result
->value
.integer
,
1271 gfc_integer_kinds
[k
].bit_size
);
1273 mpz_clrbit (result
->value
.integer
, pos
);
1275 convert_mpz_to_signed (result
->value
.integer
,
1276 gfc_integer_kinds
[k
].bit_size
);
1278 return range_check (result
, "IBCLR");
1283 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
1290 if (x
->expr_type
!= EXPR_CONSTANT
1291 || y
->expr_type
!= EXPR_CONSTANT
1292 || z
->expr_type
!= EXPR_CONSTANT
)
1295 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1297 gfc_error ("Invalid second argument of IBITS at %L", &y
->where
);
1298 return &gfc_bad_expr
;
1301 if (gfc_extract_int (z
, &len
) != NULL
|| len
< 0)
1303 gfc_error ("Invalid third argument of IBITS at %L", &z
->where
);
1304 return &gfc_bad_expr
;
1307 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
1309 bitsize
= gfc_integer_kinds
[k
].bit_size
;
1311 if (pos
+ len
> bitsize
)
1313 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1314 "bit size at %L", &y
->where
);
1315 return &gfc_bad_expr
;
1318 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1320 bits
= gfc_getmem (bitsize
* sizeof (int));
1322 for (i
= 0; i
< bitsize
; i
++)
1325 for (i
= 0; i
< len
; i
++)
1326 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
1328 for (i
= 0; i
< bitsize
; i
++)
1331 mpz_clrbit (result
->value
.integer
, i
);
1332 else if (bits
[i
] == 1)
1333 mpz_setbit (result
->value
.integer
, i
);
1335 gfc_internal_error ("IBITS: Bad bit");
1340 return range_check (result
, "IBITS");
1345 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
1350 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1353 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
1355 gfc_error ("Invalid second argument of IBSET at %L", &y
->where
);
1356 return &gfc_bad_expr
;
1359 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1361 if (pos
>= gfc_integer_kinds
[k
].bit_size
)
1363 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1365 return &gfc_bad_expr
;
1368 result
= gfc_copy_expr (x
);
1370 convert_mpz_to_unsigned (result
->value
.integer
,
1371 gfc_integer_kinds
[k
].bit_size
);
1373 mpz_setbit (result
->value
.integer
, pos
);
1375 convert_mpz_to_signed (result
->value
.integer
,
1376 gfc_integer_kinds
[k
].bit_size
);
1378 return range_check (result
, "IBSET");
1383 gfc_simplify_ichar (gfc_expr
*e
)
1388 if (e
->expr_type
!= EXPR_CONSTANT
)
1391 if (e
->value
.character
.length
!= 1)
1393 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
1394 return &gfc_bad_expr
;
1397 index
= (unsigned char) e
->value
.character
.string
[0];
1399 if (index
< 0 || index
> UCHAR_MAX
)
1400 gfc_internal_error("Argument of ICHAR at %L out of range", &e
->where
);
1402 result
= gfc_int_expr (index
);
1403 result
->where
= e
->where
;
1404 return range_check (result
, "ICHAR");
1409 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
1413 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1416 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1418 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1420 return range_check (result
, "IEOR");
1425 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
)
1428 int back
, len
, lensub
;
1429 int i
, j
, k
, count
, index
= 0, start
;
1431 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1434 if (b
!= NULL
&& b
->value
.logical
!= 0)
1439 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1442 len
= x
->value
.character
.length
;
1443 lensub
= y
->value
.character
.length
;
1447 mpz_set_si (result
->value
.integer
, 0);
1455 mpz_set_si (result
->value
.integer
, 1);
1458 else if (lensub
== 1)
1460 for (i
= 0; i
< len
; i
++)
1462 for (j
= 0; j
< lensub
; j
++)
1464 if (y
->value
.character
.string
[j
]
1465 == x
->value
.character
.string
[i
])
1475 for (i
= 0; i
< len
; i
++)
1477 for (j
= 0; j
< lensub
; j
++)
1479 if (y
->value
.character
.string
[j
]
1480 == x
->value
.character
.string
[i
])
1485 for (k
= 0; k
< lensub
; k
++)
1487 if (y
->value
.character
.string
[k
]
1488 == x
->value
.character
.string
[k
+ start
])
1492 if (count
== lensub
)
1507 mpz_set_si (result
->value
.integer
, len
+ 1);
1510 else if (lensub
== 1)
1512 for (i
= 0; i
< len
; i
++)
1514 for (j
= 0; j
< lensub
; j
++)
1516 if (y
->value
.character
.string
[j
]
1517 == x
->value
.character
.string
[len
- i
])
1519 index
= len
- i
+ 1;
1527 for (i
= 0; i
< len
; i
++)
1529 for (j
= 0; j
< lensub
; j
++)
1531 if (y
->value
.character
.string
[j
]
1532 == x
->value
.character
.string
[len
- i
])
1535 if (start
<= len
- lensub
)
1538 for (k
= 0; k
< lensub
; k
++)
1539 if (y
->value
.character
.string
[k
]
1540 == x
->value
.character
.string
[k
+ start
])
1543 if (count
== lensub
)
1560 mpz_set_si (result
->value
.integer
, index
);
1561 return range_check (result
, "INDEX");
1566 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
1568 gfc_expr
*rpart
, *rtrunc
, *result
;
1571 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
1573 return &gfc_bad_expr
;
1575 if (e
->expr_type
!= EXPR_CONSTANT
)
1578 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1583 mpz_set (result
->value
.integer
, e
->value
.integer
);
1587 rtrunc
= gfc_copy_expr (e
);
1588 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1589 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1590 gfc_free_expr (rtrunc
);
1594 rpart
= gfc_complex2real (e
, kind
);
1595 rtrunc
= gfc_copy_expr (rpart
);
1596 mpfr_trunc (rtrunc
->value
.real
, rpart
->value
.real
);
1597 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1598 gfc_free_expr (rpart
);
1599 gfc_free_expr (rtrunc
);
1603 gfc_error ("Argument of INT at %L is not a valid type", &e
->where
);
1604 gfc_free_expr (result
);
1605 return &gfc_bad_expr
;
1608 return range_check (result
, "INT");
1613 gfc_simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
1615 gfc_expr
*rpart
, *rtrunc
, *result
;
1617 if (e
->expr_type
!= EXPR_CONSTANT
)
1620 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
1625 mpz_set (result
->value
.integer
, e
->value
.integer
);
1629 rtrunc
= gfc_copy_expr (e
);
1630 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1631 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1632 gfc_free_expr (rtrunc
);
1636 rpart
= gfc_complex2real (e
, kind
);
1637 rtrunc
= gfc_copy_expr (rpart
);
1638 mpfr_trunc (rtrunc
->value
.real
, rpart
->value
.real
);
1639 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1640 gfc_free_expr (rpart
);
1641 gfc_free_expr (rtrunc
);
1645 gfc_error ("Argument of %s at %L is not a valid type", name
, &e
->where
);
1646 gfc_free_expr (result
);
1647 return &gfc_bad_expr
;
1650 return range_check (result
, name
);
1655 gfc_simplify_int2 (gfc_expr
*e
)
1657 return gfc_simplify_intconv (e
, 2, "INT2");
1662 gfc_simplify_int8 (gfc_expr
*e
)
1664 return gfc_simplify_intconv (e
, 8, "INT8");
1669 gfc_simplify_long (gfc_expr
*e
)
1671 return gfc_simplify_intconv (e
, 4, "LONG");
1676 gfc_simplify_ifix (gfc_expr
*e
)
1678 gfc_expr
*rtrunc
, *result
;
1680 if (e
->expr_type
!= EXPR_CONSTANT
)
1683 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1686 rtrunc
= gfc_copy_expr (e
);
1688 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1689 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1691 gfc_free_expr (rtrunc
);
1692 return range_check (result
, "IFIX");
1697 gfc_simplify_idint (gfc_expr
*e
)
1699 gfc_expr
*rtrunc
, *result
;
1701 if (e
->expr_type
!= EXPR_CONSTANT
)
1704 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1707 rtrunc
= gfc_copy_expr (e
);
1709 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1710 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
);
1712 gfc_free_expr (rtrunc
);
1713 return range_check (result
, "IDINT");
1718 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
1722 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1725 result
= gfc_constant_result (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
1727 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1728 return range_check (result
, "IOR");
1733 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
1736 int shift
, ashift
, isize
, k
, *bits
, i
;
1738 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1741 if (gfc_extract_int (s
, &shift
) != NULL
)
1743 gfc_error ("Invalid second argument of ISHFT at %L", &s
->where
);
1744 return &gfc_bad_expr
;
1747 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
1749 isize
= gfc_integer_kinds
[k
].bit_size
;
1758 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
1759 "at %L", &s
->where
);
1760 return &gfc_bad_expr
;
1763 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1767 mpz_set (result
->value
.integer
, e
->value
.integer
);
1768 return range_check (result
, "ISHFT");
1771 bits
= gfc_getmem (isize
* sizeof (int));
1773 for (i
= 0; i
< isize
; i
++)
1774 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1778 for (i
= 0; i
< shift
; i
++)
1779 mpz_clrbit (result
->value
.integer
, i
);
1781 for (i
= 0; i
< isize
- shift
; i
++)
1784 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1786 mpz_setbit (result
->value
.integer
, i
+ shift
);
1791 for (i
= isize
- 1; i
>= isize
- ashift
; i
--)
1792 mpz_clrbit (result
->value
.integer
, i
);
1794 for (i
= isize
- 1; i
>= ashift
; i
--)
1797 mpz_clrbit (result
->value
.integer
, i
- ashift
);
1799 mpz_setbit (result
->value
.integer
, i
- ashift
);
1803 convert_mpz_to_signed (result
->value
.integer
, isize
);
1811 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
1814 int shift
, ashift
, isize
, ssize
, delta
, k
;
1817 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
1820 if (gfc_extract_int (s
, &shift
) != NULL
)
1822 gfc_error ("Invalid second argument of ISHFTC at %L", &s
->where
);
1823 return &gfc_bad_expr
;
1826 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1827 isize
= gfc_integer_kinds
[k
].bit_size
;
1831 if (sz
->expr_type
!= EXPR_CONSTANT
)
1834 if (gfc_extract_int (sz
, &ssize
) != NULL
|| ssize
<= 0)
1836 gfc_error ("Invalid third argument of ISHFTC at %L", &sz
->where
);
1837 return &gfc_bad_expr
;
1842 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
1843 "BIT_SIZE of first argument at %L", &s
->where
);
1844 return &gfc_bad_expr
;
1858 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1859 "third argument at %L", &s
->where
);
1861 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1862 "BIT_SIZE of first argument at %L", &s
->where
);
1863 return &gfc_bad_expr
;
1866 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
1868 mpz_set (result
->value
.integer
, e
->value
.integer
);
1873 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
1875 bits
= gfc_getmem (ssize
* sizeof (int));
1877 for (i
= 0; i
< ssize
; i
++)
1878 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
1880 delta
= ssize
- ashift
;
1884 for (i
= 0; i
< delta
; i
++)
1887 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1889 mpz_setbit (result
->value
.integer
, i
+ shift
);
1892 for (i
= delta
; i
< ssize
; i
++)
1895 mpz_clrbit (result
->value
.integer
, i
- delta
);
1897 mpz_setbit (result
->value
.integer
, i
- delta
);
1902 for (i
= 0; i
< ashift
; i
++)
1905 mpz_clrbit (result
->value
.integer
, i
+ delta
);
1907 mpz_setbit (result
->value
.integer
, i
+ delta
);
1910 for (i
= ashift
; i
< ssize
; i
++)
1913 mpz_clrbit (result
->value
.integer
, i
+ shift
);
1915 mpz_setbit (result
->value
.integer
, i
+ shift
);
1919 convert_mpz_to_signed (result
->value
.integer
, isize
);
1927 gfc_simplify_kind (gfc_expr
*e
)
1930 if (e
->ts
.type
== BT_DERIVED
)
1932 gfc_error ("Argument of KIND at %L is a DERIVED type", &e
->where
);
1933 return &gfc_bad_expr
;
1936 return gfc_int_expr (e
->ts
.kind
);
1941 simplify_bound_dim (gfc_expr
*array
, int d
, int upper
, gfc_array_spec
*as
)
1943 gfc_expr
*l
, *u
, *result
;
1945 /* The last dimension of an assumed-size array is special. */
1946 if (d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
1948 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
1949 return gfc_copy_expr (as
->lower
[d
-1]);
1954 /* Then, we need to know the extent of the given dimension. */
1958 if (l
->expr_type
!= EXPR_CONSTANT
|| u
->expr_type
!= EXPR_CONSTANT
)
1961 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
1964 if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
1968 mpz_set_si (result
->value
.integer
, 0);
1970 mpz_set_si (result
->value
.integer
, 1);
1974 /* Nonzero extent. */
1976 mpz_set (result
->value
.integer
, u
->value
.integer
);
1978 mpz_set (result
->value
.integer
, l
->value
.integer
);
1981 return range_check (result
, upper
? "UBOUND" : "LBOUND");
1986 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, int upper
)
1992 if (array
->expr_type
!= EXPR_VARIABLE
)
1995 /* Follow any component references. */
1996 as
= array
->symtree
->n
.sym
->as
;
1997 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2002 switch (ref
->u
.ar
.type
)
2009 /* We're done because 'as' has already been set in the
2010 previous iteration. */
2021 as
= ref
->u
.c
.component
->as
;
2033 if (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
)
2038 /* Multi-dimensional bounds. */
2039 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
2041 gfc_constructor
*head
, *tail
;
2043 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2044 if (upper
&& as
->type
== AS_ASSUMED_SIZE
)
2046 /* An error message will be emitted in
2047 check_assumed_size_reference (resolve.c). */
2048 return &gfc_bad_expr
;
2051 /* Simplify the bounds for each dimension. */
2052 for (d
= 0; d
< array
->rank
; d
++)
2054 bounds
[d
] = simplify_bound_dim (array
, d
+ 1, upper
, as
);
2055 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
2059 for (j
= 0; j
< d
; j
++)
2060 gfc_free_expr (bounds
[j
]);
2065 /* Allocate the result expression. */
2066 e
= gfc_get_expr ();
2067 e
->where
= array
->where
;
2068 e
->expr_type
= EXPR_ARRAY
;
2069 e
->ts
.type
= BT_INTEGER
;
2070 e
->ts
.kind
= gfc_default_integer_kind
;
2072 /* The result is a rank 1 array; its size is the rank of the first
2073 argument to {L,U}BOUND. */
2075 e
->shape
= gfc_get_shape (1);
2076 mpz_init_set_ui (e
->shape
[0], array
->rank
);
2078 /* Create the constructor for this array. */
2080 for (d
= 0; d
< array
->rank
; d
++)
2082 /* Get a new constructor element. */
2084 head
= tail
= gfc_get_constructor ();
2087 tail
->next
= gfc_get_constructor ();
2091 tail
->where
= e
->where
;
2092 tail
->expr
= bounds
[d
];
2094 e
->value
.constructor
= head
;
2100 /* A DIM argument is specified. */
2101 if (dim
->expr_type
!= EXPR_CONSTANT
)
2104 d
= mpz_get_si (dim
->value
.integer
);
2106 if (d
< 1 || d
> as
->rank
2107 || (d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
2109 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
2110 return &gfc_bad_expr
;
2113 return simplify_bound_dim (array
, d
, upper
, as
);
2119 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
)
2121 return simplify_bound (array
, dim
, 0);
2126 gfc_simplify_len (gfc_expr
*e
)
2130 if (e
->expr_type
== EXPR_CONSTANT
)
2132 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
2134 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
2135 return range_check (result
, "LEN");
2138 if (e
->ts
.cl
!= NULL
&& e
->ts
.cl
->length
!= NULL
2139 && e
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
2140 && e
->ts
.cl
->length
->ts
.type
== BT_INTEGER
)
2142 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
2144 mpz_set (result
->value
.integer
, e
->ts
.cl
->length
->value
.integer
);
2145 return range_check (result
, "LEN");
2153 gfc_simplify_len_trim (gfc_expr
*e
)
2156 int count
, len
, lentrim
, i
;
2158 if (e
->expr_type
!= EXPR_CONSTANT
)
2161 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
2164 len
= e
->value
.character
.length
;
2166 for (count
= 0, i
= 1; i
<= len
; i
++)
2167 if (e
->value
.character
.string
[len
- i
] == ' ')
2172 lentrim
= len
- count
;
2174 mpz_set_si (result
->value
.integer
, lentrim
);
2175 return range_check (result
, "LEN_TRIM");
2180 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
2182 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2185 return gfc_logical_expr (gfc_compare_string (a
, b
) >= 0, &a
->where
);
2190 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
2192 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2195 return gfc_logical_expr (gfc_compare_string (a
, b
) > 0,
2201 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
2203 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2206 return gfc_logical_expr (gfc_compare_string (a
, b
) <= 0, &a
->where
);
2211 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
2213 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
2216 return gfc_logical_expr (gfc_compare_string (a
, b
) < 0, &a
->where
);
2221 gfc_simplify_log (gfc_expr
*x
)
2226 if (x
->expr_type
!= EXPR_CONSTANT
)
2229 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2231 gfc_set_model_kind (x
->ts
.kind
);
2236 if (mpfr_sgn (x
->value
.real
) <= 0)
2238 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2239 "to zero", &x
->where
);
2240 gfc_free_expr (result
);
2241 return &gfc_bad_expr
;
2244 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2248 if ((mpfr_sgn (x
->value
.complex.r
) == 0)
2249 && (mpfr_sgn (x
->value
.complex.i
) == 0))
2251 gfc_error ("Complex argument of LOG at %L cannot be zero",
2253 gfc_free_expr (result
);
2254 return &gfc_bad_expr
;
2260 mpfr_atan2 (result
->value
.complex.i
, x
->value
.complex.i
,
2261 x
->value
.complex.r
, GFC_RND_MODE
);
2263 mpfr_mul (xr
, x
->value
.complex.r
, x
->value
.complex.r
, GFC_RND_MODE
);
2264 mpfr_mul (xi
, x
->value
.complex.i
, x
->value
.complex.i
, GFC_RND_MODE
);
2265 mpfr_add (xr
, xr
, xi
, GFC_RND_MODE
);
2266 mpfr_sqrt (xr
, xr
, GFC_RND_MODE
);
2267 mpfr_log (result
->value
.complex.r
, xr
, GFC_RND_MODE
);
2275 gfc_internal_error ("gfc_simplify_log: bad type");
2278 return range_check (result
, "LOG");
2283 gfc_simplify_log10 (gfc_expr
*x
)
2287 if (x
->expr_type
!= EXPR_CONSTANT
)
2290 gfc_set_model_kind (x
->ts
.kind
);
2292 if (mpfr_sgn (x
->value
.real
) <= 0)
2294 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2295 "to zero", &x
->where
);
2296 return &gfc_bad_expr
;
2299 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2301 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2303 return range_check (result
, "LOG10");
2308 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
2313 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
2315 return &gfc_bad_expr
;
2317 if (e
->expr_type
!= EXPR_CONSTANT
)
2320 result
= gfc_constant_result (BT_LOGICAL
, kind
, &e
->where
);
2322 result
->value
.logical
= e
->value
.logical
;
2328 /* This function is special since MAX() can take any number of
2329 arguments. The simplified expression is a rewritten version of the
2330 argument list containing at most one constant element. Other
2331 constant elements are deleted. Because the argument list has
2332 already been checked, this function always succeeds. sign is 1 for
2333 MAX(), -1 for MIN(). */
2336 simplify_min_max (gfc_expr
*expr
, int sign
)
2338 gfc_actual_arglist
*arg
, *last
, *extremum
;
2339 gfc_intrinsic_sym
* specific
;
2343 specific
= expr
->value
.function
.isym
;
2345 arg
= expr
->value
.function
.actual
;
2347 for (; arg
; last
= arg
, arg
= arg
->next
)
2349 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
2352 if (extremum
== NULL
)
2358 switch (arg
->expr
->ts
.type
)
2361 if (mpz_cmp (arg
->expr
->value
.integer
,
2362 extremum
->expr
->value
.integer
) * sign
> 0)
2363 mpz_set (extremum
->expr
->value
.integer
, arg
->expr
->value
.integer
);
2368 if (mpfr_cmp (arg
->expr
->value
.real
, extremum
->expr
->value
.real
)
2370 mpfr_set (extremum
->expr
->value
.real
, arg
->expr
->value
.real
,
2376 gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
2379 /* Delete the extra constant argument. */
2381 expr
->value
.function
.actual
= arg
->next
;
2383 last
->next
= arg
->next
;
2386 gfc_free_actual_arglist (arg
);
2390 /* If there is one value left, replace the function call with the
2392 if (expr
->value
.function
.actual
->next
!= NULL
)
2395 /* Convert to the correct type and kind. */
2396 if (expr
->ts
.type
!= BT_UNKNOWN
)
2397 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2398 expr
->ts
.type
, expr
->ts
.kind
);
2400 if (specific
->ts
.type
!= BT_UNKNOWN
)
2401 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
2402 specific
->ts
.type
, specific
->ts
.kind
);
2404 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
2409 gfc_simplify_min (gfc_expr
*e
)
2411 return simplify_min_max (e
, -1);
2416 gfc_simplify_max (gfc_expr
*e
)
2418 return simplify_min_max (e
, 1);
2423 gfc_simplify_maxexponent (gfc_expr
*x
)
2428 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2430 result
= gfc_int_expr (gfc_real_kinds
[i
].max_exponent
);
2431 result
->where
= x
->where
;
2438 gfc_simplify_minexponent (gfc_expr
*x
)
2443 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
2445 result
= gfc_int_expr (gfc_real_kinds
[i
].min_exponent
);
2446 result
->where
= x
->where
;
2453 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
2456 mpfr_t quot
, iquot
, term
;
2459 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2462 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2463 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2468 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2470 /* Result is processor-dependent. */
2471 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
2472 gfc_free_expr (result
);
2473 return &gfc_bad_expr
;
2475 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2479 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2481 /* Result is processor-dependent. */
2482 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
2483 gfc_free_expr (result
);
2484 return &gfc_bad_expr
;
2487 gfc_set_model_kind (kind
);
2492 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2493 mpfr_trunc (iquot
, quot
);
2494 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2495 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2503 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2506 return range_check (result
, "MOD");
2511 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
2514 mpfr_t quot
, iquot
, term
;
2517 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
2520 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
2521 result
= gfc_constant_result (a
->ts
.type
, kind
, &a
->where
);
2526 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
2528 /* Result is processor-dependent. This processor just opts
2529 to not handle it at all. */
2530 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
2531 gfc_free_expr (result
);
2532 return &gfc_bad_expr
;
2534 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
2539 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
2541 /* Result is processor-dependent. */
2542 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
2543 gfc_free_expr (result
);
2544 return &gfc_bad_expr
;
2547 gfc_set_model_kind (kind
);
2552 mpfr_div (quot
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
2553 mpfr_floor (iquot
, quot
);
2554 mpfr_mul (term
, iquot
, p
->value
.real
, GFC_RND_MODE
);
2555 mpfr_sub (result
->value
.real
, a
->value
.real
, term
, GFC_RND_MODE
);
2563 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2566 return range_check (result
, "MODULO");
2570 /* Exists for the sole purpose of consistency with other intrinsics. */
2572 gfc_simplify_mvbits (gfc_expr
*f ATTRIBUTE_UNUSED
,
2573 gfc_expr
*fp ATTRIBUTE_UNUSED
,
2574 gfc_expr
*l ATTRIBUTE_UNUSED
,
2575 gfc_expr
*to ATTRIBUTE_UNUSED
,
2576 gfc_expr
*tp ATTRIBUTE_UNUSED
)
2583 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
2589 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
2592 if (mpfr_sgn (s
->value
.real
) == 0)
2594 gfc_error ("Second argument of NEAREST at %L shall not be zero",
2596 return &gfc_bad_expr
;
2599 gfc_set_model_kind (x
->ts
.kind
);
2600 result
= gfc_copy_expr (x
);
2602 sgn
= mpfr_sgn (s
->value
.real
);
2604 mpfr_set_inf (tmp
, sgn
);
2605 mpfr_nexttoward (result
->value
.real
, tmp
);
2608 return range_check (result
, "NEAREST");
2613 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
2615 gfc_expr
*itrunc
, *result
;
2618 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
2620 return &gfc_bad_expr
;
2622 if (e
->expr_type
!= EXPR_CONSTANT
)
2625 result
= gfc_constant_result (BT_INTEGER
, kind
, &e
->where
);
2627 itrunc
= gfc_copy_expr (e
);
2629 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
2631 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
);
2633 gfc_free_expr (itrunc
);
2635 return range_check (result
, name
);
2640 gfc_simplify_new_line (gfc_expr
*e
)
2644 if (e
->expr_type
!= EXPR_CONSTANT
)
2647 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
2649 result
->value
.character
.string
= gfc_getmem (2);
2651 result
->value
.character
.length
= 1;
2652 result
->value
.character
.string
[0] = '\n';
2653 result
->value
.character
.string
[1] = '\0'; /* For debugger */
2659 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
2661 return simplify_nint ("NINT", e
, k
);
2666 gfc_simplify_idnint (gfc_expr
*e
)
2668 return simplify_nint ("IDNINT", e
, NULL
);
2673 gfc_simplify_not (gfc_expr
*e
)
2677 if (e
->expr_type
!= EXPR_CONSTANT
)
2680 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2682 mpz_com (result
->value
.integer
, e
->value
.integer
);
2684 return range_check (result
, "NOT");
2689 gfc_simplify_null (gfc_expr
*mold
)
2695 result
= gfc_get_expr ();
2696 result
->ts
.type
= BT_UNKNOWN
;
2699 result
= gfc_copy_expr (mold
);
2700 result
->expr_type
= EXPR_NULL
;
2707 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
2712 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2715 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2716 if (x
->ts
.type
== BT_INTEGER
)
2718 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
2719 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2721 else /* BT_LOGICAL */
2723 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
2724 result
->value
.logical
= x
->value
.logical
|| y
->value
.logical
;
2727 return range_check (result
, "OR");
2732 gfc_simplify_precision (gfc_expr
*e
)
2737 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2739 result
= gfc_int_expr (gfc_real_kinds
[i
].precision
);
2740 result
->where
= e
->where
;
2747 gfc_simplify_radix (gfc_expr
*e
)
2752 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2756 i
= gfc_integer_kinds
[i
].radix
;
2760 i
= gfc_real_kinds
[i
].radix
;
2767 result
= gfc_int_expr (i
);
2768 result
->where
= e
->where
;
2775 gfc_simplify_range (gfc_expr
*e
)
2781 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2786 j
= gfc_integer_kinds
[i
].range
;
2791 j
= gfc_real_kinds
[i
].range
;
2798 result
= gfc_int_expr (j
);
2799 result
->where
= e
->where
;
2806 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
2811 if (e
->ts
.type
== BT_COMPLEX
)
2812 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
2814 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
2817 return &gfc_bad_expr
;
2819 if (e
->expr_type
!= EXPR_CONSTANT
)
2825 result
= gfc_int2real (e
, kind
);
2829 result
= gfc_real2real (e
, kind
);
2833 result
= gfc_complex2real (e
, kind
);
2837 gfc_internal_error ("bad type in REAL");
2841 return range_check (result
, "REAL");
2846 gfc_simplify_realpart (gfc_expr
*e
)
2850 if (e
->expr_type
!= EXPR_CONSTANT
)
2853 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
2854 mpfr_set (result
->value
.real
, e
->value
.complex.r
, GFC_RND_MODE
);
2856 return range_check (result
, "REALPART");
2860 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
2863 int i
, j
, len
, ncop
, nlen
;
2866 /* If NCOPIES isn't a constant, there's nothing we can do. */
2867 if (n
->expr_type
!= EXPR_CONSTANT
)
2870 /* If NCOPIES is negative, it's an error. */
2871 if (mpz_sgn (n
->value
.integer
) < 0)
2873 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
2875 return &gfc_bad_expr
;
2878 /* If we don't know the character length, we can do no more. */
2879 if (e
->ts
.cl
== NULL
|| e
->ts
.cl
->length
== NULL
2880 || e
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2883 /* If the source length is 0, any value of NCOPIES is valid
2884 and everything behaves as if NCOPIES == 0. */
2886 if (mpz_sgn (e
->ts
.cl
->length
->value
.integer
) == 0)
2887 mpz_set_ui (ncopies
, 0);
2889 mpz_set (ncopies
, n
->value
.integer
);
2891 /* Check that NCOPIES isn't too large. */
2892 if (mpz_sgn (e
->ts
.cl
->length
->value
.integer
) != 0)
2897 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
2899 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
2900 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
2901 e
->ts
.cl
->length
->value
.integer
);
2903 /* The check itself. */
2904 if (mpz_cmp (ncopies
, max
) > 0)
2907 mpz_clear (ncopies
);
2908 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
2910 return &gfc_bad_expr
;
2915 mpz_clear (ncopies
);
2917 /* For further simplification, we need the character string to be
2919 if (e
->expr_type
!= EXPR_CONSTANT
)
2922 if (mpz_sgn (e
->ts
.cl
->length
->value
.integer
) != 0)
2924 const char *res
= gfc_extract_int (n
, &ncop
);
2925 gcc_assert (res
== NULL
);
2930 len
= e
->value
.character
.length
;
2933 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
2937 result
->value
.character
.string
= gfc_getmem (1);
2938 result
->value
.character
.length
= 0;
2939 result
->value
.character
.string
[0] = '\0';
2943 result
->value
.character
.length
= nlen
;
2944 result
->value
.character
.string
= gfc_getmem (nlen
+ 1);
2946 for (i
= 0; i
< ncop
; i
++)
2947 for (j
= 0; j
< len
; j
++)
2948 result
->value
.character
.string
[j
+ i
* len
]
2949 = e
->value
.character
.string
[j
];
2951 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
2956 /* This one is a bear, but mainly has to do with shuffling elements. */
2959 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
2960 gfc_expr
*pad
, gfc_expr
*order_exp
)
2962 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
2963 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
2964 gfc_constructor
*head
, *tail
;
2970 /* Unpack the shape array. */
2971 if (source
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (source
))
2974 if (shape_exp
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (shape_exp
))
2978 && (pad
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (pad
)))
2981 if (order_exp
!= NULL
2982 && (order_exp
->expr_type
!= EXPR_ARRAY
2983 || !gfc_is_constant_expr (order_exp
)))
2992 e
= gfc_get_array_element (shape_exp
, rank
);
2996 if (gfc_extract_int (e
, &shape
[rank
]) != NULL
)
2998 gfc_error ("Integer too large in shape specification at %L",
3006 if (rank
>= GFC_MAX_DIMENSIONS
)
3008 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3009 "at %L", &e
->where
);
3014 if (shape
[rank
] < 0)
3016 gfc_error ("Shape specification at %L cannot be negative",
3026 gfc_error ("Shape specification at %L cannot be the null array",
3031 /* Now unpack the order array if present. */
3032 if (order_exp
== NULL
)
3034 for (i
= 0; i
< rank
; i
++)
3039 for (i
= 0; i
< rank
; i
++)
3042 for (i
= 0; i
< rank
; i
++)
3044 e
= gfc_get_array_element (order_exp
, i
);
3047 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3048 "size as SHAPE parameter", &order_exp
->where
);
3052 if (gfc_extract_int (e
, &order
[i
]) != NULL
)
3054 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3062 if (order
[i
] < 1 || order
[i
] > rank
)
3064 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3073 gfc_error ("Invalid permutation in ORDER parameter at %L",
3082 /* Count the elements in the source and padding arrays. */
3087 gfc_array_size (pad
, &size
);
3088 npad
= mpz_get_ui (size
);
3092 gfc_array_size (source
, &size
);
3093 nsource
= mpz_get_ui (size
);
3096 /* If it weren't for that pesky permutation we could just loop
3097 through the source and round out any shortage with pad elements.
3098 But no, someone just had to have the compiler do something the
3099 user should be doing. */
3101 for (i
= 0; i
< rank
; i
++)
3106 /* Figure out which element to extract. */
3107 mpz_set_ui (index
, 0);
3109 for (i
= rank
- 1; i
>= 0; i
--)
3111 mpz_add_ui (index
, index
, x
[order
[i
]]);
3113 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
3116 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
3117 gfc_internal_error ("Reshaped array too large at %L", &e
->where
);
3119 j
= mpz_get_ui (index
);
3122 e
= gfc_get_array_element (source
, j
);
3129 gfc_error ("PAD parameter required for short SOURCE parameter "
3130 "at %L", &source
->where
);
3135 e
= gfc_get_array_element (pad
, j
);
3139 head
= tail
= gfc_get_constructor ();
3142 tail
->next
= gfc_get_constructor ();
3149 tail
->where
= e
->where
;
3152 /* Calculate the next element. */
3156 if (++x
[i
] < shape
[i
])
3167 e
= gfc_get_expr ();
3168 e
->where
= source
->where
;
3169 e
->expr_type
= EXPR_ARRAY
;
3170 e
->value
.constructor
= head
;
3171 e
->shape
= gfc_get_shape (rank
);
3173 for (i
= 0; i
< rank
; i
++)
3174 mpz_init_set_ui (e
->shape
[i
], shape
[i
]);
3182 gfc_free_constructor (head
);
3184 return &gfc_bad_expr
;
3189 gfc_simplify_rrspacing (gfc_expr
*x
)
3195 if (x
->expr_type
!= EXPR_CONSTANT
)
3198 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3200 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3202 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3204 /* Special case x = -0 and 0. */
3205 if (mpfr_sgn (result
->value
.real
) == 0)
3207 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3211 /* | x * 2**(-e) | * 2**p. */
3212 e
= - (long int) mpfr_get_exp (x
->value
.real
);
3213 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
3215 p
= (long int) gfc_real_kinds
[i
].digits
;
3216 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
3218 return range_check (result
, "RRSPACING");
3223 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
3225 int k
, neg_flag
, power
, exp_range
;
3226 mpfr_t scale
, radix
;
3229 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3232 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3234 if (mpfr_sgn (x
->value
.real
) == 0)
3236 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3240 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3242 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
3244 /* This check filters out values of i that would overflow an int. */
3245 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
3246 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
3248 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
3249 return &gfc_bad_expr
;
3252 /* Compute scale = radix ** power. */
3253 power
= mpz_get_si (i
->value
.integer
);
3263 gfc_set_model_kind (x
->ts
.kind
);
3266 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
3267 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
3270 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3272 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
3277 return range_check (result
, "SCALE");
3282 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
)
3287 size_t indx
, len
, lenc
;
3289 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
)
3292 if (b
!= NULL
&& b
->value
.logical
!= 0)
3297 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3300 len
= e
->value
.character
.length
;
3301 lenc
= c
->value
.character
.length
;
3303 if (len
== 0 || lenc
== 0)
3311 indx
= strcspn (e
->value
.character
.string
, c
->value
.character
.string
)
3319 for (indx
= len
; indx
> 0; indx
--)
3321 for (i
= 0; i
< lenc
; i
++)
3323 if (c
->value
.character
.string
[i
]
3324 == e
->value
.character
.string
[indx
- 1])
3332 mpz_set_ui (result
->value
.integer
, indx
);
3333 return range_check (result
, "SCAN");
3338 gfc_simplify_selected_int_kind (gfc_expr
*e
)
3343 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
3348 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
3349 if (gfc_integer_kinds
[i
].range
>= range
3350 && gfc_integer_kinds
[i
].kind
< kind
)
3351 kind
= gfc_integer_kinds
[i
].kind
;
3353 if (kind
== INT_MAX
)
3356 result
= gfc_int_expr (kind
);
3357 result
->where
= e
->where
;
3364 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
)
3366 int range
, precision
, i
, kind
, found_precision
, found_range
;
3373 if (p
->expr_type
!= EXPR_CONSTANT
3374 || gfc_extract_int (p
, &precision
) != NULL
)
3382 if (q
->expr_type
!= EXPR_CONSTANT
3383 || gfc_extract_int (q
, &range
) != NULL
)
3388 found_precision
= 0;
3391 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
3393 if (gfc_real_kinds
[i
].precision
>= precision
)
3394 found_precision
= 1;
3396 if (gfc_real_kinds
[i
].range
>= range
)
3399 if (gfc_real_kinds
[i
].precision
>= precision
3400 && gfc_real_kinds
[i
].range
>= range
&& gfc_real_kinds
[i
].kind
< kind
)
3401 kind
= gfc_real_kinds
[i
].kind
;
3404 if (kind
== INT_MAX
)
3408 if (!found_precision
)
3414 result
= gfc_int_expr (kind
);
3415 result
->where
= (p
!= NULL
) ? p
->where
: q
->where
;
3422 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
3425 mpfr_t exp
, absv
, log2
, pow2
, frac
;
3428 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
3431 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3433 gfc_set_model_kind (x
->ts
.kind
);
3435 if (mpfr_sgn (x
->value
.real
) == 0)
3437 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
3447 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3448 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
3450 mpfr_trunc (log2
, log2
);
3451 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
3453 /* Old exponent value, and fraction. */
3454 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3456 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
3459 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
3460 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
3467 return range_check (result
, "SET_EXPONENT");
3472 gfc_simplify_shape (gfc_expr
*source
)
3474 mpz_t shape
[GFC_MAX_DIMENSIONS
];
3475 gfc_expr
*result
, *e
, *f
;
3480 if (source
->rank
== 0 || source
->expr_type
!= EXPR_VARIABLE
)
3483 result
= gfc_start_constructor (BT_INTEGER
, gfc_default_integer_kind
,
3486 ar
= gfc_find_array_ref (source
);
3488 t
= gfc_array_ref_shape (ar
, shape
);
3490 for (n
= 0; n
< source
->rank
; n
++)
3492 e
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3497 mpz_set (e
->value
.integer
, shape
[n
]);
3498 mpz_clear (shape
[n
]);
3502 mpz_set_ui (e
->value
.integer
, n
+ 1);
3504 f
= gfc_simplify_size (source
, e
);
3508 gfc_free_expr (result
);
3517 gfc_append_constructor (result
, e
);
3525 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
)
3533 if (gfc_array_size (array
, &size
) == FAILURE
)
3538 if (dim
->expr_type
!= EXPR_CONSTANT
)
3541 d
= mpz_get_ui (dim
->value
.integer
) - 1;
3542 if (gfc_array_dimen_size (array
, d
, &size
) == FAILURE
)
3546 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3549 mpz_set (result
->value
.integer
, size
);
3556 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
3560 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3563 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3568 mpz_abs (result
->value
.integer
, x
->value
.integer
);
3569 if (mpz_sgn (y
->value
.integer
) < 0)
3570 mpz_neg (result
->value
.integer
, result
->value
.integer
);
3575 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3577 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3578 if (mpfr_sgn (y
->value
.real
) < 0)
3579 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
3584 gfc_internal_error ("Bad type in gfc_simplify_sign");
3592 gfc_simplify_sin (gfc_expr
*x
)
3597 if (x
->expr_type
!= EXPR_CONSTANT
)
3600 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3605 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3609 gfc_set_model (x
->value
.real
);
3613 mpfr_sin (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3614 mpfr_cosh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3615 mpfr_mul (result
->value
.complex.r
, xp
, xq
, GFC_RND_MODE
);
3617 mpfr_cos (xp
, x
->value
.complex.r
, GFC_RND_MODE
);
3618 mpfr_sinh (xq
, x
->value
.complex.i
, GFC_RND_MODE
);
3619 mpfr_mul (result
->value
.complex.i
, xp
, xq
, GFC_RND_MODE
);
3626 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3629 return range_check (result
, "SIN");
3634 gfc_simplify_sinh (gfc_expr
*x
)
3638 if (x
->expr_type
!= EXPR_CONSTANT
)
3641 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3643 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3645 return range_check (result
, "SINH");
3649 /* The argument is always a double precision real that is converted to
3650 single precision. TODO: Rounding! */
3653 gfc_simplify_sngl (gfc_expr
*a
)
3657 if (a
->expr_type
!= EXPR_CONSTANT
)
3660 result
= gfc_real2real (a
, gfc_default_real_kind
);
3661 return range_check (result
, "SNGL");
3666 gfc_simplify_spacing (gfc_expr
*x
)
3672 if (x
->expr_type
!= EXPR_CONSTANT
)
3675 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3677 result
= gfc_constant_result (BT_REAL
, x
->ts
.kind
, &x
->where
);
3679 /* Special case x = 0 and -0. */
3680 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3681 if (mpfr_sgn (result
->value
.real
) == 0)
3683 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3687 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3688 are the radix, exponent of x, and precision. This excludes the
3689 possibility of subnormal numbers. Fortran 2003 states the result is
3690 b**max(e - p, emin - 1). */
3692 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
3693 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
3694 en
= en
> ep
? en
: ep
;
3696 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
3697 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
3699 return range_check (result
, "SPACING");
3704 gfc_simplify_sqrt (gfc_expr
*e
)
3707 mpfr_t ac
, ad
, s
, t
, w
;
3709 if (e
->expr_type
!= EXPR_CONSTANT
)
3712 result
= gfc_constant_result (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3717 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
3719 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
3724 /* Formula taken from Numerical Recipes to avoid over- and
3727 gfc_set_model (e
->value
.real
);
3734 if (mpfr_cmp_ui (e
->value
.complex.r
, 0) == 0
3735 && mpfr_cmp_ui (e
->value
.complex.i
, 0) == 0)
3737 mpfr_set_ui (result
->value
.complex.r
, 0, GFC_RND_MODE
);
3738 mpfr_set_ui (result
->value
.complex.i
, 0, GFC_RND_MODE
);
3742 mpfr_abs (ac
, e
->value
.complex.r
, GFC_RND_MODE
);
3743 mpfr_abs (ad
, e
->value
.complex.i
, GFC_RND_MODE
);
3745 if (mpfr_cmp (ac
, ad
) >= 0)
3747 mpfr_div (t
, e
->value
.complex.i
, e
->value
.complex.r
, GFC_RND_MODE
);
3748 mpfr_mul (t
, t
, t
, GFC_RND_MODE
);
3749 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3750 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3751 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3752 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3753 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3754 mpfr_sqrt (s
, ac
, GFC_RND_MODE
);
3755 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3759 mpfr_div (s
, e
->value
.complex.r
, e
->value
.complex.i
, GFC_RND_MODE
);
3760 mpfr_mul (t
, s
, s
, GFC_RND_MODE
);
3761 mpfr_add_ui (t
, t
, 1, GFC_RND_MODE
);
3762 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3763 mpfr_abs (s
, s
, GFC_RND_MODE
);
3764 mpfr_add (t
, t
, s
, GFC_RND_MODE
);
3765 mpfr_div_ui (t
, t
, 2, GFC_RND_MODE
);
3766 mpfr_sqrt (t
, t
, GFC_RND_MODE
);
3767 mpfr_sqrt (s
, ad
, GFC_RND_MODE
);
3768 mpfr_mul (w
, s
, t
, GFC_RND_MODE
);
3771 if (mpfr_cmp_ui (w
, 0) != 0 && mpfr_cmp_ui (e
->value
.complex.r
, 0) >= 0)
3773 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3774 mpfr_div (result
->value
.complex.i
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3775 mpfr_set (result
->value
.complex.r
, w
, GFC_RND_MODE
);
3777 else if (mpfr_cmp_ui (w
, 0) != 0
3778 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3779 && mpfr_cmp_ui (e
->value
.complex.i
, 0) >= 0)
3781 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3782 mpfr_div (result
->value
.complex.r
, e
->value
.complex.i
, t
, GFC_RND_MODE
);
3783 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3785 else if (mpfr_cmp_ui (w
, 0) != 0
3786 && mpfr_cmp_ui (e
->value
.complex.r
, 0) < 0
3787 && mpfr_cmp_ui (e
->value
.complex.i
, 0) < 0)
3789 mpfr_mul_ui (t
, w
, 2, GFC_RND_MODE
);
3790 mpfr_div (result
->value
.complex.r
, ad
, t
, GFC_RND_MODE
);
3791 mpfr_neg (w
, w
, GFC_RND_MODE
);
3792 mpfr_set (result
->value
.complex.i
, w
, GFC_RND_MODE
);
3795 gfc_internal_error ("invalid complex argument of SQRT at %L",
3807 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
3810 return range_check (result
, "SQRT");
3813 gfc_free_expr (result
);
3814 gfc_error ("Argument of SQRT at %L has a negative value", &e
->where
);
3815 return &gfc_bad_expr
;
3820 gfc_simplify_tan (gfc_expr
*x
)
3825 if (x
->expr_type
!= EXPR_CONSTANT
)
3828 i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
3830 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3832 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3834 return range_check (result
, "TAN");
3839 gfc_simplify_tanh (gfc_expr
*x
)
3843 if (x
->expr_type
!= EXPR_CONSTANT
)
3846 result
= gfc_constant_result (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3848 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3850 return range_check (result
, "TANH");
3856 gfc_simplify_tiny (gfc_expr
*e
)
3861 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
3863 result
= gfc_constant_result (BT_REAL
, e
->ts
.kind
, &e
->where
);
3864 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
3871 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
3873 /* Reference mold and size to suppress warning. */
3874 if (gfc_init_expr
&& (mold
|| size
))
3875 gfc_error ("TRANSFER intrinsic not implemented for initialization at %L",
3883 gfc_simplify_trim (gfc_expr
*e
)
3886 int count
, i
, len
, lentrim
;
3888 if (e
->expr_type
!= EXPR_CONSTANT
)
3891 len
= e
->value
.character
.length
;
3893 result
= gfc_constant_result (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
3895 for (count
= 0, i
= 1; i
<= len
; ++i
)
3897 if (e
->value
.character
.string
[len
- i
] == ' ')
3903 lentrim
= len
- count
;
3905 result
->value
.character
.length
= lentrim
;
3906 result
->value
.character
.string
= gfc_getmem (lentrim
+ 1);
3908 for (i
= 0; i
< lentrim
; i
++)
3909 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
3911 result
->value
.character
.string
[lentrim
] = '\0'; /* For debugger */
3918 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
)
3920 return simplify_bound (array
, dim
, 1);
3925 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
)
3929 size_t index
, len
, lenset
;
3932 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
)
3935 if (b
!= NULL
&& b
->value
.logical
!= 0)
3940 result
= gfc_constant_result (BT_INTEGER
, gfc_default_integer_kind
,
3943 len
= s
->value
.character
.length
;
3944 lenset
= set
->value
.character
.length
;
3948 mpz_set_ui (result
->value
.integer
, 0);
3956 mpz_set_ui (result
->value
.integer
, 1);
3960 index
= strspn (s
->value
.character
.string
, set
->value
.character
.string
)
3970 mpz_set_ui (result
->value
.integer
, len
);
3973 for (index
= len
; index
> 0; index
--)
3975 for (i
= 0; i
< lenset
; i
++)
3977 if (s
->value
.character
.string
[index
- 1]
3978 == set
->value
.character
.string
[i
])
3986 mpz_set_ui (result
->value
.integer
, index
);
3992 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
3997 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4000 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4001 if (x
->ts
.type
== BT_INTEGER
)
4003 result
= gfc_constant_result (BT_INTEGER
, kind
, &x
->where
);
4004 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4006 else /* BT_LOGICAL */
4008 result
= gfc_constant_result (BT_LOGICAL
, kind
, &x
->where
);
4009 result
->value
.logical
= (x
->value
.logical
&& !y
->value
.logical
)
4010 || (!x
->value
.logical
&& y
->value
.logical
);
4013 return range_check (result
, "XOR");
4017 /****************** Constant simplification *****************/
4019 /* Master function to convert one constant to another. While this is
4020 used as a simplification function, it requires the destination type
4021 and kind information which is supplied by a special case in
4025 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
4027 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
4028 gfc_constructor
*head
, *c
, *tail
= NULL
;
4042 f
= gfc_int2complex
;
4062 f
= gfc_real2complex
;
4073 f
= gfc_complex2int
;
4076 f
= gfc_complex2real
;
4079 f
= gfc_complex2complex
;
4105 f
= gfc_hollerith2int
;
4109 f
= gfc_hollerith2real
;
4113 f
= gfc_hollerith2complex
;
4117 f
= gfc_hollerith2character
;
4121 f
= gfc_hollerith2logical
;
4131 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4136 switch (e
->expr_type
)
4139 result
= f (e
, kind
);
4141 return &gfc_bad_expr
;
4145 if (!gfc_is_constant_expr (e
))
4150 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
4153 head
= tail
= gfc_get_constructor ();
4156 tail
->next
= gfc_get_constructor ();
4160 tail
->where
= c
->where
;
4162 if (c
->iterator
== NULL
)
4163 tail
->expr
= f (c
->expr
, kind
);
4166 g
= gfc_convert_constant (c
->expr
, type
, kind
);
4167 if (g
== &gfc_bad_expr
)
4172 if (tail
->expr
== NULL
)
4174 gfc_free_constructor (head
);
4179 result
= gfc_get_expr ();
4180 result
->ts
.type
= type
;
4181 result
->ts
.kind
= kind
;
4182 result
->expr_type
= EXPR_ARRAY
;
4183 result
->value
.constructor
= head
;
4184 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4185 result
->where
= e
->where
;
4186 result
->rank
= e
->rank
;