1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
3 2010, 2011 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"
29 #include "constructor.h"
30 #include "version.h" /* For version_string. */
33 gfc_expr gfc_bad_expr
;
36 /* Note that 'simplification' is not just transforming expressions.
37 For functions that are not simplified at compile time, range
38 checking is done if possible.
40 The return convention is that each simplification function returns:
42 A new expression node corresponding to the simplified arguments.
43 The original arguments are destroyed by the caller, and must not
44 be a part of the new expression.
46 NULL pointer indicating that no simplification was possible and
47 the original expression should remain intact.
49 An expression pointer to gfc_bad_expr (a static placeholder)
50 indicating that some error has prevented simplification. The
51 error is generated within the function and should be propagated
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 only passed to these subroutines that implement
62 the simplification of transformational intrinsics.
64 The functions in this file don't have much comment with them, but
65 everything is reasonably straight-forward. The Standard, chapter 13
66 is the best comment you'll find for this file anyway. */
68 /* Range checks an expression node. If all goes well, returns the
69 node, otherwise returns &gfc_bad_expr and frees the node. */
72 range_check (gfc_expr
*result
, const char *name
)
77 if (result
->expr_type
!= EXPR_CONSTANT
)
80 switch (gfc_range_check (result
))
86 gfc_error ("Result of %s overflows its kind at %L", name
,
91 gfc_error ("Result of %s underflows its kind at %L", name
,
96 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
100 gfc_error ("Result of %s gives range error for its kind at %L", name
,
105 gfc_free_expr (result
);
106 return &gfc_bad_expr
;
110 /* A helper function that gets an optional and possibly missing
111 kind parameter. Returns the kind, -1 if something went wrong. */
114 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
121 if (k
->expr_type
!= EXPR_CONSTANT
)
123 gfc_error ("KIND parameter of %s at %L must be an initialization "
124 "expression", name
, &k
->where
);
128 if (gfc_extract_int (k
, &kind
) != NULL
129 || gfc_validate_kind (type
, kind
, true) < 0)
131 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
139 /* Converts an mpz_t signed variable into an unsigned one, assuming
140 two's complement representations and a binary width of bitsize.
141 The conversion is a no-op unless x is negative; otherwise, it can
142 be accomplished by masking out the high bits. */
145 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
151 /* Confirm that no bits above the signed range are unset. */
152 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
154 mpz_init_set_ui (mask
, 1);
155 mpz_mul_2exp (mask
, mask
, bitsize
);
156 mpz_sub_ui (mask
, mask
, 1);
158 mpz_and (x
, x
, mask
);
164 /* Confirm that no bits above the signed range are set. */
165 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
170 /* Converts an mpz_t unsigned variable into a signed one, assuming
171 two's complement representations and a binary width of bitsize.
172 If the bitsize-1 bit is set, this is taken as a sign bit and
173 the number is converted to the corresponding negative number. */
176 convert_mpz_to_signed (mpz_t x
, int bitsize
)
180 /* Confirm that no bits above the unsigned range are set. */
181 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
183 if (mpz_tstbit (x
, bitsize
- 1) == 1)
185 mpz_init_set_ui (mask
, 1);
186 mpz_mul_2exp (mask
, mask
, bitsize
);
187 mpz_sub_ui (mask
, mask
, 1);
189 /* We negate the number by hand, zeroing the high bits, that is
190 make it the corresponding positive number, and then have it
191 negated by GMP, giving the correct representation of the
194 mpz_add_ui (x
, x
, 1);
195 mpz_and (x
, x
, mask
);
204 /* In-place convert BOZ to REAL of the specified kind. */
207 convert_boz (gfc_expr
*x
, int kind
)
209 if (x
&& x
->ts
.type
== BT_INTEGER
&& x
->is_boz
)
216 if (!gfc_convert_boz (x
, &ts
))
217 return &gfc_bad_expr
;
224 /* Test that the expression is an constant array. */
227 is_constant_array_expr (gfc_expr
*e
)
234 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
237 for (c
= gfc_constructor_first (e
->value
.constructor
);
238 c
; c
= gfc_constructor_next (c
))
239 if (c
->expr
->expr_type
!= EXPR_CONSTANT
240 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
247 /* Initialize a transformational result expression with a given value. */
250 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
252 if (e
&& e
->expr_type
== EXPR_ARRAY
)
254 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
257 init_result_expr (ctor
->expr
, init
, array
);
258 ctor
= gfc_constructor_next (ctor
);
261 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
263 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
270 e
->value
.logical
= (init
? 1 : 0);
275 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
276 else if (init
== INT_MAX
)
277 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
279 mpz_set_si (e
->value
.integer
, init
);
285 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
286 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
288 else if (init
== INT_MAX
)
289 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
291 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
295 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
301 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
302 gfc_extract_int (len
, &length
);
303 string
= gfc_get_wide_string (length
+ 1);
304 gfc_wide_memset (string
, 0, length
);
306 else if (init
== INT_MAX
)
308 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
309 gfc_extract_int (len
, &length
);
310 string
= gfc_get_wide_string (length
+ 1);
311 gfc_wide_memset (string
, 255, length
);
316 string
= gfc_get_wide_string (1);
319 string
[length
] = '\0';
320 e
->value
.character
.length
= length
;
321 e
->value
.character
.string
= string
;
333 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */
336 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
337 gfc_expr
*matrix_b
, int stride_b
, int offset_b
)
339 gfc_expr
*result
, *a
, *b
;
341 result
= gfc_get_constant_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
343 init_result_expr (result
, 0, NULL
);
345 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
346 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
349 /* Copying of expressions is required as operands are free'd
350 by the gfc_arith routines. */
351 switch (result
->ts
.type
)
354 result
= gfc_or (result
,
355 gfc_and (gfc_copy_expr (a
),
362 result
= gfc_add (result
,
363 gfc_multiply (gfc_copy_expr (a
),
371 offset_a
+= stride_a
;
372 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
374 offset_b
+= stride_b
;
375 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
382 /* Build a result expression for transformational intrinsics,
386 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
387 int kind
, locus
* where
)
392 if (!dim
|| array
->rank
== 1)
393 return gfc_get_constant_expr (type
, kind
, where
);
395 result
= gfc_get_array_expr (type
, kind
, where
);
396 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
397 result
->rank
= array
->rank
- 1;
399 /* gfc_array_size() would count the number of elements in the constructor,
400 we have not built those yet. */
402 for (i
= 0; i
< result
->rank
; ++i
)
403 nelem
*= mpz_get_ui (result
->shape
[i
]);
405 for (i
= 0; i
< nelem
; ++i
)
407 gfc_constructor_append_expr (&result
->value
.constructor
,
408 gfc_get_constant_expr (type
, kind
, where
),
416 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
418 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
419 of COUNT intrinsic is .TRUE..
421 Interface and implimentation mimics arith functions as
422 gfc_add, gfc_multiply, etc. */
424 static gfc_expr
* gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
428 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
429 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
430 gcc_assert (op2
->value
.logical
);
432 result
= gfc_copy_expr (op1
);
433 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
441 /* Transforms an ARRAY with operation OP, according to MASK, to a
442 scalar RESULT. E.g. called if
444 REAL, PARAMETER :: array(n, m) = ...
445 REAL, PARAMETER :: s = SUM(array)
447 where OP == gfc_add(). */
450 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
451 transformational_op op
)
454 gfc_constructor
*array_ctor
, *mask_ctor
;
456 /* Shortcut for constant .FALSE. MASK. */
458 && mask
->expr_type
== EXPR_CONSTANT
459 && !mask
->value
.logical
)
462 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
464 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
465 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
469 a
= array_ctor
->expr
;
470 array_ctor
= gfc_constructor_next (array_ctor
);
472 /* A constant MASK equals .TRUE. here and can be ignored. */
476 mask_ctor
= gfc_constructor_next (mask_ctor
);
477 if (!m
->value
.logical
)
481 result
= op (result
, gfc_copy_expr (a
));
487 /* Transforms an ARRAY with operation OP, according to MASK, to an
488 array RESULT. E.g. called if
490 REAL, PARAMETER :: array(n, m) = ...
491 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
493 where OP == gfc_multiply(). The result might be post processed using post_op. */
496 simplify_transformation_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*dim
,
497 gfc_expr
*mask
, transformational_op op
,
498 transformational_op post_op
)
501 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
502 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
503 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
505 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
506 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
507 tmpstride
[GFC_MAX_DIMENSIONS
];
509 /* Shortcut for constant .FALSE. MASK. */
511 && mask
->expr_type
== EXPR_CONSTANT
512 && !mask
->value
.logical
)
515 /* Build an indexed table for array element expressions to minimize
516 linked-list traversal. Masked elements are set to NULL. */
517 gfc_array_size (array
, &size
);
518 arraysize
= mpz_get_ui (size
);
520 arrayvec
= (gfc_expr
**) gfc_getmem (sizeof (gfc_expr
*) * arraysize
);
522 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
524 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
525 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
527 for (i
= 0; i
< arraysize
; ++i
)
529 arrayvec
[i
] = array_ctor
->expr
;
530 array_ctor
= gfc_constructor_next (array_ctor
);
534 if (!mask_ctor
->expr
->value
.logical
)
537 mask_ctor
= gfc_constructor_next (mask_ctor
);
541 /* Same for the result expression. */
542 gfc_array_size (result
, &size
);
543 resultsize
= mpz_get_ui (size
);
546 resultvec
= (gfc_expr
**) gfc_getmem (sizeof (gfc_expr
*) * resultsize
);
547 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
548 for (i
= 0; i
< resultsize
; ++i
)
550 resultvec
[i
] = result_ctor
->expr
;
551 result_ctor
= gfc_constructor_next (result_ctor
);
554 gfc_extract_int (dim
, &dim_index
);
555 dim_index
-= 1; /* zero-base index */
559 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
562 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
565 dim_extent
= mpz_get_si (array
->shape
[i
]);
566 dim_stride
= tmpstride
[i
];
570 extent
[n
] = mpz_get_si (array
->shape
[i
]);
571 sstride
[n
] = tmpstride
[i
];
572 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
581 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
583 *dest
= op (*dest
, gfc_copy_expr (*src
));
590 while (!done
&& count
[n
] == extent
[n
])
593 base
-= sstride
[n
] * extent
[n
];
594 dest
-= dstride
[n
] * extent
[n
];
597 if (n
< result
->rank
)
608 /* Place updated expression in result constructor. */
609 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
610 for (i
= 0; i
< resultsize
; ++i
)
613 result_ctor
->expr
= post_op (result_ctor
->expr
, resultvec
[i
]);
615 result_ctor
->expr
= resultvec
[i
];
616 result_ctor
= gfc_constructor_next (result_ctor
);
620 gfc_free (resultvec
);
626 simplify_transformation (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
627 int init_val
, transformational_op op
)
631 if (!is_constant_array_expr (array
)
632 || !gfc_is_constant_expr (dim
))
636 && !is_constant_array_expr (mask
)
637 && mask
->expr_type
!= EXPR_CONSTANT
)
640 result
= transformational_result (array
, dim
, array
->ts
.type
,
641 array
->ts
.kind
, &array
->where
);
642 init_result_expr (result
, init_val
, NULL
);
644 return !dim
|| array
->rank
== 1 ?
645 simplify_transformation_to_scalar (result
, array
, mask
, op
) :
646 simplify_transformation_to_array (result
, array
, dim
, mask
, op
, NULL
);
650 /********************** Simplification functions *****************************/
653 gfc_simplify_abs (gfc_expr
*e
)
657 if (e
->expr_type
!= EXPR_CONSTANT
)
663 result
= gfc_get_constant_expr (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
664 mpz_abs (result
->value
.integer
, e
->value
.integer
);
665 return range_check (result
, "IABS");
668 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
669 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
670 return range_check (result
, "ABS");
673 gfc_set_model_kind (e
->ts
.kind
);
674 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
675 mpc_abs (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
676 return range_check (result
, "CABS");
679 gfc_internal_error ("gfc_simplify_abs(): Bad type");
685 simplify_achar_char (gfc_expr
*e
, gfc_expr
*k
, const char *name
, bool ascii
)
689 bool too_large
= false;
691 if (e
->expr_type
!= EXPR_CONSTANT
)
694 kind
= get_kind (BT_CHARACTER
, k
, name
, gfc_default_character_kind
);
696 return &gfc_bad_expr
;
698 if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
700 gfc_error ("Argument of %s function at %L is negative", name
,
702 return &gfc_bad_expr
;
705 if (ascii
&& gfc_option
.warn_surprising
706 && mpz_cmp_si (e
->value
.integer
, 127) > 0)
707 gfc_warning ("Argument of %s function at %L outside of range [0,127]",
710 if (kind
== 1 && mpz_cmp_si (e
->value
.integer
, 255) > 0)
715 mpz_init_set_ui (t
, 2);
716 mpz_pow_ui (t
, t
, 32);
717 mpz_sub_ui (t
, t
, 1);
718 if (mpz_cmp (e
->value
.integer
, t
) > 0)
725 gfc_error ("Argument of %s function at %L is too large for the "
726 "collating sequence of kind %d", name
, &e
->where
, kind
);
727 return &gfc_bad_expr
;
730 result
= gfc_get_character_expr (kind
, &e
->where
, NULL
, 1);
731 result
->value
.character
.string
[0] = mpz_get_ui (e
->value
.integer
);
738 /* We use the processor's collating sequence, because all
739 systems that gfortran currently works on are ASCII. */
742 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
744 return simplify_achar_char (e
, k
, "ACHAR", true);
749 gfc_simplify_acos (gfc_expr
*x
)
753 if (x
->expr_type
!= EXPR_CONSTANT
)
759 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
760 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
762 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
764 return &gfc_bad_expr
;
766 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
767 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
771 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
772 mpc_acos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
776 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
779 return range_check (result
, "ACOS");
783 gfc_simplify_acosh (gfc_expr
*x
)
787 if (x
->expr_type
!= EXPR_CONSTANT
)
793 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
795 gfc_error ("Argument of ACOSH at %L must not be less than 1",
797 return &gfc_bad_expr
;
800 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
801 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
805 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
806 mpc_acosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
810 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
813 return range_check (result
, "ACOSH");
817 gfc_simplify_adjustl (gfc_expr
*e
)
823 if (e
->expr_type
!= EXPR_CONSTANT
)
826 len
= e
->value
.character
.length
;
828 for (count
= 0, i
= 0; i
< len
; ++i
)
830 ch
= e
->value
.character
.string
[i
];
836 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
837 for (i
= 0; i
< len
- count
; ++i
)
838 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
845 gfc_simplify_adjustr (gfc_expr
*e
)
851 if (e
->expr_type
!= EXPR_CONSTANT
)
854 len
= e
->value
.character
.length
;
856 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
858 ch
= e
->value
.character
.string
[i
];
864 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
865 for (i
= 0; i
< count
; ++i
)
866 result
->value
.character
.string
[i
] = ' ';
868 for (i
= count
; i
< len
; ++i
)
869 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
876 gfc_simplify_aimag (gfc_expr
*e
)
880 if (e
->expr_type
!= EXPR_CONSTANT
)
883 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
884 mpfr_set (result
->value
.real
, mpc_imagref (e
->value
.complex), GFC_RND_MODE
);
886 return range_check (result
, "AIMAG");
891 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
893 gfc_expr
*rtrunc
, *result
;
896 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
898 return &gfc_bad_expr
;
900 if (e
->expr_type
!= EXPR_CONSTANT
)
903 rtrunc
= gfc_copy_expr (e
);
904 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
906 result
= gfc_real2real (rtrunc
, kind
);
908 gfc_free_expr (rtrunc
);
910 return range_check (result
, "AINT");
915 gfc_simplify_all (gfc_expr
*mask
, gfc_expr
*dim
)
917 return simplify_transformation (mask
, dim
, NULL
, true, gfc_and
);
922 gfc_simplify_dint (gfc_expr
*e
)
924 gfc_expr
*rtrunc
, *result
;
926 if (e
->expr_type
!= EXPR_CONSTANT
)
929 rtrunc
= gfc_copy_expr (e
);
930 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
932 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
934 gfc_free_expr (rtrunc
);
936 return range_check (result
, "DINT");
941 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
946 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
948 return &gfc_bad_expr
;
950 if (e
->expr_type
!= EXPR_CONSTANT
)
953 result
= gfc_get_constant_expr (e
->ts
.type
, kind
, &e
->where
);
954 mpfr_round (result
->value
.real
, e
->value
.real
);
956 return range_check (result
, "ANINT");
961 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
966 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
969 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
974 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
975 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
976 return range_check (result
, "AND");
979 return gfc_get_logical_expr (kind
, &x
->where
,
980 x
->value
.logical
&& y
->value
.logical
);
989 gfc_simplify_any (gfc_expr
*mask
, gfc_expr
*dim
)
991 return simplify_transformation (mask
, dim
, NULL
, false, gfc_or
);
996 gfc_simplify_dnint (gfc_expr
*e
)
1000 if (e
->expr_type
!= EXPR_CONSTANT
)
1003 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &e
->where
);
1004 mpfr_round (result
->value
.real
, e
->value
.real
);
1006 return range_check (result
, "DNINT");
1011 gfc_simplify_asin (gfc_expr
*x
)
1015 if (x
->expr_type
!= EXPR_CONSTANT
)
1021 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1022 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1024 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1026 return &gfc_bad_expr
;
1028 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1029 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1033 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1034 mpc_asin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1038 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1041 return range_check (result
, "ASIN");
1046 gfc_simplify_asinh (gfc_expr
*x
)
1050 if (x
->expr_type
!= EXPR_CONSTANT
)
1053 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1058 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1062 mpc_asinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1066 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1069 return range_check (result
, "ASINH");
1074 gfc_simplify_atan (gfc_expr
*x
)
1078 if (x
->expr_type
!= EXPR_CONSTANT
)
1081 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1086 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1090 mpc_atan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1094 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1097 return range_check (result
, "ATAN");
1102 gfc_simplify_atanh (gfc_expr
*x
)
1106 if (x
->expr_type
!= EXPR_CONSTANT
)
1112 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
1113 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
1115 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1117 return &gfc_bad_expr
;
1119 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1120 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1124 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1125 mpc_atanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1129 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1132 return range_check (result
, "ATANH");
1137 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1141 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1144 if (mpfr_sgn (y
->value
.real
) == 0 && mpfr_sgn (x
->value
.real
) == 0)
1146 gfc_error ("If first argument of ATAN2 %L is zero, then the "
1147 "second argument must not be zero", &x
->where
);
1148 return &gfc_bad_expr
;
1151 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1152 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1154 return range_check (result
, "ATAN2");
1159 gfc_simplify_bessel_j0 (gfc_expr
*x
)
1163 if (x
->expr_type
!= EXPR_CONSTANT
)
1166 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1167 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1169 return range_check (result
, "BESSEL_J0");
1174 gfc_simplify_bessel_j1 (gfc_expr
*x
)
1178 if (x
->expr_type
!= EXPR_CONSTANT
)
1181 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1182 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1184 return range_check (result
, "BESSEL_J1");
1189 gfc_simplify_bessel_jn (gfc_expr
*order
, gfc_expr
*x
)
1194 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1197 n
= mpz_get_si (order
->value
.integer
);
1198 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1199 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1201 return range_check (result
, "BESSEL_JN");
1205 /* Simplify transformational form of JN and YN. */
1208 gfc_simplify_bessel_n2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
,
1215 mpfr_t x2rev
, last1
, last2
;
1217 if (x
->expr_type
!= EXPR_CONSTANT
|| order1
->expr_type
!= EXPR_CONSTANT
1218 || order2
->expr_type
!= EXPR_CONSTANT
)
1221 n1
= mpz_get_si (order1
->value
.integer
);
1222 n2
= mpz_get_si (order2
->value
.integer
);
1223 result
= gfc_get_array_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1225 result
->shape
= gfc_get_shape (1);
1226 mpz_init_set_ui (result
->shape
[0], MAX (n2
-n1
+1, 0));
1231 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1232 YN(N, 0.0) = -Inf. */
1234 if (mpfr_cmp_ui (x
->value
.real
, 0.0) == 0)
1236 if (!jn
&& gfc_option
.flag_range_check
)
1238 gfc_error ("Result of BESSEL_YN is -INF at %L", &result
->where
);
1239 gfc_free_expr (result
);
1240 return &gfc_bad_expr
;
1245 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1246 mpfr_set_ui (e
->value
.real
, 1, GFC_RND_MODE
);
1247 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1252 for (i
= n1
; i
<= n2
; i
++)
1254 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1256 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
1258 mpfr_set_inf (e
->value
.real
, -1);
1259 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1266 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1267 are stable for downward recursion and Neumann functions are stable
1268 for upward recursion. It is
1270 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1271 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1272 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1274 gfc_set_model_kind (x
->ts
.kind
);
1276 /* Get first recursion anchor. */
1280 mpfr_jn (last1
, n2
, x
->value
.real
, GFC_RND_MODE
);
1282 mpfr_yn (last1
, n1
, x
->value
.real
, GFC_RND_MODE
);
1284 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1285 mpfr_set (e
->value
.real
, last1
, GFC_RND_MODE
);
1286 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1290 gfc_free_expr (result
);
1291 return &gfc_bad_expr
;
1293 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1301 /* Get second recursion anchor. */
1305 mpfr_jn (last2
, n2
-1, x
->value
.real
, GFC_RND_MODE
);
1307 mpfr_yn (last2
, n1
+1, x
->value
.real
, GFC_RND_MODE
);
1309 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1310 mpfr_set (e
->value
.real
, last2
, GFC_RND_MODE
);
1311 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1316 gfc_free_expr (result
);
1317 return &gfc_bad_expr
;
1320 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
, -2);
1322 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1331 /* Start actual recursion. */
1334 mpfr_ui_div (x2rev
, 2, x
->value
.real
, GFC_RND_MODE
);
1336 for (i
= 2; i
<= n2
-n1
; i
++)
1338 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1340 /* Special case: For YN, if the previous N gave -INF, set
1341 also N+1 to -INF. */
1342 if (!jn
&& !gfc_option
.flag_range_check
&& mpfr_inf_p (last2
))
1344 mpfr_set_inf (e
->value
.real
, -1);
1345 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1350 mpfr_mul_si (e
->value
.real
, x2rev
, jn
? (n2
-i
+1) : (n1
+i
-1),
1352 mpfr_mul (e
->value
.real
, e
->value
.real
, last2
, GFC_RND_MODE
);
1353 mpfr_sub (e
->value
.real
, e
->value
.real
, last1
, GFC_RND_MODE
);
1355 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1359 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
,
1362 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1364 mpfr_set (last1
, last2
, GFC_RND_MODE
);
1365 mpfr_set (last2
, e
->value
.real
, GFC_RND_MODE
);
1378 gfc_free_expr (result
);
1379 return &gfc_bad_expr
;
1384 gfc_simplify_bessel_jn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1386 return gfc_simplify_bessel_n2 (order1
, order2
, x
, true);
1391 gfc_simplify_bessel_y0 (gfc_expr
*x
)
1395 if (x
->expr_type
!= EXPR_CONSTANT
)
1398 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1399 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1401 return range_check (result
, "BESSEL_Y0");
1406 gfc_simplify_bessel_y1 (gfc_expr
*x
)
1410 if (x
->expr_type
!= EXPR_CONSTANT
)
1413 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1414 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1416 return range_check (result
, "BESSEL_Y1");
1421 gfc_simplify_bessel_yn (gfc_expr
*order
, gfc_expr
*x
)
1426 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1429 n
= mpz_get_si (order
->value
.integer
);
1430 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1431 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1433 return range_check (result
, "BESSEL_YN");
1438 gfc_simplify_bessel_yn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1440 return gfc_simplify_bessel_n2 (order1
, order2
, x
, false);
1445 gfc_simplify_bit_size (gfc_expr
*e
)
1447 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1448 return gfc_get_int_expr (e
->ts
.kind
, &e
->where
,
1449 gfc_integer_kinds
[i
].bit_size
);
1454 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
1458 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
1461 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
1462 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
, false);
1464 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
,
1465 mpz_tstbit (e
->value
.integer
, b
));
1470 compare_bitwise (gfc_expr
*i
, gfc_expr
*j
)
1475 gcc_assert (i
->ts
.type
== BT_INTEGER
);
1476 gcc_assert (j
->ts
.type
== BT_INTEGER
);
1478 mpz_init_set (x
, i
->value
.integer
);
1479 k
= gfc_validate_kind (i
->ts
.type
, i
->ts
.kind
, false);
1480 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
1482 mpz_init_set (y
, j
->value
.integer
);
1483 k
= gfc_validate_kind (j
->ts
.type
, j
->ts
.kind
, false);
1484 convert_mpz_to_unsigned (y
, gfc_integer_kinds
[k
].bit_size
);
1486 res
= mpz_cmp (x
, y
);
1494 gfc_simplify_bge (gfc_expr
*i
, gfc_expr
*j
)
1496 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1499 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1500 compare_bitwise (i
, j
) >= 0);
1505 gfc_simplify_bgt (gfc_expr
*i
, gfc_expr
*j
)
1507 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1510 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1511 compare_bitwise (i
, j
) > 0);
1516 gfc_simplify_ble (gfc_expr
*i
, gfc_expr
*j
)
1518 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1521 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1522 compare_bitwise (i
, j
) <= 0);
1527 gfc_simplify_blt (gfc_expr
*i
, gfc_expr
*j
)
1529 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1532 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1533 compare_bitwise (i
, j
) < 0);
1538 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
1540 gfc_expr
*ceil
, *result
;
1543 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
1545 return &gfc_bad_expr
;
1547 if (e
->expr_type
!= EXPR_CONSTANT
)
1550 ceil
= gfc_copy_expr (e
);
1551 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
1553 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
1554 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
, &e
->where
);
1556 gfc_free_expr (ceil
);
1558 return range_check (result
, "CEILING");
1563 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
1565 return simplify_achar_char (e
, k
, "CHAR", false);
1569 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1572 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
1576 if (convert_boz (x
, kind
) == &gfc_bad_expr
)
1577 return &gfc_bad_expr
;
1579 if (convert_boz (y
, kind
) == &gfc_bad_expr
)
1580 return &gfc_bad_expr
;
1582 if (x
->expr_type
!= EXPR_CONSTANT
1583 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1586 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &x
->where
);
1591 mpc_set_z (result
->value
.complex, x
->value
.integer
, GFC_MPC_RND_MODE
);
1595 mpc_set_fr (result
->value
.complex, x
->value
.real
, GFC_RND_MODE
);
1599 mpc_set (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1603 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1607 return range_check (result
, name
);
1612 mpfr_set_z (mpc_imagref (result
->value
.complex),
1613 y
->value
.integer
, GFC_RND_MODE
);
1617 mpfr_set (mpc_imagref (result
->value
.complex),
1618 y
->value
.real
, GFC_RND_MODE
);
1622 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1625 return range_check (result
, name
);
1630 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
1634 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_complex_kind
);
1636 return &gfc_bad_expr
;
1638 return simplify_cmplx ("CMPLX", x
, y
, kind
);
1643 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
1647 if (x
->ts
.type
== BT_INTEGER
&& y
->ts
.type
== BT_INTEGER
)
1648 kind
= gfc_default_complex_kind
;
1649 else if (x
->ts
.type
== BT_REAL
|| y
->ts
.type
== BT_INTEGER
)
1651 else if (x
->ts
.type
== BT_INTEGER
|| y
->ts
.type
== BT_REAL
)
1653 else if (x
->ts
.type
== BT_REAL
&& y
->ts
.type
== BT_REAL
)
1654 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
1658 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1663 gfc_simplify_conjg (gfc_expr
*e
)
1667 if (e
->expr_type
!= EXPR_CONSTANT
)
1670 result
= gfc_copy_expr (e
);
1671 mpc_conj (result
->value
.complex, result
->value
.complex, GFC_MPC_RND_MODE
);
1673 return range_check (result
, "CONJG");
1678 gfc_simplify_cos (gfc_expr
*x
)
1682 if (x
->expr_type
!= EXPR_CONSTANT
)
1685 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1690 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1694 gfc_set_model_kind (x
->ts
.kind
);
1695 mpc_cos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1699 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1702 return range_check (result
, "COS");
1707 gfc_simplify_cosh (gfc_expr
*x
)
1711 if (x
->expr_type
!= EXPR_CONSTANT
)
1714 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1719 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1723 mpc_cosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1730 return range_check (result
, "COSH");
1735 gfc_simplify_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1739 if (!is_constant_array_expr (mask
)
1740 || !gfc_is_constant_expr (dim
)
1741 || !gfc_is_constant_expr (kind
))
1744 result
= transformational_result (mask
, dim
,
1746 get_kind (BT_INTEGER
, kind
, "COUNT",
1747 gfc_default_integer_kind
),
1750 init_result_expr (result
, 0, NULL
);
1752 /* Passing MASK twice, once as data array, once as mask.
1753 Whenever gfc_count is called, '1' is added to the result. */
1754 return !dim
|| mask
->rank
== 1 ?
1755 simplify_transformation_to_scalar (result
, mask
, mask
, gfc_count
) :
1756 simplify_transformation_to_array (result
, mask
, dim
, mask
, gfc_count
, NULL
);
1761 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1763 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
1768 gfc_simplify_dble (gfc_expr
*e
)
1770 gfc_expr
*result
= NULL
;
1772 if (e
->expr_type
!= EXPR_CONSTANT
)
1775 if (convert_boz (e
, gfc_default_double_kind
) == &gfc_bad_expr
)
1776 return &gfc_bad_expr
;
1778 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
1779 if (result
== &gfc_bad_expr
)
1780 return &gfc_bad_expr
;
1782 return range_check (result
, "DBLE");
1787 gfc_simplify_digits (gfc_expr
*x
)
1791 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1796 digits
= gfc_integer_kinds
[i
].digits
;
1801 digits
= gfc_real_kinds
[i
].digits
;
1808 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
1813 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
1818 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1821 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1822 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
1827 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
1828 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1830 mpz_set_ui (result
->value
.integer
, 0);
1835 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
1836 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
1839 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1844 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1847 return range_check (result
, "DIM");
1852 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1854 if (!is_constant_array_expr (vector_a
)
1855 || !is_constant_array_expr (vector_b
))
1858 gcc_assert (vector_a
->rank
== 1);
1859 gcc_assert (vector_b
->rank
== 1);
1860 gcc_assert (gfc_compare_types (&vector_a
->ts
, &vector_b
->ts
));
1862 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0);
1867 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
1869 gfc_expr
*a1
, *a2
, *result
;
1871 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1874 a1
= gfc_real2real (x
, gfc_default_double_kind
);
1875 a2
= gfc_real2real (y
, gfc_default_double_kind
);
1877 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
1878 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
1883 return range_check (result
, "DPROD");
1888 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
1892 int i
, k
, size
, shift
;
1894 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
1895 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
1898 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
1899 size
= gfc_integer_kinds
[k
].bit_size
;
1901 if (gfc_extract_int (shiftarg
, &shift
) != NULL
)
1903 gfc_error ("Invalid SHIFT argument of DSHIFTL at %L", &shiftarg
->where
);
1904 return &gfc_bad_expr
;
1907 gcc_assert (shift
>= 0 && shift
<= size
);
1909 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
1911 shift
= size
- shift
;
1913 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
1914 mpz_set_ui (result
->value
.integer
, 0);
1916 for (i
= 0; i
< shift
; i
++)
1917 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
1918 mpz_setbit (result
->value
.integer
, i
);
1920 for (i
= 0; i
< size
- shift
; i
++)
1921 if (mpz_tstbit (arg1
->value
.integer
, i
))
1922 mpz_setbit (result
->value
.integer
, shift
+ i
);
1924 /* Convert to a signed value. */
1925 convert_mpz_to_signed (result
->value
.integer
, size
);
1932 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
1934 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
1939 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
1941 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
1946 gfc_simplify_erf (gfc_expr
*x
)
1950 if (x
->expr_type
!= EXPR_CONSTANT
)
1953 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1954 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1956 return range_check (result
, "ERF");
1961 gfc_simplify_erfc (gfc_expr
*x
)
1965 if (x
->expr_type
!= EXPR_CONSTANT
)
1968 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1969 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1971 return range_check (result
, "ERFC");
1975 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
1977 #define MAX_ITER 200
1978 #define ARG_LIMIT 12
1980 /* Calculate ERFC_SCALED directly by its definition:
1982 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
1984 using a large precision for intermediate results. This is used for all
1985 but large values of the argument. */
1987 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
1992 prec
= mpfr_get_default_prec ();
1993 mpfr_set_default_prec (10 * prec
);
1998 mpfr_set (a
, arg
, GFC_RND_MODE
);
1999 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2000 mpfr_exp (b
, b
, GFC_RND_MODE
);
2001 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2002 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2004 mpfr_set (res
, a
, GFC_RND_MODE
);
2005 mpfr_set_default_prec (prec
);
2011 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2013 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2014 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2017 This is used for large values of the argument. Intermediate calculations
2018 are performed with twice the precision. We don't do a fixed number of
2019 iterations of the sum, but stop when it has converged to the required
2022 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2024 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2029 prec
= mpfr_get_default_prec ();
2030 mpfr_set_default_prec (2 * prec
);
2040 mpfr_init (sumtrunc
);
2041 mpfr_set_prec (oldsum
, prec
);
2042 mpfr_set_prec (sumtrunc
, prec
);
2044 mpfr_set (x
, arg
, GFC_RND_MODE
);
2045 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2046 mpz_set_ui (num
, 1);
2048 mpfr_set (u
, x
, GFC_RND_MODE
);
2049 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2050 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2051 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2053 for (i
= 1; i
< MAX_ITER
; i
++)
2055 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2057 mpz_mul_ui (num
, num
, 2 * i
- 1);
2060 mpfr_set (w
, u
, GFC_RND_MODE
);
2061 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2063 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2064 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2066 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2068 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2069 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2073 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2075 gcc_assert (i
< MAX_ITER
);
2077 /* Divide by x * sqrt(Pi). */
2078 mpfr_const_pi (u
, GFC_RND_MODE
);
2079 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2080 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2081 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2083 mpfr_set (res
, sum
, GFC_RND_MODE
);
2084 mpfr_set_default_prec (prec
);
2086 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2092 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2096 if (x
->expr_type
!= EXPR_CONSTANT
)
2099 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2100 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2101 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2103 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2105 return range_check (result
, "ERFC_SCALED");
2113 gfc_simplify_epsilon (gfc_expr
*e
)
2118 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2120 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2121 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2123 return range_check (result
, "EPSILON");
2128 gfc_simplify_exp (gfc_expr
*x
)
2132 if (x
->expr_type
!= EXPR_CONSTANT
)
2135 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2140 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2144 gfc_set_model_kind (x
->ts
.kind
);
2145 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2149 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2152 return range_check (result
, "EXP");
2157 gfc_simplify_exponent (gfc_expr
*x
)
2162 if (x
->expr_type
!= EXPR_CONSTANT
)
2165 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2168 gfc_set_model (x
->value
.real
);
2170 if (mpfr_sgn (x
->value
.real
) == 0)
2172 mpz_set_ui (result
->value
.integer
, 0);
2176 i
= (int) mpfr_get_exp (x
->value
.real
);
2177 mpz_set_si (result
->value
.integer
, i
);
2179 return range_check (result
, "EXPONENT");
2184 gfc_simplify_float (gfc_expr
*a
)
2188 if (a
->expr_type
!= EXPR_CONSTANT
)
2193 if (convert_boz (a
, gfc_default_real_kind
) == &gfc_bad_expr
)
2194 return &gfc_bad_expr
;
2196 result
= gfc_copy_expr (a
);
2199 result
= gfc_int2real (a
, gfc_default_real_kind
);
2201 return range_check (result
, "FLOAT");
2206 is_last_ref_vtab (gfc_expr
*e
)
2209 gfc_component
*comp
= NULL
;
2211 if (e
->expr_type
!= EXPR_VARIABLE
)
2214 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2215 if (ref
->type
== REF_COMPONENT
)
2216 comp
= ref
->u
.c
.component
;
2218 if (!e
->ref
|| !comp
)
2219 return e
->symtree
->n
.sym
->attr
.vtab
;
2221 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
2229 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
2231 /* Avoid simplification of resolved symbols. */
2232 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
2235 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
2236 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2237 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2239 /* Return .false. if the dynamic type can never be the same. */
2240 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
2241 && !gfc_type_is_extension_of
2242 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2243 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
2244 && !gfc_type_is_extension_of
2245 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
2246 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
2247 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
2248 && !gfc_type_is_extension_of
2250 mold
->ts
.u
.derived
->components
->ts
.u
.derived
)
2251 && !gfc_type_is_extension_of
2252 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2254 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
2255 && !gfc_type_is_extension_of
2256 (mold
->ts
.u
.derived
,
2257 a
->ts
.u
.derived
->components
->ts
.u
.derived
)))
2258 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2260 if (mold
->ts
.type
== BT_DERIVED
2261 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2262 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
2263 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
2270 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
2272 /* Avoid simplification of resolved symbols. */
2273 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
2276 /* Return .false. if the dynamic type can never be the
2278 if ((a
->ts
.type
== BT_CLASS
|| b
->ts
.type
== BT_CLASS
)
2279 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
2280 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
2281 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2283 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
2286 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2287 gfc_compare_derived_types (a
->ts
.u
.derived
,
2293 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
2299 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
2301 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2303 if (e
->expr_type
!= EXPR_CONSTANT
)
2306 gfc_set_model_kind (kind
);
2309 mpfr_floor (floor
, e
->value
.real
);
2311 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
2312 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
2316 return range_check (result
, "FLOOR");
2321 gfc_simplify_fraction (gfc_expr
*x
)
2324 mpfr_t absv
, exp
, pow2
;
2326 if (x
->expr_type
!= EXPR_CONSTANT
)
2329 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
2331 if (mpfr_sgn (x
->value
.real
) == 0)
2333 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2337 gfc_set_model_kind (x
->ts
.kind
);
2342 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
2343 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
2345 mpfr_trunc (exp
, exp
);
2346 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
2348 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
2350 mpfr_div (result
->value
.real
, absv
, pow2
, GFC_RND_MODE
);
2352 mpfr_clears (exp
, absv
, pow2
, NULL
);
2354 return range_check (result
, "FRACTION");
2359 gfc_simplify_gamma (gfc_expr
*x
)
2363 if (x
->expr_type
!= EXPR_CONSTANT
)
2366 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2367 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2369 return range_check (result
, "GAMMA");
2374 gfc_simplify_huge (gfc_expr
*e
)
2379 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2380 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2385 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2389 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
2401 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
2405 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2408 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2409 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
2410 return range_check (result
, "HYPOT");
2414 /* We use the processor's collating sequence, because all
2415 systems that gfortran currently works on are ASCII. */
2418 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
2424 if (e
->expr_type
!= EXPR_CONSTANT
)
2427 if (e
->value
.character
.length
!= 1)
2429 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
2430 return &gfc_bad_expr
;
2433 index
= e
->value
.character
.string
[0];
2435 if (gfc_option
.warn_surprising
&& index
> 127)
2436 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
2439 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
2441 return &gfc_bad_expr
;
2443 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2445 return range_check (result
, "IACHAR");
2450 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
2452 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2453 gcc_assert (result
->ts
.type
== BT_INTEGER
2454 && result
->expr_type
== EXPR_CONSTANT
);
2456 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2462 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2464 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
2469 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
2471 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2472 gcc_assert (result
->ts
.type
== BT_INTEGER
2473 && result
->expr_type
== EXPR_CONSTANT
);
2475 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2481 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2483 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
2488 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
2492 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2495 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2496 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2498 return range_check (result
, "IAND");
2503 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
2508 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2511 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
2513 gfc_error ("Invalid second argument of IBCLR at %L", &y
->where
);
2514 return &gfc_bad_expr
;
2517 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2519 if (pos
>= gfc_integer_kinds
[k
].bit_size
)
2521 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
2523 return &gfc_bad_expr
;
2526 result
= gfc_copy_expr (x
);
2528 convert_mpz_to_unsigned (result
->value
.integer
,
2529 gfc_integer_kinds
[k
].bit_size
);
2531 mpz_clrbit (result
->value
.integer
, pos
);
2533 convert_mpz_to_signed (result
->value
.integer
,
2534 gfc_integer_kinds
[k
].bit_size
);
2541 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
2548 if (x
->expr_type
!= EXPR_CONSTANT
2549 || y
->expr_type
!= EXPR_CONSTANT
2550 || z
->expr_type
!= EXPR_CONSTANT
)
2553 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
2555 gfc_error ("Invalid second argument of IBITS at %L", &y
->where
);
2556 return &gfc_bad_expr
;
2559 if (gfc_extract_int (z
, &len
) != NULL
|| len
< 0)
2561 gfc_error ("Invalid third argument of IBITS at %L", &z
->where
);
2562 return &gfc_bad_expr
;
2565 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
2567 bitsize
= gfc_integer_kinds
[k
].bit_size
;
2569 if (pos
+ len
> bitsize
)
2571 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2572 "bit size at %L", &y
->where
);
2573 return &gfc_bad_expr
;
2576 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2577 convert_mpz_to_unsigned (result
->value
.integer
,
2578 gfc_integer_kinds
[k
].bit_size
);
2580 bits
= XCNEWVEC (int, bitsize
);
2582 for (i
= 0; i
< bitsize
; i
++)
2585 for (i
= 0; i
< len
; i
++)
2586 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
2588 for (i
= 0; i
< bitsize
; i
++)
2591 mpz_clrbit (result
->value
.integer
, i
);
2592 else if (bits
[i
] == 1)
2593 mpz_setbit (result
->value
.integer
, i
);
2595 gfc_internal_error ("IBITS: Bad bit");
2600 convert_mpz_to_signed (result
->value
.integer
,
2601 gfc_integer_kinds
[k
].bit_size
);
2608 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
2613 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2616 if (gfc_extract_int (y
, &pos
) != NULL
|| pos
< 0)
2618 gfc_error ("Invalid second argument of IBSET at %L", &y
->where
);
2619 return &gfc_bad_expr
;
2622 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2624 if (pos
>= gfc_integer_kinds
[k
].bit_size
)
2626 gfc_error ("Second argument of IBSET exceeds bit size at %L",
2628 return &gfc_bad_expr
;
2631 result
= gfc_copy_expr (x
);
2633 convert_mpz_to_unsigned (result
->value
.integer
,
2634 gfc_integer_kinds
[k
].bit_size
);
2636 mpz_setbit (result
->value
.integer
, pos
);
2638 convert_mpz_to_signed (result
->value
.integer
,
2639 gfc_integer_kinds
[k
].bit_size
);
2646 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
2652 if (e
->expr_type
!= EXPR_CONSTANT
)
2655 if (e
->value
.character
.length
!= 1)
2657 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
2658 return &gfc_bad_expr
;
2661 index
= e
->value
.character
.string
[0];
2663 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
2665 return &gfc_bad_expr
;
2667 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2669 return range_check (result
, "ICHAR");
2674 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
2678 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2681 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2682 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2684 return range_check (result
, "IEOR");
2689 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
2692 int back
, len
, lensub
;
2693 int i
, j
, k
, count
, index
= 0, start
;
2695 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
2696 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
2699 if (b
!= NULL
&& b
->value
.logical
!= 0)
2704 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
2706 return &gfc_bad_expr
;
2708 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
2710 len
= x
->value
.character
.length
;
2711 lensub
= y
->value
.character
.length
;
2715 mpz_set_si (result
->value
.integer
, 0);
2723 mpz_set_si (result
->value
.integer
, 1);
2726 else if (lensub
== 1)
2728 for (i
= 0; i
< len
; i
++)
2730 for (j
= 0; j
< lensub
; j
++)
2732 if (y
->value
.character
.string
[j
]
2733 == x
->value
.character
.string
[i
])
2743 for (i
= 0; i
< len
; i
++)
2745 for (j
= 0; j
< lensub
; j
++)
2747 if (y
->value
.character
.string
[j
]
2748 == x
->value
.character
.string
[i
])
2753 for (k
= 0; k
< lensub
; k
++)
2755 if (y
->value
.character
.string
[k
]
2756 == x
->value
.character
.string
[k
+ start
])
2760 if (count
== lensub
)
2775 mpz_set_si (result
->value
.integer
, len
+ 1);
2778 else if (lensub
== 1)
2780 for (i
= 0; i
< len
; i
++)
2782 for (j
= 0; j
< lensub
; j
++)
2784 if (y
->value
.character
.string
[j
]
2785 == x
->value
.character
.string
[len
- i
])
2787 index
= len
- i
+ 1;
2795 for (i
= 0; i
< len
; i
++)
2797 for (j
= 0; j
< lensub
; j
++)
2799 if (y
->value
.character
.string
[j
]
2800 == x
->value
.character
.string
[len
- i
])
2803 if (start
<= len
- lensub
)
2806 for (k
= 0; k
< lensub
; k
++)
2807 if (y
->value
.character
.string
[k
]
2808 == x
->value
.character
.string
[k
+ start
])
2811 if (count
== lensub
)
2828 mpz_set_si (result
->value
.integer
, index
);
2829 return range_check (result
, "INDEX");
2834 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
2836 gfc_expr
*result
= NULL
;
2838 if (e
->expr_type
!= EXPR_CONSTANT
)
2841 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
2842 if (result
== &gfc_bad_expr
)
2843 return &gfc_bad_expr
;
2845 return range_check (result
, name
);
2850 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
2854 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
2856 return &gfc_bad_expr
;
2858 return simplify_intconv (e
, kind
, "INT");
2862 gfc_simplify_int2 (gfc_expr
*e
)
2864 return simplify_intconv (e
, 2, "INT2");
2869 gfc_simplify_int8 (gfc_expr
*e
)
2871 return simplify_intconv (e
, 8, "INT8");
2876 gfc_simplify_long (gfc_expr
*e
)
2878 return simplify_intconv (e
, 4, "LONG");
2883 gfc_simplify_ifix (gfc_expr
*e
)
2885 gfc_expr
*rtrunc
, *result
;
2887 if (e
->expr_type
!= EXPR_CONSTANT
)
2890 rtrunc
= gfc_copy_expr (e
);
2891 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
2893 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2895 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
2897 gfc_free_expr (rtrunc
);
2899 return range_check (result
, "IFIX");
2904 gfc_simplify_idint (gfc_expr
*e
)
2906 gfc_expr
*rtrunc
, *result
;
2908 if (e
->expr_type
!= EXPR_CONSTANT
)
2911 rtrunc
= gfc_copy_expr (e
);
2912 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
2914 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2916 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
2918 gfc_free_expr (rtrunc
);
2920 return range_check (result
, "IDINT");
2925 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
2929 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2932 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2933 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2935 return range_check (result
, "IOR");
2940 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
2942 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2943 gcc_assert (result
->ts
.type
== BT_INTEGER
2944 && result
->expr_type
== EXPR_CONSTANT
);
2946 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2952 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2954 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
2960 gfc_simplify_is_iostat_end (gfc_expr
*x
)
2962 if (x
->expr_type
!= EXPR_CONSTANT
)
2965 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
2966 mpz_cmp_si (x
->value
.integer
,
2967 LIBERROR_END
) == 0);
2972 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
2974 if (x
->expr_type
!= EXPR_CONSTANT
)
2977 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
2978 mpz_cmp_si (x
->value
.integer
,
2979 LIBERROR_EOR
) == 0);
2984 gfc_simplify_isnan (gfc_expr
*x
)
2986 if (x
->expr_type
!= EXPR_CONSTANT
)
2989 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
2990 mpfr_nan_p (x
->value
.real
));
2994 /* Performs a shift on its first argument. Depending on the last
2995 argument, the shift can be arithmetic, i.e. with filling from the
2996 left like in the SHIFTA intrinsic. */
2998 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
2999 bool arithmetic
, int direction
)
3002 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3004 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3006 if (gfc_extract_int (s
, &shift
) != NULL
)
3008 gfc_error ("Invalid second argument of %s at %L", name
, &s
->where
);
3009 return &gfc_bad_expr
;
3012 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3013 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3015 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3019 mpz_set (result
->value
.integer
, e
->value
.integer
);
3023 if (direction
> 0 && shift
< 0)
3025 /* Left shift, as in SHIFTL. */
3026 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3027 return &gfc_bad_expr
;
3029 else if (direction
< 0)
3031 /* Right shift, as in SHIFTR or SHIFTA. */
3034 gfc_error ("Second argument of %s is negative at %L",
3036 return &gfc_bad_expr
;
3042 ashift
= (shift
>= 0 ? shift
: -shift
);
3044 if (ashift
> bitsize
)
3046 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3047 "at %L", name
, &e
->where
);
3048 return &gfc_bad_expr
;
3051 bits
= XCNEWVEC (int, bitsize
);
3053 for (i
= 0; i
< bitsize
; i
++)
3054 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3059 for (i
= 0; i
< shift
; i
++)
3060 mpz_clrbit (result
->value
.integer
, i
);
3062 for (i
= 0; i
< bitsize
- shift
; i
++)
3065 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3067 mpz_setbit (result
->value
.integer
, i
+ shift
);
3073 if (arithmetic
&& bits
[bitsize
- 1])
3074 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3075 mpz_setbit (result
->value
.integer
, i
);
3077 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3078 mpz_clrbit (result
->value
.integer
, i
);
3080 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3083 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3085 mpz_setbit (result
->value
.integer
, i
- ashift
);
3089 convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3097 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3099 return simplify_shift (e
, s
, "ISHFT", false, 0);
3104 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3106 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3111 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3113 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3118 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3120 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3125 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3127 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3132 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3134 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3139 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3142 int shift
, ashift
, isize
, ssize
, delta
, k
;
3145 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3148 if (gfc_extract_int (s
, &shift
) != NULL
)
3150 gfc_error ("Invalid second argument of ISHFTC at %L", &s
->where
);
3151 return &gfc_bad_expr
;
3154 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3155 isize
= gfc_integer_kinds
[k
].bit_size
;
3159 if (sz
->expr_type
!= EXPR_CONSTANT
)
3162 if (gfc_extract_int (sz
, &ssize
) != NULL
|| ssize
<= 0)
3164 gfc_error ("Invalid third argument of ISHFTC at %L", &sz
->where
);
3165 return &gfc_bad_expr
;
3170 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
3171 "BIT_SIZE of first argument at %L", &s
->where
);
3172 return &gfc_bad_expr
;
3186 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3187 "third argument at %L", &s
->where
);
3189 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3190 "BIT_SIZE of first argument at %L", &s
->where
);
3191 return &gfc_bad_expr
;
3194 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3196 mpz_set (result
->value
.integer
, e
->value
.integer
);
3201 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
3203 bits
= XCNEWVEC (int, ssize
);
3205 for (i
= 0; i
< ssize
; i
++)
3206 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3208 delta
= ssize
- ashift
;
3212 for (i
= 0; i
< delta
; i
++)
3215 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3217 mpz_setbit (result
->value
.integer
, i
+ shift
);
3220 for (i
= delta
; i
< ssize
; i
++)
3223 mpz_clrbit (result
->value
.integer
, i
- delta
);
3225 mpz_setbit (result
->value
.integer
, i
- delta
);
3230 for (i
= 0; i
< ashift
; i
++)
3233 mpz_clrbit (result
->value
.integer
, i
+ delta
);
3235 mpz_setbit (result
->value
.integer
, i
+ delta
);
3238 for (i
= ashift
; i
< ssize
; i
++)
3241 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3243 mpz_setbit (result
->value
.integer
, i
+ shift
);
3247 convert_mpz_to_signed (result
->value
.integer
, isize
);
3255 gfc_simplify_kind (gfc_expr
*e
)
3257 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
3262 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
3263 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
3265 gfc_expr
*l
, *u
, *result
;
3268 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3269 gfc_default_integer_kind
);
3271 return &gfc_bad_expr
;
3273 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3275 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3276 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3277 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
3281 gfc_expr
* dim
= result
;
3282 mpz_set_si (dim
->value
.integer
, d
);
3284 result
= gfc_simplify_size (array
, dim
, kind
);
3285 gfc_free_expr (dim
);
3290 mpz_set_si (result
->value
.integer
, 1);
3295 /* Otherwise, we have a variable expression. */
3296 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
3299 /* The last dimension of an assumed-size array is special. */
3300 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
3301 || (coarray
&& d
== as
->rank
+ as
->corank
))
3303 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
3305 gfc_free_expr (result
);
3306 return gfc_copy_expr (as
->lower
[d
-1]);
3312 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3314 /* Then, we need to know the extent of the given dimension. */
3315 if (coarray
|| ref
->u
.ar
.type
== AR_FULL
)
3320 if (l
->expr_type
!= EXPR_CONSTANT
|| u
== NULL
3321 || u
->expr_type
!= EXPR_CONSTANT
)
3324 if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
3328 mpz_set_si (result
->value
.integer
, 0);
3330 mpz_set_si (result
->value
.integer
, 1);
3334 /* Nonzero extent. */
3336 mpz_set (result
->value
.integer
, u
->value
.integer
);
3338 mpz_set (result
->value
.integer
, l
->value
.integer
);
3345 if (gfc_ref_dimen_size (&ref
->u
.ar
, d
-1, &result
->value
.integer
, NULL
)
3350 mpz_set_si (result
->value
.integer
, (long int) 1);
3354 return range_check (result
, upper
? "UBOUND" : "LBOUND");
3357 gfc_free_expr (result
);
3363 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3369 if (array
->expr_type
!= EXPR_VARIABLE
)
3376 /* Follow any component references. */
3377 as
= array
->symtree
->n
.sym
->as
;
3378 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3383 switch (ref
->u
.ar
.type
)
3390 /* We're done because 'as' has already been set in the
3391 previous iteration. */
3408 as
= ref
->u
.c
.component
->as
;
3420 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
))
3425 /* Multi-dimensional bounds. */
3426 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3430 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
3431 if (upper
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
3433 /* An error message will be emitted in
3434 check_assumed_size_reference (resolve.c). */
3435 return &gfc_bad_expr
;
3438 /* Simplify the bounds for each dimension. */
3439 for (d
= 0; d
< array
->rank
; d
++)
3441 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
3443 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3447 for (j
= 0; j
< d
; j
++)
3448 gfc_free_expr (bounds
[j
]);
3453 /* Allocate the result expression. */
3454 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3455 gfc_default_integer_kind
);
3457 return &gfc_bad_expr
;
3459 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
3461 /* The result is a rank 1 array; its size is the rank of the first
3462 argument to {L,U}BOUND. */
3464 e
->shape
= gfc_get_shape (1);
3465 mpz_init_set_ui (e
->shape
[0], array
->rank
);
3467 /* Create the constructor for this array. */
3468 for (d
= 0; d
< array
->rank
; d
++)
3469 gfc_constructor_append_expr (&e
->value
.constructor
,
3470 bounds
[d
], &e
->where
);
3476 /* A DIM argument is specified. */
3477 if (dim
->expr_type
!= EXPR_CONSTANT
)
3480 d
= mpz_get_si (dim
->value
.integer
);
3482 if (d
< 1 || d
> array
->rank
3483 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
3485 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3486 return &gfc_bad_expr
;
3489 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
3495 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3501 if (array
->expr_type
!= EXPR_VARIABLE
)
3504 /* Follow any component references. */
3505 as
= array
->symtree
->n
.sym
->as
;
3506 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3511 switch (ref
->u
.ar
.type
)
3514 if (ref
->next
== NULL
)
3516 gcc_assert (ref
->u
.ar
.as
->corank
> 0
3517 && ref
->u
.ar
.as
->rank
== 0);
3525 /* We're done because 'as' has already been set in the
3526 previous iteration. */
3543 as
= ref
->u
.c
.component
->as
;
3555 if (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
)
3560 /* Multi-dimensional cobounds. */
3561 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3565 /* Simplify the cobounds for each dimension. */
3566 for (d
= 0; d
< as
->corank
; d
++)
3568 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + array
->rank
,
3569 upper
, as
, ref
, true);
3570 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3574 for (j
= 0; j
< d
; j
++)
3575 gfc_free_expr (bounds
[j
]);
3580 /* Allocate the result expression. */
3581 e
= gfc_get_expr ();
3582 e
->where
= array
->where
;
3583 e
->expr_type
= EXPR_ARRAY
;
3584 e
->ts
.type
= BT_INTEGER
;
3585 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
3586 gfc_default_integer_kind
);
3590 return &gfc_bad_expr
;
3594 /* The result is a rank 1 array; its size is the rank of the first
3595 argument to {L,U}COBOUND. */
3597 e
->shape
= gfc_get_shape (1);
3598 mpz_init_set_ui (e
->shape
[0], as
->corank
);
3600 /* Create the constructor for this array. */
3601 for (d
= 0; d
< as
->corank
; d
++)
3602 gfc_constructor_append_expr (&e
->value
.constructor
,
3603 bounds
[d
], &e
->where
);
3608 /* A DIM argument is specified. */
3609 if (dim
->expr_type
!= EXPR_CONSTANT
)
3612 d
= mpz_get_si (dim
->value
.integer
);
3614 if (d
< 1 || d
> as
->corank
)
3616 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3617 return &gfc_bad_expr
;
3620 return simplify_bound_dim (array
, kind
, d
+array
->rank
, upper
, as
, ref
, true);
3626 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3628 return simplify_bound (array
, dim
, kind
, 0);
3633 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3636 /* return simplify_cobound (array, dim, kind, 0);*/
3638 e
= simplify_cobound (array
, dim
, kind
, 0);
3642 gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
3643 "cobounds at %L", &array
->where
);
3644 return &gfc_bad_expr
;
3648 gfc_simplify_leadz (gfc_expr
*e
)
3650 unsigned long lz
, bs
;
3653 if (e
->expr_type
!= EXPR_CONSTANT
)
3656 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3657 bs
= gfc_integer_kinds
[i
].bit_size
;
3658 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
3660 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
3663 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
3665 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
3670 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
3673 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
3676 return &gfc_bad_expr
;
3678 if (e
->expr_type
== EXPR_CONSTANT
)
3680 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3681 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
3682 return range_check (result
, "LEN");
3684 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
3685 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3686 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
3688 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3689 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
3690 return range_check (result
, "LEN");
3698 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
3702 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
3705 return &gfc_bad_expr
;
3707 if (e
->expr_type
!= EXPR_CONSTANT
)
3710 len
= e
->value
.character
.length
;
3711 for (count
= 0, i
= 1; i
<= len
; i
++)
3712 if (e
->value
.character
.string
[len
- i
] == ' ')
3717 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
3718 return range_check (result
, "LEN_TRIM");
3722 gfc_simplify_lgamma (gfc_expr
*x
)
3727 if (x
->expr_type
!= EXPR_CONSTANT
)
3730 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3731 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
3733 return range_check (result
, "LGAMMA");
3738 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
3740 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3743 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3744 gfc_compare_string (a
, b
) >= 0);
3749 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
3751 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3754 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3755 gfc_compare_string (a
, b
) > 0);
3760 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
3762 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3765 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3766 gfc_compare_string (a
, b
) <= 0);
3771 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
3773 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3776 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3777 gfc_compare_string (a
, b
) < 0);
3782 gfc_simplify_log (gfc_expr
*x
)
3786 if (x
->expr_type
!= EXPR_CONSTANT
)
3789 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3794 if (mpfr_sgn (x
->value
.real
) <= 0)
3796 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3797 "to zero", &x
->where
);
3798 gfc_free_expr (result
);
3799 return &gfc_bad_expr
;
3802 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3806 if ((mpfr_sgn (mpc_realref (x
->value
.complex)) == 0)
3807 && (mpfr_sgn (mpc_imagref (x
->value
.complex)) == 0))
3809 gfc_error ("Complex argument of LOG at %L cannot be zero",
3811 gfc_free_expr (result
);
3812 return &gfc_bad_expr
;
3815 gfc_set_model_kind (x
->ts
.kind
);
3816 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
3820 gfc_internal_error ("gfc_simplify_log: bad type");
3823 return range_check (result
, "LOG");
3828 gfc_simplify_log10 (gfc_expr
*x
)
3832 if (x
->expr_type
!= EXPR_CONSTANT
)
3835 if (mpfr_sgn (x
->value
.real
) <= 0)
3837 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3838 "to zero", &x
->where
);
3839 return &gfc_bad_expr
;
3842 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3843 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3845 return range_check (result
, "LOG10");
3850 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
3854 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
3856 return &gfc_bad_expr
;
3858 if (e
->expr_type
!= EXPR_CONSTANT
)
3861 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
3866 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3869 int row
, result_rows
, col
, result_columns
;
3870 int stride_a
, offset_a
, stride_b
, offset_b
;
3872 if (!is_constant_array_expr (matrix_a
)
3873 || !is_constant_array_expr (matrix_b
))
3876 gcc_assert (gfc_compare_types (&matrix_a
->ts
, &matrix_b
->ts
));
3877 result
= gfc_get_array_expr (matrix_a
->ts
.type
,
3881 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
3884 result_columns
= mpz_get_si (matrix_b
->shape
[0]);
3886 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
3889 result
->shape
= gfc_get_shape (result
->rank
);
3890 mpz_init_set_si (result
->shape
[0], result_columns
);
3892 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
3894 result_rows
= mpz_get_si (matrix_b
->shape
[0]);
3896 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
3900 result
->shape
= gfc_get_shape (result
->rank
);
3901 mpz_init_set_si (result
->shape
[0], result_rows
);
3903 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
3905 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
3906 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
3907 stride_a
= mpz_get_si (matrix_a
->shape
[1]);
3908 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
3911 result
->shape
= gfc_get_shape (result
->rank
);
3912 mpz_init_set_si (result
->shape
[0], result_rows
);
3913 mpz_init_set_si (result
->shape
[1], result_columns
);
3918 offset_a
= offset_b
= 0;
3919 for (col
= 0; col
< result_columns
; ++col
)
3923 for (row
= 0; row
< result_rows
; ++row
)
3925 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
3926 matrix_b
, 1, offset_b
);
3927 gfc_constructor_append_expr (&result
->value
.constructor
,
3933 offset_b
+= stride_b
;
3941 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
3947 if (i
->expr_type
!= EXPR_CONSTANT
)
3950 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
3952 return &gfc_bad_expr
;
3953 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3955 s
= gfc_extract_int (i
, &arg
);
3958 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
3960 /* MASKR(n) = 2^n - 1 */
3961 mpz_set_ui (result
->value
.integer
, 1);
3962 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
3963 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
3965 convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
3972 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
3979 if (i
->expr_type
!= EXPR_CONSTANT
)
3982 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
3984 return &gfc_bad_expr
;
3985 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3987 s
= gfc_extract_int (i
, &arg
);
3990 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
3992 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
3993 mpz_init_set_ui (z
, 1);
3994 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
3995 mpz_set_ui (result
->value
.integer
, 1);
3996 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
3997 gfc_integer_kinds
[k
].bit_size
- arg
);
3998 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4001 convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4008 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4010 if (tsource
->expr_type
!= EXPR_CONSTANT
4011 || fsource
->expr_type
!= EXPR_CONSTANT
4012 || mask
->expr_type
!= EXPR_CONSTANT
)
4015 return gfc_copy_expr (mask
->value
.logical
? tsource
: fsource
);
4020 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4022 mpz_t arg1
, arg2
, mask
;
4025 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4026 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4029 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4031 /* Convert all argument to unsigned. */
4032 mpz_init_set (arg1
, i
->value
.integer
);
4033 mpz_init_set (arg2
, j
->value
.integer
);
4034 mpz_init_set (mask
, mask_expr
->value
.integer
);
4036 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4037 mpz_and (arg1
, arg1
, mask
);
4038 mpz_com (mask
, mask
);
4039 mpz_and (arg2
, arg2
, mask
);
4040 mpz_ior (result
->value
.integer
, arg1
, arg2
);
4050 /* Selects between current value and extremum for simplify_min_max
4051 and simplify_minval_maxval. */
4053 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
)
4055 switch (arg
->ts
.type
)
4058 if (mpz_cmp (arg
->value
.integer
,
4059 extremum
->value
.integer
) * sign
> 0)
4060 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
4064 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4066 mpfr_max (extremum
->value
.real
, extremum
->value
.real
,
4067 arg
->value
.real
, GFC_RND_MODE
);
4069 mpfr_min (extremum
->value
.real
, extremum
->value
.real
,
4070 arg
->value
.real
, GFC_RND_MODE
);
4074 #define LENGTH(x) ((x)->value.character.length)
4075 #define STRING(x) ((x)->value.character.string)
4076 if (LENGTH(extremum
) < LENGTH(arg
))
4078 gfc_char_t
*tmp
= STRING(extremum
);
4080 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
4081 memcpy (STRING(extremum
), tmp
,
4082 LENGTH(extremum
) * sizeof (gfc_char_t
));
4083 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
4084 LENGTH(arg
) - LENGTH(extremum
));
4085 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
4086 LENGTH(extremum
) = LENGTH(arg
);
4090 if (gfc_compare_string (arg
, extremum
) * sign
> 0)
4092 gfc_free (STRING(extremum
));
4093 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
4094 memcpy (STRING(extremum
), STRING(arg
),
4095 LENGTH(arg
) * sizeof (gfc_char_t
));
4096 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
4097 LENGTH(extremum
) - LENGTH(arg
));
4098 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
4105 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4110 /* This function is special since MAX() can take any number of
4111 arguments. The simplified expression is a rewritten version of the
4112 argument list containing at most one constant element. Other
4113 constant elements are deleted. Because the argument list has
4114 already been checked, this function always succeeds. sign is 1 for
4115 MAX(), -1 for MIN(). */
4118 simplify_min_max (gfc_expr
*expr
, int sign
)
4120 gfc_actual_arglist
*arg
, *last
, *extremum
;
4121 gfc_intrinsic_sym
* specific
;
4125 specific
= expr
->value
.function
.isym
;
4127 arg
= expr
->value
.function
.actual
;
4129 for (; arg
; last
= arg
, arg
= arg
->next
)
4131 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
4134 if (extremum
== NULL
)
4140 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
4142 /* Delete the extra constant argument. */
4144 expr
->value
.function
.actual
= arg
->next
;
4146 last
->next
= arg
->next
;
4149 gfc_free_actual_arglist (arg
);
4153 /* If there is one value left, replace the function call with the
4155 if (expr
->value
.function
.actual
->next
!= NULL
)
4158 /* Convert to the correct type and kind. */
4159 if (expr
->ts
.type
!= BT_UNKNOWN
)
4160 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4161 expr
->ts
.type
, expr
->ts
.kind
);
4163 if (specific
->ts
.type
!= BT_UNKNOWN
)
4164 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4165 specific
->ts
.type
, specific
->ts
.kind
);
4167 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
4172 gfc_simplify_min (gfc_expr
*e
)
4174 return simplify_min_max (e
, -1);
4179 gfc_simplify_max (gfc_expr
*e
)
4181 return simplify_min_max (e
, 1);
4185 /* This is a simplified version of simplify_min_max to provide
4186 simplification of minval and maxval for a vector. */
4189 simplify_minval_maxval (gfc_expr
*expr
, int sign
)
4191 gfc_constructor
*c
, *extremum
;
4192 gfc_intrinsic_sym
* specific
;
4195 specific
= expr
->value
.function
.isym
;
4197 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4198 c
; c
= gfc_constructor_next (c
))
4200 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4203 if (extremum
== NULL
)
4209 min_max_choose (c
->expr
, extremum
->expr
, sign
);
4212 if (extremum
== NULL
)
4215 /* Convert to the correct type and kind. */
4216 if (expr
->ts
.type
!= BT_UNKNOWN
)
4217 return gfc_convert_constant (extremum
->expr
,
4218 expr
->ts
.type
, expr
->ts
.kind
);
4220 if (specific
->ts
.type
!= BT_UNKNOWN
)
4221 return gfc_convert_constant (extremum
->expr
,
4222 specific
->ts
.type
, specific
->ts
.kind
);
4224 return gfc_copy_expr (extremum
->expr
);
4229 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4231 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4234 return simplify_minval_maxval (array
, -1);
4239 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4241 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4244 return simplify_minval_maxval (array
, 1);
4249 gfc_simplify_maxexponent (gfc_expr
*x
)
4251 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4252 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4253 gfc_real_kinds
[i
].max_exponent
);
4258 gfc_simplify_minexponent (gfc_expr
*x
)
4260 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4261 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4262 gfc_real_kinds
[i
].min_exponent
);
4267 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
4273 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4276 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4277 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4282 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4284 /* Result is processor-dependent. */
4285 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
4286 gfc_free_expr (result
);
4287 return &gfc_bad_expr
;
4289 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4293 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4295 /* Result is processor-dependent. */
4296 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
4297 gfc_free_expr (result
);
4298 return &gfc_bad_expr
;
4301 gfc_set_model_kind (kind
);
4303 mpfr_div (tmp
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
4304 mpfr_trunc (tmp
, tmp
);
4305 mpfr_mul (tmp
, tmp
, p
->value
.real
, GFC_RND_MODE
);
4306 mpfr_sub (result
->value
.real
, a
->value
.real
, tmp
, GFC_RND_MODE
);
4311 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4314 return range_check (result
, "MOD");
4319 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
4325 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4328 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4329 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4334 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4336 /* Result is processor-dependent. This processor just opts
4337 to not handle it at all. */
4338 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
4339 gfc_free_expr (result
);
4340 return &gfc_bad_expr
;
4342 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4347 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4349 /* Result is processor-dependent. */
4350 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
4351 gfc_free_expr (result
);
4352 return &gfc_bad_expr
;
4355 gfc_set_model_kind (kind
);
4357 mpfr_div (tmp
, a
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
4358 mpfr_floor (tmp
, tmp
);
4359 mpfr_mul (tmp
, tmp
, p
->value
.real
, GFC_RND_MODE
);
4360 mpfr_sub (result
->value
.real
, a
->value
.real
, tmp
, GFC_RND_MODE
);
4365 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4368 return range_check (result
, "MODULO");
4372 /* Exists for the sole purpose of consistency with other intrinsics. */
4374 gfc_simplify_mvbits (gfc_expr
*f ATTRIBUTE_UNUSED
,
4375 gfc_expr
*fp ATTRIBUTE_UNUSED
,
4376 gfc_expr
*l ATTRIBUTE_UNUSED
,
4377 gfc_expr
*to ATTRIBUTE_UNUSED
,
4378 gfc_expr
*tp ATTRIBUTE_UNUSED
)
4385 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
4388 mp_exp_t emin
, emax
;
4391 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
4394 if (mpfr_sgn (s
->value
.real
) == 0)
4396 gfc_error ("Second argument of NEAREST at %L shall not be zero",
4398 return &gfc_bad_expr
;
4401 result
= gfc_copy_expr (x
);
4403 /* Save current values of emin and emax. */
4404 emin
= mpfr_get_emin ();
4405 emax
= mpfr_get_emax ();
4407 /* Set emin and emax for the current model number. */
4408 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
4409 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
4410 mpfr_get_prec(result
->value
.real
) + 1);
4411 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
4412 mpfr_check_range (result
->value
.real
, 0, GMP_RNDU
);
4414 if (mpfr_sgn (s
->value
.real
) > 0)
4416 mpfr_nextabove (result
->value
.real
);
4417 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
4421 mpfr_nextbelow (result
->value
.real
);
4422 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
4425 mpfr_set_emin (emin
);
4426 mpfr_set_emax (emax
);
4428 /* Only NaN can occur. Do not use range check as it gives an
4429 error for denormal numbers. */
4430 if (mpfr_nan_p (result
->value
.real
) && gfc_option
.flag_range_check
)
4432 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
4433 gfc_free_expr (result
);
4434 return &gfc_bad_expr
;
4442 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
4444 gfc_expr
*itrunc
, *result
;
4447 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
4449 return &gfc_bad_expr
;
4451 if (e
->expr_type
!= EXPR_CONSTANT
)
4454 itrunc
= gfc_copy_expr (e
);
4455 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
4457 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
4458 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
4460 gfc_free_expr (itrunc
);
4462 return range_check (result
, name
);
4467 gfc_simplify_new_line (gfc_expr
*e
)
4471 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
4472 result
->value
.character
.string
[0] = '\n';
4479 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
4481 return simplify_nint ("NINT", e
, k
);
4486 gfc_simplify_idnint (gfc_expr
*e
)
4488 return simplify_nint ("IDNINT", e
, NULL
);
4493 add_squared (gfc_expr
*result
, gfc_expr
*e
)
4497 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4498 gcc_assert (result
->ts
.type
== BT_REAL
4499 && result
->expr_type
== EXPR_CONSTANT
);
4501 gfc_set_model_kind (result
->ts
.kind
);
4503 mpfr_pow_ui (tmp
, e
->value
.real
, 2, GFC_RND_MODE
);
4504 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
4513 do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
4515 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4516 gcc_assert (result
->ts
.type
== BT_REAL
4517 && result
->expr_type
== EXPR_CONSTANT
);
4519 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
4520 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4526 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
4530 if (!is_constant_array_expr (e
)
4531 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
4534 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4535 init_result_expr (result
, 0, NULL
);
4537 if (!dim
|| e
->rank
== 1)
4539 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
4541 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4544 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
4545 add_squared
, &do_sqrt
);
4552 gfc_simplify_not (gfc_expr
*e
)
4556 if (e
->expr_type
!= EXPR_CONSTANT
)
4559 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4560 mpz_com (result
->value
.integer
, e
->value
.integer
);
4562 return range_check (result
, "NOT");
4567 gfc_simplify_null (gfc_expr
*mold
)
4573 result
= gfc_copy_expr (mold
);
4574 result
->expr_type
= EXPR_NULL
;
4577 result
= gfc_get_null_expr (NULL
);
4584 gfc_simplify_num_images (void)
4588 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4590 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4591 return &gfc_bad_expr
;
4594 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
4597 /* FIXME: gfc_current_locus is wrong. */
4598 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
4599 &gfc_current_locus
);
4600 mpz_set_si (result
->value
.integer
, 1);
4606 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
4611 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4614 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4619 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
4620 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4621 return range_check (result
, "OR");
4624 return gfc_get_logical_expr (kind
, &x
->where
,
4625 x
->value
.logical
|| y
->value
.logical
);
4633 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4636 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
4638 if (!is_constant_array_expr(array
)
4639 || !is_constant_array_expr(vector
)
4640 || (!gfc_is_constant_expr (mask
)
4641 && !is_constant_array_expr(mask
)))
4644 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
4645 if (array
->ts
.type
== BT_DERIVED
)
4646 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
4648 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
4649 vector_ctor
= vector
4650 ? gfc_constructor_first (vector
->value
.constructor
)
4653 if (mask
->expr_type
== EXPR_CONSTANT
4654 && mask
->value
.logical
)
4656 /* Copy all elements of ARRAY to RESULT. */
4659 gfc_constructor_append_expr (&result
->value
.constructor
,
4660 gfc_copy_expr (array_ctor
->expr
),
4663 array_ctor
= gfc_constructor_next (array_ctor
);
4664 vector_ctor
= gfc_constructor_next (vector_ctor
);
4667 else if (mask
->expr_type
== EXPR_ARRAY
)
4669 /* Copy only those elements of ARRAY to RESULT whose
4670 MASK equals .TRUE.. */
4671 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4674 if (mask_ctor
->expr
->value
.logical
)
4676 gfc_constructor_append_expr (&result
->value
.constructor
,
4677 gfc_copy_expr (array_ctor
->expr
),
4679 vector_ctor
= gfc_constructor_next (vector_ctor
);
4682 array_ctor
= gfc_constructor_next (array_ctor
);
4683 mask_ctor
= gfc_constructor_next (mask_ctor
);
4687 /* Append any left-over elements from VECTOR to RESULT. */
4690 gfc_constructor_append_expr (&result
->value
.constructor
,
4691 gfc_copy_expr (vector_ctor
->expr
),
4693 vector_ctor
= gfc_constructor_next (vector_ctor
);
4696 result
->shape
= gfc_get_shape (1);
4697 gfc_array_size (result
, &result
->shape
[0]);
4699 if (array
->ts
.type
== BT_CHARACTER
)
4700 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
4707 do_xor (gfc_expr
*result
, gfc_expr
*e
)
4709 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
4710 gcc_assert (result
->ts
.type
== BT_LOGICAL
4711 && result
->expr_type
== EXPR_CONSTANT
);
4713 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
4720 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
4722 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
4727 gfc_simplify_popcnt (gfc_expr
*e
)
4732 if (e
->expr_type
!= EXPR_CONSTANT
)
4735 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4737 /* Convert argument to unsigned, then count the '1' bits. */
4738 mpz_init_set (x
, e
->value
.integer
);
4739 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
4740 res
= mpz_popcount (x
);
4743 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
4748 gfc_simplify_poppar (gfc_expr
*e
)
4754 if (e
->expr_type
!= EXPR_CONSTANT
)
4757 popcnt
= gfc_simplify_popcnt (e
);
4758 gcc_assert (popcnt
);
4760 s
= gfc_extract_int (popcnt
, &i
);
4763 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
4768 gfc_simplify_precision (gfc_expr
*e
)
4770 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4771 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
4772 gfc_real_kinds
[i
].precision
);
4777 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
4779 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
4784 gfc_simplify_radix (gfc_expr
*e
)
4787 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4792 i
= gfc_integer_kinds
[i
].radix
;
4796 i
= gfc_real_kinds
[i
].radix
;
4803 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4808 gfc_simplify_range (gfc_expr
*e
)
4811 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4816 i
= gfc_integer_kinds
[i
].range
;
4821 i
= gfc_real_kinds
[i
].range
;
4828 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4833 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
4835 gfc_expr
*result
= NULL
;
4838 if (e
->ts
.type
== BT_COMPLEX
)
4839 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
4841 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
4844 return &gfc_bad_expr
;
4846 if (e
->expr_type
!= EXPR_CONSTANT
)
4849 if (convert_boz (e
, kind
) == &gfc_bad_expr
)
4850 return &gfc_bad_expr
;
4852 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
4853 if (result
== &gfc_bad_expr
)
4854 return &gfc_bad_expr
;
4856 return range_check (result
, "REAL");
4861 gfc_simplify_realpart (gfc_expr
*e
)
4865 if (e
->expr_type
!= EXPR_CONSTANT
)
4868 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
4869 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
4871 return range_check (result
, "REALPART");
4875 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
4878 int i
, j
, len
, ncop
, nlen
;
4880 bool have_length
= false;
4882 /* If NCOPIES isn't a constant, there's nothing we can do. */
4883 if (n
->expr_type
!= EXPR_CONSTANT
)
4886 /* If NCOPIES is negative, it's an error. */
4887 if (mpz_sgn (n
->value
.integer
) < 0)
4889 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4891 return &gfc_bad_expr
;
4894 /* If we don't know the character length, we can do no more. */
4895 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
4896 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4898 len
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
4901 else if (e
->expr_type
== EXPR_CONSTANT
4902 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
4904 len
= e
->value
.character
.length
;
4909 /* If the source length is 0, any value of NCOPIES is valid
4910 and everything behaves as if NCOPIES == 0. */
4913 mpz_set_ui (ncopies
, 0);
4915 mpz_set (ncopies
, n
->value
.integer
);
4917 /* Check that NCOPIES isn't too large. */
4923 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
4925 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4929 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
4930 e
->ts
.u
.cl
->length
->value
.integer
);
4934 mpz_init_set_si (mlen
, len
);
4935 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
4939 /* The check itself. */
4940 if (mpz_cmp (ncopies
, max
) > 0)
4943 mpz_clear (ncopies
);
4944 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4946 return &gfc_bad_expr
;
4951 mpz_clear (ncopies
);
4953 /* For further simplification, we need the character string to be
4955 if (e
->expr_type
!= EXPR_CONSTANT
)
4959 (e
->ts
.u
.cl
->length
&&
4960 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
)) != 0)
4962 const char *res
= gfc_extract_int (n
, &ncop
);
4963 gcc_assert (res
== NULL
);
4968 len
= e
->value
.character
.length
;
4971 result
= gfc_get_constant_expr (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
4974 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
4976 len
= e
->value
.character
.length
;
4979 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
4980 for (i
= 0; i
< ncop
; i
++)
4981 for (j
= 0; j
< len
; j
++)
4982 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
4984 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
4989 /* This one is a bear, but mainly has to do with shuffling elements. */
4992 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
4993 gfc_expr
*pad
, gfc_expr
*order_exp
)
4995 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
4996 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
5000 gfc_expr
*e
, *result
;
5002 /* Check that argument expression types are OK. */
5003 if (!is_constant_array_expr (source
)
5004 || !is_constant_array_expr (shape_exp
)
5005 || !is_constant_array_expr (pad
)
5006 || !is_constant_array_expr (order_exp
))
5009 /* Proceed with simplification, unpacking the array. */
5016 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
5020 gfc_extract_int (e
, &shape
[rank
]);
5022 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
5023 gcc_assert (shape
[rank
] >= 0);
5028 gcc_assert (rank
> 0);
5030 /* Now unpack the order array if present. */
5031 if (order_exp
== NULL
)
5033 for (i
= 0; i
< rank
; i
++)
5038 for (i
= 0; i
< rank
; i
++)
5041 for (i
= 0; i
< rank
; i
++)
5043 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
5046 gfc_extract_int (e
, &order
[i
]);
5048 gcc_assert (order
[i
] >= 1 && order
[i
] <= rank
);
5050 gcc_assert (x
[order
[i
]] == 0);
5055 /* Count the elements in the source and padding arrays. */
5060 gfc_array_size (pad
, &size
);
5061 npad
= mpz_get_ui (size
);
5065 gfc_array_size (source
, &size
);
5066 nsource
= mpz_get_ui (size
);
5069 /* If it weren't for that pesky permutation we could just loop
5070 through the source and round out any shortage with pad elements.
5071 But no, someone just had to have the compiler do something the
5072 user should be doing. */
5074 for (i
= 0; i
< rank
; i
++)
5077 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
5079 if (source
->ts
.type
== BT_DERIVED
)
5080 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
5081 result
->rank
= rank
;
5082 result
->shape
= gfc_get_shape (rank
);
5083 for (i
= 0; i
< rank
; i
++)
5084 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
5086 while (nsource
> 0 || npad
> 0)
5088 /* Figure out which element to extract. */
5089 mpz_set_ui (index
, 0);
5091 for (i
= rank
- 1; i
>= 0; i
--)
5093 mpz_add_ui (index
, index
, x
[order
[i
]]);
5095 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
5098 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
5099 gfc_internal_error ("Reshaped array too large at %C");
5101 j
= mpz_get_ui (index
);
5104 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
5107 gcc_assert (npad
> 0);
5111 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
5115 gfc_constructor_append_expr (&result
->value
.constructor
,
5116 gfc_copy_expr (e
), &e
->where
);
5118 /* Calculate the next element. */
5122 if (++x
[i
] < shape
[i
])
5138 gfc_simplify_rrspacing (gfc_expr
*x
)
5144 if (x
->expr_type
!= EXPR_CONSTANT
)
5147 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5149 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5150 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5152 /* Special case x = -0 and 0. */
5153 if (mpfr_sgn (result
->value
.real
) == 0)
5155 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5159 /* | x * 2**(-e) | * 2**p. */
5160 e
= - (long int) mpfr_get_exp (x
->value
.real
);
5161 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
5163 p
= (long int) gfc_real_kinds
[i
].digits
;
5164 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
5166 return range_check (result
, "RRSPACING");
5171 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
5173 int k
, neg_flag
, power
, exp_range
;
5174 mpfr_t scale
, radix
;
5177 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5180 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5182 if (mpfr_sgn (x
->value
.real
) == 0)
5184 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5188 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5190 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
5192 /* This check filters out values of i that would overflow an int. */
5193 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
5194 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
5196 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
5197 gfc_free_expr (result
);
5198 return &gfc_bad_expr
;
5201 /* Compute scale = radix ** power. */
5202 power
= mpz_get_si (i
->value
.integer
);
5212 gfc_set_model_kind (x
->ts
.kind
);
5215 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
5216 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
5219 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5221 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5223 mpfr_clears (scale
, radix
, NULL
);
5225 return range_check (result
, "SCALE");
5229 /* Variants of strspn and strcspn that operate on wide characters. */
5232 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5235 const gfc_char_t
*c
;
5239 for (c
= s2
; *c
; c
++)
5253 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5256 const gfc_char_t
*c
;
5260 for (c
= s2
; *c
; c
++)
5275 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
5280 size_t indx
, len
, lenc
;
5281 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
5284 return &gfc_bad_expr
;
5286 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
)
5289 if (b
!= NULL
&& b
->value
.logical
!= 0)
5294 len
= e
->value
.character
.length
;
5295 lenc
= c
->value
.character
.length
;
5297 if (len
== 0 || lenc
== 0)
5305 indx
= wide_strcspn (e
->value
.character
.string
,
5306 c
->value
.character
.string
) + 1;
5313 for (indx
= len
; indx
> 0; indx
--)
5315 for (i
= 0; i
< lenc
; i
++)
5317 if (c
->value
.character
.string
[i
]
5318 == e
->value
.character
.string
[indx
- 1])
5327 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
5328 return range_check (result
, "SCAN");
5333 gfc_simplify_selected_char_kind (gfc_expr
*e
)
5337 if (e
->expr_type
!= EXPR_CONSTANT
)
5340 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
5341 || gfc_compare_with_Cstring (e
, "default", false) == 0)
5343 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
5348 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5353 gfc_simplify_selected_int_kind (gfc_expr
*e
)
5357 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
5362 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
5363 if (gfc_integer_kinds
[i
].range
>= range
5364 && gfc_integer_kinds
[i
].kind
< kind
)
5365 kind
= gfc_integer_kinds
[i
].kind
;
5367 if (kind
== INT_MAX
)
5370 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5375 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
5377 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
5379 locus
*loc
= &gfc_current_locus
;
5385 if (p
->expr_type
!= EXPR_CONSTANT
5386 || gfc_extract_int (p
, &precision
) != NULL
)
5395 if (q
->expr_type
!= EXPR_CONSTANT
5396 || gfc_extract_int (q
, &range
) != NULL
)
5407 if (rdx
->expr_type
!= EXPR_CONSTANT
5408 || gfc_extract_int (rdx
, &radix
) != NULL
)
5416 found_precision
= 0;
5420 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5422 if (gfc_real_kinds
[i
].precision
>= precision
)
5423 found_precision
= 1;
5425 if (gfc_real_kinds
[i
].range
>= range
)
5428 if (gfc_real_kinds
[i
].radix
>= radix
)
5431 if (gfc_real_kinds
[i
].precision
>= precision
5432 && gfc_real_kinds
[i
].range
>= range
5433 && gfc_real_kinds
[i
].radix
>= radix
&& gfc_real_kinds
[i
].kind
< kind
)
5434 kind
= gfc_real_kinds
[i
].kind
;
5437 if (kind
== INT_MAX
)
5439 if (found_radix
&& found_range
&& !found_precision
)
5441 else if (found_radix
&& found_precision
&& !found_range
)
5443 else if (found_radix
&& !found_precision
&& !found_range
)
5445 else if (found_radix
)
5451 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
5456 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5459 mpfr_t exp
, absv
, log2
, pow2
, frac
;
5462 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5465 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5467 if (mpfr_sgn (x
->value
.real
) == 0)
5469 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5473 gfc_set_model_kind (x
->ts
.kind
);
5480 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
5481 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
5483 mpfr_trunc (log2
, log2
);
5484 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
5486 /* Old exponent value, and fraction. */
5487 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
5489 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
5492 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
5493 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
5495 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
5497 return range_check (result
, "SET_EXPONENT");
5502 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
5504 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5505 gfc_expr
*result
, *e
, *f
;
5509 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
5511 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
5513 if (source
->rank
== 0)
5516 if (source
->expr_type
== EXPR_VARIABLE
)
5518 ar
= gfc_find_array_ref (source
);
5519 t
= gfc_array_ref_shape (ar
, shape
);
5521 else if (source
->shape
)
5524 for (n
= 0; n
< source
->rank
; n
++)
5526 mpz_init (shape
[n
]);
5527 mpz_set (shape
[n
], source
->shape
[n
]);
5533 for (n
= 0; n
< source
->rank
; n
++)
5535 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
5539 mpz_set (e
->value
.integer
, shape
[n
]);
5540 mpz_clear (shape
[n
]);
5544 mpz_set_ui (e
->value
.integer
, n
+ 1);
5546 f
= gfc_simplify_size (source
, e
, NULL
);
5550 gfc_free_expr (result
);
5557 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
5565 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5568 gfc_expr
*return_value
;
5570 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
5573 return &gfc_bad_expr
;
5575 /* For unary operations, the size of the result is given by the size
5576 of the operand. For binary ones, it's the size of the first operand
5577 unless it is scalar, then it is the size of the second. */
5578 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
5580 gfc_expr
* replacement
;
5581 gfc_expr
* simplified
;
5583 switch (array
->value
.op
.op
)
5585 /* Unary operations. */
5587 case INTRINSIC_UPLUS
:
5588 case INTRINSIC_UMINUS
:
5589 replacement
= array
->value
.op
.op1
;
5592 /* Binary operations. If any one of the operands is scalar, take
5593 the other one's size. If both of them are arrays, it does not
5594 matter -- try to find one with known shape, if possible. */
5596 if (array
->value
.op
.op1
->rank
== 0)
5597 replacement
= array
->value
.op
.op2
;
5598 else if (array
->value
.op
.op2
->rank
== 0)
5599 replacement
= array
->value
.op
.op1
;
5602 simplified
= gfc_simplify_size (array
->value
.op
.op1
, dim
, kind
);
5606 replacement
= array
->value
.op
.op2
;
5611 /* Try to reduce it directly if possible. */
5612 simplified
= gfc_simplify_size (replacement
, dim
, kind
);
5614 /* Otherwise, we build a new SIZE call. This is hopefully at least
5615 simpler than the original one. */
5617 simplified
= gfc_build_intrinsic_call ("size", array
->where
, 3,
5618 gfc_copy_expr (replacement
),
5619 gfc_copy_expr (dim
),
5620 gfc_copy_expr (kind
));
5627 if (gfc_array_size (array
, &size
) == FAILURE
)
5632 if (dim
->expr_type
!= EXPR_CONSTANT
)
5635 d
= mpz_get_ui (dim
->value
.integer
) - 1;
5636 if (gfc_array_dimen_size (array
, d
, &size
) == FAILURE
)
5640 return_value
= gfc_get_int_expr (k
, &array
->where
, mpz_get_si (size
));
5642 return return_value
;
5647 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
5651 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
5654 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5659 mpz_abs (result
->value
.integer
, x
->value
.integer
);
5660 if (mpz_sgn (y
->value
.integer
) < 0)
5661 mpz_neg (result
->value
.integer
, result
->value
.integer
);
5665 if (gfc_option
.flag_sign_zero
)
5666 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
5669 mpfr_setsign (result
->value
.real
, x
->value
.real
,
5670 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
5674 gfc_internal_error ("Bad type in gfc_simplify_sign");
5682 gfc_simplify_sin (gfc_expr
*x
)
5686 if (x
->expr_type
!= EXPR_CONSTANT
)
5689 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5694 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5698 gfc_set_model (x
->value
.real
);
5699 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5703 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5706 return range_check (result
, "SIN");
5711 gfc_simplify_sinh (gfc_expr
*x
)
5715 if (x
->expr_type
!= EXPR_CONSTANT
)
5718 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5723 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5727 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5734 return range_check (result
, "SINH");
5738 /* The argument is always a double precision real that is converted to
5739 single precision. TODO: Rounding! */
5742 gfc_simplify_sngl (gfc_expr
*a
)
5746 if (a
->expr_type
!= EXPR_CONSTANT
)
5749 result
= gfc_real2real (a
, gfc_default_real_kind
);
5750 return range_check (result
, "SNGL");
5755 gfc_simplify_spacing (gfc_expr
*x
)
5761 if (x
->expr_type
!= EXPR_CONSTANT
)
5764 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5766 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5768 /* Special case x = 0 and -0. */
5769 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5770 if (mpfr_sgn (result
->value
.real
) == 0)
5772 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
5776 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
5777 are the radix, exponent of x, and precision. This excludes the
5778 possibility of subnormal numbers. Fortran 2003 states the result is
5779 b**max(e - p, emin - 1). */
5781 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
5782 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
5783 en
= en
> ep
? en
: ep
;
5785 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
5786 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
5788 return range_check (result
, "SPACING");
5793 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
5795 gfc_expr
*result
= 0L;
5796 int i
, j
, dim
, ncopies
;
5799 if ((!gfc_is_constant_expr (source
)
5800 && !is_constant_array_expr (source
))
5801 || !gfc_is_constant_expr (dim_expr
)
5802 || !gfc_is_constant_expr (ncopies_expr
))
5805 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
5806 gfc_extract_int (dim_expr
, &dim
);
5807 dim
-= 1; /* zero-base DIM */
5809 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
5810 gfc_extract_int (ncopies_expr
, &ncopies
);
5811 ncopies
= MAX (ncopies
, 0);
5813 /* Do not allow the array size to exceed the limit for an array
5815 if (source
->expr_type
== EXPR_ARRAY
)
5817 if (gfc_array_size (source
, &size
) == FAILURE
)
5818 gfc_internal_error ("Failure getting length of a constant array.");
5821 mpz_init_set_ui (size
, 1);
5823 if (mpz_get_si (size
)*ncopies
> gfc_option
.flag_max_array_constructor
)
5826 if (source
->expr_type
== EXPR_CONSTANT
)
5828 gcc_assert (dim
== 0);
5830 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
5832 if (source
->ts
.type
== BT_DERIVED
)
5833 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
5835 result
->shape
= gfc_get_shape (result
->rank
);
5836 mpz_init_set_si (result
->shape
[0], ncopies
);
5838 for (i
= 0; i
< ncopies
; ++i
)
5839 gfc_constructor_append_expr (&result
->value
.constructor
,
5840 gfc_copy_expr (source
), NULL
);
5842 else if (source
->expr_type
== EXPR_ARRAY
)
5844 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
5845 gfc_constructor
*source_ctor
;
5847 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
5848 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
5850 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
5852 if (source
->ts
.type
== BT_DERIVED
)
5853 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
5854 result
->rank
= source
->rank
+ 1;
5855 result
->shape
= gfc_get_shape (result
->rank
);
5857 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
5860 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
5862 mpz_init_set_si (result
->shape
[i
], ncopies
);
5864 extent
[i
] = mpz_get_si (result
->shape
[i
]);
5865 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
5869 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
5870 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
5872 for (i
= 0; i
< ncopies
; ++i
)
5873 gfc_constructor_insert_expr (&result
->value
.constructor
,
5874 gfc_copy_expr (source_ctor
->expr
),
5875 NULL
, offset
+ i
* rstride
[dim
]);
5877 offset
+= (dim
== 0 ? ncopies
: 1);
5881 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5882 Replace NULL with gcc_unreachable() after implementing
5883 gfc_simplify_cshift(). */
5886 if (source
->ts
.type
== BT_CHARACTER
)
5887 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
5894 gfc_simplify_sqrt (gfc_expr
*e
)
5896 gfc_expr
*result
= NULL
;
5898 if (e
->expr_type
!= EXPR_CONSTANT
)
5904 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
5906 gfc_error ("Argument of SQRT at %L has a negative value",
5908 return &gfc_bad_expr
;
5910 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
5911 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
5915 gfc_set_model (e
->value
.real
);
5917 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
5918 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
5922 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
5925 return range_check (result
, "SQRT");
5930 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
5932 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
5937 gfc_simplify_tan (gfc_expr
*x
)
5941 if (x
->expr_type
!= EXPR_CONSTANT
)
5944 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5949 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5953 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5960 return range_check (result
, "TAN");
5965 gfc_simplify_tanh (gfc_expr
*x
)
5969 if (x
->expr_type
!= EXPR_CONSTANT
)
5972 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5977 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5981 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5988 return range_check (result
, "TANH");
5993 gfc_simplify_tiny (gfc_expr
*e
)
5998 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
6000 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6001 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6008 gfc_simplify_trailz (gfc_expr
*e
)
6010 unsigned long tz
, bs
;
6013 if (e
->expr_type
!= EXPR_CONSTANT
)
6016 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6017 bs
= gfc_integer_kinds
[i
].bit_size
;
6018 tz
= mpz_scan1 (e
->value
.integer
, 0);
6020 return gfc_get_int_expr (gfc_default_integer_kind
,
6021 &e
->where
, MIN (tz
, bs
));
6026 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6029 gfc_expr
*mold_element
;
6032 size_t result_elt_size
;
6035 unsigned char *buffer
;
6037 if (!gfc_is_constant_expr (source
)
6038 || (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
6039 || !gfc_is_constant_expr (size
))
6042 if (source
->expr_type
== EXPR_FUNCTION
)
6045 /* Calculate the size of the source. */
6046 if (source
->expr_type
== EXPR_ARRAY
6047 && gfc_array_size (source
, &tmp
) == FAILURE
)
6048 gfc_internal_error ("Failure getting length of a constant array.");
6050 source_size
= gfc_target_expr_size (source
);
6052 /* Create an empty new expression with the appropriate characteristics. */
6053 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
6055 result
->ts
= mold
->ts
;
6057 mold_element
= mold
->expr_type
== EXPR_ARRAY
6058 ? gfc_constructor_first (mold
->value
.constructor
)->expr
6061 /* Set result character length, if needed. Note that this needs to be
6062 set even for array expressions, in order to pass this information into
6063 gfc_target_interpret_expr. */
6064 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
6065 result
->value
.character
.length
= mold_element
->value
.character
.length
;
6067 /* Set the number of elements in the result, and determine its size. */
6068 result_elt_size
= gfc_target_expr_size (mold_element
);
6069 if (result_elt_size
== 0)
6071 gfc_free_expr (result
);
6075 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
6079 result
->expr_type
= EXPR_ARRAY
;
6083 result_length
= (size_t)mpz_get_ui (size
->value
.integer
);
6086 result_length
= source_size
/ result_elt_size
;
6087 if (result_length
* result_elt_size
< source_size
)
6091 result
->shape
= gfc_get_shape (1);
6092 mpz_init_set_ui (result
->shape
[0], result_length
);
6094 result_size
= result_length
* result_elt_size
;
6099 result_size
= result_elt_size
;
6102 if (gfc_option
.warn_surprising
&& source_size
< result_size
)
6103 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
6104 "source size %ld < result size %ld", &source
->where
,
6105 (long) source_size
, (long) result_size
);
6107 /* Allocate the buffer to store the binary version of the source. */
6108 buffer_size
= MAX (source_size
, result_size
);
6109 buffer
= (unsigned char*)alloca (buffer_size
);
6110 memset (buffer
, 0, buffer_size
);
6112 /* Now write source to the buffer. */
6113 gfc_target_encode_expr (source
, buffer
, buffer_size
);
6115 /* And read the buffer back into the new expression. */
6116 gfc_target_interpret_expr (buffer
, buffer_size
, result
);
6123 gfc_simplify_transpose (gfc_expr
*matrix
)
6125 int row
, matrix_rows
, col
, matrix_cols
;
6128 if (!is_constant_array_expr (matrix
))
6131 gcc_assert (matrix
->rank
== 2);
6133 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
6136 result
->shape
= gfc_get_shape (result
->rank
);
6137 mpz_set (result
->shape
[0], matrix
->shape
[1]);
6138 mpz_set (result
->shape
[1], matrix
->shape
[0]);
6140 if (matrix
->ts
.type
== BT_CHARACTER
)
6141 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
6142 else if (matrix
->ts
.type
== BT_DERIVED
)
6143 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
6145 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
6146 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
6147 for (row
= 0; row
< matrix_rows
; ++row
)
6148 for (col
= 0; col
< matrix_cols
; ++col
)
6150 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
6151 col
* matrix_rows
+ row
);
6152 gfc_constructor_insert_expr (&result
->value
.constructor
,
6153 gfc_copy_expr (e
), &matrix
->where
,
6154 row
* matrix_cols
+ col
);
6162 gfc_simplify_trim (gfc_expr
*e
)
6165 int count
, i
, len
, lentrim
;
6167 if (e
->expr_type
!= EXPR_CONSTANT
)
6170 len
= e
->value
.character
.length
;
6171 for (count
= 0, i
= 1; i
<= len
; ++i
)
6173 if (e
->value
.character
.string
[len
- i
] == ' ')
6179 lentrim
= len
- count
;
6181 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
6182 for (i
= 0; i
< lentrim
; i
++)
6183 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
6190 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
6195 gfc_constructor
*sub_cons
;
6199 if (!is_constant_array_expr (sub
))
6200 goto not_implemented
; /* return NULL;*/
6202 /* Follow any component references. */
6203 as
= coarray
->symtree
->n
.sym
->as
;
6204 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
6205 if (ref
->type
== REF_COMPONENT
)
6208 if (as
->type
== AS_DEFERRED
)
6209 goto not_implemented
; /* return NULL;*/
6211 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6212 the cosubscript addresses the first image. */
6214 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
6217 for (d
= 1; d
<= as
->corank
; d
++)
6222 if (sub_cons
== NULL
)
6224 gfc_error ("Too few elements in expression for SUB= argument at %L",
6226 return &gfc_bad_expr
;
6229 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
6231 if (ca_bound
== NULL
)
6232 goto not_implemented
; /* return NULL */
6234 if (ca_bound
== &gfc_bad_expr
)
6237 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
6241 gfc_free_expr (ca_bound
);
6242 sub_cons
= gfc_constructor_next (sub_cons
);
6246 first_image
= false;
6250 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6251 "SUB has %ld and COARRAY lower bound is %ld)",
6253 mpz_get_si (sub_cons
->expr
->value
.integer
),
6254 mpz_get_si (ca_bound
->value
.integer
));
6255 gfc_free_expr (ca_bound
);
6256 return &gfc_bad_expr
;
6259 gfc_free_expr (ca_bound
);
6261 /* Check whether upperbound is valid for the multi-images case. */
6264 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
6266 if (ca_bound
== &gfc_bad_expr
)
6269 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
6270 && mpz_cmp (ca_bound
->value
.integer
,
6271 sub_cons
->expr
->value
.integer
) < 0)
6273 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6274 "SUB has %ld and COARRAY upper bound is %ld)",
6276 mpz_get_si (sub_cons
->expr
->value
.integer
),
6277 mpz_get_si (ca_bound
->value
.integer
));
6278 gfc_free_expr (ca_bound
);
6279 return &gfc_bad_expr
;
6283 gfc_free_expr (ca_bound
);
6286 sub_cons
= gfc_constructor_next (sub_cons
);
6289 if (sub_cons
!= NULL
)
6291 gfc_error ("Too many elements in expression for SUB= argument at %L",
6293 return &gfc_bad_expr
;
6296 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6297 &gfc_current_locus
);
6299 mpz_set_si (result
->value
.integer
, 1);
6301 mpz_set_si (result
->value
.integer
, 0);
6306 gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
6307 "cobounds at %L", &coarray
->where
);
6308 return &gfc_bad_expr
;
6313 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
)
6319 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
6322 if (coarray
== NULL
)
6325 /* FIXME: gfc_current_locus is wrong. */
6326 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6327 &gfc_current_locus
);
6328 mpz_set_si (result
->value
.integer
, 1);
6332 gcc_assert (coarray
->expr_type
== EXPR_VARIABLE
);
6334 /* Follow any component references. */
6335 as
= coarray
->symtree
->n
.sym
->as
;
6336 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
6337 if (ref
->type
== REF_COMPONENT
)
6340 if (as
->type
== AS_DEFERRED
)
6341 goto not_implemented
; /* return NULL;*/
6345 /* Multi-dimensional bounds. */
6346 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
6349 /* Simplify the bounds for each dimension. */
6350 for (d
= 0; d
< as
->corank
; d
++)
6352 bounds
[d
] = simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
+ 1, 0,
6354 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
6358 for (j
= 0; j
< d
; j
++)
6359 gfc_free_expr (bounds
[j
]);
6360 if (bounds
[d
] == NULL
)
6361 goto not_implemented
;
6366 /* Allocate the result expression. */
6367 e
= gfc_get_expr ();
6368 e
->where
= coarray
->where
;
6369 e
->expr_type
= EXPR_ARRAY
;
6370 e
->ts
.type
= BT_INTEGER
;
6371 e
->ts
.kind
= gfc_default_integer_kind
;
6374 e
->shape
= gfc_get_shape (1);
6375 mpz_init_set_ui (e
->shape
[0], as
->corank
);
6377 /* Create the constructor for this array. */
6378 for (d
= 0; d
< as
->corank
; d
++)
6379 gfc_constructor_append_expr (&e
->value
.constructor
,
6380 bounds
[d
], &e
->where
);
6387 /* A DIM argument is specified. */
6388 if (dim
->expr_type
!= EXPR_CONSTANT
)
6389 goto not_implemented
; /*return NULL;*/
6391 d
= mpz_get_si (dim
->value
.integer
);
6393 if (d
< 1 || d
> as
->corank
)
6395 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
6396 return &gfc_bad_expr
;
6399 /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
6400 e
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
, NULL
, true);
6404 goto not_implemented
;
6408 gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
6409 "cobounds at %L", &coarray
->where
);
6410 return &gfc_bad_expr
;
6415 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6417 return simplify_bound (array
, dim
, kind
, 1);
6421 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6424 /* return simplify_cobound (array, dim, kind, 1);*/
6426 e
= simplify_cobound (array
, dim
, kind
, 1);
6430 gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
6431 "cobounds at %L", &array
->where
);
6432 return &gfc_bad_expr
;
6437 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6439 gfc_expr
*result
, *e
;
6440 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
6442 if (!is_constant_array_expr (vector
)
6443 || !is_constant_array_expr (mask
)
6444 || (!gfc_is_constant_expr (field
)
6445 && !is_constant_array_expr(field
)))
6448 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
6450 if (vector
->ts
.type
== BT_DERIVED
)
6451 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
6452 result
->rank
= mask
->rank
;
6453 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
6455 if (vector
->ts
.type
== BT_CHARACTER
)
6456 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
6458 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
6459 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6461 = field
->expr_type
== EXPR_ARRAY
6462 ? gfc_constructor_first (field
->value
.constructor
)
6467 if (mask_ctor
->expr
->value
.logical
)
6469 gcc_assert (vector_ctor
);
6470 e
= gfc_copy_expr (vector_ctor
->expr
);
6471 vector_ctor
= gfc_constructor_next (vector_ctor
);
6473 else if (field
->expr_type
== EXPR_ARRAY
)
6474 e
= gfc_copy_expr (field_ctor
->expr
);
6476 e
= gfc_copy_expr (field
);
6478 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
6480 mask_ctor
= gfc_constructor_next (mask_ctor
);
6481 field_ctor
= gfc_constructor_next (field_ctor
);
6489 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
6493 size_t index
, len
, lenset
;
6495 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
6498 return &gfc_bad_expr
;
6500 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
)
6503 if (b
!= NULL
&& b
->value
.logical
!= 0)
6508 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
6510 len
= s
->value
.character
.length
;
6511 lenset
= set
->value
.character
.length
;
6515 mpz_set_ui (result
->value
.integer
, 0);
6523 mpz_set_ui (result
->value
.integer
, 1);
6527 index
= wide_strspn (s
->value
.character
.string
,
6528 set
->value
.character
.string
) + 1;
6537 mpz_set_ui (result
->value
.integer
, len
);
6540 for (index
= len
; index
> 0; index
--)
6542 for (i
= 0; i
< lenset
; i
++)
6544 if (s
->value
.character
.string
[index
- 1]
6545 == set
->value
.character
.string
[i
])
6553 mpz_set_ui (result
->value
.integer
, index
);
6559 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
6564 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6567 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6572 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6573 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6574 return range_check (result
, "XOR");
6577 return gfc_get_logical_expr (kind
, &x
->where
,
6578 (x
->value
.logical
&& !y
->value
.logical
)
6579 || (!x
->value
.logical
&& y
->value
.logical
));
6587 /****************** Constant simplification *****************/
6589 /* Master function to convert one constant to another. While this is
6590 used as a simplification function, it requires the destination type
6591 and kind information which is supplied by a special case in
6595 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
6597 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
6612 f
= gfc_int2complex
;
6632 f
= gfc_real2complex
;
6643 f
= gfc_complex2int
;
6646 f
= gfc_complex2real
;
6649 f
= gfc_complex2complex
;
6675 f
= gfc_hollerith2int
;
6679 f
= gfc_hollerith2real
;
6683 f
= gfc_hollerith2complex
;
6687 f
= gfc_hollerith2character
;
6691 f
= gfc_hollerith2logical
;
6701 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6706 switch (e
->expr_type
)
6709 result
= f (e
, kind
);
6711 return &gfc_bad_expr
;
6715 if (!gfc_is_constant_expr (e
))
6718 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6719 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6720 result
->rank
= e
->rank
;
6722 for (c
= gfc_constructor_first (e
->value
.constructor
);
6723 c
; c
= gfc_constructor_next (c
))
6726 if (c
->iterator
== NULL
)
6727 tmp
= f (c
->expr
, kind
);
6730 g
= gfc_convert_constant (c
->expr
, type
, kind
);
6731 if (g
== &gfc_bad_expr
)
6733 gfc_free_expr (result
);
6741 gfc_free_expr (result
);
6745 gfc_constructor_append_expr (&result
->value
.constructor
,
6759 /* Function for converting character constants. */
6761 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
6766 if (!gfc_is_constant_expr (e
))
6769 if (e
->expr_type
== EXPR_CONSTANT
)
6771 /* Simple case of a scalar. */
6772 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
6774 return &gfc_bad_expr
;
6776 result
->value
.character
.length
= e
->value
.character
.length
;
6777 result
->value
.character
.string
6778 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
6779 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
6780 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
6782 /* Check we only have values representable in the destination kind. */
6783 for (i
= 0; i
< result
->value
.character
.length
; i
++)
6784 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
6787 gfc_error ("Character '%s' in string at %L cannot be converted "
6788 "into character kind %d",
6789 gfc_print_wide_char (result
->value
.character
.string
[i
]),
6791 return &gfc_bad_expr
;
6796 else if (e
->expr_type
== EXPR_ARRAY
)
6798 /* For an array constructor, we convert each constructor element. */
6801 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6802 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6803 result
->rank
= e
->rank
;
6804 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
6806 for (c
= gfc_constructor_first (e
->value
.constructor
);
6807 c
; c
= gfc_constructor_next (c
))
6809 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
6810 if (tmp
== &gfc_bad_expr
)
6812 gfc_free_expr (result
);
6813 return &gfc_bad_expr
;
6818 gfc_free_expr (result
);
6822 gfc_constructor_append_expr (&result
->value
.constructor
,
6834 gfc_simplify_compiler_options (void)
6839 str
= gfc_get_option_string ();
6840 result
= gfc_get_character_expr (gfc_default_character_kind
,
6841 &gfc_current_locus
, str
, strlen (str
));
6848 gfc_simplify_compiler_version (void)
6853 len
= strlen ("GCC version ") + strlen (version_string
);
6854 buffer
= XALLOCAVEC (char, len
+ 1);
6855 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
6856 return gfc_get_character_expr (gfc_default_character_kind
,
6857 &gfc_current_locus
, buffer
, len
);