1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2021 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
24 #include "tm.h" /* For BITS_PER_UNIT. */
27 #include "intrinsic.h"
29 #include "target-memory.h"
30 #include "constructor.h"
31 #include "version.h" /* For version_string. */
35 static int min_max_choose (gfc_expr
*, gfc_expr
*, int, bool back_val
= false);
37 gfc_expr gfc_bad_expr
;
39 static gfc_expr
*simplify_size (gfc_expr
*, gfc_expr
*, int);
42 /* Note that 'simplification' is not just transforming expressions.
43 For functions that are not simplified at compile time, range
44 checking is done if possible.
46 The return convention is that each simplification function returns:
48 A new expression node corresponding to the simplified arguments.
49 The original arguments are destroyed by the caller, and must not
50 be a part of the new expression.
52 NULL pointer indicating that no simplification was possible and
53 the original expression should remain intact.
55 An expression pointer to gfc_bad_expr (a static placeholder)
56 indicating that some error has prevented simplification. The
57 error is generated within the function and should be propagated
60 By the time a simplification function gets control, it has been
61 decided that the function call is really supposed to be the
62 intrinsic. No type checking is strictly necessary, since only
63 valid types will be passed on. On the other hand, a simplification
64 subroutine may have to look at the type of an argument as part of
67 Array arguments are only passed to these subroutines that implement
68 the simplification of transformational intrinsics.
70 The functions in this file don't have much comment with them, but
71 everything is reasonably straight-forward. The Standard, chapter 13
72 is the best comment you'll find for this file anyway. */
74 /* Range checks an expression node. If all goes well, returns the
75 node, otherwise returns &gfc_bad_expr and frees the node. */
78 range_check (gfc_expr
*result
, const char *name
)
83 if (result
->expr_type
!= EXPR_CONSTANT
)
86 switch (gfc_range_check (result
))
92 gfc_error ("Result of %s overflows its kind at %L", name
,
97 gfc_error ("Result of %s underflows its kind at %L", name
,
102 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
106 gfc_error ("Result of %s gives range error for its kind at %L", name
,
111 gfc_free_expr (result
);
112 return &gfc_bad_expr
;
116 /* A helper function that gets an optional and possibly missing
117 kind parameter. Returns the kind, -1 if something went wrong. */
120 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
127 if (k
->expr_type
!= EXPR_CONSTANT
)
129 gfc_error ("KIND parameter of %s at %L must be an initialization "
130 "expression", name
, &k
->where
);
134 if (gfc_extract_int (k
, &kind
)
135 || gfc_validate_kind (type
, kind
, true) < 0)
137 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
145 /* Converts an mpz_t signed variable into an unsigned one, assuming
146 two's complement representations and a binary width of bitsize.
147 The conversion is a no-op unless x is negative; otherwise, it can
148 be accomplished by masking out the high bits. */
151 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
157 /* Confirm that no bits above the signed range are unset if we
158 are doing range checking. */
159 if (flag_range_check
!= 0)
160 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
162 mpz_init_set_ui (mask
, 1);
163 mpz_mul_2exp (mask
, mask
, bitsize
);
164 mpz_sub_ui (mask
, mask
, 1);
166 mpz_and (x
, x
, mask
);
172 /* Confirm that no bits above the signed range are set if we
173 are doing range checking. */
174 if (flag_range_check
!= 0)
175 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
180 /* Converts an mpz_t unsigned variable into a signed one, assuming
181 two's complement representations and a binary width of bitsize.
182 If the bitsize-1 bit is set, this is taken as a sign bit and
183 the number is converted to the corresponding negative number. */
186 gfc_convert_mpz_to_signed (mpz_t x
, int bitsize
)
190 /* Confirm that no bits above the unsigned range are set if we are
191 doing range checking. */
192 if (flag_range_check
!= 0)
193 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
195 if (mpz_tstbit (x
, bitsize
- 1) == 1)
197 mpz_init_set_ui (mask
, 1);
198 mpz_mul_2exp (mask
, mask
, bitsize
);
199 mpz_sub_ui (mask
, mask
, 1);
201 /* We negate the number by hand, zeroing the high bits, that is
202 make it the corresponding positive number, and then have it
203 negated by GMP, giving the correct representation of the
206 mpz_add_ui (x
, x
, 1);
207 mpz_and (x
, x
, mask
);
216 /* Test that the expression is a constant array, simplifying if
217 we are dealing with a parameter array. */
220 is_constant_array_expr (gfc_expr
*e
)
223 bool array_OK
= true;
229 if (e
->expr_type
== EXPR_VARIABLE
&& e
->rank
> 0
230 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
231 gfc_simplify_expr (e
, 1);
233 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
236 for (c
= gfc_constructor_first (e
->value
.constructor
);
237 c
; c
= gfc_constructor_next (c
))
238 if (c
->expr
->expr_type
!= EXPR_CONSTANT
239 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
245 /* Check and expand the constructor. */
246 if (!array_OK
&& gfc_init_expr_flag
&& e
->rank
== 1)
248 array_OK
= gfc_reduce_init_expr (e
);
249 /* gfc_reduce_init_expr resets the flag. */
250 gfc_init_expr_flag
= true;
255 /* Recheck to make sure that any EXPR_ARRAYs have gone. */
256 for (c
= gfc_constructor_first (e
->value
.constructor
);
257 c
; c
= gfc_constructor_next (c
))
258 if (c
->expr
->expr_type
!= EXPR_CONSTANT
259 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
262 /* Make sure that the array has a valid shape. */
263 if (e
->shape
== NULL
&& e
->rank
== 1)
265 if (!gfc_array_size(e
, &size
))
267 e
->shape
= gfc_get_shape (1);
268 mpz_init_set (e
->shape
[0], size
);
275 /* Test for a size zero array. */
277 gfc_is_size_zero_array (gfc_expr
*array
)
280 if (array
->rank
== 0)
283 if (array
->expr_type
== EXPR_VARIABLE
&& array
->rank
> 0
284 && array
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
285 && array
->shape
!= NULL
)
287 for (int i
= 0; i
< array
->rank
; i
++)
288 if (mpz_cmp_si (array
->shape
[i
], 0) <= 0)
294 if (array
->expr_type
== EXPR_ARRAY
)
295 return array
->value
.constructor
== NULL
;
301 /* Initialize a transformational result expression with a given value. */
304 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
306 if (e
&& e
->expr_type
== EXPR_ARRAY
)
308 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
311 init_result_expr (ctor
->expr
, init
, array
);
312 ctor
= gfc_constructor_next (ctor
);
315 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
317 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
318 HOST_WIDE_INT length
;
324 e
->value
.logical
= (init
? 1 : 0);
329 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
330 else if (init
== INT_MAX
)
331 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
333 mpz_set_si (e
->value
.integer
, init
);
339 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
340 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
342 else if (init
== INT_MAX
)
343 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
345 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
349 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
355 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
356 gfc_extract_hwi (len
, &length
);
357 string
= gfc_get_wide_string (length
+ 1);
358 gfc_wide_memset (string
, 0, length
);
360 else if (init
== INT_MAX
)
362 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
363 gfc_extract_hwi (len
, &length
);
364 string
= gfc_get_wide_string (length
+ 1);
365 gfc_wide_memset (string
, 255, length
);
370 string
= gfc_get_wide_string (1);
373 string
[length
] = '\0';
374 e
->value
.character
.length
= length
;
375 e
->value
.character
.string
= string
;
387 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
388 if conj_a is true, the matrix_a is complex conjugated. */
391 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
392 gfc_expr
*matrix_b
, int stride_b
, int offset_b
,
395 gfc_expr
*result
, *a
, *b
, *c
;
397 /* Set result to an INTEGER(1) 0 for numeric types and .false. for
398 LOGICAL. Mixed-mode math in the loop will promote result to the
399 correct type and kind. */
400 if (matrix_a
->ts
.type
== BT_LOGICAL
)
401 result
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, false);
403 result
= gfc_get_int_expr (1, NULL
, 0);
404 result
->where
= matrix_a
->where
;
406 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
407 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
410 /* Copying of expressions is required as operands are free'd
411 by the gfc_arith routines. */
412 switch (result
->ts
.type
)
415 result
= gfc_or (result
,
416 gfc_and (gfc_copy_expr (a
),
423 if (conj_a
&& a
->ts
.type
== BT_COMPLEX
)
424 c
= gfc_simplify_conjg (a
);
426 c
= gfc_copy_expr (a
);
427 result
= gfc_add (result
, gfc_multiply (c
, gfc_copy_expr (b
)));
434 offset_a
+= stride_a
;
435 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
437 offset_b
+= stride_b
;
438 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
445 /* Build a result expression for transformational intrinsics,
449 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
450 int kind
, locus
* where
)
455 if (!dim
|| array
->rank
== 1)
456 return gfc_get_constant_expr (type
, kind
, where
);
458 result
= gfc_get_array_expr (type
, kind
, where
);
459 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
460 result
->rank
= array
->rank
- 1;
462 /* gfc_array_size() would count the number of elements in the constructor,
463 we have not built those yet. */
465 for (i
= 0; i
< result
->rank
; ++i
)
466 nelem
*= mpz_get_ui (result
->shape
[i
]);
468 for (i
= 0; i
< nelem
; ++i
)
470 gfc_constructor_append_expr (&result
->value
.constructor
,
471 gfc_get_constant_expr (type
, kind
, where
),
479 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
481 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
482 of COUNT intrinsic is .TRUE..
484 Interface and implementation mimics arith functions as
485 gfc_add, gfc_multiply, etc. */
488 gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
492 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
493 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
494 gcc_assert (op2
->value
.logical
);
496 result
= gfc_copy_expr (op1
);
497 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
505 /* Transforms an ARRAY with operation OP, according to MASK, to a
506 scalar RESULT. E.g. called if
508 REAL, PARAMETER :: array(n, m) = ...
509 REAL, PARAMETER :: s = SUM(array)
511 where OP == gfc_add(). */
514 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
515 transformational_op op
)
518 gfc_constructor
*array_ctor
, *mask_ctor
;
520 /* Shortcut for constant .FALSE. MASK. */
522 && mask
->expr_type
== EXPR_CONSTANT
523 && !mask
->value
.logical
)
526 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
528 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
529 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
533 a
= array_ctor
->expr
;
534 array_ctor
= gfc_constructor_next (array_ctor
);
536 /* A constant MASK equals .TRUE. here and can be ignored. */
540 mask_ctor
= gfc_constructor_next (mask_ctor
);
541 if (!m
->value
.logical
)
545 result
= op (result
, gfc_copy_expr (a
));
553 /* Transforms an ARRAY with operation OP, according to MASK, to an
554 array RESULT. E.g. called if
556 REAL, PARAMETER :: array(n, m) = ...
557 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
559 where OP == gfc_multiply().
560 The result might be post processed using post_op. */
563 simplify_transformation_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*dim
,
564 gfc_expr
*mask
, transformational_op op
,
565 transformational_op post_op
)
568 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
569 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
570 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
572 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
573 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
574 tmpstride
[GFC_MAX_DIMENSIONS
];
576 /* Shortcut for constant .FALSE. MASK. */
578 && mask
->expr_type
== EXPR_CONSTANT
579 && !mask
->value
.logical
)
582 /* Build an indexed table for array element expressions to minimize
583 linked-list traversal. Masked elements are set to NULL. */
584 gfc_array_size (array
, &size
);
585 arraysize
= mpz_get_ui (size
);
588 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
590 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
592 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
593 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
595 for (i
= 0; i
< arraysize
; ++i
)
597 arrayvec
[i
] = array_ctor
->expr
;
598 array_ctor
= gfc_constructor_next (array_ctor
);
602 if (!mask_ctor
->expr
->value
.logical
)
605 mask_ctor
= gfc_constructor_next (mask_ctor
);
609 /* Same for the result expression. */
610 gfc_array_size (result
, &size
);
611 resultsize
= mpz_get_ui (size
);
614 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
615 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
616 for (i
= 0; i
< resultsize
; ++i
)
618 resultvec
[i
] = result_ctor
->expr
;
619 result_ctor
= gfc_constructor_next (result_ctor
);
622 gfc_extract_int (dim
, &dim_index
);
623 dim_index
-= 1; /* zero-base index */
627 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
630 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
633 dim_extent
= mpz_get_si (array
->shape
[i
]);
634 dim_stride
= tmpstride
[i
];
638 extent
[n
] = mpz_get_si (array
->shape
[i
]);
639 sstride
[n
] = tmpstride
[i
];
640 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
644 done
= resultsize
<= 0;
649 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
651 *dest
= op (*dest
, gfc_copy_expr (*src
));
654 *dest
= post_op (*dest
, *dest
);
661 while (!done
&& count
[n
] == extent
[n
])
664 base
-= sstride
[n
] * extent
[n
];
665 dest
-= dstride
[n
] * extent
[n
];
668 if (n
< result
->rank
)
670 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
671 times, we'd warn for the last iteration, because the
672 array index will have already been incremented to the
673 array sizes, and we can't tell that this must make
674 the test against result->rank false, because ranks
675 must not exceed GFC_MAX_DIMENSIONS. */
676 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
687 /* Place updated expression in result constructor. */
688 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
689 for (i
= 0; i
< resultsize
; ++i
)
691 result_ctor
->expr
= resultvec
[i
];
692 result_ctor
= gfc_constructor_next (result_ctor
);
702 simplify_transformation (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
703 int init_val
, transformational_op op
)
708 size_zero
= gfc_is_size_zero_array (array
);
710 if (!(is_constant_array_expr (array
) || size_zero
)
711 || !gfc_is_constant_expr (dim
))
715 && !is_constant_array_expr (mask
)
716 && mask
->expr_type
!= EXPR_CONSTANT
)
719 result
= transformational_result (array
, dim
, array
->ts
.type
,
720 array
->ts
.kind
, &array
->where
);
721 init_result_expr (result
, init_val
, array
);
726 return !dim
|| array
->rank
== 1 ?
727 simplify_transformation_to_scalar (result
, array
, mask
, op
) :
728 simplify_transformation_to_array (result
, array
, dim
, mask
, op
, NULL
);
732 /********************** Simplification functions *****************************/
735 gfc_simplify_abs (gfc_expr
*e
)
739 if (e
->expr_type
!= EXPR_CONSTANT
)
745 result
= gfc_get_constant_expr (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
746 mpz_abs (result
->value
.integer
, e
->value
.integer
);
747 return range_check (result
, "IABS");
750 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
751 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
752 return range_check (result
, "ABS");
755 gfc_set_model_kind (e
->ts
.kind
);
756 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
757 mpc_abs (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
758 return range_check (result
, "CABS");
761 gfc_internal_error ("gfc_simplify_abs(): Bad type");
767 simplify_achar_char (gfc_expr
*e
, gfc_expr
*k
, const char *name
, bool ascii
)
771 bool too_large
= false;
773 if (e
->expr_type
!= EXPR_CONSTANT
)
776 kind
= get_kind (BT_CHARACTER
, k
, name
, gfc_default_character_kind
);
778 return &gfc_bad_expr
;
780 if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
782 gfc_error ("Argument of %s function at %L is negative", name
,
784 return &gfc_bad_expr
;
787 if (ascii
&& warn_surprising
&& mpz_cmp_si (e
->value
.integer
, 127) > 0)
788 gfc_warning (OPT_Wsurprising
,
789 "Argument of %s function at %L outside of range [0,127]",
792 if (kind
== 1 && mpz_cmp_si (e
->value
.integer
, 255) > 0)
797 mpz_init_set_ui (t
, 2);
798 mpz_pow_ui (t
, t
, 32);
799 mpz_sub_ui (t
, t
, 1);
800 if (mpz_cmp (e
->value
.integer
, t
) > 0)
807 gfc_error ("Argument of %s function at %L is too large for the "
808 "collating sequence of kind %d", name
, &e
->where
, kind
);
809 return &gfc_bad_expr
;
812 result
= gfc_get_character_expr (kind
, &e
->where
, NULL
, 1);
813 result
->value
.character
.string
[0] = mpz_get_ui (e
->value
.integer
);
820 /* We use the processor's collating sequence, because all
821 systems that gfortran currently works on are ASCII. */
824 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
826 return simplify_achar_char (e
, k
, "ACHAR", true);
831 gfc_simplify_acos (gfc_expr
*x
)
835 if (x
->expr_type
!= EXPR_CONSTANT
)
841 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
842 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
844 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
846 return &gfc_bad_expr
;
848 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
849 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
853 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
854 mpc_acos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
858 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
861 return range_check (result
, "ACOS");
865 gfc_simplify_acosh (gfc_expr
*x
)
869 if (x
->expr_type
!= EXPR_CONSTANT
)
875 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
877 gfc_error ("Argument of ACOSH at %L must not be less than 1",
879 return &gfc_bad_expr
;
882 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
883 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
887 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
888 mpc_acosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
892 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
895 return range_check (result
, "ACOSH");
899 gfc_simplify_adjustl (gfc_expr
*e
)
905 if (e
->expr_type
!= EXPR_CONSTANT
)
908 len
= e
->value
.character
.length
;
910 for (count
= 0, i
= 0; i
< len
; ++i
)
912 ch
= e
->value
.character
.string
[i
];
918 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
919 for (i
= 0; i
< len
- count
; ++i
)
920 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
927 gfc_simplify_adjustr (gfc_expr
*e
)
933 if (e
->expr_type
!= EXPR_CONSTANT
)
936 len
= e
->value
.character
.length
;
938 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
940 ch
= e
->value
.character
.string
[i
];
946 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
947 for (i
= 0; i
< count
; ++i
)
948 result
->value
.character
.string
[i
] = ' ';
950 for (i
= count
; i
< len
; ++i
)
951 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
958 gfc_simplify_aimag (gfc_expr
*e
)
962 if (e
->expr_type
!= EXPR_CONSTANT
)
965 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
966 mpfr_set (result
->value
.real
, mpc_imagref (e
->value
.complex), GFC_RND_MODE
);
968 return range_check (result
, "AIMAG");
973 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
975 gfc_expr
*rtrunc
, *result
;
978 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
980 return &gfc_bad_expr
;
982 if (e
->expr_type
!= EXPR_CONSTANT
)
985 rtrunc
= gfc_copy_expr (e
);
986 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
988 result
= gfc_real2real (rtrunc
, kind
);
990 gfc_free_expr (rtrunc
);
992 return range_check (result
, "AINT");
997 gfc_simplify_all (gfc_expr
*mask
, gfc_expr
*dim
)
999 return simplify_transformation (mask
, dim
, NULL
, true, gfc_and
);
1004 gfc_simplify_dint (gfc_expr
*e
)
1006 gfc_expr
*rtrunc
, *result
;
1008 if (e
->expr_type
!= EXPR_CONSTANT
)
1011 rtrunc
= gfc_copy_expr (e
);
1012 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1014 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
1016 gfc_free_expr (rtrunc
);
1018 return range_check (result
, "DINT");
1023 gfc_simplify_dreal (gfc_expr
*e
)
1025 gfc_expr
*result
= NULL
;
1027 if (e
->expr_type
!= EXPR_CONSTANT
)
1030 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
1031 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
1033 return range_check (result
, "DREAL");
1038 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
1043 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
1045 return &gfc_bad_expr
;
1047 if (e
->expr_type
!= EXPR_CONSTANT
)
1050 result
= gfc_get_constant_expr (e
->ts
.type
, kind
, &e
->where
);
1051 mpfr_round (result
->value
.real
, e
->value
.real
);
1053 return range_check (result
, "ANINT");
1058 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
1063 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1066 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1071 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
1072 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1073 return range_check (result
, "AND");
1076 return gfc_get_logical_expr (kind
, &x
->where
,
1077 x
->value
.logical
&& y
->value
.logical
);
1086 gfc_simplify_any (gfc_expr
*mask
, gfc_expr
*dim
)
1088 return simplify_transformation (mask
, dim
, NULL
, false, gfc_or
);
1093 gfc_simplify_dnint (gfc_expr
*e
)
1097 if (e
->expr_type
!= EXPR_CONSTANT
)
1100 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &e
->where
);
1101 mpfr_round (result
->value
.real
, e
->value
.real
);
1103 return range_check (result
, "DNINT");
1108 gfc_simplify_asin (gfc_expr
*x
)
1112 if (x
->expr_type
!= EXPR_CONSTANT
)
1118 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1119 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1121 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1123 return &gfc_bad_expr
;
1125 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1126 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1130 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1131 mpc_asin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1135 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1138 return range_check (result
, "ASIN");
1142 /* Convert radians to degrees, i.e., x * 180 / pi. */
1150 mpfr_const_pi (tmp
, GFC_RND_MODE
);
1151 mpfr_mul_ui (x
, x
, 180, GFC_RND_MODE
);
1152 mpfr_div (x
, x
, tmp
, GFC_RND_MODE
);
1157 /* Simplify ACOSD(X) where the returned value has units of degree. */
1160 gfc_simplify_acosd (gfc_expr
*x
)
1164 if (x
->expr_type
!= EXPR_CONSTANT
)
1167 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1168 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1170 gfc_error ("Argument of ACOSD at %L must be between -1 and 1",
1172 return &gfc_bad_expr
;
1175 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1176 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1177 rad2deg (result
->value
.real
);
1179 return range_check (result
, "ACOSD");
1183 /* Simplify asind (x) where the returned value has units of degree. */
1186 gfc_simplify_asind (gfc_expr
*x
)
1190 if (x
->expr_type
!= EXPR_CONSTANT
)
1193 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1194 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1196 gfc_error ("Argument of ASIND at %L must be between -1 and 1",
1198 return &gfc_bad_expr
;
1201 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1202 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1203 rad2deg (result
->value
.real
);
1205 return range_check (result
, "ASIND");
1209 /* Simplify atand (x) where the returned value has units of degree. */
1212 gfc_simplify_atand (gfc_expr
*x
)
1216 if (x
->expr_type
!= EXPR_CONSTANT
)
1219 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1220 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1221 rad2deg (result
->value
.real
);
1223 return range_check (result
, "ATAND");
1228 gfc_simplify_asinh (gfc_expr
*x
)
1232 if (x
->expr_type
!= EXPR_CONSTANT
)
1235 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1240 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1244 mpc_asinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1248 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1251 return range_check (result
, "ASINH");
1256 gfc_simplify_atan (gfc_expr
*x
)
1260 if (x
->expr_type
!= EXPR_CONSTANT
)
1263 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1268 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1272 mpc_atan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1276 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1279 return range_check (result
, "ATAN");
1284 gfc_simplify_atanh (gfc_expr
*x
)
1288 if (x
->expr_type
!= EXPR_CONSTANT
)
1294 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
1295 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
1297 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1299 return &gfc_bad_expr
;
1301 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1302 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1306 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1307 mpc_atanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1311 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1314 return range_check (result
, "ATANH");
1319 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1323 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1326 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1328 gfc_error ("If first argument of ATAN2 at %L is zero, then the "
1329 "second argument must not be zero", &y
->where
);
1330 return &gfc_bad_expr
;
1333 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1334 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1336 return range_check (result
, "ATAN2");
1341 gfc_simplify_bessel_j0 (gfc_expr
*x
)
1345 if (x
->expr_type
!= EXPR_CONSTANT
)
1348 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1349 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1351 return range_check (result
, "BESSEL_J0");
1356 gfc_simplify_bessel_j1 (gfc_expr
*x
)
1360 if (x
->expr_type
!= EXPR_CONSTANT
)
1363 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1364 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1366 return range_check (result
, "BESSEL_J1");
1371 gfc_simplify_bessel_jn (gfc_expr
*order
, gfc_expr
*x
)
1376 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1379 n
= mpz_get_si (order
->value
.integer
);
1380 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1381 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1383 return range_check (result
, "BESSEL_JN");
1387 /* Simplify transformational form of JN and YN. */
1390 gfc_simplify_bessel_n2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
,
1397 mpfr_t x2rev
, last1
, last2
;
1399 if (x
->expr_type
!= EXPR_CONSTANT
|| order1
->expr_type
!= EXPR_CONSTANT
1400 || order2
->expr_type
!= EXPR_CONSTANT
)
1403 n1
= mpz_get_si (order1
->value
.integer
);
1404 n2
= mpz_get_si (order2
->value
.integer
);
1405 result
= gfc_get_array_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1407 result
->shape
= gfc_get_shape (1);
1408 mpz_init_set_ui (result
->shape
[0], MAX (n2
-n1
+1, 0));
1413 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1414 YN(N, 0.0) = -Inf. */
1416 if (mpfr_cmp_ui (x
->value
.real
, 0.0) == 0)
1418 if (!jn
&& flag_range_check
)
1420 gfc_error ("Result of BESSEL_YN is -INF at %L", &result
->where
);
1421 gfc_free_expr (result
);
1422 return &gfc_bad_expr
;
1427 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1428 mpfr_set_ui (e
->value
.real
, 1, GFC_RND_MODE
);
1429 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1434 for (i
= n1
; i
<= n2
; i
++)
1436 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1438 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
1440 mpfr_set_inf (e
->value
.real
, -1);
1441 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1448 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1449 are stable for downward recursion and Neumann functions are stable
1450 for upward recursion. It is
1452 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1453 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1454 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1456 gfc_set_model_kind (x
->ts
.kind
);
1458 /* Get first recursion anchor. */
1462 mpfr_jn (last1
, n2
, x
->value
.real
, GFC_RND_MODE
);
1464 mpfr_yn (last1
, n1
, x
->value
.real
, GFC_RND_MODE
);
1466 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1467 mpfr_set (e
->value
.real
, last1
, GFC_RND_MODE
);
1468 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1472 gfc_free_expr (result
);
1473 return &gfc_bad_expr
;
1475 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1483 /* Get second recursion anchor. */
1487 mpfr_jn (last2
, n2
-1, x
->value
.real
, GFC_RND_MODE
);
1489 mpfr_yn (last2
, n1
+1, x
->value
.real
, GFC_RND_MODE
);
1491 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1492 mpfr_set (e
->value
.real
, last2
, GFC_RND_MODE
);
1493 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1498 gfc_free_expr (result
);
1499 return &gfc_bad_expr
;
1502 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
, -2);
1504 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1513 /* Start actual recursion. */
1516 mpfr_ui_div (x2rev
, 2, x
->value
.real
, GFC_RND_MODE
);
1518 for (i
= 2; i
<= n2
-n1
; i
++)
1520 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1522 /* Special case: For YN, if the previous N gave -INF, set
1523 also N+1 to -INF. */
1524 if (!jn
&& !flag_range_check
&& mpfr_inf_p (last2
))
1526 mpfr_set_inf (e
->value
.real
, -1);
1527 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1532 mpfr_mul_si (e
->value
.real
, x2rev
, jn
? (n2
-i
+1) : (n1
+i
-1),
1534 mpfr_mul (e
->value
.real
, e
->value
.real
, last2
, GFC_RND_MODE
);
1535 mpfr_sub (e
->value
.real
, e
->value
.real
, last1
, GFC_RND_MODE
);
1537 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1539 /* Range_check frees "e" in that case. */
1545 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
,
1548 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1550 mpfr_set (last1
, last2
, GFC_RND_MODE
);
1551 mpfr_set (last2
, e
->value
.real
, GFC_RND_MODE
);
1564 gfc_free_expr (result
);
1565 return &gfc_bad_expr
;
1570 gfc_simplify_bessel_jn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1572 return gfc_simplify_bessel_n2 (order1
, order2
, x
, true);
1577 gfc_simplify_bessel_y0 (gfc_expr
*x
)
1581 if (x
->expr_type
!= EXPR_CONSTANT
)
1584 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1585 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1587 return range_check (result
, "BESSEL_Y0");
1592 gfc_simplify_bessel_y1 (gfc_expr
*x
)
1596 if (x
->expr_type
!= EXPR_CONSTANT
)
1599 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1600 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1602 return range_check (result
, "BESSEL_Y1");
1607 gfc_simplify_bessel_yn (gfc_expr
*order
, gfc_expr
*x
)
1612 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1615 n
= mpz_get_si (order
->value
.integer
);
1616 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1617 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1619 return range_check (result
, "BESSEL_YN");
1624 gfc_simplify_bessel_yn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1626 return gfc_simplify_bessel_n2 (order1
, order2
, x
, false);
1631 gfc_simplify_bit_size (gfc_expr
*e
)
1633 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1634 return gfc_get_int_expr (e
->ts
.kind
, &e
->where
,
1635 gfc_integer_kinds
[i
].bit_size
);
1640 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
1644 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
1647 if (gfc_extract_int (bit
, &b
) || b
< 0)
1648 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
, false);
1650 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
,
1651 mpz_tstbit (e
->value
.integer
, b
));
1656 compare_bitwise (gfc_expr
*i
, gfc_expr
*j
)
1661 gcc_assert (i
->ts
.type
== BT_INTEGER
);
1662 gcc_assert (j
->ts
.type
== BT_INTEGER
);
1664 mpz_init_set (x
, i
->value
.integer
);
1665 k
= gfc_validate_kind (i
->ts
.type
, i
->ts
.kind
, false);
1666 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
1668 mpz_init_set (y
, j
->value
.integer
);
1669 k
= gfc_validate_kind (j
->ts
.type
, j
->ts
.kind
, false);
1670 convert_mpz_to_unsigned (y
, gfc_integer_kinds
[k
].bit_size
);
1672 res
= mpz_cmp (x
, y
);
1680 gfc_simplify_bge (gfc_expr
*i
, gfc_expr
*j
)
1682 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1685 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1686 compare_bitwise (i
, j
) >= 0);
1691 gfc_simplify_bgt (gfc_expr
*i
, gfc_expr
*j
)
1693 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1696 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1697 compare_bitwise (i
, j
) > 0);
1702 gfc_simplify_ble (gfc_expr
*i
, gfc_expr
*j
)
1704 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1707 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1708 compare_bitwise (i
, j
) <= 0);
1713 gfc_simplify_blt (gfc_expr
*i
, gfc_expr
*j
)
1715 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1718 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1719 compare_bitwise (i
, j
) < 0);
1724 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
1726 gfc_expr
*ceil
, *result
;
1729 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
1731 return &gfc_bad_expr
;
1733 if (e
->expr_type
!= EXPR_CONSTANT
)
1736 ceil
= gfc_copy_expr (e
);
1737 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
1739 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
1740 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
, &e
->where
);
1742 gfc_free_expr (ceil
);
1744 return range_check (result
, "CEILING");
1749 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
1751 return simplify_achar_char (e
, k
, "CHAR", false);
1755 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1758 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
1762 if (x
->expr_type
!= EXPR_CONSTANT
1763 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1766 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &x
->where
);
1771 mpc_set_z (result
->value
.complex, x
->value
.integer
, GFC_MPC_RND_MODE
);
1775 mpc_set_fr (result
->value
.complex, x
->value
.real
, GFC_RND_MODE
);
1779 mpc_set (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1783 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1787 return range_check (result
, name
);
1792 mpfr_set_z (mpc_imagref (result
->value
.complex),
1793 y
->value
.integer
, GFC_RND_MODE
);
1797 mpfr_set (mpc_imagref (result
->value
.complex),
1798 y
->value
.real
, GFC_RND_MODE
);
1802 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1805 return range_check (result
, name
);
1810 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
1814 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_complex_kind
);
1816 return &gfc_bad_expr
;
1818 return simplify_cmplx ("CMPLX", x
, y
, kind
);
1823 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
1827 if (x
->ts
.type
== BT_INTEGER
&& y
->ts
.type
== BT_INTEGER
)
1828 kind
= gfc_default_complex_kind
;
1829 else if (x
->ts
.type
== BT_REAL
|| y
->ts
.type
== BT_INTEGER
)
1831 else if (x
->ts
.type
== BT_INTEGER
|| y
->ts
.type
== BT_REAL
)
1833 else if (x
->ts
.type
== BT_REAL
&& y
->ts
.type
== BT_REAL
)
1834 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
1838 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1843 gfc_simplify_conjg (gfc_expr
*e
)
1847 if (e
->expr_type
!= EXPR_CONSTANT
)
1850 result
= gfc_copy_expr (e
);
1851 mpc_conj (result
->value
.complex, result
->value
.complex, GFC_MPC_RND_MODE
);
1853 return range_check (result
, "CONJG");
1857 /* Simplify atan2d (x) where the unit is degree. */
1860 gfc_simplify_atan2d (gfc_expr
*y
, gfc_expr
*x
)
1864 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1867 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1869 gfc_error ("If first argument of ATAN2D at %L is zero, then the "
1870 "second argument must not be zero", &y
->where
);
1871 return &gfc_bad_expr
;
1874 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1875 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1876 rad2deg (result
->value
.real
);
1878 return range_check (result
, "ATAN2D");
1883 gfc_simplify_cos (gfc_expr
*x
)
1887 if (x
->expr_type
!= EXPR_CONSTANT
)
1890 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1895 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1899 gfc_set_model_kind (x
->ts
.kind
);
1900 mpc_cos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1904 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1907 return range_check (result
, "COS");
1917 mpfr_const_pi (d2r
, GFC_RND_MODE
);
1918 mpfr_div_ui (d2r
, d2r
, 180, GFC_RND_MODE
);
1919 mpfr_mul (x
, x
, d2r
, GFC_RND_MODE
);
1924 /* Simplification routines for SIND, COSD, TAND. */
1925 #include "trigd_fe.inc"
1928 /* Simplify COSD(X) where X has the unit of degree. */
1931 gfc_simplify_cosd (gfc_expr
*x
)
1935 if (x
->expr_type
!= EXPR_CONSTANT
)
1938 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1939 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1940 simplify_cosd (result
->value
.real
);
1942 return range_check (result
, "COSD");
1946 /* Simplify SIND(X) where X has the unit of degree. */
1949 gfc_simplify_sind (gfc_expr
*x
)
1953 if (x
->expr_type
!= EXPR_CONSTANT
)
1956 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1957 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1958 simplify_sind (result
->value
.real
);
1960 return range_check (result
, "SIND");
1964 /* Simplify TAND(X) where X has the unit of degree. */
1967 gfc_simplify_tand (gfc_expr
*x
)
1971 if (x
->expr_type
!= EXPR_CONSTANT
)
1974 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1975 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1976 simplify_tand (result
->value
.real
);
1978 return range_check (result
, "TAND");
1982 /* Simplify COTAND(X) where X has the unit of degree. */
1985 gfc_simplify_cotand (gfc_expr
*x
)
1989 if (x
->expr_type
!= EXPR_CONSTANT
)
1992 /* Implement COTAND = -TAND(x+90).
1993 TAND offers correct exact values for multiples of 30 degrees.
1994 This implementation is also compatible with the behavior of some legacy
1995 compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */
1996 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1997 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1998 mpfr_add_ui (result
->value
.real
, result
->value
.real
, 90, GFC_RND_MODE
);
1999 simplify_tand (result
->value
.real
);
2000 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
2002 return range_check (result
, "COTAND");
2007 gfc_simplify_cosh (gfc_expr
*x
)
2011 if (x
->expr_type
!= EXPR_CONSTANT
)
2014 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2019 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2023 mpc_cosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2030 return range_check (result
, "COSH");
2035 gfc_simplify_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
2040 size_zero
= gfc_is_size_zero_array (mask
);
2042 if (!(is_constant_array_expr (mask
) || size_zero
)
2043 || !gfc_is_constant_expr (dim
)
2044 || !gfc_is_constant_expr (kind
))
2047 result
= transformational_result (mask
, dim
,
2049 get_kind (BT_INTEGER
, kind
, "COUNT",
2050 gfc_default_integer_kind
),
2053 init_result_expr (result
, 0, NULL
);
2058 /* Passing MASK twice, once as data array, once as mask.
2059 Whenever gfc_count is called, '1' is added to the result. */
2060 return !dim
|| mask
->rank
== 1 ?
2061 simplify_transformation_to_scalar (result
, mask
, mask
, gfc_count
) :
2062 simplify_transformation_to_array (result
, mask
, dim
, mask
, gfc_count
, NULL
);
2065 /* Simplification routine for cshift. This works by copying the array
2066 expressions into a one-dimensional array, shuffling the values into another
2067 one-dimensional array and creating the new array expression from this. The
2068 shuffling part is basically taken from the library routine. */
2071 gfc_simplify_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
2075 gfc_expr
**arrayvec
, **resultvec
;
2076 gfc_expr
**rptr
, **sptr
;
2078 size_t arraysize
, shiftsize
, i
;
2079 gfc_constructor
*array_ctor
, *shift_ctor
;
2080 ssize_t
*shiftvec
, *hptr
;
2081 ssize_t shift_val
, len
;
2082 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
2083 hs_ex
[GFC_MAX_DIMENSIONS
+ 1],
2084 hstride
[GFC_MAX_DIMENSIONS
], sstride
[GFC_MAX_DIMENSIONS
],
2085 a_extent
[GFC_MAX_DIMENSIONS
], a_stride
[GFC_MAX_DIMENSIONS
],
2086 h_extent
[GFC_MAX_DIMENSIONS
],
2087 ss_ex
[GFC_MAX_DIMENSIONS
+ 1];
2091 gfc_expr
**src
, **dest
;
2093 if (!is_constant_array_expr (array
))
2096 if (shift
->rank
> 0)
2097 gfc_simplify_expr (shift
, 1);
2099 if (!gfc_is_constant_expr (shift
))
2102 /* Make dim zero-based. */
2105 if (!gfc_is_constant_expr (dim
))
2107 which
= mpz_get_si (dim
->value
.integer
) - 1;
2112 gfc_array_size (array
, &size
);
2113 arraysize
= mpz_get_ui (size
);
2116 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
2117 result
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
2118 result
->rank
= array
->rank
;
2119 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
2124 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2125 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
2126 for (i
= 0; i
< arraysize
; i
++)
2128 arrayvec
[i
] = array_ctor
->expr
;
2129 array_ctor
= gfc_constructor_next (array_ctor
);
2132 resultvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2137 for (d
=0; d
< array
->rank
; d
++)
2139 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2140 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2143 if (shift
->rank
> 0)
2145 gfc_array_size (shift
, &size
);
2146 shiftsize
= mpz_get_ui (size
);
2148 shiftvec
= XCNEWVEC (ssize_t
, shiftsize
);
2149 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2150 for (d
= 0; d
< shift
->rank
; d
++)
2152 h_extent
[d
] = mpz_get_si (shift
->shape
[d
]);
2153 hstride
[d
] = d
== 0 ? 1 : hstride
[d
-1] * h_extent
[d
-1];
2159 /* Shut up compiler */
2164 for (d
=0; d
< array
->rank
; d
++)
2168 rsoffset
= a_stride
[d
];
2174 extent
[n
] = a_extent
[d
];
2175 sstride
[n
] = a_stride
[d
];
2176 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2178 hs_ex
[n
] = hstride
[n
] * extent
[n
];
2187 for (i
= 0; i
< shiftsize
; i
++)
2190 val
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2195 shift_ctor
= gfc_constructor_next (shift_ctor
);
2201 shift_val
= mpz_get_si (shift
->value
.integer
);
2202 shift_val
= shift_val
% len
;
2207 continue_loop
= true;
2213 while (continue_loop
)
2221 src
= &sptr
[sh
* rsoffset
];
2223 for (n
= 0; n
< len
- sh
; n
++)
2230 for ( n
= 0; n
< sh
; n
++)
2242 while (count
[n
] == extent
[n
])
2252 continue_loop
= false;
2266 for (i
= 0; i
< arraysize
; i
++)
2268 gfc_constructor_append_expr (&result
->value
.constructor
,
2269 gfc_copy_expr (resultvec
[i
]),
2277 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2279 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
2284 gfc_simplify_dble (gfc_expr
*e
)
2286 gfc_expr
*result
= NULL
;
2289 if (e
->expr_type
!= EXPR_CONSTANT
)
2292 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
2294 tmp1
= warn_conversion
;
2295 tmp2
= warn_conversion_extra
;
2296 warn_conversion
= warn_conversion_extra
= 0;
2298 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
2300 warn_conversion
= tmp1
;
2301 warn_conversion_extra
= tmp2
;
2303 if (result
== &gfc_bad_expr
)
2304 return &gfc_bad_expr
;
2306 return range_check (result
, "DBLE");
2311 gfc_simplify_digits (gfc_expr
*x
)
2315 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2320 digits
= gfc_integer_kinds
[i
].digits
;
2325 digits
= gfc_real_kinds
[i
].digits
;
2332 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
2337 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
2342 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2345 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2346 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
2351 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
2352 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2354 mpz_set_ui (result
->value
.integer
, 0);
2359 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
2360 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
2363 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2368 gfc_internal_error ("gfc_simplify_dim(): Bad type");
2371 return range_check (result
, "DIM");
2376 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2378 /* If vector_a is a zero-sized array, the result is 0 for INTEGER,
2379 REAL, and COMPLEX types and .false. for LOGICAL. */
2380 if (vector_a
->shape
&& mpz_get_si (vector_a
->shape
[0]) == 0)
2382 if (vector_a
->ts
.type
== BT_LOGICAL
)
2383 return gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, false);
2385 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2388 if (!is_constant_array_expr (vector_a
)
2389 || !is_constant_array_expr (vector_b
))
2392 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
2397 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
2399 gfc_expr
*a1
, *a2
, *result
;
2401 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2404 a1
= gfc_real2real (x
, gfc_default_double_kind
);
2405 a2
= gfc_real2real (y
, gfc_default_double_kind
);
2407 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
2408 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
2413 return range_check (result
, "DPROD");
2418 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
2422 int i
, k
, size
, shift
;
2424 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
2425 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
2428 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
2429 size
= gfc_integer_kinds
[k
].bit_size
;
2431 gfc_extract_int (shiftarg
, &shift
);
2433 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2435 shift
= size
- shift
;
2437 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
2438 mpz_set_ui (result
->value
.integer
, 0);
2440 for (i
= 0; i
< shift
; i
++)
2441 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
2442 mpz_setbit (result
->value
.integer
, i
);
2444 for (i
= 0; i
< size
- shift
; i
++)
2445 if (mpz_tstbit (arg1
->value
.integer
, i
))
2446 mpz_setbit (result
->value
.integer
, shift
+ i
);
2448 /* Convert to a signed value. */
2449 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
2456 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2458 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
2463 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2465 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
2470 gfc_simplify_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2477 gfc_expr
**arrayvec
, **resultvec
;
2478 gfc_expr
**rptr
, **sptr
;
2480 size_t arraysize
, i
;
2481 gfc_constructor
*array_ctor
, *shift_ctor
, *bnd_ctor
;
2482 ssize_t shift_val
, len
;
2483 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
2484 sstride
[GFC_MAX_DIMENSIONS
], a_extent
[GFC_MAX_DIMENSIONS
],
2485 a_stride
[GFC_MAX_DIMENSIONS
], ss_ex
[GFC_MAX_DIMENSIONS
+ 1];
2489 gfc_expr
**src
, **dest
;
2492 if (!is_constant_array_expr (array
))
2495 if (shift
->rank
> 0)
2496 gfc_simplify_expr (shift
, 1);
2498 if (!gfc_is_constant_expr (shift
))
2503 if (boundary
->rank
> 0)
2504 gfc_simplify_expr (boundary
, 1);
2506 if (!gfc_is_constant_expr (boundary
))
2512 if (!gfc_is_constant_expr (dim
))
2514 which
= mpz_get_si (dim
->value
.integer
) - 1;
2520 if (boundary
== NULL
)
2522 temp_boundary
= true;
2523 switch (array
->ts
.type
)
2527 bnd
= gfc_get_int_expr (array
->ts
.kind
, NULL
, 0);
2531 bnd
= gfc_get_logical_expr (array
->ts
.kind
, NULL
, 0);
2535 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2536 mpfr_set_ui (bnd
->value
.real
, 0, GFC_RND_MODE
);
2540 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2541 mpc_set_ui (bnd
->value
.complex, 0, GFC_RND_MODE
);
2545 s_len
= mpz_get_ui (array
->ts
.u
.cl
->length
->value
.integer
);
2546 bnd
= gfc_get_character_expr (array
->ts
.kind
, &gfc_current_locus
, NULL
, s_len
);
2556 temp_boundary
= false;
2560 gfc_array_size (array
, &size
);
2561 arraysize
= mpz_get_ui (size
);
2564 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
2565 result
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
2566 result
->rank
= array
->rank
;
2567 result
->ts
= array
->ts
;
2572 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2573 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
2574 for (i
= 0; i
< arraysize
; i
++)
2576 arrayvec
[i
] = array_ctor
->expr
;
2577 array_ctor
= gfc_constructor_next (array_ctor
);
2580 resultvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2585 for (d
=0; d
< array
->rank
; d
++)
2587 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2588 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2591 if (shift
->rank
> 0)
2593 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2599 shift_val
= mpz_get_si (shift
->value
.integer
);
2603 bnd_ctor
= gfc_constructor_first (bnd
->value
.constructor
);
2607 /* Shut up compiler */
2612 for (d
=0; d
< array
->rank
; d
++)
2616 rsoffset
= a_stride
[d
];
2622 extent
[n
] = a_extent
[d
];
2623 sstride
[n
] = a_stride
[d
];
2624 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2630 continue_loop
= true;
2635 while (continue_loop
)
2640 sh
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2644 if (( sh
>= 0 ? sh
: -sh
) > len
)
2650 delta
= (sh
>= 0) ? sh
: -sh
;
2654 src
= &sptr
[delta
* rsoffset
];
2660 dest
= &rptr
[delta
* rsoffset
];
2663 for (n
= 0; n
< len
- delta
; n
++)
2679 *dest
= gfc_copy_expr (bnd_ctor
->expr
);
2687 *dest
= gfc_copy_expr (bnd
);
2694 shift_ctor
= gfc_constructor_next (shift_ctor
);
2697 bnd_ctor
= gfc_constructor_next (bnd_ctor
);
2701 while (count
[n
] == extent
[n
])
2709 continue_loop
= false;
2721 for (i
= 0; i
< arraysize
; i
++)
2723 gfc_constructor_append_expr (&result
->value
.constructor
,
2724 gfc_copy_expr (resultvec
[i
]),
2730 gfc_free_expr (bnd
);
2736 gfc_simplify_erf (gfc_expr
*x
)
2740 if (x
->expr_type
!= EXPR_CONSTANT
)
2743 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2744 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2746 return range_check (result
, "ERF");
2751 gfc_simplify_erfc (gfc_expr
*x
)
2755 if (x
->expr_type
!= EXPR_CONSTANT
)
2758 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2759 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2761 return range_check (result
, "ERFC");
2765 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2767 #define MAX_ITER 200
2768 #define ARG_LIMIT 12
2770 /* Calculate ERFC_SCALED directly by its definition:
2772 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2774 using a large precision for intermediate results. This is used for all
2775 but large values of the argument. */
2777 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2782 prec
= mpfr_get_default_prec ();
2783 mpfr_set_default_prec (10 * prec
);
2788 mpfr_set (a
, arg
, GFC_RND_MODE
);
2789 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2790 mpfr_exp (b
, b
, GFC_RND_MODE
);
2791 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2792 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2794 mpfr_set (res
, a
, GFC_RND_MODE
);
2795 mpfr_set_default_prec (prec
);
2801 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2803 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2804 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2807 This is used for large values of the argument. Intermediate calculations
2808 are performed with twice the precision. We don't do a fixed number of
2809 iterations of the sum, but stop when it has converged to the required
2812 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2814 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2819 prec
= mpfr_get_default_prec ();
2820 mpfr_set_default_prec (2 * prec
);
2830 mpfr_init (sumtrunc
);
2831 mpfr_set_prec (oldsum
, prec
);
2832 mpfr_set_prec (sumtrunc
, prec
);
2834 mpfr_set (x
, arg
, GFC_RND_MODE
);
2835 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2836 mpz_set_ui (num
, 1);
2838 mpfr_set (u
, x
, GFC_RND_MODE
);
2839 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2840 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2841 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2843 for (i
= 1; i
< MAX_ITER
; i
++)
2845 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2847 mpz_mul_ui (num
, num
, 2 * i
- 1);
2850 mpfr_set (w
, u
, GFC_RND_MODE
);
2851 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2853 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2854 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2856 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2858 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2859 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2863 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2865 gcc_assert (i
< MAX_ITER
);
2867 /* Divide by x * sqrt(Pi). */
2868 mpfr_const_pi (u
, GFC_RND_MODE
);
2869 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2870 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2871 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2873 mpfr_set (res
, sum
, GFC_RND_MODE
);
2874 mpfr_set_default_prec (prec
);
2876 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2882 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2886 if (x
->expr_type
!= EXPR_CONSTANT
)
2889 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2890 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2891 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2893 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2895 return range_check (result
, "ERFC_SCALED");
2903 gfc_simplify_epsilon (gfc_expr
*e
)
2908 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2910 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2911 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2913 return range_check (result
, "EPSILON");
2918 gfc_simplify_exp (gfc_expr
*x
)
2922 if (x
->expr_type
!= EXPR_CONSTANT
)
2925 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2930 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2934 gfc_set_model_kind (x
->ts
.kind
);
2935 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2939 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2942 return range_check (result
, "EXP");
2947 gfc_simplify_exponent (gfc_expr
*x
)
2952 if (x
->expr_type
!= EXPR_CONSTANT
)
2955 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2958 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2959 if (mpfr_inf_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
2961 int i
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
2962 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2966 /* EXPONENT(+/- 0.0) = 0 */
2967 if (mpfr_zero_p (x
->value
.real
))
2969 mpz_set_ui (result
->value
.integer
, 0);
2973 gfc_set_model (x
->value
.real
);
2975 val
= (long int) mpfr_get_exp (x
->value
.real
);
2976 mpz_set_si (result
->value
.integer
, val
);
2978 return range_check (result
, "EXPONENT");
2983 gfc_simplify_failed_or_stopped_images (gfc_expr
*team ATTRIBUTE_UNUSED
,
2986 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2988 gfc_current_locus
= *gfc_current_intrinsic_where
;
2989 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2990 return &gfc_bad_expr
;
2993 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2998 gfc_extract_int (kind
, &actual_kind
);
3000 actual_kind
= gfc_default_integer_kind
;
3002 result
= gfc_get_array_expr (BT_INTEGER
, actual_kind
, &gfc_current_locus
);
3007 /* For fcoarray = lib no simplification is possible, because it is not known
3008 what images failed or are stopped at compile time. */
3014 gfc_simplify_get_team (gfc_expr
*level ATTRIBUTE_UNUSED
)
3016 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3018 gfc_current_locus
= *gfc_current_intrinsic_where
;
3019 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3020 return &gfc_bad_expr
;
3023 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
3026 result
= gfc_get_array_expr (BT_INTEGER
, gfc_default_integer_kind
, &gfc_current_locus
);
3031 /* For fcoarray = lib no simplification is possible, because it is not known
3032 what images failed or are stopped at compile time. */
3038 gfc_simplify_float (gfc_expr
*a
)
3042 if (a
->expr_type
!= EXPR_CONSTANT
)
3045 result
= gfc_int2real (a
, gfc_default_real_kind
);
3047 return range_check (result
, "FLOAT");
3052 is_last_ref_vtab (gfc_expr
*e
)
3055 gfc_component
*comp
= NULL
;
3057 if (e
->expr_type
!= EXPR_VARIABLE
)
3060 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3061 if (ref
->type
== REF_COMPONENT
)
3062 comp
= ref
->u
.c
.component
;
3064 if (!e
->ref
|| !comp
)
3065 return e
->symtree
->n
.sym
->attr
.vtab
;
3067 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
3075 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
3077 /* Avoid simplification of resolved symbols. */
3078 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
3081 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
3082 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3083 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3086 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
3089 /* Return .false. if the dynamic type can never be an extension. */
3090 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
3091 && !gfc_type_is_extension_of
3092 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
3093 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
3094 && !gfc_type_is_extension_of
3095 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
3096 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
3097 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
3098 && !gfc_type_is_extension_of
3099 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
3101 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3102 && !gfc_type_is_extension_of
3103 (mold
->ts
.u
.derived
,
3104 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
3105 && !gfc_type_is_extension_of
3106 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
3107 mold
->ts
.u
.derived
)))
3108 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3110 /* Return .true. if the dynamic type is guaranteed to be an extension. */
3111 if (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3112 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3113 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
3114 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
3121 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3123 /* Avoid simplification of resolved symbols. */
3124 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
3127 /* Return .false. if the dynamic type can never be the
3129 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
3130 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
3131 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
3132 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
3133 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3135 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
3138 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3139 gfc_compare_derived_types (a
->ts
.u
.derived
,
3145 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
3151 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
3153 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3155 if (e
->expr_type
!= EXPR_CONSTANT
)
3158 mpfr_init2 (floor
, mpfr_get_prec (e
->value
.real
));
3159 mpfr_floor (floor
, e
->value
.real
);
3161 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
3162 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
3166 return range_check (result
, "FLOOR");
3171 gfc_simplify_fraction (gfc_expr
*x
)
3176 if (x
->expr_type
!= EXPR_CONSTANT
)
3179 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
3181 /* FRACTION(inf) = NaN. */
3182 if (mpfr_inf_p (x
->value
.real
))
3184 mpfr_set_nan (result
->value
.real
);
3188 /* mpfr_frexp() correctly handles zeros and NaNs. */
3189 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3191 return range_check (result
, "FRACTION");
3196 gfc_simplify_gamma (gfc_expr
*x
)
3200 if (x
->expr_type
!= EXPR_CONSTANT
)
3203 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3204 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3206 return range_check (result
, "GAMMA");
3211 gfc_simplify_huge (gfc_expr
*e
)
3216 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3217 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3222 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
3226 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
3238 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
3242 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3245 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3246 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
3247 return range_check (result
, "HYPOT");
3251 /* We use the processor's collating sequence, because all
3252 systems that gfortran currently works on are ASCII. */
3255 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
3261 if (e
->expr_type
!= EXPR_CONSTANT
)
3264 if (e
->value
.character
.length
!= 1)
3266 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
3267 return &gfc_bad_expr
;
3270 index
= e
->value
.character
.string
[0];
3272 if (warn_surprising
&& index
> 127)
3273 gfc_warning (OPT_Wsurprising
,
3274 "Argument of IACHAR function at %L outside of range 0..127",
3277 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
3279 return &gfc_bad_expr
;
3281 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3283 return range_check (result
, "IACHAR");
3288 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
3290 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3291 gcc_assert (result
->ts
.type
== BT_INTEGER
3292 && result
->expr_type
== EXPR_CONSTANT
);
3294 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3300 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3302 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
3307 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
3309 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3310 gcc_assert (result
->ts
.type
== BT_INTEGER
3311 && result
->expr_type
== EXPR_CONSTANT
);
3313 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3319 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3321 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
3326 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
3330 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3333 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3334 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3336 return range_check (result
, "IAND");
3341 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
3346 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3349 gfc_extract_int (y
, &pos
);
3351 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3353 result
= gfc_copy_expr (x
);
3355 convert_mpz_to_unsigned (result
->value
.integer
,
3356 gfc_integer_kinds
[k
].bit_size
);
3358 mpz_clrbit (result
->value
.integer
, pos
);
3360 gfc_convert_mpz_to_signed (result
->value
.integer
,
3361 gfc_integer_kinds
[k
].bit_size
);
3368 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
3375 if (x
->expr_type
!= EXPR_CONSTANT
3376 || y
->expr_type
!= EXPR_CONSTANT
3377 || z
->expr_type
!= EXPR_CONSTANT
)
3380 gfc_extract_int (y
, &pos
);
3381 gfc_extract_int (z
, &len
);
3383 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
3385 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3387 if (pos
+ len
> bitsize
)
3389 gfc_error ("Sum of second and third arguments of IBITS exceeds "
3390 "bit size at %L", &y
->where
);
3391 return &gfc_bad_expr
;
3394 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3395 convert_mpz_to_unsigned (result
->value
.integer
,
3396 gfc_integer_kinds
[k
].bit_size
);
3398 bits
= XCNEWVEC (int, bitsize
);
3400 for (i
= 0; i
< bitsize
; i
++)
3403 for (i
= 0; i
< len
; i
++)
3404 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
3406 for (i
= 0; i
< bitsize
; i
++)
3409 mpz_clrbit (result
->value
.integer
, i
);
3410 else if (bits
[i
] == 1)
3411 mpz_setbit (result
->value
.integer
, i
);
3413 gfc_internal_error ("IBITS: Bad bit");
3418 gfc_convert_mpz_to_signed (result
->value
.integer
,
3419 gfc_integer_kinds
[k
].bit_size
);
3426 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
3431 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3434 gfc_extract_int (y
, &pos
);
3436 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3438 result
= gfc_copy_expr (x
);
3440 convert_mpz_to_unsigned (result
->value
.integer
,
3441 gfc_integer_kinds
[k
].bit_size
);
3443 mpz_setbit (result
->value
.integer
, pos
);
3445 gfc_convert_mpz_to_signed (result
->value
.integer
,
3446 gfc_integer_kinds
[k
].bit_size
);
3453 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
3459 if (e
->expr_type
!= EXPR_CONSTANT
)
3462 if (e
->value
.character
.length
!= 1)
3464 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
3465 return &gfc_bad_expr
;
3468 index
= e
->value
.character
.string
[0];
3470 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
3472 return &gfc_bad_expr
;
3474 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3476 return range_check (result
, "ICHAR");
3481 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
3485 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3488 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3489 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3491 return range_check (result
, "IEOR");
3496 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
3499 int back
, len
, lensub
;
3500 int i
, j
, k
, count
, index
= 0, start
;
3502 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
3503 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
3506 if (b
!= NULL
&& b
->value
.logical
!= 0)
3511 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
3513 return &gfc_bad_expr
;
3515 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
3517 len
= x
->value
.character
.length
;
3518 lensub
= y
->value
.character
.length
;
3522 mpz_set_si (result
->value
.integer
, 0);
3530 mpz_set_si (result
->value
.integer
, 1);
3533 else if (lensub
== 1)
3535 for (i
= 0; i
< len
; i
++)
3537 for (j
= 0; j
< lensub
; j
++)
3539 if (y
->value
.character
.string
[j
]
3540 == x
->value
.character
.string
[i
])
3550 for (i
= 0; i
< len
; i
++)
3552 for (j
= 0; j
< lensub
; j
++)
3554 if (y
->value
.character
.string
[j
]
3555 == x
->value
.character
.string
[i
])
3560 for (k
= 0; k
< lensub
; k
++)
3562 if (y
->value
.character
.string
[k
]
3563 == x
->value
.character
.string
[k
+ start
])
3567 if (count
== lensub
)
3582 mpz_set_si (result
->value
.integer
, len
+ 1);
3585 else if (lensub
== 1)
3587 for (i
= 0; i
< len
; i
++)
3589 for (j
= 0; j
< lensub
; j
++)
3591 if (y
->value
.character
.string
[j
]
3592 == x
->value
.character
.string
[len
- i
])
3594 index
= len
- i
+ 1;
3602 for (i
= 0; i
< len
; i
++)
3604 for (j
= 0; j
< lensub
; j
++)
3606 if (y
->value
.character
.string
[j
]
3607 == x
->value
.character
.string
[len
- i
])
3610 if (start
<= len
- lensub
)
3613 for (k
= 0; k
< lensub
; k
++)
3614 if (y
->value
.character
.string
[k
]
3615 == x
->value
.character
.string
[k
+ start
])
3618 if (count
== lensub
)
3635 mpz_set_si (result
->value
.integer
, index
);
3636 return range_check (result
, "INDEX");
3641 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
3643 gfc_expr
*result
= NULL
;
3646 /* Convert BOZ to integer, and return without range checking. */
3647 if (e
->ts
.type
== BT_BOZ
)
3649 if (!gfc_boz2int (e
, kind
))
3651 result
= gfc_copy_expr (e
);
3655 if (e
->expr_type
!= EXPR_CONSTANT
)
3658 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
3660 tmp1
= warn_conversion
;
3661 tmp2
= warn_conversion_extra
;
3662 warn_conversion
= warn_conversion_extra
= 0;
3664 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
3666 warn_conversion
= tmp1
;
3667 warn_conversion_extra
= tmp2
;
3669 if (result
== &gfc_bad_expr
)
3670 return &gfc_bad_expr
;
3672 return range_check (result
, name
);
3677 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
3681 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
3683 return &gfc_bad_expr
;
3685 return simplify_intconv (e
, kind
, "INT");
3689 gfc_simplify_int2 (gfc_expr
*e
)
3691 return simplify_intconv (e
, 2, "INT2");
3696 gfc_simplify_int8 (gfc_expr
*e
)
3698 return simplify_intconv (e
, 8, "INT8");
3703 gfc_simplify_long (gfc_expr
*e
)
3705 return simplify_intconv (e
, 4, "LONG");
3710 gfc_simplify_ifix (gfc_expr
*e
)
3712 gfc_expr
*rtrunc
, *result
;
3714 if (e
->expr_type
!= EXPR_CONSTANT
)
3717 rtrunc
= gfc_copy_expr (e
);
3718 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3720 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3722 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3724 gfc_free_expr (rtrunc
);
3726 return range_check (result
, "IFIX");
3731 gfc_simplify_idint (gfc_expr
*e
)
3733 gfc_expr
*rtrunc
, *result
;
3735 if (e
->expr_type
!= EXPR_CONSTANT
)
3738 rtrunc
= gfc_copy_expr (e
);
3739 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3741 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3743 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3745 gfc_free_expr (rtrunc
);
3747 return range_check (result
, "IDINT");
3752 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
3756 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3759 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3760 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3762 return range_check (result
, "IOR");
3767 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
3769 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3770 gcc_assert (result
->ts
.type
== BT_INTEGER
3771 && result
->expr_type
== EXPR_CONSTANT
);
3773 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3779 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3781 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3786 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3788 if (x
->expr_type
!= EXPR_CONSTANT
)
3791 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3792 mpz_cmp_si (x
->value
.integer
,
3793 LIBERROR_END
) == 0);
3798 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3800 if (x
->expr_type
!= EXPR_CONSTANT
)
3803 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3804 mpz_cmp_si (x
->value
.integer
,
3805 LIBERROR_EOR
) == 0);
3810 gfc_simplify_isnan (gfc_expr
*x
)
3812 if (x
->expr_type
!= EXPR_CONSTANT
)
3815 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3816 mpfr_nan_p (x
->value
.real
));
3820 /* Performs a shift on its first argument. Depending on the last
3821 argument, the shift can be arithmetic, i.e. with filling from the
3822 left like in the SHIFTA intrinsic. */
3824 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3825 bool arithmetic
, int direction
)
3828 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3830 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3833 gfc_extract_int (s
, &shift
);
3835 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3836 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3838 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3842 mpz_set (result
->value
.integer
, e
->value
.integer
);
3846 if (direction
> 0 && shift
< 0)
3848 /* Left shift, as in SHIFTL. */
3849 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3850 return &gfc_bad_expr
;
3852 else if (direction
< 0)
3854 /* Right shift, as in SHIFTR or SHIFTA. */
3857 gfc_error ("Second argument of %s is negative at %L",
3859 return &gfc_bad_expr
;
3865 ashift
= (shift
>= 0 ? shift
: -shift
);
3867 if (ashift
> bitsize
)
3869 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3870 "at %L", name
, &e
->where
);
3871 return &gfc_bad_expr
;
3874 bits
= XCNEWVEC (int, bitsize
);
3876 for (i
= 0; i
< bitsize
; i
++)
3877 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3882 for (i
= 0; i
< shift
; i
++)
3883 mpz_clrbit (result
->value
.integer
, i
);
3885 for (i
= 0; i
< bitsize
- shift
; i
++)
3888 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3890 mpz_setbit (result
->value
.integer
, i
+ shift
);
3896 if (arithmetic
&& bits
[bitsize
- 1])
3897 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3898 mpz_setbit (result
->value
.integer
, i
);
3900 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3901 mpz_clrbit (result
->value
.integer
, i
);
3903 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3906 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3908 mpz_setbit (result
->value
.integer
, i
- ashift
);
3912 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3920 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3922 return simplify_shift (e
, s
, "ISHFT", false, 0);
3927 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3929 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3934 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3936 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3941 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3943 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3948 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3950 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3955 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3957 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3962 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3965 int shift
, ashift
, isize
, ssize
, delta
, k
;
3968 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3971 gfc_extract_int (s
, &shift
);
3973 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3974 isize
= gfc_integer_kinds
[k
].bit_size
;
3978 if (sz
->expr_type
!= EXPR_CONSTANT
)
3981 gfc_extract_int (sz
, &ssize
);
3994 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3995 "BIT_SIZE of first argument at %C");
3997 gfc_error ("Absolute value of SHIFT shall be less than or equal "
3999 return &gfc_bad_expr
;
4002 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4004 mpz_set (result
->value
.integer
, e
->value
.integer
);
4009 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
4011 bits
= XCNEWVEC (int, ssize
);
4013 for (i
= 0; i
< ssize
; i
++)
4014 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
4016 delta
= ssize
- ashift
;
4020 for (i
= 0; i
< delta
; i
++)
4023 mpz_clrbit (result
->value
.integer
, i
+ shift
);
4025 mpz_setbit (result
->value
.integer
, i
+ shift
);
4028 for (i
= delta
; i
< ssize
; i
++)
4031 mpz_clrbit (result
->value
.integer
, i
- delta
);
4033 mpz_setbit (result
->value
.integer
, i
- delta
);
4038 for (i
= 0; i
< ashift
; i
++)
4041 mpz_clrbit (result
->value
.integer
, i
+ delta
);
4043 mpz_setbit (result
->value
.integer
, i
+ delta
);
4046 for (i
= ashift
; i
< ssize
; i
++)
4049 mpz_clrbit (result
->value
.integer
, i
+ shift
);
4051 mpz_setbit (result
->value
.integer
, i
+ shift
);
4055 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
4063 gfc_simplify_kind (gfc_expr
*e
)
4065 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
4070 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
4071 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
4073 gfc_expr
*l
, *u
, *result
;
4076 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4077 gfc_default_integer_kind
);
4079 return &gfc_bad_expr
;
4081 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4083 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
4084 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
4085 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
4089 gfc_expr
* dim
= result
;
4090 mpz_set_si (dim
->value
.integer
, d
);
4092 result
= simplify_size (array
, dim
, k
);
4093 gfc_free_expr (dim
);
4098 mpz_set_si (result
->value
.integer
, 1);
4103 /* Otherwise, we have a variable expression. */
4104 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
4107 if (!gfc_resolve_array_spec (as
, 0))
4110 /* The last dimension of an assumed-size array is special. */
4111 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
4112 || (coarray
&& d
== as
->rank
+ as
->corank
4113 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
4115 if (as
->lower
[d
-1] && as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
4117 gfc_free_expr (result
);
4118 return gfc_copy_expr (as
->lower
[d
-1]);
4124 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4126 /* Then, we need to know the extent of the given dimension. */
4127 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
4129 gfc_expr
*declared_bound
;
4131 bool constant_lbound
, constant_ubound
;
4136 gcc_assert (l
!= NULL
);
4138 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
4139 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
4141 empty_bound
= upper
? 0 : 1;
4142 declared_bound
= upper
? u
: l
;
4144 if ((!upper
&& !constant_lbound
)
4145 || (upper
&& !constant_ubound
))
4150 /* For {L,U}BOUND, the value depends on whether the array
4151 is empty. We can nevertheless simplify if the declared bound
4152 has the same value as that of an empty array, in which case
4153 the result isn't dependent on the array emptyness. */
4154 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
4155 mpz_set_si (result
->value
.integer
, empty_bound
);
4156 else if (!constant_lbound
|| !constant_ubound
)
4157 /* Array emptyness can't be determined, we can't simplify. */
4159 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
4160 mpz_set_si (result
->value
.integer
, empty_bound
);
4162 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4165 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4171 int d2
= 0, cnt
= 0;
4172 for (int idx
= 0; idx
< ref
->u
.ar
.dimen
; ++idx
)
4174 if (ref
->u
.ar
.dimen_type
[idx
] == DIMEN_ELEMENT
)
4176 else if (cnt
< d
- 1)
4181 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d2
+ d
- 1, &result
->value
.integer
, NULL
))
4185 mpz_set_si (result
->value
.integer
, (long int) 1);
4189 return range_check (result
, upper
? "UBOUND" : "LBOUND");
4192 gfc_free_expr (result
);
4198 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4202 ar_type type
= AR_UNKNOWN
;
4205 if (array
->ts
.type
== BT_CLASS
)
4208 if (array
->expr_type
!= EXPR_VARIABLE
)
4215 /* Do not attempt to resolve if error has already been issued. */
4216 if (array
->symtree
->n
.sym
->error
)
4219 /* Follow any component references. */
4220 as
= array
->symtree
->n
.sym
->as
;
4221 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4226 type
= ref
->u
.ar
.type
;
4227 switch (ref
->u
.ar
.type
)
4234 /* We're done because 'as' has already been set in the
4235 previous iteration. */
4249 as
= ref
->u
.c
.component
->as
;
4262 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
4263 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
4267 || (as
->type
!= AS_DEFERRED
4268 && array
->expr_type
== EXPR_VARIABLE
4269 && !gfc_expr_attr (array
).allocatable
4270 && !gfc_expr_attr (array
).pointer
));
4274 /* Multi-dimensional bounds. */
4275 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4279 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4280 if (upper
&& type
== AR_FULL
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
4282 /* An error message will be emitted in
4283 check_assumed_size_reference (resolve.c). */
4284 return &gfc_bad_expr
;
4287 /* Simplify the bounds for each dimension. */
4288 for (d
= 0; d
< array
->rank
; d
++)
4290 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
4292 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4296 for (j
= 0; j
< d
; j
++)
4297 gfc_free_expr (bounds
[j
]);
4300 return &gfc_bad_expr
;
4306 /* Allocate the result expression. */
4307 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4308 gfc_default_integer_kind
);
4310 return &gfc_bad_expr
;
4312 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
4314 /* The result is a rank 1 array; its size is the rank of the first
4315 argument to {L,U}BOUND. */
4317 e
->shape
= gfc_get_shape (1);
4318 mpz_init_set_ui (e
->shape
[0], array
->rank
);
4320 /* Create the constructor for this array. */
4321 for (d
= 0; d
< array
->rank
; d
++)
4322 gfc_constructor_append_expr (&e
->value
.constructor
,
4323 bounds
[d
], &e
->where
);
4329 /* A DIM argument is specified. */
4330 if (dim
->expr_type
!= EXPR_CONSTANT
)
4333 d
= mpz_get_si (dim
->value
.integer
);
4335 if ((d
< 1 || d
> array
->rank
)
4336 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
4338 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4339 return &gfc_bad_expr
;
4342 if (as
&& as
->type
== AS_ASSUMED_RANK
)
4345 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
4351 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4357 if (array
->expr_type
!= EXPR_VARIABLE
)
4360 /* Follow any component references. */
4361 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
4362 ? array
->ts
.u
.derived
->components
->as
4363 : array
->symtree
->n
.sym
->as
;
4364 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4369 switch (ref
->u
.ar
.type
)
4372 if (ref
->u
.ar
.as
->corank
> 0)
4374 gcc_assert (as
== ref
->u
.ar
.as
);
4381 /* We're done because 'as' has already been set in the
4382 previous iteration. */
4396 as
= ref
->u
.c
.component
->as
;
4410 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
4415 /* Multi-dimensional cobounds. */
4416 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4420 /* Simplify the cobounds for each dimension. */
4421 for (d
= 0; d
< as
->corank
; d
++)
4423 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
4424 upper
, as
, ref
, true);
4425 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4429 for (j
= 0; j
< d
; j
++)
4430 gfc_free_expr (bounds
[j
]);
4435 /* Allocate the result expression. */
4436 e
= gfc_get_expr ();
4437 e
->where
= array
->where
;
4438 e
->expr_type
= EXPR_ARRAY
;
4439 e
->ts
.type
= BT_INTEGER
;
4440 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
4441 gfc_default_integer_kind
);
4445 return &gfc_bad_expr
;
4449 /* The result is a rank 1 array; its size is the rank of the first
4450 argument to {L,U}COBOUND. */
4452 e
->shape
= gfc_get_shape (1);
4453 mpz_init_set_ui (e
->shape
[0], as
->corank
);
4455 /* Create the constructor for this array. */
4456 for (d
= 0; d
< as
->corank
; d
++)
4457 gfc_constructor_append_expr (&e
->value
.constructor
,
4458 bounds
[d
], &e
->where
);
4463 /* A DIM argument is specified. */
4464 if (dim
->expr_type
!= EXPR_CONSTANT
)
4467 d
= mpz_get_si (dim
->value
.integer
);
4469 if (d
< 1 || d
> as
->corank
)
4471 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4472 return &gfc_bad_expr
;
4475 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
4481 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4483 return simplify_bound (array
, dim
, kind
, 0);
4488 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4490 return simplify_cobound (array
, dim
, kind
, 0);
4494 gfc_simplify_leadz (gfc_expr
*e
)
4496 unsigned long lz
, bs
;
4499 if (e
->expr_type
!= EXPR_CONSTANT
)
4502 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4503 bs
= gfc_integer_kinds
[i
].bit_size
;
4504 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
4506 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
4509 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
4511 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
4515 /* Check for constant length of a substring. */
4518 substring_has_constant_len (gfc_expr
*e
)
4521 HOST_WIDE_INT istart
, iend
, length
;
4522 bool equal_length
= false;
4524 if (e
->ts
.type
!= BT_CHARACTER
)
4527 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4528 if (ref
->type
!= REF_COMPONENT
&& ref
->type
!= REF_ARRAY
)
4532 || ref
->type
!= REF_SUBSTRING
4534 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
4536 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
4537 || !ref
->u
.ss
.length
)
4540 /* For non-deferred strings the given length shall be constant. */
4542 && (!ref
->u
.ss
.length
->length
4543 || ref
->u
.ss
.length
->length
->expr_type
!= EXPR_CONSTANT
))
4546 /* Basic checks on substring starting and ending indices. */
4547 if (!gfc_resolve_substring (ref
, &equal_length
))
4550 istart
= gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
);
4551 iend
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
);
4557 gfc_error ("Substring start index (%wd) at %L below 1",
4558 istart
, &ref
->u
.ss
.start
->where
);
4562 /* For deferred strings use end index as proxy for length. */
4566 length
= gfc_mpz_get_hwi (ref
->u
.ss
.length
->length
->value
.integer
);
4569 gfc_error ("Substring end index (%wd) at %L exceeds string length",
4570 iend
, &ref
->u
.ss
.end
->where
);
4573 length
= iend
- istart
+ 1;
4578 /* Fix substring length. */
4579 e
->value
.character
.length
= length
;
4586 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
4589 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
4592 return &gfc_bad_expr
;
4594 if (e
->expr_type
== EXPR_CONSTANT
4595 || substring_has_constant_len (e
))
4597 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4598 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
4599 return range_check (result
, "LEN");
4601 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
4602 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
4603 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
4605 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4606 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
4607 return range_check (result
, "LEN");
4609 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
4610 && e
->symtree
->n
.sym
4611 && e
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
4612 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
4613 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
4614 && e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
4615 && UNLIMITED_POLY (e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
))
4617 /* The expression in assoc->target points to a ref to the _data component
4618 of the unlimited polymorphic entity. To get the _len component the last
4619 _data ref needs to be stripped and a ref to the _len component added. */
4620 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
, k
);
4627 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
4630 size_t count
, len
, i
;
4631 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
4634 return &gfc_bad_expr
;
4636 if (e
->expr_type
!= EXPR_CONSTANT
)
4639 len
= e
->value
.character
.length
;
4640 for (count
= 0, i
= 1; i
<= len
; i
++)
4641 if (e
->value
.character
.string
[len
- i
] == ' ')
4646 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
4647 return range_check (result
, "LEN_TRIM");
4651 gfc_simplify_lgamma (gfc_expr
*x
)
4656 if (x
->expr_type
!= EXPR_CONSTANT
)
4659 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4660 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
4662 return range_check (result
, "LGAMMA");
4667 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
4669 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4672 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4673 gfc_compare_string (a
, b
) >= 0);
4678 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
4680 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4683 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4684 gfc_compare_string (a
, b
) > 0);
4689 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
4691 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4694 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4695 gfc_compare_string (a
, b
) <= 0);
4700 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
4702 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4705 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4706 gfc_compare_string (a
, b
) < 0);
4711 gfc_simplify_log (gfc_expr
*x
)
4715 if (x
->expr_type
!= EXPR_CONSTANT
)
4718 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4723 if (mpfr_sgn (x
->value
.real
) <= 0)
4725 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4726 "to zero", &x
->where
);
4727 gfc_free_expr (result
);
4728 return &gfc_bad_expr
;
4731 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4735 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
4736 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
4738 gfc_error ("Complex argument of LOG at %L cannot be zero",
4740 gfc_free_expr (result
);
4741 return &gfc_bad_expr
;
4744 gfc_set_model_kind (x
->ts
.kind
);
4745 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
4749 gfc_internal_error ("gfc_simplify_log: bad type");
4752 return range_check (result
, "LOG");
4757 gfc_simplify_log10 (gfc_expr
*x
)
4761 if (x
->expr_type
!= EXPR_CONSTANT
)
4764 if (mpfr_sgn (x
->value
.real
) <= 0)
4766 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4767 "to zero", &x
->where
);
4768 return &gfc_bad_expr
;
4771 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4772 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4774 return range_check (result
, "LOG10");
4779 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
4783 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
4785 return &gfc_bad_expr
;
4787 if (e
->expr_type
!= EXPR_CONSTANT
)
4790 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
4795 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
4798 int row
, result_rows
, col
, result_columns
;
4799 int stride_a
, offset_a
, stride_b
, offset_b
;
4801 if (!is_constant_array_expr (matrix_a
)
4802 || !is_constant_array_expr (matrix_b
))
4805 /* MATMUL should do mixed-mode arithmetic. Set the result type. */
4806 if (matrix_a
->ts
.type
!= matrix_b
->ts
.type
)
4809 e
.expr_type
= EXPR_OP
;
4810 gfc_clear_ts (&e
.ts
);
4811 e
.value
.op
.op
= INTRINSIC_NONE
;
4812 e
.value
.op
.op1
= matrix_a
;
4813 e
.value
.op
.op2
= matrix_b
;
4814 gfc_type_convert_binary (&e
, 1);
4815 result
= gfc_get_array_expr (e
.ts
.type
, e
.ts
.kind
, &matrix_a
->where
);
4819 result
= gfc_get_array_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
4823 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
4826 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4828 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4831 result
->shape
= gfc_get_shape (result
->rank
);
4832 mpz_init_set_si (result
->shape
[0], result_columns
);
4834 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
4836 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4838 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4842 result
->shape
= gfc_get_shape (result
->rank
);
4843 mpz_init_set_si (result
->shape
[0], result_rows
);
4845 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
4847 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4848 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4849 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4850 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4853 result
->shape
= gfc_get_shape (result
->rank
);
4854 mpz_init_set_si (result
->shape
[0], result_rows
);
4855 mpz_init_set_si (result
->shape
[1], result_columns
);
4861 for (col
= 0; col
< result_columns
; ++col
)
4865 for (row
= 0; row
< result_rows
; ++row
)
4867 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
4868 matrix_b
, 1, offset_b
, false);
4869 gfc_constructor_append_expr (&result
->value
.constructor
,
4875 offset_b
+= stride_b
;
4883 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
4888 if (i
->expr_type
!= EXPR_CONSTANT
)
4891 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
4893 return &gfc_bad_expr
;
4894 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4896 bool fail
= gfc_extract_int (i
, &arg
);
4899 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4901 /* MASKR(n) = 2^n - 1 */
4902 mpz_set_ui (result
->value
.integer
, 1);
4903 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4904 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4906 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4913 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4919 if (i
->expr_type
!= EXPR_CONSTANT
)
4922 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4924 return &gfc_bad_expr
;
4925 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4927 bool fail
= gfc_extract_int (i
, &arg
);
4930 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4932 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4933 mpz_init_set_ui (z
, 1);
4934 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4935 mpz_set_ui (result
->value
.integer
, 1);
4936 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4937 gfc_integer_kinds
[k
].bit_size
- arg
);
4938 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4941 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4948 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4951 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4953 if (mask
->expr_type
== EXPR_CONSTANT
)
4955 result
= gfc_copy_expr (mask
->value
.logical
? tsource
: fsource
);
4956 /* Parenthesis is needed to get lower bounds of 1. */
4957 result
= gfc_get_parentheses (result
);
4958 gfc_simplify_expr (result
, 1);
4962 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4963 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4966 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4968 if (tsource
->ts
.type
== BT_DERIVED
)
4969 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4970 else if (tsource
->ts
.type
== BT_CHARACTER
)
4971 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4973 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4974 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4975 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4979 if (mask_ctor
->expr
->value
.logical
)
4980 gfc_constructor_append_expr (&result
->value
.constructor
,
4981 gfc_copy_expr (tsource_ctor
->expr
),
4984 gfc_constructor_append_expr (&result
->value
.constructor
,
4985 gfc_copy_expr (fsource_ctor
->expr
),
4987 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4988 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4989 mask_ctor
= gfc_constructor_next (mask_ctor
);
4992 result
->shape
= gfc_get_shape (1);
4993 gfc_array_size (result
, &result
->shape
[0]);
5000 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
5002 mpz_t arg1
, arg2
, mask
;
5005 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
5006 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
5009 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
5011 /* Convert all argument to unsigned. */
5012 mpz_init_set (arg1
, i
->value
.integer
);
5013 mpz_init_set (arg2
, j
->value
.integer
);
5014 mpz_init_set (mask
, mask_expr
->value
.integer
);
5016 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
5017 mpz_and (arg1
, arg1
, mask
);
5018 mpz_com (mask
, mask
);
5019 mpz_and (arg2
, arg2
, mask
);
5020 mpz_ior (result
->value
.integer
, arg1
, arg2
);
5030 /* Selects between current value and extremum for simplify_min_max
5031 and simplify_minval_maxval. */
5033 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
, bool back_val
)
5037 switch (arg
->ts
.type
)
5040 if (extremum
->ts
.kind
< arg
->ts
.kind
)
5041 extremum
->ts
.kind
= arg
->ts
.kind
;
5042 ret
= mpz_cmp (arg
->value
.integer
,
5043 extremum
->value
.integer
) * sign
;
5045 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
5049 if (extremum
->ts
.kind
< arg
->ts
.kind
)
5050 extremum
->ts
.kind
= arg
->ts
.kind
;
5051 if (mpfr_nan_p (extremum
->value
.real
))
5054 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
5056 else if (mpfr_nan_p (arg
->value
.real
))
5060 ret
= mpfr_cmp (arg
->value
.real
, extremum
->value
.real
) * sign
;
5062 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
5067 #define LENGTH(x) ((x)->value.character.length)
5068 #define STRING(x) ((x)->value.character.string)
5069 if (LENGTH (extremum
) < LENGTH(arg
))
5071 gfc_char_t
*tmp
= STRING(extremum
);
5073 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
5074 memcpy (STRING(extremum
), tmp
,
5075 LENGTH(extremum
) * sizeof (gfc_char_t
));
5076 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
5077 LENGTH(arg
) - LENGTH(extremum
));
5078 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
5079 LENGTH(extremum
) = LENGTH(arg
);
5082 ret
= gfc_compare_string (arg
, extremum
) * sign
;
5085 free (STRING(extremum
));
5086 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
5087 memcpy (STRING(extremum
), STRING(arg
),
5088 LENGTH(arg
) * sizeof (gfc_char_t
));
5089 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
5090 LENGTH(extremum
) - LENGTH(arg
));
5091 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
5098 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5100 if (back_val
&& ret
== 0)
5107 /* This function is special since MAX() can take any number of
5108 arguments. The simplified expression is a rewritten version of the
5109 argument list containing at most one constant element. Other
5110 constant elements are deleted. Because the argument list has
5111 already been checked, this function always succeeds. sign is 1 for
5112 MAX(), -1 for MIN(). */
5115 simplify_min_max (gfc_expr
*expr
, int sign
)
5117 gfc_actual_arglist
*arg
, *last
, *extremum
;
5118 gfc_expr
*tmp
, *ret
;
5124 arg
= expr
->value
.function
.actual
;
5126 for (; arg
; last
= arg
, arg
= arg
->next
)
5128 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
5131 if (extremum
== NULL
)
5137 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
5139 /* Delete the extra constant argument. */
5140 last
->next
= arg
->next
;
5143 gfc_free_actual_arglist (arg
);
5147 /* If there is one value left, replace the function call with the
5149 if (expr
->value
.function
.actual
->next
!= NULL
)
5152 /* Handle special cases of specific functions (min|max)1 and
5155 tmp
= expr
->value
.function
.actual
->expr
;
5156 fname
= expr
->value
.function
.isym
->name
;
5158 if ((tmp
->ts
.type
!= BT_INTEGER
|| tmp
->ts
.kind
!= gfc_integer_4_kind
)
5159 && (strcmp (fname
, "min1") == 0 || strcmp (fname
, "max1") == 0))
5161 ret
= gfc_convert_constant (tmp
, BT_INTEGER
, gfc_integer_4_kind
);
5163 else if ((tmp
->ts
.type
!= BT_REAL
|| tmp
->ts
.kind
!= gfc_real_4_kind
)
5164 && (strcmp (fname
, "amin0") == 0 || strcmp (fname
, "amax0") == 0))
5166 ret
= gfc_convert_constant (tmp
, BT_REAL
, gfc_real_4_kind
);
5169 ret
= gfc_copy_expr (tmp
);
5177 gfc_simplify_min (gfc_expr
*e
)
5179 return simplify_min_max (e
, -1);
5184 gfc_simplify_max (gfc_expr
*e
)
5186 return simplify_min_max (e
, 1);
5189 /* Helper function for gfc_simplify_minval. */
5192 gfc_min (gfc_expr
*op1
, gfc_expr
*op2
)
5194 min_max_choose (op1
, op2
, -1);
5195 gfc_free_expr (op1
);
5199 /* Simplify minval for constant arrays. */
5202 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5204 return simplify_transformation (array
, dim
, mask
, INT_MAX
, gfc_min
);
5207 /* Helper function for gfc_simplify_maxval. */
5210 gfc_max (gfc_expr
*op1
, gfc_expr
*op2
)
5212 min_max_choose (op1
, op2
, 1);
5213 gfc_free_expr (op1
);
5218 /* Simplify maxval for constant arrays. */
5221 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5223 return simplify_transformation (array
, dim
, mask
, INT_MIN
, gfc_max
);
5227 /* Transform minloc or maxloc of an array, according to MASK,
5228 to the scalar result. This code is mostly identical to
5229 simplify_transformation_to_scalar. */
5232 simplify_minmaxloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
5233 gfc_expr
*extremum
, int sign
, bool back_val
)
5236 gfc_constructor
*array_ctor
, *mask_ctor
;
5239 mpz_set_si (result
->value
.integer
, 0);
5242 /* Shortcut for constant .FALSE. MASK. */
5244 && mask
->expr_type
== EXPR_CONSTANT
5245 && !mask
->value
.logical
)
5248 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5249 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5250 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5254 mpz_init_set_si (count
, 0);
5257 mpz_add_ui (count
, count
, 1);
5258 a
= array_ctor
->expr
;
5259 array_ctor
= gfc_constructor_next (array_ctor
);
5260 /* A constant MASK equals .TRUE. here and can be ignored. */
5263 m
= mask_ctor
->expr
;
5264 mask_ctor
= gfc_constructor_next (mask_ctor
);
5265 if (!m
->value
.logical
)
5268 if (min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5269 mpz_set (result
->value
.integer
, count
);
5272 gfc_free_expr (extremum
);
5276 /* Simplify minloc / maxloc in the absence of a dim argument. */
5279 simplify_minmaxloc_nodim (gfc_expr
*result
, gfc_expr
*extremum
,
5280 gfc_expr
*array
, gfc_expr
*mask
, int sign
,
5283 ssize_t res
[GFC_MAX_DIMENSIONS
];
5285 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5286 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5287 sstride
[GFC_MAX_DIMENSIONS
];
5292 for (i
= 0; i
<array
->rank
; i
++)
5295 /* Shortcut for constant .FALSE. MASK. */
5297 && mask
->expr_type
== EXPR_CONSTANT
5298 && !mask
->value
.logical
)
5301 for (i
= 0; i
< array
->rank
; i
++)
5304 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5305 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5310 continue_loop
= true;
5311 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5312 if (mask
&& mask
->rank
> 0)
5313 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5317 /* Loop over the array elements (and mask), keeping track of
5318 the indices to return. */
5319 while (continue_loop
)
5323 a
= array_ctor
->expr
;
5326 m
= mask_ctor
->expr
;
5327 ma
= m
->value
.logical
;
5328 mask_ctor
= gfc_constructor_next (mask_ctor
);
5333 if (ma
&& min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5335 for (i
= 0; i
<array
->rank
; i
++)
5338 array_ctor
= gfc_constructor_next (array_ctor
);
5340 } while (count
[0] != extent
[0]);
5344 /* When we get to the end of a dimension, reset it and increment
5345 the next dimension. */
5348 if (n
>= array
->rank
)
5350 continue_loop
= false;
5355 } while (count
[n
] == extent
[n
]);
5359 gfc_free_expr (extremum
);
5360 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5361 for (i
= 0; i
<array
->rank
; i
++)
5364 r_expr
= result_ctor
->expr
;
5365 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5366 result_ctor
= gfc_constructor_next (result_ctor
);
5371 /* Helper function for gfc_simplify_minmaxloc - build an array
5372 expression with n elements. */
5375 new_array (bt type
, int kind
, int n
, locus
*where
)
5380 result
= gfc_get_array_expr (type
, kind
, where
);
5382 result
->shape
= gfc_get_shape(1);
5383 mpz_init_set_si (result
->shape
[0], n
);
5384 for (i
= 0; i
< n
; i
++)
5386 gfc_constructor_append_expr (&result
->value
.constructor
,
5387 gfc_get_constant_expr (type
, kind
, where
),
5394 /* Simplify minloc and maxloc. This code is mostly identical to
5395 simplify_transformation_to_array. */
5398 simplify_minmaxloc_to_array (gfc_expr
*result
, gfc_expr
*array
,
5399 gfc_expr
*dim
, gfc_expr
*mask
,
5400 gfc_expr
*extremum
, int sign
, bool back_val
)
5403 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5404 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5405 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5407 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5408 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5409 tmpstride
[GFC_MAX_DIMENSIONS
];
5411 /* Shortcut for constant .FALSE. MASK. */
5413 && mask
->expr_type
== EXPR_CONSTANT
5414 && !mask
->value
.logical
)
5417 /* Build an indexed table for array element expressions to minimize
5418 linked-list traversal. Masked elements are set to NULL. */
5419 gfc_array_size (array
, &size
);
5420 arraysize
= mpz_get_ui (size
);
5423 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5425 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5427 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5428 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5430 for (i
= 0; i
< arraysize
; ++i
)
5432 arrayvec
[i
] = array_ctor
->expr
;
5433 array_ctor
= gfc_constructor_next (array_ctor
);
5437 if (!mask_ctor
->expr
->value
.logical
)
5440 mask_ctor
= gfc_constructor_next (mask_ctor
);
5444 /* Same for the result expression. */
5445 gfc_array_size (result
, &size
);
5446 resultsize
= mpz_get_ui (size
);
5449 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5450 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5451 for (i
= 0; i
< resultsize
; ++i
)
5453 resultvec
[i
] = result_ctor
->expr
;
5454 result_ctor
= gfc_constructor_next (result_ctor
);
5457 gfc_extract_int (dim
, &dim_index
);
5458 dim_index
-= 1; /* zero-base index */
5462 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5465 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5468 dim_extent
= mpz_get_si (array
->shape
[i
]);
5469 dim_stride
= tmpstride
[i
];
5473 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5474 sstride
[n
] = tmpstride
[i
];
5475 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5479 done
= resultsize
<= 0;
5485 ex
= gfc_copy_expr (extremum
);
5486 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5488 if (*src
&& min_max_choose (*src
, ex
, sign
, back_val
) > 0)
5489 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5498 while (!done
&& count
[n
] == extent
[n
])
5501 base
-= sstride
[n
] * extent
[n
];
5502 dest
-= dstride
[n
] * extent
[n
];
5505 if (n
< result
->rank
)
5507 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5508 times, we'd warn for the last iteration, because the
5509 array index will have already been incremented to the
5510 array sizes, and we can't tell that this must make
5511 the test against result->rank false, because ranks
5512 must not exceed GFC_MAX_DIMENSIONS. */
5513 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5524 /* Place updated expression in result constructor. */
5525 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5526 for (i
= 0; i
< resultsize
; ++i
)
5528 result_ctor
->expr
= resultvec
[i
];
5529 result_ctor
= gfc_constructor_next (result_ctor
);
5538 /* Simplify minloc and maxloc for constant arrays. */
5541 gfc_simplify_minmaxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
5542 gfc_expr
*kind
, gfc_expr
*back
, int sign
)
5548 bool back_val
= false;
5550 if (!is_constant_array_expr (array
)
5551 || !gfc_is_constant_expr (dim
))
5555 && !is_constant_array_expr (mask
)
5556 && mask
->expr_type
!= EXPR_CONSTANT
)
5561 if (gfc_extract_int (kind
, &ikind
, -1))
5565 ikind
= gfc_default_integer_kind
;
5569 if (back
->expr_type
!= EXPR_CONSTANT
)
5572 back_val
= back
->value
.logical
;
5582 extremum
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
5583 init_result_expr (extremum
, init_val
, array
);
5587 result
= transformational_result (array
, dim
, BT_INTEGER
,
5588 ikind
, &array
->where
);
5589 init_result_expr (result
, 0, array
);
5591 if (array
->rank
== 1)
5592 return simplify_minmaxloc_to_scalar (result
, array
, mask
, extremum
,
5595 return simplify_minmaxloc_to_array (result
, array
, dim
, mask
, extremum
,
5600 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5601 return simplify_minmaxloc_nodim (result
, extremum
, array
, mask
,
5607 gfc_simplify_minloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5610 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, -1);
5614 gfc_simplify_maxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5617 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, 1);
5620 /* Simplify findloc to scalar. Similar to
5621 simplify_minmaxloc_to_scalar. */
5624 simplify_findloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5625 gfc_expr
*mask
, int back_val
)
5628 gfc_constructor
*array_ctor
, *mask_ctor
;
5631 mpz_set_si (result
->value
.integer
, 0);
5633 /* Shortcut for constant .FALSE. MASK. */
5635 && mask
->expr_type
== EXPR_CONSTANT
5636 && !mask
->value
.logical
)
5639 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5640 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5641 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5645 mpz_init_set_si (count
, 0);
5648 mpz_add_ui (count
, count
, 1);
5649 a
= array_ctor
->expr
;
5650 array_ctor
= gfc_constructor_next (array_ctor
);
5651 /* A constant MASK equals .TRUE. here and can be ignored. */
5654 m
= mask_ctor
->expr
;
5655 mask_ctor
= gfc_constructor_next (mask_ctor
);
5656 if (!m
->value
.logical
)
5659 if (gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5661 /* We have a match. If BACK is true, continue so we find
5663 mpz_set (result
->value
.integer
, count
);
5672 /* Simplify findloc in the absence of a dim argument. Similar to
5673 simplify_minmaxloc_nodim. */
5676 simplify_findloc_nodim (gfc_expr
*result
, gfc_expr
*value
, gfc_expr
*array
,
5677 gfc_expr
*mask
, bool back_val
)
5679 ssize_t res
[GFC_MAX_DIMENSIONS
];
5681 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5682 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5683 sstride
[GFC_MAX_DIMENSIONS
];
5688 for (i
= 0; i
< array
->rank
; i
++)
5691 /* Shortcut for constant .FALSE. MASK. */
5693 && mask
->expr_type
== EXPR_CONSTANT
5694 && !mask
->value
.logical
)
5697 for (i
= 0; i
< array
->rank
; i
++)
5700 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5701 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5706 continue_loop
= true;
5707 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5708 if (mask
&& mask
->rank
> 0)
5709 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5713 /* Loop over the array elements (and mask), keeping track of
5714 the indices to return. */
5715 while (continue_loop
)
5719 a
= array_ctor
->expr
;
5722 m
= mask_ctor
->expr
;
5723 ma
= m
->value
.logical
;
5724 mask_ctor
= gfc_constructor_next (mask_ctor
);
5729 if (ma
&& gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5731 for (i
= 0; i
< array
->rank
; i
++)
5736 array_ctor
= gfc_constructor_next (array_ctor
);
5738 } while (count
[0] != extent
[0]);
5742 /* When we get to the end of a dimension, reset it and increment
5743 the next dimension. */
5746 if (n
>= array
->rank
)
5748 continue_loop
= false;
5753 } while (count
[n
] == extent
[n
]);
5757 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5758 for (i
= 0; i
< array
->rank
; i
++)
5761 r_expr
= result_ctor
->expr
;
5762 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5763 result_ctor
= gfc_constructor_next (result_ctor
);
5769 /* Simplify findloc to an array. Similar to
5770 simplify_minmaxloc_to_array. */
5773 simplify_findloc_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5774 gfc_expr
*dim
, gfc_expr
*mask
, bool back_val
)
5777 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5778 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5779 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5781 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5782 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5783 tmpstride
[GFC_MAX_DIMENSIONS
];
5785 /* Shortcut for constant .FALSE. MASK. */
5787 && mask
->expr_type
== EXPR_CONSTANT
5788 && !mask
->value
.logical
)
5791 /* Build an indexed table for array element expressions to minimize
5792 linked-list traversal. Masked elements are set to NULL. */
5793 gfc_array_size (array
, &size
);
5794 arraysize
= mpz_get_ui (size
);
5797 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5799 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5801 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5802 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5804 for (i
= 0; i
< arraysize
; ++i
)
5806 arrayvec
[i
] = array_ctor
->expr
;
5807 array_ctor
= gfc_constructor_next (array_ctor
);
5811 if (!mask_ctor
->expr
->value
.logical
)
5814 mask_ctor
= gfc_constructor_next (mask_ctor
);
5818 /* Same for the result expression. */
5819 gfc_array_size (result
, &size
);
5820 resultsize
= mpz_get_ui (size
);
5823 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5824 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5825 for (i
= 0; i
< resultsize
; ++i
)
5827 resultvec
[i
] = result_ctor
->expr
;
5828 result_ctor
= gfc_constructor_next (result_ctor
);
5831 gfc_extract_int (dim
, &dim_index
);
5833 dim_index
-= 1; /* Zero-base index. */
5837 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5840 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5843 dim_extent
= mpz_get_si (array
->shape
[i
]);
5844 dim_stride
= tmpstride
[i
];
5848 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5849 sstride
[n
] = tmpstride
[i
];
5850 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5854 done
= resultsize
<= 0;
5859 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5861 if (*src
&& gfc_compare_expr (*src
, value
, INTRINSIC_EQ
) == 0)
5863 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5874 while (!done
&& count
[n
] == extent
[n
])
5877 base
-= sstride
[n
] * extent
[n
];
5878 dest
-= dstride
[n
] * extent
[n
];
5881 if (n
< result
->rank
)
5883 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5884 times, we'd warn for the last iteration, because the
5885 array index will have already been incremented to the
5886 array sizes, and we can't tell that this must make
5887 the test against result->rank false, because ranks
5888 must not exceed GFC_MAX_DIMENSIONS. */
5889 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5900 /* Place updated expression in result constructor. */
5901 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5902 for (i
= 0; i
< resultsize
; ++i
)
5904 result_ctor
->expr
= resultvec
[i
];
5905 result_ctor
= gfc_constructor_next (result_ctor
);
5913 /* Simplify findloc. */
5916 gfc_simplify_findloc (gfc_expr
*array
, gfc_expr
*value
, gfc_expr
*dim
,
5917 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
5921 bool back_val
= false;
5923 if (!is_constant_array_expr (array
)
5924 || !gfc_is_constant_expr (dim
))
5927 if (! gfc_is_constant_expr (value
))
5931 && !is_constant_array_expr (mask
)
5932 && mask
->expr_type
!= EXPR_CONSTANT
)
5937 if (gfc_extract_int (kind
, &ikind
, -1))
5941 ikind
= gfc_default_integer_kind
;
5945 if (back
->expr_type
!= EXPR_CONSTANT
)
5948 back_val
= back
->value
.logical
;
5953 result
= transformational_result (array
, dim
, BT_INTEGER
,
5954 ikind
, &array
->where
);
5955 init_result_expr (result
, 0, array
);
5957 if (array
->rank
== 1)
5958 return simplify_findloc_to_scalar (result
, array
, value
, mask
,
5961 return simplify_findloc_to_array (result
, array
, value
, dim
, mask
,
5966 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5967 return simplify_findloc_nodim (result
, value
, array
, mask
, back_val
);
5973 gfc_simplify_maxexponent (gfc_expr
*x
)
5975 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5976 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5977 gfc_real_kinds
[i
].max_exponent
);
5982 gfc_simplify_minexponent (gfc_expr
*x
)
5984 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5985 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5986 gfc_real_kinds
[i
].min_exponent
);
5991 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
5996 /* First check p. */
5997 if (p
->expr_type
!= EXPR_CONSTANT
)
6000 /* p shall not be 0. */
6004 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
6006 gfc_error ("Argument %qs of MOD at %L shall not be zero",
6008 return &gfc_bad_expr
;
6012 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
6014 gfc_error ("Argument %qs of MOD at %L shall not be zero",
6016 return &gfc_bad_expr
;
6020 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6023 if (a
->expr_type
!= EXPR_CONSTANT
)
6026 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6027 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6029 if (a
->ts
.type
== BT_INTEGER
)
6030 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6033 gfc_set_model_kind (kind
);
6034 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6038 return range_check (result
, "MOD");
6043 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
6048 /* First check p. */
6049 if (p
->expr_type
!= EXPR_CONSTANT
)
6052 /* p shall not be 0. */
6056 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
6058 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6060 return &gfc_bad_expr
;
6064 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
6066 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6068 return &gfc_bad_expr
;
6072 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6075 if (a
->expr_type
!= EXPR_CONSTANT
)
6078 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6079 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6081 if (a
->ts
.type
== BT_INTEGER
)
6082 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6085 gfc_set_model_kind (kind
);
6086 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6088 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
6090 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
6091 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
6095 mpfr_copysign (result
->value
.real
, result
->value
.real
,
6096 p
->value
.real
, GFC_RND_MODE
);
6099 return range_check (result
, "MODULO");
6104 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
6107 mpfr_exp_t emin
, emax
;
6110 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
6113 result
= gfc_copy_expr (x
);
6115 /* Save current values of emin and emax. */
6116 emin
= mpfr_get_emin ();
6117 emax
= mpfr_get_emax ();
6119 /* Set emin and emax for the current model number. */
6120 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
6121 mpfr_set_emin ((mpfr_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
6122 mpfr_get_prec(result
->value
.real
) + 1);
6123 mpfr_set_emax ((mpfr_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
6124 mpfr_check_range (result
->value
.real
, 0, MPFR_RNDU
);
6126 if (mpfr_sgn (s
->value
.real
) > 0)
6128 mpfr_nextabove (result
->value
.real
);
6129 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDU
);
6133 mpfr_nextbelow (result
->value
.real
);
6134 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDD
);
6137 mpfr_set_emin (emin
);
6138 mpfr_set_emax (emax
);
6140 /* Only NaN can occur. Do not use range check as it gives an
6141 error for denormal numbers. */
6142 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
6144 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
6145 gfc_free_expr (result
);
6146 return &gfc_bad_expr
;
6154 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
6156 gfc_expr
*itrunc
, *result
;
6159 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
6161 return &gfc_bad_expr
;
6163 if (e
->expr_type
!= EXPR_CONSTANT
)
6166 itrunc
= gfc_copy_expr (e
);
6167 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
6169 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
6170 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
6172 gfc_free_expr (itrunc
);
6174 return range_check (result
, name
);
6179 gfc_simplify_new_line (gfc_expr
*e
)
6183 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
6184 result
->value
.character
.string
[0] = '\n';
6191 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
6193 return simplify_nint ("NINT", e
, k
);
6198 gfc_simplify_idnint (gfc_expr
*e
)
6200 return simplify_nint ("IDNINT", e
, NULL
);
6203 static int norm2_scale
;
6206 norm2_add_squared (gfc_expr
*result
, gfc_expr
*e
)
6210 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6211 gcc_assert (result
->ts
.type
== BT_REAL
6212 && result
->expr_type
== EXPR_CONSTANT
);
6214 gfc_set_model_kind (result
->ts
.kind
);
6215 int index
= gfc_validate_kind (BT_REAL
, result
->ts
.kind
, false);
6217 if (mpfr_regular_p (result
->value
.real
))
6219 exp
= mpfr_get_exp (result
->value
.real
);
6220 /* If result is getting close to overflowing, scale down. */
6221 if (exp
>= gfc_real_kinds
[index
].max_exponent
- 4
6222 && norm2_scale
<= gfc_real_kinds
[index
].max_exponent
- 2)
6225 mpfr_div_ui (result
->value
.real
, result
->value
.real
, 16,
6231 if (mpfr_regular_p (e
->value
.real
))
6233 exp
= mpfr_get_exp (e
->value
.real
);
6234 /* If e**2 would overflow or close to overflowing, scale down. */
6235 if (exp
- norm2_scale
>= gfc_real_kinds
[index
].max_exponent
/ 2 - 2)
6237 int new_scale
= gfc_real_kinds
[index
].max_exponent
/ 2 + 4;
6238 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6239 mpfr_set_exp (tmp
, new_scale
- norm2_scale
);
6240 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6241 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6242 norm2_scale
= new_scale
;
6247 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6248 mpfr_set_exp (tmp
, norm2_scale
);
6249 mpfr_div (tmp
, e
->value
.real
, tmp
, GFC_RND_MODE
);
6252 mpfr_set (tmp
, e
->value
.real
, GFC_RND_MODE
);
6253 mpfr_pow_ui (tmp
, tmp
, 2, GFC_RND_MODE
);
6254 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
6263 norm2_do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
6265 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6266 gcc_assert (result
->ts
.type
== BT_REAL
6267 && result
->expr_type
== EXPR_CONSTANT
);
6270 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6271 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6272 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6276 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6277 mpfr_set_exp (tmp
, norm2_scale
);
6278 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6288 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
6293 size_zero
= gfc_is_size_zero_array (e
);
6295 if (!(is_constant_array_expr (e
) || size_zero
)
6296 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
6299 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6300 init_result_expr (result
, 0, NULL
);
6306 if (!dim
|| e
->rank
== 1)
6308 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
6310 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6311 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6315 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6316 mpfr_set_exp (tmp
, norm2_scale
);
6317 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6323 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
6332 gfc_simplify_not (gfc_expr
*e
)
6336 if (e
->expr_type
!= EXPR_CONSTANT
)
6339 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6340 mpz_com (result
->value
.integer
, e
->value
.integer
);
6342 return range_check (result
, "NOT");
6347 gfc_simplify_null (gfc_expr
*mold
)
6353 result
= gfc_copy_expr (mold
);
6354 result
->expr_type
= EXPR_NULL
;
6357 result
= gfc_get_null_expr (NULL
);
6364 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
6368 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6370 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6371 return &gfc_bad_expr
;
6374 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6377 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
6380 /* FIXME: gfc_current_locus is wrong. */
6381 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6382 &gfc_current_locus
);
6384 if (failed
&& failed
->value
.logical
!= 0)
6385 mpz_set_si (result
->value
.integer
, 0);
6387 mpz_set_si (result
->value
.integer
, 1);
6394 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
6399 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6402 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6407 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6408 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6409 return range_check (result
, "OR");
6412 return gfc_get_logical_expr (kind
, &x
->where
,
6413 x
->value
.logical
|| y
->value
.logical
);
6421 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
6424 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
6426 if (!is_constant_array_expr (array
)
6427 || !is_constant_array_expr (vector
)
6428 || (!gfc_is_constant_expr (mask
)
6429 && !is_constant_array_expr (mask
)))
6432 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
6433 if (array
->ts
.type
== BT_DERIVED
)
6434 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
6436 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
6437 vector_ctor
= vector
6438 ? gfc_constructor_first (vector
->value
.constructor
)
6441 if (mask
->expr_type
== EXPR_CONSTANT
6442 && mask
->value
.logical
)
6444 /* Copy all elements of ARRAY to RESULT. */
6447 gfc_constructor_append_expr (&result
->value
.constructor
,
6448 gfc_copy_expr (array_ctor
->expr
),
6451 array_ctor
= gfc_constructor_next (array_ctor
);
6452 vector_ctor
= gfc_constructor_next (vector_ctor
);
6455 else if (mask
->expr_type
== EXPR_ARRAY
)
6457 /* Copy only those elements of ARRAY to RESULT whose
6458 MASK equals .TRUE.. */
6459 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6462 if (mask_ctor
->expr
->value
.logical
)
6464 gfc_constructor_append_expr (&result
->value
.constructor
,
6465 gfc_copy_expr (array_ctor
->expr
),
6467 vector_ctor
= gfc_constructor_next (vector_ctor
);
6470 array_ctor
= gfc_constructor_next (array_ctor
);
6471 mask_ctor
= gfc_constructor_next (mask_ctor
);
6475 /* Append any left-over elements from VECTOR to RESULT. */
6478 gfc_constructor_append_expr (&result
->value
.constructor
,
6479 gfc_copy_expr (vector_ctor
->expr
),
6481 vector_ctor
= gfc_constructor_next (vector_ctor
);
6484 result
->shape
= gfc_get_shape (1);
6485 gfc_array_size (result
, &result
->shape
[0]);
6487 if (array
->ts
.type
== BT_CHARACTER
)
6488 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
6495 do_xor (gfc_expr
*result
, gfc_expr
*e
)
6497 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
6498 gcc_assert (result
->ts
.type
== BT_LOGICAL
6499 && result
->expr_type
== EXPR_CONSTANT
);
6501 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
6507 gfc_simplify_is_contiguous (gfc_expr
*array
)
6509 if (gfc_is_simply_contiguous (array
, false, true))
6510 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 1);
6512 if (gfc_is_not_contiguous (array
))
6513 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 0);
6520 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
6522 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
6527 gfc_simplify_popcnt (gfc_expr
*e
)
6532 if (e
->expr_type
!= EXPR_CONSTANT
)
6535 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6537 /* Convert argument to unsigned, then count the '1' bits. */
6538 mpz_init_set (x
, e
->value
.integer
);
6539 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
6540 res
= mpz_popcount (x
);
6543 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
6548 gfc_simplify_poppar (gfc_expr
*e
)
6553 if (e
->expr_type
!= EXPR_CONSTANT
)
6556 popcnt
= gfc_simplify_popcnt (e
);
6557 gcc_assert (popcnt
);
6559 bool fail
= gfc_extract_int (popcnt
, &i
);
6562 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
6567 gfc_simplify_precision (gfc_expr
*e
)
6569 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6570 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
6571 gfc_real_kinds
[i
].precision
);
6576 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6578 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
6583 gfc_simplify_radix (gfc_expr
*e
)
6586 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6591 i
= gfc_integer_kinds
[i
].radix
;
6595 i
= gfc_real_kinds
[i
].radix
;
6602 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6607 gfc_simplify_range (gfc_expr
*e
)
6610 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6615 i
= gfc_integer_kinds
[i
].range
;
6620 i
= gfc_real_kinds
[i
].range
;
6627 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6632 gfc_simplify_rank (gfc_expr
*e
)
6638 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
6643 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
6645 gfc_expr
*result
= NULL
;
6646 int kind
, tmp1
, tmp2
;
6648 /* Convert BOZ to real, and return without range checking. */
6649 if (e
->ts
.type
== BT_BOZ
)
6651 /* Determine kind for conversion of the BOZ. */
6653 gfc_extract_int (k
, &kind
);
6655 kind
= gfc_default_real_kind
;
6657 if (!gfc_boz2real (e
, kind
))
6659 result
= gfc_copy_expr (e
);
6663 if (e
->ts
.type
== BT_COMPLEX
)
6664 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
6666 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
6669 return &gfc_bad_expr
;
6671 if (e
->expr_type
!= EXPR_CONSTANT
)
6674 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
6676 tmp1
= warn_conversion
;
6677 tmp2
= warn_conversion_extra
;
6678 warn_conversion
= warn_conversion_extra
= 0;
6680 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
6682 warn_conversion
= tmp1
;
6683 warn_conversion_extra
= tmp2
;
6685 if (result
== &gfc_bad_expr
)
6686 return &gfc_bad_expr
;
6688 return range_check (result
, "REAL");
6693 gfc_simplify_realpart (gfc_expr
*e
)
6697 if (e
->expr_type
!= EXPR_CONSTANT
)
6700 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6701 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
6703 return range_check (result
, "REALPART");
6707 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
6712 bool have_length
= false;
6714 /* If NCOPIES isn't a constant, there's nothing we can do. */
6715 if (n
->expr_type
!= EXPR_CONSTANT
)
6718 /* If NCOPIES is negative, it's an error. */
6719 if (mpz_sgn (n
->value
.integer
) < 0)
6721 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6723 return &gfc_bad_expr
;
6726 /* If we don't know the character length, we can do no more. */
6727 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
6728 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6730 len
= gfc_mpz_get_hwi (e
->ts
.u
.cl
->length
->value
.integer
);
6733 else if (e
->expr_type
== EXPR_CONSTANT
6734 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
6736 len
= e
->value
.character
.length
;
6741 /* If the source length is 0, any value of NCOPIES is valid
6742 and everything behaves as if NCOPIES == 0. */
6745 mpz_set_ui (ncopies
, 0);
6747 mpz_set (ncopies
, n
->value
.integer
);
6749 /* Check that NCOPIES isn't too large. */
6755 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6757 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6761 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
6762 e
->ts
.u
.cl
->length
->value
.integer
);
6767 gfc_mpz_set_hwi (mlen
, len
);
6768 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
6772 /* The check itself. */
6773 if (mpz_cmp (ncopies
, max
) > 0)
6776 mpz_clear (ncopies
);
6777 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6779 return &gfc_bad_expr
;
6784 mpz_clear (ncopies
);
6786 /* For further simplification, we need the character string to be
6788 if (e
->expr_type
!= EXPR_CONSTANT
)
6793 (e
->ts
.u
.cl
->length
&&
6794 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
) != 0))
6796 bool fail
= gfc_extract_hwi (n
, &ncop
);
6803 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
6805 len
= e
->value
.character
.length
;
6806 gfc_charlen_t nlen
= ncop
* len
;
6808 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6809 (2**28 elements * 4 bytes (wide chars) per element) defer to
6810 runtime instead of consuming (unbounded) memory and CPU at
6812 if (nlen
> 268435456)
6814 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6815 " deferred to runtime, expect bugs", &e
->where
);
6819 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
6820 for (size_t i
= 0; i
< (size_t) ncop
; i
++)
6821 for (size_t j
= 0; j
< (size_t) len
; j
++)
6822 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
6824 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
6829 /* This one is a bear, but mainly has to do with shuffling elements. */
6832 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
6833 gfc_expr
*pad
, gfc_expr
*order_exp
)
6835 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
6836 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
6840 gfc_expr
*e
, *result
;
6841 bool zerosize
= false;
6843 /* Check that argument expression types are OK. */
6844 if (!is_constant_array_expr (source
)
6845 || !is_constant_array_expr (shape_exp
)
6846 || !is_constant_array_expr (pad
)
6847 || !is_constant_array_expr (order_exp
))
6850 if (source
->shape
== NULL
)
6853 /* Proceed with simplification, unpacking the array. */
6858 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
6863 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
6867 gfc_extract_int (e
, &shape
[rank
]);
6869 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
6870 gcc_assert (shape
[rank
] >= 0);
6875 gcc_assert (rank
> 0);
6877 /* Now unpack the order array if present. */
6878 if (order_exp
== NULL
)
6880 for (i
= 0; i
< rank
; i
++)
6886 int order_size
, shape_size
;
6888 if (order_exp
->rank
!= shape_exp
->rank
)
6890 gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
6891 &order_exp
->where
, &shape_exp
->where
);
6892 return &gfc_bad_expr
;
6895 gfc_array_size (shape_exp
, &size
);
6896 shape_size
= mpz_get_ui (size
);
6898 gfc_array_size (order_exp
, &size
);
6899 order_size
= mpz_get_ui (size
);
6901 if (order_size
!= shape_size
)
6903 gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
6904 &order_exp
->where
, &shape_exp
->where
);
6905 return &gfc_bad_expr
;
6908 for (i
= 0; i
< rank
; i
++)
6910 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
6913 gfc_extract_int (e
, &order
[i
]);
6915 if (order
[i
] < 1 || order
[i
] > rank
)
6917 gfc_error ("Element with a value of %d in ORDER at %L must be "
6918 "in the range [1, ..., %d] for the RESHAPE intrinsic "
6919 "near %L", order
[i
], &order_exp
->where
, rank
,
6921 return &gfc_bad_expr
;
6925 if (x
[order
[i
]] != 0)
6927 gfc_error ("ORDER at %L is not a permutation of the size of "
6928 "SHAPE at %L", &order_exp
->where
, &shape_exp
->where
);
6929 return &gfc_bad_expr
;
6935 /* Count the elements in the source and padding arrays. */
6940 gfc_array_size (pad
, &size
);
6941 npad
= mpz_get_ui (size
);
6945 gfc_array_size (source
, &size
);
6946 nsource
= mpz_get_ui (size
);
6949 /* If it weren't for that pesky permutation we could just loop
6950 through the source and round out any shortage with pad elements.
6951 But no, someone just had to have the compiler do something the
6952 user should be doing. */
6954 for (i
= 0; i
< rank
; i
++)
6957 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6959 if (source
->ts
.type
== BT_DERIVED
)
6960 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6961 if (source
->ts
.type
== BT_CHARACTER
&& result
->ts
.u
.cl
== NULL
)
6962 result
->ts
= source
->ts
;
6963 result
->rank
= rank
;
6964 result
->shape
= gfc_get_shape (rank
);
6965 for (i
= 0; i
< rank
; i
++)
6967 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
6975 while (nsource
> 0 || npad
> 0)
6977 /* Figure out which element to extract. */
6978 mpz_set_ui (index
, 0);
6980 for (i
= rank
- 1; i
>= 0; i
--)
6982 mpz_add_ui (index
, index
, x
[order
[i
]]);
6984 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
6987 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
6988 gfc_internal_error ("Reshaped array too large at %C");
6990 j
= mpz_get_ui (index
);
6993 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
7003 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
7007 gfc_constructor_append_expr (&result
->value
.constructor
,
7008 gfc_copy_expr (e
), &e
->where
);
7010 /* Calculate the next element. */
7014 if (++x
[i
] < shape
[i
])
7032 gfc_simplify_rrspacing (gfc_expr
*x
)
7038 if (x
->expr_type
!= EXPR_CONSTANT
)
7041 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7043 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7045 /* RRSPACING(+/- 0.0) = 0.0 */
7046 if (mpfr_zero_p (x
->value
.real
))
7048 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7052 /* RRSPACING(inf) = NaN */
7053 if (mpfr_inf_p (x
->value
.real
))
7055 mpfr_set_nan (result
->value
.real
);
7059 /* RRSPACING(NaN) = same NaN */
7060 if (mpfr_nan_p (x
->value
.real
))
7062 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7066 /* | x * 2**(-e) | * 2**p. */
7067 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7068 e
= - (long int) mpfr_get_exp (x
->value
.real
);
7069 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
7071 p
= (long int) gfc_real_kinds
[i
].digits
;
7072 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
7074 return range_check (result
, "RRSPACING");
7079 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
7081 int k
, neg_flag
, power
, exp_range
;
7082 mpfr_t scale
, radix
;
7085 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7088 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7090 if (mpfr_zero_p (x
->value
.real
))
7092 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7096 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
7098 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
7100 /* This check filters out values of i that would overflow an int. */
7101 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
7102 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
7104 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
7105 gfc_free_expr (result
);
7106 return &gfc_bad_expr
;
7109 /* Compute scale = radix ** power. */
7110 power
= mpz_get_si (i
->value
.integer
);
7120 gfc_set_model_kind (x
->ts
.kind
);
7123 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
7124 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
7127 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7129 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7131 mpfr_clears (scale
, radix
, NULL
);
7133 return range_check (result
, "SCALE");
7137 /* Variants of strspn and strcspn that operate on wide characters. */
7140 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7143 const gfc_char_t
*c
;
7147 for (c
= s2
; *c
; c
++)
7161 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7164 const gfc_char_t
*c
;
7168 for (c
= s2
; *c
; c
++)
7183 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
7188 size_t indx
, len
, lenc
;
7189 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
7192 return &gfc_bad_expr
;
7194 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
7195 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
7198 if (b
!= NULL
&& b
->value
.logical
!= 0)
7203 len
= e
->value
.character
.length
;
7204 lenc
= c
->value
.character
.length
;
7206 if (len
== 0 || lenc
== 0)
7214 indx
= wide_strcspn (e
->value
.character
.string
,
7215 c
->value
.character
.string
) + 1;
7220 for (indx
= len
; indx
> 0; indx
--)
7222 for (i
= 0; i
< lenc
; i
++)
7224 if (c
->value
.character
.string
[i
]
7225 == e
->value
.character
.string
[indx
- 1])
7233 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
7234 return range_check (result
, "SCAN");
7239 gfc_simplify_selected_char_kind (gfc_expr
*e
)
7243 if (e
->expr_type
!= EXPR_CONSTANT
)
7246 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
7247 || gfc_compare_with_Cstring (e
, "default", false) == 0)
7249 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
7254 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7259 gfc_simplify_selected_int_kind (gfc_expr
*e
)
7263 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
))
7268 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
7269 if (gfc_integer_kinds
[i
].range
>= range
7270 && gfc_integer_kinds
[i
].kind
< kind
)
7271 kind
= gfc_integer_kinds
[i
].kind
;
7273 if (kind
== INT_MAX
)
7276 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7281 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
7283 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
7285 locus
*loc
= &gfc_current_locus
;
7291 if (p
->expr_type
!= EXPR_CONSTANT
7292 || gfc_extract_int (p
, &precision
))
7301 if (q
->expr_type
!= EXPR_CONSTANT
7302 || gfc_extract_int (q
, &range
))
7313 if (rdx
->expr_type
!= EXPR_CONSTANT
7314 || gfc_extract_int (rdx
, &radix
))
7322 found_precision
= 0;
7326 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
7328 if (gfc_real_kinds
[i
].precision
>= precision
)
7329 found_precision
= 1;
7331 if (gfc_real_kinds
[i
].range
>= range
)
7334 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7337 if (gfc_real_kinds
[i
].precision
>= precision
7338 && gfc_real_kinds
[i
].range
>= range
7339 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7340 && gfc_real_kinds
[i
].kind
< kind
)
7341 kind
= gfc_real_kinds
[i
].kind
;
7344 if (kind
== INT_MAX
)
7346 if (found_radix
&& found_range
&& !found_precision
)
7348 else if (found_radix
&& found_precision
&& !found_range
)
7350 else if (found_radix
&& !found_precision
&& !found_range
)
7352 else if (found_radix
)
7358 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
7363 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
7366 mpfr_t exp
, absv
, log2
, pow2
, frac
;
7369 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7372 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7374 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7375 SET_EXPONENT (NaN) = same NaN */
7376 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
7378 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7382 /* SET_EXPONENT (inf) = NaN */
7383 if (mpfr_inf_p (x
->value
.real
))
7385 mpfr_set_nan (result
->value
.real
);
7389 gfc_set_model_kind (x
->ts
.kind
);
7396 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
7397 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
7399 mpfr_trunc (log2
, log2
);
7400 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
7402 /* Old exponent value, and fraction. */
7403 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
7405 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
7408 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
7409 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
7411 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
7413 return range_check (result
, "SET_EXPONENT");
7418 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
7420 mpz_t shape
[GFC_MAX_DIMENSIONS
];
7421 gfc_expr
*result
, *e
, *f
;
7425 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
7427 if (source
->rank
== -1)
7430 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
7431 result
->shape
= gfc_get_shape (1);
7432 mpz_init (result
->shape
[0]);
7434 if (source
->rank
== 0)
7437 if (source
->expr_type
== EXPR_VARIABLE
)
7439 ar
= gfc_find_array_ref (source
);
7440 t
= gfc_array_ref_shape (ar
, shape
);
7442 else if (source
->shape
)
7445 for (n
= 0; n
< source
->rank
; n
++)
7447 mpz_init (shape
[n
]);
7448 mpz_set (shape
[n
], source
->shape
[n
]);
7454 for (n
= 0; n
< source
->rank
; n
++)
7456 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
7459 mpz_set (e
->value
.integer
, shape
[n
]);
7462 mpz_set_ui (e
->value
.integer
, n
+ 1);
7464 f
= simplify_size (source
, e
, k
);
7468 gfc_free_expr (result
);
7475 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
7477 gfc_free_expr (result
);
7479 gfc_clear_shape (shape
, source
->rank
);
7480 return &gfc_bad_expr
;
7483 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
7487 gfc_clear_shape (shape
, source
->rank
);
7489 mpz_set_si (result
->shape
[0], source
->rank
);
7496 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
7499 gfc_expr
*return_value
;
7502 /* For unary operations, the size of the result is given by the size
7503 of the operand. For binary ones, it's the size of the first operand
7504 unless it is scalar, then it is the size of the second. */
7505 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
7507 gfc_expr
* replacement
;
7508 gfc_expr
* simplified
;
7510 switch (array
->value
.op
.op
)
7512 /* Unary operations. */
7514 case INTRINSIC_UPLUS
:
7515 case INTRINSIC_UMINUS
:
7516 case INTRINSIC_PARENTHESES
:
7517 replacement
= array
->value
.op
.op1
;
7520 /* Binary operations. If any one of the operands is scalar, take
7521 the other one's size. If both of them are arrays, it does not
7522 matter -- try to find one with known shape, if possible. */
7524 if (array
->value
.op
.op1
->rank
== 0)
7525 replacement
= array
->value
.op
.op2
;
7526 else if (array
->value
.op
.op2
->rank
== 0)
7527 replacement
= array
->value
.op
.op1
;
7530 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
7534 replacement
= array
->value
.op
.op2
;
7539 /* Try to reduce it directly if possible. */
7540 simplified
= simplify_size (replacement
, dim
, k
);
7542 /* Otherwise, we build a new SIZE call. This is hopefully at least
7543 simpler than the original one. */
7546 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
7547 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
7548 GFC_ISYM_SIZE
, "size",
7550 gfc_copy_expr (replacement
),
7551 gfc_copy_expr (dim
),
7559 if (!gfc_array_size (array
, &size
))
7564 if (dim
->expr_type
!= EXPR_CONSTANT
)
7567 d
= mpz_get_ui (dim
->value
.integer
) - 1;
7568 if (!gfc_array_dimen_size (array
, d
, &size
))
7572 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
7573 mpz_set (return_value
->value
.integer
, size
);
7576 return return_value
;
7581 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
7584 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
7587 return &gfc_bad_expr
;
7589 result
= simplify_size (array
, dim
, k
);
7590 if (result
== NULL
|| result
== &gfc_bad_expr
)
7593 return range_check (result
, "SIZE");
7597 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
7598 multiplied by the array size. */
7601 gfc_simplify_sizeof (gfc_expr
*x
)
7603 gfc_expr
*result
= NULL
;
7607 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7610 if (x
->ts
.type
== BT_CHARACTER
7611 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7612 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7615 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
7616 && !gfc_array_size (x
, &array_size
))
7619 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
7621 gfc_target_expr_size (x
, &res_size
);
7622 mpz_set_si (result
->value
.integer
, res_size
);
7628 /* STORAGE_SIZE returns the size in bits of a single array element. */
7631 gfc_simplify_storage_size (gfc_expr
*x
,
7634 gfc_expr
*result
= NULL
;
7638 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7641 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
7642 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7643 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7646 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
7648 return &gfc_bad_expr
;
7650 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
7652 gfc_element_size (x
, &siz
);
7653 mpz_set_si (result
->value
.integer
, siz
);
7654 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
7656 return range_check (result
, "STORAGE_SIZE");
7661 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
7665 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
7668 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7673 mpz_abs (result
->value
.integer
, x
->value
.integer
);
7674 if (mpz_sgn (y
->value
.integer
) < 0)
7675 mpz_neg (result
->value
.integer
, result
->value
.integer
);
7680 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
7683 mpfr_setsign (result
->value
.real
, x
->value
.real
,
7684 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
7688 gfc_internal_error ("Bad type in gfc_simplify_sign");
7696 gfc_simplify_sin (gfc_expr
*x
)
7700 if (x
->expr_type
!= EXPR_CONSTANT
)
7703 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7708 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7712 gfc_set_model (x
->value
.real
);
7713 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7717 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
7720 return range_check (result
, "SIN");
7725 gfc_simplify_sinh (gfc_expr
*x
)
7729 if (x
->expr_type
!= EXPR_CONSTANT
)
7732 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7737 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7741 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7748 return range_check (result
, "SINH");
7752 /* The argument is always a double precision real that is converted to
7753 single precision. TODO: Rounding! */
7756 gfc_simplify_sngl (gfc_expr
*a
)
7761 if (a
->expr_type
!= EXPR_CONSTANT
)
7764 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
7766 tmp1
= warn_conversion
;
7767 tmp2
= warn_conversion_extra
;
7768 warn_conversion
= warn_conversion_extra
= 0;
7770 result
= gfc_real2real (a
, gfc_default_real_kind
);
7772 warn_conversion
= tmp1
;
7773 warn_conversion_extra
= tmp2
;
7775 return range_check (result
, "SNGL");
7780 gfc_simplify_spacing (gfc_expr
*x
)
7786 if (x
->expr_type
!= EXPR_CONSTANT
)
7789 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7790 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7792 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
7793 if (mpfr_zero_p (x
->value
.real
))
7795 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
7799 /* SPACING(inf) = NaN */
7800 if (mpfr_inf_p (x
->value
.real
))
7802 mpfr_set_nan (result
->value
.real
);
7806 /* SPACING(NaN) = same NaN */
7807 if (mpfr_nan_p (x
->value
.real
))
7809 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7813 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
7814 are the radix, exponent of x, and precision. This excludes the
7815 possibility of subnormal numbers. Fortran 2003 states the result is
7816 b**max(e - p, emin - 1). */
7818 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
7819 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
7820 en
= en
> ep
? en
: ep
;
7822 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
7823 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
7825 return range_check (result
, "SPACING");
7830 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
7832 gfc_expr
*result
= NULL
;
7833 int nelem
, i
, j
, dim
, ncopies
;
7836 if ((!gfc_is_constant_expr (source
)
7837 && !is_constant_array_expr (source
))
7838 || !gfc_is_constant_expr (dim_expr
)
7839 || !gfc_is_constant_expr (ncopies_expr
))
7842 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
7843 gfc_extract_int (dim_expr
, &dim
);
7844 dim
-= 1; /* zero-base DIM */
7846 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
7847 gfc_extract_int (ncopies_expr
, &ncopies
);
7848 ncopies
= MAX (ncopies
, 0);
7850 /* Do not allow the array size to exceed the limit for an array
7852 if (source
->expr_type
== EXPR_ARRAY
)
7854 if (!gfc_array_size (source
, &size
))
7855 gfc_internal_error ("Failure getting length of a constant array.");
7858 mpz_init_set_ui (size
, 1);
7860 nelem
= mpz_get_si (size
) * ncopies
;
7861 if (nelem
> flag_max_array_constructor
)
7863 if (gfc_init_expr_flag
)
7865 gfc_error ("The number of elements (%d) in the array constructor "
7866 "at %L requires an increase of the allowed %d upper "
7867 "limit. See %<-fmax-array-constructor%> option.",
7868 nelem
, &source
->where
, flag_max_array_constructor
);
7869 return &gfc_bad_expr
;
7875 if (source
->expr_type
== EXPR_CONSTANT
7876 || source
->expr_type
== EXPR_STRUCTURE
)
7878 gcc_assert (dim
== 0);
7880 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7882 if (source
->ts
.type
== BT_DERIVED
)
7883 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7885 result
->shape
= gfc_get_shape (result
->rank
);
7886 mpz_init_set_si (result
->shape
[0], ncopies
);
7888 for (i
= 0; i
< ncopies
; ++i
)
7889 gfc_constructor_append_expr (&result
->value
.constructor
,
7890 gfc_copy_expr (source
), NULL
);
7892 else if (source
->expr_type
== EXPR_ARRAY
)
7894 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
7895 gfc_constructor
*source_ctor
;
7897 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
7898 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
7900 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7902 if (source
->ts
.type
== BT_DERIVED
)
7903 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7904 result
->rank
= source
->rank
+ 1;
7905 result
->shape
= gfc_get_shape (result
->rank
);
7907 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
7910 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
7912 mpz_init_set_si (result
->shape
[i
], ncopies
);
7914 extent
[i
] = mpz_get_si (result
->shape
[i
]);
7915 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
7919 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
7920 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
7922 for (i
= 0; i
< ncopies
; ++i
)
7923 gfc_constructor_insert_expr (&result
->value
.constructor
,
7924 gfc_copy_expr (source_ctor
->expr
),
7925 NULL
, offset
+ i
* rstride
[dim
]);
7927 offset
+= (dim
== 0 ? ncopies
: 1);
7932 gfc_error ("Simplification of SPREAD at %C not yet implemented");
7933 return &gfc_bad_expr
;
7936 if (source
->ts
.type
== BT_CHARACTER
)
7937 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
7944 gfc_simplify_sqrt (gfc_expr
*e
)
7946 gfc_expr
*result
= NULL
;
7948 if (e
->expr_type
!= EXPR_CONSTANT
)
7954 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
7956 gfc_error ("Argument of SQRT at %L has a negative value",
7958 return &gfc_bad_expr
;
7960 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7961 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
7965 gfc_set_model (e
->value
.real
);
7967 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7968 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
7972 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
7975 return range_check (result
, "SQRT");
7980 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
7982 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
7986 /* Simplify COTAN(X) where X has the unit of radian. */
7989 gfc_simplify_cotan (gfc_expr
*x
)
7994 if (x
->expr_type
!= EXPR_CONSTANT
)
7997 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8002 mpfr_cot (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8006 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
8007 val
= &result
->value
.complex;
8008 mpc_init2 (swp
, mpfr_get_default_prec ());
8009 mpc_sin_cos (*val
, swp
, x
->value
.complex, GFC_MPC_RND_MODE
,
8011 mpc_div (*val
, swp
, *val
, GFC_MPC_RND_MODE
);
8019 return range_check (result
, "COTAN");
8024 gfc_simplify_tan (gfc_expr
*x
)
8028 if (x
->expr_type
!= EXPR_CONSTANT
)
8031 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8036 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8040 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8047 return range_check (result
, "TAN");
8052 gfc_simplify_tanh (gfc_expr
*x
)
8056 if (x
->expr_type
!= EXPR_CONSTANT
)
8059 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8064 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8068 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8075 return range_check (result
, "TANH");
8080 gfc_simplify_tiny (gfc_expr
*e
)
8085 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
8087 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
8088 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
8095 gfc_simplify_trailz (gfc_expr
*e
)
8097 unsigned long tz
, bs
;
8100 if (e
->expr_type
!= EXPR_CONSTANT
)
8103 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
8104 bs
= gfc_integer_kinds
[i
].bit_size
;
8105 tz
= mpz_scan1 (e
->value
.integer
, 0);
8107 return gfc_get_int_expr (gfc_default_integer_kind
,
8108 &e
->where
, MIN (tz
, bs
));
8113 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
8116 gfc_expr
*mold_element
;
8121 unsigned char *buffer
;
8122 size_t result_length
;
8124 if (!gfc_is_constant_expr (source
) || !gfc_is_constant_expr (size
))
8127 if (!gfc_resolve_expr (mold
))
8129 if (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
8132 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
8133 &result_size
, &result_length
))
8136 /* Calculate the size of the source. */
8137 if (source
->expr_type
== EXPR_ARRAY
&& !gfc_array_size (source
, &tmp
))
8138 gfc_internal_error ("Failure getting length of a constant array.");
8140 /* Create an empty new expression with the appropriate characteristics. */
8141 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
8143 result
->ts
= mold
->ts
;
8145 mold_element
= (mold
->expr_type
== EXPR_ARRAY
&& mold
->value
.constructor
)
8146 ? gfc_constructor_first (mold
->value
.constructor
)->expr
8149 /* Set result character length, if needed. Note that this needs to be
8150 set even for array expressions, in order to pass this information into
8151 gfc_target_interpret_expr. */
8152 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
8153 result
->value
.character
.length
= mold_element
->value
.character
.length
;
8155 /* Set the number of elements in the result, and determine its size. */
8157 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
8159 result
->expr_type
= EXPR_ARRAY
;
8161 result
->shape
= gfc_get_shape (1);
8162 mpz_init_set_ui (result
->shape
[0], result_length
);
8167 /* Allocate the buffer to store the binary version of the source. */
8168 buffer_size
= MAX (source_size
, result_size
);
8169 buffer
= (unsigned char*)alloca (buffer_size
);
8170 memset (buffer
, 0, buffer_size
);
8172 /* Now write source to the buffer. */
8173 gfc_target_encode_expr (source
, buffer
, buffer_size
);
8175 /* And read the buffer back into the new expression. */
8176 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
8183 gfc_simplify_transpose (gfc_expr
*matrix
)
8185 int row
, matrix_rows
, col
, matrix_cols
;
8188 if (!is_constant_array_expr (matrix
))
8191 gcc_assert (matrix
->rank
== 2);
8193 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
8196 result
->shape
= gfc_get_shape (result
->rank
);
8197 mpz_init_set (result
->shape
[0], matrix
->shape
[1]);
8198 mpz_init_set (result
->shape
[1], matrix
->shape
[0]);
8200 if (matrix
->ts
.type
== BT_CHARACTER
)
8201 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
8202 else if (matrix
->ts
.type
== BT_DERIVED
)
8203 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
8205 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
8206 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
8207 for (row
= 0; row
< matrix_rows
; ++row
)
8208 for (col
= 0; col
< matrix_cols
; ++col
)
8210 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
8211 col
* matrix_rows
+ row
);
8212 gfc_constructor_insert_expr (&result
->value
.constructor
,
8213 gfc_copy_expr (e
), &matrix
->where
,
8214 row
* matrix_cols
+ col
);
8222 gfc_simplify_trim (gfc_expr
*e
)
8225 int count
, i
, len
, lentrim
;
8227 if (e
->expr_type
!= EXPR_CONSTANT
)
8230 len
= e
->value
.character
.length
;
8231 for (count
= 0, i
= 1; i
<= len
; ++i
)
8233 if (e
->value
.character
.string
[len
- i
] == ' ')
8239 lentrim
= len
- count
;
8241 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
8242 for (i
= 0; i
< lentrim
; i
++)
8243 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
8250 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
8255 gfc_constructor
*sub_cons
;
8259 if (!is_constant_array_expr (sub
))
8262 /* Follow any component references. */
8263 as
= coarray
->symtree
->n
.sym
->as
;
8264 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
8265 if (ref
->type
== REF_COMPONENT
)
8268 if (as
->type
== AS_DEFERRED
)
8271 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
8272 the cosubscript addresses the first image. */
8274 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
8277 for (d
= 1; d
<= as
->corank
; d
++)
8282 gcc_assert (sub_cons
!= NULL
);
8284 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
8286 if (ca_bound
== NULL
)
8289 if (ca_bound
== &gfc_bad_expr
)
8292 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
8296 gfc_free_expr (ca_bound
);
8297 sub_cons
= gfc_constructor_next (sub_cons
);
8301 first_image
= false;
8305 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8306 "SUB has %ld and COARRAY lower bound is %ld)",
8308 mpz_get_si (sub_cons
->expr
->value
.integer
),
8309 mpz_get_si (ca_bound
->value
.integer
));
8310 gfc_free_expr (ca_bound
);
8311 return &gfc_bad_expr
;
8314 gfc_free_expr (ca_bound
);
8316 /* Check whether upperbound is valid for the multi-images case. */
8319 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
8321 if (ca_bound
== &gfc_bad_expr
)
8324 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
8325 && mpz_cmp (ca_bound
->value
.integer
,
8326 sub_cons
->expr
->value
.integer
) < 0)
8328 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8329 "SUB has %ld and COARRAY upper bound is %ld)",
8331 mpz_get_si (sub_cons
->expr
->value
.integer
),
8332 mpz_get_si (ca_bound
->value
.integer
));
8333 gfc_free_expr (ca_bound
);
8334 return &gfc_bad_expr
;
8338 gfc_free_expr (ca_bound
);
8341 sub_cons
= gfc_constructor_next (sub_cons
);
8344 gcc_assert (sub_cons
== NULL
);
8346 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
8349 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8350 &gfc_current_locus
);
8352 mpz_set_si (result
->value
.integer
, 1);
8354 mpz_set_si (result
->value
.integer
, 0);
8360 gfc_simplify_image_status (gfc_expr
*image
, gfc_expr
*team ATTRIBUTE_UNUSED
)
8362 if (flag_coarray
== GFC_FCOARRAY_NONE
)
8364 gfc_current_locus
= *gfc_current_intrinsic_where
;
8365 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
8366 return &gfc_bad_expr
;
8369 /* Simplification is possible for fcoarray = single only. For all other modes
8370 the result depends on runtime conditions. */
8371 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8374 if (gfc_is_constant_expr (image
))
8377 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8379 if (mpz_get_si (image
->value
.integer
) == 1)
8380 mpz_set_si (result
->value
.integer
, 0);
8382 mpz_set_si (result
->value
.integer
, GFC_STAT_STOPPED_IMAGE
);
8391 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
8392 gfc_expr
*distance ATTRIBUTE_UNUSED
)
8394 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8397 /* If no coarray argument has been passed or when the first argument
8398 is actually a distance argment. */
8399 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
8402 /* FIXME: gfc_current_locus is wrong. */
8403 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8404 &gfc_current_locus
);
8405 mpz_set_si (result
->value
.integer
, 1);
8409 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
8410 return simplify_cobound (coarray
, dim
, NULL
, 0);
8415 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8417 return simplify_bound (array
, dim
, kind
, 1);
8421 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8423 return simplify_cobound (array
, dim
, kind
, 1);
8428 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
8430 gfc_expr
*result
, *e
;
8431 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
8433 if (!is_constant_array_expr (vector
)
8434 || !is_constant_array_expr (mask
)
8435 || (!gfc_is_constant_expr (field
)
8436 && !is_constant_array_expr (field
)))
8439 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
8441 if (vector
->ts
.type
== BT_DERIVED
)
8442 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
8443 result
->rank
= mask
->rank
;
8444 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
8446 if (vector
->ts
.type
== BT_CHARACTER
)
8447 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
8449 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
8450 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
8452 = field
->expr_type
== EXPR_ARRAY
8453 ? gfc_constructor_first (field
->value
.constructor
)
8458 if (mask_ctor
->expr
->value
.logical
)
8460 gcc_assert (vector_ctor
);
8461 e
= gfc_copy_expr (vector_ctor
->expr
);
8462 vector_ctor
= gfc_constructor_next (vector_ctor
);
8464 else if (field
->expr_type
== EXPR_ARRAY
)
8465 e
= gfc_copy_expr (field_ctor
->expr
);
8467 e
= gfc_copy_expr (field
);
8469 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
8471 mask_ctor
= gfc_constructor_next (mask_ctor
);
8472 field_ctor
= gfc_constructor_next (field_ctor
);
8480 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
8484 size_t index
, len
, lenset
;
8486 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
8489 return &gfc_bad_expr
;
8491 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
8492 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
8495 if (b
!= NULL
&& b
->value
.logical
!= 0)
8500 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
8502 len
= s
->value
.character
.length
;
8503 lenset
= set
->value
.character
.length
;
8507 mpz_set_ui (result
->value
.integer
, 0);
8515 mpz_set_ui (result
->value
.integer
, 1);
8519 index
= wide_strspn (s
->value
.character
.string
,
8520 set
->value
.character
.string
) + 1;
8529 mpz_set_ui (result
->value
.integer
, len
);
8532 for (index
= len
; index
> 0; index
--)
8534 for (i
= 0; i
< lenset
; i
++)
8536 if (s
->value
.character
.string
[index
- 1]
8537 == set
->value
.character
.string
[i
])
8545 mpz_set_ui (result
->value
.integer
, index
);
8551 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
8556 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
8559 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
8564 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
8565 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
8566 return range_check (result
, "XOR");
8569 return gfc_get_logical_expr (kind
, &x
->where
,
8570 (x
->value
.logical
&& !y
->value
.logical
)
8571 || (!x
->value
.logical
&& y
->value
.logical
));
8579 /****************** Constant simplification *****************/
8581 /* Master function to convert one constant to another. While this is
8582 used as a simplification function, it requires the destination type
8583 and kind information which is supplied by a special case in
8587 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
8589 gfc_expr
*result
, *(*f
) (gfc_expr
*, int);
8590 gfc_constructor
*c
, *t
;
8604 f
= gfc_int2complex
;
8624 f
= gfc_real2complex
;
8635 f
= gfc_complex2int
;
8638 f
= gfc_complex2real
;
8641 f
= gfc_complex2complex
;
8667 f
= gfc_hollerith2int
;
8671 f
= gfc_hollerith2real
;
8675 f
= gfc_hollerith2complex
;
8679 f
= gfc_hollerith2character
;
8683 f
= gfc_hollerith2logical
;
8695 f
= gfc_character2int
;
8699 f
= gfc_character2real
;
8703 f
= gfc_character2complex
;
8707 f
= gfc_character2character
;
8711 f
= gfc_character2logical
;
8721 return &gfc_bad_expr
;
8726 switch (e
->expr_type
)
8729 result
= f (e
, kind
);
8731 return &gfc_bad_expr
;
8735 if (!gfc_is_constant_expr (e
))
8738 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8739 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8740 result
->rank
= e
->rank
;
8742 for (c
= gfc_constructor_first (e
->value
.constructor
);
8743 c
; c
= gfc_constructor_next (c
))
8746 if (c
->iterator
== NULL
)
8748 if (c
->expr
->expr_type
== EXPR_ARRAY
)
8749 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8750 else if (c
->expr
->expr_type
== EXPR_OP
)
8752 if (!gfc_simplify_expr (c
->expr
, 1))
8753 return &gfc_bad_expr
;
8754 tmp
= f (c
->expr
, kind
);
8757 tmp
= f (c
->expr
, kind
);
8760 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8762 if (tmp
== NULL
|| tmp
== &gfc_bad_expr
)
8764 gfc_free_expr (result
);
8768 t
= gfc_constructor_append_expr (&result
->value
.constructor
,
8771 t
->iterator
= gfc_copy_iterator (c
->iterator
);
8784 /* Function for converting character constants. */
8786 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
8791 if (!gfc_is_constant_expr (e
))
8794 if (e
->expr_type
== EXPR_CONSTANT
)
8796 /* Simple case of a scalar. */
8797 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
8799 return &gfc_bad_expr
;
8801 result
->value
.character
.length
= e
->value
.character
.length
;
8802 result
->value
.character
.string
8803 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
8804 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
8805 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
8807 /* Check we only have values representable in the destination kind. */
8808 for (i
= 0; i
< result
->value
.character
.length
; i
++)
8809 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
8812 gfc_error ("Character %qs in string at %L cannot be converted "
8813 "into character kind %d",
8814 gfc_print_wide_char (result
->value
.character
.string
[i
]),
8816 gfc_free_expr (result
);
8817 return &gfc_bad_expr
;
8822 else if (e
->expr_type
== EXPR_ARRAY
)
8824 /* For an array constructor, we convert each constructor element. */
8827 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8828 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8829 result
->rank
= e
->rank
;
8830 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
8832 for (c
= gfc_constructor_first (e
->value
.constructor
);
8833 c
; c
= gfc_constructor_next (c
))
8835 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
8836 if (tmp
== &gfc_bad_expr
)
8838 gfc_free_expr (result
);
8839 return &gfc_bad_expr
;
8844 gfc_free_expr (result
);
8848 gfc_constructor_append_expr (&result
->value
.constructor
,
8860 gfc_simplify_compiler_options (void)
8865 str
= gfc_get_option_string ();
8866 result
= gfc_get_character_expr (gfc_default_character_kind
,
8867 &gfc_current_locus
, str
, strlen (str
));
8874 gfc_simplify_compiler_version (void)
8879 len
= strlen ("GCC version ") + strlen (version_string
);
8880 buffer
= XALLOCAVEC (char, len
+ 1);
8881 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
8882 return gfc_get_character_expr (gfc_default_character_kind
,
8883 &gfc_current_locus
, buffer
, len
);
8886 /* Simplification routines for intrinsics of IEEE modules. */
8889 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
8891 gfc_actual_arglist
*arg
;
8892 gfc_expr
*p
= NULL
, *q
= NULL
, *rdx
= NULL
;
8894 arg
= expr
->value
.function
.actual
;
8898 q
= arg
->next
->expr
;
8899 if (arg
->next
->next
)
8900 rdx
= arg
->next
->next
->expr
;
8903 /* Currently, if IEEE is supported and this module is built, it means
8904 all our floating-point types conform to IEEE. Hence, we simply handle
8905 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
8906 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
8910 simplify_ieee_support (gfc_expr
*expr
)
8912 /* We consider that if the IEEE modules are loaded, we have full support
8913 for flags, halting and rounding, which are the three functions
8914 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
8915 expressions. One day, we will need libgfortran to detect support and
8916 communicate it back to us, allowing for partial support. */
8918 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
8923 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
8925 int n
= strlen(name
);
8927 if (!strncmp(sym
->name
, name
, n
))
8930 /* If a generic was used and renamed, we need more work to find out.
8931 Compare the specific name. */
8932 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
8939 gfc_simplify_ieee_functions (gfc_expr
*expr
)
8941 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
8943 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
8944 return simplify_ieee_selected_real_kind (expr
);
8945 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
8946 || matches_ieee_function_name(sym
, "ieee_support_halting")
8947 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
8948 return simplify_ieee_support (expr
);