1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2022 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 if (array
->shape
== NULL
)
2115 gfc_array_size (array
, &size
);
2116 arraysize
= mpz_get_ui (size
);
2119 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
2120 result
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
2121 result
->rank
= array
->rank
;
2122 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
2127 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2128 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
2129 for (i
= 0; i
< arraysize
; i
++)
2131 arrayvec
[i
] = array_ctor
->expr
;
2132 array_ctor
= gfc_constructor_next (array_ctor
);
2135 resultvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2141 for (d
=0; d
< array
->rank
; d
++)
2143 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2144 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2147 if (shift
->rank
> 0)
2149 gfc_array_size (shift
, &size
);
2150 shiftsize
= mpz_get_ui (size
);
2152 shiftvec
= XCNEWVEC (ssize_t
, shiftsize
);
2153 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2154 for (d
= 0; d
< shift
->rank
; d
++)
2156 h_extent
[d
] = mpz_get_si (shift
->shape
[d
]);
2157 hstride
[d
] = d
== 0 ? 1 : hstride
[d
-1] * h_extent
[d
-1];
2163 /* Shut up compiler */
2168 for (d
=0; d
< array
->rank
; d
++)
2172 rsoffset
= a_stride
[d
];
2178 extent
[n
] = a_extent
[d
];
2179 sstride
[n
] = a_stride
[d
];
2180 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2182 hs_ex
[n
] = hstride
[n
] * extent
[n
];
2191 for (i
= 0; i
< shiftsize
; i
++)
2194 val
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2199 shift_ctor
= gfc_constructor_next (shift_ctor
);
2205 shift_val
= mpz_get_si (shift
->value
.integer
);
2206 shift_val
= shift_val
% len
;
2211 continue_loop
= true;
2217 while (continue_loop
)
2225 src
= &sptr
[sh
* rsoffset
];
2227 for (n
= 0; n
< len
- sh
; n
++)
2234 for ( n
= 0; n
< sh
; n
++)
2246 while (count
[n
] == extent
[n
])
2256 continue_loop
= false;
2270 for (i
= 0; i
< arraysize
; i
++)
2272 gfc_constructor_append_expr (&result
->value
.constructor
,
2273 gfc_copy_expr (resultvec
[i
]),
2281 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2283 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
2288 gfc_simplify_dble (gfc_expr
*e
)
2290 gfc_expr
*result
= NULL
;
2293 if (e
->expr_type
!= EXPR_CONSTANT
)
2296 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
2298 tmp1
= warn_conversion
;
2299 tmp2
= warn_conversion_extra
;
2300 warn_conversion
= warn_conversion_extra
= 0;
2302 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
2304 warn_conversion
= tmp1
;
2305 warn_conversion_extra
= tmp2
;
2307 if (result
== &gfc_bad_expr
)
2308 return &gfc_bad_expr
;
2310 return range_check (result
, "DBLE");
2315 gfc_simplify_digits (gfc_expr
*x
)
2319 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2324 digits
= gfc_integer_kinds
[i
].digits
;
2329 digits
= gfc_real_kinds
[i
].digits
;
2336 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
2341 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
2346 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2349 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2350 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
2355 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
2356 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2358 mpz_set_ui (result
->value
.integer
, 0);
2363 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
2364 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
2367 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2372 gfc_internal_error ("gfc_simplify_dim(): Bad type");
2375 return range_check (result
, "DIM");
2380 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2382 /* If vector_a is a zero-sized array, the result is 0 for INTEGER,
2383 REAL, and COMPLEX types and .false. for LOGICAL. */
2384 if (vector_a
->shape
&& mpz_get_si (vector_a
->shape
[0]) == 0)
2386 if (vector_a
->ts
.type
== BT_LOGICAL
)
2387 return gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, false);
2389 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2392 if (!is_constant_array_expr (vector_a
)
2393 || !is_constant_array_expr (vector_b
))
2396 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
2401 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
2403 gfc_expr
*a1
, *a2
, *result
;
2405 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2408 a1
= gfc_real2real (x
, gfc_default_double_kind
);
2409 a2
= gfc_real2real (y
, gfc_default_double_kind
);
2411 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
2412 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
2417 return range_check (result
, "DPROD");
2422 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
2426 int i
, k
, size
, shift
;
2428 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
2429 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
2432 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
2433 size
= gfc_integer_kinds
[k
].bit_size
;
2435 gfc_extract_int (shiftarg
, &shift
);
2437 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2439 shift
= size
- shift
;
2441 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
2442 mpz_set_ui (result
->value
.integer
, 0);
2444 for (i
= 0; i
< shift
; i
++)
2445 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
2446 mpz_setbit (result
->value
.integer
, i
);
2448 for (i
= 0; i
< size
- shift
; i
++)
2449 if (mpz_tstbit (arg1
->value
.integer
, i
))
2450 mpz_setbit (result
->value
.integer
, shift
+ i
);
2452 /* Convert to a signed value. */
2453 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
2460 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2462 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
2467 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2469 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
2474 gfc_simplify_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2481 gfc_expr
**arrayvec
, **resultvec
;
2482 gfc_expr
**rptr
, **sptr
;
2484 size_t arraysize
, i
;
2485 gfc_constructor
*array_ctor
, *shift_ctor
, *bnd_ctor
;
2486 ssize_t shift_val
, len
;
2487 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
2488 sstride
[GFC_MAX_DIMENSIONS
], a_extent
[GFC_MAX_DIMENSIONS
],
2489 a_stride
[GFC_MAX_DIMENSIONS
], ss_ex
[GFC_MAX_DIMENSIONS
+ 1];
2493 gfc_expr
**src
, **dest
;
2496 if (!is_constant_array_expr (array
))
2499 if (shift
->rank
> 0)
2500 gfc_simplify_expr (shift
, 1);
2502 if (!gfc_is_constant_expr (shift
))
2507 if (boundary
->rank
> 0)
2508 gfc_simplify_expr (boundary
, 1);
2510 if (!gfc_is_constant_expr (boundary
))
2516 if (!gfc_is_constant_expr (dim
))
2518 which
= mpz_get_si (dim
->value
.integer
) - 1;
2524 if (boundary
== NULL
)
2526 temp_boundary
= true;
2527 switch (array
->ts
.type
)
2531 bnd
= gfc_get_int_expr (array
->ts
.kind
, NULL
, 0);
2535 bnd
= gfc_get_logical_expr (array
->ts
.kind
, NULL
, 0);
2539 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2540 mpfr_set_ui (bnd
->value
.real
, 0, GFC_RND_MODE
);
2544 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2545 mpc_set_ui (bnd
->value
.complex, 0, GFC_RND_MODE
);
2549 s_len
= mpz_get_ui (array
->ts
.u
.cl
->length
->value
.integer
);
2550 bnd
= gfc_get_character_expr (array
->ts
.kind
, &gfc_current_locus
, NULL
, s_len
);
2560 temp_boundary
= false;
2564 gfc_array_size (array
, &size
);
2565 arraysize
= mpz_get_ui (size
);
2568 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
2569 result
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
2570 result
->rank
= array
->rank
;
2571 result
->ts
= array
->ts
;
2576 if (array
->shape
== NULL
)
2579 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2580 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
2581 for (i
= 0; i
< arraysize
; i
++)
2583 arrayvec
[i
] = array_ctor
->expr
;
2584 array_ctor
= gfc_constructor_next (array_ctor
);
2587 resultvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2592 for (d
=0; d
< array
->rank
; d
++)
2594 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2595 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2598 if (shift
->rank
> 0)
2600 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2606 shift_val
= mpz_get_si (shift
->value
.integer
);
2610 bnd_ctor
= gfc_constructor_first (bnd
->value
.constructor
);
2614 /* Shut up compiler */
2619 for (d
=0; d
< array
->rank
; d
++)
2623 rsoffset
= a_stride
[d
];
2629 extent
[n
] = a_extent
[d
];
2630 sstride
[n
] = a_stride
[d
];
2631 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2637 continue_loop
= true;
2642 while (continue_loop
)
2647 sh
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2651 if (( sh
>= 0 ? sh
: -sh
) > len
)
2657 delta
= (sh
>= 0) ? sh
: -sh
;
2661 src
= &sptr
[delta
* rsoffset
];
2667 dest
= &rptr
[delta
* rsoffset
];
2670 for (n
= 0; n
< len
- delta
; n
++)
2686 *dest
= gfc_copy_expr (bnd_ctor
->expr
);
2694 *dest
= gfc_copy_expr (bnd
);
2701 shift_ctor
= gfc_constructor_next (shift_ctor
);
2704 bnd_ctor
= gfc_constructor_next (bnd_ctor
);
2708 while (count
[n
] == extent
[n
])
2716 continue_loop
= false;
2728 for (i
= 0; i
< arraysize
; i
++)
2730 gfc_constructor_append_expr (&result
->value
.constructor
,
2731 gfc_copy_expr (resultvec
[i
]),
2737 gfc_free_expr (bnd
);
2743 gfc_simplify_erf (gfc_expr
*x
)
2747 if (x
->expr_type
!= EXPR_CONSTANT
)
2750 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2751 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2753 return range_check (result
, "ERF");
2758 gfc_simplify_erfc (gfc_expr
*x
)
2762 if (x
->expr_type
!= EXPR_CONSTANT
)
2765 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2766 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2768 return range_check (result
, "ERFC");
2772 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2774 #define MAX_ITER 200
2775 #define ARG_LIMIT 12
2777 /* Calculate ERFC_SCALED directly by its definition:
2779 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2781 using a large precision for intermediate results. This is used for all
2782 but large values of the argument. */
2784 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2789 prec
= mpfr_get_default_prec ();
2790 mpfr_set_default_prec (10 * prec
);
2795 mpfr_set (a
, arg
, GFC_RND_MODE
);
2796 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2797 mpfr_exp (b
, b
, GFC_RND_MODE
);
2798 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2799 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2801 mpfr_set (res
, a
, GFC_RND_MODE
);
2802 mpfr_set_default_prec (prec
);
2808 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2810 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2811 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2814 This is used for large values of the argument. Intermediate calculations
2815 are performed with twice the precision. We don't do a fixed number of
2816 iterations of the sum, but stop when it has converged to the required
2819 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2821 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2826 prec
= mpfr_get_default_prec ();
2827 mpfr_set_default_prec (2 * prec
);
2837 mpfr_init (sumtrunc
);
2838 mpfr_set_prec (oldsum
, prec
);
2839 mpfr_set_prec (sumtrunc
, prec
);
2841 mpfr_set (x
, arg
, GFC_RND_MODE
);
2842 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2843 mpz_set_ui (num
, 1);
2845 mpfr_set (u
, x
, GFC_RND_MODE
);
2846 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2847 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2848 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2850 for (i
= 1; i
< MAX_ITER
; i
++)
2852 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2854 mpz_mul_ui (num
, num
, 2 * i
- 1);
2857 mpfr_set (w
, u
, GFC_RND_MODE
);
2858 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2860 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2861 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2863 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2865 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2866 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2870 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2872 gcc_assert (i
< MAX_ITER
);
2874 /* Divide by x * sqrt(Pi). */
2875 mpfr_const_pi (u
, GFC_RND_MODE
);
2876 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2877 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2878 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2880 mpfr_set (res
, sum
, GFC_RND_MODE
);
2881 mpfr_set_default_prec (prec
);
2883 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2889 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2893 if (x
->expr_type
!= EXPR_CONSTANT
)
2896 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2897 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2898 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2900 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2902 return range_check (result
, "ERFC_SCALED");
2910 gfc_simplify_epsilon (gfc_expr
*e
)
2915 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2917 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2918 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2920 return range_check (result
, "EPSILON");
2925 gfc_simplify_exp (gfc_expr
*x
)
2929 if (x
->expr_type
!= EXPR_CONSTANT
)
2932 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2937 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2941 gfc_set_model_kind (x
->ts
.kind
);
2942 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2946 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2949 return range_check (result
, "EXP");
2954 gfc_simplify_exponent (gfc_expr
*x
)
2959 if (x
->expr_type
!= EXPR_CONSTANT
)
2962 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2965 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2966 if (mpfr_inf_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
2968 int i
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
2969 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2973 /* EXPONENT(+/- 0.0) = 0 */
2974 if (mpfr_zero_p (x
->value
.real
))
2976 mpz_set_ui (result
->value
.integer
, 0);
2980 gfc_set_model (x
->value
.real
);
2982 val
= (long int) mpfr_get_exp (x
->value
.real
);
2983 mpz_set_si (result
->value
.integer
, val
);
2985 return range_check (result
, "EXPONENT");
2990 gfc_simplify_failed_or_stopped_images (gfc_expr
*team ATTRIBUTE_UNUSED
,
2993 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2995 gfc_current_locus
= *gfc_current_intrinsic_where
;
2996 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2997 return &gfc_bad_expr
;
3000 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
3005 gfc_extract_int (kind
, &actual_kind
);
3007 actual_kind
= gfc_default_integer_kind
;
3009 result
= gfc_get_array_expr (BT_INTEGER
, actual_kind
, &gfc_current_locus
);
3014 /* For fcoarray = lib no simplification is possible, because it is not known
3015 what images failed or are stopped at compile time. */
3021 gfc_simplify_get_team (gfc_expr
*level ATTRIBUTE_UNUSED
)
3023 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3025 gfc_current_locus
= *gfc_current_intrinsic_where
;
3026 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3027 return &gfc_bad_expr
;
3030 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
3033 result
= gfc_get_array_expr (BT_INTEGER
, gfc_default_integer_kind
, &gfc_current_locus
);
3038 /* For fcoarray = lib no simplification is possible, because it is not known
3039 what images failed or are stopped at compile time. */
3045 gfc_simplify_float (gfc_expr
*a
)
3049 if (a
->expr_type
!= EXPR_CONSTANT
)
3052 result
= gfc_int2real (a
, gfc_default_real_kind
);
3054 return range_check (result
, "FLOAT");
3059 is_last_ref_vtab (gfc_expr
*e
)
3062 gfc_component
*comp
= NULL
;
3064 if (e
->expr_type
!= EXPR_VARIABLE
)
3067 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3068 if (ref
->type
== REF_COMPONENT
)
3069 comp
= ref
->u
.c
.component
;
3071 if (!e
->ref
|| !comp
)
3072 return e
->symtree
->n
.sym
->attr
.vtab
;
3074 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
3082 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
3084 /* Avoid simplification of resolved symbols. */
3085 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
3088 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
3089 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3090 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3093 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
3096 /* Return .false. if the dynamic type can never be an extension. */
3097 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
3098 && !gfc_type_is_extension_of
3099 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
3100 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
3101 && !gfc_type_is_extension_of
3102 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
3103 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
3104 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
3105 && !gfc_type_is_extension_of
3106 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
3108 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3109 && !gfc_type_is_extension_of
3110 (mold
->ts
.u
.derived
,
3111 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
3112 && !gfc_type_is_extension_of
3113 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
3114 mold
->ts
.u
.derived
)))
3115 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3117 /* Return .true. if the dynamic type is guaranteed to be an extension. */
3118 if (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3119 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3120 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
3121 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
3128 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3130 /* Avoid simplification of resolved symbols. */
3131 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
3134 /* Return .false. if the dynamic type can never be the
3136 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
3137 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
3138 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
3139 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
3140 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3142 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
3145 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3146 gfc_compare_derived_types (a
->ts
.u
.derived
,
3152 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
3158 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
3160 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3162 if (e
->expr_type
!= EXPR_CONSTANT
)
3165 mpfr_init2 (floor
, mpfr_get_prec (e
->value
.real
));
3166 mpfr_floor (floor
, e
->value
.real
);
3168 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
3169 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
3173 return range_check (result
, "FLOOR");
3178 gfc_simplify_fraction (gfc_expr
*x
)
3183 if (x
->expr_type
!= EXPR_CONSTANT
)
3186 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
3188 /* FRACTION(inf) = NaN. */
3189 if (mpfr_inf_p (x
->value
.real
))
3191 mpfr_set_nan (result
->value
.real
);
3195 /* mpfr_frexp() correctly handles zeros and NaNs. */
3196 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3198 return range_check (result
, "FRACTION");
3203 gfc_simplify_gamma (gfc_expr
*x
)
3207 if (x
->expr_type
!= EXPR_CONSTANT
)
3210 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3211 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3213 return range_check (result
, "GAMMA");
3218 gfc_simplify_huge (gfc_expr
*e
)
3223 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3224 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3229 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
3233 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
3245 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
3249 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3252 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3253 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
3254 return range_check (result
, "HYPOT");
3258 /* We use the processor's collating sequence, because all
3259 systems that gfortran currently works on are ASCII. */
3262 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
3268 if (e
->expr_type
!= EXPR_CONSTANT
)
3271 if (e
->value
.character
.length
!= 1)
3273 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
3274 return &gfc_bad_expr
;
3277 index
= e
->value
.character
.string
[0];
3279 if (warn_surprising
&& index
> 127)
3280 gfc_warning (OPT_Wsurprising
,
3281 "Argument of IACHAR function at %L outside of range 0..127",
3284 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
3286 return &gfc_bad_expr
;
3288 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3290 return range_check (result
, "IACHAR");
3295 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
3297 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3298 gcc_assert (result
->ts
.type
== BT_INTEGER
3299 && result
->expr_type
== EXPR_CONSTANT
);
3301 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3307 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3309 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
3314 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
3316 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3317 gcc_assert (result
->ts
.type
== BT_INTEGER
3318 && result
->expr_type
== EXPR_CONSTANT
);
3320 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3326 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3328 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
3333 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
3337 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3340 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3341 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3343 return range_check (result
, "IAND");
3348 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
3353 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3356 gfc_extract_int (y
, &pos
);
3358 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3360 result
= gfc_copy_expr (x
);
3362 convert_mpz_to_unsigned (result
->value
.integer
,
3363 gfc_integer_kinds
[k
].bit_size
);
3365 mpz_clrbit (result
->value
.integer
, pos
);
3367 gfc_convert_mpz_to_signed (result
->value
.integer
,
3368 gfc_integer_kinds
[k
].bit_size
);
3375 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
3382 if (x
->expr_type
!= EXPR_CONSTANT
3383 || y
->expr_type
!= EXPR_CONSTANT
3384 || z
->expr_type
!= EXPR_CONSTANT
)
3387 gfc_extract_int (y
, &pos
);
3388 gfc_extract_int (z
, &len
);
3390 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
3392 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3394 if (pos
+ len
> bitsize
)
3396 gfc_error ("Sum of second and third arguments of IBITS exceeds "
3397 "bit size at %L", &y
->where
);
3398 return &gfc_bad_expr
;
3401 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3402 convert_mpz_to_unsigned (result
->value
.integer
,
3403 gfc_integer_kinds
[k
].bit_size
);
3405 bits
= XCNEWVEC (int, bitsize
);
3407 for (i
= 0; i
< bitsize
; i
++)
3410 for (i
= 0; i
< len
; i
++)
3411 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
3413 for (i
= 0; i
< bitsize
; i
++)
3416 mpz_clrbit (result
->value
.integer
, i
);
3417 else if (bits
[i
] == 1)
3418 mpz_setbit (result
->value
.integer
, i
);
3420 gfc_internal_error ("IBITS: Bad bit");
3425 gfc_convert_mpz_to_signed (result
->value
.integer
,
3426 gfc_integer_kinds
[k
].bit_size
);
3433 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
3438 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3441 gfc_extract_int (y
, &pos
);
3443 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3445 result
= gfc_copy_expr (x
);
3447 convert_mpz_to_unsigned (result
->value
.integer
,
3448 gfc_integer_kinds
[k
].bit_size
);
3450 mpz_setbit (result
->value
.integer
, pos
);
3452 gfc_convert_mpz_to_signed (result
->value
.integer
,
3453 gfc_integer_kinds
[k
].bit_size
);
3460 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
3466 if (e
->expr_type
!= EXPR_CONSTANT
)
3469 if (e
->value
.character
.length
!= 1)
3471 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
3472 return &gfc_bad_expr
;
3475 index
= e
->value
.character
.string
[0];
3477 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
3479 return &gfc_bad_expr
;
3481 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3483 return range_check (result
, "ICHAR");
3488 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
3492 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3495 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3496 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3498 return range_check (result
, "IEOR");
3503 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
3506 int back
, len
, lensub
;
3507 int i
, j
, k
, count
, index
= 0, start
;
3509 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
3510 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
3513 if (b
!= NULL
&& b
->value
.logical
!= 0)
3518 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
3520 return &gfc_bad_expr
;
3522 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
3524 len
= x
->value
.character
.length
;
3525 lensub
= y
->value
.character
.length
;
3529 mpz_set_si (result
->value
.integer
, 0);
3537 mpz_set_si (result
->value
.integer
, 1);
3540 else if (lensub
== 1)
3542 for (i
= 0; i
< len
; i
++)
3544 for (j
= 0; j
< lensub
; j
++)
3546 if (y
->value
.character
.string
[j
]
3547 == x
->value
.character
.string
[i
])
3557 for (i
= 0; i
< len
; i
++)
3559 for (j
= 0; j
< lensub
; j
++)
3561 if (y
->value
.character
.string
[j
]
3562 == x
->value
.character
.string
[i
])
3567 for (k
= 0; k
< lensub
; k
++)
3569 if (y
->value
.character
.string
[k
]
3570 == x
->value
.character
.string
[k
+ start
])
3574 if (count
== lensub
)
3589 mpz_set_si (result
->value
.integer
, len
+ 1);
3592 else if (lensub
== 1)
3594 for (i
= 0; i
< len
; i
++)
3596 for (j
= 0; j
< lensub
; j
++)
3598 if (y
->value
.character
.string
[j
]
3599 == x
->value
.character
.string
[len
- i
])
3601 index
= len
- i
+ 1;
3609 for (i
= 0; i
< len
; i
++)
3611 for (j
= 0; j
< lensub
; j
++)
3613 if (y
->value
.character
.string
[j
]
3614 == x
->value
.character
.string
[len
- i
])
3617 if (start
<= len
- lensub
)
3620 for (k
= 0; k
< lensub
; k
++)
3621 if (y
->value
.character
.string
[k
]
3622 == x
->value
.character
.string
[k
+ start
])
3625 if (count
== lensub
)
3642 mpz_set_si (result
->value
.integer
, index
);
3643 return range_check (result
, "INDEX");
3648 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
3650 gfc_expr
*result
= NULL
;
3653 /* Convert BOZ to integer, and return without range checking. */
3654 if (e
->ts
.type
== BT_BOZ
)
3656 if (!gfc_boz2int (e
, kind
))
3658 result
= gfc_copy_expr (e
);
3662 if (e
->expr_type
!= EXPR_CONSTANT
)
3665 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
3667 tmp1
= warn_conversion
;
3668 tmp2
= warn_conversion_extra
;
3669 warn_conversion
= warn_conversion_extra
= 0;
3671 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
3673 warn_conversion
= tmp1
;
3674 warn_conversion_extra
= tmp2
;
3676 if (result
== &gfc_bad_expr
)
3677 return &gfc_bad_expr
;
3679 return range_check (result
, name
);
3684 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
3688 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
3690 return &gfc_bad_expr
;
3692 return simplify_intconv (e
, kind
, "INT");
3696 gfc_simplify_int2 (gfc_expr
*e
)
3698 return simplify_intconv (e
, 2, "INT2");
3703 gfc_simplify_int8 (gfc_expr
*e
)
3705 return simplify_intconv (e
, 8, "INT8");
3710 gfc_simplify_long (gfc_expr
*e
)
3712 return simplify_intconv (e
, 4, "LONG");
3717 gfc_simplify_ifix (gfc_expr
*e
)
3719 gfc_expr
*rtrunc
, *result
;
3721 if (e
->expr_type
!= EXPR_CONSTANT
)
3724 rtrunc
= gfc_copy_expr (e
);
3725 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3727 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3729 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3731 gfc_free_expr (rtrunc
);
3733 return range_check (result
, "IFIX");
3738 gfc_simplify_idint (gfc_expr
*e
)
3740 gfc_expr
*rtrunc
, *result
;
3742 if (e
->expr_type
!= EXPR_CONSTANT
)
3745 rtrunc
= gfc_copy_expr (e
);
3746 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3748 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3750 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3752 gfc_free_expr (rtrunc
);
3754 return range_check (result
, "IDINT");
3759 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
3763 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3766 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3767 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3769 return range_check (result
, "IOR");
3774 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
3776 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3777 gcc_assert (result
->ts
.type
== BT_INTEGER
3778 && result
->expr_type
== EXPR_CONSTANT
);
3780 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3786 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3788 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3793 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3795 if (x
->expr_type
!= EXPR_CONSTANT
)
3798 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3799 mpz_cmp_si (x
->value
.integer
,
3800 LIBERROR_END
) == 0);
3805 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3807 if (x
->expr_type
!= EXPR_CONSTANT
)
3810 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3811 mpz_cmp_si (x
->value
.integer
,
3812 LIBERROR_EOR
) == 0);
3817 gfc_simplify_isnan (gfc_expr
*x
)
3819 if (x
->expr_type
!= EXPR_CONSTANT
)
3822 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3823 mpfr_nan_p (x
->value
.real
));
3827 /* Performs a shift on its first argument. Depending on the last
3828 argument, the shift can be arithmetic, i.e. with filling from the
3829 left like in the SHIFTA intrinsic. */
3831 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3832 bool arithmetic
, int direction
)
3835 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3837 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3840 gfc_extract_int (s
, &shift
);
3842 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3843 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3845 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3849 mpz_set (result
->value
.integer
, e
->value
.integer
);
3853 if (direction
> 0 && shift
< 0)
3855 /* Left shift, as in SHIFTL. */
3856 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3857 return &gfc_bad_expr
;
3859 else if (direction
< 0)
3861 /* Right shift, as in SHIFTR or SHIFTA. */
3864 gfc_error ("Second argument of %s is negative at %L",
3866 return &gfc_bad_expr
;
3872 ashift
= (shift
>= 0 ? shift
: -shift
);
3874 if (ashift
> bitsize
)
3876 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3877 "at %L", name
, &e
->where
);
3878 return &gfc_bad_expr
;
3881 bits
= XCNEWVEC (int, bitsize
);
3883 for (i
= 0; i
< bitsize
; i
++)
3884 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3889 for (i
= 0; i
< shift
; i
++)
3890 mpz_clrbit (result
->value
.integer
, i
);
3892 for (i
= 0; i
< bitsize
- shift
; i
++)
3895 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3897 mpz_setbit (result
->value
.integer
, i
+ shift
);
3903 if (arithmetic
&& bits
[bitsize
- 1])
3904 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3905 mpz_setbit (result
->value
.integer
, i
);
3907 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3908 mpz_clrbit (result
->value
.integer
, i
);
3910 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3913 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3915 mpz_setbit (result
->value
.integer
, i
- ashift
);
3919 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3927 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3929 return simplify_shift (e
, s
, "ISHFT", false, 0);
3934 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3936 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3941 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3943 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3948 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3950 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3955 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3957 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3962 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3964 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3969 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3972 int shift
, ashift
, isize
, ssize
, delta
, k
;
3975 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3978 gfc_extract_int (s
, &shift
);
3980 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3981 isize
= gfc_integer_kinds
[k
].bit_size
;
3985 if (sz
->expr_type
!= EXPR_CONSTANT
)
3988 gfc_extract_int (sz
, &ssize
);
4001 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
4002 "BIT_SIZE of first argument at %C");
4004 gfc_error ("Absolute value of SHIFT shall be less than or equal "
4006 return &gfc_bad_expr
;
4009 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4011 mpz_set (result
->value
.integer
, e
->value
.integer
);
4016 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
4018 bits
= XCNEWVEC (int, ssize
);
4020 for (i
= 0; i
< ssize
; i
++)
4021 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
4023 delta
= ssize
- ashift
;
4027 for (i
= 0; i
< delta
; i
++)
4030 mpz_clrbit (result
->value
.integer
, i
+ shift
);
4032 mpz_setbit (result
->value
.integer
, i
+ shift
);
4035 for (i
= delta
; i
< ssize
; i
++)
4038 mpz_clrbit (result
->value
.integer
, i
- delta
);
4040 mpz_setbit (result
->value
.integer
, i
- delta
);
4045 for (i
= 0; i
< ashift
; i
++)
4048 mpz_clrbit (result
->value
.integer
, i
+ delta
);
4050 mpz_setbit (result
->value
.integer
, i
+ delta
);
4053 for (i
= ashift
; i
< ssize
; i
++)
4056 mpz_clrbit (result
->value
.integer
, i
+ shift
);
4058 mpz_setbit (result
->value
.integer
, i
+ shift
);
4062 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
4070 gfc_simplify_kind (gfc_expr
*e
)
4072 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
4077 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
4078 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
4080 gfc_expr
*l
, *u
, *result
;
4083 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4084 gfc_default_integer_kind
);
4086 return &gfc_bad_expr
;
4088 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4090 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
4091 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
4092 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
4096 gfc_expr
* dim
= result
;
4097 mpz_set_si (dim
->value
.integer
, d
);
4099 result
= simplify_size (array
, dim
, k
);
4100 gfc_free_expr (dim
);
4105 mpz_set_si (result
->value
.integer
, 1);
4110 /* Otherwise, we have a variable expression. */
4111 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
4114 if (!gfc_resolve_array_spec (as
, 0))
4117 /* The last dimension of an assumed-size array is special. */
4118 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
4119 || (coarray
&& d
== as
->rank
+ as
->corank
4120 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
4122 if (as
->lower
[d
-1] && as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
4124 gfc_free_expr (result
);
4125 return gfc_copy_expr (as
->lower
[d
-1]);
4131 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4133 /* Then, we need to know the extent of the given dimension. */
4134 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
4136 gfc_expr
*declared_bound
;
4138 bool constant_lbound
, constant_ubound
;
4143 gcc_assert (l
!= NULL
);
4145 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
4146 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
4148 empty_bound
= upper
? 0 : 1;
4149 declared_bound
= upper
? u
: l
;
4151 if ((!upper
&& !constant_lbound
)
4152 || (upper
&& !constant_ubound
))
4157 /* For {L,U}BOUND, the value depends on whether the array
4158 is empty. We can nevertheless simplify if the declared bound
4159 has the same value as that of an empty array, in which case
4160 the result isn't dependent on the array emptyness. */
4161 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
4162 mpz_set_si (result
->value
.integer
, empty_bound
);
4163 else if (!constant_lbound
|| !constant_ubound
)
4164 /* Array emptyness can't be determined, we can't simplify. */
4166 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
4167 mpz_set_si (result
->value
.integer
, empty_bound
);
4169 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4172 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4178 int d2
= 0, cnt
= 0;
4179 for (int idx
= 0; idx
< ref
->u
.ar
.dimen
; ++idx
)
4181 if (ref
->u
.ar
.dimen_type
[idx
] == DIMEN_ELEMENT
)
4183 else if (cnt
< d
- 1)
4188 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d2
+ d
- 1, &result
->value
.integer
, NULL
))
4192 mpz_set_si (result
->value
.integer
, (long int) 1);
4196 return range_check (result
, upper
? "UBOUND" : "LBOUND");
4199 gfc_free_expr (result
);
4205 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4209 ar_type type
= AR_UNKNOWN
;
4212 if (array
->ts
.type
== BT_CLASS
)
4215 if (array
->expr_type
!= EXPR_VARIABLE
)
4222 /* Do not attempt to resolve if error has already been issued. */
4223 if (array
->symtree
->n
.sym
->error
)
4226 /* Follow any component references. */
4227 as
= array
->symtree
->n
.sym
->as
;
4228 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4233 type
= ref
->u
.ar
.type
;
4234 switch (ref
->u
.ar
.type
)
4241 /* We're done because 'as' has already been set in the
4242 previous iteration. */
4256 as
= ref
->u
.c
.component
->as
;
4269 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
4270 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
4273 /* 'array' shall not be an unallocated allocatable variable or a pointer that
4274 is not associated. */
4275 if (array
->expr_type
== EXPR_VARIABLE
4276 && (gfc_expr_attr (array
).allocatable
|| gfc_expr_attr (array
).pointer
))
4280 || (as
->type
!= AS_DEFERRED
4281 && array
->expr_type
== EXPR_VARIABLE
4282 && !gfc_expr_attr (array
).allocatable
4283 && !gfc_expr_attr (array
).pointer
));
4287 /* Multi-dimensional bounds. */
4288 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4292 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4293 if (upper
&& type
== AR_FULL
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
4295 /* An error message will be emitted in
4296 check_assumed_size_reference (resolve.cc). */
4297 return &gfc_bad_expr
;
4300 /* Simplify the bounds for each dimension. */
4301 for (d
= 0; d
< array
->rank
; d
++)
4303 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
4305 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4309 for (j
= 0; j
< d
; j
++)
4310 gfc_free_expr (bounds
[j
]);
4313 return &gfc_bad_expr
;
4319 /* Allocate the result expression. */
4320 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4321 gfc_default_integer_kind
);
4323 return &gfc_bad_expr
;
4325 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
4327 /* The result is a rank 1 array; its size is the rank of the first
4328 argument to {L,U}BOUND. */
4330 e
->shape
= gfc_get_shape (1);
4331 mpz_init_set_ui (e
->shape
[0], array
->rank
);
4333 /* Create the constructor for this array. */
4334 for (d
= 0; d
< array
->rank
; d
++)
4335 gfc_constructor_append_expr (&e
->value
.constructor
,
4336 bounds
[d
], &e
->where
);
4342 /* A DIM argument is specified. */
4343 if (dim
->expr_type
!= EXPR_CONSTANT
)
4346 d
= mpz_get_si (dim
->value
.integer
);
4348 if ((d
< 1 || d
> array
->rank
)
4349 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
4351 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4352 return &gfc_bad_expr
;
4355 if (as
&& as
->type
== AS_ASSUMED_RANK
)
4358 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
4364 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4370 if (array
->expr_type
!= EXPR_VARIABLE
)
4373 /* Follow any component references. */
4374 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
4375 ? array
->ts
.u
.derived
->components
->as
4376 : array
->symtree
->n
.sym
->as
;
4377 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4382 switch (ref
->u
.ar
.type
)
4385 if (ref
->u
.ar
.as
->corank
> 0)
4387 gcc_assert (as
== ref
->u
.ar
.as
);
4394 /* We're done because 'as' has already been set in the
4395 previous iteration. */
4409 as
= ref
->u
.c
.component
->as
;
4423 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
4428 /* Multi-dimensional cobounds. */
4429 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4433 /* Simplify the cobounds for each dimension. */
4434 for (d
= 0; d
< as
->corank
; d
++)
4436 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
4437 upper
, as
, ref
, true);
4438 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4442 for (j
= 0; j
< d
; j
++)
4443 gfc_free_expr (bounds
[j
]);
4448 /* Allocate the result expression. */
4449 e
= gfc_get_expr ();
4450 e
->where
= array
->where
;
4451 e
->expr_type
= EXPR_ARRAY
;
4452 e
->ts
.type
= BT_INTEGER
;
4453 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
4454 gfc_default_integer_kind
);
4458 return &gfc_bad_expr
;
4462 /* The result is a rank 1 array; its size is the rank of the first
4463 argument to {L,U}COBOUND. */
4465 e
->shape
= gfc_get_shape (1);
4466 mpz_init_set_ui (e
->shape
[0], as
->corank
);
4468 /* Create the constructor for this array. */
4469 for (d
= 0; d
< as
->corank
; d
++)
4470 gfc_constructor_append_expr (&e
->value
.constructor
,
4471 bounds
[d
], &e
->where
);
4476 /* A DIM argument is specified. */
4477 if (dim
->expr_type
!= EXPR_CONSTANT
)
4480 d
= mpz_get_si (dim
->value
.integer
);
4482 if (d
< 1 || d
> as
->corank
)
4484 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4485 return &gfc_bad_expr
;
4488 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
4494 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4496 return simplify_bound (array
, dim
, kind
, 0);
4501 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4503 return simplify_cobound (array
, dim
, kind
, 0);
4507 gfc_simplify_leadz (gfc_expr
*e
)
4509 unsigned long lz
, bs
;
4512 if (e
->expr_type
!= EXPR_CONSTANT
)
4515 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4516 bs
= gfc_integer_kinds
[i
].bit_size
;
4517 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
4519 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
4522 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
4524 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
4528 /* Check for constant length of a substring. */
4531 substring_has_constant_len (gfc_expr
*e
)
4534 HOST_WIDE_INT istart
, iend
, length
;
4535 bool equal_length
= false;
4537 if (e
->ts
.type
!= BT_CHARACTER
)
4540 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4541 if (ref
->type
!= REF_COMPONENT
&& ref
->type
!= REF_ARRAY
)
4545 || ref
->type
!= REF_SUBSTRING
4547 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
4549 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
4552 /* Basic checks on substring starting and ending indices. */
4553 if (!gfc_resolve_substring (ref
, &equal_length
))
4556 istart
= gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
);
4557 iend
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
);
4560 length
= iend
- istart
+ 1;
4564 /* Fix substring length. */
4565 e
->value
.character
.length
= length
;
4572 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
4575 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
4578 return &gfc_bad_expr
;
4580 if (e
->expr_type
== EXPR_CONSTANT
4581 || substring_has_constant_len (e
))
4583 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4584 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
4585 return range_check (result
, "LEN");
4587 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
4588 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
4589 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
4591 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4592 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
4593 return range_check (result
, "LEN");
4595 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
4596 && e
->symtree
->n
.sym
4597 && e
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
4598 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
4599 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
4600 && e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
4601 && UNLIMITED_POLY (e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
))
4603 /* The expression in assoc->target points to a ref to the _data component
4604 of the unlimited polymorphic entity. To get the _len component the last
4605 _data ref needs to be stripped and a ref to the _len component added. */
4606 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
, k
);
4613 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
4616 size_t count
, len
, i
;
4617 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
4620 return &gfc_bad_expr
;
4622 if (e
->expr_type
!= EXPR_CONSTANT
)
4625 len
= e
->value
.character
.length
;
4626 for (count
= 0, i
= 1; i
<= len
; i
++)
4627 if (e
->value
.character
.string
[len
- i
] == ' ')
4632 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
4633 return range_check (result
, "LEN_TRIM");
4637 gfc_simplify_lgamma (gfc_expr
*x
)
4642 if (x
->expr_type
!= EXPR_CONSTANT
)
4645 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4646 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
4648 return range_check (result
, "LGAMMA");
4653 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
4655 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4658 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4659 gfc_compare_string (a
, b
) >= 0);
4664 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
4666 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4669 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4670 gfc_compare_string (a
, b
) > 0);
4675 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
4677 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4680 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4681 gfc_compare_string (a
, b
) <= 0);
4686 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
4688 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4691 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4692 gfc_compare_string (a
, b
) < 0);
4697 gfc_simplify_log (gfc_expr
*x
)
4701 if (x
->expr_type
!= EXPR_CONSTANT
)
4704 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4709 if (mpfr_sgn (x
->value
.real
) <= 0)
4711 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4712 "to zero", &x
->where
);
4713 gfc_free_expr (result
);
4714 return &gfc_bad_expr
;
4717 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4721 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
4722 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
4724 gfc_error ("Complex argument of LOG at %L cannot be zero",
4726 gfc_free_expr (result
);
4727 return &gfc_bad_expr
;
4730 gfc_set_model_kind (x
->ts
.kind
);
4731 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
4735 gfc_internal_error ("gfc_simplify_log: bad type");
4738 return range_check (result
, "LOG");
4743 gfc_simplify_log10 (gfc_expr
*x
)
4747 if (x
->expr_type
!= EXPR_CONSTANT
)
4750 if (mpfr_sgn (x
->value
.real
) <= 0)
4752 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4753 "to zero", &x
->where
);
4754 return &gfc_bad_expr
;
4757 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4758 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4760 return range_check (result
, "LOG10");
4765 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
4769 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
4771 return &gfc_bad_expr
;
4773 if (e
->expr_type
!= EXPR_CONSTANT
)
4776 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
4781 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
4784 int row
, result_rows
, col
, result_columns
;
4785 int stride_a
, offset_a
, stride_b
, offset_b
;
4787 if (!is_constant_array_expr (matrix_a
)
4788 || !is_constant_array_expr (matrix_b
))
4791 /* MATMUL should do mixed-mode arithmetic. Set the result type. */
4792 if (matrix_a
->ts
.type
!= matrix_b
->ts
.type
)
4795 e
.expr_type
= EXPR_OP
;
4796 gfc_clear_ts (&e
.ts
);
4797 e
.value
.op
.op
= INTRINSIC_NONE
;
4798 e
.value
.op
.op1
= matrix_a
;
4799 e
.value
.op
.op2
= matrix_b
;
4800 gfc_type_convert_binary (&e
, 1);
4801 result
= gfc_get_array_expr (e
.ts
.type
, e
.ts
.kind
, &matrix_a
->where
);
4805 result
= gfc_get_array_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
4809 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
4812 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4814 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4817 result
->shape
= gfc_get_shape (result
->rank
);
4818 mpz_init_set_si (result
->shape
[0], result_columns
);
4820 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
4822 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4824 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4828 result
->shape
= gfc_get_shape (result
->rank
);
4829 mpz_init_set_si (result
->shape
[0], result_rows
);
4831 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
4833 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4834 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4835 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4836 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4839 result
->shape
= gfc_get_shape (result
->rank
);
4840 mpz_init_set_si (result
->shape
[0], result_rows
);
4841 mpz_init_set_si (result
->shape
[1], result_columns
);
4847 for (col
= 0; col
< result_columns
; ++col
)
4851 for (row
= 0; row
< result_rows
; ++row
)
4853 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
4854 matrix_b
, 1, offset_b
, false);
4855 gfc_constructor_append_expr (&result
->value
.constructor
,
4861 offset_b
+= stride_b
;
4869 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
4874 if (i
->expr_type
!= EXPR_CONSTANT
)
4877 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
4879 return &gfc_bad_expr
;
4880 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4882 bool fail
= gfc_extract_int (i
, &arg
);
4885 if (!gfc_check_mask (i
, kind_arg
))
4886 return &gfc_bad_expr
;
4888 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4890 /* MASKR(n) = 2^n - 1 */
4891 mpz_set_ui (result
->value
.integer
, 1);
4892 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4893 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4895 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4902 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4908 if (i
->expr_type
!= EXPR_CONSTANT
)
4911 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4913 return &gfc_bad_expr
;
4914 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4916 bool fail
= gfc_extract_int (i
, &arg
);
4919 if (!gfc_check_mask (i
, kind_arg
))
4920 return &gfc_bad_expr
;
4922 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4924 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4925 mpz_init_set_ui (z
, 1);
4926 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4927 mpz_set_ui (result
->value
.integer
, 1);
4928 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4929 gfc_integer_kinds
[k
].bit_size
- arg
);
4930 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4933 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4940 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4943 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4945 if (mask
->expr_type
== EXPR_CONSTANT
)
4947 result
= gfc_copy_expr (mask
->value
.logical
? tsource
: fsource
);
4948 /* Parenthesis is needed to get lower bounds of 1. */
4949 result
= gfc_get_parentheses (result
);
4950 gfc_simplify_expr (result
, 1);
4954 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4955 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4958 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4960 if (tsource
->ts
.type
== BT_DERIVED
)
4961 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4962 else if (tsource
->ts
.type
== BT_CHARACTER
)
4963 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4965 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4966 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4967 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4971 if (mask_ctor
->expr
->value
.logical
)
4972 gfc_constructor_append_expr (&result
->value
.constructor
,
4973 gfc_copy_expr (tsource_ctor
->expr
),
4976 gfc_constructor_append_expr (&result
->value
.constructor
,
4977 gfc_copy_expr (fsource_ctor
->expr
),
4979 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4980 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4981 mask_ctor
= gfc_constructor_next (mask_ctor
);
4984 result
->shape
= gfc_get_shape (1);
4985 gfc_array_size (result
, &result
->shape
[0]);
4992 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4994 mpz_t arg1
, arg2
, mask
;
4997 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4998 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
5001 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
5003 /* Convert all argument to unsigned. */
5004 mpz_init_set (arg1
, i
->value
.integer
);
5005 mpz_init_set (arg2
, j
->value
.integer
);
5006 mpz_init_set (mask
, mask_expr
->value
.integer
);
5008 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
5009 mpz_and (arg1
, arg1
, mask
);
5010 mpz_com (mask
, mask
);
5011 mpz_and (arg2
, arg2
, mask
);
5012 mpz_ior (result
->value
.integer
, arg1
, arg2
);
5022 /* Selects between current value and extremum for simplify_min_max
5023 and simplify_minval_maxval. */
5025 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
, bool back_val
)
5029 switch (arg
->ts
.type
)
5032 if (extremum
->ts
.kind
< arg
->ts
.kind
)
5033 extremum
->ts
.kind
= arg
->ts
.kind
;
5034 ret
= mpz_cmp (arg
->value
.integer
,
5035 extremum
->value
.integer
) * sign
;
5037 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
5041 if (extremum
->ts
.kind
< arg
->ts
.kind
)
5042 extremum
->ts
.kind
= arg
->ts
.kind
;
5043 if (mpfr_nan_p (extremum
->value
.real
))
5046 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
5048 else if (mpfr_nan_p (arg
->value
.real
))
5052 ret
= mpfr_cmp (arg
->value
.real
, extremum
->value
.real
) * sign
;
5054 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
5059 #define LENGTH(x) ((x)->value.character.length)
5060 #define STRING(x) ((x)->value.character.string)
5061 if (LENGTH (extremum
) < LENGTH(arg
))
5063 gfc_char_t
*tmp
= STRING(extremum
);
5065 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
5066 memcpy (STRING(extremum
), tmp
,
5067 LENGTH(extremum
) * sizeof (gfc_char_t
));
5068 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
5069 LENGTH(arg
) - LENGTH(extremum
));
5070 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
5071 LENGTH(extremum
) = LENGTH(arg
);
5074 ret
= gfc_compare_string (arg
, extremum
) * sign
;
5077 free (STRING(extremum
));
5078 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
5079 memcpy (STRING(extremum
), STRING(arg
),
5080 LENGTH(arg
) * sizeof (gfc_char_t
));
5081 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
5082 LENGTH(extremum
) - LENGTH(arg
));
5083 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
5090 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5092 if (back_val
&& ret
== 0)
5099 /* This function is special since MAX() can take any number of
5100 arguments. The simplified expression is a rewritten version of the
5101 argument list containing at most one constant element. Other
5102 constant elements are deleted. Because the argument list has
5103 already been checked, this function always succeeds. sign is 1 for
5104 MAX(), -1 for MIN(). */
5107 simplify_min_max (gfc_expr
*expr
, int sign
)
5110 gfc_actual_arglist
*arg
, *last
, *extremum
;
5111 gfc_expr
*tmp
, *ret
;
5117 arg
= expr
->value
.function
.actual
;
5119 for (; arg
; last
= arg
, arg
= arg
->next
)
5121 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
5124 if (extremum
== NULL
)
5130 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
5132 /* Delete the extra constant argument. */
5133 last
->next
= arg
->next
;
5136 gfc_free_actual_arglist (arg
);
5140 /* If there is one value left, replace the function call with the
5142 if (expr
->value
.function
.actual
->next
!= NULL
)
5145 /* Handle special cases of specific functions (min|max)1 and
5148 tmp
= expr
->value
.function
.actual
->expr
;
5149 fname
= expr
->value
.function
.isym
->name
;
5151 if ((tmp
->ts
.type
!= BT_INTEGER
|| tmp
->ts
.kind
!= gfc_integer_4_kind
)
5152 && (strcmp (fname
, "min1") == 0 || strcmp (fname
, "max1") == 0))
5154 /* Explicit conversion, turn off -Wconversion and -Wconversion-extra
5156 tmp1
= warn_conversion
;
5157 tmp2
= warn_conversion_extra
;
5158 warn_conversion
= warn_conversion_extra
= 0;
5160 ret
= gfc_convert_constant (tmp
, BT_INTEGER
, gfc_integer_4_kind
);
5162 warn_conversion
= tmp1
;
5163 warn_conversion_extra
= tmp2
;
5165 else if ((tmp
->ts
.type
!= BT_REAL
|| tmp
->ts
.kind
!= gfc_real_4_kind
)
5166 && (strcmp (fname
, "amin0") == 0 || strcmp (fname
, "amax0") == 0))
5168 ret
= gfc_convert_constant (tmp
, BT_REAL
, gfc_real_4_kind
);
5171 ret
= gfc_copy_expr (tmp
);
5179 gfc_simplify_min (gfc_expr
*e
)
5181 return simplify_min_max (e
, -1);
5186 gfc_simplify_max (gfc_expr
*e
)
5188 return simplify_min_max (e
, 1);
5191 /* Helper function for gfc_simplify_minval. */
5194 gfc_min (gfc_expr
*op1
, gfc_expr
*op2
)
5196 min_max_choose (op1
, op2
, -1);
5197 gfc_free_expr (op1
);
5201 /* Simplify minval for constant arrays. */
5204 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5206 return simplify_transformation (array
, dim
, mask
, INT_MAX
, gfc_min
);
5209 /* Helper function for gfc_simplify_maxval. */
5212 gfc_max (gfc_expr
*op1
, gfc_expr
*op2
)
5214 min_max_choose (op1
, op2
, 1);
5215 gfc_free_expr (op1
);
5220 /* Simplify maxval for constant arrays. */
5223 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5225 return simplify_transformation (array
, dim
, mask
, INT_MIN
, gfc_max
);
5229 /* Transform minloc or maxloc of an array, according to MASK,
5230 to the scalar result. This code is mostly identical to
5231 simplify_transformation_to_scalar. */
5234 simplify_minmaxloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
5235 gfc_expr
*extremum
, int sign
, bool back_val
)
5238 gfc_constructor
*array_ctor
, *mask_ctor
;
5241 mpz_set_si (result
->value
.integer
, 0);
5244 /* Shortcut for constant .FALSE. MASK. */
5246 && mask
->expr_type
== EXPR_CONSTANT
5247 && !mask
->value
.logical
)
5250 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5251 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5252 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5256 mpz_init_set_si (count
, 0);
5259 mpz_add_ui (count
, count
, 1);
5260 a
= array_ctor
->expr
;
5261 array_ctor
= gfc_constructor_next (array_ctor
);
5262 /* A constant MASK equals .TRUE. here and can be ignored. */
5265 m
= mask_ctor
->expr
;
5266 mask_ctor
= gfc_constructor_next (mask_ctor
);
5267 if (!m
->value
.logical
)
5270 if (min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5271 mpz_set (result
->value
.integer
, count
);
5274 gfc_free_expr (extremum
);
5278 /* Simplify minloc / maxloc in the absence of a dim argument. */
5281 simplify_minmaxloc_nodim (gfc_expr
*result
, gfc_expr
*extremum
,
5282 gfc_expr
*array
, gfc_expr
*mask
, int sign
,
5285 ssize_t res
[GFC_MAX_DIMENSIONS
];
5287 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5288 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5289 sstride
[GFC_MAX_DIMENSIONS
];
5294 for (i
= 0; i
<array
->rank
; i
++)
5297 /* Shortcut for constant .FALSE. MASK. */
5299 && mask
->expr_type
== EXPR_CONSTANT
5300 && !mask
->value
.logical
)
5303 if (array
->shape
== NULL
)
5306 for (i
= 0; i
< array
->rank
; i
++)
5309 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5310 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5315 continue_loop
= true;
5316 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5317 if (mask
&& mask
->rank
> 0)
5318 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5322 /* Loop over the array elements (and mask), keeping track of
5323 the indices to return. */
5324 while (continue_loop
)
5328 a
= array_ctor
->expr
;
5331 m
= mask_ctor
->expr
;
5332 ma
= m
->value
.logical
;
5333 mask_ctor
= gfc_constructor_next (mask_ctor
);
5338 if (ma
&& min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5340 for (i
= 0; i
<array
->rank
; i
++)
5343 array_ctor
= gfc_constructor_next (array_ctor
);
5345 } while (count
[0] != extent
[0]);
5349 /* When we get to the end of a dimension, reset it and increment
5350 the next dimension. */
5353 if (n
>= array
->rank
)
5355 continue_loop
= false;
5360 } while (count
[n
] == extent
[n
]);
5364 gfc_free_expr (extremum
);
5365 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5366 for (i
= 0; i
<array
->rank
; i
++)
5369 r_expr
= result_ctor
->expr
;
5370 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5371 result_ctor
= gfc_constructor_next (result_ctor
);
5376 /* Helper function for gfc_simplify_minmaxloc - build an array
5377 expression with n elements. */
5380 new_array (bt type
, int kind
, int n
, locus
*where
)
5385 result
= gfc_get_array_expr (type
, kind
, where
);
5387 result
->shape
= gfc_get_shape(1);
5388 mpz_init_set_si (result
->shape
[0], n
);
5389 for (i
= 0; i
< n
; i
++)
5391 gfc_constructor_append_expr (&result
->value
.constructor
,
5392 gfc_get_constant_expr (type
, kind
, where
),
5399 /* Simplify minloc and maxloc. This code is mostly identical to
5400 simplify_transformation_to_array. */
5403 simplify_minmaxloc_to_array (gfc_expr
*result
, gfc_expr
*array
,
5404 gfc_expr
*dim
, gfc_expr
*mask
,
5405 gfc_expr
*extremum
, int sign
, bool back_val
)
5408 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5409 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5410 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5412 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5413 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5414 tmpstride
[GFC_MAX_DIMENSIONS
];
5416 /* Shortcut for constant .FALSE. MASK. */
5418 && mask
->expr_type
== EXPR_CONSTANT
5419 && !mask
->value
.logical
)
5422 /* Build an indexed table for array element expressions to minimize
5423 linked-list traversal. Masked elements are set to NULL. */
5424 gfc_array_size (array
, &size
);
5425 arraysize
= mpz_get_ui (size
);
5428 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5430 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5432 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5433 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5435 for (i
= 0; i
< arraysize
; ++i
)
5437 arrayvec
[i
] = array_ctor
->expr
;
5438 array_ctor
= gfc_constructor_next (array_ctor
);
5442 if (!mask_ctor
->expr
->value
.logical
)
5445 mask_ctor
= gfc_constructor_next (mask_ctor
);
5449 /* Same for the result expression. */
5450 gfc_array_size (result
, &size
);
5451 resultsize
= mpz_get_ui (size
);
5454 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5455 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5456 for (i
= 0; i
< resultsize
; ++i
)
5458 resultvec
[i
] = result_ctor
->expr
;
5459 result_ctor
= gfc_constructor_next (result_ctor
);
5462 gfc_extract_int (dim
, &dim_index
);
5463 dim_index
-= 1; /* zero-base index */
5467 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5470 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5473 dim_extent
= mpz_get_si (array
->shape
[i
]);
5474 dim_stride
= tmpstride
[i
];
5478 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5479 sstride
[n
] = tmpstride
[i
];
5480 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5484 done
= resultsize
<= 0;
5490 ex
= gfc_copy_expr (extremum
);
5491 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5493 if (*src
&& min_max_choose (*src
, ex
, sign
, back_val
) > 0)
5494 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5503 while (!done
&& count
[n
] == extent
[n
])
5506 base
-= sstride
[n
] * extent
[n
];
5507 dest
-= dstride
[n
] * extent
[n
];
5510 if (n
< result
->rank
)
5512 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5513 times, we'd warn for the last iteration, because the
5514 array index will have already been incremented to the
5515 array sizes, and we can't tell that this must make
5516 the test against result->rank false, because ranks
5517 must not exceed GFC_MAX_DIMENSIONS. */
5518 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5529 /* Place updated expression in result constructor. */
5530 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5531 for (i
= 0; i
< resultsize
; ++i
)
5533 result_ctor
->expr
= resultvec
[i
];
5534 result_ctor
= gfc_constructor_next (result_ctor
);
5543 /* Simplify minloc and maxloc for constant arrays. */
5546 gfc_simplify_minmaxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
5547 gfc_expr
*kind
, gfc_expr
*back
, int sign
)
5553 bool back_val
= false;
5555 if (!is_constant_array_expr (array
)
5556 || !gfc_is_constant_expr (dim
))
5560 && !is_constant_array_expr (mask
)
5561 && mask
->expr_type
!= EXPR_CONSTANT
)
5566 if (gfc_extract_int (kind
, &ikind
, -1))
5570 ikind
= gfc_default_integer_kind
;
5574 if (back
->expr_type
!= EXPR_CONSTANT
)
5577 back_val
= back
->value
.logical
;
5587 extremum
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
5588 init_result_expr (extremum
, init_val
, array
);
5592 result
= transformational_result (array
, dim
, BT_INTEGER
,
5593 ikind
, &array
->where
);
5594 init_result_expr (result
, 0, array
);
5596 if (array
->rank
== 1)
5597 return simplify_minmaxloc_to_scalar (result
, array
, mask
, extremum
,
5600 return simplify_minmaxloc_to_array (result
, array
, dim
, mask
, extremum
,
5605 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5606 return simplify_minmaxloc_nodim (result
, extremum
, array
, mask
,
5612 gfc_simplify_minloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5615 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, -1);
5619 gfc_simplify_maxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5622 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, 1);
5625 /* Simplify findloc to scalar. Similar to
5626 simplify_minmaxloc_to_scalar. */
5629 simplify_findloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5630 gfc_expr
*mask
, int back_val
)
5633 gfc_constructor
*array_ctor
, *mask_ctor
;
5636 mpz_set_si (result
->value
.integer
, 0);
5638 /* Shortcut for constant .FALSE. MASK. */
5640 && mask
->expr_type
== EXPR_CONSTANT
5641 && !mask
->value
.logical
)
5644 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5645 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5646 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5650 mpz_init_set_si (count
, 0);
5653 mpz_add_ui (count
, count
, 1);
5654 a
= array_ctor
->expr
;
5655 array_ctor
= gfc_constructor_next (array_ctor
);
5656 /* A constant MASK equals .TRUE. here and can be ignored. */
5659 m
= mask_ctor
->expr
;
5660 mask_ctor
= gfc_constructor_next (mask_ctor
);
5661 if (!m
->value
.logical
)
5664 if (gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5666 /* We have a match. If BACK is true, continue so we find
5668 mpz_set (result
->value
.integer
, count
);
5677 /* Simplify findloc in the absence of a dim argument. Similar to
5678 simplify_minmaxloc_nodim. */
5681 simplify_findloc_nodim (gfc_expr
*result
, gfc_expr
*value
, gfc_expr
*array
,
5682 gfc_expr
*mask
, bool back_val
)
5684 ssize_t res
[GFC_MAX_DIMENSIONS
];
5686 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5687 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5688 sstride
[GFC_MAX_DIMENSIONS
];
5693 for (i
= 0; i
< array
->rank
; i
++)
5696 /* Shortcut for constant .FALSE. MASK. */
5698 && mask
->expr_type
== EXPR_CONSTANT
5699 && !mask
->value
.logical
)
5702 for (i
= 0; i
< array
->rank
; i
++)
5705 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5706 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5711 continue_loop
= true;
5712 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5713 if (mask
&& mask
->rank
> 0)
5714 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5718 /* Loop over the array elements (and mask), keeping track of
5719 the indices to return. */
5720 while (continue_loop
)
5724 a
= array_ctor
->expr
;
5727 m
= mask_ctor
->expr
;
5728 ma
= m
->value
.logical
;
5729 mask_ctor
= gfc_constructor_next (mask_ctor
);
5734 if (ma
&& gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5736 for (i
= 0; i
< array
->rank
; i
++)
5741 array_ctor
= gfc_constructor_next (array_ctor
);
5743 } while (count
[0] != extent
[0]);
5747 /* When we get to the end of a dimension, reset it and increment
5748 the next dimension. */
5751 if (n
>= array
->rank
)
5753 continue_loop
= false;
5758 } while (count
[n
] == extent
[n
]);
5762 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5763 for (i
= 0; i
< array
->rank
; i
++)
5766 r_expr
= result_ctor
->expr
;
5767 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5768 result_ctor
= gfc_constructor_next (result_ctor
);
5774 /* Simplify findloc to an array. Similar to
5775 simplify_minmaxloc_to_array. */
5778 simplify_findloc_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5779 gfc_expr
*dim
, gfc_expr
*mask
, bool back_val
)
5782 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5783 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5784 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5786 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5787 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5788 tmpstride
[GFC_MAX_DIMENSIONS
];
5790 /* Shortcut for constant .FALSE. MASK. */
5792 && mask
->expr_type
== EXPR_CONSTANT
5793 && !mask
->value
.logical
)
5796 /* Build an indexed table for array element expressions to minimize
5797 linked-list traversal. Masked elements are set to NULL. */
5798 gfc_array_size (array
, &size
);
5799 arraysize
= mpz_get_ui (size
);
5802 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5804 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5806 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5807 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5809 for (i
= 0; i
< arraysize
; ++i
)
5811 arrayvec
[i
] = array_ctor
->expr
;
5812 array_ctor
= gfc_constructor_next (array_ctor
);
5816 if (!mask_ctor
->expr
->value
.logical
)
5819 mask_ctor
= gfc_constructor_next (mask_ctor
);
5823 /* Same for the result expression. */
5824 gfc_array_size (result
, &size
);
5825 resultsize
= mpz_get_ui (size
);
5828 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5829 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5830 for (i
= 0; i
< resultsize
; ++i
)
5832 resultvec
[i
] = result_ctor
->expr
;
5833 result_ctor
= gfc_constructor_next (result_ctor
);
5836 gfc_extract_int (dim
, &dim_index
);
5838 dim_index
-= 1; /* Zero-base index. */
5842 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5845 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5848 dim_extent
= mpz_get_si (array
->shape
[i
]);
5849 dim_stride
= tmpstride
[i
];
5853 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5854 sstride
[n
] = tmpstride
[i
];
5855 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5859 done
= resultsize
<= 0;
5864 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5866 if (*src
&& gfc_compare_expr (*src
, value
, INTRINSIC_EQ
) == 0)
5868 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5879 while (!done
&& count
[n
] == extent
[n
])
5882 base
-= sstride
[n
] * extent
[n
];
5883 dest
-= dstride
[n
] * extent
[n
];
5886 if (n
< result
->rank
)
5888 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5889 times, we'd warn for the last iteration, because the
5890 array index will have already been incremented to the
5891 array sizes, and we can't tell that this must make
5892 the test against result->rank false, because ranks
5893 must not exceed GFC_MAX_DIMENSIONS. */
5894 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5905 /* Place updated expression in result constructor. */
5906 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5907 for (i
= 0; i
< resultsize
; ++i
)
5909 result_ctor
->expr
= resultvec
[i
];
5910 result_ctor
= gfc_constructor_next (result_ctor
);
5918 /* Simplify findloc. */
5921 gfc_simplify_findloc (gfc_expr
*array
, gfc_expr
*value
, gfc_expr
*dim
,
5922 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
5926 bool back_val
= false;
5928 if (!is_constant_array_expr (array
)
5929 || !gfc_is_constant_expr (dim
))
5932 if (! gfc_is_constant_expr (value
))
5936 && !is_constant_array_expr (mask
)
5937 && mask
->expr_type
!= EXPR_CONSTANT
)
5942 if (gfc_extract_int (kind
, &ikind
, -1))
5946 ikind
= gfc_default_integer_kind
;
5950 if (back
->expr_type
!= EXPR_CONSTANT
)
5953 back_val
= back
->value
.logical
;
5958 result
= transformational_result (array
, dim
, BT_INTEGER
,
5959 ikind
, &array
->where
);
5960 init_result_expr (result
, 0, array
);
5962 if (array
->rank
== 1)
5963 return simplify_findloc_to_scalar (result
, array
, value
, mask
,
5966 return simplify_findloc_to_array (result
, array
, value
, dim
, mask
,
5971 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5972 return simplify_findloc_nodim (result
, value
, array
, mask
, back_val
);
5978 gfc_simplify_maxexponent (gfc_expr
*x
)
5980 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5981 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5982 gfc_real_kinds
[i
].max_exponent
);
5987 gfc_simplify_minexponent (gfc_expr
*x
)
5989 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5990 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5991 gfc_real_kinds
[i
].min_exponent
);
5996 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
6001 /* First check p. */
6002 if (p
->expr_type
!= EXPR_CONSTANT
)
6005 /* p shall not be 0. */
6009 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
6011 gfc_error ("Argument %qs of MOD at %L shall not be zero",
6013 return &gfc_bad_expr
;
6017 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
6019 gfc_error ("Argument %qs of MOD at %L shall not be zero",
6021 return &gfc_bad_expr
;
6025 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6028 if (a
->expr_type
!= EXPR_CONSTANT
)
6031 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6032 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6034 if (a
->ts
.type
== BT_INTEGER
)
6035 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6038 gfc_set_model_kind (kind
);
6039 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6043 return range_check (result
, "MOD");
6048 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
6053 /* First check p. */
6054 if (p
->expr_type
!= EXPR_CONSTANT
)
6057 /* p shall not be 0. */
6061 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
6063 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6065 return &gfc_bad_expr
;
6069 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
6071 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6073 return &gfc_bad_expr
;
6077 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6080 if (a
->expr_type
!= EXPR_CONSTANT
)
6083 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6084 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6086 if (a
->ts
.type
== BT_INTEGER
)
6087 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6090 gfc_set_model_kind (kind
);
6091 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6093 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
6095 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
6096 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
6100 mpfr_copysign (result
->value
.real
, result
->value
.real
,
6101 p
->value
.real
, GFC_RND_MODE
);
6104 return range_check (result
, "MODULO");
6109 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
6112 mpfr_exp_t emin
, emax
;
6115 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
6118 result
= gfc_copy_expr (x
);
6120 /* Save current values of emin and emax. */
6121 emin
= mpfr_get_emin ();
6122 emax
= mpfr_get_emax ();
6124 /* Set emin and emax for the current model number. */
6125 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
6126 mpfr_set_emin ((mpfr_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
6127 mpfr_get_prec(result
->value
.real
) + 1);
6128 mpfr_set_emax ((mpfr_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
6129 mpfr_check_range (result
->value
.real
, 0, MPFR_RNDU
);
6131 if (mpfr_sgn (s
->value
.real
) > 0)
6133 mpfr_nextabove (result
->value
.real
);
6134 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDU
);
6138 mpfr_nextbelow (result
->value
.real
);
6139 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDD
);
6142 mpfr_set_emin (emin
);
6143 mpfr_set_emax (emax
);
6145 /* Only NaN can occur. Do not use range check as it gives an
6146 error for denormal numbers. */
6147 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
6149 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
6150 gfc_free_expr (result
);
6151 return &gfc_bad_expr
;
6159 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
6161 gfc_expr
*itrunc
, *result
;
6164 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
6166 return &gfc_bad_expr
;
6168 if (e
->expr_type
!= EXPR_CONSTANT
)
6171 itrunc
= gfc_copy_expr (e
);
6172 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
6174 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
6175 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
6177 gfc_free_expr (itrunc
);
6179 return range_check (result
, name
);
6184 gfc_simplify_new_line (gfc_expr
*e
)
6188 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
6189 result
->value
.character
.string
[0] = '\n';
6196 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
6198 return simplify_nint ("NINT", e
, k
);
6203 gfc_simplify_idnint (gfc_expr
*e
)
6205 return simplify_nint ("IDNINT", e
, NULL
);
6208 static int norm2_scale
;
6211 norm2_add_squared (gfc_expr
*result
, gfc_expr
*e
)
6215 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6216 gcc_assert (result
->ts
.type
== BT_REAL
6217 && result
->expr_type
== EXPR_CONSTANT
);
6219 gfc_set_model_kind (result
->ts
.kind
);
6220 int index
= gfc_validate_kind (BT_REAL
, result
->ts
.kind
, false);
6222 if (mpfr_regular_p (result
->value
.real
))
6224 exp
= mpfr_get_exp (result
->value
.real
);
6225 /* If result is getting close to overflowing, scale down. */
6226 if (exp
>= gfc_real_kinds
[index
].max_exponent
- 4
6227 && norm2_scale
<= gfc_real_kinds
[index
].max_exponent
- 2)
6230 mpfr_div_ui (result
->value
.real
, result
->value
.real
, 16,
6236 if (mpfr_regular_p (e
->value
.real
))
6238 exp
= mpfr_get_exp (e
->value
.real
);
6239 /* If e**2 would overflow or close to overflowing, scale down. */
6240 if (exp
- norm2_scale
>= gfc_real_kinds
[index
].max_exponent
/ 2 - 2)
6242 int new_scale
= gfc_real_kinds
[index
].max_exponent
/ 2 + 4;
6243 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6244 mpfr_set_exp (tmp
, new_scale
- norm2_scale
);
6245 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6246 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6247 norm2_scale
= new_scale
;
6252 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6253 mpfr_set_exp (tmp
, norm2_scale
);
6254 mpfr_div (tmp
, e
->value
.real
, tmp
, GFC_RND_MODE
);
6257 mpfr_set (tmp
, e
->value
.real
, GFC_RND_MODE
);
6258 mpfr_pow_ui (tmp
, tmp
, 2, GFC_RND_MODE
);
6259 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
6268 norm2_do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
6270 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6271 gcc_assert (result
->ts
.type
== BT_REAL
6272 && result
->expr_type
== EXPR_CONSTANT
);
6275 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6276 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6277 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6281 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6282 mpfr_set_exp (tmp
, norm2_scale
);
6283 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6293 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
6298 size_zero
= gfc_is_size_zero_array (e
);
6300 if (!(is_constant_array_expr (e
) || size_zero
)
6301 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
6304 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6305 init_result_expr (result
, 0, NULL
);
6311 if (!dim
|| e
->rank
== 1)
6313 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
6315 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6316 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6320 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6321 mpfr_set_exp (tmp
, norm2_scale
);
6322 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6328 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
6337 gfc_simplify_not (gfc_expr
*e
)
6341 if (e
->expr_type
!= EXPR_CONSTANT
)
6344 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6345 mpz_com (result
->value
.integer
, e
->value
.integer
);
6347 return range_check (result
, "NOT");
6352 gfc_simplify_null (gfc_expr
*mold
)
6358 result
= gfc_copy_expr (mold
);
6359 result
->expr_type
= EXPR_NULL
;
6362 result
= gfc_get_null_expr (NULL
);
6369 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
6373 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6375 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6376 return &gfc_bad_expr
;
6379 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6382 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
6385 /* FIXME: gfc_current_locus is wrong. */
6386 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6387 &gfc_current_locus
);
6389 if (failed
&& failed
->value
.logical
!= 0)
6390 mpz_set_si (result
->value
.integer
, 0);
6392 mpz_set_si (result
->value
.integer
, 1);
6399 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
6404 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6407 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6412 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6413 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6414 return range_check (result
, "OR");
6417 return gfc_get_logical_expr (kind
, &x
->where
,
6418 x
->value
.logical
|| y
->value
.logical
);
6426 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
6429 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
6431 if (!is_constant_array_expr (array
)
6432 || !is_constant_array_expr (vector
)
6433 || (!gfc_is_constant_expr (mask
)
6434 && !is_constant_array_expr (mask
)))
6437 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
6438 if (array
->ts
.type
== BT_DERIVED
)
6439 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
6441 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
6442 vector_ctor
= vector
6443 ? gfc_constructor_first (vector
->value
.constructor
)
6446 if (mask
->expr_type
== EXPR_CONSTANT
6447 && mask
->value
.logical
)
6449 /* Copy all elements of ARRAY to RESULT. */
6452 gfc_constructor_append_expr (&result
->value
.constructor
,
6453 gfc_copy_expr (array_ctor
->expr
),
6456 array_ctor
= gfc_constructor_next (array_ctor
);
6457 vector_ctor
= gfc_constructor_next (vector_ctor
);
6460 else if (mask
->expr_type
== EXPR_ARRAY
)
6462 /* Copy only those elements of ARRAY to RESULT whose
6463 MASK equals .TRUE.. */
6464 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6467 if (mask_ctor
->expr
->value
.logical
)
6469 gfc_constructor_append_expr (&result
->value
.constructor
,
6470 gfc_copy_expr (array_ctor
->expr
),
6472 vector_ctor
= gfc_constructor_next (vector_ctor
);
6475 array_ctor
= gfc_constructor_next (array_ctor
);
6476 mask_ctor
= gfc_constructor_next (mask_ctor
);
6480 /* Append any left-over elements from VECTOR to RESULT. */
6483 gfc_constructor_append_expr (&result
->value
.constructor
,
6484 gfc_copy_expr (vector_ctor
->expr
),
6486 vector_ctor
= gfc_constructor_next (vector_ctor
);
6489 result
->shape
= gfc_get_shape (1);
6490 gfc_array_size (result
, &result
->shape
[0]);
6492 if (array
->ts
.type
== BT_CHARACTER
)
6493 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
6500 do_xor (gfc_expr
*result
, gfc_expr
*e
)
6502 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
6503 gcc_assert (result
->ts
.type
== BT_LOGICAL
6504 && result
->expr_type
== EXPR_CONSTANT
);
6506 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
6512 gfc_simplify_is_contiguous (gfc_expr
*array
)
6514 if (gfc_is_simply_contiguous (array
, false, true))
6515 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 1);
6517 if (gfc_is_not_contiguous (array
))
6518 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 0);
6525 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
6527 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
6532 gfc_simplify_popcnt (gfc_expr
*e
)
6537 if (e
->expr_type
!= EXPR_CONSTANT
)
6540 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6542 /* Convert argument to unsigned, then count the '1' bits. */
6543 mpz_init_set (x
, e
->value
.integer
);
6544 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
6545 res
= mpz_popcount (x
);
6548 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
6553 gfc_simplify_poppar (gfc_expr
*e
)
6558 if (e
->expr_type
!= EXPR_CONSTANT
)
6561 popcnt
= gfc_simplify_popcnt (e
);
6562 gcc_assert (popcnt
);
6564 bool fail
= gfc_extract_int (popcnt
, &i
);
6567 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
6572 gfc_simplify_precision (gfc_expr
*e
)
6574 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6575 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
6576 gfc_real_kinds
[i
].precision
);
6581 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6583 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
6588 gfc_simplify_radix (gfc_expr
*e
)
6591 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6596 i
= gfc_integer_kinds
[i
].radix
;
6600 i
= gfc_real_kinds
[i
].radix
;
6607 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6612 gfc_simplify_range (gfc_expr
*e
)
6615 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6620 i
= gfc_integer_kinds
[i
].range
;
6625 i
= gfc_real_kinds
[i
].range
;
6632 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6637 gfc_simplify_rank (gfc_expr
*e
)
6643 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
6648 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
6650 gfc_expr
*result
= NULL
;
6651 int kind
, tmp1
, tmp2
;
6653 /* Convert BOZ to real, and return without range checking. */
6654 if (e
->ts
.type
== BT_BOZ
)
6656 /* Determine kind for conversion of the BOZ. */
6658 gfc_extract_int (k
, &kind
);
6660 kind
= gfc_default_real_kind
;
6662 if (!gfc_boz2real (e
, kind
))
6664 result
= gfc_copy_expr (e
);
6668 if (e
->ts
.type
== BT_COMPLEX
)
6669 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
6671 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
6674 return &gfc_bad_expr
;
6676 if (e
->expr_type
!= EXPR_CONSTANT
)
6679 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
6681 tmp1
= warn_conversion
;
6682 tmp2
= warn_conversion_extra
;
6683 warn_conversion
= warn_conversion_extra
= 0;
6685 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
6687 warn_conversion
= tmp1
;
6688 warn_conversion_extra
= tmp2
;
6690 if (result
== &gfc_bad_expr
)
6691 return &gfc_bad_expr
;
6693 return range_check (result
, "REAL");
6698 gfc_simplify_realpart (gfc_expr
*e
)
6702 if (e
->expr_type
!= EXPR_CONSTANT
)
6705 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6706 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
6708 return range_check (result
, "REALPART");
6712 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
6717 bool have_length
= false;
6719 /* If NCOPIES isn't a constant, there's nothing we can do. */
6720 if (n
->expr_type
!= EXPR_CONSTANT
)
6723 /* If NCOPIES is negative, it's an error. */
6724 if (mpz_sgn (n
->value
.integer
) < 0)
6726 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6728 return &gfc_bad_expr
;
6731 /* If we don't know the character length, we can do no more. */
6732 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
6733 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6735 len
= gfc_mpz_get_hwi (e
->ts
.u
.cl
->length
->value
.integer
);
6738 else if (e
->expr_type
== EXPR_CONSTANT
6739 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
6741 len
= e
->value
.character
.length
;
6746 /* If the source length is 0, any value of NCOPIES is valid
6747 and everything behaves as if NCOPIES == 0. */
6750 mpz_set_ui (ncopies
, 0);
6752 mpz_set (ncopies
, n
->value
.integer
);
6754 /* Check that NCOPIES isn't too large. */
6760 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6762 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6766 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
6767 e
->ts
.u
.cl
->length
->value
.integer
);
6772 gfc_mpz_set_hwi (mlen
, len
);
6773 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
6777 /* The check itself. */
6778 if (mpz_cmp (ncopies
, max
) > 0)
6781 mpz_clear (ncopies
);
6782 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6784 return &gfc_bad_expr
;
6789 mpz_clear (ncopies
);
6791 /* For further simplification, we need the character string to be
6793 if (e
->expr_type
!= EXPR_CONSTANT
)
6798 (e
->ts
.u
.cl
->length
&&
6799 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
) != 0))
6801 bool fail
= gfc_extract_hwi (n
, &ncop
);
6808 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
6810 len
= e
->value
.character
.length
;
6811 gfc_charlen_t nlen
= ncop
* len
;
6813 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6814 (2**28 elements * 4 bytes (wide chars) per element) defer to
6815 runtime instead of consuming (unbounded) memory and CPU at
6817 if (nlen
> 268435456)
6819 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6820 " deferred to runtime, expect bugs", &e
->where
);
6824 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
6825 for (size_t i
= 0; i
< (size_t) ncop
; i
++)
6826 for (size_t j
= 0; j
< (size_t) len
; j
++)
6827 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
6829 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
6834 /* This one is a bear, but mainly has to do with shuffling elements. */
6837 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
6838 gfc_expr
*pad
, gfc_expr
*order_exp
)
6840 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
6841 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
6845 gfc_expr
*e
, *result
;
6846 bool zerosize
= false;
6848 /* Check that argument expression types are OK. */
6849 if (!is_constant_array_expr (source
)
6850 || !is_constant_array_expr (shape_exp
)
6851 || !is_constant_array_expr (pad
)
6852 || !is_constant_array_expr (order_exp
))
6855 if (source
->shape
== NULL
)
6858 /* Proceed with simplification, unpacking the array. */
6863 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
6868 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
6872 gfc_extract_int (e
, &shape
[rank
]);
6874 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
6875 if (shape
[rank
] < 0)
6877 gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
6878 "negative value %d for dimension %d",
6879 &shape_exp
->where
, shape
[rank
], rank
+1);
6880 return &gfc_bad_expr
;
6886 gcc_assert (rank
> 0);
6888 /* Now unpack the order array if present. */
6889 if (order_exp
== NULL
)
6891 for (i
= 0; i
< rank
; i
++)
6897 int order_size
, shape_size
;
6899 if (order_exp
->rank
!= shape_exp
->rank
)
6901 gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
6902 &order_exp
->where
, &shape_exp
->where
);
6903 return &gfc_bad_expr
;
6906 gfc_array_size (shape_exp
, &size
);
6907 shape_size
= mpz_get_ui (size
);
6909 gfc_array_size (order_exp
, &size
);
6910 order_size
= mpz_get_ui (size
);
6912 if (order_size
!= shape_size
)
6914 gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
6915 &order_exp
->where
, &shape_exp
->where
);
6916 return &gfc_bad_expr
;
6919 for (i
= 0; i
< rank
; i
++)
6921 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
6924 gfc_extract_int (e
, &order
[i
]);
6926 if (order
[i
] < 1 || order
[i
] > rank
)
6928 gfc_error ("Element with a value of %d in ORDER at %L must be "
6929 "in the range [1, ..., %d] for the RESHAPE intrinsic "
6930 "near %L", order
[i
], &order_exp
->where
, rank
,
6932 return &gfc_bad_expr
;
6936 if (x
[order
[i
]] != 0)
6938 gfc_error ("ORDER at %L is not a permutation of the size of "
6939 "SHAPE at %L", &order_exp
->where
, &shape_exp
->where
);
6940 return &gfc_bad_expr
;
6946 /* Count the elements in the source and padding arrays. */
6951 gfc_array_size (pad
, &size
);
6952 npad
= mpz_get_ui (size
);
6956 gfc_array_size (source
, &size
);
6957 nsource
= mpz_get_ui (size
);
6960 /* If it weren't for that pesky permutation we could just loop
6961 through the source and round out any shortage with pad elements.
6962 But no, someone just had to have the compiler do something the
6963 user should be doing. */
6965 for (i
= 0; i
< rank
; i
++)
6968 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6970 if (source
->ts
.type
== BT_DERIVED
)
6971 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6972 if (source
->ts
.type
== BT_CHARACTER
&& result
->ts
.u
.cl
== NULL
)
6973 result
->ts
= source
->ts
;
6974 result
->rank
= rank
;
6975 result
->shape
= gfc_get_shape (rank
);
6976 for (i
= 0; i
< rank
; i
++)
6978 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
6986 while (nsource
> 0 || npad
> 0)
6988 /* Figure out which element to extract. */
6989 mpz_set_ui (index
, 0);
6991 for (i
= rank
- 1; i
>= 0; i
--)
6993 mpz_add_ui (index
, index
, x
[order
[i
]]);
6995 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
6998 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
6999 gfc_internal_error ("Reshaped array too large at %C");
7001 j
= mpz_get_ui (index
);
7004 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
7014 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
7018 gfc_constructor_append_expr (&result
->value
.constructor
,
7019 gfc_copy_expr (e
), &e
->where
);
7021 /* Calculate the next element. */
7025 if (++x
[i
] < shape
[i
])
7043 gfc_simplify_rrspacing (gfc_expr
*x
)
7049 if (x
->expr_type
!= EXPR_CONSTANT
)
7052 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7054 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7056 /* RRSPACING(+/- 0.0) = 0.0 */
7057 if (mpfr_zero_p (x
->value
.real
))
7059 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7063 /* RRSPACING(inf) = NaN */
7064 if (mpfr_inf_p (x
->value
.real
))
7066 mpfr_set_nan (result
->value
.real
);
7070 /* RRSPACING(NaN) = same NaN */
7071 if (mpfr_nan_p (x
->value
.real
))
7073 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7077 /* | x * 2**(-e) | * 2**p. */
7078 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7079 e
= - (long int) mpfr_get_exp (x
->value
.real
);
7080 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
7082 p
= (long int) gfc_real_kinds
[i
].digits
;
7083 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
7085 return range_check (result
, "RRSPACING");
7090 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
7092 int k
, neg_flag
, power
, exp_range
;
7093 mpfr_t scale
, radix
;
7096 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7099 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7101 if (mpfr_zero_p (x
->value
.real
))
7103 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7107 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
7109 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
7111 /* This check filters out values of i that would overflow an int. */
7112 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
7113 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
7115 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
7116 gfc_free_expr (result
);
7117 return &gfc_bad_expr
;
7120 /* Compute scale = radix ** power. */
7121 power
= mpz_get_si (i
->value
.integer
);
7131 gfc_set_model_kind (x
->ts
.kind
);
7134 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
7135 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
7138 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7140 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7142 mpfr_clears (scale
, radix
, NULL
);
7144 return range_check (result
, "SCALE");
7148 /* Variants of strspn and strcspn that operate on wide characters. */
7151 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7154 const gfc_char_t
*c
;
7158 for (c
= s2
; *c
; c
++)
7172 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7175 const gfc_char_t
*c
;
7179 for (c
= s2
; *c
; c
++)
7194 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
7199 size_t indx
, len
, lenc
;
7200 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
7203 return &gfc_bad_expr
;
7205 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
7206 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
7209 if (b
!= NULL
&& b
->value
.logical
!= 0)
7214 len
= e
->value
.character
.length
;
7215 lenc
= c
->value
.character
.length
;
7217 if (len
== 0 || lenc
== 0)
7225 indx
= wide_strcspn (e
->value
.character
.string
,
7226 c
->value
.character
.string
) + 1;
7231 for (indx
= len
; indx
> 0; indx
--)
7233 for (i
= 0; i
< lenc
; i
++)
7235 if (c
->value
.character
.string
[i
]
7236 == e
->value
.character
.string
[indx
- 1])
7244 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
7245 return range_check (result
, "SCAN");
7250 gfc_simplify_selected_char_kind (gfc_expr
*e
)
7254 if (e
->expr_type
!= EXPR_CONSTANT
)
7257 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
7258 || gfc_compare_with_Cstring (e
, "default", false) == 0)
7260 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
7265 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7270 gfc_simplify_selected_int_kind (gfc_expr
*e
)
7274 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
))
7279 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
7280 if (gfc_integer_kinds
[i
].range
>= range
7281 && gfc_integer_kinds
[i
].kind
< kind
)
7282 kind
= gfc_integer_kinds
[i
].kind
;
7284 if (kind
== INT_MAX
)
7287 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7292 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
7294 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
7296 locus
*loc
= &gfc_current_locus
;
7302 if (p
->expr_type
!= EXPR_CONSTANT
7303 || gfc_extract_int (p
, &precision
))
7312 if (q
->expr_type
!= EXPR_CONSTANT
7313 || gfc_extract_int (q
, &range
))
7324 if (rdx
->expr_type
!= EXPR_CONSTANT
7325 || gfc_extract_int (rdx
, &radix
))
7333 found_precision
= 0;
7337 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
7339 if (gfc_real_kinds
[i
].precision
>= precision
)
7340 found_precision
= 1;
7342 if (gfc_real_kinds
[i
].range
>= range
)
7345 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7348 if (gfc_real_kinds
[i
].precision
>= precision
7349 && gfc_real_kinds
[i
].range
>= range
7350 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7351 && gfc_real_kinds
[i
].kind
< kind
)
7352 kind
= gfc_real_kinds
[i
].kind
;
7355 if (kind
== INT_MAX
)
7357 if (found_radix
&& found_range
&& !found_precision
)
7359 else if (found_radix
&& found_precision
&& !found_range
)
7361 else if (found_radix
&& !found_precision
&& !found_range
)
7363 else if (found_radix
)
7369 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
7374 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
7377 mpfr_t exp
, absv
, log2
, pow2
, frac
;
7380 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7383 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7385 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7386 SET_EXPONENT (NaN) = same NaN */
7387 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
7389 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7393 /* SET_EXPONENT (inf) = NaN */
7394 if (mpfr_inf_p (x
->value
.real
))
7396 mpfr_set_nan (result
->value
.real
);
7400 gfc_set_model_kind (x
->ts
.kind
);
7407 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
7408 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
7410 mpfr_trunc (log2
, log2
);
7411 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
7413 /* Old exponent value, and fraction. */
7414 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
7416 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
7419 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
7420 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
7422 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
7424 return range_check (result
, "SET_EXPONENT");
7429 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
7431 mpz_t shape
[GFC_MAX_DIMENSIONS
];
7432 gfc_expr
*result
, *e
, *f
;
7436 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
7438 if (source
->rank
== -1)
7441 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
7442 result
->shape
= gfc_get_shape (1);
7443 mpz_init (result
->shape
[0]);
7445 if (source
->rank
== 0)
7448 if (source
->expr_type
== EXPR_VARIABLE
)
7450 ar
= gfc_find_array_ref (source
);
7451 t
= gfc_array_ref_shape (ar
, shape
);
7453 else if (source
->shape
)
7456 for (n
= 0; n
< source
->rank
; n
++)
7458 mpz_init (shape
[n
]);
7459 mpz_set (shape
[n
], source
->shape
[n
]);
7465 for (n
= 0; n
< source
->rank
; n
++)
7467 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
7470 mpz_set (e
->value
.integer
, shape
[n
]);
7473 mpz_set_ui (e
->value
.integer
, n
+ 1);
7475 f
= simplify_size (source
, e
, k
);
7479 gfc_free_expr (result
);
7486 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
7488 gfc_free_expr (result
);
7490 gfc_clear_shape (shape
, source
->rank
);
7491 return &gfc_bad_expr
;
7494 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
7498 gfc_clear_shape (shape
, source
->rank
);
7500 mpz_set_si (result
->shape
[0], source
->rank
);
7507 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
7510 gfc_expr
*return_value
;
7514 /* For unary operations, the size of the result is given by the size
7515 of the operand. For binary ones, it's the size of the first operand
7516 unless it is scalar, then it is the size of the second. */
7517 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
7519 gfc_expr
* replacement
;
7520 gfc_expr
* simplified
;
7522 switch (array
->value
.op
.op
)
7524 /* Unary operations. */
7526 case INTRINSIC_UPLUS
:
7527 case INTRINSIC_UMINUS
:
7528 case INTRINSIC_PARENTHESES
:
7529 replacement
= array
->value
.op
.op1
;
7532 /* Binary operations. If any one of the operands is scalar, take
7533 the other one's size. If both of them are arrays, it does not
7534 matter -- try to find one with known shape, if possible. */
7536 if (array
->value
.op
.op1
->rank
== 0)
7537 replacement
= array
->value
.op
.op2
;
7538 else if (array
->value
.op
.op2
->rank
== 0)
7539 replacement
= array
->value
.op
.op1
;
7542 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
7546 replacement
= array
->value
.op
.op2
;
7551 /* Try to reduce it directly if possible. */
7552 simplified
= simplify_size (replacement
, dim
, k
);
7554 /* Otherwise, we build a new SIZE call. This is hopefully at least
7555 simpler than the original one. */
7558 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
7559 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
7560 GFC_ISYM_SIZE
, "size",
7562 gfc_copy_expr (replacement
),
7563 gfc_copy_expr (dim
),
7569 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
7570 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
)
7571 gfc_resolve_array_spec (ref
->u
.ar
.as
, 0);
7575 if (!gfc_array_size (array
, &size
))
7580 if (dim
->expr_type
!= EXPR_CONSTANT
)
7583 d
= mpz_get_ui (dim
->value
.integer
) - 1;
7584 if (!gfc_array_dimen_size (array
, d
, &size
))
7588 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
7589 mpz_set (return_value
->value
.integer
, size
);
7592 return return_value
;
7597 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
7600 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
7603 return &gfc_bad_expr
;
7605 result
= simplify_size (array
, dim
, k
);
7606 if (result
== NULL
|| result
== &gfc_bad_expr
)
7609 return range_check (result
, "SIZE");
7613 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
7614 multiplied by the array size. */
7617 gfc_simplify_sizeof (gfc_expr
*x
)
7619 gfc_expr
*result
= NULL
;
7623 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7626 if (x
->ts
.type
== BT_CHARACTER
7627 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7628 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7631 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
7632 && !gfc_array_size (x
, &array_size
))
7635 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
7637 gfc_target_expr_size (x
, &res_size
);
7638 mpz_set_si (result
->value
.integer
, res_size
);
7644 /* STORAGE_SIZE returns the size in bits of a single array element. */
7647 gfc_simplify_storage_size (gfc_expr
*x
,
7650 gfc_expr
*result
= NULL
;
7654 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7657 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
7658 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7659 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7662 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
7664 return &gfc_bad_expr
;
7666 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
7668 gfc_element_size (x
, &siz
);
7669 mpz_set_si (result
->value
.integer
, siz
);
7670 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
7672 return range_check (result
, "STORAGE_SIZE");
7677 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
7681 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
7684 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7689 mpz_abs (result
->value
.integer
, x
->value
.integer
);
7690 if (mpz_sgn (y
->value
.integer
) < 0)
7691 mpz_neg (result
->value
.integer
, result
->value
.integer
);
7696 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
7699 mpfr_setsign (result
->value
.real
, x
->value
.real
,
7700 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
7704 gfc_internal_error ("Bad type in gfc_simplify_sign");
7712 gfc_simplify_sin (gfc_expr
*x
)
7716 if (x
->expr_type
!= EXPR_CONSTANT
)
7719 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7724 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7728 gfc_set_model (x
->value
.real
);
7729 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7733 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
7736 return range_check (result
, "SIN");
7741 gfc_simplify_sinh (gfc_expr
*x
)
7745 if (x
->expr_type
!= EXPR_CONSTANT
)
7748 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7753 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7757 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7764 return range_check (result
, "SINH");
7768 /* The argument is always a double precision real that is converted to
7769 single precision. TODO: Rounding! */
7772 gfc_simplify_sngl (gfc_expr
*a
)
7777 if (a
->expr_type
!= EXPR_CONSTANT
)
7780 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
7782 tmp1
= warn_conversion
;
7783 tmp2
= warn_conversion_extra
;
7784 warn_conversion
= warn_conversion_extra
= 0;
7786 result
= gfc_real2real (a
, gfc_default_real_kind
);
7788 warn_conversion
= tmp1
;
7789 warn_conversion_extra
= tmp2
;
7791 return range_check (result
, "SNGL");
7796 gfc_simplify_spacing (gfc_expr
*x
)
7802 if (x
->expr_type
!= EXPR_CONSTANT
)
7805 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7806 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7808 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
7809 if (mpfr_zero_p (x
->value
.real
))
7811 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
7815 /* SPACING(inf) = NaN */
7816 if (mpfr_inf_p (x
->value
.real
))
7818 mpfr_set_nan (result
->value
.real
);
7822 /* SPACING(NaN) = same NaN */
7823 if (mpfr_nan_p (x
->value
.real
))
7825 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7829 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
7830 are the radix, exponent of x, and precision. This excludes the
7831 possibility of subnormal numbers. Fortran 2003 states the result is
7832 b**max(e - p, emin - 1). */
7834 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
7835 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
7836 en
= en
> ep
? en
: ep
;
7838 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
7839 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
7841 return range_check (result
, "SPACING");
7846 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
7848 gfc_expr
*result
= NULL
;
7849 int nelem
, i
, j
, dim
, ncopies
;
7852 if ((!gfc_is_constant_expr (source
)
7853 && !is_constant_array_expr (source
))
7854 || !gfc_is_constant_expr (dim_expr
)
7855 || !gfc_is_constant_expr (ncopies_expr
))
7858 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
7859 gfc_extract_int (dim_expr
, &dim
);
7860 dim
-= 1; /* zero-base DIM */
7862 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
7863 gfc_extract_int (ncopies_expr
, &ncopies
);
7864 ncopies
= MAX (ncopies
, 0);
7866 /* Do not allow the array size to exceed the limit for an array
7868 if (source
->expr_type
== EXPR_ARRAY
)
7870 if (!gfc_array_size (source
, &size
))
7871 gfc_internal_error ("Failure getting length of a constant array.");
7874 mpz_init_set_ui (size
, 1);
7876 nelem
= mpz_get_si (size
) * ncopies
;
7877 if (nelem
> flag_max_array_constructor
)
7879 if (gfc_init_expr_flag
)
7881 gfc_error ("The number of elements (%d) in the array constructor "
7882 "at %L requires an increase of the allowed %d upper "
7883 "limit. See %<-fmax-array-constructor%> option.",
7884 nelem
, &source
->where
, flag_max_array_constructor
);
7885 return &gfc_bad_expr
;
7891 if (source
->expr_type
== EXPR_CONSTANT
7892 || source
->expr_type
== EXPR_STRUCTURE
)
7894 gcc_assert (dim
== 0);
7896 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7898 if (source
->ts
.type
== BT_DERIVED
)
7899 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7901 result
->shape
= gfc_get_shape (result
->rank
);
7902 mpz_init_set_si (result
->shape
[0], ncopies
);
7904 for (i
= 0; i
< ncopies
; ++i
)
7905 gfc_constructor_append_expr (&result
->value
.constructor
,
7906 gfc_copy_expr (source
), NULL
);
7908 else if (source
->expr_type
== EXPR_ARRAY
)
7910 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
7911 gfc_constructor
*source_ctor
;
7913 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
7914 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
7916 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7918 if (source
->ts
.type
== BT_DERIVED
)
7919 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7920 result
->rank
= source
->rank
+ 1;
7921 result
->shape
= gfc_get_shape (result
->rank
);
7923 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
7926 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
7928 mpz_init_set_si (result
->shape
[i
], ncopies
);
7930 extent
[i
] = mpz_get_si (result
->shape
[i
]);
7931 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
7935 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
7936 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
7938 for (i
= 0; i
< ncopies
; ++i
)
7939 gfc_constructor_insert_expr (&result
->value
.constructor
,
7940 gfc_copy_expr (source_ctor
->expr
),
7941 NULL
, offset
+ i
* rstride
[dim
]);
7943 offset
+= (dim
== 0 ? ncopies
: 1);
7948 gfc_error ("Simplification of SPREAD at %C not yet implemented");
7949 return &gfc_bad_expr
;
7952 if (source
->ts
.type
== BT_CHARACTER
)
7953 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
7960 gfc_simplify_sqrt (gfc_expr
*e
)
7962 gfc_expr
*result
= NULL
;
7964 if (e
->expr_type
!= EXPR_CONSTANT
)
7970 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
7972 gfc_error ("Argument of SQRT at %L has a negative value",
7974 return &gfc_bad_expr
;
7976 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7977 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
7981 gfc_set_model (e
->value
.real
);
7983 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7984 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
7988 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
7991 return range_check (result
, "SQRT");
7996 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
7998 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
8002 /* Simplify COTAN(X) where X has the unit of radian. */
8005 gfc_simplify_cotan (gfc_expr
*x
)
8010 if (x
->expr_type
!= EXPR_CONSTANT
)
8013 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8018 mpfr_cot (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8022 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
8023 val
= &result
->value
.complex;
8024 mpc_init2 (swp
, mpfr_get_default_prec ());
8025 mpc_sin_cos (*val
, swp
, x
->value
.complex, GFC_MPC_RND_MODE
,
8027 mpc_div (*val
, swp
, *val
, GFC_MPC_RND_MODE
);
8035 return range_check (result
, "COTAN");
8040 gfc_simplify_tan (gfc_expr
*x
)
8044 if (x
->expr_type
!= EXPR_CONSTANT
)
8047 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8052 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8056 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8063 return range_check (result
, "TAN");
8068 gfc_simplify_tanh (gfc_expr
*x
)
8072 if (x
->expr_type
!= EXPR_CONSTANT
)
8075 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8080 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8084 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8091 return range_check (result
, "TANH");
8096 gfc_simplify_tiny (gfc_expr
*e
)
8101 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
8103 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
8104 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
8111 gfc_simplify_trailz (gfc_expr
*e
)
8113 unsigned long tz
, bs
;
8116 if (e
->expr_type
!= EXPR_CONSTANT
)
8119 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
8120 bs
= gfc_integer_kinds
[i
].bit_size
;
8121 tz
= mpz_scan1 (e
->value
.integer
, 0);
8123 return gfc_get_int_expr (gfc_default_integer_kind
,
8124 &e
->where
, MIN (tz
, bs
));
8129 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
8132 gfc_expr
*mold_element
;
8137 unsigned char *buffer
;
8138 size_t result_length
;
8140 if (!gfc_is_constant_expr (source
) || !gfc_is_constant_expr (size
))
8143 if (!gfc_resolve_expr (mold
))
8145 if (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
8148 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
8149 &result_size
, &result_length
))
8152 /* Calculate the size of the source. */
8153 if (source
->expr_type
== EXPR_ARRAY
&& !gfc_array_size (source
, &tmp
))
8154 gfc_internal_error ("Failure getting length of a constant array.");
8156 /* Create an empty new expression with the appropriate characteristics. */
8157 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
8159 result
->ts
= mold
->ts
;
8161 mold_element
= (mold
->expr_type
== EXPR_ARRAY
&& mold
->value
.constructor
)
8162 ? gfc_constructor_first (mold
->value
.constructor
)->expr
8165 /* Set result character length, if needed. Note that this needs to be
8166 set even for array expressions, in order to pass this information into
8167 gfc_target_interpret_expr. */
8168 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
8170 result
->value
.character
.length
= mold_element
->value
.character
.length
;
8172 /* Let the typespec of the result inherit the string length.
8173 This is crucial if a resulting array has size zero. */
8174 if (mold_element
->ts
.u
.cl
->length
)
8175 result
->ts
.u
.cl
->length
= gfc_copy_expr (mold_element
->ts
.u
.cl
->length
);
8177 result
->ts
.u
.cl
->length
=
8178 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8179 mold_element
->value
.character
.length
);
8182 /* Set the number of elements in the result, and determine its size. */
8184 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
8186 result
->expr_type
= EXPR_ARRAY
;
8188 result
->shape
= gfc_get_shape (1);
8189 mpz_init_set_ui (result
->shape
[0], result_length
);
8194 /* Allocate the buffer to store the binary version of the source. */
8195 buffer_size
= MAX (source_size
, result_size
);
8196 buffer
= (unsigned char*)alloca (buffer_size
);
8197 memset (buffer
, 0, buffer_size
);
8199 /* Now write source to the buffer. */
8200 gfc_target_encode_expr (source
, buffer
, buffer_size
);
8202 /* And read the buffer back into the new expression. */
8203 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
8210 gfc_simplify_transpose (gfc_expr
*matrix
)
8212 int row
, matrix_rows
, col
, matrix_cols
;
8215 if (!is_constant_array_expr (matrix
))
8218 gcc_assert (matrix
->rank
== 2);
8220 if (matrix
->shape
== NULL
)
8223 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
8226 result
->shape
= gfc_get_shape (result
->rank
);
8227 mpz_init_set (result
->shape
[0], matrix
->shape
[1]);
8228 mpz_init_set (result
->shape
[1], matrix
->shape
[0]);
8230 if (matrix
->ts
.type
== BT_CHARACTER
)
8231 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
8232 else if (matrix
->ts
.type
== BT_DERIVED
)
8233 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
8235 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
8236 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
8237 for (row
= 0; row
< matrix_rows
; ++row
)
8238 for (col
= 0; col
< matrix_cols
; ++col
)
8240 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
8241 col
* matrix_rows
+ row
);
8242 gfc_constructor_insert_expr (&result
->value
.constructor
,
8243 gfc_copy_expr (e
), &matrix
->where
,
8244 row
* matrix_cols
+ col
);
8252 gfc_simplify_trim (gfc_expr
*e
)
8255 int count
, i
, len
, lentrim
;
8257 if (e
->expr_type
!= EXPR_CONSTANT
)
8260 len
= e
->value
.character
.length
;
8261 for (count
= 0, i
= 1; i
<= len
; ++i
)
8263 if (e
->value
.character
.string
[len
- i
] == ' ')
8269 lentrim
= len
- count
;
8271 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
8272 for (i
= 0; i
< lentrim
; i
++)
8273 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
8280 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
8285 gfc_constructor
*sub_cons
;
8289 if (!is_constant_array_expr (sub
))
8292 /* Follow any component references. */
8293 as
= coarray
->symtree
->n
.sym
->as
;
8294 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
8295 if (ref
->type
== REF_COMPONENT
)
8298 if (as
->type
== AS_DEFERRED
)
8301 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
8302 the cosubscript addresses the first image. */
8304 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
8307 for (d
= 1; d
<= as
->corank
; d
++)
8312 gcc_assert (sub_cons
!= NULL
);
8314 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
8316 if (ca_bound
== NULL
)
8319 if (ca_bound
== &gfc_bad_expr
)
8322 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
8326 gfc_free_expr (ca_bound
);
8327 sub_cons
= gfc_constructor_next (sub_cons
);
8331 first_image
= false;
8335 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8336 "SUB has %ld and COARRAY lower bound is %ld)",
8338 mpz_get_si (sub_cons
->expr
->value
.integer
),
8339 mpz_get_si (ca_bound
->value
.integer
));
8340 gfc_free_expr (ca_bound
);
8341 return &gfc_bad_expr
;
8344 gfc_free_expr (ca_bound
);
8346 /* Check whether upperbound is valid for the multi-images case. */
8349 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
8351 if (ca_bound
== &gfc_bad_expr
)
8354 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
8355 && mpz_cmp (ca_bound
->value
.integer
,
8356 sub_cons
->expr
->value
.integer
) < 0)
8358 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8359 "SUB has %ld and COARRAY upper bound is %ld)",
8361 mpz_get_si (sub_cons
->expr
->value
.integer
),
8362 mpz_get_si (ca_bound
->value
.integer
));
8363 gfc_free_expr (ca_bound
);
8364 return &gfc_bad_expr
;
8368 gfc_free_expr (ca_bound
);
8371 sub_cons
= gfc_constructor_next (sub_cons
);
8374 gcc_assert (sub_cons
== NULL
);
8376 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
8379 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8380 &gfc_current_locus
);
8382 mpz_set_si (result
->value
.integer
, 1);
8384 mpz_set_si (result
->value
.integer
, 0);
8390 gfc_simplify_image_status (gfc_expr
*image
, gfc_expr
*team ATTRIBUTE_UNUSED
)
8392 if (flag_coarray
== GFC_FCOARRAY_NONE
)
8394 gfc_current_locus
= *gfc_current_intrinsic_where
;
8395 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
8396 return &gfc_bad_expr
;
8399 /* Simplification is possible for fcoarray = single only. For all other modes
8400 the result depends on runtime conditions. */
8401 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8404 if (gfc_is_constant_expr (image
))
8407 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8409 if (mpz_get_si (image
->value
.integer
) == 1)
8410 mpz_set_si (result
->value
.integer
, 0);
8412 mpz_set_si (result
->value
.integer
, GFC_STAT_STOPPED_IMAGE
);
8421 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
8422 gfc_expr
*distance ATTRIBUTE_UNUSED
)
8424 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8427 /* If no coarray argument has been passed or when the first argument
8428 is actually a distance argument. */
8429 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
8432 /* FIXME: gfc_current_locus is wrong. */
8433 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8434 &gfc_current_locus
);
8435 mpz_set_si (result
->value
.integer
, 1);
8439 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
8440 return simplify_cobound (coarray
, dim
, NULL
, 0);
8445 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8447 return simplify_bound (array
, dim
, kind
, 1);
8451 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8453 return simplify_cobound (array
, dim
, kind
, 1);
8458 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
8460 gfc_expr
*result
, *e
;
8461 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
8463 if (!is_constant_array_expr (vector
)
8464 || !is_constant_array_expr (mask
)
8465 || (!gfc_is_constant_expr (field
)
8466 && !is_constant_array_expr (field
)))
8469 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
8471 if (vector
->ts
.type
== BT_DERIVED
)
8472 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
8473 result
->rank
= mask
->rank
;
8474 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
8476 if (vector
->ts
.type
== BT_CHARACTER
)
8477 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
8479 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
8480 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
8482 = field
->expr_type
== EXPR_ARRAY
8483 ? gfc_constructor_first (field
->value
.constructor
)
8488 if (mask_ctor
->expr
->value
.logical
)
8490 gcc_assert (vector_ctor
);
8491 e
= gfc_copy_expr (vector_ctor
->expr
);
8492 vector_ctor
= gfc_constructor_next (vector_ctor
);
8494 else if (field
->expr_type
== EXPR_ARRAY
)
8495 e
= gfc_copy_expr (field_ctor
->expr
);
8497 e
= gfc_copy_expr (field
);
8499 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
8501 mask_ctor
= gfc_constructor_next (mask_ctor
);
8502 field_ctor
= gfc_constructor_next (field_ctor
);
8510 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
8514 size_t index
, len
, lenset
;
8516 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
8519 return &gfc_bad_expr
;
8521 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
8522 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
8525 if (b
!= NULL
&& b
->value
.logical
!= 0)
8530 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
8532 len
= s
->value
.character
.length
;
8533 lenset
= set
->value
.character
.length
;
8537 mpz_set_ui (result
->value
.integer
, 0);
8545 mpz_set_ui (result
->value
.integer
, 1);
8549 index
= wide_strspn (s
->value
.character
.string
,
8550 set
->value
.character
.string
) + 1;
8559 mpz_set_ui (result
->value
.integer
, len
);
8562 for (index
= len
; index
> 0; index
--)
8564 for (i
= 0; i
< lenset
; i
++)
8566 if (s
->value
.character
.string
[index
- 1]
8567 == set
->value
.character
.string
[i
])
8575 mpz_set_ui (result
->value
.integer
, index
);
8581 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
8586 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
8589 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
8594 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
8595 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
8596 return range_check (result
, "XOR");
8599 return gfc_get_logical_expr (kind
, &x
->where
,
8600 (x
->value
.logical
&& !y
->value
.logical
)
8601 || (!x
->value
.logical
&& y
->value
.logical
));
8609 /****************** Constant simplification *****************/
8611 /* Master function to convert one constant to another. While this is
8612 used as a simplification function, it requires the destination type
8613 and kind information which is supplied by a special case in
8617 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
8619 gfc_expr
*result
, *(*f
) (gfc_expr
*, int);
8620 gfc_constructor
*c
, *t
;
8634 f
= gfc_int2complex
;
8654 f
= gfc_real2complex
;
8665 f
= gfc_complex2int
;
8668 f
= gfc_complex2real
;
8671 f
= gfc_complex2complex
;
8697 f
= gfc_hollerith2int
;
8701 f
= gfc_hollerith2real
;
8705 f
= gfc_hollerith2complex
;
8709 f
= gfc_hollerith2character
;
8713 f
= gfc_hollerith2logical
;
8725 f
= gfc_character2int
;
8729 f
= gfc_character2real
;
8733 f
= gfc_character2complex
;
8737 f
= gfc_character2character
;
8741 f
= gfc_character2logical
;
8751 return &gfc_bad_expr
;
8756 switch (e
->expr_type
)
8759 result
= f (e
, kind
);
8761 return &gfc_bad_expr
;
8765 if (!gfc_is_constant_expr (e
))
8768 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8769 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8770 result
->rank
= e
->rank
;
8772 for (c
= gfc_constructor_first (e
->value
.constructor
);
8773 c
; c
= gfc_constructor_next (c
))
8776 if (c
->iterator
== NULL
)
8778 if (c
->expr
->expr_type
== EXPR_ARRAY
)
8779 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8780 else if (c
->expr
->expr_type
== EXPR_OP
)
8782 if (!gfc_simplify_expr (c
->expr
, 1))
8783 return &gfc_bad_expr
;
8784 tmp
= f (c
->expr
, kind
);
8787 tmp
= f (c
->expr
, kind
);
8790 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8792 if (tmp
== NULL
|| tmp
== &gfc_bad_expr
)
8794 gfc_free_expr (result
);
8798 t
= gfc_constructor_append_expr (&result
->value
.constructor
,
8801 t
->iterator
= gfc_copy_iterator (c
->iterator
);
8814 /* Function for converting character constants. */
8816 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
8821 if (!gfc_is_constant_expr (e
))
8824 if (e
->expr_type
== EXPR_CONSTANT
)
8826 /* Simple case of a scalar. */
8827 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
8829 return &gfc_bad_expr
;
8831 result
->value
.character
.length
= e
->value
.character
.length
;
8832 result
->value
.character
.string
8833 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
8834 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
8835 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
8837 /* Check we only have values representable in the destination kind. */
8838 for (i
= 0; i
< result
->value
.character
.length
; i
++)
8839 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
8842 gfc_error ("Character %qs in string at %L cannot be converted "
8843 "into character kind %d",
8844 gfc_print_wide_char (result
->value
.character
.string
[i
]),
8846 gfc_free_expr (result
);
8847 return &gfc_bad_expr
;
8852 else if (e
->expr_type
== EXPR_ARRAY
)
8854 /* For an array constructor, we convert each constructor element. */
8857 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8858 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8859 result
->rank
= e
->rank
;
8860 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
8862 for (c
= gfc_constructor_first (e
->value
.constructor
);
8863 c
; c
= gfc_constructor_next (c
))
8865 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
8866 if (tmp
== &gfc_bad_expr
)
8868 gfc_free_expr (result
);
8869 return &gfc_bad_expr
;
8874 gfc_free_expr (result
);
8878 gfc_constructor_append_expr (&result
->value
.constructor
,
8890 gfc_simplify_compiler_options (void)
8895 str
= gfc_get_option_string ();
8896 result
= gfc_get_character_expr (gfc_default_character_kind
,
8897 &gfc_current_locus
, str
, strlen (str
));
8904 gfc_simplify_compiler_version (void)
8909 len
= strlen ("GCC version ") + strlen (version_string
);
8910 buffer
= XALLOCAVEC (char, len
+ 1);
8911 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
8912 return gfc_get_character_expr (gfc_default_character_kind
,
8913 &gfc_current_locus
, buffer
, len
);
8916 /* Simplification routines for intrinsics of IEEE modules. */
8919 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
8921 gfc_actual_arglist
*arg
;
8922 gfc_expr
*p
= NULL
, *q
= NULL
, *rdx
= NULL
;
8924 arg
= expr
->value
.function
.actual
;
8928 q
= arg
->next
->expr
;
8929 if (arg
->next
->next
)
8930 rdx
= arg
->next
->next
->expr
;
8933 /* Currently, if IEEE is supported and this module is built, it means
8934 all our floating-point types conform to IEEE. Hence, we simply handle
8935 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
8936 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
8940 simplify_ieee_support (gfc_expr
*expr
)
8942 /* We consider that if the IEEE modules are loaded, we have full support
8943 for flags, halting and rounding, which are the three functions
8944 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
8945 expressions. One day, we will need libgfortran to detect support and
8946 communicate it back to us, allowing for partial support. */
8948 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
8953 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
8955 int n
= strlen(name
);
8957 if (!strncmp(sym
->name
, name
, n
))
8960 /* If a generic was used and renamed, we need more work to find out.
8961 Compare the specific name. */
8962 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
8969 gfc_simplify_ieee_functions (gfc_expr
*expr
)
8971 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
8973 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
8974 return simplify_ieee_selected_real_kind (expr
);
8975 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
8976 || matches_ieee_function_name(sym
, "ieee_support_halting")
8977 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
8978 return simplify_ieee_support (expr
);